----------------------------------------------------------------------------- -- -- Module : Language.PureScript.Error -- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors -- License : MIT -- -- Maintainer : Phil Freeman -- Stability : experimental -- Portability : -- -- | -- ----------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} 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 -- | -- A type of error messages -- 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) -- | -- Wrapper of simpler errors -- 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 -- | -- Get the error code for a particular error type -- 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" -- | -- A stack trace for an error -- newtype MultipleErrors = MultipleErrors { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid) instance UnificationError Type MultipleErrors where occursCheckFailed = occursCheckFailed instance UnificationError Kind MultipleErrors where occursCheckFailed = occursCheckFailed -- | Check whether a collection of errors is empty or not. nonEmpty :: MultipleErrors -> Bool nonEmpty = not . null . runMultipleErrors -- | -- Create an error set from a single simple error message -- errorMessage :: SimpleErrorMessage -> MultipleErrors errorMessage err = MultipleErrors [SimpleErrorWrapper err] -- | -- Create an error set from a single error message -- singleError :: ErrorMessage -> MultipleErrors singleError = MultipleErrors . pure -- | -- Lift a function on ErrorMessage to a function on MultipleErrors -- onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors onErrorMessages f = MultipleErrors . map f . runMultipleErrors -- | The various types of things which might need to be relabelled in errors messages. data LabelType = TypeLabel | SkolemLabel String deriving (Show, Eq, Ord) -- | A map from rigid type variable name/unknown variable pairs to new variables. type UnknownMap = M.Map (LabelType, Unknown) Unknown -- | How critical the issue is data Level = Error | Warning deriving Show -- | -- Extract nested error messages from wrapper errors -- 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 -- | -- Pretty print a single error, simplifying if necessary -- prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) where -- | -- Pretty print an ErrorMessage -- 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 -- | -- Render a DictionaryValue fit for human consumption in error messages -- 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 ] -- | -- Pretty print and export declaration -- 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 -- | -- Simplify an error message -- 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 -- | -- Pretty print multiple errors -- prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String prettyPrintMultipleErrors full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Multiple errors found:" full -- | -- Pretty print multiple warnings -- 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 -- | -- Interpret multiple errors and warnings in a monad supporting errors and warnings -- interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a interpretMultipleErrorsAndWarnings (err, ws) = do tell ws either throwError return $ err -- | -- Rethrow an error with a more detailed error message in the case of failure -- rethrow :: (MonadError e m) => (e -> e) -> m a -> m a rethrow f = flip catchError $ \e -> throwError (f e) -- | -- Rethrow an error with source position information -- 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 -- | -- Collect errors in in parallel -- 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