mirror of
https://github.com/carp-lang/Carp.git
synced 2024-11-04 01:25:04 +03:00
compiler: better error messages
This commit is contained in:
hellerve
parent
19bf708312
commit
6716edf2af
@ -60,6 +60,7 @@ library
|
||||
, text
|
||||
, ansi-terminal >= 0.9
|
||||
, cmark
|
||||
, edit-distance
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
|
||||
@ -65,7 +65,7 @@ addCommandConfigurable name maybeArity callback =
|
||||
withArity arity args =
|
||||
if length args == arity
|
||||
then callback args
|
||||
else return (Left (EvalError ("Invalid args to '" ++ name ++ "' command: " ++ joinWithComma (map pretty args))))
|
||||
else return (Left (EvalError ("Invalid args to '" ++ name ++ "' command: " ++ joinWithComma (map pretty args)) Nothing))
|
||||
withoutArity args =
|
||||
callback args
|
||||
|
||||
@ -175,7 +175,7 @@ commandProjectGetConfig [xobj@(XObj (Str key) _ _)] =
|
||||
"file-path-print-length" -> Right $ Str $ show (projectFilePathPrintLength proj)
|
||||
_ ->
|
||||
Left $ EvalError ("[CONFIG ERROR] Project.get-config can't understand the key '" ++
|
||||
key ++ "' at " ++ prettyInfoFromXObj xobj ++ ".")
|
||||
key) (info xobj)
|
||||
commandProjectGetConfig [faultyKey] =
|
||||
do presentError ("First argument to 'Project.config' must be a string: " ++ pretty faultyKey) dynamicNil
|
||||
|
||||
@ -229,7 +229,10 @@ commandBuild args =
|
||||
)
|
||||
case src of
|
||||
Left err ->
|
||||
return (Left (EvalError ("[CODEGEN ERROR] " ++ show err)))
|
||||
return (Left (EvalError
|
||||
("I encountered an error when emitting code:\n\n" ++
|
||||
(show err))
|
||||
Nothing))
|
||||
Right okSrc ->
|
||||
do let compiler = projectCompiler proj
|
||||
echoCompilationCommand = projectEchoCompilationCommand proj
|
||||
@ -506,48 +509,48 @@ commandLength [x] =
|
||||
case x of
|
||||
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 'length' to non-list: " ++ pretty x ++ " at " ++ prettyInfoFromXObj x)))
|
||||
_ -> return (Left (EvalError ("Applying 'length' to non-list: " ++ pretty x) (info x)))
|
||||
|
||||
commandCar :: CommandCallback
|
||||
commandCar [x] =
|
||||
case x of
|
||||
XObj (Lst (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) (info x)))
|
||||
|
||||
commandCdr :: CommandCallback
|
||||
commandCdr [x] =
|
||||
case x of
|
||||
XObj (Lst (_ : cdr)) i _ -> return (Right (XObj (Lst cdr) i Nothing))
|
||||
XObj (Arr (_ : cdr)) i _ -> return (Right (XObj (Arr cdr) i Nothing))
|
||||
_ -> return (Left (EvalError "Applying 'cdr' to non-list or empty list"))
|
||||
_ -> return (Left (EvalError "Applying 'cdr' to non-list or empty list" (info x)))
|
||||
|
||||
commandLast :: CommandCallback
|
||||
commandLast [x] =
|
||||
case x of
|
||||
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."))
|
||||
_ -> return (Left (EvalError "Applying 'last' to non-list or empty list." (info x)))
|
||||
|
||||
commandAllButLast :: CommandCallback
|
||||
commandAllButLast [x] =
|
||||
case x of
|
||||
XObj (Lst lst) i _ -> return (Right (XObj (Lst (init lst)) i Nothing))
|
||||
XObj (Arr arr) i _ -> return (Right (XObj (Arr (init arr)) i 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." (info x)))
|
||||
|
||||
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'?
|
||||
XObj (Arr arr) _ _ -> return (Right (XObj (Arr (x : arr)) (info x) (ty x)))
|
||||
_ -> return (Left (EvalError "Applying 'cons' to non-list or empty list."))
|
||||
_ -> return (Left (EvalError "Applying 'cons' to non-list or empty list." (info x)))
|
||||
|
||||
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."))
|
||||
_ -> return (Left (EvalError "Applying 'cons-last' to non-list or empty list." (info x)))
|
||||
|
||||
commandAppend :: CommandCallback
|
||||
commandAppend [xs, ys] =
|
||||
@ -555,13 +558,13 @@ commandAppend [xs, ys] =
|
||||
(XObj (Lst lst1) i t, XObj (Lst lst2) _ _) ->
|
||||
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." (info xs)))
|
||||
|
||||
commandMacroError :: CommandCallback
|
||||
commandMacroError [msg] =
|
||||
case msg of
|
||||
XObj (Str msg) _ _ -> return (Left (EvalError msg))
|
||||
x -> return (Left (EvalError (pretty x)))
|
||||
XObj (Str smsg) _ _ -> return (Left (EvalError smsg (info msg)))
|
||||
x -> return (Left (EvalError (pretty x) (info msg)))
|
||||
|
||||
commandMacroLog :: CommandCallback
|
||||
commandMacroLog [msg] =
|
||||
@ -597,7 +600,7 @@ commandEq [a, b] =
|
||||
(XObj (Lst []) _ _, XObj (Lst []) _ _) ->
|
||||
Right trueXObj
|
||||
_ ->
|
||||
Left (EvalError ("Can't compare " ++ pretty a ++ " with " ++ pretty b))
|
||||
Left (EvalError ("Can't compare " ++ pretty a ++ " with " ++ pretty b) (info a))
|
||||
|
||||
commandLt :: CommandCallback
|
||||
commandLt [a, b] =
|
||||
@ -615,7 +618,7 @@ commandLt [a, b] =
|
||||
if aNum < bNum
|
||||
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) (info a))
|
||||
|
||||
commandGt :: CommandCallback
|
||||
commandGt [a, b] =
|
||||
@ -633,7 +636,7 @@ commandGt [a, b] =
|
||||
if aNum > bNum
|
||||
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) (info a))
|
||||
|
||||
commandCharAt :: CommandCallback
|
||||
commandCharAt [a, b] =
|
||||
@ -641,7 +644,7 @@ commandCharAt [a, b] =
|
||||
(XObj (Str s) _ _, XObj (Num IntTy n) _ _) ->
|
||||
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) (info a))
|
||||
|
||||
commandIndexOf :: CommandCallback
|
||||
commandIndexOf [a, b] =
|
||||
@ -649,7 +652,7 @@ commandIndexOf [a, b] =
|
||||
(XObj (Str s) _ _, XObj (Chr c) _ _) ->
|
||||
Right (XObj (Num IntTy (getIdx c s)) (Just dummyInfo) (Just IntTy))
|
||||
_ ->
|
||||
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) (info a))
|
||||
where getIdx c s = fromIntegral $ fromMaybe (-1) $ elemIndex c s
|
||||
|
||||
commandSubstring :: CommandCallback
|
||||
@ -658,7 +661,7 @@ commandSubstring [a, b, c] =
|
||||
(XObj (Str s) _ _, XObj (Num IntTy f) _ _, XObj (Num IntTy t) _ _) ->
|
||||
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) (info a))
|
||||
|
||||
commandStringLength :: CommandCallback
|
||||
commandStringLength [a] =
|
||||
@ -666,17 +669,17 @@ commandStringLength [a] =
|
||||
XObj (Str s) _ _ ->
|
||||
Right (XObj (Num IntTy (fromIntegral (length s))) (Just dummyInfo) (Just IntTy))
|
||||
_ ->
|
||||
Left (EvalError ("Can't call length with " ++ pretty a))
|
||||
Left (EvalError ("Can't call length with " ++ pretty a) (info a))
|
||||
|
||||
commandStringJoin :: CommandCallback
|
||||
commandStringJoin [a] =
|
||||
return $ case a of
|
||||
XObj (Arr strings) _ _ ->
|
||||
case (sequence (map unwrapStringXObj strings)) of
|
||||
Left err -> Left (EvalError err)
|
||||
Left err -> Left (EvalError err (info a))
|
||||
Right result -> Right (XObj (Str (join result)) (Just dummyInfo) (Just StringTy))
|
||||
_ ->
|
||||
Left (EvalError ("Can't call join with " ++ pretty a))
|
||||
Left (EvalError ("Can't call join with " ++ pretty a) (info a))
|
||||
|
||||
commandStringDirectory :: CommandCallback
|
||||
commandStringDirectory [a] =
|
||||
@ -684,7 +687,7 @@ commandStringDirectory [a] =
|
||||
XObj (Str s) _ _ ->
|
||||
Right (XObj (Str (takeDirectory s)) (Just dummyInfo) (Just StringTy))
|
||||
_ ->
|
||||
Left (EvalError ("Can't call directory with " ++ pretty a))
|
||||
Left (EvalError ("Can't call directory with " ++ pretty a) (info a))
|
||||
|
||||
commandPlus :: CommandCallback
|
||||
commandPlus [a, b] =
|
||||
@ -692,9 +695,9 @@ commandPlus [a, b] =
|
||||
(XObj (Num aty aNum) _ _, XObj (Num bty bNum) _ _) ->
|
||||
if aty == bty
|
||||
then Right (XObj (Num aty (aNum + bNum)) (Just dummyInfo) (Just aty))
|
||||
else Left (EvalError ("Can't call + with " ++ pretty a ++ " and " ++ pretty b))
|
||||
else Left (EvalError ("Can't call + with " ++ pretty a ++ " and " ++ pretty b) (info a))
|
||||
_ ->
|
||||
Left (EvalError ("Can't call + with " ++ pretty a ++ " and " ++ pretty b))
|
||||
Left (EvalError ("Can't call + with " ++ pretty a ++ " and " ++ pretty b) (info a))
|
||||
|
||||
commandMinus :: CommandCallback
|
||||
commandMinus [a, b] =
|
||||
@ -702,9 +705,9 @@ commandMinus [a, b] =
|
||||
(XObj (Num aty aNum) _ _, XObj (Num bty bNum) _ _) ->
|
||||
if aty == bty
|
||||
then Right (XObj (Num aty (aNum - bNum)) (Just dummyInfo) (Just aty))
|
||||
else Left (EvalError ("Can't call - with " ++ pretty a ++ " and " ++ pretty b))
|
||||
else Left (EvalError ("Can't call - with " ++ pretty a ++ " and " ++ pretty b) (info a))
|
||||
_ ->
|
||||
Left (EvalError ("Can't call - with " ++ pretty a ++ " and " ++ pretty b))
|
||||
Left (EvalError ("Can't call - with " ++ pretty a ++ " and " ++ pretty b) (info a))
|
||||
|
||||
commandDiv :: CommandCallback
|
||||
commandDiv [a, b] =
|
||||
@ -714,9 +717,9 @@ commandDiv [a, b] =
|
||||
(XObj (Num aty aNum) _ _, XObj (Num bty bNum) _ _) ->
|
||||
if aty == bty
|
||||
then Right (XObj (Num aty (aNum / bNum)) (Just dummyInfo) (Just aty))
|
||||
else Left (EvalError ("Can't call / with " ++ pretty a ++ " and " ++ pretty b))
|
||||
else Left (EvalError ("Can't call / with " ++ pretty a ++ " and " ++ pretty b) (info a))
|
||||
_ ->
|
||||
Left (EvalError ("Can't call / with " ++ pretty a ++ " and " ++ pretty b))
|
||||
Left (EvalError ("Can't call / with " ++ pretty a ++ " and " ++ pretty b) (info a))
|
||||
|
||||
commandMul :: CommandCallback
|
||||
commandMul [a, b] =
|
||||
@ -724,9 +727,9 @@ commandMul [a, b] =
|
||||
(XObj (Num aty aNum) _ _, XObj (Num bty bNum) _ _) ->
|
||||
if aty == bty
|
||||
then Right (XObj (Num aty (aNum * bNum)) (Just dummyInfo) (Just aty))
|
||||
else Left (EvalError ("Can't call * with " ++ pretty a ++ " and " ++ pretty b))
|
||||
else Left (EvalError ("Can't call * with " ++ pretty a ++ " and " ++ pretty b) (info a))
|
||||
_ ->
|
||||
Left (EvalError ("Can't call * with " ++ pretty a ++ " and " ++ pretty b))
|
||||
Left (EvalError ("Can't call * with " ++ pretty a ++ " and " ++ pretty b) (info a))
|
||||
|
||||
commandStr :: CommandCallback
|
||||
commandStr xs =
|
||||
@ -747,7 +750,7 @@ commandNot [x] =
|
||||
then return (Right falseXObj)
|
||||
else return (Right trueXObj)
|
||||
_ ->
|
||||
return (Left (EvalError ("Can't perform logical operation (not) on " ++ pretty x)))
|
||||
return (Left (EvalError ("Can't perform logical operation (not) on " ++ pretty x) (info x)))
|
||||
|
||||
commandSaveDocsInternal :: CommandCallback
|
||||
commandSaveDocsInternal [modulePath] =
|
||||
@ -756,22 +759,22 @@ commandSaveDocsInternal [modulePath] =
|
||||
case modulePath of
|
||||
XObj (Lst xobjs) _ _ ->
|
||||
case sequence (map unwrapSymPathXObj xobjs) of
|
||||
Left err -> return (Left (EvalError err))
|
||||
Left err -> return (Left (EvalError err (info modulePath)))
|
||||
Right okPaths ->
|
||||
case sequence (map (getEnvironmentForDocumentation globalEnv) okPaths) of
|
||||
Left err -> return (Left err)
|
||||
Right okEnvs -> saveDocs (zip okPaths okEnvs)
|
||||
x ->
|
||||
return (Left (EvalError ("Invalid arg to save-docs-internal (expected list of symbols): " ++ pretty x)))
|
||||
return (Left (EvalError ("Invalid arg to save-docs-internal (expected list of symbols): " ++ pretty x) (info modulePath)))
|
||||
where getEnvironmentForDocumentation :: Env -> SymPath -> Either EvalError Env
|
||||
getEnvironmentForDocumentation env path =
|
||||
case lookupInEnv path env of
|
||||
Just (_, Binder _ (XObj (Mod foundEnv) _ _)) ->
|
||||
Right foundEnv
|
||||
Just (_, Binder _ x) ->
|
||||
Left (EvalError ("Non module can't be saved: " ++ pretty x))
|
||||
Left (EvalError ("Non module can't be saved: " ++ pretty x) (info modulePath))
|
||||
Nothing ->
|
||||
Left (EvalError ("Can't find module at '" ++ show path ++ "'"))
|
||||
Left (EvalError ("Can't find module at '" ++ show path ++ "'") (info modulePath))
|
||||
|
||||
saveDocs :: [(SymPath, Env)] -> StateT Context IO (Either EvalError XObj)
|
||||
saveDocs pathsAndEnvs =
|
||||
|
||||
105
src/Emit.hs
105
src/Emit.hs
@ -32,10 +32,10 @@ indentAmount = 4
|
||||
|
||||
data ToCError = InvalidParameter XObj
|
||||
| InvalidList XObj
|
||||
| DontVisitObj Obj
|
||||
| CannotEmitUnit
|
||||
| CannotEmitExternal
|
||||
| CannotEmitModKeyword
|
||||
| DontVisitObj XObj
|
||||
| CannotEmitUnit XObj
|
||||
| CannotEmitExternal XObj
|
||||
| CannotEmitModKeyword XObj
|
||||
| BinderIsMissingType Binder
|
||||
| UnresolvedMultiSymbol XObj
|
||||
| UnresolvedInterfaceSymbol XObj
|
||||
@ -43,23 +43,40 @@ data ToCError = InvalidParameter XObj
|
||||
| CannotSet XObj
|
||||
|
||||
instance Show ToCError where
|
||||
show (InvalidParameter xobj) = "Invalid parameter: " ++ show (obj xobj)
|
||||
show (InvalidList xobj) = "Invalid list: " ++ show (obj xobj)
|
||||
show (DontVisitObj o) = "Don't visit " ++ show o ++ " (internal compiler error)."
|
||||
show CannotEmitUnit = "Can't emit code for empty list: ()"
|
||||
show CannotEmitExternal = "Can't emit code for external function/variable."
|
||||
show CannotEmitModKeyword = "Can't emit code for Mod."
|
||||
show (BinderIsMissingType b) = "Binder is missing type: " ++ show b
|
||||
show (InvalidParameter xobj) =
|
||||
"I encountered an invalid parameter `" ++ show (obj xobj) ++ "` at " ++
|
||||
prettyInfoFromXObj xobj ++ "."
|
||||
show (InvalidList xobj) =
|
||||
"I encountered an invalid list `" ++ show (obj xobj) ++ "` at " ++
|
||||
prettyInfoFromXObj xobj ++ "."
|
||||
show (DontVisitObj xobj) =
|
||||
"I can’t visit " ++ show (obj xobj) ++ " at " ++ prettyInfoFromXObj xobj ++
|
||||
"."
|
||||
show (CannotEmitUnit xobj) =
|
||||
"I can't emit code for the unit type `()` at" ++ prettyInfoFromXObj xobj ++
|
||||
"."
|
||||
show (CannotEmitExternal xobj) =
|
||||
"I can’t emit code for the external function/variable `" ++
|
||||
show (obj xobj) ++ "` at " ++ prettyInfoFromXObj xobj ++ "."
|
||||
show (CannotEmitModKeyword xobj) =
|
||||
"I can’t emit code for the module `" ++ show (obj xobj) ++ "` at " ++
|
||||
prettyInfoFromXObj xobj ++ "."
|
||||
show (BinderIsMissingType b) =
|
||||
"I encountered a binder `" ++ show b ++ "` that is missing its type."
|
||||
show (UnresolvedMultiSymbol xobj@(XObj (MultiSym symName symPaths) _ _)) =
|
||||
"Found ambiguous symbol '" ++ symName ++
|
||||
"' (alternatives are " ++ joinWithComma (map show symPaths) ++ ")" ++
|
||||
" at " ++ prettyInfoFromXObj xobj
|
||||
"I found an ambiguous symbol `" ++ symName ++
|
||||
"` at " ++ prettyInfoFromXObj xobj ++ "\n\nPossibilities:\n " ++
|
||||
joinWith "\n " (map show symPaths) ++
|
||||
"\n\nAll possibilities have the correct type."
|
||||
show (UnresolvedInterfaceSymbol xobj@(XObj (InterfaceSym symName) _ _)) =
|
||||
"Found unresolved use of interface '" ++ symName ++ "'" ++
|
||||
" at " ++ prettyInfoFromXObj xobj
|
||||
"I found an interface `" ++ symName ++
|
||||
"` that is unresolved in the context at" ++ prettyInfoFromXObj xobj
|
||||
show (UnresolvedGenericType xobj@(XObj _ _ (Just t))) =
|
||||
"Found unresolved generic type '" ++ show t ++ "' at " ++ prettyInfoFromXObj xobj
|
||||
show (CannotSet xobj) = "Can't emit code for setting " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj
|
||||
"I found an unresolved generic type `" ++ show t ++
|
||||
"` for the expression `" ++ show xobj ++ "` at " ++ prettyInfoFromXObj xobj
|
||||
show (CannotSet xobj) =
|
||||
"I can’t emit code for setting `" ++ pretty xobj ++ "` at " ++
|
||||
prettyInfoFromXObj xobj ++ "\n\nOnly variables can be reset using `set!`."
|
||||
|
||||
data ToCMode = Functions | Globals | All deriving Show
|
||||
|
||||
@ -93,32 +110,32 @@ toC toCMode root = emitterSrc (execState (visit startingIndent root) (EmitterSta
|
||||
'\\' -> "'\\\\'"
|
||||
x -> ['\'', x, '\'']
|
||||
Sym _ _ -> visitSymbol indent xobj
|
||||
Defn -> error (show (DontVisitObj Defn))
|
||||
Def -> error (show (DontVisitObj Def))
|
||||
Let -> error (show (DontVisitObj Let))
|
||||
If -> error (show (DontVisitObj If))
|
||||
Break -> error (show (DontVisitObj Break))
|
||||
While -> error (show (DontVisitObj While))
|
||||
Do -> error (show (DontVisitObj Do))
|
||||
e@(Typ _) -> error (show (DontVisitObj e))
|
||||
e@(DefSumtype _) -> error (show (DontVisitObj e))
|
||||
Mod _ -> error (show CannotEmitModKeyword)
|
||||
External _ -> error (show CannotEmitExternal)
|
||||
ExternalType -> error (show (DontVisitObj ExternalType))
|
||||
e@(Command _) -> error (show (DontVisitObj e))
|
||||
e@(Deftemplate _) -> error (show (DontVisitObj e))
|
||||
e@(Instantiate _) -> error (show (DontVisitObj e))
|
||||
e@(Defalias _) -> error (show (DontVisitObj e))
|
||||
e@(MultiSym _ _) -> error (show (DontVisitObj e))
|
||||
e@(InterfaceSym _) -> error (show (DontVisitObj e))
|
||||
Address -> error (show (DontVisitObj Address))
|
||||
SetBang -> error (show (DontVisitObj SetBang))
|
||||
Macro -> error (show (DontVisitObj Macro))
|
||||
Dynamic -> error (show (DontVisitObj Dynamic))
|
||||
The -> error (show (DontVisitObj The))
|
||||
Ref -> error (show (DontVisitObj Ref))
|
||||
Deref -> error (show (DontVisitObj Deref))
|
||||
e@(Interface _ _) -> error (show (DontVisitObj e))
|
||||
Defn -> error (show (DontVisitObj xobj))
|
||||
Def -> error (show (DontVisitObj xobj))
|
||||
Let -> error (show (DontVisitObj xobj))
|
||||
If -> error (show (DontVisitObj xobj))
|
||||
Break -> error (show (DontVisitObj xobj))
|
||||
While -> error (show (DontVisitObj xobj))
|
||||
Do -> error (show (DontVisitObj xobj))
|
||||
e@(Typ _) -> error (show (DontVisitObj xobj))
|
||||
e@(DefSumtype _) -> error (show (DontVisitObj xobj))
|
||||
Mod _ -> error (show (CannotEmitModKeyword xobj))
|
||||
External _ -> error (show (CannotEmitExternal xobj))
|
||||
ExternalType -> error (show (DontVisitObj xobj))
|
||||
e@(Command _) -> error (show (DontVisitObj xobj))
|
||||
e@(Deftemplate _) -> error (show (DontVisitObj xobj))
|
||||
e@(Instantiate _) -> error (show (DontVisitObj xobj))
|
||||
e@(Defalias _) -> error (show (DontVisitObj xobj))
|
||||
e@(MultiSym _ _) -> error (show (DontVisitObj xobj))
|
||||
e@(InterfaceSym _) -> error (show (DontVisitObj xobj))
|
||||
Address -> error (show (DontVisitObj xobj))
|
||||
SetBang -> error (show (DontVisitObj xobj))
|
||||
Macro -> error (show (DontVisitObj xobj))
|
||||
Dynamic -> error (show (DontVisitObj xobj))
|
||||
The -> error (show (DontVisitObj xobj))
|
||||
Ref -> error (show (DontVisitObj xobj))
|
||||
Deref -> error (show (DontVisitObj xobj))
|
||||
e@(Interface _ _) -> error (show (DontVisitObj xobj))
|
||||
|
||||
visitStr' indent str i =
|
||||
-- | This will allocate a new string every time the code runs:
|
||||
|
||||
136
src/Eval.hs
136
src/Eval.hs
@ -59,40 +59,40 @@ eval env xobj =
|
||||
[XObj (Sym (SymPath [] "file") _) _ _] ->
|
||||
case i of
|
||||
Just info -> return (Right (XObj (Str (infoFile info)) i t))
|
||||
Nothing -> return (Left (EvalError ("No information about object " ++ pretty xobj)))
|
||||
Nothing -> return (Left (EvalError ("No information about object " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "line") _) _ _] ->
|
||||
case i of
|
||||
Just info ->
|
||||
return (Right (XObj (Num IntTy (fromIntegral (infoLine info))) i t))
|
||||
Nothing ->
|
||||
return (Left (EvalError ("No information about object " ++ pretty xobj)))
|
||||
return (Left (EvalError ("No information about object " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "column") _) _ _] ->
|
||||
case i of
|
||||
Just info ->
|
||||
return (Right (XObj (Num IntTy (fromIntegral (infoColumn info))) i t))
|
||||
Nothing ->
|
||||
return (Left (EvalError ("No information about object " ++ pretty xobj)))
|
||||
return (Left (EvalError ("No information about object " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "file") _) _ _, XObj _ infoToCheck _] ->
|
||||
case infoToCheck of
|
||||
Just info -> return (Right (XObj (Str (infoFile info)) i t))
|
||||
Nothing -> return (Left (EvalError ("No information about object " ++ pretty xobj)))
|
||||
Nothing -> return (Left (EvalError ("No information about object " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "line") _) _ _, XObj _ infoToCheck _] ->
|
||||
case infoToCheck of
|
||||
Just info ->
|
||||
return (Right (XObj (Num IntTy (fromIntegral (infoLine info))) i t))
|
||||
Nothing ->
|
||||
return (Left (EvalError ("No information about object " ++ pretty xobj)))
|
||||
return (Left (EvalError ("No information about object " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "column") _) _ _, XObj _ infoToCheck _] ->
|
||||
case infoToCheck of
|
||||
Just info ->
|
||||
return (Right (XObj (Num IntTy (fromIntegral (infoColumn info))) i t))
|
||||
Nothing ->
|
||||
return (Left (EvalError ("No information about object " ++ pretty xobj)))
|
||||
return (Left (EvalError ("No information about object " ++ pretty xobj) (info xobj)))
|
||||
|
||||
XObj Do _ _ : rest ->
|
||||
do evaledList <- fmap sequence (mapM (eval env) rest)
|
||||
@ -100,7 +100,7 @@ eval env xobj =
|
||||
Left e -> return (Left e)
|
||||
Right ok ->
|
||||
case ok of
|
||||
[] -> return (Left (EvalError "No forms in 'do' statement."))
|
||||
[] -> return (Left (EvalError "No forms in 'do' statement." (info xobj)))
|
||||
_ -> return (Right (last ok))
|
||||
|
||||
XObj (Sym (SymPath [] "list") _) _ _ : rest ->
|
||||
@ -126,10 +126,10 @@ eval env xobj =
|
||||
XObj (Bol bb) _ _ ->
|
||||
if bb then Right trueXObj else Right falseXObj
|
||||
_ ->
|
||||
Left (EvalError ("Can't perform logical operation (and) on " ++ pretty okB))
|
||||
Left (EvalError ("Can't perform logical operation (and) on " ++ pretty okB) (info okB))
|
||||
else Right falseXObj
|
||||
_ ->
|
||||
Left (EvalError ("Can't perform logical operation (and) on " ++ pretty okA))
|
||||
Left (EvalError ("Can't perform logical operation (and) on " ++ pretty okA) (info okA))
|
||||
|
||||
[XObj (Sym (SymPath ["Dynamic"] "or") _) _ _, a, b] ->
|
||||
do evaledA <- eval env a
|
||||
@ -144,9 +144,9 @@ eval env xobj =
|
||||
XObj (Bol bb) _ _ ->
|
||||
if bb then Right trueXObj else Right falseXObj
|
||||
_ ->
|
||||
Left (EvalError ("Can't perform logical operation (or) on " ++ pretty okB))
|
||||
Left (EvalError ("Can't perform logical operation (or) on " ++ pretty okB) (info okB))
|
||||
_ ->
|
||||
Left (EvalError ("Can't perform logical operation (or) on " ++ pretty okA))
|
||||
Left (EvalError ("Can't perform logical operation (or) on " ++ pretty okA) (info okA))
|
||||
|
||||
[XObj If _ _, condition, ifTrue, ifFalse] ->
|
||||
do evaledCondition <- eval env condition
|
||||
@ -156,11 +156,21 @@ eval env xobj =
|
||||
Bol b -> if b
|
||||
then eval env ifTrue
|
||||
else eval env ifFalse
|
||||
_ -> return (Left (EvalError ("Non-boolean expression in if-statement: " ++ pretty okCondition)))
|
||||
_ -> return (Left (EvalError ("`if` condition contains non-boolean value: " ++ pretty okCondition) (info okCondition)))
|
||||
Left err -> return (Left err)
|
||||
|
||||
[defnExpr@(XObj Defn _ _), name, args, body] ->
|
||||
specialCommandDefine xobj
|
||||
[defnExpr@(XObj Defn _ _), name, args@(XObj (Arr a) _ _), body] ->
|
||||
if all isSym a
|
||||
then specialCommandDefine xobj
|
||||
else return (Left (EvalError ("`defn` requires all arguments to be symbols, but it got `" ++ pretty args ++ "`") (info xobj)))
|
||||
where isSym (XObj (Sym _ _) _ _) = True
|
||||
isSym _ = False
|
||||
|
||||
[defnExpr@(XObj Defn _ _), name, invalidArgs, _] ->
|
||||
return (Left (EvalError ("`defn` requires an array of symbols as argument list, but it got `" ++ pretty invalidArgs ++ "`") (info xobj)))
|
||||
|
||||
(defnExpr@(XObj Defn _ _) : _) ->
|
||||
return (Left (EvalError ("I didn’t understand the `defn` at " ++ prettyInfoFromXObj xobj ++ ":\n\n" ++ pretty xobj ++ "\n\nIs it valid? Every `defn` needs to follow the form `(defn name [arg] body)`.") Nothing))
|
||||
|
||||
[defExpr@(XObj Def _ _), name, expr] ->
|
||||
specialCommandDefine xobj
|
||||
@ -187,12 +197,12 @@ eval env xobj =
|
||||
evaledBody <- eval envWithBindings body
|
||||
return $ do okBody <- evaledBody
|
||||
Right okBody
|
||||
else return (Left (EvalError ("Uneven number of forms in let-statement: " ++ pretty xobj))) -- Unreachable?
|
||||
else return (Left (EvalError ("Uneven number of forms in `let`: " ++ pretty xobj) (info xobj))) -- Unreachable?
|
||||
|
||||
XObj (Sym (SymPath [] "register-type") _) _ _ : XObj (Sym (SymPath _ typeName) _) _ _ : rest ->
|
||||
specialCommandRegisterType typeName rest
|
||||
XObj (Sym (SymPath _ "register-type") _) _ _ : _ ->
|
||||
return (Left (EvalError (show "Invalid ars to 'register-type': " ++ pretty xobj)))
|
||||
return (Left (EvalError (show "Invalid args to `register-type`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
XObj (Sym (SymPath [] "deftype") _) _ _ : nameXObj : rest ->
|
||||
specialCommandDeftype nameXObj rest
|
||||
@ -202,62 +212,62 @@ eval env xobj =
|
||||
[XObj (Sym (SymPath [] "register") _) _ _, XObj (Sym (SymPath _ name) _) _ _, typeXObj, XObj (Str overrideName) _ _] ->
|
||||
specialCommandRegister name typeXObj (Just overrideName)
|
||||
XObj (Sym (SymPath [] "register") _) _ _ : _ ->
|
||||
return (Left (EvalError ("Invalid args to 'register' command: " ++ pretty xobj)))
|
||||
return (Left (EvalError ("Invalid args to `register`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "definterface") _) _ _, nameXObj@(XObj (Sym _ _) _ _), typeXObj] ->
|
||||
specialCommandDefinterface nameXObj typeXObj
|
||||
XObj (Sym (SymPath [] "definterface") _) _ _ : _ ->
|
||||
return (Left (EvalError ("Invalid args to 'definterface' command: " ++ pretty xobj)))
|
||||
return (Left (EvalError ("Invalid args to `definterface`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "defdynamic") _) _ _, (XObj (Sym (SymPath [] name) _) _ _), params, body] ->
|
||||
specialCommandDefdynamic name params body
|
||||
XObj (Sym (SymPath [] "defdynamic") _) _ _ : _ ->
|
||||
return (Left (EvalError ("Invalid args to 'defdynamic' command: " ++ pretty xobj)))
|
||||
return (Left (EvalError ("Invalid args to `defdynamic`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "defmacro") _) _ _, (XObj (Sym (SymPath [] name) _) _ _), params, body] ->
|
||||
specialCommandDefmacro name params body
|
||||
XObj (Sym (SymPath [] "defmacro") _) _ _ : _ ->
|
||||
return (Left (EvalError ("Invalid args to 'defmacro' command: " ++ pretty xobj)))
|
||||
return (Left (EvalError ("Invalid args to `defmacro`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
XObj (Sym (SymPath [] "defmodule") _) _ _ : (XObj (Sym (SymPath [] moduleName) _) _ _) : innerExpressions ->
|
||||
specialCommandDefmodule xobj moduleName innerExpressions
|
||||
XObj (Sym (SymPath [] "defmodule") _) _ _ : _ ->
|
||||
return (Left (EvalError ("Invalid args to 'defmodule' command: " ++ pretty xobj)))
|
||||
return (Left (EvalError ("Invalid args to `defmodule`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "info") _) _ _, target@(XObj (Sym path @(SymPath _ name) _) _ _)] ->
|
||||
specialCommandInfo target
|
||||
XObj (Sym (SymPath [] "info") _) _ _ : _ ->
|
||||
return (Left (EvalError ("Invalid args to 'info' command: " ++ pretty xobj)))
|
||||
return (Left (EvalError ("Invalid args to `info`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "type") _) _ _, target] ->
|
||||
specialCommandType target
|
||||
XObj (Sym (SymPath [] "type") _) _ _ : _ ->
|
||||
return (Left (EvalError ("Invalid args to 'type' command: " ++ pretty xobj)))
|
||||
return (Left (EvalError ("Invalid args to `type`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "meta-set!") _) _ _, target@(XObj (Sym path @(SymPath _ name) _) _ _), (XObj (Str key) _ _), value] ->
|
||||
specialCommandMetaSet path key value
|
||||
XObj (Sym (SymPath [] "meta-set!") _) _ _ : _ ->
|
||||
return (Left (EvalError ("Invalid args to 'meta-set!' command: " ++ pretty xobj)))
|
||||
return (Left (EvalError ("Invalid args to `meta-set!`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "meta") _) _ _, target@(XObj (Sym path @(SymPath _ name) _) _ _), (XObj (Str key) _ _)] ->
|
||||
specialCommandMetaGet path key
|
||||
XObj (Sym (SymPath [] "meta") _) _ _ : _ ->
|
||||
return (Left (EvalError ("Invalid args to 'meta' command: " ++ pretty xobj)))
|
||||
return (Left (EvalError ("Invalid args to `meta`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "members") _) _ _, target] ->
|
||||
specialCommandMembers target
|
||||
XObj (Sym (SymPath [] "members") _) _ _ : _ ->
|
||||
return (Left (EvalError ("Invalid args to 'members' command: " ++ pretty xobj)))
|
||||
return (Left (EvalError ("Invalid args to `members`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
[XObj (Sym (SymPath [] "use") _) _ _, xobj@(XObj (Sym path _) _ _)] ->
|
||||
specialCommandUse xobj path
|
||||
XObj (Sym (SymPath [] "use") _) _ _ : _ ->
|
||||
return (Left (EvalError ("Invalid args to 'use' command: " ++ pretty xobj)))
|
||||
return (Left (EvalError ("Invalid args to `use`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
XObj With _ _ : xobj@(XObj (Sym path _) _ _) : forms ->
|
||||
specialCommandWith xobj path forms
|
||||
XObj With _ _ : _ ->
|
||||
return (Left (EvalError ("Invalid args to 'with.' command: " ++ pretty xobj)))
|
||||
return (Left (EvalError ("Invalid args to `with`: " ++ pretty xobj) (info xobj)))
|
||||
|
||||
f:args -> do evaledF <- eval env f
|
||||
case evaledF of
|
||||
@ -285,8 +295,8 @@ eval env xobj =
|
||||
Right okArgs -> getCommand callback okArgs
|
||||
Left err -> return (Left err)
|
||||
_ ->
|
||||
return (Left (EvalError ("Can't eval non-macro / non-dynamic function '" ++ pretty f ++ "' in " ++
|
||||
pretty xobj ++ " at " ++ prettyInfoFromXObj xobj)))
|
||||
return (Left (EvalError ("Can't eval '" ++ pretty f ++ "' (it’s neither a macro nor a dynamic function) in " ++
|
||||
pretty xobj) (info f)))
|
||||
|
||||
evalList _ = error "Can't eval non-list in evalList."
|
||||
|
||||
@ -297,7 +307,7 @@ eval env xobj =
|
||||
Nothing ->
|
||||
case lookupInEnv path env of
|
||||
Just (_, Binder _ found) -> return (Right found)
|
||||
Nothing -> return (Left (EvalError ("Can't find symbol '" ++ show path ++ "' at " ++ prettyInfoFromXObj xobj)))
|
||||
Nothing -> return (Left (EvalError ("Can't find symbol '" ++ show path ++ "'") (info xobj)))
|
||||
evalSymbol _ = error "Can't eval non-symbol in evalSymbol."
|
||||
|
||||
evalArray :: XObj -> StateT Context IO (Either EvalError XObj)
|
||||
@ -319,9 +329,7 @@ checkMatchingNrOfArgs xobj params args =
|
||||
else show paramLen
|
||||
in if (usesRestArgs && argsLen > paramLen) || (paramLen == argsLen)
|
||||
then Right ()
|
||||
else Left (EvalError ("Wrong nr of arguments in call to '" ++ pretty xobj ++ "' at " ++ prettyInfoFromXObj xobj ++
|
||||
", expected " ++ expected ++ " but got " ++ show argsLen ++ "."
|
||||
))
|
||||
else Left (EvalError ("Wrong number of arguments in call to '" ++ pretty xobj ++ "', expected " ++ expected ++ " but got " ++ show argsLen) (info xobj))
|
||||
|
||||
-- | Apply a function to some arguments. The other half of 'eval'.
|
||||
apply :: Env -> XObj -> [XObj] -> [XObj] -> StateT Context IO (Either EvalError XObj)
|
||||
@ -356,9 +364,9 @@ found binder =
|
||||
notFound :: ExecutionMode -> XObj -> SymPath -> StateT Context IO (Either EvalError XObj)
|
||||
notFound execMode xobj path =
|
||||
do fppl <- fmap (projectFilePathPrintLength . contextProj) get
|
||||
return $ Left $ EvalError $ case execMode of
|
||||
return $ Left $ EvalError (case execMode of
|
||||
Check -> machineReadableInfoFromXObj fppl xobj ++ (" Can't find '" ++ show path ++ "'")
|
||||
_ -> "Can't find '" ++ show path ++ "'"
|
||||
_ -> "Can't find '" ++ show path ++ "'") (info xobj)
|
||||
|
||||
-- | A command at the REPL
|
||||
-- | TODO: Is it possible to remove the error cases?
|
||||
@ -475,7 +483,7 @@ catcher ctx exception =
|
||||
CancelEvaluationException ->
|
||||
stop 1
|
||||
EvalException evalError ->
|
||||
do putStrLnWithColor Red ("[EVAL ERROR] " ++ show evalError)
|
||||
do putStrLnWithColor Red (show evalError)
|
||||
stop 1
|
||||
where stop returnCode =
|
||||
case contextExecMode ctx of
|
||||
@ -515,8 +523,8 @@ define hidden ctx@(Context globalEnv typeEnv _ proj _ _) annXObj =
|
||||
Just foundSignature ->
|
||||
do let Just sigTy = xobjToTy foundSignature
|
||||
when (not (areUnifiable (forceTy annXObj) sigTy)) $
|
||||
throw $ EvalException (EvalError ("Definition at " ++ prettyInfoFromXObj annXObj ++ " does not match 'sig' annotation " ++
|
||||
show sigTy ++ ", actual type is " ++ show (forceTy annXObj)))
|
||||
throw $ EvalException (EvalError ("Definition at " ++ prettyInfoFromXObj annXObj ++ " does not match `sig` annotation " ++
|
||||
show sigTy ++ ", actual type is `" ++ show (forceTy annXObj) ++ "`.") Nothing)
|
||||
Nothing ->
|
||||
return ()
|
||||
--putStrLnWithColor Blue (show (getPath annXObj) ++ " : " ++ showMaybeTy (ty annXObj) ++ (if hidden then " [HIDDEN]" else ""))
|
||||
@ -582,7 +590,7 @@ specialCommandDefine xobj =
|
||||
expansionResult <- expandAll eval globalEnv xobj
|
||||
ctxAfterExpansion <- get
|
||||
case expansionResult of
|
||||
Left err -> return (Left (EvalError (show err)))
|
||||
Left err -> return (Left (EvalError (show err) Nothing))
|
||||
Right expanded ->
|
||||
let xobjFullPath = setFullyQualifiedDefn expanded (SymPath pathStrings (getName xobj))
|
||||
xobjFullSymbols = setFullyQualifiedSymbols typeEnv globalEnv innerEnv xobjFullPath
|
||||
@ -591,9 +599,9 @@ specialCommandDefine xobj =
|
||||
case contextExecMode ctx of
|
||||
Check ->
|
||||
let fppl = projectFilePathPrintLength (contextProj ctx)
|
||||
in return (Left (EvalError (joinWith "\n" (machineReadableErrorStrings fppl err))))
|
||||
in return (Left (EvalError (joinWith "\n" (machineReadableErrorStrings fppl err)) Nothing))
|
||||
_ ->
|
||||
return (Left (EvalError (show err)))
|
||||
return (Left (EvalError (show err) Nothing))
|
||||
Right (annXObj, annDeps) ->
|
||||
do ctxWithDeps <- liftIO $ foldM (define True) ctxAfterExpansion annDeps
|
||||
ctxWithDef <- liftIO $ define False ctxWithDeps annXObj
|
||||
@ -620,7 +628,7 @@ specialCommandRegisterType typeName rest =
|
||||
members ->
|
||||
case bindingsForRegisteredType typeEnv globalEnv pathStrings typeName members i preExistingModule of
|
||||
Left errorMessage ->
|
||||
return (Left (EvalError (show errorMessage)))
|
||||
return (Left (EvalError (show errorMessage) Nothing))
|
||||
Right (typeModuleName, typeModuleXObj, deps) ->
|
||||
let ctx' = (ctx { contextGlobalEnv = envInsertAt globalEnv (SymPath pathStrings typeModuleName) (Binder emptyMeta typeModuleXObj)
|
||||
, contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) typeName typeDefinition)
|
||||
@ -670,11 +678,11 @@ deftypeInternal nameXObj typeName typeVariableXObjs rest =
|
||||
Right ok -> put ok
|
||||
return dynamicNil
|
||||
Left err ->
|
||||
return (Left (EvalError ("Invalid type definition for '" ++ pretty nameXObj ++ "':\n\n" ++ show err)))
|
||||
return (Left (EvalError ("Invalid type definition for '" ++ pretty nameXObj ++ "':\n\n" ++ show err) Nothing))
|
||||
(_, Nothing) ->
|
||||
return (Left (EvalError ("Invalid type variables for type definition: " ++ pretty nameXObj)))
|
||||
return (Left (EvalError ("Invalid type variables for type definition: " ++ pretty nameXObj) (info nameXObj)))
|
||||
_ ->
|
||||
return (Left (EvalError ("Invalid name for type definition: " ++ pretty nameXObj)))
|
||||
return (Left (EvalError ("Invalid name for type definition: " ++ pretty nameXObj) (info nameXObj)))
|
||||
|
||||
specialCommandRegister :: String -> XObj -> Maybe String -> StateT Context IO (Either EvalError XObj)
|
||||
specialCommandRegister name typeXObj overrideName =
|
||||
@ -694,12 +702,12 @@ specialCommandRegister name typeXObj overrideName =
|
||||
Check -> let fppl = projectFilePathPrintLength (contextProj ctx)
|
||||
in machineReadableInfoFromXObj fppl typeXObj ++ " "
|
||||
_ -> ""
|
||||
in return (Left (EvalError (prefix ++ err)))
|
||||
in return (Left (EvalError (prefix ++ err) (info typeXObj)))
|
||||
Right ctx' ->
|
||||
do put (ctx' { contextGlobalEnv = env' })
|
||||
return dynamicNil
|
||||
Nothing ->
|
||||
return (Left (EvalError ("Can't understand type when registering '" ++ name ++ "'")))
|
||||
return (Left (EvalError ("Can't understand type when registering '" ++ name ++ "'") (info typeXObj)))
|
||||
|
||||
specialCommandDefinterface :: XObj -> XObj -> StateT Context IO (Either EvalError XObj)
|
||||
specialCommandDefinterface nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _) typeXObj =
|
||||
@ -722,7 +730,7 @@ specialCommandDefinterface nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _) ty
|
||||
return dynamicNil
|
||||
Nothing ->
|
||||
return (Left (EvalError ("Invalid type for interface '" ++ name ++ "': " ++
|
||||
pretty typeXObj ++ " at " ++ prettyInfoFromXObj typeXObj ++ ".")))
|
||||
pretty typeXObj) (info typeXObj)))
|
||||
|
||||
specialCommandDefdynamic :: String -> XObj -> XObj -> StateT Context IO (Either EvalError XObj)
|
||||
specialCommandDefdynamic name params body =
|
||||
@ -762,7 +770,7 @@ specialCommandDefmodule xobj moduleName innerExpressions =
|
||||
put (popModulePath ctxAfterModuleAdditions)
|
||||
return dynamicNil -- TODO: propagate errors...
|
||||
Just _ ->
|
||||
return (Left (EvalError ("Can't redefine '" ++ moduleName ++ "' as module.")))
|
||||
return (Left (EvalError ("Can't redefine '" ++ moduleName ++ "' as module") (info xobj)))
|
||||
Nothing ->
|
||||
do let parentEnv = getEnv env pathStrings
|
||||
innerEnv = Env (Map.fromList []) (Just parentEnv) (Just moduleName) [] ExternalEnv 0
|
||||
@ -868,9 +876,9 @@ specialCommandMembers target =
|
||||
->
|
||||
return (Right (XObj (Arr (map (\(a, b) -> (XObj (Lst [a, b]) Nothing Nothing)) (pairwise members))) Nothing Nothing))
|
||||
_ ->
|
||||
return (Left (EvalError ("Can't find a struct type named '" ++ name ++ "' in type environment.")))
|
||||
return (Left (EvalError ("Can't find a struct type named '" ++ name ++ "' in type environment") (info target)))
|
||||
_ ->
|
||||
return (Left (EvalError ("Can't get the members of non-symbol: " ++ pretty target)))
|
||||
return (Left (EvalError ("Can't get the members of non-symbol: " ++ pretty target) (info target)))
|
||||
|
||||
specialCommandUse :: XObj -> SymPath -> StateT Context IO (Either EvalError XObj)
|
||||
specialCommandUse xobj path =
|
||||
@ -886,7 +894,7 @@ specialCommandUse xobj path =
|
||||
do put $ ctx { contextGlobalEnv = envReplaceEnvAt env pathStrings e' }
|
||||
return dynamicNil
|
||||
Nothing ->
|
||||
return (Left (EvalError ("Can't find a module named '" ++ show path ++ "' at " ++ prettyInfoFromXObj xobj ++ ".")))
|
||||
return (Left (EvalError ("Can't find a module named '" ++ show path ++ "'") (info xobj)))
|
||||
|
||||
specialCommandWith :: XObj -> SymPath -> [XObj] -> StateT Context IO (Either EvalError XObj)
|
||||
specialCommandWith xobj path forms =
|
||||
@ -922,7 +930,7 @@ specialCommandMetaSet path key value =
|
||||
(Just dummyInfo)
|
||||
(Just (VarTy "a"))))
|
||||
(SymPath _ _) ->
|
||||
return (Left (EvalError ("Special command 'meta-set!' failed, can't find '" ++ show path ++ "'.")))
|
||||
return (Left (EvalError ("Special command 'meta-set!' failed, can't find '" ++ show path ++ "'") (info value)))
|
||||
where
|
||||
setMetaOn :: Context -> Binder -> StateT Context IO (Either EvalError XObj)
|
||||
setMetaOn ctx binder@(Binder metaData xobj) =
|
||||
@ -949,7 +957,7 @@ specialCommandMetaGet path key =
|
||||
Nothing ->
|
||||
return dynamicNil
|
||||
Nothing ->
|
||||
return (Left (EvalError ("Special command 'meta' failed, can't find '" ++ show path ++ "'.")))
|
||||
return (Left (EvalError ("Special command 'meta' failed, can't find '" ++ show path ++ "'") Nothing))
|
||||
|
||||
|
||||
|
||||
@ -998,19 +1006,19 @@ commandLoad [xobj@(XObj (Str path) _ _)] =
|
||||
fppl ctx =
|
||||
projectFilePathPrintLength (contextProj ctx)
|
||||
invalidPath ctx path =
|
||||
Left $ EvalError $
|
||||
(case contextExecMode ctx of
|
||||
Left $ EvalError
|
||||
((case contextExecMode ctx of
|
||||
Check ->
|
||||
(machineReadableInfoFromXObj (fppl ctx) xobj) ++ " Invalid path: '" ++ path ++ "'"
|
||||
_ -> "Invalid path: '" ++ path ++ "'") ++
|
||||
"\n\nIf you tried loading an external package, try appending a version string (like `@master`)."
|
||||
"\n\nIf you tried loading an external package, try appending a version string (like `@master`)") (info xobj)
|
||||
invalidPathWith ctx path stderr =
|
||||
Left $ EvalError $
|
||||
(case contextExecMode ctx of
|
||||
Left $ EvalError
|
||||
((case contextExecMode ctx of
|
||||
Check ->
|
||||
(machineReadableInfoFromXObj (fppl ctx) xobj) ++ " Invalid path: '" ++ path ++ "'"
|
||||
_ -> "Invalid path: '" ++ path ++ "'") ++
|
||||
"\n\nTried interpreting statement as git import, but got: " ++ stderr
|
||||
"\n\nI tried interpreting the statement as a git import, but got: " ++ stderr) (info xobj)
|
||||
tryInstall path =
|
||||
let split = splitOn "@" path
|
||||
in tryInstallWithCheckout (joinWith "@" (init split)) (last split)
|
||||
@ -1061,7 +1069,7 @@ commandLoad [xobj@(XObj (Str path) _ _)] =
|
||||
ExitFailure _ -> do
|
||||
return $ invalidPathWith ctx path stderr1
|
||||
commandLoad [x] =
|
||||
return $ Left (EvalError ("Invalid args to 'load' command: " ++ pretty x))
|
||||
return $ Left (EvalError ("Invalid args to 'load' command: " ++ pretty x) (info x))
|
||||
|
||||
|
||||
-- | Load several files in order.
|
||||
@ -1111,10 +1119,10 @@ commandC [xobj] =
|
||||
typeEnv = contextTypeEnv ctx
|
||||
result <- expandAll eval globalEnv xobj
|
||||
case result of
|
||||
Left err -> return (Left (EvalError (show err)))
|
||||
Left err -> return (Left (EvalError (show err) (info xobj)))
|
||||
Right expanded ->
|
||||
case annotate typeEnv globalEnv (setFullyQualifiedSymbols typeEnv globalEnv globalEnv expanded) of
|
||||
Left err -> return (Left (EvalError (show err)))
|
||||
Left err -> return (Left (EvalError (show err) (info xobj)))
|
||||
Right (annXObj, annDeps) ->
|
||||
do liftIO (printC annXObj)
|
||||
liftIO (mapM printC annDeps)
|
||||
|
||||
@ -89,14 +89,18 @@ expand eval env xobj =
|
||||
return $ do okBindings <- sequence bind
|
||||
okBody <- expandedBody
|
||||
Right (XObj (Lst [letExpr, XObj (Arr (concat okBindings)) bindi bindt, okBody]) i t)
|
||||
else return (Left (EvalError ("Uneven number of forms in let-statement: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj)))
|
||||
else return (Left (EvalError (
|
||||
"I ecountered an odd number of forms inside a `let` (`" ++
|
||||
pretty xobj ++ "`)")
|
||||
(info xobj)))
|
||||
|
||||
matchExpr@(XObj Match _ _) : expr : rest ->
|
||||
do ctx <- get
|
||||
let fppl = projectFilePathPrintLength (contextProj ctx)
|
||||
if null rest
|
||||
then return (Left (EvalError ("No forms in match-expression: " ++
|
||||
machineReadableInfoFromXObj fppl xobj))) -- TODO: fppl shouldn't be decided here
|
||||
then return (Left
|
||||
(EvalError "I encountered a `match` without forms"
|
||||
(info xobj)))
|
||||
else if even (length rest)
|
||||
then do expandedExpr <- expand eval env expr
|
||||
expandedPairs <- mapM (\(l,r) -> do expandedR <- expand eval env r
|
||||
@ -106,8 +110,9 @@ expand eval env xobj =
|
||||
return $ do okExpandedExpr <- expandedExpr
|
||||
okExpandedRest <- expandedRest
|
||||
return (XObj (Lst (matchExpr : okExpandedExpr : okExpandedRest)) i t)
|
||||
else return (Left (EvalError ("Uneven number of forms in match-expression: " ++
|
||||
machineReadableInfoFromXObj fppl xobj)))
|
||||
else return (Left (EvalError
|
||||
"I encountered an odd number of forms inside a `match`"
|
||||
(info xobj)))
|
||||
|
||||
doExpr@(XObj Do _ _) : expressions ->
|
||||
do expandedExpressions <- mapM (expand eval env) expressions
|
||||
@ -118,11 +123,20 @@ expand eval env xobj =
|
||||
return $ do okExpression <- expandedExpression
|
||||
Right (XObj (Lst [withExpr, pathExpr , okExpression]) i t) -- Replace the with-expression with just the expression!
|
||||
[withExpr@(XObj With _ _), _, _] ->
|
||||
return (Left (EvalError ("Non-symbol in 'with' expression: " ++ show xobj ++ " at " ++ prettyInfoFromXObj xobj)))
|
||||
return (Left (EvalError ("I encountered the value `" ++ pretty xobj ++
|
||||
"` inside a `with` at " ++ prettyInfoFromXObj xobj ++
|
||||
".\n\n`with` accepts only symbols.")
|
||||
Nothing))
|
||||
(XObj With _ _) : _ ->
|
||||
return (Left (EvalError ("Can't have multiple forms within a 'with' expression (except at top-level) at " ++ prettyInfoFromXObj xobj)))
|
||||
return (Left (EvalError (
|
||||
"I encountered multiple forms inside a `with` at " ++
|
||||
prettyInfoFromXObj xobj ++
|
||||
".\n\n`with` accepts only one expression, except at the top level.")
|
||||
Nothing))
|
||||
XObj Mod{} _ _ : _ ->
|
||||
return (Left (EvalError "Can't eval module"))
|
||||
return (Left (EvalError ("I can’t evaluate the module `" ++
|
||||
pretty xobj ++ "`")
|
||||
(info xobj)))
|
||||
f:args -> do expandedF <- expand eval env f
|
||||
expandedArgs <- fmap sequence (mapM (expand eval env) args)
|
||||
case expandedF of
|
||||
|
||||
@ -222,7 +222,7 @@ genConstraints typeEnv root = fmap sort (gen root)
|
||||
let Just headTy = ty x
|
||||
genObj o n = XObj (Sym (SymPath [] ("Whereas the " ++ enumerate n ++ " element in the array is " ++ show (getPath o))) Symbol)
|
||||
(info o) (ty o)
|
||||
headObj = XObj (Sym (SymPath [] ("I inferred the type of the array from the first element of the array " ++ show (getPath x))) Symbol)
|
||||
headObj = XObj (Sym (SymPath [] ("I inferred the type of the array from its first element " ++ show (getPath x))) Symbol)
|
||||
(info x) (Just headTy)
|
||||
Just (StructTy "Array" [t]) = ty xobj
|
||||
betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1..]
|
||||
|
||||
@ -118,7 +118,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
return (Right (xobj { ty = Just renamed }))
|
||||
| otherwise -> return (Right (xobj { ty = Just theType }))
|
||||
Nothing -> return (Left (SymbolMissingType xobj foundEnv))
|
||||
Nothing -> return (Left (SymbolNotDefined symPath xobj)) -- Gives the error message "Trying to refer to an undefined symbol ..."
|
||||
Nothing -> return (Left (SymbolNotDefined symPath xobj env)) -- Gives the error message "Trying to refer to an undefined symbol ..."
|
||||
|
||||
visitMultiSym :: Env -> XObj -> [SymPath] -> State Integer (Either TypeError XObj)
|
||||
visitMultiSym _ xobj@(XObj (MultiSym name _) _ _) _ =
|
||||
|
||||
@ -3,6 +3,7 @@ module Lookup where
|
||||
import Data.List (intercalate, foldl')
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (mapMaybe, fromMaybe, fromJust)
|
||||
import Text.EditDistance (defaultEditCosts, levenshteinDistance)
|
||||
|
||||
import Types
|
||||
import Obj
|
||||
@ -209,3 +210,18 @@ isFunctionType _ = False
|
||||
isStructType :: Ty -> Bool
|
||||
isStructType (StructTy _ _) = True
|
||||
isStructType _ = False
|
||||
|
||||
keysInEnvEditDistance :: SymPath -> Env -> Int -> [String]
|
||||
keysInEnvEditDistance (SymPath [] name) env distance =
|
||||
let candidates = Map.filterWithKey (\k _ -> (levenshteinDistance defaultEditCosts k name) < distance) (envBindings env)
|
||||
in Map.keys candidates
|
||||
keysInEnvEditDistance path@(SymPath (p : ps) name) env distance =
|
||||
case Map.lookup p (envBindings env) of
|
||||
Just (Binder _ xobj) ->
|
||||
case xobj of
|
||||
(XObj (Mod modEnv) _ _) -> keysInEnvEditDistance (SymPath ps name) modEnv distance
|
||||
_ -> []
|
||||
Nothing ->
|
||||
case envParent env of
|
||||
Just parent -> keysInEnvEditDistance path parent distance
|
||||
Nothing -> []
|
||||
|
||||
@ -294,10 +294,12 @@ pretty = visit 0
|
||||
Interface _ _ -> "interface"
|
||||
With -> "with"
|
||||
|
||||
newtype EvalError = EvalError String deriving (Eq)
|
||||
data EvalError = EvalError String (Maybe Info) deriving (Eq)
|
||||
|
||||
instance Show EvalError where
|
||||
show (EvalError msg) = msg
|
||||
show (EvalError msg info) = msg ++ getInfo info
|
||||
where getInfo (Just i) = " at " ++ prettyInfo i ++ "."
|
||||
getInfo Nothing = ""
|
||||
|
||||
-- | Get the type of an XObj as a string.
|
||||
typeStr :: XObj -> String
|
||||
|
||||
176
src/TypeError.hs
176
src/TypeError.hs
@ -6,12 +6,13 @@ import Types
|
||||
import Obj
|
||||
import Constraints
|
||||
import Util
|
||||
import Lookup
|
||||
|
||||
data TypeError = SymbolMissingType XObj Env
|
||||
| DefnMissingType XObj
|
||||
| DefMissingType XObj
|
||||
| ExpressionMissingType XObj
|
||||
| SymbolNotDefined SymPath XObj
|
||||
| SymbolNotDefined SymPath XObj Env
|
||||
| InvalidObj Obj XObj
|
||||
| CantUseDerefOutsideFunctionApplication XObj
|
||||
| NotAType XObj
|
||||
@ -49,103 +50,172 @@ data TypeError = SymbolMissingType XObj Env
|
||||
|
||||
instance Show TypeError where
|
||||
show (SymbolMissingType xobj env) =
|
||||
"I couldn’t find a type for the symbol '" ++ getName xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ " in the environment:\n" ++ prettyEnvironment env ++ "\n\nIt might be too general. You could try adding a type hint using `the`."
|
||||
"I couldn’t find a type for the symbol '" ++ getName xobj ++ "' at " ++
|
||||
prettyInfoFromXObj xobj ++ " in the environment:\n" ++
|
||||
prettyEnvironment env ++
|
||||
"\n\nIt might be too general. You could try adding a type hint using `the`."
|
||||
show (DefnMissingType xobj) =
|
||||
"I couldn’t find a type for the function definition '" ++ getName xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ ".\n\nIt might be too general. You could try adding a type hint using `the`."
|
||||
"I couldn’t find a type for the function definition '" ++ getName xobj ++
|
||||
"' at " ++ prettyInfoFromXObj xobj ++
|
||||
".\n\nIt might be too general. You could try adding a type hint using `the`."
|
||||
show (DefMissingType xobj) =
|
||||
"I couldn’t find a type for the variable definition '" ++ getName xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ ".\n\nIt might be too general. You could try adding a type hint using `the`."
|
||||
"I couldn’t find a type for the variable definition '" ++ getName xobj ++
|
||||
"' at " ++ prettyInfoFromXObj xobj ++
|
||||
".\n\nIt might be too general. You could try adding a type hint using `the`."
|
||||
show (ExpressionMissingType xobj)=
|
||||
"I couldn’t find a type for the expression '" ++ pretty xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ ".\n\nIt might be too general. You could try adding a type hint using `the`."
|
||||
show (SymbolNotDefined symPath xobj) =
|
||||
"I couldn’t find the symbol '" ++ show symPath ++ "' at " ++ prettyInfoFromXObj xobj ++ ".\n\nMaybe you forgot to define it?"
|
||||
"I couldn’t find a type for the expression '" ++ pretty xobj ++ "' at " ++
|
||||
prettyInfoFromXObj xobj ++
|
||||
".\n\nIt might be too general. You could try adding a type hint using `the`."
|
||||
show (SymbolNotDefined symPath@(SymPath p _) xobj env) =
|
||||
"I couldn’t find the symbol '" ++ show symPath ++ "' at " ++
|
||||
prettyInfoFromXObj xobj ++ ".\n\n" ++
|
||||
matches (keysInEnvEditDistance symPath env 3)
|
||||
where matches [] = "Maybe you forgot to define it?"
|
||||
matches x = "Maybe you wanted one of the following?\n " ++ joinWith "\n " (map (\s -> show $ (SymPath p s)) x)
|
||||
show (InvalidObj Defn xobj) =
|
||||
"I didn’t understand the function definition at " ++ prettyInfoFromXObj xobj ++ ".\n\nIs it valid?"
|
||||
"I didn’t understand the function definition at " ++
|
||||
prettyInfoFromXObj xobj ++
|
||||
".\n\nIs it valid? Every `defn` needs to follow the form `(defn name [arg] body)`."
|
||||
show (CantUseDerefOutsideFunctionApplication xobj) =
|
||||
"I found a `deref` / `~` that isn’t inside a function application at " ++ prettyInfoFromXObj xobj ++ ".\n\nEvery usage of `~` must be inside a function application."
|
||||
"I found a `deref` / `~` that isn’t inside a function application at " ++
|
||||
prettyInfoFromXObj xobj ++
|
||||
".\n\nEvery usage of `~` must be inside a function application."
|
||||
show (InvalidObj If xobj) =
|
||||
"I didn’t understand the `if` statement at " ++ prettyInfoFromXObj xobj ++ ".\n\nIs it valid?"
|
||||
"I didn’t understand the `if` statement at " ++ prettyInfoFromXObj xobj ++
|
||||
".\n\nIs it valid? Every `if` needs to follow the form `(if cond iftrue iffalse)`."
|
||||
show (InvalidObj o xobj) =
|
||||
"I didn’t understand the form '" ++ show o ++ "' at " ++ prettyInfoFromXObj xobj ++ ".\n\nIs it valid?"
|
||||
"I didn’t understand the form `" ++ show o ++ "` at " ++
|
||||
prettyInfoFromXObj xobj ++ ".\n\nIs it valid?"
|
||||
show (WrongArgCount xobj expected actual) =
|
||||
"You used the wrong number of arguments in '" ++ getName xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ ". I expected " ++ show expected ++ ", but got " ++ show actual ++ "."
|
||||
"You used the wrong number of arguments in '" ++ getName xobj ++ "' at " ++
|
||||
prettyInfoFromXObj xobj ++ ". I expected " ++ show expected ++
|
||||
", but got " ++ show actual ++ "."
|
||||
show (NotAFunction xobj) =
|
||||
"You are trying to call the non-function '" ++ getName xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ "."
|
||||
"You are trying to call the non-function `" ++ getName xobj ++ "` at " ++
|
||||
prettyInfoFromXObj xobj ++ "."
|
||||
show (NoStatementsInDo xobj) =
|
||||
"There are no expressions inside of the `do` statement at " ++ prettyInfoFromXObj xobj ++ ".\n\nAll do statements need to have one or more expressions in it."
|
||||
"There are no expressions inside of the `do` statement at " ++
|
||||
prettyInfoFromXObj xobj ++
|
||||
".\n\nAll instances of `do` need to have one or more expressions in it."
|
||||
show (TooManyFormsInBody xobj) =
|
||||
"There are too many expressions in the body of the form at " ++ prettyInfoFromXObj xobj ++ ".\n\nTry wrapping them in a `do`."
|
||||
"There are too many expressions in the body of the form at " ++
|
||||
prettyInfoFromXObj xobj ++ ".\n\nTry wrapping them in a `do`."
|
||||
show (NoFormsInBody xobj) =
|
||||
"There are no expressions in the body body of the form at " ++ prettyInfoFromXObj xobj ++ ".\n\nI need exactly one body form. For multiple forms, try using `do`."
|
||||
"There are no expressions in the body body of the form at " ++
|
||||
prettyInfoFromXObj xobj ++
|
||||
".\n\nI need exactly one body form. For multiple forms, try using `do`."
|
||||
show (UnificationFailed constraint@(Constraint a b aObj bObj ctx _) mappings constraints) =
|
||||
"I can’t match the types '" ++ show (recursiveLookupTy mappings a) ++ "' and '" ++ show (recursiveLookupTy mappings b) ++ "'" ++ extra ++ ".\n\n" ++
|
||||
"I can’t match the types `" ++ show (recursiveLookupTy mappings a) ++
|
||||
"` and `" ++ show (recursiveLookupTy mappings b) ++ "`" ++ extra ++
|
||||
".\n\n" ++
|
||||
--show aObj ++ "\nWITH\n" ++ show bObj ++ "\n\n" ++
|
||||
" " ++ pretty aObj ++ " : " ++ showTypeFromXObj mappings aObj ++ "\n At " ++ prettyInfoFromXObj aObj ++ "" ++
|
||||
" " ++ pretty aObj ++ " : " ++ showTypeFromXObj mappings aObj ++
|
||||
"\n At " ++ prettyInfoFromXObj aObj ++ "" ++
|
||||
"\n\n" ++
|
||||
" " ++ pretty bObj ++ " : " ++ showTypeFromXObj mappings bObj ++ "\n At " ++ prettyInfoFromXObj bObj ++ "\n"
|
||||
" " ++ pretty bObj ++ " : " ++ showTypeFromXObj mappings bObj ++
|
||||
"\n At " ++ prettyInfoFromXObj bObj ++ "\n"
|
||||
-- ++ "Constraint: " ++ show constraint ++ "\n\n"
|
||||
-- "All constraints:\n" ++ show constraints ++ "\n\n" ++
|
||||
-- "Mappings: \n" ++ show mappings ++ "\n\n"
|
||||
where extra = if ctx == aObj || ctx == bObj then "" else " within `" ++ snip (pretty ctx) ++ "`"
|
||||
snip s = if length s > 25 then take 15 s ++ " ... " ++ drop (length s - 5) s else s
|
||||
snip s = if length s > 25
|
||||
then take 15 s ++ " ... " ++ drop (length s - 5) s
|
||||
else s
|
||||
show (CantDisambiguate xobj originalName theType options) =
|
||||
"I can’t disambiguate the symbol '" ++ originalName ++ "' of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++
|
||||
"\nPossibilities:\n " ++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
|
||||
"I found an ambiguous symbol `" ++ originalName ++ "` of type `" ++
|
||||
show theType ++ "` at " ++ prettyInfoFromXObj xobj ++
|
||||
"\nPossibilities:\n " ++
|
||||
joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
|
||||
show (CantDisambiguateInterfaceLookup xobj name theType options) =
|
||||
"I can’t disambiguate the interface '" ++ name ++ "' of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++
|
||||
"\nPossibilities:\n " ++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
|
||||
"I found an ambiguous interface `" ++ name ++ "` of type `" ++
|
||||
show theType ++ "` at " ++ prettyInfoFromXObj xobj ++
|
||||
"\nPossibilities:\n " ++
|
||||
joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
|
||||
show (SeveralExactMatches xobj name theType options) =
|
||||
"There are several exact matches for the interface '" ++ name ++ "' of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++
|
||||
"\nPossibilities:\n " ++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
|
||||
"There are several exact matches for the interface `" ++ name ++
|
||||
"` of type `" ++ show theType ++ "` at " ++ prettyInfoFromXObj xobj ++
|
||||
"\nPossibilities:\n " ++
|
||||
joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
|
||||
show (NoMatchingSignature xobj originalName theType options) =
|
||||
"I can’t find any implementation for the interface '" ++ originalName ++
|
||||
"' of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++
|
||||
"\nNone of the possibilities have the correct signature:\n " ++ joinWith
|
||||
"I can’t find any implementation for the interface `" ++ originalName ++
|
||||
"` of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++
|
||||
".\n\nNone of the possibilities have the correct signature:\n " ++ joinWith
|
||||
"\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
|
||||
show (LeadingColon xobj) =
|
||||
"I found a symbol '" ++ pretty xobj ++ "' that starts with a colon at " ++ prettyInfoFromXObj xobj ++ ".\n\nThis is disallowed."
|
||||
"I found a symbol '" ++ pretty xobj ++ "' that starts with a colon at " ++
|
||||
prettyInfoFromXObj xobj ++ ".\n\nThis is disallowed."
|
||||
show (HolesFound holes) =
|
||||
"I found the following holes:\n\n " ++ joinWith "\n " (map (\(name, t) -> name ++ " : " ++ show t) holes) ++ "\n"
|
||||
show (FailedToExpand xobj (EvalError errorMessage)) =
|
||||
"I failed to expand a macro at " ++ prettyInfoFromXObj xobj ++ ".\n\nThe error message I got was: " ++ errorMessage
|
||||
"I found the following holes:\n\n " ++
|
||||
joinWith "\n " (map (\(name, t) -> name ++ " : " ++ show t) holes) ++
|
||||
"\n"
|
||||
show (FailedToExpand xobj err@(EvalError _ _)) =
|
||||
"I failed to expand a macro at " ++ prettyInfoFromXObj xobj ++
|
||||
".\n\nThe error message I got was: " ++ show err
|
||||
show (NotAValidType xobj) =
|
||||
pretty xobj ++ "is not a valid type at " ++ prettyInfoFromXObj xobj
|
||||
show (FunctionsCantReturnRefTy xobj t) =
|
||||
"Functions can’t return references. " ++ getName xobj ++ " : " ++ show t ++ " at " ++ prettyInfoFromXObj xobj ++ "\n\nYou’ll have to copy the return value using `@`."
|
||||
"Functions can’t return references. " ++ getName xobj ++ " : " ++ show t
|
||||
++ " at " ++ prettyInfoFromXObj xobj ++
|
||||
"\n\nYou’ll have to copy the return value using `@`."
|
||||
show (LetCantReturnRefTy xobj t) =
|
||||
"`let` expressions can’t return references. '" ++ pretty xobj ++ "' : " ++ show t ++ " at " ++ prettyInfoFromXObj xobj ++ "\n\nYou’ll have to copy the return value using `@`."
|
||||
"`let` expressions can’t return references. " ++ pretty xobj ++ " : " ++
|
||||
show t ++ " at " ++ prettyInfoFromXObj xobj ++
|
||||
"\n\nYou’ll have to copy the return value using `@`."
|
||||
show (GettingReferenceToUnownedValue xobj) =
|
||||
"You’re referencing a given-away value '" ++ pretty xobj ++ "' at " ++ --"' (expression " ++ freshVar i ++ ") at " ++
|
||||
prettyInfoFromXObj xobj ++ "\n" ++ show xobj ++ "\n\nYou’ll have to copy the value using `@`."
|
||||
"You’re referencing a given-away value `" ++ pretty xobj ++ "` at " ++ --"' (expression " ++ freshVar i ++ ") at " ++
|
||||
prettyInfoFromXObj xobj ++ "\n" ++ show xobj ++
|
||||
"\n\nYou’ll have to copy the value using `@`."
|
||||
show (UsingUnownedValue xobj) =
|
||||
"You’re using a given-away value '" ++ pretty xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ ".\n\nYou’ll have to copy the value using `@`."
|
||||
"You’re using a given-away value `" ++ pretty xobj ++ "` at " ++
|
||||
prettyInfoFromXObj xobj ++ ".\n\nYou’ll have to copy the value using `@`."
|
||||
show (UsingCapturedValue xobj) =
|
||||
"You’re using a value '" ++ pretty xobj ++ "' that was captured by a function at " ++ prettyInfoFromXObj xobj ++ "."
|
||||
"You’re using a value `" ++ pretty xobj ++
|
||||
"` that was captured by a function at " ++ prettyInfoFromXObj xobj ++ "."
|
||||
show (ArraysCannotContainRefs xobj) =
|
||||
"Arrays can’t contain references: '" ++ pretty xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ ".\n\nYou’ll have to make a copy using `@`."
|
||||
"Arrays can’t contain references: `" ++ pretty xobj ++ "` at " ++
|
||||
prettyInfoFromXObj xobj ++ ".\n\nYou’ll have to make a copy using `@`."
|
||||
show (MainCanOnlyReturnUnitOrInt xobj t) =
|
||||
"The main function can only return an `Int` or a unit type (`()`), but it got `" ++ show t ++ "`."
|
||||
"The main function can only return an `Int` or a unit type (`()`), but it got `" ++
|
||||
show t ++ "`."
|
||||
show (MainCannotHaveArguments xobj c) =
|
||||
"The main function may not receive arguments, but it got " ++ show c ++ "."
|
||||
show (CannotConcretize xobj) =
|
||||
"I’m unable to concretize the expression '" ++ pretty xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ ".\n\nIt might be too general. You could try adding a type hint using `the`."
|
||||
"I’m unable to concretize the expression '" ++ pretty xobj ++ "' at " ++
|
||||
prettyInfoFromXObj xobj ++
|
||||
".\n\nIt might be too general. You could try adding a type hint using `the`."
|
||||
show (TooManyAnnotateCalls xobj) =
|
||||
"There were too many annotation calls when annotating '" ++ pretty xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ ".\n\n I deduced it was an infinite loop."
|
||||
"There were too many annotation calls when annotating `" ++ pretty xobj ++
|
||||
"` at " ++ prettyInfoFromXObj xobj ++
|
||||
".\n\n I deduced it was an infinite loop."
|
||||
show (NotAType xobj) =
|
||||
"I don’t understand the type '" ++ pretty xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ "\n\nIs it defined?"
|
||||
"I don’t understand the type '" ++ pretty xobj ++ "' at " ++
|
||||
prettyInfoFromXObj xobj ++ "\n\nIs it defined?"
|
||||
show (CannotSet xobj) =
|
||||
"I can’t `set!` the expression " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ ".\n\nOnly variables can be reset using `set!`."
|
||||
"I can’t `set!` the expression `" ++ pretty xobj ++ "` at " ++
|
||||
prettyInfoFromXObj xobj ++ ".\n\nOnly variables can be reset using `set!`."
|
||||
show (DoesNotMatchSignatureAnnotation xobj sigTy) =
|
||||
"The definition at " ++ prettyInfoFromXObj xobj ++ " does not match its annotation provided to `sig` as" ++ show sigTy ++ ", its actual type is " ++ show (forceTy xobj) ++ "."
|
||||
"The definition at " ++ prettyInfoFromXObj xobj ++
|
||||
" does not match its annotation provided to `sig` as `" ++ show sigTy ++
|
||||
"`, its actual type is `" ++ show (forceTy xobj) ++ "`."
|
||||
show (CannotMatch xobj) =
|
||||
"I can’t `match` '" ++ pretty xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ ".\n\nOnly sumtypes can be matched against."
|
||||
"I can’t `match` `" ++ pretty xobj ++ "` at " ++ prettyInfoFromXObj xobj ++
|
||||
".\n\nOnly sumtypes can be matched against."
|
||||
show (InvalidSumtypeCase xobj) =
|
||||
"I failed to read '" ++ pretty xobj ++ "' as a sumtype case, at " ++ prettyInfoFromXObj xobj ++ ".\n\nSumtype cases look like this: `(Foo Int typevar)`"
|
||||
"I failed to read `" ++ pretty xobj ++ "` as a sumtype case at " ++
|
||||
prettyInfoFromXObj xobj ++
|
||||
".\n\nSumtype cases look like this: `(Foo [Int typevar])`"
|
||||
show (InvalidMemberType t xobj) =
|
||||
"I can’t use the type '" ++ show t ++ "' as a member type at " ++ prettyInfoFromXObj xobj ++ ".\n\nIs it defined and captured in the head of the type definition?"
|
||||
"I can’t use the type `" ++ show t ++ "` as a member type at " ++
|
||||
prettyInfoFromXObj xobj ++
|
||||
".\n\nIs it defined and captured in the head of the type definition?"
|
||||
show (NotAmongRegisteredTypes t xobj) =
|
||||
"I can’t find a definition for the type '" ++ show t ++ "' at " ++ prettyInfoFromXObj xobj ++ ".\n\nWas it registered?"
|
||||
"I can’t find a definition for the type `" ++ show t ++ "` at " ++
|
||||
prettyInfoFromXObj xobj ++ ".\n\nWas it registered?"
|
||||
show (UnevenMembers xobjs) =
|
||||
"The number of members and types is uneven: '" ++ joinWithComma (map pretty xobjs) ++ "' at " ++ prettyInfoFromXObj (head xobjs) ++ ".\n\nBecause they are pairs of names and their types, they need to be even.\nDid you forget a name or type?"
|
||||
"The number of members and types is uneven: `" ++
|
||||
joinWithComma (map pretty xobjs) ++ "` at " ++
|
||||
prettyInfoFromXObj (head xobjs) ++
|
||||
".\n\nBecause they are pairs of names and their types, they need to be even.\nDid you forget a name or type?"
|
||||
|
||||
machineReadableErrorStrings :: FilePathPrintLength -> TypeError -> [String]
|
||||
machineReadableErrorStrings fppl err =
|
||||
@ -161,7 +231,7 @@ machineReadableErrorStrings fppl err =
|
||||
[machineReadableInfoFromXObj fppl xobj ++ " Variable definition '" ++ getName xobj ++ "' missing type."]
|
||||
(ExpressionMissingType xobj) ->
|
||||
[machineReadableInfoFromXObj fppl xobj ++ " Expression '" ++ pretty xobj ++ "' missing type."]
|
||||
(SymbolNotDefined symPath xobj) ->
|
||||
(SymbolNotDefined symPath xobj _) ->
|
||||
[machineReadableInfoFromXObj fppl xobj ++ " Trying to refer to an undefined symbol '" ++ show symPath ++ "'."]
|
||||
(SymbolMissingType xobj env) ->
|
||||
[machineReadableInfoFromXObj fppl xobj ++ " Symbol '" ++ getName xobj ++ "' missing type."]
|
||||
@ -203,7 +273,7 @@ machineReadableErrorStrings fppl err =
|
||||
-- (HolesFound holes) ->
|
||||
-- (map (\(name, t) -> machineReadableInfoFromXObj fppl xobj ++ " " ++ name ++ " : " ++ show t) holes)
|
||||
|
||||
(FailedToExpand xobj (EvalError errorMessage)) ->
|
||||
(FailedToExpand xobj (EvalError errorMessage _)) ->
|
||||
[machineReadableInfoFromXObj fppl xobj ++ "Failed to expand: " ++ errorMessage]
|
||||
|
||||
-- TODO: Remove overlapping errors:
|
||||
|
||||
Loading…
Reference in New Issue
Block a user