mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
97 lines
3.3 KiB
Haskell
97 lines
3.3 KiB
Haskell
module PrimitiveError where
|
||
|
||
import Obj
|
||
import TypeError
|
||
import Types
|
||
|
||
data PrimitiveError
|
||
= ArgumentTypeError String String String XObj
|
||
| ArgumentArityError XObj String [XObj]
|
||
| MissingInfo XObj
|
||
| ForewardImplementsMeta
|
||
| RegisterTypeError
|
||
| SymbolNotFoundError SymPath
|
||
| BadDeftypeMembers
|
||
| QualifiedTypeMember [XObj]
|
||
| InvalidTypeName XObj
|
||
| InvalidTypeVariables XObj
|
||
| MetaSetFailed XObj String
|
||
| StructNotFound XObj
|
||
| NonTypeInTypeEnv SymPath XObj
|
||
| InvalidSumtypeCase XObj
|
||
| TooManySumtypeCases
|
||
|
||
data PrimitiveWarning
|
||
= NonExistentInterfaceWarning XObj
|
||
| DefinitionTypeChangeWarning XObj Ty
|
||
|
||
instance Show PrimitiveError where
|
||
show (ArgumentTypeError fun ty position actual) =
|
||
"`" ++ fun ++ "` expected " ++ ty ++ " as its " ++ position
|
||
++ " argument, but got `"
|
||
++ pretty actual
|
||
++ "`"
|
||
show (ArgumentArityError fun numberExpected args) =
|
||
"`" ++ show (getPath fun) ++ "`" ++ "expected " ++ numberExpected
|
||
++ " arguments "
|
||
++ ", but got "
|
||
++ show (length args)
|
||
show (MissingInfo x) =
|
||
"No information about object: " ++ pretty x
|
||
show ForewardImplementsMeta =
|
||
"Can't set the `implements` meta on a global definition before it is declared."
|
||
show RegisterTypeError =
|
||
"I don't understand this usage of `register-type`.\n\n"
|
||
++ "Valid usages :\n"
|
||
++ " (register-type Name)\n"
|
||
++ " (register-type Name [field0 Type, ...])\n"
|
||
++ " (register-type Name c-name)\n"
|
||
++ " (register-type Name c-name [field0 Type, ...]"
|
||
show (SymbolNotFoundError path) =
|
||
"I can’t find the symbol `" ++ show path ++ "`"
|
||
show (BadDeftypeMembers) =
|
||
"All fields must have a name and a type."
|
||
++ "Example:\n"
|
||
++ "```(deftype Name [field1 Type1, field2 Type2, field3 Type3])```\n"
|
||
show (QualifiedTypeMember xobjs) =
|
||
"Type members must be unqualified symbols, but got `"
|
||
++ concatMap pretty xobjs
|
||
++ "`"
|
||
show (InvalidTypeName xobj) =
|
||
("Invalid name for type definition: " ++ pretty xobj)
|
||
show (InvalidTypeVariables xobj) =
|
||
("Invalid type variables for type definition: " ++ pretty xobj)
|
||
show (MetaSetFailed xobj e) =
|
||
"`meta-set!` failed on `" ++ pretty xobj
|
||
++ "` "
|
||
++ show e
|
||
show (StructNotFound xobj) =
|
||
"Couldn't find a type named '" ++ (show (getPath xobj))
|
||
++ "' in the type environment."
|
||
show (NonTypeInTypeEnv path xobj) =
|
||
"Can't get members for: " ++ show path
|
||
++ " found a non-type in the type environment: "
|
||
++ (pretty xobj)
|
||
show (PrimitiveError.InvalidSumtypeCase xobj) =
|
||
"Can't get members for an invalid sumtype case: "
|
||
++ pretty xobj
|
||
show TooManySumtypeCases =
|
||
"Got too many sumtype cases (>128) for type"
|
||
|
||
instance Show PrimitiveWarning where
|
||
show (NonExistentInterfaceWarning x) =
|
||
"The interface "
|
||
++ show (getPath x)
|
||
++ " is not defined."
|
||
++ " Did you define it using `definterface`?"
|
||
show (DefinitionTypeChangeWarning annXObj previousType) =
|
||
"Definition at " ++ prettyInfoFromXObj annXObj ++ " changed type of '" ++ show (getPath annXObj)
|
||
++ "' from "
|
||
++ show previousType
|
||
++ " to "
|
||
++ show (forceTy annXObj)
|
||
|
||
toEvalError :: Context -> XObj -> PrimitiveError -> (Context, Either EvalError XObj)
|
||
toEvalError ctx xobj perr =
|
||
evalError ctx (show perr) (xobjInfo xobj)
|