module Language.PureScript.Errors where
import Data.Either (lefts, rights)
import Data.List (intercalate, transpose)
import Data.Function (on)
import Data.Monoid
import Data.Foldable (fold, foldMap)
import qualified Data.Map as M
import Control.Monad
import Control.Monad.Unify
import Control.Monad.Writer
import Control.Monad.Error.Class (MonadError(..))
import Control.Applicative ((<$>), (<*>), Applicative, pure)
import Control.Monad.Trans.State.Lazy
import Control.Arrow(first)
import Language.PureScript.AST
import Language.PureScript.Environment (isObject, isFunction)
import Language.PureScript.Pretty
import Language.PureScript.Types
import Language.PureScript.Names
import Language.PureScript.Kinds
import Language.PureScript.TypeClassDictionaries
import qualified Text.PrettyPrint.Boxes as Box
import qualified Text.Parsec as P
data SimpleErrorMessage
= ErrorParsingExterns P.ParseError
| ErrorParsingFFIModule FilePath
| ErrorParsingModule P.ParseError
| MissingFFIModule ModuleName
| MultipleFFIModules ModuleName [FilePath]
| UnnecessaryFFIModule ModuleName FilePath
| InvalidExternsFile FilePath
| CannotGetFileInfo FilePath
| CannotReadFile FilePath
| CannotWriteFile FilePath
| InfiniteType Type
| InfiniteKind Kind
| CannotReorderOperators
| MultipleFixities Ident
| OrphanTypeDeclaration Ident
| OrphanFixityDeclaration String
| RedefinedModule ModuleName
| RedefinedIdent Ident
| OverlappingNamesInLet
| UnknownModule ModuleName
| UnknownType (Qualified ProperName)
| UnknownTypeClass (Qualified ProperName)
| UnknownValue (Qualified Ident)
| UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))
| UnknownTypeConstructor (Qualified ProperName)
| ConflictingImport String ModuleName
| ConflictingImports String ModuleName ModuleName
| ConflictingTypeDecls ProperName
| ConflictingCtorDecls ProperName
| TypeConflictsWithClass ProperName
| CtorConflictsWithClass ProperName
| ClassConflictsWithType ProperName
| ClassConflictsWithCtor ProperName
| DuplicateClassExport ProperName
| DuplicateValueExport Ident
| DuplicateTypeArgument String
| InvalidDoBind
| InvalidDoLet
| CycleInDeclaration Ident
| CycleInTypeSynonym (Maybe ProperName)
| CycleInModules [ModuleName]
| NameIsUndefined Ident
| NameNotInScope Ident
| UndefinedTypeVariable ProperName
| PartiallyAppliedSynonym (Qualified ProperName)
| EscapedSkolem (Maybe Expr)
| UnspecifiedSkolemScope
| TypesDoNotUnify Type Type
| KindsDoNotUnify Kind Kind
| ConstrainedTypeUnified Type Type
| OverlappingInstances (Qualified ProperName) [Type] [DictionaryValue]
| NoInstanceFound (Qualified ProperName) [Type]
| DuplicateLabel String (Maybe Expr)
| DuplicateValueDeclaration Ident
| ArgListLengthsDiffer Ident
| OverlappingArgNames (Maybe Ident)
| MissingClassMember Ident
| ExtraneousClassMember Ident
| ExpectedType Kind
| IncorrectConstructorArity (Qualified ProperName)
| SubsumptionCheckFailed
| ExprDoesNotHaveType Expr Type
| PropertyIsMissing String Type
| CannotApplyFunction Type Expr
| TypeSynonymInstance
| InvalidNewtype
| InvalidInstanceHead Type
| TransitiveExportError DeclarationRef [DeclarationRef]
| ShadowedName Ident
| WildcardInferredType Type
| NotExhaustivePattern [[Binder]] Bool
| OverlappingPattern [[Binder]] Bool
| ClassOperator ProperName Ident
deriving (Show)
data ErrorMessage
= NotYetDefined [Ident] ErrorMessage
| ErrorUnifyingTypes Type Type ErrorMessage
| ErrorInExpression Expr ErrorMessage
| ErrorInModule ModuleName ErrorMessage
| ErrorInInstance (Qualified ProperName) [Type] ErrorMessage
| ErrorInSubsumption Type Type ErrorMessage
| ErrorCheckingType Expr Type ErrorMessage
| ErrorCheckingKind Type ErrorMessage
| ErrorInferringType Expr ErrorMessage
| ErrorInApplication Expr Type Expr ErrorMessage
| ErrorInDataConstructor ProperName ErrorMessage
| ErrorInTypeConstructor ProperName ErrorMessage
| ErrorInBindingGroup [Ident] ErrorMessage
| ErrorInDataBindingGroup ErrorMessage
| ErrorInTypeSynonym ProperName ErrorMessage
| ErrorInValueDeclaration Ident ErrorMessage
| ErrorInForeignImport Ident ErrorMessage
| PositionedError SourceSpan ErrorMessage
| SimpleErrorWrapper SimpleErrorMessage
deriving (Show)
instance UnificationError Type ErrorMessage where
occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t
instance UnificationError Kind ErrorMessage where
occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k
errorCode :: ErrorMessage -> String
errorCode em = case unwrapErrorMessage em of
(ErrorParsingExterns _) -> "ErrorParsingExterns"
(ErrorParsingFFIModule _) -> "ErrorParsingFFIModule"
(ErrorParsingModule _) -> "ErrorParsingModule"
MissingFFIModule{} -> "MissingFFIModule"
MultipleFFIModules{} -> "MultipleFFIModules"
UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"
(InvalidExternsFile _) -> "InvalidExternsFile"
(CannotGetFileInfo _) -> "CannotGetFileInfo"
(CannotReadFile _) -> "CannotReadFile"
(CannotWriteFile _) -> "CannotWriteFile"
(InfiniteType _) -> "InfiniteType"
(InfiniteKind _) -> "InfiniteKind"
CannotReorderOperators -> "CannotReorderOperators"
(MultipleFixities _) -> "MultipleFixities"
(OrphanTypeDeclaration _) -> "OrphanTypeDeclaration"
(OrphanFixityDeclaration _) -> "OrphanFixityDeclaration"
(RedefinedModule _) -> "RedefinedModule"
(RedefinedIdent _) -> "RedefinedIdent"
OverlappingNamesInLet -> "OverlappingNamesInLet"
(UnknownModule _) -> "UnknownModule"
(UnknownType _) -> "UnknownType"
(UnknownTypeClass _) -> "UnknownTypeClass"
(UnknownValue _) -> "UnknownValue"
(UnknownDataConstructor _ _) -> "UnknownDataConstructor"
(UnknownTypeConstructor _) -> "UnknownTypeConstructor"
(ConflictingImport _ _) -> "ConflictingImport"
(ConflictingImports _ _ _) -> "ConflictingImports"
(ConflictingTypeDecls _) -> "ConflictingTypeDecls"
(ConflictingCtorDecls _) -> "ConflictingCtorDecls"
(TypeConflictsWithClass _) -> "TypeConflictsWithClass"
(CtorConflictsWithClass _) -> "CtorConflictsWithClass"
(ClassConflictsWithType _) -> "ClassConflictsWithType"
(ClassConflictsWithCtor _) -> "ClassConflictsWithCtor"
(DuplicateClassExport _) -> "DuplicateClassExport"
(DuplicateValueExport _) -> "DuplicateValueExport"
(DuplicateTypeArgument _) -> "DuplicateTypeArgument"
InvalidDoBind -> "InvalidDoBind"
InvalidDoLet -> "InvalidDoLet"
(CycleInDeclaration _) -> "CycleInDeclaration"
(CycleInTypeSynonym _) -> "CycleInTypeSynonym"
(CycleInModules _) -> "CycleInModules"
(NameIsUndefined _) -> "NameIsUndefined"
(NameNotInScope _) -> "NameNotInScope"
(UndefinedTypeVariable _) -> "UndefinedTypeVariable"
(PartiallyAppliedSynonym _) -> "PartiallyAppliedSynonym"
(EscapedSkolem _) -> "EscapedSkolem"
UnspecifiedSkolemScope -> "UnspecifiedSkolemScope"
(TypesDoNotUnify _ _) -> "TypesDoNotUnify"
(KindsDoNotUnify _ _) -> "KindsDoNotUnify"
(ConstrainedTypeUnified _ _) -> "ConstrainedTypeUnified"
(OverlappingInstances _ _ _) -> "OverlappingInstances"
(NoInstanceFound _ _) -> "NoInstanceFound"
(DuplicateLabel _ _) -> "DuplicateLabel"
(DuplicateValueDeclaration _) -> "DuplicateValueDeclaration"
(ArgListLengthsDiffer _) -> "ArgListLengthsDiffer"
(OverlappingArgNames _) -> "OverlappingArgNames"
(MissingClassMember _) -> "MissingClassMember"
(ExtraneousClassMember _) -> "ExtraneousClassMember"
(ExpectedType _) -> "ExpectedType"
(IncorrectConstructorArity _) -> "IncorrectConstructorArity"
SubsumptionCheckFailed -> "SubsumptionCheckFailed"
(ExprDoesNotHaveType _ _) -> "ExprDoesNotHaveType"
(PropertyIsMissing _ _) -> "PropertyIsMissing"
(CannotApplyFunction _ _) -> "CannotApplyFunction"
TypeSynonymInstance -> "TypeSynonymInstance"
InvalidNewtype -> "InvalidNewtype"
(InvalidInstanceHead _) -> "InvalidInstanceHead"
(TransitiveExportError _ _) -> "TransitiveExportError"
(ShadowedName _) -> "ShadowedName"
(WildcardInferredType _) -> "WildcardInferredType"
(NotExhaustivePattern _ _) -> "NotExhaustivePattern"
(OverlappingPattern _ _) -> "OverlappingPattern"
(ClassOperator _ _) -> "ClassOperator"
newtype MultipleErrors = MultipleErrors
{ runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)
instance UnificationError Type MultipleErrors where
occursCheckFailed = occursCheckFailed
instance UnificationError Kind MultipleErrors where
occursCheckFailed = occursCheckFailed
nonEmpty :: MultipleErrors -> Bool
nonEmpty = not . null . runMultipleErrors
errorMessage :: SimpleErrorMessage -> MultipleErrors
errorMessage err = MultipleErrors [SimpleErrorWrapper err]
singleError :: ErrorMessage -> MultipleErrors
singleError = MultipleErrors . pure
onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
onErrorMessages f = MultipleErrors . map f . runMultipleErrors
data LabelType = TypeLabel | SkolemLabel String deriving (Show, Eq, Ord)
type UnknownMap = M.Map (LabelType, Unknown) Unknown
data Level = Error | Warning deriving Show
unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
unwrapErrorMessage em = case em of
(ErrorCheckingKind _ err) -> unwrapErrorMessage err
(ErrorCheckingType _ _ err) -> unwrapErrorMessage err
(ErrorInApplication _ _ _ err) -> unwrapErrorMessage err
(ErrorInBindingGroup _ err) -> unwrapErrorMessage err
(ErrorInDataBindingGroup err) -> unwrapErrorMessage err
(ErrorInDataConstructor _ err) -> unwrapErrorMessage err
(ErrorInExpression _ err) -> unwrapErrorMessage err
(ErrorInForeignImport _ err) -> unwrapErrorMessage err
(ErrorInInstance _ _ err) -> unwrapErrorMessage err
(ErrorInModule _ err) -> unwrapErrorMessage err
(ErrorInSubsumption _ _ err) -> unwrapErrorMessage err
(ErrorInTypeConstructor _ err) -> unwrapErrorMessage err
(ErrorInTypeSynonym _ err) -> unwrapErrorMessage err
(ErrorInValueDeclaration _ err) -> unwrapErrorMessage err
(ErrorInferringType _ err) -> unwrapErrorMessage err
(ErrorUnifyingTypes _ _ err) -> unwrapErrorMessage err
(NotYetDefined _ err) -> unwrapErrorMessage err
(PositionedError _ err) -> unwrapErrorMessage err
(SimpleErrorWrapper sem) -> sem
replaceUnknowns :: Type -> State UnknownMap Type
replaceUnknowns = everywhereOnTypesM replaceTypes
where
lookupTable :: (LabelType, Unknown) -> UnknownMap -> (Unknown, UnknownMap)
lookupTable x m = case M.lookup x m of
Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m)
Just i -> (i, m)
replaceTypes :: Type -> State UnknownMap Type
replaceTypes (TUnknown u) = state $ first TUnknown . lookupTable (TypeLabel, u)
replaceTypes (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (SkolemLabel name, s)
replaceTypes other = return other
onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
onTypesInErrorMessageM f = g
where
gSimple (InfiniteType t) = InfiniteType <$> (f t)
gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> (f t1) <*> (f t2)
gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> (f t1) <*> (f t2)
gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> (f t)
gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> (f t)
gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> (pure e)
gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
gSimple other = pure other
g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> (f t1) <*> (f t2) <*> (g em)
g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> (f t1) <*> (f t2) <*> (g e)
g (ErrorCheckingType e t em) = ErrorCheckingType e <$> (f t) <*> (g em)
g (ErrorCheckingKind t em) = ErrorCheckingKind <$> (f t) <*> g em
g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> (f t1) <*> (pure e2) <*> (g em)
g (NotYetDefined x e) = NotYetDefined x <$> (g e)
g (ErrorInExpression x e) = ErrorInExpression x <$> (g e)
g (ErrorInModule x e) = ErrorInModule x <$> (g e)
g (ErrorInInstance x y e) = ErrorInInstance x y <$> (g e)
g (ErrorInferringType x e) = ErrorInferringType x <$> (g e)
g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> (g e)
g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> (g e)
g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> (g e)
g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> (g e)
g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> (g e)
g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> (g e)
g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> (g e)
g (PositionedError x e) = PositionedError x <$> (g e)
g (SimpleErrorWrapper sem) = SimpleErrorWrapper <$> gSimple sem
prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box
prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
where
prettyPrintErrorMessage :: ErrorMessage -> Box.Box
prettyPrintErrorMessage em =
paras $
go em:suggestions em ++
[line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this error."]
where
wikiUri :: String
wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
go :: ErrorMessage -> Box.Box
goSimple (CannotGetFileInfo path) =
paras [ line "Unable to read file info: "
, indent . line $ path
]
goSimple (CannotReadFile path) =
paras [ line "Unable to read file: "
, indent . line $ path
]
goSimple (CannotWriteFile path) =
paras [ line "Unable to write file: "
, indent . line $ path
]
goSimple (ErrorParsingExterns err) =
paras [ lineWithLevel "parsing externs files: "
, indent . line . show $ err
]
goSimple (ErrorParsingFFIModule path) =
paras [ line "Unable to parse module from FFI file: "
, indent . line $ path
]
goSimple (ErrorParsingModule err) =
paras [ line "Unable to parse module: "
, indent . line . show $ err
]
goSimple (MissingFFIModule mn) =
line $ "Missing FFI implementations for module " ++ show mn
goSimple (UnnecessaryFFIModule mn path) =
paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ show mn ++ ": "
, indent . line $ path
]
goSimple (MultipleFFIModules mn paths) =
paras $ [ line $ "Multiple FFI implementations have been provided for module " ++ show mn ++ ": " ]
++ map (indent . line) paths
goSimple (InvalidExternsFile path) =
paras [ line "Externs file is invalid: "
, indent . line $ path
]
goSimple InvalidDoBind =
line "Bind statement cannot be the last statement in a do block"
goSimple InvalidDoLet =
line "Let statement cannot be the last statement in a do block"
goSimple CannotReorderOperators =
line "Unable to reorder operators"
goSimple UnspecifiedSkolemScope =
line "Skolem variable scope is unspecified"
goSimple OverlappingNamesInLet =
line "Overlapping names in let binding."
goSimple (InfiniteType ty) =
paras [ line "Infinite type detected: "
, indent $ line $ prettyPrintType ty
]
goSimple (InfiniteKind ki) =
paras [ line "Infinite kind detected: "
, indent $ line $ prettyPrintKind ki
]
goSimple (MultipleFixities name) =
line $ "Multiple fixity declarations for " ++ show name
goSimple (OrphanTypeDeclaration nm) =
line $ "Orphan type declaration for " ++ show nm
goSimple (OrphanFixityDeclaration op) =
line $ "Orphan fixity declaration for " ++ show op
goSimple (RedefinedModule name) =
line $ "Module " ++ show name ++ " has been defined multiple times"
goSimple (RedefinedIdent name) =
line $ "Name " ++ show name ++ " has been defined multiple times"
goSimple (UnknownModule mn) =
line $ "Unknown module " ++ show mn
goSimple (UnknownType name) =
line $ "Unknown type " ++ show name
goSimple (UnknownTypeClass name) =
line $ "Unknown type class " ++ show name
goSimple (UnknownValue name) =
line $ "Unknown value " ++ show name
goSimple (UnknownTypeConstructor name) =
line $ "Unknown type constructor " ++ show name
goSimple (UnknownDataConstructor dc tc) =
line $ "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc
goSimple (ConflictingImport nm mn) =
line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ show mn
goSimple (ConflictingImports nm m1 m2) =
line $ "Conflicting imports for " ++ show nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
goSimple (ConflictingTypeDecls nm) =
line $ "Conflicting type declarations for " ++ show nm
goSimple (ConflictingCtorDecls nm) =
line $ "Conflicting data constructor declarations for " ++ show nm
goSimple (TypeConflictsWithClass nm) =
line $ "Type " ++ show nm ++ " conflicts with type class declaration of the same name"
goSimple (CtorConflictsWithClass nm) =
line $ "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"
goSimple (ClassConflictsWithType nm) =
line $ "Type class " ++ show nm ++ " conflicts with type declaration of the same name"
goSimple (ClassConflictsWithCtor nm) =
line $ "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"
goSimple (DuplicateClassExport nm) =
line $ "Duplicate export declaration for type class " ++ show nm
goSimple (DuplicateValueExport nm) =
line $ "Duplicate export declaration for value " ++ show nm
goSimple (CycleInDeclaration nm) =
line $ "Cycle in declaration of " ++ show nm
goSimple (CycleInModules mns) =
line $ "Cycle in module dependencies: " ++ intercalate ", " (map show mns)
goSimple (CycleInTypeSynonym pn) =
line $ "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn
goSimple (NameIsUndefined ident) =
line $ show ident ++ " is undefined"
goSimple (NameNotInScope ident) =
line $ show ident ++ " may not be defined in the current scope"
goSimple (UndefinedTypeVariable name) =
line $ "Type variable " ++ show name ++ " is undefined"
goSimple (PartiallyAppliedSynonym name) =
line $ "Partially applied type synonym " ++ show name
goSimple (EscapedSkolem binding) =
paras $ [ line "Rigid/skolem type variable has escaped." ]
<> foldMap (\expr -> [ line "Relevant expression: "
, indent $ line $ prettyPrintValue expr
]) binding
goSimple (TypesDoNotUnify t1 t2)
= paras [ line "Cannot unify type"
, indent $ line $ prettyPrintType t1
, line "with type"
, indent $ line $ prettyPrintType t2
]
goSimple (KindsDoNotUnify k1 k2) =
paras [ line "Cannot unify kind"
, indent $ line $ prettyPrintKind k1
, line "with kind"
, indent $ line $ prettyPrintKind k2
]
goSimple (ConstrainedTypeUnified t1 t2) =
paras [ line "Cannot unify constrained type"
, indent $ line $ prettyPrintType t1
, line "with type"
, indent $ line $ prettyPrintType t2
]
goSimple (OverlappingInstances nm ts ds) =
paras [ line $ "Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
, paras $ map prettyPrintDictionaryValue ds
]
goSimple (NoInstanceFound nm ts) =
line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
goSimple (DuplicateLabel l expr) =
paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
<> foldMap (\expr' -> [ line "Relevant expression: "
, indent $ line $ prettyPrintValue expr'
]) expr
goSimple (DuplicateTypeArgument name) =
line $ "Duplicate type argument " ++ show name
goSimple (DuplicateValueDeclaration nm) =
line $ "Duplicate value declaration for " ++ show nm
goSimple (ArgListLengthsDiffer ident) =
line $ "Argument list lengths differ in declaration " ++ show ident
goSimple (OverlappingArgNames ident) =
line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident
goSimple (MissingClassMember ident) =
line $ "Member " ++ show ident ++ " has not been implemented"
goSimple (ExtraneousClassMember ident) =
line $ "Member " ++ show ident ++ " is not a member of the class being instantiated"
goSimple (ExpectedType kind) =
line $ "Expected type of kind *, was " ++ prettyPrintKind kind
goSimple (IncorrectConstructorArity nm) =
line $ "Wrong number of arguments to constructor " ++ show nm
goSimple SubsumptionCheckFailed = line $ "Unable to check type subsumption"
goSimple (ExprDoesNotHaveType expr ty) =
paras [ line "Expression"
, indent $ line $ prettyPrintValue expr
, line "does not have type"
, indent $ line $ prettyPrintType ty
]
goSimple (PropertyIsMissing prop row) =
line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
goSimple (CannotApplyFunction fn arg) =
paras [ line "Cannot apply function of type"
, indent $ line $ prettyPrintType fn
, line "to argument"
, indent $ line $ prettyPrintValue arg
]
goSimple TypeSynonymInstance =
line "Type synonym instances are disallowed"
goSimple InvalidNewtype =
line "Newtypes must define a single constructor with a single argument"
goSimple (InvalidInstanceHead ty) =
paras [ line "Invalid type in class instance head:"
, indent $ line $ prettyPrintType ty
]
goSimple (TransitiveExportError x ys) =
paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
: map (line . prettyPrintExport) ys
goSimple (ShadowedName nm) =
line $ "Name '" ++ show nm ++ "' was shadowed."
goSimple (ClassOperator className opName) =
paras [ line $ "Class '" ++ show className ++ "' declares operator " ++ show opName ++ "."
, indent $ line $ "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"
, indent $ line $ show opName ++ " = someMember"
]
goSimple (WildcardInferredType ty) =
line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty
goSimple (NotExhaustivePattern bs b) =
indent $ paras $ [ line "Pattern could not be determined to cover all cases."
, line $ "The definition has the following uncovered cases:\n"
, Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
] ++ if not b then [line "..."] else []
goSimple (OverlappingPattern bs b) =
indent $ paras $ [ line "Redundant cases have been detected."
, line $ "The definition has the following redundant cases:\n"
, Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
] ++ if not b then [line "..."] else []
go (NotYetDefined names err) =
paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"
, indent $ go err
]
go (ErrorUnifyingTypes t1 t2 err) =
paras [ lineWithLevel "unifying type "
, indent $ line $ prettyPrintType t1
, line "with type"
, indent $ line $ prettyPrintType t2
, go err
]
go (ErrorInExpression expr err) =
paras [ lineWithLevel "in expression:"
, indent $ line $ prettyPrintValue expr
, go err
]
go (ErrorInModule mn err) =
paras [ lineWithLevel $ "in module " ++ show mn ++ ":"
, go err
]
go (ErrorInSubsumption t1 t2 err) =
paras [ lineWithLevel "checking that type "
, indent $ line $ prettyPrintType t1
, line "subsumes type"
, indent $ line $ prettyPrintType t2
, go err
]
go (ErrorInInstance name ts err) =
paras [ lineWithLevel $ "in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
, go err
]
go (ErrorCheckingKind ty err) =
paras [ lineWithLevel "checking kind of type "
, indent $ line $ prettyPrintType ty
, go err
]
go (ErrorInferringType expr err) =
paras [ lineWithLevel "inferring type of value "
, indent $ line $ prettyPrintValue expr
, go err
]
go (ErrorCheckingType expr ty err) =
paras [ lineWithLevel "checking that value "
, indent $ line $ prettyPrintValue expr
, line "has type"
, indent $ line $ prettyPrintType ty
, go err
]
go (ErrorInApplication f t a err) =
paras [ lineWithLevel "applying function"
, indent $ line $ prettyPrintValue f
, line "of type"
, indent $ line $ prettyPrintType t
, line "to argument"
, indent $ line $ prettyPrintValue a
, go err
]
go (ErrorInDataConstructor nm err) =
paras [ lineWithLevel $ "in data constructor " ++ show nm ++ ":"
, go err
]
go (ErrorInTypeConstructor nm err) =
paras [ lineWithLevel $ "in type constructor " ++ show nm ++ ":"
, go err
]
go (ErrorInBindingGroup nms err) =
paras [ lineWithLevel $ "in binding group " ++ intercalate ", " (map show nms) ++ ":"
, go err
]
go (ErrorInDataBindingGroup err) =
paras [ lineWithLevel $ "in data binding group:"
, go err
]
go (ErrorInTypeSynonym name err) =
paras [ lineWithLevel $ "in type synonym " ++ show name ++ ":"
, go err
]
go (ErrorInValueDeclaration n err) =
paras [ lineWithLevel $ "in value declaration " ++ show n ++ ":"
, go err
]
go (ErrorInForeignImport nm err) =
paras [ lineWithLevel $ "in foreign import " ++ show nm ++ ":"
, go err
]
go (PositionedError srcSpan err) =
paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
, indent $ go err
]
go (SimpleErrorWrapper sem) = goSimple sem
line :: String -> Box.Box
line = Box.text
lineWithLevel :: String -> Box.Box
lineWithLevel text = line $ show level ++ " " ++ text
suggestions :: ErrorMessage -> [Box.Box]
suggestions = suggestions' . unwrapErrorMessage
where
suggestions' (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ show im ++ ":"
, indent . line $ "import " ++ show im ++ " hiding (" ++ nm ++ ")"
]
suggestions' (TypesDoNotUnify t1 t2)
| isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]
| otherwise = []
suggestions' _ = []
paras :: [Box.Box] -> Box.Box
paras = Box.vcat Box.left
indent :: Box.Box -> Box.Box
indent = Box.moveRight 2
prettyPrintDictionaryValue :: DictionaryValue -> Box.Box
prettyPrintDictionaryValue (LocalDictionaryValue _) = line "Dictionary in scope"
prettyPrintDictionaryValue (GlobalDictionaryValue nm) = line (show nm)
prettyPrintDictionaryValue (DependentDictionaryValue nm args) = paras [ line $ (show nm) ++ " via"
, indent $ paras $ map prettyPrintDictionaryValue args
]
prettyPrintDictionaryValue (SubclassDictionaryValue sup nm _) = paras [ line $ (show nm) ++ " via superclass"
, indent $ prettyPrintDictionaryValue sup
]
prettyPrintExport :: DeclarationRef -> String
prettyPrintExport (TypeRef pn _) = show pn
prettyPrintExport (ValueRef ident) = show ident
prettyPrintExport (TypeClassRef pn) = show pn
prettyPrintExport (TypeInstanceRef ident) = show ident
prettyPrintExport (ModuleRef name) = "module " ++ show name
prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
simplifyErrorMessage :: ErrorMessage -> ErrorMessage
simplifyErrorMessage = unwrap Nothing
where
unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
unwrap pos (ErrorInExpression _ err) = unwrap pos err
unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)
unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)
unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err
unwrap pos (ErrorInferringType _ err) = unwrap pos err
unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err
unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)
unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err
unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)
unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)
unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)
unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)
unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)
unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)
unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)
unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
unwrap _ (PositionedError pos err) = unwrap (Just pos) err
unwrap pos other = wrap pos other
wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
wrap Nothing = id
wrap (Just pos) = PositionedError pos
prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
prettyPrintMultipleErrors full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Multiple errors found:" full
prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
prettyPrintMultipleWarnings full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Multiple warnings found:" full
prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap String
prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
result <- prettyPrintSingleError full level e
return $ renderBox $
Box.vcat Box.left [ Box.text intro
, result
]
prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full level
return $ renderBox $
Box.vcat Box.left [ Box.text intro
, Box.vsep 1 Box.left result
]
renderBox :: Box.Box -> String
renderBox = unlines . map trimEnd . lines . Box.render
where
trimEnd = reverse . dropWhile (== ' ') . reverse
interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a
interpretMultipleErrorsAndWarnings (err, ws) = do
tell ws
either throwError return $ err
rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
rethrow f = flip catchError $ \e -> throwError (f e)
rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a
rethrowWithPosition pos = rethrow (onErrorMessages withPosition)
where
withPosition :: ErrorMessage -> ErrorMessage
withPosition (PositionedError _ err) = withPosition err
withPosition err = PositionedError pos err
parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]
parU xs f = forM xs (withError . f) >>= collectErrors
where
withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a)
withError u = catchError (Right <$> u) (return . Left)
collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]
collectErrors es = case lefts es of
[] -> return $ rights es
errs -> throwError $ fold errs