3a7d26e · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #906 from purescript/745

3a7d26ePhil Freeman12 years ago

psci/Main.hs+1−1

compare with golang

unifiedsplit

@@ -531,7 +531,7 @@ handleKindOf typ = do

531 let chk = P.CheckState env' 0 0 (Just mName)

532 k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk

533 case k of

534− Left errStack -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack

534+ Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack

535 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind

536 Nothing -> PSCI $ outputStrLn "Could not find kind"

537

src/Control/Monad/Unify.hs+10−6

@@ -20,11 +20,9 @@

20{-# LANGUAGE MultiParamTypeClasses #-}

21{-# LANGUAGE FunctionalDependencies #-}

22{-# LANGUAGE UndecidableInstances #-}

23−{-# LANGUAGE OverloadedStrings #-}

25module Control.Monad.Unify where

24module Control.Monad.Unify where

27−import Data.String (IsString)

28import Data.Monoid

26import Data.Monoid

30import Control.Applicative

28import Control.Applicative

@@ -84,10 +82,16 @@ data UnifyState t = UnifyState {

84defaultUnifyState :: (Partial t) => UnifyState t

82defaultUnifyState :: (Partial t) => UnifyState t

85defaultUnifyState = UnifyState 0 mempty

83defaultUnifyState = UnifyState 0 mempty

85+-- |

86+-- A class for errors which support unification errors

87+--

88+class UnificationError t e where

89+ occursCheckFailed :: t -> e

90+

87-- |

91-- |

88-- The type checking monad, which provides the state of the type checker, and error reporting capabilities

92-- The type checking monad, which provides the state of the type checker, and error reporting capabilities

89--

93--

90−newtype UnifyT t m a = UnifyT { unUnify :: (StateT (UnifyState t) m) a }

94+newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a }

91 deriving (Functor, Monad, Applicative, Alternative, MonadPlus)

95 deriving (Functor, Monad, Applicative, Alternative, MonadPlus)

93instance (MonadState s m) => MonadState s (UnifyT t m) where

97instance (MonadState s m) => MonadState s (UnifyT t m) where

@@ -113,7 +117,7 @@ substituteOne u t = Substitution $ M.singleton u t

113-- |

117-- |

114-- Replace a unification variable with the specified value in the current substitution

118-- Replace a unification variable with the specified value in the current substitution

115--

119--

116−(=:=) :: (IsString e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()

120+(=:=) :: (UnificationError t e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()

117(=:=) u t' = do

121(=:=) u t' = do

118 st <- UnifyT get

122 st <- UnifyT get

119 let sub = unifyCurrentSubstitution st

123 let sub = unifyCurrentSubstitution st

@@ -128,10 +132,10 @@ substituteOne u t = Substitution $ M.singleton u t

128-- |

132-- |

129-- Perform the occurs check, to make sure a unification variable does not occur inside a value

133-- Perform the occurs check, to make sure a unification variable does not occur inside a value

130--

134--

131−occursCheck :: (IsString e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()

135+occursCheck :: (UnificationError t e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()

132occursCheck u t =

136occursCheck u t =

133 case isUnknown t of

137 case isUnknown t of

134− Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ "Occurs check fails"

138+ Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ occursCheckFailed t

135 _ -> return ()

139 _ -> return ()

136

140

137-- |

141-- |

src/Language/PureScript.hs+4−4

@@ -96,9 +96,9 @@ compile' env ms prefix = do

96 additional <- asks optionsAdditional

97 mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)

98 (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms

99− (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted

99+ (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ desugar sorted

100 (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent

101− regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

101+ regrouped <- interpretMultipleErrors True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

102 let corefn = map (CoreFn.moduleToCoreFn env') regrouped

103 let entryPoints = moduleNameFromString `map` entryPointModules additional

104 let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn

@@ -192,7 +192,7 @@ make outputDir ms prefix = do

192

193 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

194

195− (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)

195+ (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)

196

197 evalSupplyT nextVar $ go initEnvironment desugared

198

@@ -212,7 +212,7 @@ make outputDir ms prefix = do

212

213 (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m

214

215− regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

215+ regrouped <- interpretMultipleErrors True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

216

217 let mod' = Module coms moduleName' regrouped exps

218 let corefn = CoreFn.moduleToCoreFn env' mod'

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

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

30 -- Column number

31 --

32 , sourcePosColumn :: Int

33− } deriving (D.Data, D.Typeable)

33+ } deriving (Eq, D.Data, D.Typeable)

35instance Show SourcePos where

36 show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)

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

47 -- End of the span

48 --

49 , spanEnd :: SourcePos

50− } deriving (D.Data, D.Typeable)

50+ } deriving (Eq, D.Data, D.Typeable)

52instance Show SourceSpan where

53 show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)

src/Language/PureScript/Errors.hs+354−91

@@ -12,108 +12,378 @@

12--

13-----------------------------------------------------------------------------

15−{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}

15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

16+{-# LANGUAGE FlexibleContexts #-}

17+{-# LANGUAGE MultiParamTypeClasses #-}

17module Language.PureScript.Errors where

19module Language.PureScript.Errors where

19import Data.Either (lefts, rights)

21import Data.Either (lefts, rights)

20−import Data.String (IsString(..))

21import Data.List (intersperse, intercalate)

22import Data.List (intersperse, intercalate)

22import Data.Monoid

23import Data.Monoid

24+import Data.Foldable (fold, foldMap)

24import Control.Monad.Except

26import Control.Monad.Except

27+import Control.Monad.Unify

25import Control.Applicative ((<$>))

28import Control.Applicative ((<$>))

27import Language.PureScript.AST

30import Language.PureScript.AST

28import Language.PureScript.Pretty

31import Language.PureScript.Pretty

29import Language.PureScript.Types

32import Language.PureScript.Types

33+import Language.PureScript.Names

34+import Language.PureScript.Kinds

35+import Language.PureScript.TypeClassDictionaries

31-- |

37-- |

32−-- Type for sources of type checking errors

38+-- A type of error messages

33−--

39+--

34−data ErrorSource

40+data ErrorMessage

35− -- |

41+ = InfiniteType Type

36− -- An error which originated at a Expr

42+ | InfiniteKind Kind

37− --

43+ | CannotReorderOperators

38− = ExprError Expr

44+ | MultipleFixities Ident

39− -- |

45+ | OrphanTypeDeclaration Ident

40− -- An error which originated at a Type

46+ | OrphanFixityDeclaration String

41− --

47+ | RedefinedModule ModuleName

42− | TypeError Type deriving (Show)

48+ | RedefinedIdent Ident

43−

49+ | OverlappingNamesInLet

44−-- |

50+ | UnknownModule ModuleName

45−-- Compilation errors

51+ | UnknownType (Qualified ProperName)

46−--

52+ | UnknownTypeClass (Qualified ProperName)

47−data CompileError

53+ | UnknownValue (Qualified Ident)

48− = CompileError

54+ | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))

49− { -- |

55+ | UnknownTypeConstructor (Qualified ProperName)

50− -- Error message

56+ | ConflictingImport String ModuleName

51− --

57+ | ConflictingImports String ModuleName ModuleName

52− compileErrorMessage :: String

58+ | ConflictingTypeDecls ProperName

53− -- |

59+ | ConflictingCtorDecls ProperName

54− -- The value where the error occurred

60+ | TypeConflictsWithClass ProperName

55− --

61+ | CtorConflictsWithClass ProperName

56− , compileErrorValue :: Maybe ErrorSource

62+ | ClassConflictsWithType ProperName

57− -- |

63+ | ClassConflictsWithCtor ProperName

58− -- Optional source position information

64+ | DuplicateClassExport ProperName

59− --

65+ | DuplicateValueExport Ident

60− , compileErrorPosition :: Maybe SourceSpan

66+ | DuplicateTypeArgument String

61− }

67+ | InvalidDoBind

68+ | InvalidDoLet

69+ | CycleInDeclaration Ident

70+ | CycleInTypeSynonym (Maybe ProperName)

71+ | NameIsUndefined Ident

72+ | NameNotInScope Ident

73+ | UndefinedTypeVariable ProperName

74+ | PartiallyAppliedSynonym (Qualified ProperName)

75+ | NotYetDefined [Ident] ErrorMessage

76+ | EscapedSkolem (Maybe Expr)

77+ | UnspecifiedSkolemScope

78+ | TypesDoNotUnify Type Type

79+ | KindsDoNotUnify Kind Kind

80+ | ConstrainedTypeUnified Type Type

81+ | OverlappingInstances (Qualified ProperName) [Type] [DictionaryValue]

82+ | NoInstanceFound (Qualified ProperName) [Type]

83+ | DuplicateLabel String (Maybe Expr)

84+ | DuplicateValueDeclaration Ident

85+ | ArgListLengthsDiffer Ident

86+ | OverlappingArgNames (Maybe Ident)

87+ | MissingClassMember Ident

88+ | ExpectedType Kind

89+ | IncorrectConstructorArity (Qualified ProperName)

90+ | SubsumptionCheckFailed

91+ | ExprDoesNotHaveType Expr Type

92+ | PropertyIsMissing String Type

93+ | ErrorUnifyingTypes Type Type ErrorMessage

94+ | CannotApplyFunction Type Expr

95+ | TypeSynonymInstance

96+ | InvalidNewtype

97+ | InvalidInstanceHead Type

98+ | TransitiveExportError DeclarationRef [DeclarationRef]

99+ | ErrorInExpression Expr ErrorMessage

100+ | ErrorInModule ModuleName ErrorMessage

101+ | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage

102+ | ErrorInSubsumption Type Type ErrorMessage

103+ | ErrorCheckingType Expr Type ErrorMessage

104+ | ErrorCheckingKind Type ErrorMessage

105+ | ErrorInferringType Expr ErrorMessage

106+ | ErrorInApplication Expr Type Expr ErrorMessage

107+ | ErrorInDataConstructor ProperName ErrorMessage

108+ | ErrorInTypeConstructor ProperName ErrorMessage

109+ | ErrorInBindingGroup [Ident] ErrorMessage

110+ | ErrorInDataBindingGroup ErrorMessage

111+ | ErrorInTypeSynonym ProperName ErrorMessage

112+ | ErrorInValueDeclaration Ident ErrorMessage

113+ | ErrorInForeignImport Ident ErrorMessage

114+ | PositionedError SourceSpan ErrorMessage

62 deriving (Show)

115 deriving (Show)

116+

117+instance UnificationError Type ErrorMessage where

118+ occursCheckFailed = InfiniteType

119+

120+instance UnificationError Kind ErrorMessage where

121+ occursCheckFailed = InfiniteKind

122

64-- |

123-- |

65−-- A stack trace for an error

124+-- Get the error code for a particular error type

66--

125--

67−data ErrorStack

126+errorCode :: ErrorMessage -> String

68− = ErrorStack { runErrorStack :: [CompileError] }

127+errorCode (InfiniteType _) = "InfiniteType"

69− | MultipleErrors [ErrorStack] deriving (Show)

128+errorCode (InfiniteKind _) = "InfiniteKind"

129+errorCode CannotReorderOperators = "CannotReorderOperators"

130+errorCode (MultipleFixities _) = "MultipleFixities"

131+errorCode (OrphanTypeDeclaration _) = "OrphanTypeDeclaration"

132+errorCode (OrphanFixityDeclaration _) = "OrphanFixityDeclaration"

133+errorCode (RedefinedModule _) = "RedefinedModule"

134+errorCode (RedefinedIdent _) = "RedefinedIdent"

135+errorCode OverlappingNamesInLet = "OverlappingNamesInLet"

136+errorCode (UnknownModule _) = "UnknownModule"

137+errorCode (UnknownType _) = "UnknownType"

138+errorCode (UnknownTypeClass _) = "UnknownTypeClass"

139+errorCode (UnknownValue _) = "UnknownValue"

140+errorCode (UnknownDataConstructor _ _) = "UnknownDataConstructor"

141+errorCode (UnknownTypeConstructor _) = "UnknownTypeConstructor"

142+errorCode (ConflictingImport _ _) = "ConflictingImport"

143+errorCode (ConflictingImports _ _ _) = "ConflictingImports"

144+errorCode (ConflictingTypeDecls _) = "ConflictingTypeDecls"

145+errorCode (ConflictingCtorDecls _) = "ConflictingCtorDecls"

146+errorCode (TypeConflictsWithClass _) = "TypeConflictsWithClass"

147+errorCode (CtorConflictsWithClass _) = "CtorConflictsWithClass"

148+errorCode (ClassConflictsWithType _) = "ClassConflictsWithType"

149+errorCode (ClassConflictsWithCtor _) = "ClassConflictsWithCtor"

150+errorCode (DuplicateClassExport _) = "DuplicateClassExport"

151+errorCode (DuplicateValueExport _) = "DuplicateValueExport"

152+errorCode (DuplicateTypeArgument _) = "DuplicateTypeArgument"

153+errorCode InvalidDoBind = "InvalidDoBind"

154+errorCode InvalidDoLet = "InvalidDoLet"

155+errorCode (CycleInDeclaration _) = "CycleInDeclaration"

156+errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym"

157+errorCode (NameIsUndefined _) = "NameIsUndefined"

158+errorCode (NameNotInScope _) = "NameNotInScope"

159+errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable"

160+errorCode (PartiallyAppliedSynonym _) = "PartiallyAppliedSynonym"

161+errorCode (EscapedSkolem _) = "EscapedSkolem"

162+errorCode UnspecifiedSkolemScope = "UnspecifiedSkolemScope"

163+errorCode (TypesDoNotUnify _ _) = "TypesDoNotUnify"

164+errorCode (KindsDoNotUnify _ _) = "KindsDoNotUnify"

165+errorCode (ConstrainedTypeUnified _ _) = "ConstrainedTypeUnified"

166+errorCode (OverlappingInstances _ _ _) = "OverlappingInstances"

167+errorCode (NoInstanceFound _ _) = "NoInstanceFound"

168+errorCode (DuplicateLabel _ _) = "DuplicateLabel"

169+errorCode (DuplicateValueDeclaration _) = "DuplicateValueDeclaration"

170+errorCode (ArgListLengthsDiffer _) = "ArgListLengthsDiffer"

171+errorCode (OverlappingArgNames _) = "OverlappingArgNames"

172+errorCode (MissingClassMember _) = "MissingClassMember"

173+errorCode (ExpectedType _) = "ExpectedType"

174+errorCode (IncorrectConstructorArity _) = "IncorrectConstructorArity"

175+errorCode SubsumptionCheckFailed = "SubsumptionCheckFailed"

176+errorCode (ExprDoesNotHaveType _ _) = "ExprDoesNotHaveType"

177+errorCode (PropertyIsMissing _ _) = "PropertyIsMissing"

178+errorCode (ErrorUnifyingTypes _ _ _) = "ErrorUnifyingTypes"

179+errorCode (CannotApplyFunction _ _) = "CannotApplyFunction"

180+errorCode TypeSynonymInstance = "TypeSynonymInstance"

181+errorCode InvalidNewtype = "InvalidNewtype"

182+errorCode (InvalidInstanceHead _) = "InvalidInstanceHead"

183+errorCode (TransitiveExportError _ _) = "TransitiveExportError"

184+errorCode (NotYetDefined _ e) = errorCode e

185+errorCode (ErrorInExpression _ e) = errorCode e

186+errorCode (ErrorInModule _ e) = errorCode e

187+errorCode (ErrorInInstance _ _ e) = errorCode e

188+errorCode (ErrorInSubsumption _ _ e) = errorCode e

189+errorCode (ErrorCheckingType _ _ e) = errorCode e

190+errorCode (ErrorCheckingKind _ e) = errorCode e

191+errorCode (ErrorInferringType _ e) = errorCode e

192+errorCode (ErrorInApplication _ _ _ e) = errorCode e

193+errorCode (ErrorInDataConstructor _ e) = errorCode e

194+errorCode (ErrorInTypeConstructor _ e) = errorCode e

195+errorCode (ErrorInBindingGroup _ e) = errorCode e

196+errorCode (ErrorInDataBindingGroup e) = errorCode e

197+errorCode (ErrorInTypeSynonym _ e) = errorCode e

198+errorCode (ErrorInValueDeclaration _ e) = errorCode e

199+errorCode (ErrorInForeignImport _ e) = errorCode e

200+errorCode (PositionedError _ e) = errorCode e

201

71−-- TODO: Remove strMsg, the IsString instance, and unnecessary

202+-- |

72−-- OverloadedStrings pragmas. See #745

203+-- Pretty print an ErrorMessage

73−-- | Create an ErrorStack from a string

204+--

74−strMsg :: String -> ErrorStack

205+prettyPrintErrorMessage :: ErrorMessage -> String

75−strMsg s = ErrorStack [CompileError s Nothing Nothing]

206+prettyPrintErrorMessage e =

76−

207+ go e ++ "\n\nSee " ++ wikiUri ++ " for more information, or to contribute content related to this error."

77−instance IsString ErrorStack where

208+ where

78− fromString = strMsg

209+ wikiUri :: String

210+ wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

211+

212+ go :: ErrorMessage -> String

213+ go InvalidDoBind = "Bind statement cannot be the last statement in a do block"

214+ go InvalidDoLet = "Let statement cannot be the last statement in a do block"

215+ go CannotReorderOperators = "Unable to reorder operators"

216+ go UnspecifiedSkolemScope = "Skolem variable scope is unspecified"

217+ go OverlappingNamesInLet = "Overlapping names in let binding."

218+ go (InfiniteType ty) = "Infinite type detected: " ++ prettyPrintType ty

219+ go (InfiniteKind ki) = "Infinite kind detected: " ++ prettyPrintKind ki

220+ go (MultipleFixities name) = "Multiple fixity declarations for " ++ show name

221+ go (OrphanTypeDeclaration nm) = "Orphan type declaration for " ++ show nm

222+ go (OrphanFixityDeclaration op) = "Orphan fixity declaration for " ++ show op

223+ go (RedefinedModule name) = "Module " ++ show name ++ " has been defined multiple times"

224+ go (RedefinedIdent name) = "Name " ++ show name ++ " has been defined multiple times"

225+ go (UnknownModule mn) = "Unknown module " ++ show mn

226+ go (UnknownType name) = "Unknown type " ++ show name

227+ go (UnknownTypeClass name) = "Unknown type class " ++ show name

228+ go (UnknownValue name) = "Unknown value " ++ show name

229+ go (UnknownTypeConstructor name) = "Unknown type constructor " ++ show name

230+ go (UnknownDataConstructor dc tc) = "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc

231+ go (ConflictingImport nm mn) = "Declaration " ++ nm ++ " conflicts with import " ++ show mn

232+ go (ConflictingImports nm m1 m2) = "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2

233+ go (ConflictingTypeDecls nm) = "Conflicting type declarations for " ++ show nm

234+ go (ConflictingCtorDecls nm) = "Conflicting data constructor declarations for " ++ show nm

235+ go (TypeConflictsWithClass nm) = "Type " ++ show nm ++ " conflicts with type class declaration of the same name"

236+ go (CtorConflictsWithClass nm) = "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"

237+ go (ClassConflictsWithType nm) = "Type class " ++ show nm ++ " conflicts with type declaration of the same name"

238+ go (ClassConflictsWithCtor nm) = "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"

239+ go (DuplicateClassExport nm) = "Duplicate export declaration for type class " ++ show nm

240+ go (DuplicateValueExport nm) = "Duplicate export declaration for value " ++ show nm

241+ go (CycleInDeclaration nm) = "Cycle in declaration of " ++ show nm

242+ go (NotYetDefined names err) = "The following are not yet defined here: " ++ unwords (map show names) ++ "\n" ++ go err

243+ go (CycleInTypeSynonym pn) = "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn

244+ go (NameIsUndefined ident) = show ident ++ " is undefined"

245+ go (NameNotInScope ident) = show ident ++ " may not be defined in the current scope"

246+ go (UndefinedTypeVariable name) = "Type variable " ++ show name ++ " is undefined"

247+ go (PartiallyAppliedSynonym name) = "Partially applied type synonym " ++ show name

248+ go (EscapedSkolem binding) = "Rigid/skolem type variable " ++ foldMap (("bound by " ++) . prettyPrintValue) binding ++ " has escaped."

249+ go (TypesDoNotUnify t1 t2) = "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2

250+ go (KindsDoNotUnify k1 k2) = "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2

251+ go (ConstrainedTypeUnified t1 t2) = "Cannot unify constrained type " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2

252+ go (OverlappingInstances nm ts ds) = unlines ( ("Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintType ts) ++ ":")

253+ : map prettyPrintDictionaryValue ds)

254+ go (NoInstanceFound nm ts) = "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)

255+ go (DuplicateLabel l expr) = "Duplicate label " ++ show l ++ " in row." ++ foldMap ((" Relevant expression: " ++) . prettyPrintValue) expr

256+ go (DuplicateTypeArgument name) = "Duplicate type argument " ++ show name

257+ go (DuplicateValueDeclaration nm) = "Duplicate value declaration for " ++ show nm

258+ go (ArgListLengthsDiffer ident) = "Argument list lengths differ in declaration " ++ show ident

259+ go (OverlappingArgNames ident) = "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident

260+ go (MissingClassMember ident) = "Member " ++ show ident ++ " has not been implemented"

261+ go (ExpectedType kind) = "Expected type of kind *, was " ++ prettyPrintKind kind

262+ go (IncorrectConstructorArity nm) = "Wrong number of arguments to constructor " ++ show nm

263+ go SubsumptionCheckFailed = "Unable to check type subsumption"

264+ go (ExprDoesNotHaveType expr ty) = "Expression " ++ prettyPrintValue expr ++ " does not have type " ++ prettyPrintType ty

265+ go (PropertyIsMissing prop row) = "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop

266+ go (CannotApplyFunction fn arg) = "Cannot apply function of type " ++ prettyPrintType fn ++ " to argument " ++ prettyPrintValue arg

267+ go TypeSynonymInstance = "Type synonym instances are disallowed"

268+ go InvalidNewtype = "Newtypes must define a single constructor with a single argument"

269+ go (InvalidInstanceHead ty) = "Invalid type " ++ prettyPrintType ty ++ " in class instance head"

270+ go (TransitiveExportError x ys) = "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: " ++ intercalate ", " (map prettyPrintExport ys)

271+ go (ErrorUnifyingTypes t1 t2 err) = "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ go err

272+ go (ErrorInExpression expr err) = "Error in expression " ++ prettyPrintValue expr ++ ":\n" ++ go err

273+ go (ErrorInModule mn err) = "Error in module " ++ show mn ++ ":\n" ++ go err

274+ go (ErrorInSubsumption t1 t2 err) = "Error checking that type " ++ prettyPrintType t1 ++ " subsumes type " ++ prettyPrintType t2 ++ ":\n" ++ go err

275+ go (ErrorInInstance name ts err) = "Error in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":\n" ++ go err

276+ go (ErrorCheckingKind ty err) = "Error checking kind of type " ++ prettyPrintType ty ++ ":\n" ++ go err

277+ go (ErrorInferringType expr err) = "Error inferring type of value " ++ prettyPrintValue expr ++ ":\n" ++ go err

278+ go (ErrorCheckingType expr ty err) = "Error checking value " ++ prettyPrintValue expr ++ " has type " ++ prettyPrintType ty ++ ":\n" ++ go err

279+ go (ErrorInApplication f t a err) = "Error applying function " ++ prettyPrintValue f ++ " of type " ++ prettyPrintType t ++ " to argument " ++ prettyPrintValue a ++ ":\n" ++ go err

280+ go (ErrorInDataConstructor nm err) = "Error in data constructor " ++ show nm ++ ":\n" ++ go err

281+ go (ErrorInTypeConstructor nm err) = "Error in type constructor " ++ show nm ++ ":\n" ++ go err

282+ go (ErrorInBindingGroup nms err) = "Error in binding group " ++ intercalate ", " (map show nms) ++ ":\n" ++ go err

283+ go (ErrorInDataBindingGroup err) = "Error in data binding group:\n" ++ go err

284+ go (ErrorInTypeSynonym name err) = "Error in type synonym " ++ show name ++ ":\n" ++ go err

285+ go (ErrorInValueDeclaration n err) = "Error in value declaration " ++ show n ++ ":\n" ++ go err

286+ go (ErrorInForeignImport nm err) = "Error in foreign import " ++ show nm ++ ":\n" ++ go err

287+ go (PositionedError pos err) = "Error at " ++ show pos ++ ":\n" ++ go err

288

80−prettyPrintErrorStack :: Bool -> ErrorStack -> String

289+-- |

81−prettyPrintErrorStack printFullStack (ErrorStack es) =

290+-- Render a DictionaryValue fit for human consumption in error messages

82− case mconcat $ map (Last . compileErrorPosition) es of

291+--

83− Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'

292+prettyPrintDictionaryValue :: DictionaryValue -> String

84− _ -> prettyPrintErrorStack'

293+prettyPrintDictionaryValue = unlines . indented 0

85 where

294 where

86− prettyPrintErrorStack' :: String

295+ indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]

87− prettyPrintErrorStack'

296+ indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]

88− | printFullStack = intercalate "\n" (map showError (filter isErrorNonEmpty es))

297+ indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args

89− | otherwise =

298+ indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup

90− let

91− es' = filter isErrorNonEmpty es

92− in case length es' of

93− 1 -> showError (head es')

94− _ -> showError (head es') ++ "\n" ++ showError (last es')

95−prettyPrintErrorStack printFullStack (MultipleErrors es) =

96− unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es

299

98−stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a

300+ spaces n = replicate n ' ' ++ "- "

99−stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return

301+

302+-- |

303+-- Pretty print and export declaration

304+--

305+prettyPrintExport :: DeclarationRef -> String

306+prettyPrintExport (TypeRef pn _) = show pn

307+prettyPrintExport (ValueRef ident) = show ident

308+prettyPrintExport (TypeClassRef pn) = show pn

309+prettyPrintExport (TypeInstanceRef ident) = show ident

310+prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

311+

312+-- |

313+-- A stack trace for an error

314+--

315+newtype MultipleErrors = MultipleErrors

316+ { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)

317+

318+instance UnificationError Type MultipleErrors where

319+ occursCheckFailed = errorMessage . occursCheckFailed

320+

321+instance UnificationError Kind MultipleErrors where

322+ occursCheckFailed = errorMessage . occursCheckFailed

100

323

101−isErrorNonEmpty :: CompileError -> Bool

324+-- |

102−isErrorNonEmpty = not . null . compileErrorMessage

325+-- Simplify an error message

326+--

327+simplifyErrorMessage :: ErrorMessage -> ErrorMessage

328+simplifyErrorMessage = unwrap Nothing

329+ where

330+ unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

331+ unwrap pos (ErrorInExpression _ err) = unwrap pos err

332+ unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)

333+ unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)

334+ unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err

335+ unwrap pos (ErrorInferringType _ err) = unwrap pos err

336+ unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err

337+ unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)

338+ unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)

339+ unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err

340+ unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)

341+ unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)

342+ unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)

343+ unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)

344+ unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)

345+ unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)

346+ unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)

347+ unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)

348+ unwrap _ (PositionedError pos err) = unwrap (Just pos) err

349+ unwrap pos other = wrap pos other

350+

351+ wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

352+ wrap Nothing = id

353+ wrap (Just pos) = PositionedError pos

103

354

104−showError :: CompileError -> String

355+-- |

105−showError (CompileError msg Nothing _) = msg

356+-- Create an error set from a single error message

106−showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " ++ prettyPrintValue val ++ ":\n" ++ msg

357+--

107−showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg

358+errorMessage :: ErrorMessage -> MultipleErrors

359+errorMessage err = MultipleErrors [err]

108

360

109−mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack

361+-- |

110−mkErrorStack msg t = ErrorStack [mkCompileError msg t]

362+-- Lift a function on ErrorMessage to a function on MultipleErrors

363+--

364+onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors

365+onErrorMessages f = MultipleErrors . map f . runMultipleErrors

366+

367+-- |

368+-- Pretty print a single error, simplifying if necessary

369+--

370+prettyPrintSingleError :: Bool -> ErrorMessage -> String

371+prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else simplifyErrorMessage e)

111

372

112−mkCompileError :: String -> Maybe ErrorSource -> CompileError

373+-- |

113−mkCompileError msg t = CompileError msg t Nothing

374+-- Pretty print multiple errors

375+--

376+prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String

377+prettyPrintMultipleErrors full (MultipleErrors [e]) =

378+ prettyPrintSingleError full e

379+prettyPrintMultipleErrors full (MultipleErrors es) =

380+ unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintSingleError full) es

114

381

115−positionError :: SourceSpan -> CompileError

382+-- |

116−positionError pos = CompileError "" Nothing (Just pos)

383+-- Interpret multiple errors in a monad supporting errors

384+--

385+interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a

386+interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors printFullStack) return

117

387

118-- |

388-- |

119-- Rethrow an error with a more detailed error message in the case of failure

389-- Rethrow an error with a more detailed error message in the case of failure

@@ -124,30 +394,23 @@ rethrow f = flip catchError $ \e -> throwError (f e)

124-- |

394-- |

125-- Rethrow an error with source position information

395-- Rethrow an error with source position information

126--

396--

127−rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a

397+rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a

128−rethrowWithPosition pos = rethrow (positionError pos `combineErrors`)

398+rethrowWithPosition pos = rethrow (onErrorMessages withPosition)

399+ where

400+ withPosition :: ErrorMessage -> ErrorMessage

401+ withPosition (PositionedError _ err) = withPosition err

402+ withPosition err = PositionedError pos err

129

403

130-- |

404-- |

131-- Collect errors in in parallel

405-- Collect errors in in parallel

132--

406--

133−parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]

407+parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]

134parU xs f = forM xs (withError . f) >>= collectErrors

408parU xs f = forM xs (withError . f) >>= collectErrors

135 where

409 where

136− withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)

410+ withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a)

137 withError u = catchError (Right <$> u) (return . Left)

411 withError u = catchError (Right <$> u) (return . Left)

138

412

139− collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]

413+ collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]

140 collectErrors es = case lefts es of

414 collectErrors es = case lefts es of

141− [err] -> throwError err

142 [] -> return $ rights es

415 [] -> return $ rights es

143− errs -> throwError $ MultipleErrors errs

416+ errs -> throwError $ fold errs

144−

145−-- |

146−-- Add an extra error string onto the top of each error stack in a list of possibly many errors

147−--

148−combineErrors :: CompileError -> ErrorStack -> ErrorStack

149−combineErrors ce err = go (ErrorStack [ce]) err

150− where

151− go (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)

152− go (MultipleErrors es) x = MultipleErrors [ go e x | e <- es ]

153− go x (MultipleErrors es) = MultipleErrors [ go x e | e <- es ]

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

@@ -58,7 +58,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S

58--

59-- * Group mutually recursive value and data declarations into binding groups.

60--

61−desugar :: (Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]

61+desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

62desugar = map removeSignedLiterals

63 >>> mapM desugarObjectConstructors

64 >=> mapM desugarOperatorSections

src/Language/PureScript/Sugar/BindingGroups.hs+12−13

@@ -41,7 +41,7 @@ import Language.PureScript.Errors

41-- |

42-- Replace all sets of mutually-recursive declarations in a module with binding groups

43--

44−createBindingGroupsModule :: (Functor m, Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]

44+createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

45createBindingGroupsModule = mapM $ \(Module coms name ds exps) -> Module coms name <$> createBindingGroups name ds <*> pure exps

47-- |

@@ -50,20 +50,20 @@ createBindingGroupsModule = mapM $ \(Module coms name ds exps) -> Module coms na

50collapseBindingGroupsModule :: [Module] -> [Module]

51collapseBindingGroupsModule = map $ \(Module coms name ds exps) -> Module coms name (collapseBindingGroups ds) exps

53−createBindingGroups :: (Functor m, Applicative m, MonadError ErrorStack m) => ModuleName -> [Declaration] -> m [Declaration]

53+createBindingGroups :: (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]

54createBindingGroups moduleName = mapM f <=< handleDecls

56 where

57 (f, _, _) = everywhereOnValuesTopDownM return handleExprs return

59− handleExprs :: (Functor m, MonadError ErrorStack m) => Expr -> m Expr

59+ handleExprs :: (Functor m, MonadError MultipleErrors m) => Expr -> m Expr

60 handleExprs (Let ds val) = flip Let val <$> handleDecls ds

61 handleExprs other = return other

63 -- |

64 -- Replace all sets of mutually-recursive declarations with binding groups

65 --

66− handleDecls :: (Functor m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]

66+ handleDecls :: (Functor m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

67 handleDecls ds = do

68 let values = filter isValueDecl ds

69 dataDecls = filter isDataDecl ds

@@ -155,7 +155,7 @@ getProperName _ = error "Expected DataDeclaration"

155-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

156--

157--

158−toBindingGroup :: (Functor m, MonadError ErrorStack m) => ModuleName -> SCC Declaration -> m Declaration

158+toBindingGroup :: (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration

159toBindingGroup _ (AcyclicSCC d) = return d

160toBindingGroup _ (CyclicSCC [d]) = return d

161toBindingGroup moduleName (CyclicSCC ds') =

@@ -176,24 +176,23 @@ toBindingGroup moduleName (CyclicSCC ds') =

176 valueVerts :: [(Declaration, Ident, [Ident])]

177 valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'

178

179− toBinding :: (MonadError ErrorStack m) => SCC Declaration -> m (Ident, NameKind, Expr)

179+ toBinding :: (MonadError MultipleErrors m) => SCC Declaration -> m (Ident, NameKind, Expr)

180 toBinding (AcyclicSCC d) = return $ fromValueDecl d

181 toBinding (CyclicSCC ~(d:ds)) = cycleError d ds

182

183− cycleError :: (MonadError ErrorStack m) => Declaration -> [Declaration] -> m a

183+ cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a

184 cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

185− cycleError (ValueDeclaration n _ _ (Right e)) [] = throwError $

185+ cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n

186− mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))

187− cycleError d ds@(_:_) = rethrow (mkCompileError ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing `combineErrors`) $ cycleError d []

186+ cycleError d ds@(_:_) = rethrow (onErrorMessages (NotYetDefined (map getIdent ds))) $ cycleError d []

188 cycleError _ _ = error "Expected ValueDeclaration"

187 cycleError _ _ = error "Expected ValueDeclaration"

189

188

190−toDataBindingGroup :: (MonadError ErrorStack m) => SCC Declaration -> m Declaration

189+toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

191toDataBindingGroup (AcyclicSCC d) = return d

190toDataBindingGroup (AcyclicSCC d) = return d

192toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of

191toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of

193− Just pn -> throwError $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing

192+ Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn)

194 _ -> return d

193 _ -> return d

195toDataBindingGroup (CyclicSCC ds')

194toDataBindingGroup (CyclicSCC ds')

196− | all (isJust . isTypeSynonym) ds' = throwError $ mkErrorStack "Cycle in type synonyms" Nothing

195+ | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing

197 | otherwise = return $ DataBindingGroupDeclaration ds'

196 | otherwise = return $ DataBindingGroupDeclaration ds'

198

197

199isTypeSynonym :: Declaration -> Maybe ProperName

198isTypeSynonym :: Declaration -> Maybe ProperName

src/Language/PureScript/Sugar/CaseDeclarations.hs+11−11

@@ -44,17 +44,17 @@ isLeft (Right _) = False

44-- |

45-- Replace all top-level binders in a module with case expressions.

46--

47−desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]

47+desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

48desugarCasesModule ms = forM ms $ \(Module coms name ds exps) ->

49− rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $

49+ rethrow (onErrorMessages (ErrorInModule name)) $

50 Module coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps

52−desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]

52+desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

53desugarAbs = flip parU f

54 where

55 (f, _, _) = everywhereOnValuesM return replace return

57− replace :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Expr -> m Expr

57+ replace :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Expr -> m Expr

58 replace (Abs (Right binder) val) = do

59 ident <- Ident <$> freshName

60 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]

@@ -63,10 +63,10 @@ desugarAbs = flip parU f

63-- |

64-- Replace all top-level binders with case expressions.

65--

66−desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]

66+desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

67desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup

68 where

69− desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]

69+ desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

70 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

71 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest

72 desugarRest (ValueDeclaration name nameKind bs result : rest) =

@@ -89,18 +89,18 @@ inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2

89inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2

90inSameGroup _ _ = False

92−toDecls :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]

92+toDecls :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

93toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do

94 let args = map (\(VarBinder arg) -> arg) bs

95 body = foldr (Abs . Left) val args

96− guardWith (strMsg "Overlapping function argument names") $ length (nub args) == length args

96+ guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (nub args) == length args

97 return [ValueDeclaration ident nameKind [] (Right body)]

98toDecls ds@(ValueDeclaration ident _ bs result : _) = do

99 let tuples = map toTuple ds

100 unless (all ((== length bs) . length . fst) tuples) $

101− throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing

101+ throwError . errorMessage $ ArgListLengthsDiffer ident

102 unless (not (null bs) || isLeft result) $

103− throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing

103+ throwError . errorMessage $ DuplicateValueDeclaration ident

104 caseDecl <- makeCaseDeclaration ident tuples

105 return [caseDecl]

106toDecls (PositionedDeclaration pos com d : ds) = do

@@ -117,7 +117,7 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result)

117toTuple (PositionedDeclaration _ _ d) = toTuple d

118toTuple _ = error "Not a value declaration"

119

120−makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration

120+makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration

121makeCaseDeclaration ident alternatives = do

122 let argPattern = length . fst . head $ alternatives

123 args <- map Ident <$> replicateM argPattern freshName

src/Language/PureScript/Sugar/DoNotation.hs+4−4

@@ -35,10 +35,10 @@ import Control.Monad.Supply.Class

35-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,

36-- and all @DoNotationLet@ constructors with let expressions.

37--

38−desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> m Module

38+desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module

39desugarDoModule (Module coms mn ds exts) = Module coms mn <$> parU ds desugarDo <*> pure exts

41−desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Declaration -> m Declaration

41+desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration

42desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)

43desugarDo d =

44 let (f, _, _) = everywhereOnValuesM return replace return

@@ -61,7 +61,7 @@ desugarDo d =

61 go (DoNotationValue val : rest) = do

62 rest' <- go rest

63 return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')

64− go [DoNotationBind _ _] = throwError $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing

64+ go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind

65 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

66 go (DoNotationBind (VarBinder ident) val : rest) = do

67 rest' <- go rest

@@ -70,7 +70,7 @@ desugarDo d =

70 rest' <- go rest

71 ident <- Ident <$> freshName

72 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))

73− go [DoNotationLet _] = throwError $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing

73+ go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet

74 go (DoNotationLet ds : rest) = do

75 rest' <- go rest

76 return $ Let ds rest'

src/Language/PureScript/Sugar/Names.hs+53−63

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

87-- Updates the exports for a module from the global environment. If the module was not previously

88-- present in the global environment, it is created.

89--

90−updateExportedModule :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment

90+updateExportedModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment

91updateExportedModule env mn update = do

92 let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env

93 exports' <- update exports

@@ -96,61 +96,61 @@ updateExportedModule env mn update = do

96-- |

97-- Adds an empty module to an ExportEnvironment.

98--

99−addEmptyModule :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> m ExportEnvironment

99+addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> m ExportEnvironment

100addEmptyModule env name =

101 if name `M.member` env

102− then throwError $ mkErrorStack ("Module '" ++ show name ++ "' has been defined more than once") Nothing

102+ then throwError . errorMessage $ RedefinedModule name

103 else return $ M.insert name (Exports [] [] []) env

104

105-- |

106-- Adds a type belonging to a module to the export environment.

107--

108−addType :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment

108+addType :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment

109addType env mn name dctors = updateExportedModule env mn $ \m -> do

110 let exTypes = exportedTypes m

111 let exDctors = snd `concatMap` exTypes

112 let exClasses = exportedTypeClasses m

113− when (any ((== name) . fst) exTypes) $ throwMultipleDefError "type" name

113+ when (any ((== name) . fst) exTypes) $ throwConflictError ConflictingTypeDecls name

114− when (name `elem` exClasses) $ throwConflictingDefError "Type" "type class" name

114+ when (name `elem` exClasses) $ throwConflictError TypeConflictsWithClass name

115 forM_ dctors $ \dctor -> do

116− when (dctor `elem` exDctors) $ throwMultipleDefError "data constructor" dctor

116+ when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

117− when (dctor `elem` exClasses) $ throwConflictingDefError "Data constructor" "type class" dctor

117+ when (dctor `elem` exClasses) $ throwConflictError CtorConflictsWithClass dctor

118 return $ m { exportedTypes = (name, dctors) : exTypes }

119

120-- |

121-- Adds a class to the export environment.

122--

123−addTypeClass :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment

123+addTypeClass :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment

124addTypeClass env mn name = updateExportedModule env mn $ \m -> do

125 let exTypes = exportedTypes m

126 let exDctors = snd `concatMap` exTypes

127− when (any ((== name) . fst) exTypes) $ throwConflictingDefError "Type class" "type" name

127+ when (any ((== name) . fst) exTypes) $ throwConflictError ClassConflictsWithType name

128− when (name `elem` exDctors) $ throwConflictingDefError "Type class" "data constructor" name

128+ when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

129− classes <- addExport "type class" (exportedTypeClasses m) name

129+ classes <- addExport DuplicateClassExport (exportedTypeClasses m) name

130 return $ m { exportedTypeClasses = classes }

131

132-- |

133-- Adds a class to the export environment.

134--

135−addValue :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment

135+addValue :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment

136addValue env mn name = updateExportedModule env mn $ \m -> do

137− values <- addExport "value" (exportedValues m) name

137+ values <- addExport DuplicateValueExport (exportedValues m) name

138 return $ m { exportedValues = values }

139

140-- |

141-- Adds an entry to a list of exports unless it is already present, in which case an error is

142-- returned.

143--

144−addExport :: (Applicative m, MonadError ErrorStack m, Eq a, Show a) => String -> [a] -> a -> m [a]

144+addExport :: (Applicative m, MonadError MultipleErrors m, Eq a, Show a) => (a -> ErrorMessage) -> [a] -> a -> m [a]

145addExport what exports name =

146 if name `elem` exports

147− then throwMultipleDefError what name

147+ then throwConflictError what name

148 else return $ name : exports

149

150-- |

151-- Replaces all local names with qualified names within a set of modules.

152--

153−desugarImports :: forall m. (Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]

153+desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

154desugarImports modules = do

155 unfilteredExports <- findExports modules

156 exports <- foldM filterModuleExports unfilteredExports modules

@@ -168,7 +168,7 @@ desugarImports modules = do

168 -- the module has access to an unfiltered list of its own members.

169 renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module

170 renameInModule' unfilteredExports exports m@(Module _ mn _ _) =

171− rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ do

171+ rethrow (onErrorMessages (ErrorInModule mn)) $ do

172 let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports

173 let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports

174 imports <- resolveImports env m

@@ -205,7 +205,7 @@ elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps

205-- Replaces all local names with qualified names within a module and checks that all existing

206-- qualified names are valid.

207--

208−renameInModule :: forall m. (Applicative m, MonadError ErrorStack m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module

208+renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module

209renameInModule imports exports (Module coms mn decls exps) =

210 Module coms mn <$> parU decls go <*> pure exps

211 where

@@ -236,7 +236,7 @@ renameInModule imports exports (Module coms mn decls exps) =

236 let args = mapMaybe letBoundVariable ds

237 unless (length (nub args) == length args) $

238 maybe id rethrowWithPosition pos $

239− throwError $ mkErrorStack ("Overlapping names in let binding.") Nothing

239+ throwError . errorMessage $ OverlappingNamesInLet

240 return ((pos, args ++ bound), Let ds val')

241 where

242 updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =

@@ -271,28 +271,28 @@ renameInModule imports exports (Module coms mn decls exps) =

271

272 updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)

273

274− updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))

274+ updateTypeName = update UnknownType importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))

275− updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)

275+ updateClassName = update UnknownTypeClass importedTypeClasses (flip elem . exportedTypeClasses)

276− updateValueName = update "value" importedValues (flip elem . exportedValues)

276+ updateValueName = update UnknownValue importedValues (flip elem . exportedValues)

277− updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))

277+ updateDataConstructorName = update (flip UnknownDataConstructor Nothing) importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))

278

279 -- Update names so unqualified references become qualified, and locally qualified references

280 -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)

281− update :: (Ord a, Show a) => String

281+ update :: (Ord a, Show a) => (Qualified a -> ErrorMessage)

282 -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))

283 -> (Exports -> a -> Bool)

284 -> Qualified a

285 -> Maybe SourceSpan

286 -> m (Qualified a)

287− update t getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of

287+ update unknown getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of

288 (Just qname', _) -> return qname'

289 (Nothing, Just mn'') -> do

290− when (isExplicitQualModule mn'') $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing

290+ when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname

291 modExports <- getExports mn''

292 if checkE modExports name

293 then return qname

294− else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing

294+ else throwError . errorMessage $ unknown qname

295− _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing

295+ _ -> throwError . errorMessage $ unknown qname

296 where

297 isExplicitQualModule :: ModuleName -> Bool

298 isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')

@@ -303,12 +303,12 @@ renameInModule imports exports (Module coms mn decls exps) =

303

304 -- Gets the exports for a module, or an error message if the module doesn't exist

305 getExports :: ModuleName -> m Exports

306− getExports mn' = maybe (throwError $ mkErrorStack ("Unknown module '" ++ show mn' ++ "'") Nothing) return $ M.lookup mn' exports

306+ getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') return $ M.lookup mn' exports

307

308-- |

309-- Finds all exported declarations in a set of modules.

310--

311−findExports :: forall m. (Applicative m, MonadError ErrorStack m) => [Module] -> m ExportEnvironment

311+findExports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m ExportEnvironment

312findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports

313 where

314

@@ -321,7 +321,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

321 addModule :: ExportEnvironment -> Module -> m ExportEnvironment

322 addModule env (Module _ mn ds _) = do

323 env' <- addEmptyModule env mn

324− rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ foldM (addDecl mn) env' ds

324+ rethrow (onErrorMessages (ErrorInModule mn)) $ foldM (addDecl mn) env' ds

325

326 -- Add a declaration from a module to the global export environment

327 addDecl :: ModuleName -> ExportEnvironment -> Declaration -> m ExportEnvironment

@@ -344,10 +344,10 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

344-- Filters the exports for a module to ensure only explicit exports are kept in the global exports

345-- environment.

346--

347−filterExports :: forall m. (Applicative m, MonadError ErrorStack m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment

347+filterExports :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment

348filterExports mn exps env = do

349 let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)

350− moduleExports' <- rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ filterModule moduleExports

350+ moduleExports' <- rethrow (onErrorMessages (ErrorInModule mn)) $ filterModule moduleExports

351 return $ M.insert mn moduleExports' env

352 where

353

@@ -364,7 +364,7 @@ filterExports mn exps env = do

364 filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]

365 filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r

366 filterTypes expTys result (TypeRef name expDcons) = do

367− dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys

367+ dcons <- maybe (throwError . errorMessage . UnknownType $ Qualified (Just mn) name) return $ name `lookup` expTys

368 dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons

369 return $ (name, dcons') : result

370 filterTypes _ result _ = return result

@@ -374,7 +374,7 @@ filterExports mn exps env = do

374 filterDcons tcon exps' result name =

375 if name `elem` exps'

376 then return $ name : result

377− else throwError $ mkErrorStack ("Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'") Nothing

377+ else throwError . errorMessage $ UnknownDataConstructor (Qualified (Just mn) name) (Just (Qualified (Just mn) tcon))

378

379 -- Ensure the exported classes exist in the module and add them to the set of exports

380 filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]

@@ -382,7 +382,7 @@ filterExports mn exps env = do

382 filterClasses exps' result (TypeClassRef name) =

383 if name `elem` exps'

384 then return $ name : result

385− else throwError $ mkErrorStack ("Cannot export undefined type class '" ++ show name ++ "'") Nothing

385+ else throwError . errorMessage . UnknownTypeClass $ Qualified (Just mn) name

386 filterClasses _ result _ = return result

387

388 -- Ensure the exported values exist in the module and add them to the set of exports

@@ -391,7 +391,7 @@ filterExports mn exps env = do

391 filterValues exps' result (ValueRef name) =

392 if name `elem` exps'

393 then return $ name : result

394− else throwError $ mkErrorStack ("Cannot export undefined value '" ++ show name ++ "'") Nothing

394+ else throwError . errorMessage . UnknownValue $ Qualified (Just mn) name

395 filterValues _ result _ = return result

396

397-- |

@@ -408,7 +408,7 @@ findImports = foldl (findImports' Nothing) M.empty

408-- |

409-- Constructs a local environment for a module.

410--

411−resolveImports :: forall m. (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> Module -> m ImportEnvironment

411+resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment

412resolveImports env (Module _ currentModule decls _) =

413 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

414 where

@@ -421,7 +421,7 @@ resolveImports env (Module _ currentModule decls _) =

421

422 resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> m ImportEnvironment

423 resolveImport' imp (mn, (pos, typ, impQual)) = do

424− modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env

424+ modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) return $ mn `M.lookup` env

425 positioned $ resolveImport currentModule mn modExports imp impQual typ

426 where

427 positioned err = case pos of

@@ -431,7 +431,7 @@ resolveImports env (Module _ currentModule decls _) =

431-- |

432-- Extends the local environment for a module by resolving an import of another module.

433--

434−resolveImport :: forall m. (Applicative m, MonadError ErrorStack m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment

434+resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment

435resolveImport currentModule importModule exps imps impQual =

436 resolveByType

437 where

@@ -492,14 +492,14 @@ resolveImport currentModule importModule exps imps impQual =

492 check (PositionedDeclarationRef pos _ r) =

493 rethrowWithPosition pos $ check r

494 check ref@(ValueRef name) =

495− checkImportExists "value" values name >> return ref

495+ checkImportExists UnknownValue values name >> return ref

496 check ref@(TypeRef name dctors) = do

497− _ <- checkImportExists "type" availableTypes name

497+ _ <- checkImportExists UnknownType availableTypes name

498 let allDctors = allExportedDataConstructors name

499 _ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors

500 return ref

501 check ref@(TypeClassRef name) =

502− checkImportExists "type class" classes name >> return ref

502+ checkImportExists UnknownTypeClass classes name >> return ref

503 check _ = error "Invalid argument to checkRefIsValid"

504

505 -- Find all exported data constructors for a given type

@@ -511,11 +511,11 @@ resolveImport currentModule importModule exps imps impQual =

511 updateImports m name = case M.lookup (Qualified impQual name) m of

512 Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m

513 Just (Qualified Nothing _) -> error "Invalid state in updateImports"

514− Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing

514+ Just (Qualified (Just mn) _) -> throwError . errorMessage $ err

515 where

516 err = if mn == currentModule || importModule == currentModule

517− then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"

517+ then ConflictingImport (show name) mn

518− else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"

518+ else ConflictingImports (show name) mn importModule

519

520 -- The available values, types, and classes in the module being imported

521 values = exportedValues exps

@@ -525,27 +525,17 @@ resolveImport currentModule importModule exps imps impQual =

525 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

526 -- from

527 checkDctorExists :: [ProperName] -> ProperName -> m ProperName

528− checkDctorExists = checkImportExists "data constructor"

528+ checkDctorExists = checkImportExists (flip UnknownDataConstructor Nothing)

529

530 -- Check that an explicitly imported item exists in the module it is being imported from

531− checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> m a

531+ checkImportExists :: (Eq a, Show a) => (Qualified a -> ErrorMessage) -> [a] -> a -> m a

532− checkImportExists t exports item =

532+ checkImportExists unknown exports item =

533 if item `elem` exports

534 then return item

535− else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing

535+ else throwError . errorMessage . unknown $ Qualified (Just importModule) item

536

537-- |

538-- Raises an error for when there is more than one definition for something.

539--

540−throwMultipleDefError :: (Applicative m, MonadError ErrorStack m, Show a) => String -> a -> m b

540+throwConflictError :: (Applicative m, MonadError MultipleErrors m, Show a) => (a -> ErrorMessage) -> a -> m b

541−throwMultipleDefError what name = throwError $

541+throwConflictError conflict = throwError . errorMessage . conflict

542− mkErrorStack ("Multiple definitions for " ++ what ++ " '" ++ show name ++ "'") Nothing

543−

544−-- |

545−-- Raises an error for when there is a conflicting definition for something, for example, a type

546−-- class and data constructor of the same name.

547−--

548−throwConflictingDefError :: (Applicative m, MonadError ErrorStack m, Show a) => String -> String -> a -> m b

549−throwConflictingDefError what1 what2 name = throwError $

550− mkErrorStack (what1 ++ " '" ++ show name ++ "' cannot be defined in the same module as a " ++ what2 ++ " of the same name") Nothing

551−

src/Language/PureScript/Sugar/ObjectWildcards.hs+1−1

@@ -31,7 +31,7 @@ import Language.PureScript.AST

31import Language.PureScript.Errors

32import Language.PureScript.Names

34−desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> m Module

34+desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module

35desugarObjectConstructors (Module coms mn ds exts) = Module coms mn <$> mapM desugarDecl ds <*> pure exts

36 where

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

@@ -49,7 +49,7 @@ import qualified Language.PureScript.Constants as C

49-- |

50-- Remove explicit parentheses and reorder binary operator applications

51--

52−rebracket :: (Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]

52+rebracket :: (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

53rebracket ms = do

54 let fixities = concatMap collectFixities ms

55 ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities

@@ -64,7 +64,7 @@ removeSignedLiterals (Module coms mn ds exts) = Module coms mn (map f' ds) exts

64 go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val

65 go other = other

67−rebracketModule :: (Applicative m, MonadError ErrorStack m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module

67+rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module

68rebracketModule opTable (Module coms mn ds exts) =

69 let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return

70 in Module coms mn <$> (map removeParens <$> parU ds f) <*> pure exts

@@ -85,15 +85,15 @@ collectFixities (Module _ moduleName ds _) = concatMap collect ds

85 collect FixityDeclaration{} = error "Fixity without srcpos info"

86 collect _ = []

88−ensureNoDuplicates :: (MonadError ErrorStack m) => [(Qualified Ident, SourceSpan)] -> m ()

88+ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()

89ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

90 where

91 go [] = return ()

92 go [_] = return ()

93 go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =

94− rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $

94+ rethrow (onErrorMessages (ErrorInModule mn)) $

95 rethrowWithPosition pos $

96− throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing

96+ throwError . errorMessage $ MultipleFixities name

97 go (_ : rest) = go rest

99customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]

@@ -108,7 +108,7 @@ customOperatorTable fixities =

108

109type Chain = [Either Expr Expr]

110

111−matchOperators :: forall m. (MonadError ErrorStack m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr

111+matchOperators :: forall m. (MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr

112matchOperators ops = parseChains

113 where

114 parseChains :: Expr -> m Expr

@@ -118,7 +118,7 @@ matchOperators ops = parseChains

118 extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r

119 extendChain other = [Left other]

120 bracketChain :: Chain -> m Expr

121− bracketChain = either (throwError . (`mkErrorStack` Nothing) . show) return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

121+ bracketChain = either (const . throwError . errorMessage $ CannotReorderOperators) return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

122 opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]

123 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

124 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

@@ -151,7 +151,7 @@ matchOp op = do

151 ident <- parseOp

152 guard $ ident == op

153

154−desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> m Module

154+desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module

155desugarOperatorSections (Module coms mn ds exts) = Module coms mn <$> mapM goDecl ds <*> pure exts

156 where

157

src/Language/PureScript/Sugar/TypeClasses.hs+9−10

@@ -27,7 +27,6 @@ import Language.PureScript.Environment

27import Language.PureScript.Errors

28import Language.PureScript.Kinds

29import Language.PureScript.Names

30−import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)

31import Language.PureScript.Sugar.CaseDeclarations

30import Language.PureScript.Sugar.CaseDeclarations

32import Control.Monad.Supply.Class

31import Control.Monad.Supply.Class

33import Language.PureScript.Types

32import Language.PureScript.Types

@@ -51,10 +50,10 @@ type Desugar = StateT MemberMap

51-- Add type synonym declarations for type class dictionary types, and value declarations for type class

50-- Add type synonym declarations for type class dictionary types, and value declarations for type class

52-- instance dictionary expressions.

51-- instance dictionary expressions.

53--

52--

54−desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]

53+desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

55desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

54desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

57−desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> Desugar m Module

56+desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module

58desugarModule (Module coms name decls (Just exps)) = do

57desugarModule (Module coms name decls (Just exps)) = do

59 (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)

58 (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)

60 return $ Module coms name (concat declss) $ Just (exps ++ catMaybes newExpss)

59 return $ Module coms name (concat declss) $ Just (exps ++ catMaybes newExpss)

@@ -160,7 +159,7 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"

160-- return new Sub(fooString, "");

159-- return new Sub(fooString, "");

161-- };

160-- };

162-}

161-}

163−desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])

162+desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])

164desugarDecl mn exps = go

163desugarDecl mn exps = go

165 where

164 where

166 go d@(TypeClassDeclaration name args implies members) = do

165 go d@(TypeClassDeclaration name args implies members) = do

@@ -230,18 +229,18 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type

230unit :: Type

229unit :: Type

231unit = TypeApp tyObject REmpty

230unit = TypeApp tyObject REmpty

232

231

233−typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration

232+typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration

234typeInstanceDictionaryDeclaration name mn deps className tys decls =

233typeInstanceDictionaryDeclaration name mn deps className tys decls =

235− rethrow (mkCompileError ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") Nothing `combineErrors`) $ do

234+ rethrow (onErrorMessages (ErrorInInstance className tys)) $ do

236 m <- get

235 m <- get

237

236

238 -- Lookup the type arguments and member types for the type class

237 -- Lookup the type arguments and member types for the type class

239 (TypeClassDeclaration _ args implies tyDecls) <-

238 (TypeClassDeclaration _ args implies tyDecls) <-

240− maybe (throwError $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) return $

239+ maybe (throwError . errorMessage $ UnknownTypeClass className) return $

241 M.lookup (qualify mn className) m

240 M.lookup (qualify mn className) m

242

241

243 case mapMaybe declName tyDecls \\ mapMaybe declName decls of

242 case mapMaybe declName tyDecls \\ mapMaybe declName decls of

244− x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing

243+ member : _ -> throwError . errorMessage $ MissingClassMember member

245 [] -> do

244 [] -> do

246

245

247 let instanceTys = map memberToNameAndType tyDecls

246 let instanceTys = map memberToNameAndType tyDecls

@@ -276,9 +275,9 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

276 declName (TypeDeclaration ident _) = Just ident

275 declName (TypeDeclaration ident _) = Just ident

277 declName _ = Nothing

276 declName _ = Nothing

278

277

279− memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [(Ident, Type)] -> Declaration -> Desugar m Expr

278+ memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr

280 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

279 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

281− _ <- maybe (throwError $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) return $ lookup ident tys'

280+ _ <- maybe (throwError . errorMessage $ MissingClassMember ident) return $ lookup ident tys'

282 return val

281 return val

283 memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do

282 memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do

284 val <- memberToValue tys' d

283 val <- memberToValue tys' d

src/Language/PureScript/Sugar/TypeDeclarations.hs+6−6

@@ -35,15 +35,15 @@ import Language.PureScript.Traversals

35-- |

36-- Replace all top level type declarations in a module with type annotations

37--

38−desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]

38+desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

39desugarTypeDeclarationsModule ms = forM ms $ \(Module coms name ds exps) ->

40− rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $

40+ rethrow (onErrorMessages (ErrorInModule name)) $

41 Module coms name <$> desugarTypeDeclarations ds <*> pure exps

43-- |

44-- Replace all top level type declarations with type annotations

45--

46−desugarTypeDeclarations :: (Functor m, Applicative m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]

46+desugarTypeDeclarations :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

47desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

48 (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)

49 return (PositionedDeclaration pos com d' : ds')

@@ -51,13 +51,13 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

51 (_, nameKind, val) <- fromValueDeclaration d

52 desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

53 where

54− fromValueDeclaration :: (Functor m, Applicative m, MonadError ErrorStack m) => Declaration -> m (Ident, NameKind, Expr)

54+ fromValueDeclaration :: (Functor m, Applicative m, MonadError MultipleErrors m) => Declaration -> m (Ident, NameKind, Expr)

55 fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

56 fromValueDeclaration (PositionedDeclaration pos com d') = do

57 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

58 return (ident, nameKind, PositionedValue pos com val)

59− fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing

59+ fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

60−desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing

60+desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError . errorMessage $ OrphanTypeDeclaration name

61desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

62 let (_, f, _) = everywhereOnValuesTopDownM return go return

63 f' (Left gs) = Left <$> mapM (pairM return f) gs

src/Language/PureScript/TypeChecker.hs+42−50

@@ -26,8 +26,9 @@ import Language.PureScript.TypeChecker.Types as T

26import Language.PureScript.TypeChecker.Synonyms as T

28import Data.Maybe

29−import Data.List (nub, (\\), find, intercalate)

29+import Data.List (nub, (\\))

30import Data.Foldable (for_)

31+

31import qualified Data.Map as M

32import qualified Data.Map as M

33import Control.Monad.State

34import Control.Monad.State

@@ -46,7 +47,7 @@ addDataType moduleName dtype name args dctors ctorKind = do

46 env <- getEnv

47 env <- getEnv

47 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }

48 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }

48 forM_ dctors $ \(dctor, tys) ->

49 forM_ dctors $ \(dctor, tys) ->

49− rethrow (mkCompileError ("Error in data constructor " ++ show dctor) Nothing `combineErrors`) $

50+ rethrow (onErrorMessages (ErrorInDataConstructor dctor)) $

50 addDataConstructor moduleName dtype name (map fst args) dctor tys

51 addDataConstructor moduleName dtype name (map fst args) dctor tys

52addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

53addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

@@ -70,7 +71,7 @@ valueIsNotDefined :: ModuleName -> Ident -> Check ()

70valueIsNotDefined moduleName name = do

71valueIsNotDefined moduleName name = do

71 env <- getEnv

72 env <- getEnv

72 case M.lookup (moduleName, name) (names env) of

73 case M.lookup (moduleName, name) (names env) of

73− Just _ -> throwError . strMsg $ show name ++ " is already defined"

74+ Just _ -> throwError . errorMessage $ RedefinedIdent name

74 Nothing -> return ()

75 Nothing -> return ()

76addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()

77addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()

@@ -94,7 +95,7 @@ addTypeClassDictionaries entries =

95checkDuplicateTypeArguments :: [String] -> Check ()

96checkDuplicateTypeArguments :: [String] -> Check ()

96checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

97checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

97− throwError . strMsg $ "Duplicate type argument '" ++ dup ++ "'"

98+ throwError . errorMessage $ DuplicateTypeArgument dup

98 where

99 where

99 firstDup :: Maybe String

100 firstDup :: Maybe String

100 firstDup = listToMaybe $ args \\ nub args

101 firstDup = listToMaybe $ args \\ nub args

@@ -103,10 +104,10 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()

103checkTypeClassInstance _ (TypeVar _) = return ()

104checkTypeClassInstance _ (TypeVar _) = return ()

104checkTypeClassInstance _ (TypeConstructor ctor) = do

105checkTypeClassInstance _ (TypeConstructor ctor) = do

105 env <- getEnv

106 env <- getEnv

106− when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"

107+ when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance

107 return ()

108 return ()

108checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2

109checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2

109−checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance head is invalid." (Just (TypeError ty))

110+checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty

110

111

111-- |

112-- |

112-- Check that type synonyms are fully-applied in a type

113-- Check that type synonyms are fully-applied in a type

@@ -133,7 +134,7 @@ typeCheckAll mainModuleName moduleName exps = go

133 go :: [Declaration] -> Check [Declaration]

134 go :: [Declaration] -> Check [Declaration]

134 go [] = return []

135 go [] = return []

135 go (DataDeclaration dtype name args dctors : rest) = do

136 go (DataDeclaration dtype name args dctors : rest) = do

136− rethrow (mkCompileError ("Error in type constructor " ++ show name) Nothing `combineErrors`) $ do

137+ rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do

137 when (dtype == Newtype) $ checkNewtype dctors

138 when (dtype == Newtype) $ checkNewtype dctors

138 checkDuplicateTypeArguments $ map fst args

139 checkDuplicateTypeArguments $ map fst args

139 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)

140 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)

@@ -144,10 +145,10 @@ typeCheckAll mainModuleName moduleName exps = go

144 where

145 where

145 checkNewtype :: [(ProperName, [Type])] -> Check ()

146 checkNewtype :: [(ProperName, [Type])] -> Check ()

146 checkNewtype [(_, [_])] = return ()

147 checkNewtype [(_, [_])] = return ()

147− checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"

148+ checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype

148− checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"

149+ checkNewtype _ = throwError . errorMessage $ InvalidNewtype

149 go (d@(DataBindingGroupDeclaration tys) : rest) = do

150 go (d@(DataBindingGroupDeclaration tys) : rest) = do

150− rethrow (mkCompileError "Error in data binding group" Nothing `combineErrors`) $ do

151+ rethrow (onErrorMessages ErrorInDataBindingGroup) $ do

151 let syns = mapMaybe toTypeSynonym tys

152 let syns = mapMaybe toTypeSynonym tys

152 let dataDecls = mapMaybe toDataDecl tys

153 let dataDecls = mapMaybe toDataDecl tys

153 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

154 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

@@ -169,7 +170,7 @@ typeCheckAll mainModuleName moduleName exps = go

169 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'

170 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'

170 toDataDecl _ = Nothing

171 toDataDecl _ = Nothing

171 go (TypeSynonymDeclaration name args ty : rest) = do

172 go (TypeSynonymDeclaration name args ty : rest) = do

172− rethrow (mkCompileError ("Error in type synonym " ++ show name) Nothing `combineErrors`) $ do

173+ rethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do

173 checkDuplicateTypeArguments $ map fst args

174 checkDuplicateTypeArguments $ map fst args

174 kind <- kindsOf False moduleName name args [ty]

175 kind <- kindsOf False moduleName name args [ty]

175 let args' = args `withKinds` kind

176 let args' = args `withKinds` kind

@@ -178,7 +179,7 @@ typeCheckAll mainModuleName moduleName exps = go

178 return $ TypeSynonymDeclaration name args ty : ds

179 return $ TypeSynonymDeclaration name args ty : ds

179 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

180 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

180 go (ValueDeclaration name nameKind [] (Right val) : rest) = do

181 go (ValueDeclaration name nameKind [] (Right val) : rest) = do

181− d <- rethrow (mkCompileError ("Error in declaration " ++ show name) Nothing `combineErrors`) $ do

182+ d <- rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do

182 valueIsNotDefined moduleName name

183 valueIsNotDefined moduleName name

183 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]

184 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]

184 addValue moduleName name ty nameKind

185 addValue moduleName name ty nameKind

@@ -187,7 +188,7 @@ typeCheckAll mainModuleName moduleName exps = go

187 return $ d : ds

188 return $ d : ds

188 go (ValueDeclaration{} : _) = error "Binders were not desugared"

189 go (ValueDeclaration{} : _) = error "Binders were not desugared"

189 go (BindingGroupDeclaration vals : rest) = do

190 go (BindingGroupDeclaration vals : rest) = do

190− d <- rethrow (mkCompileError ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) Nothing `combineErrors`) $ do

191+ d <- rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

191 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->

192 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->

192 valueIsNotDefined moduleName name

193 valueIsNotDefined moduleName name

193 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals

194 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals

@@ -207,19 +208,19 @@ typeCheckAll mainModuleName moduleName exps = go

207 ds <- go rest

208 ds <- go rest

208 return $ d : ds

209 return $ d : ds

209 go (d@(ExternDeclaration importTy name _ ty) : rest) = do

210 go (d@(ExternDeclaration importTy name _ ty) : rest) = do

210− rethrow (mkCompileError ("Error in foreign import declaration " ++ show name) Nothing `combineErrors`) $ do

211+ rethrow (onErrorMessages (ErrorInForeignImport name)) $ do

211 env <- getEnv

212 env <- getEnv

212 kind <- kindOf moduleName ty

213 kind <- kindOf moduleName ty

213− guardWith (strMsg "Expected kind *") $ kind == Star

214+ guardWith (errorMessage (ExpectedType kind)) $ kind == Star

214 case M.lookup (moduleName, name) (names env) of

215 case M.lookup (moduleName, name) (names env) of

215− Just _ -> throwError . strMsg $ show name ++ " is already defined"

216+ Just _ -> throwError . errorMessage $ RedefinedIdent name

216 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })

217 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })

217 ds <- go rest

218 ds <- go rest

218 return $ d : ds

219 return $ d : ds

219 go (d@(FixityDeclaration _ name) : rest) = do

220 go (d@(FixityDeclaration _ name) : rest) = do

220 ds <- go rest

221 ds <- go rest

221 env <- getEnv

222 env <- getEnv

222− guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env

223+ guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env

223 return $ d : ds

224 return $ d : ds

224 go (d@(ImportDeclaration importedModule _ _) : rest) = do

225 go (d@(ImportDeclaration importedModule _ _) : rest) = do

225 tcds <- getTypeClassDictionaries

226 tcds <- getTypeClassDictionaries

@@ -277,7 +278,7 @@ typeCheckAll mainModuleName moduleName exps = go

277--

278--

278typeCheckModule :: Maybe ModuleName -> Module -> Check Module

279typeCheckModule :: Maybe ModuleName -> Module -> Check Module

279typeCheckModule _ (Module _ _ _ Nothing) = error "exports should have been elaborated"

280typeCheckModule _ (Module _ _ _ Nothing) = error "exports should have been elaborated"

280−typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = do

281+typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = rethrow (onErrorMessages (ErrorInModule mn)) $ do

281 modify (\s -> s { checkCurrentModule = Just mn })

282 modify (\s -> s { checkCurrentModule = Just mn })

282 decls' <- typeCheckAll mainModuleName mn exps decls

283 decls' <- typeCheckAll mainModuleName mn exps decls

283 forM_ exps $ \e -> do

284 forM_ exps $ \e -> do

@@ -287,63 +288,54 @@ typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = do

287 return $ Module coms mn decls' (Just exps)

288 return $ Module coms mn decls' (Just exps)

288 where

289 where

289

290

290− checkMemberExport :: (Show a) => String -> (Type -> [a]) -> (a -> Bool) -> DeclarationRef -> Check ()

291+ checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check ()

291− checkMemberExport thing extract test (ValueRef name) = do

292+ checkMemberExport extract dr@(ValueRef name) = do

292 ty <- lookupVariable mn (Qualified (Just mn) name)

293 ty <- lookupVariable mn (Qualified (Just mn) name)

293− case find test (extract ty) of

294+ case filter (not . exported) (extract ty) of

294− Just hiddenType -> throwError . strMsg $

295+ [] -> return ()

295− "Error in module '" ++ show mn ++ "':\n\

296+ hidden -> throwError . errorMessage $ TransitiveExportError dr hidden

296− \Exporting declaration '" ++ show name ++ "' requires " ++ thing ++ " '" ++ show hiddenType ++ "' to be exported as well"

297+ where

297− Nothing -> return ()

298+ exported e = any (exports e) exps

299+ exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2

300+ exports (ValueRef id1) (ValueRef id2) = id1 == id2

301+ exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2

302+ exports (TypeInstanceRef id1) (TypeInstanceRef id2) = id1 == id2

303+ exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2

304+ exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2

305+ exports _ _ = False

298− checkMemberExport _ _ _ _ = return ()

306+ checkMemberExport _ _ = return ()

299

307

300 -- Check that all the type constructors defined in the current module that appear in member types

308 -- Check that all the type constructors defined in the current module that appear in member types

301 -- have also been exported from the module

309 -- have also been exported from the module

302 checkTypesAreExported :: DeclarationRef -> Check ()

310 checkTypesAreExported :: DeclarationRef -> Check ()

303− checkTypesAreExported = checkMemberExport "type" findTcons isTconHidden

311+ checkTypesAreExported = checkMemberExport findTcons

304 where

312 where

305− findTcons :: Type -> [ProperName]

313+ findTcons :: Type -> [DeclarationRef]

306 findTcons = everythingOnTypes (++) go

314 findTcons = everythingOnTypes (++) go

307 where

315 where

308− go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]

316+ go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (error "Data constructors unused in checkTypesAreExported")]

309 go _ = []

317 go _ = []

310− isTconHidden :: ProperName -> Bool

311− isTconHidden tyName = all go exps

312− where

313− go (TypeRef tyName' _) = tyName' /= tyName

314− go _ = True

315

318

316 -- Check that all the classes defined in the current module that appear in member types have also

319 -- Check that all the classes defined in the current module that appear in member types have also

317 -- been exported from the module

320 -- been exported from the module

318 checkClassesAreExported :: DeclarationRef -> Check ()

321 checkClassesAreExported :: DeclarationRef -> Check ()

319− checkClassesAreExported = checkMemberExport "class" findClasses isClassHidden

322+ checkClassesAreExported = checkMemberExport findClasses

320 where

323 where

321− findClasses :: Type -> [ProperName]

324+ findClasses :: Type -> [DeclarationRef]

322 findClasses = everythingOnTypes (++) go

325 findClasses = everythingOnTypes (++) go

323 where

326 where

324− go (ConstrainedType cs _) = mapMaybe (extractCurrentModuleClass . fst) cs

327+ go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs

325 go _ = []

328 go _ = []

326 extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName

329 extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName

327 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

330 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

328 extractCurrentModuleClass _ = Nothing

331 extractCurrentModuleClass _ = Nothing

329− isClassHidden :: ProperName -> Bool

330− isClassHidden clsName = all go exps

331− where

332− go (TypeClassRef clsName') = clsName' /= clsName

333− go _ = True

334

332

335 checkClassMembersAreExported :: DeclarationRef -> Check ()

333 checkClassMembersAreExported :: DeclarationRef -> Check ()

336− checkClassMembersAreExported (TypeClassRef name) = do

334+ checkClassMembersAreExported dr@(TypeClassRef name) = do

337 let members = ValueRef `map` head (mapMaybe findClassMembers decls)

335 let members = ValueRef `map` head (mapMaybe findClassMembers decls)

338 let missingMembers = members \\ exps

336 let missingMembers = members \\ exps

339− unless (null missingMembers) $

337+ unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members

340− throwError . strMsg $

341− "Error in module '" ++ show mn ++ "':\n\

342− \Class '" ++ show name ++ "' is exported but is missing member exports for '" ++ intercalate "', '" (map (show . runValueRef) missingMembers) ++ "'"

343 where

338 where

344− runValueRef :: DeclarationRef -> Ident

345− runValueRef (ValueRef refName) = refName

346− runValueRef _ = error "non-ValueRef passed to runValueRef"

347 findClassMembers :: Declaration -> Maybe [Ident]

339 findClassMembers :: Declaration -> Maybe [Ident]

348 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds

340 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds

349 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d

341 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d

src/Language/PureScript/TypeChecker/Entailment.hs+2−45

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

31import Language.PureScript.Errors

32import Language.PureScript.Environment

33import Language.PureScript.Names

34−import Language.PureScript.Pretty

35import Language.PureScript.TypeChecker.Monad

34import Language.PureScript.TypeChecker.Monad

36import Language.PureScript.TypeChecker.Synonyms

35import Language.PureScript.TypeChecker.Synonyms

37import Language.PureScript.TypeChecker.Unify

36import Language.PureScript.TypeChecker.Unify

@@ -39,29 +38,6 @@ import Language.PureScript.TypeClassDictionaries

39import Language.PureScript.Types

38import Language.PureScript.Types

40import qualified Language.PureScript.Constants as C

39import qualified Language.PureScript.Constants as C

42−-- |

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

44−-- class dictionaries at runtime, which can be compared for equality

45−--

46−data DictionaryValue

47− -- |

48− -- A dictionary which is brought into scope by a local constraint

49− --

50− = LocalDictionaryValue (Qualified Ident)

51− -- |

52− -- A dictionary which is brought into scope by an instance declaration

53− --

54− | GlobalDictionaryValue (Qualified Ident)

55− -- |

56− -- A dictionary which depends on other dictionaries

57− --

58− | DependentDictionaryValue (Qualified Ident) [DictionaryValue]

59− -- |

60− -- A subclass dictionary

61− --

62− | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

63− deriving (Show, Ord, Eq)

64−

65-- |

41-- |

66-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

42-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

67-- return a type class dictionary reference.

43-- return a type class dictionary reference.

@@ -140,16 +116,9 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

140 checkOverlaps :: [DictionaryValue] -> Check Expr

116 checkOverlaps :: [DictionaryValue] -> Check Expr

141 checkOverlaps dicts =

117 checkOverlaps dicts =

142 case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of

118 case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of

143− (d1, d2) : _ -> throwError . strMsg $ unlines

119+ ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys (map fst ds)

144− [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "."

145− , "For example:"

146− , prettyPrintDictionaryValue d1

147− , "and:"

148− , prettyPrintDictionaryValue d2

149− ]

150 _ -> case chooseSimplestDictionaries dicts of

120 _ -> case chooseSimplestDictionaries dicts of

151− [] -> throwError . strMsg $

121+ [] -> throwError . errorMessage $ NoInstanceFound className tys

152− "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)

153 d : _ -> return $ dictionaryValueToValue d

122 d : _ -> return $ dictionaryValueToValue d

154 -- Choose the simplest DictionaryValues from a list of candidates

123 -- Choose the simplest DictionaryValues from a list of candidates

155 -- The reason for this function is as follows:

124 -- The reason for this function is as follows:

@@ -180,18 +149,6 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

180 overlapping SubclassDictionaryValue{} _ = False

149 overlapping SubclassDictionaryValue{} _ = False

181 overlapping _ SubclassDictionaryValue{} = False

150 overlapping _ SubclassDictionaryValue{} = False

182 overlapping _ _ = True

151 overlapping _ _ = True

183− -- |

184− -- Render a DictionaryValue fit for human consumption in error messages

185− --

186− prettyPrintDictionaryValue :: DictionaryValue -> String

187− prettyPrintDictionaryValue = unlines . indented 0

188− where

189− indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]

190− indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]

191− indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args

192− indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup

193−

194− spaces n = replicate n ' ' ++ "- "

195

152

196 valUndefined :: Expr

153 valUndefined :: Expr

197 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))

154 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))

src/Language/PureScript/TypeChecker/Kinds.hs+5−6

@@ -38,7 +38,6 @@ import Language.PureScript.Environment

38import Language.PureScript.Errors

39import Language.PureScript.Kinds

40import Language.PureScript.Names

41−import Language.PureScript.Pretty

42import Language.PureScript.TypeChecker.Monad

41import Language.PureScript.TypeChecker.Monad

43import Language.PureScript.Types

42import Language.PureScript.Types

@@ -65,7 +64,7 @@ instance Unifiable Check Kind where

65 FunKind k1 k2 =?= FunKind k3 k4 = do

64 FunKind k1 k2 =?= FunKind k3 k4 = do

66 k1 =?= k3

65 k1 =?= k3

67 k2 =?= k4

66 k2 =?= k4

68− k1 =?= k2 = UnifyT . lift . throwError . strMsg $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."

67+ k1 =?= k2 = UnifyT . lift . throwError . errorMessage $ KindsDoNotUnify k1 k2

70-- |

69-- |

71-- Infer the kind of a single type

70-- Infer the kind of a single type

@@ -78,7 +77,7 @@ kindOf _ ty = fst <$> kindOfWithScopedVars ty

78--

77--

79kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])

78kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])

80kindOfWithScopedVars ty =

79kindOfWithScopedVars ty =

81− rethrow (mkCompileError "Error checking kind" (Just (TypeError ty)) `combineErrors`) $

80+ rethrow (onErrorMessages (ErrorCheckingKind ty)) $

82 fmap tidyUp . liftUnify $ infer ty

81 fmap tidyUp . liftUnify $ infer ty

83 where

82 where

84 tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k)

83 tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k)

@@ -156,7 +155,7 @@ starIfUnknown k = k

156-- Infer a kind for a type

155-- Infer a kind for a type

157--

156--

158infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

157infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

159−infer ty = rethrow (mkCompileError "Error inferring type of value" (Just (TypeError ty)) `combineErrors`) $ infer' ty

158+infer ty = rethrow (onErrorMessages (ErrorCheckingKind ty)) $ infer' ty

160

159

161infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

160infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

162infer' (ForAll ident ty _) = do

161infer' (ForAll ident ty _) = do

@@ -189,10 +188,10 @@ infer' other = (, []) <$> go other

189 go (Skolem v _ _) = do

188 go (Skolem v _ _) = do

190 Just moduleName <- checkCurrentModule <$> get

189 Just moduleName <- checkCurrentModule <$> get

191 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

190 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

192− go c@(TypeConstructor v) = do

191+ go (TypeConstructor v) = do

193 env <- liftCheck getEnv

192 env <- liftCheck getEnv

194 case M.lookup v (types env) of

193 case M.lookup v (types env) of

195− Nothing -> UnifyT . lift . throwError $ mkErrorStack "Unknown type constructor" (Just (TypeError c))

194+ Nothing -> UnifyT . lift . throwError . errorMessage $ UnknownTypeConstructor v

196 Just (kind, _) -> return kind

195 Just (kind, _) -> return kind

197 go (TypeApp t1 t2) = do

196 go (TypeApp t1 t2) = do

198 k0 <- fresh

197 k0 <- fresh

src/Language/PureScript/TypeChecker/Monad.hs+13−13

@@ -109,41 +109,41 @@ makeBindingGroupVisible action = do

109-- |

110-- Lookup the type of a value by name in the @Environment@

111--

112−lookupVariable :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type

112+lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type

113lookupVariable currentModule (Qualified moduleName var) = do

114 env <- getEnv

115 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

116− Nothing -> throwError . strMsg $ show var ++ " is undefined"

116+ Nothing -> throwError . errorMessage $ NameIsUndefined var

117 Just (ty, _, _) -> return ty

118

119-- |

120-- Lookup the visibility of a value by name in the @Environment@

121--

122−getVisibility :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility

122+getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility

123getVisibility currentModule (Qualified moduleName var) = do

124 env <- getEnv

125 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

126− Nothing -> throwError . strMsg $ show var ++ " is undefined"

126+ Nothing -> throwError . errorMessage $ NameIsUndefined var

127 Just (_, _, vis) -> return vis

128

129-- |

130-- Assert that a name is visible

131--

132−checkVisibility :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()

132+checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()

133checkVisibility currentModule name@(Qualified _ var) = do

134 vis <- getVisibility currentModule name

135 case vis of

136− Undefined -> throwError . strMsg $ show var ++ " may not be defined in the current scope."

136+ Undefined -> throwError . errorMessage $ NameNotInScope var

137 _ -> return ()

138

139-- |

140-- Lookup the kind of a type by name in the @Environment@

141--

142−lookupTypeVariable :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind

142+lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind

143lookupTypeVariable currentModule (Qualified moduleName name) = do

144 env <- getEnv

145 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

146− Nothing -> throwError . strMsg $ "Type variable " ++ show name ++ " is undefined"

146+ Nothing -> throwError . errorMessage $ UndefinedTypeVariable name

147 Just (k, _) -> return k

148

149-- |

@@ -171,8 +171,8 @@ data CheckState = CheckState {

171-- |

172-- The type checking monad, which provides the state of the type checker, and error reporting capabilities

173--

174−newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a }

174+newtype Check a = Check { unCheck :: StateT CheckState (Either MultipleErrors) a }

175− deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError ErrorStack)

175+ deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError MultipleErrors)

176

177-- |

178-- Get the current @Environment@

@@ -204,9 +204,9 @@ runCheck = runCheck' initEnvironment

204runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment)

205runCheck' env c = do

206 verbose <- asks optionsVerboseErrors

207− stringifyErrorStack verbose $ do

207+ interpretMultipleErrors verbose $ do

208− (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

208+ (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

209− return (a, checkEnv s)

209+ return (a, checkEnv s)

210

211-- |

212-- Make an assertion, failing with an error message

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

@@ -53,7 +53,7 @@ checkDuplicateLabels =

53 checkDups r@RCons{} =

54 let (ls, _) = rowToList r in

55 case firstDup . sort . map fst $ ls of

56− Just l -> throwError $ mkErrorStack ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val)

56+ Just l -> throwError . errorMessage $ DuplicateLabel l (Just val)

57 Nothing -> return ()

58 checkDups _ = return ()

src/Language/PureScript/TypeChecker/Skolems.hs+2−3

@@ -31,7 +31,6 @@ import Control.Monad.Unify

32import Language.PureScript.AST

33import Language.PureScript.Errors

34−import Language.PureScript.Pretty

35import Language.PureScript.TypeChecker.Monad

34import Language.PureScript.TypeChecker.Monad

36import Language.PureScript.Types

35import Language.PureScript.Types

@@ -89,7 +88,7 @@ skolemEscapeCheck root@TypedValue{} =

89 let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def

88 let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def

90 in case f root of

89 in case f root of

91 [] -> return ()

90 [] -> return ()

92− ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ExprError val))

91+ ((binding, val) : _) -> throwError . errorMessage . ErrorInExpression val $ EscapedSkolem binding

93 where

92 where

94 def s _ = (s, [])

93 def s _ = (s, [])

@@ -112,4 +111,4 @@ skolemEscapeCheck root@TypedValue{} =

112 where

111 where

113 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)

112 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)

114 go' _ = mempty

113 go' _ = mempty

115−skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))

114+skolemEscapeCheck _ = error "Untyped value passed to skolemEscapeCheck"

src/Language/PureScript/TypeChecker/Subsumption.hs+2−9

@@ -20,14 +20,12 @@ module Language.PureScript.TypeChecker.Subsumption (

20import Data.List (sortBy)

21import Data.Ord (comparing)

23−import Control.Applicative

24import Control.Monad.Except

23import Control.Monad.Except

25import Control.Monad.Unify

24import Control.Monad.Unify

27import Language.PureScript.AST

26import Language.PureScript.AST

28import Language.PureScript.Environment

27import Language.PureScript.Environment

29import Language.PureScript.Errors

28import Language.PureScript.Errors

30−import Language.PureScript.Pretty

31import Language.PureScript.TypeChecker.Monad

29import Language.PureScript.TypeChecker.Monad

32import Language.PureScript.TypeChecker.Skolems

30import Language.PureScript.TypeChecker.Skolems

33import Language.PureScript.TypeChecker.Synonyms

31import Language.PureScript.TypeChecker.Synonyms

@@ -38,12 +36,7 @@ import Language.PureScript.Types

38-- Check whether one type subsumes another, rethrowing errors to provide a better error message

36-- Check whether one type subsumes another, rethrowing errors to provide a better error message

39--

37--

40subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)

38subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)

41−subsumes val ty1 ty2 = rethrow (mkCompileError errorMessage (ExprError <$> val) `combineErrors`) $ subsumes' val ty1 ty2

39+subsumes val ty1 ty2 = rethrow (onErrorMessages (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2

42− where

43− errorMessage = "Error checking that type "

44− ++ prettyPrintType ty1

45− ++ " subsumes type "

46− ++ prettyPrintType ty2

48-- |

41-- |

49-- Check whether one type subsumes another

42-- Check whether one type subsumes another

@@ -58,7 +51,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =

58 sko <- newSkolemConstant

51 sko <- newSkolemConstant

59 let sk = skolemize ident sko sco' ty2

52 let sk = skolemize ident sko sco' ty2

60 subsumes val ty1 sk

53 subsumes val ty1 sk

61− Nothing -> throwError . strMsg $ "Skolem variable scope is unspecified"

54+ Nothing -> throwError . errorMessage $ UnspecifiedSkolemScope

62subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

55subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

63 _ <- subsumes Nothing arg2 arg1

56 _ <- subsumes Nothing arg2 arg1

64 _ <- subsumes Nothing ret1 ret2

57 _ <- subsumes Nothing ret1 ret2

src/Language/PureScript/TypeChecker/Synonyms.hs+12−12

@@ -40,19 +40,19 @@ import Language.PureScript.Types

40-- |

41-- Build a type substitution for a type synonym

42--

43−buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)

43+buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either ErrorMessage (Maybe Type)

44buildTypeSubstitution name n = go n []

45 where

46− go :: Int -> [Type] -> Type -> Either String (Maybe Type)

46+ go :: Int -> [Type] -> Type -> Either ErrorMessage (Maybe Type)

47 go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)

48− go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name

48+ go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ PartiallyAppliedSynonym name

49 go m args (TypeApp f arg) = go (m - 1) (arg:args) f

50 go _ _ _ = return Nothing

52-- |

53-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor

54--

55−saturateTypeSynonym :: Qualified ProperName -> Int -> Type -> Either String Type

55+saturateTypeSynonym :: Qualified ProperName -> Int -> Type -> Either ErrorMessage Type

56saturateTypeSynonym name n = everywhereOnTypesTopDownM replace

57 where

58 replace t = fromMaybe t <$> buildTypeSubstitution name n t

@@ -60,7 +60,7 @@ saturateTypeSynonym name n = everywhereOnTypesTopDownM replace

60-- |

61-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor

62--

63−saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either String Type

63+saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either ErrorMessage Type

64saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns

66-- |

@@ -76,22 +76,22 @@ desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym

76-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate

77-- better error messages during unification.

78--

79−replaceAllTypeSynonyms' :: Environment -> Type -> Either String Type

79+replaceAllTypeSynonyms' :: Environment -> Type -> Either ErrorMessage Type

80replaceAllTypeSynonyms' env d =

81 let

82 syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env

83 in

84 saturateAllTypeSynonyms syns d

86−replaceAllTypeSynonyms :: (e ~ ErrorStack, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

86+replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

87replaceAllTypeSynonyms d = do

88 env <- getEnv

89− either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d

89+ either (throwError . errorMessage) return $ replaceAllTypeSynonyms' env d

91-- |

92-- Replace a type synonym and its arguments with the aliased type

93--

94−expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either String Type

94+expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either ErrorMessage Type

95expandTypeSynonym' env name args =

96 case M.lookup name (typeSynonyms env) of

97 Just (synArgs, body) -> do

@@ -99,12 +99,12 @@ expandTypeSynonym' env name args =

99 replaceAllTypeSynonyms' env repl

100 Nothing -> error "Type synonym was not defined"

101

102−expandTypeSynonym :: (e ~ ErrorStack, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type

102+expandTypeSynonym :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type

103expandTypeSynonym name args = do

104 env <- getEnv

105− either (throwError . strMsg) return $ expandTypeSynonym' env name args

105+ either (throwError . errorMessage) return $ expandTypeSynonym' env name args

106

107−expandAllTypeSynonyms :: (e ~ ErrorStack, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

107+expandAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

108expandAllTypeSynonyms = everywhereOnTypesTopDownM go

109 where

110 go (SaturatedTypeSynonym name args) = expandTypeSynonym name args

src/Language/PureScript/TypeChecker/Types.hs+22−32

@@ -39,7 +39,6 @@ import Data.Either (lefts, rights)

39import Data.List

40import Data.Maybe (fromMaybe)

41import qualified Data.Map as M

42−import Data.String (IsString)

44import Control.Applicative

43import Control.Applicative

45import Control.Monad.Except

44import Control.Monad.Except

@@ -51,7 +50,6 @@ import Language.PureScript.Environment

51import Language.PureScript.Errors

50import Language.PureScript.Errors

52import Language.PureScript.Kinds

51import Language.PureScript.Kinds

53import Language.PureScript.Names

52import Language.PureScript.Names

54−import Language.PureScript.Pretty

55import Language.PureScript.Traversals

53import Language.PureScript.Traversals

56import Language.PureScript.TypeChecker.Entailment

54import Language.PureScript.TypeChecker.Entailment

57import Language.PureScript.TypeChecker.Kinds

55import Language.PureScript.TypeChecker.Kinds

@@ -184,7 +182,7 @@ replaceTypeClassDictionaries mn =

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

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

185--

183--

186checkTypeKind :: Kind -> UnifyT t Check ()

184checkTypeKind :: Kind -> UnifyT t Check ()

187−checkTypeKind kind = guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

185+checkTypeKind kind = guardWith (errorMessage (ExpectedType kind)) $ kind == Star

188

186

189-- |

187-- |

190-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns

188-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns

@@ -207,7 +205,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)

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

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

208--

206--

209infer :: Expr -> UnifyT Type Check Expr

207infer :: Expr -> UnifyT Type Check Expr

210−infer val = rethrow (mkCompileError "Error inferring type of value" (Just (ExprError val)) `combineErrors`) $ infer' val

208+infer val = rethrow (onErrorMessages (ErrorInferringType val)) $ infer' val

211

209

212-- |

210-- |

213-- Infer a type for a value

211-- Infer a type for a value

@@ -269,7 +267,7 @@ infer' (Var var) = do

269infer' v@(Constructor c) = do

267infer' v@(Constructor c) = do

270 env <- getEnv

268 env <- getEnv

271 case M.lookup c (dataConstructors env) of

269 case M.lookup c (dataConstructors env) of

272− Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"

270+ Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing

273 Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty

271 Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty

274 return $ TypedValue True v' ty'

272 return $ TypedValue True v' ty'

275infer' (Case vals binders) = do

273infer' (Case vals binders) = do

@@ -365,8 +363,8 @@ inferBinder val (ConstructorBinder ctor binders) = do

365 return M.empty

363 return M.empty

366 go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =

364 go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =

367 M.union <$> inferBinder obj binder <*> go binders' ret

365 M.union <$> inferBinder obj binder <*> go binders' ret

368− go _ _ = throwError . strMsg $ "Wrong number of arguments to constructor " ++ show ctor

366+ go _ _ = throwError . errorMessage $ IncorrectConstructorArity ctor

369− _ -> throwError . strMsg $ "Constructor " ++ show ctor ++ " is not defined"

367+ _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing

370inferBinder val (ObjectBinder props) = do

368inferBinder val (ObjectBinder props) = do

371 row <- fresh

369 row <- fresh

372 rest <- fresh

370 rest <- fresh

@@ -404,7 +402,7 @@ inferBinder val (PositionedBinder pos _ binder) =

404checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative]

402checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative]

405checkBinders _ _ [] = return []

403checkBinders _ _ [] = return []

406checkBinders nvals ret (CaseAlternative binders result : bs) = do

404checkBinders nvals ret (CaseAlternative binders result : bs) = do

407− guardWith (strMsg "Overlapping binders in case statement") $

405+ guardWith (errorMessage $ OverlappingArgNames Nothing) $

408 let ns = concatMap binderNames binders in length (nub ns) == length ns

406 let ns = concatMap binderNames binders in length (nub ns) == length ns

409 Just moduleName <- checkCurrentModule <$> get

407 Just moduleName <- checkCurrentModule <$> get

410 m1 <- M.unions <$> zipWithM inferBinder nvals binders

408 m1 <- M.unions <$> zipWithM inferBinder nvals binders

@@ -427,13 +425,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do

427-- Check the type of a value, rethrowing errors to provide a better error message

425-- Check the type of a value, rethrowing errors to provide a better error message

428--

426--

429check :: Expr -> Type -> UnifyT Type Check Expr

427check :: Expr -> Type -> UnifyT Type Check Expr

430−check val ty = rethrow (mkCompileError errorMessage (Just (ExprError val)) `combineErrors`) $ check' val ty

428+check val ty = rethrow (onErrorMessages (ErrorCheckingType val ty)) $ check' val ty

431− where

432− errorMessage =

433− "Error checking type of term " ++

434− prettyPrintValue val ++

435− " against type " ++

436− prettyPrintType ty

437

429

438-- |

430-- |

439-- Check the type of a value

431-- Check the type of a value

@@ -490,7 +482,7 @@ check' v@(Var var) ty = do

490 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

482 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

491 v' <- subsumes (Just v) repl ty'

483 v' <- subsumes (Just v) repl ty'

492 case v' of

484 case v' of

493− Nothing -> throwError . strMsg $ "Unable to check type subsumption"

485+ Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

494 Just v'' -> return $ TypedValue True v'' ty'

486 Just v'' -> return $ TypedValue True v'' ty'

495check' (SuperClassDictionary className tys) _ = do

487check' (SuperClassDictionary className tys) _ = do

496 {-

488 {-

@@ -513,7 +505,7 @@ check' (TypedValue checkType val ty1) ty2 = do

513 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

505 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

514 val' <- subsumes (Just val) ty1' ty2'

506 val' <- subsumes (Just val) ty1' ty2'

515 case val' of

507 case val' of

516− Nothing -> throwError . strMsg $ "Unable to check type subsumption"

508+ Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

517 Just val'' -> do

509 Just val'' -> do

518 val''' <- if checkType then withScopedTypeVars moduleName args (check val'' ty2') else return val''

510 val''' <- if checkType then withScopedTypeVars moduleName args (check val'' ty2') else return val''

519 return $ TypedValue checkType (TypedValue True val''' ty1') ty2'

511 return $ TypedValue checkType (TypedValue True val''' ty1') ty2'

@@ -551,7 +543,7 @@ check' (Accessor prop val) ty = do

551check' (Constructor c) ty = do

543check' (Constructor c) ty = do

552 env <- getEnv

544 env <- getEnv

553 case M.lookup c (dataConstructors env) of

545 case M.lookup c (dataConstructors env) of

554− Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"

546+ Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing

555 Just (_, _, ty1, _) -> do

547 Just (_, _, ty1, _) -> do

556 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

548 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

557 _ <- subsumes Nothing repl ty

549 _ <- subsumes Nothing repl ty

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

568 return $ TypedValue True val' kt

560 return $ TypedValue True val' kt

569check' (PositionedValue pos _ val) ty =

561check' (PositionedValue pos _ val) ty =

570 rethrowWithPosition pos $ check' val ty

562 rethrowWithPosition pos $ check' val ty

571−check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))

563+check' val ty = throwError . errorMessage $ ExprDoesNotHaveType val ty

572

564

573containsTypeSynonyms :: Type -> Bool

565containsTypeSynonyms :: Type -> Bool

574containsTypeSynonyms = everythingOnTypes (||) go where

566containsTypeSynonyms = everythingOnTypes (||) go where

@@ -589,8 +581,8 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

589 return []

581 return []

590 go [] [] Skolem{} | lax = return []

582 go [] [] Skolem{} | lax = return []

591 go [] ((p, _): _) _ | lax = return []

583 go [] ((p, _): _) _ | lax = return []

592− | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))

584+ | otherwise = throwError . errorMessage $ PropertyIsMissing p row

593− go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))

585+ go ((p,_):_) [] REmpty = throwError . errorMessage $ PropertyIsMissing p row

594 go ((p,v):ps') ts r =

586 go ((p,v):ps') ts r =

595 case lookup p ts of

587 case lookup p ts of

596 Nothing -> do

588 Nothing -> do

@@ -603,19 +595,15 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

603 v' <- check v ty

595 v' <- check v ty

604 ps'' <- go ps' (delete (p, ty) ts) r

596 ps'' <- go ps' (delete (p, ty) ts) r

605 return $ (p, v') : ps''

597 return $ (p, v') : ps''

606− go _ _ _ = throwError $ mkErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ExprError (ObjectLiteral ps)))

598+ go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType (ObjectLiteral ps) (TypeApp tyObject row)

607

599

608-- |

600-- |

609-- Check the type of a function application, rethrowing errors to provide a better error message

601-- Check the type of a function application, rethrowing errors to provide a better error message

610--

602--

611checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)

603checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)

612−checkFunctionApplication fn fnTy arg ret = rethrow (mkCompileError errorMessage (Just (ExprError fn)) `combineErrors`) $ do

604+checkFunctionApplication fn fnTy arg ret = rethrow (onErrorMessages (ErrorInApplication fn fnTy arg)) $ do

613 subst <- unifyCurrentSubstitution <$> UnifyT get

605 subst <- unifyCurrentSubstitution <$> UnifyT get

614 checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)

606 checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)

615− where

616− errorMessage = "Error applying function of type "

617− ++ prettyPrintType fnTy

618− ++ " to argument " ++ prettyPrintValue arg

619

607

620-- |

608-- |

621-- Check the type of a function application

609-- Check the type of a function application

@@ -651,9 +639,7 @@ checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do

651 checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret

639 checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret

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

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

653 return (fnTy, App fn dict)

641 return (fnTy, App fn dict)

654−checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "

642+checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg

655− ++ prettyPrintType fnTy

656− ++ " to argument " ++ prettyPrintValue arg

657

643

658-- |

644-- |

659-- Compute the meet of two types, i.e. the most general type which both types subsume.

645-- Compute the meet of two types, i.e. the most general type which both types subsume.

@@ -673,5 +659,9 @@ meet e1 e2 t1 t2 = do

673-- |

659-- |

674-- Ensure a set of property names and value does not contain duplicate labels

660-- Ensure a set of property names and value does not contain duplicate labels

675--

661--

676−ensureNoDuplicateProperties :: (IsString e, MonadError e m) => [(String, Expr)] -> m ()

662+ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(String, Expr)] -> m ()

677−ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps

663+ensureNoDuplicateProperties ps =

664+ let ls = map fst ps in

665+ case ls \\ nub ls of

666+ l : _ -> throwError . errorMessage $ DuplicateLabel l Nothing

667+ _ -> return ()

src/Language/PureScript/TypeChecker/Unify.hs+7−8

@@ -34,7 +34,6 @@ import Control.Monad.Unify

35import Language.PureScript.Environment

36import Language.PureScript.Errors

37−import Language.PureScript.Pretty

38import Language.PureScript.TypeChecker.Monad

37import Language.PureScript.TypeChecker.Monad

39import Language.PureScript.TypeChecker.Skolems

38import Language.PureScript.TypeChecker.Skolems

40import Language.PureScript.TypeChecker.Synonyms

39import Language.PureScript.TypeChecker.Synonyms

@@ -60,7 +59,7 @@ instance Unifiable Check Type where

60-- Unify two types, updating the current substitution

59-- Unify two types, updating the current substitution

61--

60--

62unifyTypes :: Type -> Type -> UnifyT Type Check ()

61unifyTypes :: Type -> Type -> UnifyT Type Check ()

63−unifyTypes t1 t2 = rethrow (mkCompileError ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing `combineErrors`) $

62+unifyTypes t1 t2 = rethrow (onErrorMessages (ErrorUnifyingTypes t1 t2)) $

64 unifyTypes' t1 t2

63 unifyTypes' t1 t2

65 where

64 where

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

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

@@ -82,11 +81,11 @@ unifyTypes t1 t2 = rethrow (mkCompileError ("Error unifying type " ++ prettyPrin

82 sko <- newSkolemConstant

81 sko <- newSkolemConstant

83 let sk = skolemize ident sko sc ty1

82 let sk = skolemize ident sko sc ty1

84 sk `unifyTypes` ty2

83 sk `unifyTypes` ty2

85− unifyTypes' ForAll{} _ = throwError . strMsg $ "Skolem variable scope is unspecified"

84+ unifyTypes' ForAll{} _ = throwError . errorMessage $ UnspecifiedSkolemScope

86 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

85 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

87 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

86 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

88− unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =

87+ unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) =

89− guardWith (strMsg ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".")) (c1 == c2)

88+ guardWith (errorMessage (TypesDoNotUnify ty1 ty2)) (c1 == c2)

90 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

89 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

91 t3 `unifyTypes` t5

90 t3 `unifyTypes` t5

92 t4 `unifyTypes` t6

91 t4 `unifyTypes` t6

@@ -97,9 +96,9 @@ unifyTypes t1 t2 = rethrow (mkCompileError ("Error unifying type " ++ prettyPrin

97 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2

96 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2

98 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

97 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

99 unifyTypes' r1 r2@REmpty = unifyRows r1 r2

98 unifyTypes' r1 r2@REmpty = unifyRows r1 r2

100− unifyTypes' t@(ConstrainedType _ _) _ = throwError . strMsg $ "Attempted to unify a constrained type " ++ prettyPrintType t ++ " with another type."

99+ unifyTypes' ty1@(ConstrainedType _ _) ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2

101 unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3

100 unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3

102− unifyTypes' t3 t4 = throwError . strMsg $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

101+ unifyTypes' t3 t4 = throwError . errorMessage $ TypesDoNotUnify t3 t4

103

102

104-- |

103-- |

105-- Unify two rows, updating the current substitution

104-- Unify two rows, updating the current substitution

@@ -136,7 +135,7 @@ unifyRows r1 r2 =

136 unifyRows' [] REmpty [] REmpty = return ()

135 unifyRows' [] REmpty [] REmpty = return ()

137 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

136 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

138 unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()

137 unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()

139− unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"

138+ unifyRows' sd3 r3 sd4 r4 = throwError . errorMessage $ TypesDoNotUnify (rowFromList (sd3, r3)) (rowFromList (sd4, r4))

140

139

141-- |

140-- |

142-- Check that two types unify

141-- Check that two types unify

src/Language/PureScript/TypeClassDictionaries.hs+23

@@ -65,6 +65,29 @@ data TypeClassDictionaryType

65 --

66 | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)

68+-- |

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

70+-- class dictionaries at runtime, which can be compared for equality

71+--

72+data DictionaryValue

73+ -- |

74+ -- A dictionary which is brought into scope by a local constraint

75+ --

76+ = LocalDictionaryValue (Qualified Ident)

77+ -- |

78+ -- A dictionary which is brought into scope by an instance declaration

79+ --

80+ | GlobalDictionaryValue (Qualified Ident)

81+ -- |

82+ -- A dictionary which depends on other dictionaries

83+ --

84+ | DependentDictionaryValue (Qualified Ident) [DictionaryValue]

85+ -- |

86+ -- A subclass dictionary

87+ --

88+ | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

89+ deriving (Show, Ord, Eq)

90+

68-- |

91-- |

69-- Find the original dictionary which a type class dictionary in scope refers to

92-- Find the original dictionary which a type class dictionary in scope refers to

70--

93--

tests/Main.hs+1−1

@@ -77,7 +77,7 @@ assertDoesNotCompile preludeExterns inputFile = do

77 putStrLn $ "Assert " ++ inputFile ++ " does not compile"

78 assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile $ \e ->

79 case e of

80− Left _ -> return Nothing

80+ Left err -> putStrLn err >> return Nothing

81 Right _ -> return $ Just "Should not have compiled"

83findNodeProcess :: IO (Maybe String)