haskell/Core.hs

   1 module Core
   2 ( ns )
   3 where
   4
   5 import System.IO (hFlush, stdout)
   6 import Control.Monad.Except (throwError)
   7 import Control.Monad.Trans (liftIO)
   8 import qualified Data.Map as Map
   9 import Data.Foldable (foldlM)
  10 import Data.Time.Clock.POSIX (getPOSIXTime)
  11 import Data.IORef (newIORef, readIORef, writeIORef)
  12
  13 import Readline (readline)
  14 import Reader (read_str)
  15 import Types
  16 import Printer (_pr_list)
  17
  18 -- General functions
  19
  20 equal_Q :: Fn
  21 equal_Q [a, b] = return $ MalBoolean $ a == b
  22 equal_Q _ = throwStr "illegal arguments to ="
  23
  24 -- Error/Exception functions
  25
  26 throw :: Fn
  27 throw [mv] = throwError mv
  28 throw _ = throwStr "illegal arguments to throw"
  29
  30 -- Unary predicates
  31
  32 pred1 :: (MalVal -> Bool) -> Fn
  33 pred1 hostPred [x] = return $ MalBoolean $ hostPred x
  34 pred1 _ _ = throwStr "illegal call to unary predicate"
  35
  36 atom_Q :: MalVal -> Bool
  37 atom_Q (MalAtom _ _) = True
  38 atom_Q _             = False
  39
  40 false_Q :: MalVal -> Bool
  41 false_Q (MalBoolean False) = True
  42 false_Q _                  = False
  43
  44 fn_Q :: MalVal -> Bool
  45 fn_Q (MalFunction {macro=False}) = True
  46 fn_Q _                           = False
  47
  48 macro_Q :: MalVal -> Bool
  49 macro_Q (MalFunction {macro=True}) = True
  50 macro_Q _                          = False
  51
  52 map_Q :: MalVal -> Bool
  53 map_Q (MalHashMap _ _) = True
  54 map_Q _                = False
  55
  56 keyword_Q :: MalVal -> Bool
  57 keyword_Q (MalString (c : _)) = c == keywordMagic
  58 keyword_Q _                   = False
  59
  60 list_Q :: MalVal -> Bool
  61 list_Q (MalSeq _ (Vect False) _) = True
  62 list_Q _                         = False
  63
  64 nil_Q :: MalVal -> Bool
  65 nil_Q Nil = True
  66 nil_Q _   = False
  67
  68 number_Q :: MalVal -> Bool
  69 number_Q (MalNumber _) = True
  70 number_Q _             = False
  71
  72 string_Q :: MalVal -> Bool
  73 string_Q (MalString "")      = True
  74 string_Q (MalString (c : _)) = c /= keywordMagic
  75 string_Q _                   = False
  76
  77 symbol_Q :: MalVal -> Bool
  78 symbol_Q (MalSymbol _) = True
  79 symbol_Q _             = False
  80
  81 true_Q :: MalVal -> Bool
  82 true_Q (MalBoolean True) = True
  83 true_Q _                 = False
  84
  85 vector_Q :: MalVal -> Bool
  86 vector_Q (MalSeq _ (Vect True) _) = True
  87 vector_Q _                        = False
  88
  89 -- Scalar functions
  90
  91 symbol :: Fn
  92 symbol [MalString s] = return $ MalSymbol s
  93 symbol _ = throwStr "symbol called with non-string"
  94
  95 keyword :: Fn
  96 keyword [kw@(MalString (c : _))] | c == keywordMagic = return kw
  97 keyword [MalString s] = return $ MalString (keywordMagic : s)
  98 keyword _ = throwStr "keyword called with non-string"
  99
 100 -- String functions
 101
 102 pr_str :: Fn
 103 pr_str args = liftIO $ MalString <$> _pr_list True " " args
 104
 105 str :: Fn
 106 str args = liftIO $ MalString <$> _pr_list False "" args
 107
 108 prn :: Fn
 109 prn args = liftIO $ do
 110     putStrLn =<< _pr_list True " " args
 111     hFlush stdout
 112     return Nil
 113
 114 println :: Fn
 115 println args = liftIO $ do
 116     putStrLn =<< _pr_list False " " args
 117     hFlush stdout
 118     return Nil
 119
 120 slurp :: Fn
 121 slurp [MalString path] = MalString <$> liftIO (readFile path)
 122 slurp _ = throwStr "invalid arguments to slurp"
 123
 124 do_readline :: Fn
 125 do_readline [MalString prompt] = do
 126     maybeLine <- liftIO $ readline prompt
 127     case maybeLine of
 128         Nothing -> throwStr "readline failed"
 129         Just line -> return $ MalString line
 130 do_readline _ = throwStr "invalid arguments to readline"
 131
 132 read_string :: Fn
 133 read_string [MalString s] = read_str s
 134 read_string _ = throwStr "invalid read-string"
 135
 136 -- Numeric functions
 137
 138 num_op :: (Int -> Int -> Int) -> Fn
 139 num_op op [MalNumber a, MalNumber b] = return $ MalNumber $ op a b
 140 num_op _ _ = throwStr "illegal arguments to number operation"
 141
 142 cmp_op :: (Int -> Int -> Bool) -> Fn
 143 cmp_op op [MalNumber a, MalNumber b] = return $ MalBoolean $ op a b
 144 cmp_op _ _ = throwStr "illegal arguments to comparison operation"
 145
 146 time_ms :: Fn
 147 time_ms [] = MalNumber . round . (* 1000) <$> liftIO getPOSIXTime
 148 time_ms _ = throwStr "invalid time-ms"
 149
 150
 151 -- List functions
 152
 153 list :: Fn
 154 list = return . toList
 155
 156 -- Vector functions
 157
 158 vector :: Fn
 159 vector = return . MalSeq (MetaData Nil) (Vect True)
 160
 161 -- Hash Map functions
 162
 163 hash_map :: Fn
 164 hash_map kvs =
 165     case keyValuePairs kvs of
 166         Just pairs -> return $ MalHashMap (MetaData Nil) $ Map.fromList pairs
 167         Nothing    -> throwStr "invalid call to hash-map"
 168
 169 assoc :: Fn
 170 assoc (MalHashMap _ hm : kvs) =
 171     case keyValuePairs kvs of
 172         Just pairs -> return $ MalHashMap (MetaData Nil) $ Map.union (Map.fromList pairs) hm
 173         Nothing    -> throwStr "invalid assoc"
 174 assoc _ = throwStr "invalid call to assoc"
 175
 176 remover :: Map.Map String MalVal -> MalVal -> IOThrows (Map.Map String MalVal)
 177 remover m (MalString k) = return $ Map.delete k m
 178 remover _ _ = throwStr "invalid dissoc"
 179
 180 dissoc :: Fn
 181 dissoc (MalHashMap _ hm : ks) = MalHashMap (MetaData Nil) <$> foldlM remover hm ks
 182 dissoc _ = throwStr "invalid call to dissoc"
 183
 184 get :: Fn
 185 get [MalHashMap _ hm, MalString k] =
 186     case Map.lookup k hm of
 187         Just mv -> return mv
 188         Nothing -> return Nil
 189 get [Nil, MalString _] = return Nil
 190 get _ = throwStr "invalid call to get"
 191
 192 contains_Q :: Fn
 193 contains_Q [MalHashMap _ hm, MalString k] = return $ MalBoolean $ Map.member k hm
 194 contains_Q [Nil,             MalString _] = return $ MalBoolean False
 195 contains_Q _ = throwStr "invalid call to contains?"
 196
 197 keys :: Fn
 198 keys [MalHashMap _ hm] = return $ toList $ MalString <$> Map.keys hm
 199 keys _ = throwStr "invalid call to keys"
 200
 201 vals :: Fn
 202 vals [MalHashMap _ hm] = return $ toList $ Map.elems hm
 203 vals _ = throwStr "invalid call to vals"
 204
 205 -- Sequence functions
 206
 207 sequential_Q :: MalVal -> Bool
 208 sequential_Q (MalSeq _ _ _) = True
 209 sequential_Q _              = False
 210
 211 cons :: Fn
 212 cons [x, Nil           ] = return $ toList [x]
 213 cons [x, MalSeq _ _ lst] = return $ toList (x : lst)
 214 cons _ = throwStr "illegal call to cons"
 215
 216 unwrapSeq :: MalVal -> IOThrows [MalVal]
 217 unwrapSeq (MalSeq _ _ xs) = return xs
 218 unwrapSeq _ = throwStr "invalid concat"
 219
 220 do_concat :: Fn
 221 do_concat args = toList . concat <$> mapM unwrapSeq args
 222
 223 nth :: Fn
 224 nth [MalSeq _ _ lst, MalNumber idx] =
 225     case drop idx lst of
 226         x : _ -> return x
 227         []    -> throwStr "nth: index out of range"
 228 --  See https://wiki.haskell.org/Avoiding_partial_functions
 229 nth _ = throwStr "invalid call to nth"
 230
 231 first :: Fn
 232 first [Nil               ] = return Nil
 233 first [MalSeq _ _ []     ] = return Nil
 234 first [MalSeq _ _ (x : _)] = return x
 235 first _ = throwStr "illegal call to first"
 236
 237 rest :: Fn
 238 rest [Nil                ] = return $ toList []
 239 rest [MalSeq _ _ []      ] = return $ toList []
 240 rest [MalSeq _ _ (_ : xs)] = return $ toList xs
 241 rest _ = throwStr "illegal call to rest"
 242
 243 empty_Q :: MalVal -> Bool
 244 empty_Q Nil             = True
 245 empty_Q (MalSeq _ _ []) = True
 246 empty_Q _               = False
 247
 248 count :: Fn
 249 count [Nil           ] = return $ MalNumber 0
 250 count [MalSeq _ _ lst] = return $ MalNumber $ length lst
 251 count _ = throwStr "non-sequence passed to count"
 252
 253 concatLast :: [MalVal] -> IOThrows [MalVal]
 254 concatLast [MalSeq _ _ lst] = return lst
 255 concatLast (a : as)         = (a :) <$> concatLast as
 256 concatLast _ = throwStr "last argument of apply must be a sequence"
 257
 258 apply :: Fn
 259 apply (MalFunction {fn=f} : xs) = f =<< concatLast xs
 260 apply _ = throwStr "Illegal call to apply"
 261
 262 do_map :: Fn
 263 do_map [MalFunction {fn=f}, MalSeq _ _ args] = toList <$> mapM (\x -> f [x]) args
 264 do_map _ = throwStr "Illegal call to map"
 265
 266 conj :: Fn
 267 conj (MalSeq _ (Vect False) lst : args) = return $ toList $ reverse args ++ lst
 268 conj (MalSeq _ (Vect True)  lst : args) = return $ MalSeq (MetaData Nil) (Vect True) $ lst ++ args
 269 conj _ = throwStr "illegal arguments to conj"
 270
 271 do_seq :: Fn
 272 do_seq [Nil            ] = return Nil
 273 do_seq [MalSeq _ _ []  ] = return Nil
 274 do_seq [MalSeq _ _ lst ] = return $ toList lst
 275 do_seq [MalString ""   ] = return Nil
 276 do_seq [MalString s    ] = return $ toList $ MalString <$> pure <$> s
 277 do_seq _ = throwStr "seq: called on non-sequence"
 278
 279 -- Metadata functions
 280
 281 with_meta :: Fn
 282 with_meta [MalSeq _ v x,       m] = return $ MalSeq (MetaData m) v x
 283 with_meta [MalHashMap _ x,     m] = return $ MalHashMap (MetaData m) x
 284 with_meta [MalAtom _ x,        m] = return $ MalAtom (MetaData m) x
 285 with_meta [f@(MalFunction {}), m] = return $ f {meta=m}
 286 with_meta _ = throwStr "invalid with-meta call"
 287
 288 do_meta :: Fn
 289 do_meta [MalSeq (MetaData m) _ _  ] = return m
 290 do_meta [MalHashMap (MetaData m) _] = return m
 291 do_meta [MalAtom (MetaData m) _   ] = return m
 292 do_meta [MalFunction {meta=m}     ] = return m
 293 do_meta _ = throwStr "invalid meta call"
 294
 295 -- Atom functions
 296
 297 atom :: Fn
 298 atom [val] = MalAtom (MetaData Nil) <$> liftIO (newIORef val)
 299 atom _ = throwStr "invalid atom call"
 300
 301 deref :: Fn
 302 deref [MalAtom _ ref] = liftIO $ readIORef ref
 303 deref _ = throwStr "invalid deref call"
 304
 305 reset_BANG :: Fn
 306 reset_BANG [MalAtom _ ref, val] = do
 307     liftIO $ writeIORef ref $ val
 308     return val
 309 reset_BANG _ = throwStr "invalid reset!"
 310
 311 swap_BANG :: Fn
 312 swap_BANG (MalAtom _ ref : MalFunction {fn=f} : args) = do
 313     val <- liftIO $ readIORef ref
 314     new_val <- f (val : args)
 315     liftIO $ writeIORef ref new_val
 316     return new_val
 317 swap_BANG _ = throwStr "Illegal swap!"
 318
 319 ns :: [(String, Fn)]
 320 ns = [
 321     ("=",           equal_Q),
 322     ("throw",       throw),
 323     ("nil?",        pred1 nil_Q),
 324     ("true?",       pred1 true_Q),
 325     ("false?",      pred1 false_Q),
 326     ("string?",     pred1 string_Q),
 327     ("symbol",      symbol),
 328     ("symbol?",     pred1 symbol_Q),
 329     ("keyword",     keyword),
 330     ("keyword?",    pred1 keyword_Q),
 331     ("number?",     pred1 number_Q),
 332     ("fn?",         pred1 fn_Q),
 333     ("macro?",      pred1 macro_Q),
 334
 335     ("pr-str",      pr_str),
 336     ("str",         str),
 337     ("prn",         prn),
 338     ("println",     println),
 339     ("readline",    do_readline),
 340     ("read-string", read_string),
 341     ("slurp",       slurp),
 342
 343     ("<",           cmp_op (<)),
 344     ("<=",          cmp_op (<=)),
 345     (">",           cmp_op (>)),
 346     (">=",          cmp_op (>=)),
 347     ("+",           num_op (+)),
 348     ("-",           num_op (-)),
 349     ("*",           num_op (*)),
 350     ("/",           num_op (div)),
 351     ("time-ms",     time_ms),
 352
 353     ("list",        list),
 354     ("list?",       pred1 list_Q),
 355     ("vector",      vector),
 356     ("vector?",     pred1 vector_Q),
 357     ("hash-map",    hash_map),
 358     ("map?",        pred1 map_Q),
 359     ("assoc",       assoc),
 360     ("dissoc",      dissoc),
 361     ("get",         get),
 362     ("contains?",   contains_Q),
 363     ("keys",        keys),
 364     ("vals",        vals),
 365
 366     ("sequential?", pred1 sequential_Q),
 367     ("cons",        cons),
 368     ("concat",      do_concat),
 369     ("nth",         nth),
 370     ("first",       first),
 371     ("rest",        rest),
 372     ("empty?",      pred1 empty_Q),
 373     ("count",       count),
 374     ("apply",       apply),
 375     ("map",         do_map),
 376
 377     ("conj",        conj),
 378     ("seq",         do_seq),
 379
 380     ("with-meta",   with_meta),
 381     ("meta",        do_meta),
 382     ("atom",        atom),
 383     ("atom?",       pred1 atom_Q),
 384     ("deref",       deref),
 385     ("reset!",      reset_BANG),
 386     ("swap!",       swap_BANG)]