module CSPM.TypeChecker.Exceptions (
Error, Warning,
infiniteUnificationMessage,
unificationErrorMessage,
incorrectArgumentCountMessage,
constraintUnificationErrorMessage,
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
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)
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."