@@ -272,6 +272,9 @@ data LabelType = TypeLabel | SkolemLabel String deriving (Show, Eq, Ord)
272272-- | A map from rigid type variable name/unknown variable pairs to new variables.
273273type UnknownMap = M.Map (LabelType, Unknown) Unknown
274274
275+-- | How critical the issue is
276+data Level = Error | Warning deriving Show
277+
275278-- |
276279-- Extract nested error messages from wrapper errors
277280--
@@ -344,8 +347,8 @@ onTypesInErrorMessageM f = g
344347-- |
345348-- Pretty print a single error, simplifying if necessary
346349--
347−prettyPrintSingleError :: Bool -> ErrorMessage -> State UnknownMap Box.Box
348−prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
350+prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box
351+prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
349352 where
350353 -- |
351354 -- Pretty print an ErrorMessage
@@ -373,7 +376,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
373376 , indent . line $ path
374377 ]
375378 goSimple (ErrorParsingExterns err) =
376− paras [ line "Error parsing externs files: "
379+ paras [ lineWithLevel "parsing externs files: "
377380 , indent . line . show $ err
378381 ]
379382 goSimple (ErrorParsingFFIModule path) =
@@ -561,51 +564,51 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
561564 , indent $ go err
562565 ]
563566 go (ErrorUnifyingTypes t1 t2 err) =
564− paras [ line "Error unifying type "
567+ paras [ lineWithLevel "unifying type "
565568 , indent $ line $ prettyPrintType t1
566569 , line "with type"
567570 , indent $ line $ prettyPrintType t2
568571 , go err
569572 ]
570573 go (ErrorInExpression expr err) =
571− paras [ line "Error in expression:"
574+ paras [ lineWithLevel "in expression:"
572575 , indent $ line $ prettyPrintValue expr
573576 , go err
574577 ]
575578 go (ErrorInModule mn err) =
576− paras [ line $ "Error in module " ++ show mn ++ ":"
579+ paras [ lineWithLevel $ "in module " ++ show mn ++ ":"
577580 , go err
578581 ]
579582 go (ErrorInSubsumption t1 t2 err) =
580− paras [ line "Error checking that type "
583+ paras [ lineWithLevel "checking that type "
581584 , indent $ line $ prettyPrintType t1
582585 , line "subsumes type"
583586 , indent $ line $ prettyPrintType t2
584587 , go err
585588 ]
586589 go (ErrorInInstance name ts err) =
587− paras [ line $ "Error in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
590+ paras [ lineWithLevel $ "in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
588591 , go err
589592 ]
590593 go (ErrorCheckingKind ty err) =
591− paras [ line "Error checking kind of type "
594+ paras [ lineWithLevel "checking kind of type "
592595 , indent $ line $ prettyPrintType ty
593596 , go err
594597 ]
595598 go (ErrorInferringType expr err) =
596− paras [ line "Error inferring type of value "
599+ paras [ lineWithLevel "inferring type of value "
597600 , indent $ line $ prettyPrintValue expr
598601 , go err
599602 ]
600603 go (ErrorCheckingType expr ty err) =
601− paras [ line "Error checking that value "
604+ paras [ lineWithLevel "checking that value "
602605 , indent $ line $ prettyPrintValue expr
603606 , line "has type"
604607 , indent $ line $ prettyPrintType ty
605608 , go err
606609 ]
607610 go (ErrorInApplication f t a err) =
608− paras [ line "Error applying function"
611+ paras [ lineWithLevel "applying function"
609612 , indent $ line $ prettyPrintValue f
610613 , line "of type"
611614 , indent $ line $ prettyPrintType t
@@ -614,35 +617,35 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
614617 , go err
615618 ]
616619 go (ErrorInDataConstructor nm err) =
617− paras [ line $ "Error in data constructor " ++ show nm ++ ":"
620+ paras [ lineWithLevel $ "in data constructor " ++ show nm ++ ":"
618621 , go err
619622 ]
620623 go (ErrorInTypeConstructor nm err) =
621− paras [ line $ "Error in type constructor " ++ show nm ++ ":"
624+ paras [ lineWithLevel $ "in type constructor " ++ show nm ++ ":"
622625 , go err
623626 ]
624627 go (ErrorInBindingGroup nms err) =
625− paras [ line $ "Error in binding group " ++ intercalate ", " (map show nms) ++ ":"
628+ paras [ lineWithLevel $ "in binding group " ++ intercalate ", " (map show nms) ++ ":"
626629 , go err
627630 ]
628631 go (ErrorInDataBindingGroup err) =
629− paras [ line $ "Error in data binding group:"
632+ paras [ lineWithLevel $ "in data binding group:"
630633 , go err
631634 ]
632635 go (ErrorInTypeSynonym name err) =
633− paras [ line $ "Error in type synonym " ++ show name ++ ":"
636+ paras [ lineWithLevel $ "in type synonym " ++ show name ++ ":"
634637 , go err
635638 ]
636639 go (ErrorInValueDeclaration n err) =
637− paras [ line $ "Error in value declaration " ++ show n ++ ":"
640+ paras [ lineWithLevel $ "in value declaration " ++ show n ++ ":"
638641 , go err
639642 ]
640643 go (ErrorInForeignImport nm err) =
641− paras [ line $ "Error in foreign import " ++ show nm ++ ":"
644+ paras [ lineWithLevel $ "in foreign import " ++ show nm ++ ":"
642645 , go err
643646 ]
644647 go (PositionedError srcSpan err) =
645− paras [ line $ "Error at " ++ displaySourceSpan srcSpan ++ ":"
648+ paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
646649 , indent $ go err
647650 ]
648651 go (SimpleErrorWrapper sem) = goSimple sem
@@ -650,6 +653,9 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
650653 line :: String -> Box.Box
651654 line = Box.text
652655
656+ lineWithLevel :: String -> Box.Box
657+ lineWithLevel text = line $ show level ++ " " ++ text
658+
653659 suggestions :: ErrorMessage -> [Box.Box]
654660 suggestions = suggestions' . unwrapErrorMessage
655661 where
@@ -727,23 +733,23 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
727733-- Pretty print multiple errors
728734--
729735prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
730−prettyPrintMultipleErrors full = flip evalState M.empty . prettyPrintMultipleErrorsWith "Error:" "Multiple errors:" full
736+prettyPrintMultipleErrors full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error:" "Multiple errors:" full
731737
732738-- |
733739-- Pretty print multiple warnings
734740--
735741prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
736−prettyPrintMultipleWarnings full = flip evalState M.empty . prettyPrintMultipleErrorsWith "Warning:" "Multiple warnings:" full
742+prettyPrintMultipleWarnings full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning:" "Multiple warnings:" full
737743
738−prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> State UnknownMap String
739−prettyPrintMultipleErrorsWith intro _ full (MultipleErrors [e]) = do
740− result <- prettyPrintSingleError full e
744+prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap String
745+prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
746+ result <- prettyPrintSingleError full level e
741747 return $ renderBox $
742748 Box.vcat Box.left [ Box.text intro
743749 , result
744750 ]
745−prettyPrintMultipleErrorsWith _ intro full (MultipleErrors es) = do
746− result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full
751+prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
752+ result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full level
747753 return $ renderBox $
748754 Box.vcat Box.left [ Box.text intro
749755 , Box.vsep 1 Box.left result