@@ -20,7 +20,7 @@
2020module Language.PureScript.Errors where
2121
2222import Data.Either (lefts, rights)
23−import Data.List (intercalate, transpose)
23+import Data.List (intercalate, transpose, nub)
2424import Data.Function (on)
2525#if __GLASGOW_HASKELL__ < 710
2626import Data.Foldable (fold, foldMap)
@@ -52,7 +52,6 @@ import qualified Text.PrettyPrint.Boxes as Box
5252import qualified Text.Parsec as P
5353import qualified Text.Parsec.Error as PE
5454import Text.Parsec.Error (Message(..))
55−import Data.List (nub)
5655
5756-- |
5857-- A type of error messages
@@ -100,6 +99,7 @@ data SimpleErrorMessage
10099 | CtorConflictsWithClass ProperName
101100 | ClassConflictsWithType ProperName
102101 | ClassConflictsWithCtor ProperName
102+ | DuplicateModuleName ModuleName
103103 | DuplicateClassExport ProperName
104104 | DuplicateValueExport Ident
105105 | DuplicateTypeArgument String
@@ -145,6 +145,7 @@ data SimpleErrorMessage
145145 | WildcardInferredType Type
146146 | NotExhaustivePattern [[Binder]] Bool
147147 | OverlappingPattern [[Binder]] Bool
148+ | IncompleteExhaustivityCheck
148149 | ClassOperator ProperName Ident
149150 | MisleadingEmptyTypeImport ModuleName ProperName
150151 | ImportHidingModule ModuleName
@@ -229,6 +230,7 @@ errorCode em = case unwrapErrorMessage em of
229230 CtorConflictsWithClass{} -> "CtorConflictsWithClass"
230231 ClassConflictsWithType{} -> "ClassConflictsWithType"
231232 ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
233+ DuplicateModuleName{} -> "DuplicateModuleName"
232234 DuplicateClassExport{} -> "DuplicateClassExport"
233235 DuplicateValueExport{} -> "DuplicateValueExport"
234236 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
@@ -274,6 +276,7 @@ errorCode em = case unwrapErrorMessage em of
274276 WildcardInferredType{} -> "WildcardInferredType"
275277 NotExhaustivePattern{} -> "NotExhaustivePattern"
276278 OverlappingPattern{} -> "OverlappingPattern"
279+ IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"
277280 ClassOperator{} -> "ClassOperator"
278281 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"
279282 ImportHidingModule{} -> "ImportHidingModule"
@@ -364,33 +367,33 @@ replaceUnknowns = everywhereOnTypesM replaceTypes
364367onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
365368onTypesInErrorMessageM f = g
366369 where
367− gSimple (InfiniteType t) = InfiniteType <$> (f t)
368− gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> (f t1) <*> (f t2)
369− gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> (f t1) <*> (f t2)
370− gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> (f t)
371− gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> (f t)
372− gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> (pure e)
370+ gSimple (InfiniteType t) = InfiniteType <$> f t
371+ gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
372+ gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2
373+ gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
374+ gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> f t
375+ gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
373376 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
374377 gSimple other = pure other
375− g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> (f t1) <*> (f t2) <*> (g em)
376− g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> (f t1) <*> (f t2) <*> (g e)
377− g (ErrorCheckingType e t em) = ErrorCheckingType e <$> (f t) <*> (g em)
378− g (ErrorCheckingKind t em) = ErrorCheckingKind <$> (f t) <*> g em
379− g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> (f t1) <*> (pure e2) <*> (g em)
380− g (NotYetDefined x e) = NotYetDefined x <$> (g e)
381− g (ErrorInExpression x e) = ErrorInExpression x <$> (g e)
382− g (ErrorInModule x e) = ErrorInModule x <$> (g e)
383− g (ErrorInInstance x y e) = ErrorInInstance x y <$> (g e)
384− g (ErrorInferringType x e) = ErrorInferringType x <$> (g e)
385− g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> (g e)
386− g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> (g e)
387− g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> (g e)
388− g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> (g e)
389− g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> (g e)
390− g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> (g e)
391− g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> (g e)
392− g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> (g e)
393− g (PositionedError x e) = PositionedError x <$> (g e)
378+ g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> f t1 <*> f t2 <*> g em
379+ g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> f t1 <*> f t2 <*> g e
380+ g (ErrorCheckingType e t em) = ErrorCheckingType e <$> f t <*> g em
381+ g (ErrorCheckingKind t em) = ErrorCheckingKind <$> f t <*> g em
382+ g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> f t1 <*> pure e2 <*> g em
383+ g (NotYetDefined x e) = NotYetDefined x <$> g e
384+ g (ErrorInExpression x e) = ErrorInExpression x <$> g e
385+ g (ErrorInModule x e) = ErrorInModule x <$> g e
386+ g (ErrorInInstance x y e) = ErrorInInstance x y <$> g e
387+ g (ErrorInferringType x e) = ErrorInferringType x <$> g e
388+ g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> g e
389+ g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> g e
390+ g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> g e
391+ g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> g e
392+ g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> g e
393+ g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> g e
394+ g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> g e
395+ g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> g e
396+ g (PositionedError x e) = PositionedError x <$> g e
394397 g (SimpleErrorWrapper sem) = SimpleErrorWrapper <$> gSimple sem
395398
396399-- |
@@ -524,6 +527,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
524527 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"
525528 goSimple (ClassConflictsWithCtor nm) =
526529 line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"
530+ goSimple (DuplicateModuleName mn) =
531+ line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."
527532 goSimple (DuplicateClassExport nm) =
528533 line $ "Duplicate export declaration for type class " ++ runProperName nm
529534 goSimple (DuplicateValueExport nm) =
@@ -662,6 +667,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
662667 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
663668 ] ++
664669 [ line "..." | not b ]
670+ goSimple IncompleteExhaustivityCheck =
671+ paras [ line "An exhaustivity check was abandoned due to too many possible cases."
672+ , line "You may want to decomposing your data types into smaller types."
673+ ]
665674 go (NotYetDefined names err) =
666675 paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"
667676 , indent $ go err
@@ -732,7 +741,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
732741 , go err
733742 ]
734743 go (ErrorInDataBindingGroup err) =
735− paras [ lineWithLevel $ "in data binding group:"
744+ paras [ lineWithLevel "in data binding group:"
736745 , go err
737746 ]
738747 go (ErrorInTypeSynonym name err) =
@@ -851,7 +860,7 @@ prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
851860 , result
852861 ]
853862prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
854− result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full level
863+ result <- forM es $ liftM (Box.moveRight 2) . prettyPrintSingleError full level
855864 return $
856865 Box.vcat Box.left [ Box.text intro
857866 , Box.vsep 1 Box.left result
@@ -859,7 +868,7 @@ prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
859868
860869-- | Pretty print a Parsec ParseError as a Box
861870prettyPrintParseError :: P.ParseError -> Box.Box
862−prettyPrintParseError = (prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input") . PE.errorMessages
871+prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages
863872
864873-- |
865874-- Pretty print ParseError detail messages.
@@ -872,9 +881,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd
872881 | otherwise = Box.vcat Box.left $ map Box.text $ clean [showSysUnExpect,showUnExpect,showExpect,showMessages]
873882
874883 where
875− (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs
876− (unExpect,msgs2) = span ((UnExpect "") ==) msgs1
877− (expect,messages) = span ((Expect "") ==) msgs2
884+ (sysUnExpect,msgs1) = span (SysUnExpect "" ==) msgs
885+ (unExpect,msgs2) = span (UnExpect "" ==) msgs1
886+ (expect,messages) = span (Expect "" ==) msgs2
878887
879888 showExpect = showMany msgExpecting expect
880889 showUnExpect = showMany msgUnExpected unExpect
@@ -922,7 +931,7 @@ renderBox = unlines . map trimEnd . lines . Box.render
922931interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a
923932interpretMultipleErrorsAndWarnings (err, ws) = do
924933 tell ws
925− either throwError return $ err
934+ either throwError return err
926935
927936-- |
928937-- Rethrow an error with a more detailed error message in the case of failure