4828b5d · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Improved error messages in the constraint solver (#2230)

Behold: No type class instance was found for Issue1310.Inject (Eff ( console :: CONSOLE | t0 ) ) (Eff ( oops :: Oops | eff1 ) ) The instance head contains unknown type variables. Consider adding a type annotation. while checking that expression inj (log "Oops") has type forall eff. Eff ( oops :: Oops | eff ) Unit while applying a function inj of type forall a g f. (Inject f g) => f a -> g a to argument log "Oops" in value declaration main where eff1 is a rigid type variable bound at line 18, column 1 - line 18, column 23 t0 is an unknown type

commit4828b5d3fa078361e03dd0f3dbbfa46dd4ee6b20 authorPhil Freeman <paf31@cantab.net> dateMon 25 Jul 2016, 19:50 (10 years ago) parent0824b1f

37 files changed+328−250

compare with golang

unifiedsplit

src/Language/PureScript/AST/Binders.hs+1−1

@@ -61,7 +61,7 @@ data Binder

6161 -- A binder with a type annotation

6262 --

6363 | TypedBinder Type Binder

64− deriving (Show, Read, Eq)

64+ deriving (Show, Eq)

6565

6666-- |

6767-- Collect all names introduced in binders in an expression

src/Language/PureScript/AST/Declarations.hs+153−12

@@ -22,6 +22,145 @@ import Language.PureScript.Kinds

2222import Language.PureScript.TypeClassDictionaries

2323import Language.PureScript.Comments

2424import Language.PureScript.Environment

25+import qualified Language.PureScript.Bundle as Bundle

26+

27+import qualified Text.Parsec as P

28+

29+-- | A type of error messages

30+data SimpleErrorMessage

31+ = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

32+ | ErrorParsingModule P.ParseError

33+ | MissingFFIModule ModuleName

34+ | MultipleFFIModules ModuleName [FilePath]

35+ | UnnecessaryFFIModule ModuleName FilePath

36+ | MissingFFIImplementations ModuleName [Ident]

37+ | UnusedFFIImplementations ModuleName [Ident]

38+ | InvalidFFIIdentifier ModuleName String

39+ | CannotGetFileInfo FilePath

40+ | CannotReadFile FilePath

41+ | CannotWriteFile FilePath

42+ | InfiniteType Type

43+ | InfiniteKind Kind

44+ | MultipleValueOpFixities (OpName 'ValueOpName)

45+ | MultipleTypeOpFixities (OpName 'TypeOpName)

46+ | OrphanTypeDeclaration Ident

47+ | RedefinedModule ModuleName [SourceSpan]

48+ | RedefinedIdent Ident

49+ | OverlappingNamesInLet

50+ | UnknownName (Qualified Name)

51+ | UnknownImport ModuleName Name

52+ | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)

53+ | UnknownExport Name

54+ | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)

55+ | ScopeConflict Name [ModuleName]

56+ | ScopeShadowing Name (Maybe ModuleName) [ModuleName]

57+ | DeclConflict Name Name

58+ | ExportConflict (Qualified Name) (Qualified Name)

59+ | DuplicateModuleName ModuleName

60+ | DuplicateTypeArgument String

61+ | InvalidDoBind

62+ | InvalidDoLet

63+ | CycleInDeclaration Ident

64+ | CycleInTypeSynonym (Maybe (ProperName 'TypeName))

65+ | CycleInModules [ModuleName]

66+ | NameIsUndefined Ident

67+ | UndefinedTypeVariable (ProperName 'TypeName)

68+ | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))

69+ | EscapedSkolem (Maybe Expr)

70+ | TypesDoNotUnify Type Type

71+ | KindsDoNotUnify Kind Kind

72+ | ConstrainedTypeUnified Type Type

73+ | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]

74+ | NoInstanceFound Constraint

75+ | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]

76+ | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

77+ | CannotFindDerivingType (ProperName 'TypeName)

78+ | DuplicateLabel String (Maybe Expr)

79+ | DuplicateValueDeclaration Ident

80+ | ArgListLengthsDiffer Ident

81+ | OverlappingArgNames (Maybe Ident)

82+ | MissingClassMember Ident

83+ | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))

84+ | ExpectedType Type Kind

85+ | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))

86+ | ExprDoesNotHaveType Expr Type

87+ | PropertyIsMissing String

88+ | AdditionalProperty String

89+ | CannotApplyFunction Type Expr

90+ | TypeSynonymInstance

91+ | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]

92+ | InvalidNewtype (ProperName 'TypeName)

93+ | InvalidInstanceHead Type

94+ | TransitiveExportError DeclarationRef [DeclarationRef]

95+ | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)

96+ | ShadowedName Ident

97+ | ShadowedTypeVar String

98+ | UnusedTypeVar String

99+ | WildcardInferredType Type

100+ | HoleInferredType String Type [(Ident, Type)]

101+ | MissingTypeDeclaration Ident Type

102+ | OverlappingPattern [[Binder]] Bool

103+ | IncompleteExhaustivityCheck

104+ | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)

105+ | ImportHidingModule ModuleName

106+ | UnusedImport ModuleName

107+ | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]

108+ | UnusedDctorImport (ProperName 'TypeName)

109+ | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]

110+ | DuplicateSelectiveImport ModuleName

111+ | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

112+ | DuplicateImportRef Name

113+ | DuplicateExportRef Name

114+ | IntOutOfRange Integer String Integer Integer

115+ | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

116+ | ImplicitImport ModuleName [DeclarationRef]

117+ | HidingImport ModuleName [DeclarationRef]

118+ | CaseBinderLengthDiffers Int [Binder]

119+ | IncorrectAnonymousArgument

120+ | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)

121+ | DeprecatedRequirePath

122+ | CannotGeneralizeRecursiveFunction Ident Type

123+ deriving (Show)

124+

125+-- | Error message hints, providing more detailed information about failure.

126+data ErrorMessageHint

127+ = ErrorUnifyingTypes Type Type

128+ | ErrorInExpression Expr

129+ | ErrorInModule ModuleName

130+ | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]

131+ | ErrorInSubsumption Type Type

132+ | ErrorCheckingAccessor Expr String

133+ | ErrorCheckingType Expr Type

134+ | ErrorCheckingKind Type

135+ | ErrorCheckingGuard

136+ | ErrorInferringType Expr

137+ | ErrorInApplication Expr Type Expr

138+ | ErrorInDataConstructor (ProperName 'ConstructorName)

139+ | ErrorInTypeConstructor (ProperName 'TypeName)

140+ | ErrorInBindingGroup [Ident]

141+ | ErrorInDataBindingGroup

142+ | ErrorInTypeSynonym (ProperName 'TypeName)

143+ | ErrorInValueDeclaration Ident

144+ | ErrorInTypeDeclaration Ident

145+ | ErrorInForeignImport Ident

146+ | ErrorSolvingConstraint Constraint

147+ | PositionedError SourceSpan

148+ deriving (Show)

149+

150+-- | Categories of hints

151+data HintCategory

152+ = ExprHint

153+ | KindHint

154+ | CheckHint

155+ | PositionHint

156+ | SolverHint

157+ | OtherHint

158+ deriving (Show, Eq)

159+

160+data ErrorMessage = ErrorMessage

161+ [ErrorMessageHint]

162+ SimpleErrorMessage

163+ deriving (Show)

25164

26165-- |

27166-- A module declaration, consisting of comments about the module, a module name,

@@ -29,7 +168,7 @@ import Language.PureScript.Environment

29168-- explicitly exported. If the export list is Nothing, everything is exported.

30169--

31170data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])

32− deriving (Show, Read)

171+ deriving (Show)

33172

34173-- | Return a module's name.

35174getModuleName :: Module -> ModuleName

@@ -88,7 +227,7 @@ data DeclarationRef

88227 -- A declaration reference with source position information

89228 --

90229 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

91− deriving (Show, Read)

230+ deriving (Show)

92231

93232instance Eq DeclarationRef where

94233 (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'

@@ -149,7 +288,7 @@ data ImportDeclarationType

149288 -- An import with a list of references to hide: `import M hiding (foo)`

150289 --

151290 | Hiding [DeclarationRef]

152− deriving (Eq, Show, Read)

291+ deriving (Eq, Show)

153292

154293isImplicit :: ImportDeclarationType -> Bool

155294isImplicit Implicit = True

@@ -216,15 +355,15 @@ data Declaration

216355 -- A declaration with source position information

217356 --

218357 | PositionedDeclaration SourceSpan [Comment] Declaration

219− deriving (Show, Read)

358+ deriving (Show)

220359

221360data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)

222− deriving (Eq, Ord, Show, Read)

361+ deriving (Eq, Ord, Show)

223362

224363data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)

225− deriving (Eq, Ord, Show, Read)

364+ deriving (Eq, Ord, Show)

226365

227−pattern ValueFixityDeclaration :: Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration

366+pattern ValueFixityDeclaration :: Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration

228367pattern ValueFixityDeclaration fixity name op = FixityDeclaration (Left (ValueFixity fixity name op))

229368

230369pattern TypeFixityDeclaration :: Fixity -> Qualified (ProperName 'TypeName) -> OpName 'TypeOpName -> Declaration

@@ -236,7 +375,7 @@ data TypeInstanceBody

236375 = DerivedInstance

237376 -- | This is a regular (explicit) instance

238377 | ExplicitInstance [Declaration]

239− deriving (Show, Read)

378+ deriving (Show)

240379

241380mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody

242381mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)

@@ -421,7 +560,9 @@ data Expr

421560 -- at superclass implementations when searching for a dictionary, the type class name and

422561 -- instance type, and the type class dictionaries in scope.

423562 --

424− | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

563+ | TypeClassDictionary Constraint

564+ (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

565+ [ErrorMessageHint]

425566 -- |

426567 -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.

427568 --

@@ -442,7 +583,7 @@ data Expr

442583 -- A value with source position information

443584 --

444585 | PositionedValue SourceSpan [Comment] Expr

445− deriving (Show, Read)

586+ deriving (Show)

446587

447588-- |

448589-- An alternative in a case statement

@@ -456,7 +597,7 @@ data CaseAlternative = CaseAlternative

456597 -- The result expression or a collect of guarded expressions

457598 --

458599 , caseAlternativeResult :: Either [(Guard, Expr)] Expr

459− } deriving (Show, Read)

600+ } deriving (Show)

460601

461602-- |

462603-- A statement in a do-notation block

@@ -478,7 +619,7 @@ data DoNotationElement

478619 -- A do notation element with source position information

479620 --

480621 | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement

481− deriving (Show, Read)

622+ deriving (Show)

482623

483624$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)

484625$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)

src/Language/PureScript/AST/Literals.hs+1−1

@@ -34,4 +34,4 @@ data Literal a

3434 -- An object literal

3535 --

3636 | ObjectLiteral [(String, a)]

37− deriving (Eq, Ord, Show, Read, Functor)

37+ deriving (Eq, Ord, Show, Functor)

src/Language/PureScript/AST/Operators.hs+2−2

@@ -21,7 +21,7 @@ type Precedence = Integer

2121-- Associativity for infix operators

2222--

2323data Associativity = Infixl | Infixr | Infix

24− deriving (Show, Read, Eq, Ord)

24+ deriving (Show, Eq, Ord)

2525

2626showAssoc :: Associativity -> String

2727showAssoc Infixl = "infixl"

@@ -44,7 +44,7 @@ instance A.FromJSON Associativity where

4444-- Fixity data for infix operators

4545--

4646data Fixity = Fixity Associativity Precedence

47− deriving (Show, Read, Eq, Ord)

47+ deriving (Show, Eq, Ord)

4848

4949instance A.ToJSON Fixity where

5050 toJSON (Fixity associativity precedence) =

src/Language/PureScript/AST/SourcePos.hs+2−2

@@ -22,7 +22,7 @@ data SourcePos = SourcePos

2222 -- Column number

2323 --

2424 , sourcePosColumn :: Int

25− } deriving (Show, Read, Eq, Ord)

25+ } deriving (Show, Eq, Ord)

2626

2727displaySourcePos :: SourcePos -> String

2828displaySourcePos sp =

@@ -50,7 +50,7 @@ data SourceSpan = SourceSpan

5050 -- End of the span

5151 --

5252 , spanEnd :: SourcePos

53− } deriving (Show, Read, Eq, Ord)

53+ } deriving (Show, Eq, Ord)

5454

5555displayStartEndPos :: SourceSpan -> String

5656displayStartEndPos sp =

src/Language/PureScript/AST/Traversals.hs+1−1

@@ -582,7 +582,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con

582582 forDecls (TypeDeclaration _ ty) = f ty

583583 forDecls _ = mempty

584584

585− forValues (TypeClassDictionary c _) = mconcat (map f (constraintArgs c))

585+ forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c))

586586 forValues (SuperClassDictionary _ tys) = mconcat (map f tys)

587587 forValues (TypedValue _ _ ty) = f ty

588588 forValues _ = mempty

src/Language/PureScript/Bundle.hs+3−3

@@ -43,20 +43,20 @@ data ErrorMessage

4343 | UnableToParseModule String

4444 | UnsupportedExport

4545 | ErrorInModule ModuleIdentifier ErrorMessage

46− deriving (Show, Read)

46+ deriving (Show)

4747

4848-- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules.

4949data ModuleType

5050 = Regular

5151 | Foreign

52− deriving (Show, Read, Eq, Ord)

52+ deriving (Show, Eq, Ord)

5353

5454showModuleType :: ModuleType -> String

5555showModuleType Regular = "Regular"

5656showModuleType Foreign = "Foreign"

5757

5858-- | A module is identified by its module name and its type.

59−data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read, Eq, Ord)

59+data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord)

6060

6161moduleName :: ModuleIdentifier -> String

6262moduleName (ModuleIdentifier name _) = name

src/Language/PureScript/CodeGen/JS.hs+3−1

@@ -27,7 +27,9 @@ import Language.PureScript.CodeGen.JS.Common as Common

2727import Language.PureScript.CodeGen.JS.Optimizer

2828import Language.PureScript.CoreFn

2929import Language.PureScript.Crash

30−import Language.PureScript.Errors

30+import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..),

31+ MultipleErrors(..), rethrow,

32+ errorMessage, rethrowWithPosition, addHint)

3133import Language.PureScript.Names

3234import Language.PureScript.Options

3335import Language.PureScript.Traversals (sndM)

src/Language/PureScript/CodeGen/JS/AST.hs+3−3

@@ -35,7 +35,7 @@ data UnaryOperator

3535 -- Constructor

3636 --

3737 | JSNew

38− deriving (Show, Read, Eq)

38+ deriving (Show, Eq)

3939

4040-- |

4141-- Built-in binary operators

@@ -117,7 +117,7 @@ data BinaryOperator

117117 -- Bitwise right shift with zero-fill

118118 --

119119 | ZeroFillShiftRight

120− deriving (Show, Read, Eq)

120+ deriving (Show, Eq)

121121

122122-- |

123123-- Data type for simplified Javascript expressions

@@ -238,7 +238,7 @@ data JS

238238 -- |

239239 -- Commented Javascript

240240 --

241− | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Read, Eq)

241+ | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Eq)

242242

243243withSourceSpan :: SourceSpan -> JS -> JS

244244withSourceSpan withSpan = go

src/Language/PureScript/Comments.hs+1−1

@@ -12,6 +12,6 @@ import Data.Aeson.TH

1212data Comment

1313 = LineComment String

1414 | BlockComment String

15− deriving (Show, Read, Eq, Ord)

15+ deriving (Show, Eq, Ord)

1616

1717$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)

src/Language/PureScript/CoreFn/Binders.hs+1−1

@@ -31,7 +31,7 @@ data Binder a

3131 -- |

3232 -- A binder which binds its input to an identifier

3333 --

34− | NamedBinder a Ident (Binder a) deriving (Show, Read, Functor)

34+ | NamedBinder a Ident (Binder a) deriving (Show, Functor)

3535

3636

3737extractBinderAnn :: Binder a -> a

src/Language/PureScript/CoreFn/Expr.hs+3−3

@@ -51,7 +51,7 @@ data Expr a

5151 -- A let binding

5252 --

5353 | Let a [Bind a] (Expr a)

54− deriving (Show, Read, Functor)

54+ deriving (Show, Functor)

5555

5656-- |

5757-- A let or module binding.

@@ -64,7 +64,7 @@ data Bind a

6464 -- |

6565 -- Mutually recursive binding group for several values

6666 --

67− | Rec [((a, Ident), Expr a)] deriving (Show, Read, Functor)

67+ | Rec [((a, Ident), Expr a)] deriving (Show, Functor)

6868

6969-- |

7070-- A guard is just a boolean-valued expression that appears alongside a set of binders

@@ -83,7 +83,7 @@ data CaseAlternative a = CaseAlternative

8383 -- The result expression or a collect of guarded expressions

8484 --

8585 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

86− } deriving (Show, Read)

86+ } deriving (Show)

8787

8888instance Functor CaseAlternative where

8989

src/Language/PureScript/CoreFn/Meta.hs+2−2

@@ -26,7 +26,7 @@ data Meta

2626 -- |

2727 -- The contained reference is for a foreign member

2828 --

29− | IsForeign deriving (Show, Read, Eq)

29+ | IsForeign deriving (Show, Eq)

3030

3131-- |

3232-- Data constructor metadata

@@ -39,4 +39,4 @@ data ConstructorType

3939 -- |

4040 -- The constructor is for a type with multiple construcors

4141 --

42− | SumType deriving (Show, Read, Eq)

42+ | SumType deriving (Show, Eq)

src/Language/PureScript/CoreFn/Module.hs+1−1

@@ -17,6 +17,6 @@ data Module a = Module

1717 , moduleExports :: [Ident]

1818 , moduleForeign :: [ForeignDecl]

1919 , moduleDecls :: [Bind a]

20− } deriving (Show, Read)

20+ } deriving (Show)

2121

2222type ForeignDecl = (Ident, Type)

src/Language/PureScript/Docs/AsMarkdown.hs+1−1

@@ -110,7 +110,7 @@ childToString f decl@ChildDeclaration{..} =

110110data First

111111 = First

112112 | NotFirst

113− deriving (Show, Read, Eq, Ord)

113+ deriving (Show, Eq, Ord)

114114

115115type Docs = Writer [String] ()

116116

src/Language/PureScript/Environment.hs+5−5

@@ -46,7 +46,7 @@ data Environment = Environment {

4646 -- Type classes

4747 --

4848 , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

49− } deriving (Show, Read)

49+ } deriving (Show)

5050

5151-- |

5252-- The initial environment with no values and only the default javascript types defined

@@ -65,7 +65,7 @@ data NameVisibility

6565 -- |

6666 -- The name is defined in the another binding group, or has been made visible by a function binder

6767 --

68− | Defined deriving (Show, Read, Eq)

68+ | Defined deriving (Show, Eq)

6969

7070-- |

7171-- A flag for whether a name is for an private or public value - only public values will be

@@ -85,7 +85,7 @@ data NameKind

8585 -- A name for member introduced by foreign import

8686 --

8787 | External

88− deriving (Show, Read, Eq)

88+ deriving (Show, Eq)

8989

9090-- |

9191-- The kinds of a type

@@ -111,7 +111,7 @@ data TypeKind

111111 -- A scoped type variable

112112 --

113113 | ScopedTypeVar

114− deriving (Show, Read, Eq)

114+ deriving (Show, Eq)

115115

116116-- |

117117-- The type ('data' or 'newtype') of a data type declaration

@@ -125,7 +125,7 @@ data DataDeclType

125125 -- A newtype constructor

126126 --

127127 | Newtype

128− deriving (Show, Read, Eq, Ord)

128+ deriving (Show, Eq, Ord)

129129

130130showDataDeclType :: DataDeclType -> String

131131showDataDeclType Data = "data"

src/Language/PureScript/Errors.hs+32−143

@@ -1,7 +1,10 @@

11{-# LANGUAGE GeneralizedNewtypeDeriving #-}

22{-# LANGUAGE NamedFieldPuns #-}

4−module Language.PureScript.Errors where

4+module Language.PureScript.Errors

5+ ( module Language.PureScript.AST

6+ , module Language.PureScript.Errors

7+ ) where

69import Prelude.Compat

710

@@ -21,7 +24,6 @@ import qualified Data.Map as M

2124

2225import Language.PureScript.AST

2326import Language.PureScript.Crash

24−import Language.PureScript.Kinds

2527import Language.PureScript.Names

2628import Language.PureScript.Pretty

2729import Language.PureScript.Traversals

@@ -37,137 +39,6 @@ import qualified Text.Parsec.Error as PE

3739import qualified Text.PrettyPrint.Boxes as Box

3840import Text.Parsec.Error (Message(..))

3941

40−-- | A type of error messages

41−data SimpleErrorMessage

42− = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

43− | ErrorParsingModule P.ParseError

44− | MissingFFIModule ModuleName

45− | MultipleFFIModules ModuleName [FilePath]

46− | UnnecessaryFFIModule ModuleName FilePath

47− | MissingFFIImplementations ModuleName [Ident]

48− | UnusedFFIImplementations ModuleName [Ident]

49− | InvalidFFIIdentifier ModuleName String

50− | CannotGetFileInfo FilePath

51− | CannotReadFile FilePath

52− | CannotWriteFile FilePath

53− | InfiniteType Type

54− | InfiniteKind Kind

55− | MultipleValueOpFixities (OpName 'ValueOpName)

56− | MultipleTypeOpFixities (OpName 'TypeOpName)

57− | OrphanTypeDeclaration Ident

58− | RedefinedModule ModuleName [SourceSpan]

59− | RedefinedIdent Ident

60− | OverlappingNamesInLet

61− | UnknownName (Qualified Name)

62− | UnknownImport ModuleName Name

63− | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)

64− | UnknownExport Name

65− | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)

66− | ScopeConflict Name [ModuleName]

67− | ScopeShadowing Name (Maybe ModuleName) [ModuleName]

68− | DeclConflict Name Name

69− | ExportConflict (Qualified Name) (Qualified Name)

70− | DuplicateModuleName ModuleName

71− | DuplicateTypeArgument String

72− | InvalidDoBind

73− | InvalidDoLet

74− | CycleInDeclaration Ident

75− | CycleInTypeSynonym (Maybe (ProperName 'TypeName))

76− | CycleInModules [ModuleName]

77− | NameIsUndefined Ident

78− | UndefinedTypeVariable (ProperName 'TypeName)

79− | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))

80− | EscapedSkolem (Maybe Expr)

81− | TypesDoNotUnify Type Type

82− | KindsDoNotUnify Kind Kind

83− | ConstrainedTypeUnified Type Type

84− | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]

85− | NoInstanceFound Constraint

86− | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]

87− | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

88− | CannotFindDerivingType (ProperName 'TypeName)

89− | DuplicateLabel String (Maybe Expr)

90− | DuplicateValueDeclaration Ident

91− | ArgListLengthsDiffer Ident

92− | OverlappingArgNames (Maybe Ident)

93− | MissingClassMember Ident

94− | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))

95− | ExpectedType Type Kind

96− | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))

97− | ExprDoesNotHaveType Expr Type

98− | PropertyIsMissing String

99− | AdditionalProperty String

100− | CannotApplyFunction Type Expr

101− | TypeSynonymInstance

102− | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]

103− | InvalidNewtype (ProperName 'TypeName)

104− | InvalidInstanceHead Type

105− | TransitiveExportError DeclarationRef [DeclarationRef]

106− | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)

107− | ShadowedName Ident

108− | ShadowedTypeVar String

109− | UnusedTypeVar String

110− | WildcardInferredType Type

111− | HoleInferredType String Type [(Ident, Type)]

112− | MissingTypeDeclaration Ident Type

113− | OverlappingPattern [[Binder]] Bool

114− | IncompleteExhaustivityCheck

115− | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)

116− | ImportHidingModule ModuleName

117− | UnusedImport ModuleName

118− | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]

119− | UnusedDctorImport (ProperName 'TypeName)

120− | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]

121− | DuplicateSelectiveImport ModuleName

122− | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

123− | DuplicateImportRef Name

124− | DuplicateExportRef Name

125− | IntOutOfRange Integer String Integer Integer

126− | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

127− | ImplicitImport ModuleName [DeclarationRef]

128− | HidingImport ModuleName [DeclarationRef]

129− | CaseBinderLengthDiffers Int [Binder]

130− | IncorrectAnonymousArgument

131− | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)

132− | DeprecatedRequirePath

133− | CannotGeneralizeRecursiveFunction Ident Type

134− deriving (Show)

135−

136−-- | Error message hints, providing more detailed information about failure.

137−data ErrorMessageHint

138− = ErrorUnifyingTypes Type Type

139− | ErrorInExpression Expr

140− | ErrorInModule ModuleName

141− | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]

142− | ErrorInSubsumption Type Type

143− | ErrorCheckingAccessor Expr String

144− | ErrorCheckingType Expr Type

145− | ErrorCheckingKind Type

146− | ErrorCheckingGuard

147− | ErrorInferringType Expr

148− | ErrorInApplication Expr Type Expr

149− | ErrorInDataConstructor (ProperName 'ConstructorName)

150− | ErrorInTypeConstructor (ProperName 'TypeName)

151− | ErrorInBindingGroup [Ident]

152− | ErrorInDataBindingGroup

153− | ErrorInTypeSynonym (ProperName 'TypeName)

154− | ErrorInValueDeclaration Ident

155− | ErrorInTypeDeclaration Ident

156− | ErrorInForeignImport Ident

157− | PositionedError SourceSpan

158− deriving Show

159−

160−-- | Categories of hints

161−data HintCategory

162− = ExprHint

163− | KindHint

164− | CheckHint

165− | PositionHint

166− | OtherHint

167− deriving (Show, Eq)

168−

169−data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)

170−

17142newtype ErrorSuggestion = ErrorSuggestion String

17243

17344-- | Get the source span for an error

@@ -321,7 +192,11 @@ onErrorMessages f = MultipleErrors . map f . runMultipleErrors

321192

322193-- | Add a hint to an error message

323194addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors

324−addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se

195+addHint hint = addHints [hint]

196+

197+-- | Add hints to an error message

198+addHints :: [ErrorMessageHint] -> MultipleErrors -> MultipleErrors

199+addHints hints = onErrorMessages $ \(ErrorMessage hints' se) -> ErrorMessage (hints ++ hints') se

325200

326201-- | A map from rigid type variable name/unknown variable pairs to new variables.

327202data TypeMap = TypeMap

@@ -396,6 +271,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

396271 gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t

397272 gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2

398273 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts

274+ gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con

399275 gHint other = pure other

400276

401277wikiUri :: ErrorMessage -> String

@@ -1062,6 +938,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

1062938 paras [ detail

1063939 , line $ "in foreign import " ++ markCode (showIdent nm)

1064940 ]

941+ renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail =

942+ paras [ detail

943+ , line "while solving type class constriant"

944+ , markCodeBox $ indent $ Box.hsep 1 Box.left

945+ [ line (showQualified runProperName nm)

946+ , Box.vcat Box.left (map typeAtomAsBox ts)

947+ ]

948+ ]

1065949 renderHint (PositionedError srcSpan) detail =

1066950 paras [ line $ "at " ++ displaySourceSpan srcSpan

1067951 , detail

@@ -1139,6 +1023,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

11391023 where

11401024 isUnifyHint ErrorUnifyingTypes{} = True

11411025 isUnifyHint _ = False

1026+ stripRedudantHints NoInstanceFound{} = stripFirst isSolverHint

1027+ where

1028+ isSolverHint ErrorSolvingConstraint{} = True

1029+ isSolverHint _ = False

11421030 stripRedudantHints _ = id

11431031

11441032 stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint]

@@ -1150,15 +1038,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

11501038 stripFirst _ [] = []

11511039

11521040 hintCategory :: ErrorMessageHint -> HintCategory

1153− hintCategory ErrorCheckingType{} = ExprHint

1154− hintCategory ErrorInferringType{} = ExprHint

1155− hintCategory ErrorInExpression{} = ExprHint

1156− hintCategory ErrorUnifyingTypes{} = CheckHint

1157− hintCategory ErrorInSubsumption{} = CheckHint

1158− hintCategory ErrorInApplication{} = CheckHint

1159− hintCategory ErrorCheckingKind{} = CheckHint

1160− hintCategory PositionedError{} = PositionHint

1161− hintCategory _ = OtherHint

1041+ hintCategory ErrorCheckingType{} = ExprHint

1042+ hintCategory ErrorInferringType{} = ExprHint

1043+ hintCategory ErrorInExpression{} = ExprHint

1044+ hintCategory ErrorUnifyingTypes{} = CheckHint

1045+ hintCategory ErrorInSubsumption{} = CheckHint

1046+ hintCategory ErrorInApplication{} = CheckHint

1047+ hintCategory ErrorCheckingKind{} = CheckHint

1048+ hintCategory ErrorSolvingConstraint{} = SolverHint

1049+ hintCategory PositionedError{} = PositionHint

1050+ hintCategory _ = OtherHint

11621051

11631052-- Pretty print and export declaration

11641053prettyPrintExport :: DeclarationRef -> String

src/Language/PureScript/Externs.hs+5−5

@@ -50,7 +50,7 @@ data ExternsFile = ExternsFile

5050 , efTypeFixities :: [ExternsTypeFixity]

5151 -- | List of type and value declaration

5252 , efDeclarations :: [ExternsDeclaration]

53− } deriving (Show, Read)

53+ } deriving (Show)

5454

5555-- | A module import in an externs file

5656data ExternsImport = ExternsImport

@@ -61,7 +61,7 @@ data ExternsImport = ExternsImport

6161 , eiImportType :: ImportDeclarationType

6262 -- | The imported-as name, for qualified imports

6363 , eiImportedAs :: Maybe ModuleName

64− } deriving (Show, Read)

64+ } deriving (Show)

6565

6666-- | A fixity declaration in an externs file

6767data ExternsFixity = ExternsFixity

@@ -74,7 +74,7 @@ data ExternsFixity = ExternsFixity

7474 , efOperator :: OpName 'ValueOpName

7575 -- | The value the operator is an alias for

7676 , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName))

77− } deriving (Show, Read)

77+ } deriving (Show)

7878

7979-- | A type fixity declaration in an externs file

8080data ExternsTypeFixity = ExternsTypeFixity

@@ -87,7 +87,7 @@ data ExternsTypeFixity = ExternsTypeFixity

8787 , efTypeOperator :: OpName 'TypeOpName

8888 -- | The value the operator is an alias for

8989 , efTypeAlias :: Qualified (ProperName 'TypeName)

90− } deriving (Show, Read)

90+ } deriving (Show)

9191

9292-- | A type or value declaration appearing in an externs file

9393data ExternsDeclaration =

@@ -130,7 +130,7 @@ data ExternsDeclaration =

130130 , edInstanceTypes :: [Type]

131131 , edInstanceConstraints :: Maybe [Constraint]

132132 }

133− deriving (Show, Read)

133+ deriving (Show)

134134

135135-- | Convert an externs file back into a module

136136applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment

src/Language/PureScript/Interactive/Completion.hs+1−1

@@ -91,7 +91,7 @@ data CompletionContext

9191 | CtxIdentifier

9292 | CtxType

9393 | CtxFixed String

94− deriving (Show, Read)

94+ deriving (Show)

9595

9696-- |

9797-- Decide what kind of completion we need based on input. This function expects

src/Language/PureScript/Kinds.hs+1−1

@@ -20,7 +20,7 @@ data Kind

2020 | FunKind Kind Kind

2121 -- | Type-level strings

2222 | Symbol

23− deriving (Show, Read, Eq, Ord)

23+ deriving (Show, Eq, Ord)

2424

2525$(A.deriveJSON A.defaultOptions ''Kind)

2626

src/Language/PureScript/Make.hs+2−2

@@ -85,7 +85,7 @@ import qualified Text.Parsec as Parsec

8585-- | Progress messages from the make process

8686data ProgressMessage

8787 = CompilingModule ModuleName

88− deriving (Show, Read, Eq, Ord)

88+ deriving (Show, Eq, Ord)

8989

9090-- | Render a progress message

9191renderProgressMessage :: ProgressMessage -> String

@@ -129,7 +129,7 @@ data RebuildPolicy

129129 -- | Never rebuild this module

130130 = RebuildNever

131131 -- | Always rebuild this module

132− | RebuildAlways deriving (Show, Read, Eq, Ord)

132+ | RebuildAlways deriving (Show, Eq, Ord)

133133

134134-- | Rebuild a single module

135135rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

src/Language/PureScript/Names.hs+5−5

@@ -64,7 +64,7 @@ data Ident

6464 -- A generated name for an identifier

6565 --

6666 | GenIdent (Maybe String) Integer

67− deriving (Show, Read, Eq, Ord)

67+ deriving (Show, Eq, Ord)

6868

6969runIdent :: Ident -> String

7070runIdent (Ident i) = i

@@ -84,7 +84,7 @@ freshIdent' = GenIdent Nothing <$> fresh

8484-- Operator alias names.

8585--

8686newtype OpName (a :: OpNameType) = OpName { runOpName :: String }

87− deriving (Show, Read, Eq, Ord)

87+ deriving (Show, Eq, Ord)

8888

8989instance ToJSON (OpName a) where

9090 toJSON = toJSON . runOpName

@@ -104,7 +104,7 @@ data OpNameType = ValueOpName | TypeOpName

104104-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

105105--

106106newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }

107− deriving (Show, Read, Eq, Ord)

107+ deriving (Show, Eq, Ord)

108108

109109instance ToJSON (ProperName a) where

110110 toJSON = toJSON . runProperName

@@ -129,7 +129,7 @@ coerceProperName = ProperName . runProperName

129129-- Module names

130130--

131131newtype ModuleName = ModuleName [ProperName 'Namespace]

132− deriving (Show, Read, Eq, Ord)

132+ deriving (Show, Eq, Ord)

133133

134134runModuleName :: ModuleName -> String

135135runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)

@@ -146,7 +146,7 @@ moduleNameFromString = ModuleName . splitProperNames

146146-- A qualified name, i.e. a name with an optional module name

147147--

148148data Qualified a = Qualified (Maybe ModuleName) a

149− deriving (Show, Read, Eq, Ord, Functor)

149+ deriving (Show, Eq, Ord, Functor)

150150

151151showQualified :: (a -> String) -> Qualified a -> String

152152showQualified f (Qualified Nothing a) = f a

src/Language/PureScript/Parser/Lexer.hs+1−1

@@ -104,7 +104,7 @@ data Token

104104 | StringLiteral String

105105 | Number (Either Integer Double)

106106 | HoleLit String

107− deriving (Show, Read, Eq, Ord)

107+ deriving (Show, Eq, Ord)

108108

109109prettyPrintToken :: Token -> String

110110prettyPrintToken LParen = "("

src/Language/PureScript/Pretty/Values.hs+1−1

@@ -60,7 +60,7 @@ prettyPrintValue d (Let ds val) =

6060 (text "in " <> prettyPrintValue (d - 1) val)

6161prettyPrintValue d (Do els) =

6262 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)

63−prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys

63+prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys

6464prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)

6565prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

6666 text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"

src/Language/PureScript/Publish.hs+2−2

@@ -169,7 +169,7 @@ getModulesAndBookmarks = do

169169 Left err ->

170170 userError (CompileError err)

171171

172−data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)

172+data TreeStatus = Clean | Dirty deriving (Show, Eq, Ord, Enum)

173173

174174getGitWorkingTreeStatus :: PrepareM TreeStatus

175175getGitWorkingTreeStatus = do

@@ -273,7 +273,7 @@ data DependencyStatus

273273 | ResolvedVersion String

274274 -- ^ Resolved to a version. The String argument is the resolution tag (eg,

275275 -- "v0.1.0").

276− deriving (Show, Read, Eq)

276+ deriving (Show, Eq)

277277

278278-- Go through all bower dependencies which contain purescript code, and

279279-- extract their versions.

src/Language/PureScript/Sugar/Names/Env.hs+4−4

@@ -49,7 +49,7 @@ data ImportRecord a =

4949 , importSourceModule :: ModuleName

5050 , importProvenance :: ImportProvenance

5151 }

52− deriving (Eq, Ord, Show, Read)

52+ deriving (Eq, Ord, Show)

5353

5454-- |

5555-- Used to track how an import was introduced into scope. This allows us to

@@ -61,7 +61,7 @@ data ImportProvenance

6161 | FromExplicit

6262 | Local

6363 | Prim

64− deriving (Eq, Ord, Show, Read)

64+ deriving (Eq, Ord, Show)

6565

6666type ImportMap a = M.Map (Qualified a) [ImportRecord a]

6767

@@ -104,7 +104,7 @@ data Imports = Imports

104104 -- The "as" names of modules that have been imported qualified.

105105 --

106106 , importedQualModules :: S.Set ModuleName

107− } deriving (Show, Read)

107+ } deriving (Show)

108108

109109nullImports :: Imports

110110nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty

@@ -155,7 +155,7 @@ data Exports = Exports

155155 -- from.

156156 --

157157 , exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName

158− } deriving (Show, Read)

158+ } deriving (Show)

159159

160160-- |

161161-- An empty 'Exports' value.

src/Language/PureScript/Sugar/Operators.hs+2−2

@@ -329,9 +329,9 @@ updateTypes goType = (goDecl, goExpr, goBinder)

329329

330330 goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)

331331 goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)

332− goExpr pos (TypeClassDictionary (Constraint name tys info) dicts) = do

332+ goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do

333333 tys' <- traverse (goType' pos) tys

334− return (pos, TypeClassDictionary (Constraint name tys' info) dicts)

334+ return (pos, TypeClassDictionary (Constraint name tys' info) dicts hints)

335335 goExpr pos (SuperClassDictionary cls tys) = do

336336 tys' <- traverse (goType' pos) tys

337337 return (pos, SuperClassDictionary cls tys')

src/Language/PureScript/Sugar/TypeClasses.hs+1−2

@@ -11,9 +11,8 @@ module Language.PureScript.Sugar.TypeClasses

1111import Prelude.Compat

1212

1313import Language.PureScript.Crash

14−import Language.PureScript.AST hiding (isExported)

1514import Language.PureScript.Environment

16−import Language.PureScript.Errors

15+import Language.PureScript.Errors hiding (isExported)

1716import Language.PureScript.Kinds

1817import Language.PureScript.Names

1918import Language.PureScript.Externs

src/Language/PureScript/TypeChecker/Entailment.hs+6−4

@@ -22,6 +22,7 @@ import Language.PureScript.AST

2222import Language.PureScript.Crash

2323import Language.PureScript.Errors

2424import Language.PureScript.Names

25+import Language.PureScript.TypeChecker.Monad (CheckState, withErrorMessageHint)

2526import Language.PureScript.TypeChecker.Unify

2627import Language.PureScript.TypeClassDictionaries

2728import Language.PureScript.Types

@@ -39,7 +40,7 @@ combineContexts = M.unionWith (M.unionWith M.union)

3940

4041-- | Replace type class dictionary placeholders with inferred type class dictionaries

4142replaceTypeClassDictionaries

42− :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

43+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

4344 => Bool

4445 -> ModuleName

4546 -> Expr

@@ -48,7 +49,8 @@ replaceTypeClassDictionaries shouldGeneralize mn =

4849 let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return

4950 in flip evalStateT M.empty . runWriterT . f

5051 where

51− go (TypeClassDictionary constraint dicts) = entails shouldGeneralize mn dicts constraint

52+ go (TypeClassDictionary constraint dicts hints) =

53+ rethrow (addHints hints) $ entails shouldGeneralize mn dicts constraint

5254 go other = return (other, [])

5355

5456-- |

@@ -57,7 +59,7 @@ replaceTypeClassDictionaries shouldGeneralize mn =

5759--

5860entails

5961 :: forall m

60− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

62+ . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

6163 => Bool

6264 -> ModuleName

6365 -> Context

@@ -79,7 +81,7 @@ entails shouldGeneralize moduleName context = solve

7981 findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx

8082

8183 solve :: Constraint -> StateT Context m (Expr, [(Ident, Constraint)])

82− solve con = do

84+ solve con = StateT . (withErrorMessageHint (ErrorSolvingConstraint con) .) . runStateT $ do

8385 (dict, unsolved) <- go 0 con

8486 return (dictionaryValueToValue dict, unsolved)

8587 where

src/Language/PureScript/TypeChecker/Kinds.hs+2−2

@@ -107,7 +107,7 @@ kindOfWithScopedVars ::

107107 Type ->

108108 m (Kind, [(String, Kind)])

109109kindOfWithScopedVars ty =

110− rethrow (addHint (ErrorCheckingKind ty)) $

110+ withErrorMessageHint (ErrorCheckingKind ty) $

111111 fmap tidyUp . liftUnify $ infer ty

112112 where

113113 tidyUp ((k, args), sub) = ( starIfUnknown (substituteKind sub k)

@@ -200,7 +200,7 @@ infer

200200 :: (MonadError MultipleErrors m, MonadState CheckState m)

201201 => Type

202202 -> m (Kind, [(String, Kind)])

203−infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty

203+infer ty = withErrorMessageHint (ErrorCheckingKind ty) $ infer' ty

204204

205205infer'

206206 :: forall m

src/Language/PureScript/TypeChecker/Monad.hs+47−8

@@ -35,18 +35,30 @@ emptySubstitution = Substitution M.empty M.empty

3535

3636-- | State required for type checking

3737data CheckState = CheckState

38− { checkEnv :: Environment -- ^ The current @Environment@

39− , checkNextType :: Int -- ^ The next type unification variable

40− , checkNextKind :: Int -- ^ The next kind unification variable

41− , checkNextSkolem :: Int -- ^ The next skolem variable

42− , checkNextSkolemScope :: Int -- ^ The next skolem scope constant

43− , checkCurrentModule :: Maybe ModuleName -- ^ The current module

44− , checkSubstitution :: Substitution -- ^ The current substitution

38+ { checkEnv :: Environment

39+ -- ^ The current @Environment@

40+ , checkNextType :: Int

41+ -- ^ The next type unification variable

42+ , checkNextKind :: Int

43+ -- ^ The next kind unification variable

44+ , checkNextSkolem :: Int

45+ -- ^ The next skolem variable

46+ , checkNextSkolemScope :: Int

47+ -- ^ The next skolem scope constant

48+ , checkCurrentModule :: Maybe ModuleName

49+ -- ^ The current module

50+ , checkSubstitution :: Substitution

51+ -- ^ The current substitution

52+ , checkHints :: [ErrorMessageHint]

53+ -- ^ The current error message hint stack.

54+ -- This goes into state, rather than using 'rethrow',

55+ -- since this way, we can provide good error messages

56+ -- during instance resolution.

4557 }

4658

4759-- | Create an empty @CheckState@

4860emptyCheckState :: Environment -> CheckState

49−emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution

61+emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution []

5062

5163-- | Unification variables

5264type Unknown = Int

@@ -91,6 +103,33 @@ withScopedTypeVars mn ks ma = do

91103 tell . errorMessage $ ShadowedTypeVar name

92104 bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma

93105

106+withErrorMessageHint

107+ :: (MonadState CheckState m, MonadError MultipleErrors m)

108+ => ErrorMessageHint

109+ -> m a

110+ -> m a

111+withErrorMessageHint hint action = do

112+ orig <- get

113+ modify $ \st -> st { checkHints = hint : checkHints st }

114+ -- Need to use 'rethrow' anyway, since we have to handle regular errors

115+ a <- rethrow (addHint hint) action

116+ modify $ \st -> st { checkHints = checkHints orig }

117+ return a

118+

119+rethrowWithPositionTC

120+ :: (MonadState CheckState m, MonadError MultipleErrors m)

121+ => SourceSpan

122+ -> m a

123+ -> m a

124+rethrowWithPositionTC pos = withErrorMessageHint (PositionedError pos)

125+

126+warnAndRethrowWithPositionTC

127+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

128+ => SourceSpan

129+ -> m a

130+ -> m a

131+warnAndRethrowWithPositionTC pos = rethrowWithPositionTC pos . warnWithPosition pos

132+

94133-- | Temporarily make a collection of type class dictionaries available

95134withTypeClassDictionaries

96135 :: MonadState CheckState m

src/Language/PureScript/TypeChecker/Subsumption.hs+4−3

@@ -8,7 +8,7 @@ module Language.PureScript.TypeChecker.Subsumption

88import Prelude.Compat

1010import Control.Monad.Error.Class (MonadError(..))

11−import Control.Monad.State.Class (MonadState(..))

11+import Control.Monad.State.Class (MonadState(..), gets)

1212

1313import Data.List (sortBy)

1414import Data.Ord (comparing)

@@ -24,7 +24,7 @@ import Language.PureScript.Types

2424

2525-- | Check that one type subsumes another, rethrowing errors to provide a better error message

2626subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)

27−subsumes val ty1 ty2 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2

27+subsumes val ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' val ty1 ty2

2828

2929-- | Check tahat one type subsumes another

3030subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) =>

@@ -52,7 +52,8 @@ subsumes' val ty1 (KindedType ty2 _) =

5252 subsumes val ty1 ty2

5353subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

5454 dicts <- getTypeClassDictionaries

55− subsumes' (Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty1 ty2

55+ hints <- gets checkHints

56+ subsumes' (Just $ foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty1 ty2

5657subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do

5758 let

5859 (ts1, r1') = rowToList r1

src/Language/PureScript/TypeChecker/Types.hs+21−16

@@ -201,7 +201,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'

201201 where

202202 g :: Expr -> Expr

203203 g (TypedValue checkTy val t) = TypedValue checkTy val (f t)

204− g (TypeClassDictionary c sco) = TypeClassDictionary (mapConstraintArgs (map f) c) sco

204+ g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints

205205 g other = other

206206

207207-- | Check the kind of a type, failing if it is not of kind *.

@@ -227,7 +227,8 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do

227227 instantiatePolyTypeWithUnknowns val ty'

228228instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

229229 dicts <- getTypeClassDictionaries

230− instantiatePolyTypeWithUnknowns (foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty

230+ hints <- gets checkHints

231+ instantiatePolyTypeWithUnknowns (foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty

231232instantiatePolyTypeWithUnknowns val ty = return (val, ty)

232233

233234-- | Infer a type for a value, rethrowing any error to provide a more useful error message

@@ -235,7 +236,7 @@ infer ::

235236 (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

236237 Expr ->

237238 m Expr

238−infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val

239+infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val

239240

240241-- | Infer a type for a value

241242infer' ::

@@ -267,7 +268,7 @@ infer' (ObjectUpdate o ps) = do

267268 let oldTy = TypeApp tyRecord $ rowFromList (oldTys, row)

268269 o' <- TypedValue True <$> check o oldTy <*> pure oldTy

269270 return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyRecord $ rowFromList (newTys, row)

270−infer' (Accessor prop val) = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do

271+infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do

271272 field <- freshType

272273 rest <- freshType

273274 typed <- check val (TypeApp tyRecord (RCons prop field rest))

@@ -290,7 +291,8 @@ infer' (Var var) = do

290291 case ty of

291292 ConstrainedType constraints ty' -> do

292293 dicts <- getTypeClassDictionaries

293− return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'

294+ hints <- gets checkHints

295+ return $ TypedValue True (foldl App (Var var) (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty'

294296 _ -> return $ TypedValue True (Var var) ty

295297infer' v@(Constructor c) = do

296298 env <- getEnv

@@ -316,7 +318,8 @@ infer' (Let ds val) = do

316318 return $ TypedValue True (Let ds' val') valTy

317319infer' (SuperClassDictionary className tys) = do

318320 dicts <- getTypeClassDictionaries

319− return $ TypeClassDictionary (Constraint className tys Nothing) dicts

321+ hints <- gets checkHints

322+ return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints

320323infer' (TypedValue checkType val ty) = do

321324 Just moduleName <- checkCurrentModule <$> get

322325 (kind, args) <- kindOfWithScopedVars ty

@@ -331,7 +334,7 @@ infer' (Hole name) = do

331334 let ctx = [ (ident, ty') | ((mn, ident@Ident{}), (ty', _, Defined)) <- env, mn == moduleName ]

332335 tell . errorMessage $ HoleInferredType name ty ctx

333336 return $ TypedValue True (Hole name) ty

334−infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do

337+infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do

335338 TypedValue t v ty <- infer' val

336339 return $ TypedValue t (PositionedValue pos c v) ty

337340infer' v = internalError $ "Invalid argument to infer: " ++ show v

@@ -368,7 +371,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

368371 bindNames dict $ do

369372 makeBindingGroupVisible

370373 inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j

371−inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do

374+inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPositionTC pos $ do

372375 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j

373376 return (PositionedDeclaration pos com d' : ds', val')

374377inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"

@@ -426,7 +429,7 @@ inferBinder val (NamedBinder name binder) = do

426429 m <- inferBinder val binder

427430 return $ M.insert name val m

428431inferBinder val (PositionedBinder pos _ binder) =

429− warnAndRethrowWithPosition pos $ inferBinder val binder

432+ warnAndRethrowWithPositionTC pos $ inferBinder val binder

430433-- TODO: When adding support for polymorphic types, check subsumption here,

431434-- change the definition of `binderRequiresMonotype`,

432435-- and use `kindOfWithScopedVars`.

@@ -487,7 +490,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do

487490 case result of

488491 Left gs -> do

489492 gs' <- forM gs $ \(grd, val) -> do

490− grd' <- rethrow (addHint ErrorCheckingGuard) $ check grd tyBoolean

493+ grd' <- withErrorMessageHint ErrorCheckingGuard $ check grd tyBoolean

491494 val' <- TypedValue True <$> check val ret <*> pure ret

492495 return (grd', val')

493496 return $ Left gs'

@@ -505,7 +508,7 @@ check ::

505508 Expr ->

506509 Type ->

507510 m Expr

508−check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty

511+check val ty = withErrorMessageHint (ErrorCheckingType val ty) $ check' val ty

509512

510513-- |

511514-- Check the type of a value

@@ -599,7 +602,8 @@ check' (SuperClassDictionary className tys) _ = do

599602 -- declaration gets desugared.

600603 -}

601604 dicts <- getTypeClassDictionaries

602− return $ TypeClassDictionary (Constraint className tys Nothing) dicts

605+ hints <- gets checkHints

606+ return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints

603607check' (TypedValue checkType val ty1) ty2 = do

604608 Just moduleName <- checkCurrentModule <$> get

605609 (kind, args) <- kindOfWithScopedVars ty1

@@ -638,7 +642,7 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyRecord = do

638642 obj' <- check obj (TypeApp tyRecord (rowFromList (us ++ remainingProps, rest)))

639643 ps' <- checkProperties e ps row True

640644 return $ TypedValue True (ObjectUpdate obj' ps') t

641−check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do

645+check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do

642646 rest <- freshType

643647 val' <- check val (TypeApp tyRecord (RCons prop ty rest))

644648 return $ TypedValue True (Accessor prop val') ty

@@ -659,7 +663,7 @@ check' val kt@(KindedType ty kind) = do

659663 checkTypeKind ty kind

660664 val' <- check' val ty

661665 return $ TypedValue True val' kt

662−check' (PositionedValue pos c val) ty = warnAndRethrowWithPosition pos $ do

666+check' (PositionedValue pos c val) ty = warnAndRethrowWithPositionTC pos $ do

663667 TypedValue t v ty' <- check' val ty

664668 return $ TypedValue t (PositionedValue pos c v) ty'

665669check' val ty = do

@@ -713,7 +717,7 @@ checkFunctionApplication ::

713717 Expr ->

714718 Maybe Type ->

715719 m (Type, Expr)

716−checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication fn fnTy arg)) $ do

720+checkFunctionApplication fn fnTy arg ret = withErrorMessageHint (ErrorInApplication fn fnTy arg) $ do

717721 subst <- gets checkSubstitution

718722 checkFunctionApplication' fn (substituteType subst fnTy) arg (substituteType subst <$> ret)

719723

@@ -749,7 +753,8 @@ checkFunctionApplication' fn (KindedType ty _) arg ret =

749753 checkFunctionApplication fn ty arg ret

750754checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do

751755 dicts <- getTypeClassDictionaries

752− checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret

756+ hints <- gets checkHints

757+ checkFunctionApplication' (foldl App fn (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) fnTy arg ret

753758checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =

754759 return (fnTy, App fn dict)

755760checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg

src/Language/PureScript/TypeChecker/Unify.hs+1−1

@@ -80,7 +80,7 @@ unknownsInType t = everythingOnTypes (.) go t []

8080unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()

8181unifyTypes t1 t2 = do

8282 sub <- gets checkSubstitution

83− rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ unifyTypes' (substituteType sub t1) (substituteType sub t2)

83+ withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2)

8484 where

8585 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()

8686 unifyTypes' (TUnknown u) t = solveType u t

src/Language/PureScript/TypeClassDictionaries.hs+2−2

@@ -21,7 +21,7 @@ data TypeClassDictionaryInScope

2121 -- | Type class dependencies which must be satisfied to construct this dictionary

2222 , tcdDependencies :: Maybe [Constraint]

2323 }

24− deriving (Show, Read)

24+ deriving (Show)

2525

2626-- |

2727-- A simplified representation of expressions which are used to represent type

@@ -44,4 +44,4 @@ data DictionaryValue

4444 -- A subclass dictionary

4545 --

4646 | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer

47− deriving (Show, Read, Ord, Eq)

47+ deriving (Show, Ord, Eq)

src/Language/PureScript/Types.hs+4−4

@@ -23,7 +23,7 @@ import Language.PureScript.Names

2323-- An identifier for the scope of a skolem variable

2424--

2525newtype SkolemScope = SkolemScope { runSkolemScope :: Int }

26− deriving (Show, Read, Eq, Ord, A.ToJSON, A.FromJSON)

26+ deriving (Show, Eq, Ord, A.ToJSON, A.FromJSON)

2727

2828-- |

2929-- The type of types

@@ -71,7 +71,7 @@ data Type

7171 -- Note: although it seems this constructor is not used, it _is_ useful,

7272 -- since it prevents certain traversals from matching.

7373 | ParensInType Type

74− deriving (Show, Read, Eq, Ord)

74+ deriving (Show, Eq, Ord)

7575

7676-- | Additional data relevant to type class constraints

7777data ConstraintData

@@ -81,7 +81,7 @@ data ConstraintData

8181 -- not matched, and a flag indicating whether the list was truncated or not.

8282 -- Note: we use 'String' here because using 'Binder' would introduce a cyclic

8383 -- dependency in the module graph.

84− deriving (Show, Read, Eq, Ord)

84+ deriving (Show, Eq, Ord)

8585

8686-- | A typeclass constraint

8787data Constraint = Constraint

@@ -91,7 +91,7 @@ data Constraint = Constraint

9191 -- ^ type arguments

9292 , constraintData :: Maybe ConstraintData

9393 -- ^ additional data relevant to this constraint

94− } deriving (Show, Read, Eq, Ord)

94+ } deriving (Show, Eq, Ord)

9595

9696mapConstraintArgs :: ([Type] -> [Type]) -> Constraint -> Constraint

9797mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) }

tests/TestPscPublish.hs+1−1

@@ -30,7 +30,7 @@ data TestResult

3030 = ParseFailed String

3131 | Mismatch ByteString ByteString -- ^ encoding before, encoding after

3232 | Pass ByteString

33− deriving (Show, Read)

33+ deriving (Show)

3434

3535roundTrip :: UploadedPackage -> TestResult

3636roundTrip pkg =