diff options
Diffstat (limited to 'haskell/Core.hs')
| -rw-r--r-- | haskell/Core.hs | 104 |
1 files changed, 57 insertions, 47 deletions
diff --git a/haskell/Core.hs b/haskell/Core.hs index 4bb5517..d1034c1 100644 --- a/haskell/Core.hs +++ b/haskell/Core.hs @@ -2,7 +2,9 @@ module Core ( ns ) where +import System.IO (hFlush, stdout) import Control.Exception (catch) +import Control.Monad.Trans (liftIO) import qualified Data.Map as Map import Data.Time.Clock.POSIX (getPOSIXTime) import Data.IORef (IORef, newIORef, readIORef, writeIORef) @@ -15,23 +17,28 @@ import Printer (_pr_str, _pr_list) -- General functions equal_Q [a, b] = return $ if a == b then MalTrue else MalFalse -equal_Q _ = error $ "illegal arguments to =" +equal_Q _ = throwStr "illegal arguments to =" -run_1 :: (MalVal -> MalVal) -> [MalVal] -> IO MalVal +run_1 :: (MalVal -> MalVal) -> [MalVal] -> IOThrows MalVal run_1 f (x:[]) = return $ f x -run_1 _ _ = error $ "function takes a single argument" +run_1 _ _ = throwStr "function takes a single argument" -run_2 :: (MalVal -> MalVal -> MalVal) -> [MalVal] -> IO MalVal +run_2 :: (MalVal -> MalVal -> MalVal) -> [MalVal] -> IOThrows MalVal run_2 f (x:y:[]) = return $ f x y -run_2 _ _ = error $ "function takes a two arguments" +run_2 _ _ = throwStr "function takes a two arguments" + +-- Error/Exception functions + +throw (mv:[]) = throwMalVal mv +throw _ = throwStr "illegal arguments to throw" -- Scalar functions -symbol (MalString str) = MalSymbol str -symbol _ = error $ "symbol called with non-string" +symbol (MalString str:[]) = return $ MalSymbol str +symbol _ = throwStr "symbol called with non-string" -keyword (MalString str) = MalString $ "\x029e" ++ str -keyword _ = error $ "keyword called with non-string" +keyword (MalString str:[]) = return $ MalString $ "\x029e" ++ str +keyword _ = throwStr "keyword called with non-string" -- String functions @@ -43,37 +50,39 @@ str args = do return $ MalString $ _pr_list False "" args prn args = do - putStrLn $ _pr_list True " " args + liftIO $ putStrLn $ _pr_list True " " args + liftIO $ hFlush stdout return Nil println args = do - putStrLn $ _pr_list False " " args + liftIO $ putStrLn $ _pr_list False " " args + liftIO $ hFlush stdout return Nil slurp ([MalString path]) = do - str <- readFile path + str <- liftIO $ readFile path return $ MalString str -slurp _ = error $ "invalid arguments to slurp" +slurp _ = throwStr "invalid arguments to slurp" do_readline ([MalString prompt]) = do - str <- readline prompt + str <- liftIO $ readline prompt case str of - Nothing -> error "readline failed" + Nothing -> throwStr "readline failed" Just str -> return $ MalString str -do_readline _ = error $ "invalid arguments to readline" +do_readline _ = throwStr "invalid arguments to readline" -- Numeric functions num_op op [MalNumber a, MalNumber b] = do return $ MalNumber $ op a b -num_op _ _ = error $ "illegal arguments to number operation" +num_op _ _ = throwStr "illegal arguments to number operation" cmp_op op [MalNumber a, MalNumber b] = do return $ if op a b then MalTrue else MalFalse -cmp_op _ _ = error $ "illegal arguments to comparison operation" +cmp_op _ _ = throwStr "illegal arguments to comparison operation" time_ms _ = do - t <- getPOSIXTime + t <- liftIO $ getPOSIXTime return $ MalNumber $ round (t * 1000) @@ -87,7 +96,7 @@ vector args = return $ MalVector args Nil -- Hash Map functions -_pairup [x] = error "Odd number of elements to _pairup" +_pairup [x] = throwStr "Odd number of elements to _pairup" _pairup [] = return [] _pairup (MalString x:y:xs) = do rest <- _pairup xs @@ -100,33 +109,33 @@ hash_map args = do assoc (MalHashMap hm _:kvs) = do pairs <- _pairup kvs return $ MalHashMap (Map.union (Map.fromList pairs) hm) Nil -assoc _ = error $ "invalid call to assoc" +assoc _ = throwStr "invalid call to assoc" dissoc (MalHashMap hm _:ks) = do let remover = (\hm (MalString k) -> Map.delete k hm) in return $ MalHashMap (foldl remover hm ks) Nil -dissoc _ = error $ "invalid call to dissoc" +dissoc _ = throwStr "invalid call to dissoc" get (MalHashMap hm _:MalString k:[]) = do case Map.lookup k hm of Just mv -> return mv Nothing -> return Nil get (Nil:MalString k:[]) = return Nil -get _ = error $ "invalid call to get" +get _ = throwStr "invalid call to get" contains_Q (MalHashMap hm _:MalString k:[]) = do if Map.member k hm then return MalTrue else return MalFalse contains_Q (Nil:MalString k:[]) = return MalFalse -contains_Q _ = error $ "invalid call to contains?" +contains_Q _ = throwStr "invalid call to contains?" keys (MalHashMap hm _:[]) = do return $ MalList (map MalString (Map.keys hm)) Nil -keys _ = error $ "invalid call to keys" +keys _ = throwStr "invalid call to keys" vals (MalHashMap hm _:[]) = do return $ MalList (Map.elems hm) Nil -vals _ = error $ "invalid call to vals" +vals _ = throwStr "invalid call to vals" -- Sequence functions @@ -145,11 +154,11 @@ do_concat args = return $ MalList (foldl concat1 [] args) Nil nth ((MalList lst _):(MalNumber idx):[]) = do if idx < length lst then return $ lst !! idx - else error "nth: index out of range" + else throwStr "nth: index out of range" nth ((MalVector lst _):(MalNumber idx):[]) = do if idx < length lst then return $ lst !! idx - else error "nth: index out of range" -nth _ = error "invalid call to nth" + else throwStr "nth: index out of range" +nth _ = throwStr "invalid call to nth" first (MalList lst _) = if length lst > 0 then lst !! 0 else Nil first (MalVector lst _) = if length lst > 0 then lst !! 0 else Nil @@ -162,14 +171,14 @@ empty_Q (MalList [] _) = MalTrue empty_Q (MalVector [] _) = MalTrue empty_Q _ = MalFalse -count Nil = MalNumber 0 -count (MalList lst _) = MalNumber $ length lst -count (MalVector lst _) = MalNumber $ length lst -count _ = error $ "non-sequence passed to count" +count (Nil:[]) = return $ MalNumber 0 +count (MalList lst _:[]) = return $ MalNumber $ length lst +count (MalVector lst _:[]) = return $ MalNumber $ length lst +count _ = throwStr $ "non-sequence passed to count" conj ((MalList lst _):args) = return $ MalList ((reverse args) ++ lst) Nil conj ((MalVector lst _):args) = return $ MalVector (lst ++ args) Nil -conj _ = error $ "illegal arguments to conj" +conj _ = throwStr $ "illegal arguments to conj" apply args = do f <- _get_call args @@ -191,7 +200,7 @@ with_meta ((MalAtom atm _):m:[]) = return $ MalAtom atm m with_meta ((Func f _):m:[]) = return $ Func f m with_meta ((MalFunc {fn=f, ast=a, env=e, params=p, macro=mc}):m:[]) = do return $ MalFunc {fn=f, ast=a, env=e, params=p, macro=mc, meta=m} -with_meta _ = error $ "invalid with-meta call" +with_meta _ = throwStr $ "invalid with-meta call" do_meta ((MalList _ m):[]) = return m do_meta ((MalVector _ m):[]) = return m @@ -199,40 +208,41 @@ do_meta ((MalHashMap _ m):[]) = return m do_meta ((MalAtom _ m):[]) = return m do_meta ((Func _ m):[]) = return m do_meta ((MalFunc {meta=m}):[]) = return m -do_meta _ = error $ "invalid meta call" +do_meta _ = throwStr $ "invalid meta call" -- Atom functions atom (val:[]) = do - ref <- newIORef val + ref <- liftIO $ newIORef val return $ MalAtom ref Nil -atom _ = error "invalid atom call" +atom _ = throwStr "invalid atom call" deref (MalAtom ref _:[]) = do - val <- readIORef ref + val <- liftIO $ readIORef ref return val -deref _ = error "invalid deref call" +deref _ = throwStr "invalid deref call" reset_BANG (MalAtom ref _:val:[]) = do - _ <- writeIORef ref $ val + liftIO $ writeIORef ref $ val return val -reset_BANG _ = error "invalid deref call" +reset_BANG _ = throwStr "invalid deref call" swap_BANG (MalAtom ref _:args) = do - val <- readIORef ref + val <- liftIO $ readIORef ref f <- _get_call args new_val <- f $ [val] ++ (tail args) - _ <- writeIORef ref $ new_val + _ <- liftIO $ writeIORef ref $ new_val return new_val ns = [ ("=", _func equal_Q), + ("throw", _func throw), ("nil?", _func $ run_1 $ _nil_Q), ("true?", _func $ run_1 $ _true_Q), ("false?", _func $ run_1 $ _false_Q), - ("symbol", _func $ run_1 $ symbol), + ("symbol", _func $ symbol), ("symbol?", _func $ run_1 $ _symbol_Q), - ("keyword", _func $ run_1 $ keyword), + ("keyword", _func $ keyword), ("keyword?", _func $ run_1 $ _keyword_Q), ("pr-str", _func pr_str), @@ -273,7 +283,7 @@ ns = [ ("first", _func $ run_1 $ first), ("rest", _func $ run_1 $ rest), ("empty?", _func $ run_1 $ empty_Q), - ("count", _func $ run_1 $ count), + ("count", _func $ count), ("conj", _func $ conj), ("apply", _func $ apply), ("map", _func $ do_map), |