@@ -56,8 +56,7 @@ import Text.Parsec.Error (Message(..))
5656
5757-- | A type of error messages
5858data SimpleErrorMessage
59− = ErrorParsingExterns P.ParseError
60− | ErrorParsingFFIModule FilePath
59+ = ErrorParsingFFIModule FilePath
6160 | ErrorParsingModule P.ParseError
6261 | MissingFFIModule ModuleName
6362 | MultipleFFIModules ModuleName [FilePath]
@@ -148,8 +147,7 @@ data SimpleErrorMessage
148147
149148-- | Error message hints, providing more detailed information about failure.
150149data ErrorMessageHint
151− = NotYetDefined [Ident]
152− | ErrorUnifyingTypes Type Type
150+ = ErrorUnifyingTypes Type Type
153151 | ErrorInExpression Expr
154152 | ErrorInModule ModuleName
155153 | ErrorInInstance (Qualified ProperName) [Type]
@@ -192,7 +190,6 @@ instance UnificationError Kind ErrorMessage where
192190--
193191errorCode :: ErrorMessage -> String
194192errorCode em = case unwrapErrorMessage em of
195− ErrorParsingExterns{} -> "ErrorParsingExterns"
196193 ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"
197194 ErrorParsingModule{} -> "ErrorParsingModule"
198195 MissingFFIModule{} -> "MissingFFIModule"
@@ -375,9 +372,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
375372 prettyPrintErrorMessage :: ErrorMessage -> Box.Box
376373 prettyPrintErrorMessage (ErrorMessage hints simple) =
377374 paras $
378− map renderHint hints ++
379− [ renderSimpleErrorMessage simple
380− , line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."
375+ [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints
376+ , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, "
377+ , line $ "or to contribute content related to this " ++ levelText ++ "."
378+ ]
381379 ]
382380 where
383381 wikiUri :: String
@@ -396,10 +394,6 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
396394 paras [ line "Unable to write file: "
397395 , indent . line $ path
398396 ]
399− renderSimpleErrorMessage (ErrorParsingExterns err) =
400− paras [ lineWithLevel "parsing externs files: "
401− , prettyPrintParseError err
402− ]
403397 renderSimpleErrorMessage (ErrorParsingFFIModule path) =
404398 paras [ line "Unable to parse foreign module:"
405399 , indent . line $ path
@@ -694,81 +688,117 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
694688 , line "You may want to decompose your data types into smaller types."
695689 ]
696690
697− renderHint :: ErrorMessageHint -> Box.Box
698− renderHint (NotYetDefined names) =
699− line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"
700− renderHint (ErrorUnifyingTypes t1 t2) =
701− paras [ lineWithLevel "while trying to match type "
702− , indent $ typeAsBox t1
703− , line "with type"
704− , indent $ typeAsBox t2
705− ]
706− renderHint (ErrorInExpression expr) =
707− paras [ lineWithLevel "in expression:"
708− , indent $ prettyPrintValue expr
709− ]
710− renderHint (ErrorInModule mn) =
711− paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"
712− ]
713− renderHint (ErrorInSubsumption t1 t2) =
714− paras [ lineWithLevel "checking that type"
715− , indent $ typeAsBox t1
716− , line "is at least as general as type"
717− , indent $ typeAsBox t2
718− ]
719− renderHint (ErrorInInstance nm ts) =
720− paras [ lineWithLevel "in type class instance"
721− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
722− , Box.vcat Box.left (map typeAtomAsBox ts)
723− ]
724− ]
725− renderHint (ErrorCheckingKind ty) =
726− paras [ lineWithLevel "checking kind of type"
727− , indent $ typeAsBox ty
728− ]
729− renderHint (ErrorInferringType expr) =
730− paras [ lineWithLevel "inferring type of expression"
731− , indent $ prettyPrintValue expr
732− ]
733− renderHint (ErrorCheckingType expr ty) =
734− paras [ lineWithLevel "checking that expression"
735− , indent $ prettyPrintValue expr
736− , line "has type"
737− , indent $ typeAsBox ty
691+ renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
692+ renderHint (ErrorUnifyingTypes t1 t2) detail =
693+ paras [ detail
694+ , Box.hsep 1 Box.top [ line "while trying to match type"
695+ , typeAsBox t1
696+ ]
697+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type"
698+ , typeAsBox t2
699+ ]
700+ ]
701+ renderHint (ErrorInExpression expr) detail =
702+ paras [ detail
703+ , Box.hsep 1 Box.top [ Box.text "in the expression"
704+ , prettyPrintValue expr
705+ ]
706+ ]
707+ renderHint (ErrorInModule mn) detail =
708+ paras [ line $ "in module " ++ runModuleName mn
709+ , detail
710+ ]
711+ renderHint (ErrorInSubsumption t1 t2) detail =
712+ paras [ detail
713+ , Box.hsep 1 Box.top [ line "while checking that type"
714+ , typeAsBox t1
715+ ]
716+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type"
717+ , typeAsBox t2
718+ ]
719+ ]
720+ renderHint (ErrorInInstance nm ts) detail =
721+ paras [ detail
722+ , Box.hsep 1 Box.top [ line "in type class instance"
723+ , line (showQualified runProperName nm)
724+ , Box.vcat Box.left (map typeAtomAsBox ts)
725+ ]
726+ ]
727+ renderHint (ErrorCheckingKind ty) detail =
728+ paras [ detail
729+ , Box.hsep 1 Box.top [ line "while checking the kind of"
730+ , typeAsBox ty
731+ ]
732+ ]
733+ renderHint (ErrorInferringType expr) detail =
734+ paras [ detail
735+ , Box.hsep 1 Box.top [ line "while inferring the type of"
736+ , prettyPrintValue expr
737+ ]
738+ ]
739+ renderHint (ErrorCheckingType expr ty) detail =
740+ paras [ detail
741+ , Box.hsep 1 Box.top [ line "while checking that expression"
742+ , prettyPrintValue expr
743+ ]
744+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type"
745+ , typeAsBox ty
746+ ]
747+ ]
748+ renderHint (ErrorCheckingAccessor expr prop) detail =
749+ paras [ detail
750+ , Box.hsep 1 Box.top [ line "while checking type of property accessor"
751+ , prettyPrintValue (Accessor prop expr)
752+ ]
753+ ]
754+ renderHint (ErrorInApplication f t a) detail =
755+ paras [ detail
756+ , Box.hsep 1 Box.top [ line "while applying a function"
757+ , prettyPrintValue f
758+ ]
759+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type"
760+ , typeAsBox t
761+ ]
762+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument"
763+ , prettyPrintValue a
764+ ]
765+ ]
766+ renderHint (ErrorInDataConstructor nm) detail =
767+ paras [ detail
768+ , line $ "in data constructor " ++ runProperName nm
769+ ]
770+ renderHint (ErrorInTypeConstructor nm) detail =
771+ paras [ detail
772+ , line $ "in type constructor " ++ runProperName nm
773+ ]
774+ renderHint (ErrorInBindingGroup nms) detail =
775+ paras [ detail
776+ , line $ "in binding group " ++ intercalate ", " (map showIdent nms)
777+ ]
778+ renderHint ErrorInDataBindingGroup detail =
779+ paras [ detail
780+ , line "in data binding group"
781+ ]
782+ renderHint (ErrorInTypeSynonym name) detail =
783+ paras [ detail
784+ , line $ "in type synonym " ++ runProperName name
785+ ]
786+ renderHint (ErrorInValueDeclaration n) detail =
787+ paras [ detail
788+ , line $ "in value declaration " ++ showIdent n
789+ ]
790+ renderHint (ErrorInTypeDeclaration n) detail =
791+ paras [ detail
792+ , line $ "in type declaration for " ++ showIdent n
793+ ]
794+ renderHint (ErrorInForeignImport nm) detail =
795+ paras [ detail
796+ , line $ "in foreign import " ++ showIdent nm
797+ ]
798+ renderHint (PositionedError srcSpan) detail =
799+ paras [ line $ "at " ++ displaySourceSpan srcSpan
800+ , detail
738801 ]
739− renderHint (ErrorCheckingAccessor expr prop) =
740− paras [ lineWithLevel "checking type of property accessor"
741− , indent $ prettyPrintValue (Accessor prop expr)
742− ]
743− renderHint (ErrorInApplication f t a) =
744− paras [ lineWithLevel "applying a function"
745− , indent $ prettyPrintValue f
746− , line "of type"
747− , indent $ typeAsBox t
748− , line "to argument"
749− , indent $ prettyPrintValue a
750− ]
751− renderHint (ErrorInDataConstructor nm) =
752− lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"
753− renderHint (ErrorInTypeConstructor nm) =
754− lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"
755− renderHint (ErrorInBindingGroup nms) =
756− lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"
757− renderHint ErrorInDataBindingGroup =
758− lineWithLevel "in data binding group:"
759− renderHint (ErrorInTypeSynonym name) =
760− lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"
761− renderHint (ErrorInValueDeclaration n) =
762− lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"
763− renderHint (ErrorInTypeDeclaration n) =
764− lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"
765− renderHint (ErrorInForeignImport nm) =
766− lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"
767− renderHint (PositionedError srcSpan) =
768− lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
769−
770− lineWithLevel :: String -> Box.Box
771− lineWithLevel text = line $ show level ++ " " ++ text
772802
773803 levelText :: String
774804 levelText = case level of