carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-10-11 12:37:32 +03:00
Code Issues Projects Releases Wiki Activity

compiler: simplified error handling in commands

Browse Source
This commit is contained in:
hellerve 2017-12-28 17:09:39 +01:00
parent 48d1858b28
commit b3dcd0311d
2 changed files with 44 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
app/Main.hs
View File

@ -137,48 +137,48 @@ arrayModule = Env { envBindings = bindings, envParent = Nothing, envModuleName =
dynamicStringModule :: Env dynamicStringModule :: Env
dynamicStringModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "String", envUseModules = [], envMode = ExternalEnv } dynamicStringModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "String", envUseModules = [], envMode = ExternalEnv }
where bindings = Map.fromList [ addCommand "char-at" (CommandFunction commandCharAt) where bindings = Map.fromList [ addCommand "char-at" 2 commandCharAt
, addCommand "index-of" (CommandFunction commandIndexOf) , addCommand "index-of" 2 commandIndexOf
, addCommand "substring" (CommandFunction commandSubstring) , addCommand "substring" 3 commandSubstring
, addCommand "count" (CommandFunction commandStringCount) , addCommand "count" 1 commandStringCount
] ]
dynamicModule :: Env dynamicModule :: Env
dynamicModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "Dynamic", envUseModules = [], envMode = ExternalEnv } dynamicModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "Dynamic", envUseModules = [], envMode = ExternalEnv }
where bindings = Map.fromList $ where bindings = Map.fromList $
[ addCommand "list?" (CommandFunction commandIsList) [ addCommand "list?" 1 commandIsList
, addCommand "count" (CommandFunction commandCount) , addCommand "count" 1 commandCount
, addCommand "car" (CommandFunction commandCar) , addCommand "car" 1 commandCar
, addCommand "cdr" (CommandFunction commandCdr) , addCommand "cdr" 1 commandCdr
, addCommand "last" (CommandFunction commandLast) , addCommand "last" 1 commandLast
, addCommand "all-but-last" (CommandFunction commandAllButLast) , addCommand "all-but-last" 1 commandAllButLast
, addCommand "cons" (CommandFunction commandCons) , addCommand "cons" 2 commandCons
, addCommand "cons-last" (CommandFunction commandConsLast) , addCommand "cons-last" 2 commandConsLast
, addCommand "append" (CommandFunction commandAppend) , addCommand "append" 2 commandAppend
, addCommand "macro-error" (CommandFunction commandMacroError) , addCommand "macro-error" 1 commandMacroError
, addCommand "=" (CommandFunction commandEq) , addCommand "=" 2 commandEq
, addCommand "<" (CommandFunction commandLt) , addCommand "<" 2 commandLt
, addCommand ">" (CommandFunction commandGt) , addCommand ">" 2 commandGt
, addCommand "+" (CommandFunction commandPlus) , addCommand "+" 2 commandPlus
, addCommand "-" (CommandFunction commandMinus) , addCommand "-" 2 commandMinus
, addCommand "/" (CommandFunction commandDiv) , addCommand "/" 2 commandDiv
, addCommand "*" (CommandFunction commandMul) , addCommand "*" 2 commandMul
, addCommand "c" (CommandFunction commandC) , addCommand "c" 1 commandC
, addCommand "quit" (CommandFunction commandQuit) , addCommand "quit" 0 commandQuit
, addCommand "cat" (CommandFunction commandCat) , addCommand "cat" 0 commandCat
, addCommand "run" (CommandFunction commandRunExe) , addCommand "run" 0 commandRunExe
, addCommand "build" (CommandFunction commandBuild) , addCommand "build" 0 commandBuild
, addCommand "reload" (CommandFunction commandReload) , addCommand "reload" 0 commandReload
, addCommand "env" (CommandFunction commandListBindings) , addCommand "env" 0 commandListBindings
, addCommand "help" (CommandFunction commandHelp) , addCommand "help" 1 commandHelp
, addCommand "project" (CommandFunction commandProject) , addCommand "project" 0 commandProject
, addCommand "load" (CommandFunction commandLoad) , addCommand "load" 1 commandLoad
, addCommand "macro-log" (CommandFunction commandPrint) , addCommand "macro-log" 1 commandPrint
, addCommand "expand" (CommandFunction commandExpand) , addCommand "expand" 1 commandExpand
, addCommand "project-set!" (CommandFunction commandProjectSet) , addCommand "project-set!" 2 commandProjectSet
, addCommand "os" (CommandFunction commandOS) , addCommand "os" 0 commandOS
, addCommand "system-include" (CommandFunction commandAddSystemInclude) , addCommand "system-include" 1 commandAddSystemInclude
, addCommand "local-include" (CommandFunction commandAddLocalInclude) , addCommand "local-include" 1 commandAddLocalInclude
] ]
++ [("String", Binder (XObj (Mod dynamicStringModule) Nothing Nothing))] ++ [("String", Binder (XObj (Mod dynamicStringModule) Nothing Nothing))]

54
src/Commands.hs
View File

@ -42,14 +42,18 @@ falseXObj :: XObj
falseXObj = XObj (Bol False) Nothing Nothing falseXObj = XObj (Bol False) Nothing Nothing
-- | Use this function to register commands in the environment. -- | Use this function to register commands in the environment.
addCommand :: String -> CommandFunctionType -> (String, Binder) addCommand :: String -> Int -> CommandCallback -> (String, Binder)
addCommand name callback = addCommand name arity callback =
let path = SymPath [] name let path = SymPath [] name
cmd = XObj (Lst [XObj (Command callback) (Just dummyInfo) Nothing cmd = XObj (Lst [XObj (Command (CommandFunction withArity)) (Just dummyInfo) Nothing
,XObj (Sym path) Nothing Nothing ,XObj (Sym path) Nothing Nothing
]) ])
(Just dummyInfo) (Just DynamicTy) (Just dummyInfo) (Just DynamicTy)
in (name, Binder cmd) in (name, Binder cmd)
where withArity args =
if length args == arity
then callback args
else return (Left (EvalError ("Invalid args to '" ++ name ++ "' command: " ++ joinWithComma (map pretty args))))
-- | Command for changing various project settings. -- | Command for changing various project settings.
commandProjectSet :: CommandCallback commandProjectSet :: CommandCallback
@ -74,8 +78,6 @@ commandProjectSet [XObj (Str key) _ _, value] =
val -> err "Argument to project-set! must be a string" dynamicNil val -> err "Argument to project-set! must be a string" dynamicNil
where err msg ret = liftIO $ do putStrLnWithColor Red msg where err msg ret = liftIO $ do putStrLnWithColor Red msg
return ret return ret
commandProjectSet args =
return (Left (EvalError ("Invalid args to 'project-set!' command: " ++ joinWithComma (map pretty args))))
-- | Command for exiting the REPL/compiler -- | Command for exiting the REPL/compiler
commandQuit :: CommandCallback commandQuit :: CommandCallback
@ -330,8 +332,6 @@ commandIsList [x] =
case x of case x of
XObj (Lst _) _ _ -> return (Right trueXObj) XObj (Lst _) _ _ -> return (Right trueXObj)
_ -> return (Right falseXObj) _ -> return (Right falseXObj)
commandIsList args =
return (Left (EvalError ("Invalid args to 'list?': " ++ joinWithComma (map pretty args))))
commandCount :: CommandCallback commandCount :: CommandCallback
commandCount [x] = commandCount [x] =
@ -339,8 +339,6 @@ commandCount [x] =
XObj (Lst lst) _ _ -> return (Right (XObj (Num IntTy (fromIntegral (length lst))) Nothing Nothing)) XObj (Lst lst) _ _ -> return (Right (XObj (Num IntTy (fromIntegral (length lst))) Nothing Nothing))
XObj (Arr arr) _ _ -> return (Right (XObj (Num IntTy (fromIntegral (length arr))) Nothing Nothing)) XObj (Arr arr) _ _ -> return (Right (XObj (Num IntTy (fromIntegral (length arr))) Nothing Nothing))
_ -> return (Left (EvalError ("Applying 'count' to non-list: " ++ pretty x ++ " at " ++ prettyInfoFromXObj x))) _ -> return (Left (EvalError ("Applying 'count' to non-list: " ++ pretty x ++ " at " ++ prettyInfoFromXObj x)))
commandCount args =
return (Left (EvalError ("Invalid args to 'count': " ++ joinWithComma (map pretty args))))
commandCar :: CommandCallback commandCar :: CommandCallback
commandCar [x] = commandCar [x] =
@ -348,8 +346,6 @@ commandCar [x] =
XObj (Lst (car : _)) _ _ -> return (Right car) XObj (Lst (car : _)) _ _ -> return (Right car)
XObj (Arr (car : _)) _ _ -> return (Right car) XObj (Arr (car : _)) _ _ -> return (Right car)
_ -> return (Left (EvalError ("Applying 'car' to non-list: " ++ pretty x))) _ -> return (Left (EvalError ("Applying 'car' to non-list: " ++ pretty x)))
commandCar args =
return (Left (EvalError ("Invalid args to 'car': " ++ joinWithComma (map pretty args))))
commandCdr :: CommandCallback commandCdr :: CommandCallback
commandCdr [x] = commandCdr [x] =
@ -357,8 +353,6 @@ commandCdr [x] =
XObj (Lst (_ : cdr)) _ _ -> return (Right (XObj (Lst cdr) Nothing Nothing)) XObj (Lst (_ : cdr)) _ _ -> return (Right (XObj (Lst cdr) Nothing Nothing))
XObj (Arr (_ : cdr)) _ _ -> return (Right (XObj (Arr cdr) Nothing Nothing)) XObj (Arr (_ : cdr)) _ _ -> return (Right (XObj (Arr cdr) Nothing Nothing))
_ -> return (Left (EvalError "Applying 'cdr' to non-list or empty list")) _ -> return (Left (EvalError "Applying 'cdr' to non-list or empty list"))
commandCdr args =
return (Left (EvalError ("Invalid args to 'cdr': " ++ joinWithComma (map pretty args))))
commandLast :: CommandCallback commandLast :: CommandCallback
commandLast [x] = commandLast [x] =
@ -366,8 +360,6 @@ commandLast [x] =
XObj (Lst lst) _ _ -> return (Right (last lst)) XObj (Lst lst) _ _ -> return (Right (last lst))
XObj (Arr arr) _ _ -> return (Right (last arr)) XObj (Arr arr) _ _ -> return (Right (last arr))
_ -> return (Left (EvalError "Applying 'last' to non-list or empty list.")) _ -> return (Left (EvalError "Applying 'last' to non-list or empty list."))
commandLast args =
return (Left (EvalError ("Invalid args to 'last': " ++ joinWithComma (map pretty args))))
commandAllButLast :: CommandCallback commandAllButLast :: CommandCallback
commandAllButLast [x] = commandAllButLast [x] =
@ -375,24 +367,18 @@ commandAllButLast [x] =
XObj (Lst lst) _ _ -> return (Right (XObj (Lst (init lst)) Nothing Nothing)) XObj (Lst lst) _ _ -> return (Right (XObj (Lst (init lst)) Nothing Nothing))
XObj (Arr arr) _ _ -> return (Right (XObj (Arr (init arr)) Nothing Nothing)) XObj (Arr arr) _ _ -> return (Right (XObj (Arr (init arr)) Nothing Nothing))
_ -> return (Left (EvalError "Applying 'all-but-last' to non-list or empty list.")) _ -> return (Left (EvalError "Applying 'all-but-last' to non-list or empty list."))
commandAllButLast args =
return (Left (EvalError ("Invalid args to 'all-but-last': " ++ joinWithComma (map pretty args))))
commandCons :: CommandCallback commandCons :: CommandCallback
commandCons [x, xs] = commandCons [x, xs] =
case xs of case xs of
XObj (Lst lst) _ _ -> return (Right (XObj (Lst (x : lst)) (info x) (ty x))) -- TODO: probably not correct to just copy 'i' and 't'? XObj (Lst lst) _ _ -> return (Right (XObj (Lst (x : lst)) (info x) (ty x))) -- TODO: probably not correct to just copy 'i' and 't'?
_ -> return (Left (EvalError "Applying 'cons' to non-list or empty list.")) _ -> return (Left (EvalError "Applying 'cons' to non-list or empty list."))
commandCons args =
return (Left (EvalError ("Invalid args to 'cons': " ++ joinWithComma (map pretty args))))
commandConsLast :: CommandCallback commandConsLast :: CommandCallback
commandConsLast [x, xs] = commandConsLast [x, xs] =
case xs of case xs of
XObj (Lst lst) i t -> return (Right (XObj (Lst (lst ++ [x])) i t)) -- TODO: should they get their own i:s and t:s XObj (Lst lst) i t -> return (Right (XObj (Lst (lst ++ [x])) i t)) -- TODO: should they get their own i:s and t:s
_ -> return (Left (EvalError "Applying 'cons-last' to non-list or empty list.")) _ -> return (Left (EvalError "Applying 'cons-last' to non-list or empty list."))
commandConsLast args =
return (Left (EvalError ("Invalid args to 'cons-last': " ++ joinWithComma (map pretty args))))
commandAppend :: CommandCallback commandAppend :: CommandCallback
commandAppend [xs, ys] = commandAppend [xs, ys] =
@ -401,16 +387,12 @@ commandAppend [xs, ys] =
return (Right (XObj (Lst (lst1 ++ lst2)) i t)) -- TODO: should they get their own i:s and t:s return (Right (XObj (Lst (lst1 ++ lst2)) i t)) -- TODO: should they get their own i:s and t:s
_ -> _ ->
return (Left (EvalError "Applying 'append' to non-list or empty list.")) return (Left (EvalError "Applying 'append' to non-list or empty list."))
commandAppend args =
return (Left (EvalError ("Invalid args to 'append': " ++ joinWithComma (map pretty args))))
commandMacroError :: CommandCallback commandMacroError :: CommandCallback
commandMacroError [msg] = commandMacroError [msg] =
case msg of case msg of
XObj (Str msg) _ _ -> return (Left (EvalError msg)) XObj (Str msg) _ _ -> return (Left (EvalError msg))
_ -> return (Left (EvalError "Calling 'macro-error' with non-string argument")) _ -> return (Left (EvalError "Calling 'macro-error' with non-string argument"))
commandMacroError args =
return (Left (EvalError ("Invalid args to 'macro-error': " ++ joinWithComma (map pretty args))))
commandEq :: CommandCallback commandEq :: CommandCallback
commandEq [a, b] = commandEq [a, b] =
@ -433,8 +415,6 @@ commandEq [a, b] =
if sa == sb then Right trueXObj else Right falseXObj if sa == sb then Right trueXObj else Right falseXObj
_ -> _ ->
Left (EvalError ("Can't compare " ++ pretty a ++ " with " ++ pretty b)) Left (EvalError ("Can't compare " ++ pretty a ++ " with " ++ pretty b))
commandEq args =
return (Left (EvalError ("Invalid args to '=': " ++ joinWithComma (map pretty args))))
commandLt :: CommandCallback commandLt :: CommandCallback
commandLt [a, b] = commandLt [a, b] =
@ -453,8 +433,6 @@ commandLt [a, b] =
then Right trueXObj else Right falseXObj then Right trueXObj else Right falseXObj
_ -> _ ->
Left (EvalError ("Can't compare (<) " ++ pretty a ++ " with " ++ pretty b)) Left (EvalError ("Can't compare (<) " ++ pretty a ++ " with " ++ pretty b))
commandLt args =
return (Left (EvalError ("Invalid args to '<': " ++ joinWithComma (map pretty args))))
commandGt :: CommandCallback commandGt :: CommandCallback
commandGt [a, b] = commandGt [a, b] =
@ -473,8 +451,6 @@ commandGt [a, b] =
then Right trueXObj else Right falseXObj then Right trueXObj else Right falseXObj
_ -> _ ->
Left (EvalError ("Can't compare (>) " ++ pretty a ++ " with " ++ pretty b)) Left (EvalError ("Can't compare (>) " ++ pretty a ++ " with " ++ pretty b))
commandGt args =
return (Left (EvalError ("Invalid args to '>': " ++ joinWithComma (map pretty args))))
commandCharAt :: CommandCallback commandCharAt :: CommandCallback
commandCharAt [a, b] = commandCharAt [a, b] =
@ -483,8 +459,6 @@ commandCharAt [a, b] =
Right (XObj (Chr (s !! (round n :: Int))) (Just dummyInfo) (Just IntTy)) Right (XObj (Chr (s !! (round n :: Int))) (Just dummyInfo) (Just IntTy))
_ -> _ ->
Left (EvalError ("Can't call char-at with " ++ pretty a ++ " and " ++ pretty b)) Left (EvalError ("Can't call char-at with " ++ pretty a ++ " and " ++ pretty b))
commandCharAt args =
return (Left (EvalError ("Invalid args to 'char-at': " ++ joinWithComma (map pretty args))))
commandIndexOf :: CommandCallback commandIndexOf :: CommandCallback
commandIndexOf [a, b] = commandIndexOf [a, b] =
@ -494,8 +468,6 @@ commandIndexOf [a, b] =
_ -> _ ->
Left (EvalError ("Can't call index-of with " ++ pretty a ++ " and " ++ pretty b)) Left (EvalError ("Can't call index-of with " ++ pretty a ++ " and " ++ pretty b))
where getIdx c s = fromIntegral $ fromMaybe (-1) $ elemIndex c s where getIdx c s = fromIntegral $ fromMaybe (-1) $ elemIndex c s
commandIndexOf args =
return (Left (EvalError ("Invalid args to 'index-of': " ++ joinWithComma (map pretty args))))
commandSubstring :: CommandCallback commandSubstring :: CommandCallback
commandSubstring [a, b, c] = commandSubstring [a, b, c] =
@ -504,8 +476,6 @@ commandSubstring [a, b, c] =
Right (XObj (Str (take (round t :: Int) (drop (round f :: Int) s))) (Just dummyInfo) (Just StringTy)) Right (XObj (Str (take (round t :: Int) (drop (round f :: Int) s))) (Just dummyInfo) (Just StringTy))
_ -> _ ->
Left (EvalError ("Can't call substring with " ++ pretty a ++ ", " ++ pretty b ++ " and " ++ pretty c)) Left (EvalError ("Can't call substring with " ++ pretty a ++ ", " ++ pretty b ++ " and " ++ pretty c))
commandSubstring args =
return (Left (EvalError ("Invalid args to 'substring': " ++ joinWithComma (map pretty args))))
commandStringCount :: CommandCallback commandStringCount :: CommandCallback
commandStringCount [a] = commandStringCount [a] =
@ -514,8 +484,6 @@ commandStringCount [a] =
Right (XObj (Num IntTy (fromIntegral (length s))) (Just dummyInfo) (Just IntTy)) Right (XObj (Num IntTy (fromIntegral (length s))) (Just dummyInfo) (Just IntTy))
_ -> _ ->
Left (EvalError ("Can't call count with " ++ pretty a)) Left (EvalError ("Can't call count with " ++ pretty a))
commandStringCount args =
return (Left (EvalError ("Invalid args to 'count': " ++ joinWithComma (map pretty args))))
commandPlus :: CommandCallback commandPlus :: CommandCallback
commandPlus [a, b] = commandPlus [a, b] =
@ -524,8 +492,6 @@ commandPlus [a, b] =
Right (XObj (Num IntTy (aNum + bNum)) (Just dummyInfo) (Just IntTy)) Right (XObj (Num IntTy (aNum + bNum)) (Just dummyInfo) (Just IntTy))
_ -> _ ->
Left (EvalError ("Can't call + with " ++ pretty a ++ " and " ++ pretty b)) Left (EvalError ("Can't call + with " ++ pretty a ++ " and " ++ pretty b))
commandPlus args =
return (Left (EvalError ("Invalid args to '+': " ++ joinWithComma (map pretty args))))
commandMinus :: CommandCallback commandMinus :: CommandCallback
commandMinus [a, b] = commandMinus [a, b] =
@ -534,8 +500,6 @@ commandMinus [a, b] =
Right (XObj (Num IntTy (aNum - bNum)) (Just dummyInfo) (Just IntTy)) Right (XObj (Num IntTy (aNum - bNum)) (Just dummyInfo) (Just IntTy))
_ -> _ ->
Left (EvalError ("Can't call - with " ++ pretty a ++ " and " ++ pretty b)) Left (EvalError ("Can't call - with " ++ pretty a ++ " and " ++ pretty b))
commandMinus args =
return (Left (EvalError ("Invalid args to '-': " ++ joinWithComma (map pretty args))))
commandDiv :: CommandCallback commandDiv :: CommandCallback
commandDiv [a, b] = commandDiv [a, b] =
@ -544,8 +508,6 @@ commandDiv [a, b] =
Right (XObj (Num IntTy (aNum / bNum)) (Just dummyInfo) (Just IntTy)) Right (XObj (Num IntTy (aNum / bNum)) (Just dummyInfo) (Just IntTy))
_ -> _ ->
Left (EvalError ("Can't call / with " ++ pretty a ++ " and " ++ pretty b)) Left (EvalError ("Can't call / with " ++ pretty a ++ " and " ++ pretty b))
commandDiv args =
return (Left (EvalError ("Invalid args to '/': " ++ joinWithComma (map pretty args))))
commandMul :: CommandCallback commandMul :: CommandCallback
commandMul [a, b] = commandMul [a, b] =
@ -554,5 +516,3 @@ commandMul [a, b] =
Right (XObj (Num IntTy (aNum * bNum)) (Just dummyInfo) (Just IntTy)) Right (XObj (Num IntTy (aNum * bNum)) (Just dummyInfo) (Just IntTy))
_ -> _ ->
Left (EvalError ("Can't call * with " ++ pretty a ++ " and " ++ pretty b)) Left (EvalError ("Can't call * with " ++ pretty a ++ " and " ++ pretty b))
commandMul args =
return (Left (EvalError ("Invalid args to '*': " ++ joinWithComma (map pretty args))))