mirror of
https://github.com/carp-lang/Carp.git
synced 2024-10-11 04:27:55 +03:00
compiler: simplified error handling in commands
This commit is contained in:
parent
48d1858b28
commit
b3dcd0311d
74
app/Main.hs
74
app/Main.hs
@ -137,48 +137,48 @@ arrayModule = Env { envBindings = bindings, envParent = Nothing, envModuleName =
|
||||
|
||||
dynamicStringModule :: Env
|
||||
dynamicStringModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "String", envUseModules = [], envMode = ExternalEnv }
|
||||
where bindings = Map.fromList [ addCommand "char-at" (CommandFunction commandCharAt)
|
||||
, addCommand "index-of" (CommandFunction commandIndexOf)
|
||||
, addCommand "substring" (CommandFunction commandSubstring)
|
||||
, addCommand "count" (CommandFunction commandStringCount)
|
||||
where bindings = Map.fromList [ addCommand "char-at" 2 commandCharAt
|
||||
, addCommand "index-of" 2 commandIndexOf
|
||||
, addCommand "substring" 3 commandSubstring
|
||||
, addCommand "count" 1 commandStringCount
|
||||
]
|
||||
|
||||
dynamicModule :: Env
|
||||
dynamicModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "Dynamic", envUseModules = [], envMode = ExternalEnv }
|
||||
where bindings = Map.fromList $
|
||||
[ addCommand "list?" (CommandFunction commandIsList)
|
||||
, addCommand "count" (CommandFunction commandCount)
|
||||
, addCommand "car" (CommandFunction commandCar)
|
||||
, addCommand "cdr" (CommandFunction commandCdr)
|
||||
, addCommand "last" (CommandFunction commandLast)
|
||||
, addCommand "all-but-last" (CommandFunction commandAllButLast)
|
||||
, addCommand "cons" (CommandFunction commandCons)
|
||||
, addCommand "cons-last" (CommandFunction commandConsLast)
|
||||
, addCommand "append" (CommandFunction commandAppend)
|
||||
, addCommand "macro-error" (CommandFunction commandMacroError)
|
||||
, addCommand "=" (CommandFunction commandEq)
|
||||
, addCommand "<" (CommandFunction commandLt)
|
||||
, addCommand ">" (CommandFunction commandGt)
|
||||
, addCommand "+" (CommandFunction commandPlus)
|
||||
, addCommand "-" (CommandFunction commandMinus)
|
||||
, addCommand "/" (CommandFunction commandDiv)
|
||||
, addCommand "*" (CommandFunction commandMul)
|
||||
, addCommand "c" (CommandFunction commandC)
|
||||
, addCommand "quit" (CommandFunction commandQuit)
|
||||
, addCommand "cat" (CommandFunction commandCat)
|
||||
, addCommand "run" (CommandFunction commandRunExe)
|
||||
, addCommand "build" (CommandFunction commandBuild)
|
||||
, addCommand "reload" (CommandFunction commandReload)
|
||||
, addCommand "env" (CommandFunction commandListBindings)
|
||||
, addCommand "help" (CommandFunction commandHelp)
|
||||
, addCommand "project" (CommandFunction commandProject)
|
||||
, addCommand "load" (CommandFunction commandLoad)
|
||||
, addCommand "macro-log" (CommandFunction commandPrint)
|
||||
, addCommand "expand" (CommandFunction commandExpand)
|
||||
, addCommand "project-set!" (CommandFunction commandProjectSet)
|
||||
, addCommand "os" (CommandFunction commandOS)
|
||||
, addCommand "system-include" (CommandFunction commandAddSystemInclude)
|
||||
, addCommand "local-include" (CommandFunction commandAddLocalInclude)
|
||||
[ addCommand "list?" 1 commandIsList
|
||||
, addCommand "count" 1 commandCount
|
||||
, addCommand "car" 1 commandCar
|
||||
, addCommand "cdr" 1 commandCdr
|
||||
, addCommand "last" 1 commandLast
|
||||
, addCommand "all-but-last" 1 commandAllButLast
|
||||
, addCommand "cons" 2 commandCons
|
||||
, addCommand "cons-last" 2 commandConsLast
|
||||
, addCommand "append" 2 commandAppend
|
||||
, addCommand "macro-error" 1 commandMacroError
|
||||
, addCommand "=" 2 commandEq
|
||||
, addCommand "<" 2 commandLt
|
||||
, addCommand ">" 2 commandGt
|
||||
, addCommand "+" 2 commandPlus
|
||||
, addCommand "-" 2 commandMinus
|
||||
, addCommand "/" 2 commandDiv
|
||||
, addCommand "*" 2 commandMul
|
||||
, addCommand "c" 1 commandC
|
||||
, addCommand "quit" 0 commandQuit
|
||||
, addCommand "cat" 0 commandCat
|
||||
, addCommand "run" 0 commandRunExe
|
||||
, addCommand "build" 0 commandBuild
|
||||
, addCommand "reload" 0 commandReload
|
||||
, addCommand "env" 0 commandListBindings
|
||||
, addCommand "help" 1 commandHelp
|
||||
, addCommand "project" 0 commandProject
|
||||
, addCommand "load" 1 commandLoad
|
||||
, addCommand "macro-log" 1 commandPrint
|
||||
, addCommand "expand" 1 commandExpand
|
||||
, addCommand "project-set!" 2 commandProjectSet
|
||||
, addCommand "os" 0 commandOS
|
||||
, addCommand "system-include" 1 commandAddSystemInclude
|
||||
, addCommand "local-include" 1 commandAddLocalInclude
|
||||
]
|
||||
++ [("String", Binder (XObj (Mod dynamicStringModule) Nothing Nothing))]
|
||||
|
||||
|
@ -42,14 +42,18 @@ falseXObj :: XObj
|
||||
falseXObj = XObj (Bol False) Nothing Nothing
|
||||
|
||||
-- | Use this function to register commands in the environment.
|
||||
addCommand :: String -> CommandFunctionType -> (String, Binder)
|
||||
addCommand name callback =
|
||||
addCommand :: String -> Int -> CommandCallback -> (String, Binder)
|
||||
addCommand name arity callback =
|
||||
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
|
||||
])
|
||||
(Just dummyInfo) (Just DynamicTy)
|
||||
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.
|
||||
commandProjectSet :: CommandCallback
|
||||
@ -74,8 +78,6 @@ commandProjectSet [XObj (Str key) _ _, value] =
|
||||
val -> err "Argument to project-set! must be a string" dynamicNil
|
||||
where err msg ret = liftIO $ do putStrLnWithColor Red msg
|
||||
return ret
|
||||
commandProjectSet args =
|
||||
return (Left (EvalError ("Invalid args to 'project-set!' command: " ++ joinWithComma (map pretty args))))
|
||||
|
||||
-- | Command for exiting the REPL/compiler
|
||||
commandQuit :: CommandCallback
|
||||
@ -330,8 +332,6 @@ commandIsList [x] =
|
||||
case x of
|
||||
XObj (Lst _) _ _ -> return (Right trueXObj)
|
||||
_ -> return (Right falseXObj)
|
||||
commandIsList args =
|
||||
return (Left (EvalError ("Invalid args to 'list?': " ++ joinWithComma (map pretty args))))
|
||||
|
||||
commandCount :: CommandCallback
|
||||
commandCount [x] =
|
||||
@ -339,8 +339,6 @@ commandCount [x] =
|
||||
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))
|
||||
_ -> 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 [x] =
|
||||
@ -348,8 +346,6 @@ commandCar [x] =
|
||||
XObj (Lst (car : _)) _ _ -> return (Right car)
|
||||
XObj (Arr (car : _)) _ _ -> return (Right car)
|
||||
_ -> 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 [x] =
|
||||
@ -357,8 +353,6 @@ commandCdr [x] =
|
||||
XObj (Lst (_ : cdr)) _ _ -> return (Right (XObj (Lst cdr) Nothing Nothing))
|
||||
XObj (Arr (_ : cdr)) _ _ -> return (Right (XObj (Arr cdr) Nothing Nothing))
|
||||
_ -> 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 [x] =
|
||||
@ -366,8 +360,6 @@ commandLast [x] =
|
||||
XObj (Lst lst) _ _ -> return (Right (last lst))
|
||||
XObj (Arr arr) _ _ -> return (Right (last arr))
|
||||
_ -> 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 [x] =
|
||||
@ -375,24 +367,18 @@ commandAllButLast [x] =
|
||||
XObj (Lst lst) _ _ -> return (Right (XObj (Lst (init lst)) 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."))
|
||||
commandAllButLast args =
|
||||
return (Left (EvalError ("Invalid args to 'all-but-last': " ++ joinWithComma (map pretty args))))
|
||||
|
||||
commandCons :: CommandCallback
|
||||
commandCons [x, xs] =
|
||||
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'?
|
||||
_ -> 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 [x, xs] =
|
||||
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
|
||||
_ -> 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 [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 (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 [msg] =
|
||||
case msg of
|
||||
XObj (Str msg) _ _ -> return (Left (EvalError msg))
|
||||
_ -> 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 [a, b] =
|
||||
@ -433,8 +415,6 @@ commandEq [a, b] =
|
||||
if sa == sb then Right trueXObj else Right falseXObj
|
||||
_ ->
|
||||
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 [a, b] =
|
||||
@ -453,8 +433,6 @@ commandLt [a, b] =
|
||||
then Right trueXObj else Right falseXObj
|
||||
_ ->
|
||||
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 [a, b] =
|
||||
@ -473,8 +451,6 @@ commandGt [a, b] =
|
||||
then Right trueXObj else Right falseXObj
|
||||
_ ->
|
||||
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 [a, b] =
|
||||
@ -483,8 +459,6 @@ commandCharAt [a, b] =
|
||||
Right (XObj (Chr (s !! (round n :: Int))) (Just dummyInfo) (Just IntTy))
|
||||
_ ->
|
||||
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 [a, b] =
|
||||
@ -494,8 +468,6 @@ commandIndexOf [a, b] =
|
||||
_ ->
|
||||
Left (EvalError ("Can't call index-of with " ++ pretty a ++ " and " ++ pretty b))
|
||||
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 [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))
|
||||
_ ->
|
||||
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 [a] =
|
||||
@ -514,8 +484,6 @@ commandStringCount [a] =
|
||||
Right (XObj (Num IntTy (fromIntegral (length s))) (Just dummyInfo) (Just IntTy))
|
||||
_ ->
|
||||
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 [a, b] =
|
||||
@ -524,8 +492,6 @@ commandPlus [a, b] =
|
||||
Right (XObj (Num IntTy (aNum + bNum)) (Just dummyInfo) (Just IntTy))
|
||||
_ ->
|
||||
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 [a, b] =
|
||||
@ -534,8 +500,6 @@ commandMinus [a, b] =
|
||||
Right (XObj (Num IntTy (aNum - bNum)) (Just dummyInfo) (Just IntTy))
|
||||
_ ->
|
||||
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 [a, b] =
|
||||
@ -544,8 +508,6 @@ commandDiv [a, b] =
|
||||
Right (XObj (Num IntTy (aNum / bNum)) (Just dummyInfo) (Just IntTy))
|
||||
_ ->
|
||||
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 [a, b] =
|
||||
@ -554,5 +516,3 @@ commandMul [a, b] =
|
||||
Right (XObj (Num IntTy (aNum * bNum)) (Just dummyInfo) (Just IntTy))
|
||||
_ ->
|
||||
Left (EvalError ("Can't call * with " ++ pretty a ++ " and " ++ pretty b))
|
||||
commandMul args =
|
||||
return (Left (EvalError ("Invalid args to '*': " ++ joinWithComma (map pretty args))))
|
||||
|
Loading…
Reference in New Issue
Block a user