module CSPM.TypeChecker.Exceptions (
Error, Warning,
varNotInScopeMessage,
infiniteUnificationMessage,
unificationErrorMessage,
duplicatedDefinitionsMessage,
incorrectArgumentCountMessage,
constraintUnificationErrorMessage,
transparentFunctionNotRecognised,
externalFunctionNotRecognised,
deprecatedNameUsed,
unsafeNameUsed,
)
where
import Data.Typeable
import Data.List (group, sort)
import Prelude
import CSPM.DataStructures.Names
import CSPM.DataStructures.Syntax
import CSPM.DataStructures.Types
import CSPM.PrettyPrinter
import Util.Annotated
import Util.Exception
import Util.PartialFunctions
import Util.PrettyPrint
type Error = Doc
type Warning = Doc
varNotInScopeMessage :: Name -> Error
varNotInScopeMessage n = prettyPrint n <+> text "is not in scope"
incorrectArgumentCountMessage :: Doc -> Int -> Int -> Error
incorrectArgumentCountMessage func expected actual =
hang (hang (text "The function") tabWidth func) tabWidth
(text "was supplied with" <+> int actual <+>
text "arguments, but was expecting" <+> int expected)
infiniteUnificationMessage :: Type -> Type -> Error
infiniteUnificationMessage t1 t2 =
let [ppt1, ppt2] = prettyPrintTypes [t1, t2] in
text "Cannot construct the infinite type:" <+> ppt1 <+> equals <+> ppt2
unificationErrorMessage :: [(Type, Type)] -> Error
unificationErrorMessage unificationStack =
let
hd = head unificationStack
lt = last unificationStack
(it1, it2) = hd
(t1, t2) = lt
[pit1, pit2, pt1, pt2] = prettyPrintTypes [it1, it2, t1, t2]
in
sep [text "Couldn't match expected type" <+> pit1,
nest 8 (text "with actual type" <+> pit2)]
$$
if hd == lt then empty
else sep [text "whilst matching expected type" <+> pt1,
nest 8 (text "with actual type" <+> pt2)]
constraintUnificationErrorMessage :: Constraint -> Type -> Error
constraintUnificationErrorMessage c t =
hang (hang (text "The type") tabWidth (prettyPrint t)) tabWidth
(text "does not have the constraint" <+> prettyPrint c)
duplicatedDefinitionsMessage :: [(Name, SrcSpan)] -> [Error]
duplicatedDefinitionsMessage ns = duplicatedDefinitionsMessage' $
let
names = map fst ns
dupNames = (map head . filter (\ g -> length g > 1) . group . sort) names
in [(n, applyRelation ns n) | n <- dupNames]
duplicatedDefinitionsMessage' :: [(Name, [SrcSpan])] -> [Error]
duplicatedDefinitionsMessage' nlocs =
map (\ (n, spans) ->
hang (text "The variable" <+> prettyPrint n
<+> text "has multiple definitions at" <> colon) tabWidth
(vcat (map prettyPrint spans))) nlocs
transparentFunctionNotRecognised :: Name -> Error
transparentFunctionNotRecognised n =
text "The transparent function" <+> prettyPrint n <+>
text "is not recognised."
externalFunctionNotRecognised :: Name -> Error
externalFunctionNotRecognised n =
text "The external function" <+> prettyPrint n <+>
text "is not recognised."
deprecatedNameUsed :: Name -> Maybe Name -> Error
deprecatedNameUsed n Nothing =
prettyPrint n <+> text "is deprecated."
deprecatedNameUsed n (Just replacement) =
prettyPrint n <+> text "is deprecated - use" <+>
prettyPrint replacement <+> text "instead."
unsafeNameUsed :: Name -> Error
unsafeNameUsed n =
text "The invocation of" <+> prettyPrint n
<+> text "has not been type-checked."
<+> text "Therefore, a runtime type error may occur here."