haskell/Core.hs

   1 module Core
   2 ( ns )
   3 where
   4
   5 import System.IO (hFlush, stdout)
   6 import Control.Exception (catch)
   7 import Control.Monad.Trans (liftIO)
   8 import qualified Data.Map as Map
   9 import Data.Time.Clock.POSIX (getPOSIXTime)
  10 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
  11
  12 import Readline (readline)
  13 import Reader (read_str)
  14 import Types
  15 import Printer (_pr_str, _pr_list)
  16
  17 -- General functions
  18
  19 equal_Q [a, b] = return $ if a == b then MalTrue else MalFalse
  20 equal_Q _ = throwStr "illegal arguments to ="
  21
  22 run_1 :: (MalVal -> MalVal) -> [MalVal] -> IOThrows MalVal
  23 run_1 f (x:[]) = return $ f x
  24 run_1 _ _ = throwStr "function takes a single argument"
  25
  26 run_2 :: (MalVal -> MalVal -> MalVal) -> [MalVal] -> IOThrows MalVal
  27 run_2 f (x:y:[]) = return $ f x y
  28 run_2 _ _ = throwStr "function takes a two arguments"
  29
  30 -- Error/Exception functions
  31
  32 throw (mv:[]) = throwMalVal mv
  33 throw _ = throwStr "illegal arguments to throw"
  34
  35 -- Scalar functions
  36
  37 symbol (MalString str:[]) = return $ MalSymbol str
  38 symbol _ = throwStr "symbol called with non-string"
  39
  40 keyword (MalString str:[]) = return $ MalString $ "\x029e" ++ str
  41 keyword _ = throwStr "keyword called with non-string"
  42
  43
  44 -- String functions
  45
  46 pr_str args = do
  47     return $ MalString $ _pr_list True " " args
  48
  49 str args = do
  50     return $ MalString $ _pr_list False "" args
  51
  52 prn args = do
  53     liftIO $ putStrLn $ _pr_list True " " args
  54     liftIO $ hFlush stdout
  55     return Nil
  56
  57 println args = do
  58     liftIO $ putStrLn $ _pr_list False " " args
  59     liftIO $ hFlush stdout
  60     return Nil
  61
  62 slurp ([MalString path]) = do
  63     str <- liftIO $ readFile path
  64     return $ MalString str
  65 slurp _ = throwStr "invalid arguments to slurp"
  66
  67 do_readline ([MalString prompt]) = do
  68     str <- liftIO $ readline prompt
  69     case str of
  70         Nothing -> throwStr "readline failed"
  71         Just str -> return $ MalString str
  72 do_readline _ = throwStr "invalid arguments to readline"
  73
  74 -- Numeric functions
  75
  76 num_op op [MalNumber a, MalNumber b] = do
  77     return $ MalNumber $ op a b
  78 num_op _ _ = throwStr "illegal arguments to number operation"
  79
  80 cmp_op op [MalNumber a, MalNumber b] = do
  81     return $ if op a b then MalTrue else MalFalse
  82 cmp_op _ _ = throwStr "illegal arguments to comparison operation"
  83
  84 time_ms _ = do
  85    t <- liftIO $ getPOSIXTime
  86    return $ MalNumber $ round (t * 1000)
  87
  88
  89 -- List functions
  90
  91 list args = return $ MalList args Nil
  92
  93 -- Vector functions
  94
  95 vector args = return $ MalVector args Nil
  96
  97 -- Hash Map functions
  98
  99 _pairup [x] = throwStr "Odd number of elements to _pairup"
 100 _pairup [] = return []
 101 _pairup (MalString x:y:xs) = do
 102     rest <- _pairup xs
 103     return $ (x,y):rest
 104
 105 hash_map args = do
 106     pairs <- _pairup args
 107     return $ MalHashMap (Map.fromList pairs) Nil
 108
 109 assoc (MalHashMap hm _:kvs) = do
 110     pairs <- _pairup kvs
 111     return $ MalHashMap (Map.union (Map.fromList pairs) hm) Nil
 112 assoc _ = throwStr "invalid call to assoc"
 113
 114 dissoc (MalHashMap hm _:ks) = do
 115     let remover = (\hm (MalString k) -> Map.delete k hm) in
 116         return $ MalHashMap (foldl remover  hm ks) Nil
 117 dissoc _ = throwStr "invalid call to dissoc"
 118
 119 get (MalHashMap hm _:MalString k:[]) = do
 120     case Map.lookup k hm of
 121         Just mv -> return mv
 122         Nothing -> return Nil
 123 get (Nil:MalString k:[]) = return Nil
 124 get _ = throwStr "invalid call to get"
 125
 126 contains_Q (MalHashMap hm _:MalString k:[]) = do
 127     if Map.member k hm then return MalTrue
 128     else return MalFalse
 129 contains_Q (Nil:MalString k:[]) = return MalFalse
 130 contains_Q _ = throwStr "invalid call to contains?"
 131
 132 keys (MalHashMap hm _:[]) = do
 133     return $ MalList (map MalString (Map.keys hm)) Nil
 134 keys _ = throwStr "invalid call to keys"
 135
 136 vals (MalHashMap hm _:[]) = do
 137     return $ MalList (Map.elems hm) Nil
 138 vals _ = throwStr "invalid call to vals"
 139
 140
 141 -- Sequence functions
 142
 143 _sequential_Q (MalList _ _) = MalTrue
 144 _sequential_Q (MalVector _ _) = MalTrue
 145 _sequential_Q _ = MalFalse
 146
 147 cons x Nil = MalList [x] Nil
 148 cons x (MalList lst _) = MalList (x:lst) Nil
 149 cons x (MalVector lst _) = MalList (x:lst) Nil
 150
 151 concat1 a (MalList lst _) = a ++ lst
 152 concat1 a (MalVector lst _) = a ++ lst
 153 do_concat args = return $ MalList (foldl concat1 [] args) Nil
 154
 155 nth ((MalList lst _):(MalNumber idx):[]) = do
 156     if idx < length lst then return $ lst !! idx
 157     else throwStr "nth: index out of range"
 158 nth ((MalVector lst _):(MalNumber idx):[]) = do
 159     if idx < length lst then return $ lst !! idx
 160     else throwStr "nth: index out of range"
 161 nth _ = throwStr "invalid call to nth"
 162
 163 first (MalList lst _) = if length lst > 0 then lst !! 0 else Nil
 164 first (MalVector lst _) = if length lst > 0 then lst !! 0 else Nil
 165
 166 rest (MalList lst _) = MalList (drop 1 lst) Nil
 167 rest (MalVector lst _) = MalList (drop 1 lst) Nil
 168
 169 empty_Q Nil              = MalTrue
 170 empty_Q (MalList [] _)   = MalTrue
 171 empty_Q (MalVector [] _) = MalTrue
 172 empty_Q _                = MalFalse
 173
 174 count (Nil:[])             = return $ MalNumber 0
 175 count (MalList lst _:[])   = return $ MalNumber $ length lst
 176 count (MalVector lst _:[]) = return $ MalNumber $ length lst
 177 count _ = throwStr $ "non-sequence passed to count"
 178
 179 conj ((MalList lst _):args) = return $ MalList ((reverse args) ++ lst) Nil
 180 conj ((MalVector lst _):args) = return $ MalVector (lst ++ args) Nil
 181 conj _ = throwStr $ "illegal arguments to conj"
 182
 183 apply args = do
 184     f <- _get_call args
 185     lst <- _to_list (last args)
 186     f $ (init (drop 1 args)) ++ lst
 187
 188 do_map args = do
 189     f <- _get_call args
 190     lst <- _to_list (args !! 1)
 191     do new_lst <- mapM (\x -> f [x]) lst
 192        return $ MalList new_lst Nil
 193
 194 -- Metadata functions
 195
 196 with_meta ((MalList lst _):m:[])   = return $ MalList lst m
 197 with_meta ((MalVector lst _):m:[]) = return $ MalVector lst m
 198 with_meta ((MalHashMap hm _):m:[]) = return $ MalHashMap hm m
 199 with_meta ((MalAtom atm _):m:[])   = return $ MalAtom atm m
 200 with_meta ((Func f _):m:[])        = return $ Func f m
 201 with_meta ((MalFunc {fn=f, ast=a, env=e, params=p, macro=mc}):m:[]) = do
 202     return $ MalFunc {fn=f, ast=a, env=e, params=p, macro=mc, meta=m}
 203 with_meta _ = throwStr $ "invalid with-meta call"
 204
 205 do_meta ((MalList _ m):[])      = return m
 206 do_meta ((MalVector _ m):[])    = return m
 207 do_meta ((MalHashMap _ m):[])   = return m
 208 do_meta ((MalAtom _ m):[])      = return m
 209 do_meta ((Func _ m):[])         = return m
 210 do_meta ((MalFunc {meta=m}):[]) = return m
 211 do_meta _ = throwStr $ "invalid meta call"
 212
 213 -- Atom functions
 214
 215 atom (val:[]) = do
 216     ref <- liftIO $ newIORef val
 217     return $ MalAtom ref Nil
 218 atom _ = throwStr "invalid atom call"
 219
 220 deref (MalAtom ref _:[]) = do
 221     val <- liftIO $ readIORef ref
 222     return val
 223 deref _ = throwStr "invalid deref call"
 224
 225 reset_BANG (MalAtom ref _:val:[]) = do
 226     liftIO $ writeIORef ref $ val
 227     return val
 228 reset_BANG _ = throwStr "invalid deref call"
 229
 230 swap_BANG (MalAtom ref _:args) = do
 231     val <- liftIO $ readIORef ref
 232     f <- _get_call args
 233     new_val <- f $ [val] ++ (tail args)
 234     _ <- liftIO $ writeIORef ref $ new_val
 235     return new_val
 236
 237 ns = [
 238     ("=",  _func equal_Q),
 239     ("throw", _func throw),
 240     ("nil?", _func $ run_1 $ _nil_Q),
 241     ("true?", _func $ run_1 $ _true_Q),
 242     ("false?", _func $ run_1 $ _false_Q),
 243     ("symbol", _func $ symbol),
 244     ("symbol?", _func $ run_1 $ _symbol_Q),
 245     ("keyword", _func $ keyword),
 246     ("keyword?", _func $ run_1 $ _keyword_Q),
 247
 248     ("pr-str", _func pr_str),
 249     ("str", _func str),
 250     ("prn", _func prn),
 251     ("println", _func println),
 252     ("readline", _func do_readline),
 253     ("read-string", _func (\[(MalString s)] -> read_str s)),
 254     ("slurp", _func slurp),
 255
 256     ("<",  _func $ cmp_op (<)),
 257     ("<=", _func $ cmp_op (<=)),
 258     (">",  _func $ cmp_op (>)),
 259     (">=", _func $ cmp_op (>=)),
 260     ("+",  _func $ num_op (+)),
 261     ("-",  _func $ num_op (-)),
 262     ("*",  _func $ num_op (*)),
 263     ("/",  _func $ num_op (div)),
 264     ("time-ms", _func $ time_ms),
 265
 266     ("list",     _func $ list),
 267     ("list?",    _func $ run_1 _list_Q),
 268     ("vector",   _func $ vector),
 269     ("vector?",  _func $ run_1 _vector_Q),
 270     ("hash-map", _func $ hash_map),
 271     ("map?",     _func $ run_1 _hash_map_Q),
 272     ("assoc",    _func $ assoc),
 273     ("dissoc",   _func $ dissoc),
 274     ("get",      _func $ get),
 275     ("contains?",_func $ contains_Q),
 276     ("keys",     _func $ keys),
 277     ("vals",     _func $ vals),
 278
 279     ("sequential?", _func $ run_1 _sequential_Q),
 280     ("cons", _func $ run_2 $ cons),
 281     ("concat", _func $ do_concat),
 282     ("nth", _func nth),
 283     ("first", _func $ run_1 $ first),
 284     ("rest", _func $ run_1 $ rest),
 285     ("empty?", _func $ run_1 $ empty_Q),
 286     ("count", _func $ count),
 287     ("conj", _func $ conj),
 288     ("apply", _func $ apply),
 289     ("map", _func $ do_map),
 290
 291     ("with-meta", _func $ with_meta),
 292     ("meta",      _func $ do_meta),
 293     ("atom",      _func $ atom),
 294     ("atom?",     _func $ run_1 _atom_Q),
 295     ("deref",     _func $ deref),
 296     ("reset!",    _func $ reset_BANG),
 297     ("swap!",     _func $ swap_BANG)]