9345724 · rowtype-yoga/purescript-native

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

on golang help sign in

Change data structure for error message hints

9345724Phil Freeman11 years ago

psci/PSCi.hs+2−2

compare with golang

unifiedsplit

@@ -464,7 +464,7 @@ handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do

464 Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))

465handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do

466 foreignsOrError <- psciIO . runMake $ do

467− foreignFile <- makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile absPath)) (readFile absPath)

467+ foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)

468 P.parseForeignModulesFromFiles [(absPath, foreignFile)]

469 case foreignsOrError of

470 Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err

@@ -533,7 +533,7 @@ loop PSCiOptions{..} = do

533 historyFilename <- getHistoryFilename

534 let settings = defaultSettings { historyFile = Just historyFilename }

535 foreignsOrError <- runMake $ do

536− foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile inFile)) (readFile inFile))

536+ foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))

537 P.parseForeignModulesFromFiles foreignFilesContent

538 case foreignsOrError of

539 Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure

src/Language/PureScript/Errors.hs+227−278

@@ -20,10 +20,11 @@

20module Language.PureScript.Errors where

22import Data.Either (lefts, rights)

23−import Data.List (intercalate, transpose, nub)

23+import Data.List (intercalate, transpose, nub, nubBy, partition)

24import Data.Function (on)

25#if __GLASGOW_HASKELL__ < 710

26import Data.Foldable (fold, foldMap)

27+import Data.Traversable (traverse)

27#else

28#else

28import Data.Foldable (fold)

29import Data.Foldable (fold)

29#endif

30#endif

@@ -53,9 +54,7 @@ import qualified Text.Parsec as P

53import qualified Text.Parsec.Error as PE

54import qualified Text.Parsec.Error as PE

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

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

56−-- |

57−-- A type of error messages

57+-- | A type of error messages

58−--

59data SimpleErrorMessage

58data SimpleErrorMessage

60 = ErrorParsingExterns P.ParseError

59 = ErrorParsingExterns P.ParseError

61 | ErrorParsingFFIModule FilePath

60 | ErrorParsingFFIModule FilePath

@@ -148,39 +147,47 @@ data SimpleErrorMessage

148 | ClassOperator ProperName Ident

147 | ClassOperator ProperName Ident

149 | MisleadingEmptyTypeImport ModuleName ProperName

148 | MisleadingEmptyTypeImport ModuleName ProperName

150 | ImportHidingModule ModuleName

149 | ImportHidingModule ModuleName

151− deriving (Show)

150+ deriving Show

152−

151+

153−-- |

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

154−-- Wrapper of simpler errors

153+data ErrorMessageHint

155−--

156−data ErrorMessage

157− = NotYetDefined [Ident] ErrorMessage

154+ = NotYetDefined [Ident]

158− | ErrorUnifyingTypes Type Type ErrorMessage

155+ | ErrorUnifyingTypes Type Type

159− | ErrorInExpression Expr ErrorMessage

156+ | ErrorInExpression Expr

160− | ErrorInModule ModuleName ErrorMessage

157+ | ErrorInModule ModuleName

161− | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage

158+ | ErrorInInstance (Qualified ProperName) [Type]

162− | ErrorInSubsumption Type Type ErrorMessage

159+ | ErrorInSubsumption Type Type

163− | ErrorCheckingType Expr Type ErrorMessage

160+ | ErrorCheckingType Expr Type

164− | ErrorCheckingKind Type ErrorMessage

161+ | ErrorCheckingKind Type

165− | ErrorInferringType Expr ErrorMessage

162+ | ErrorInferringType Expr

166− | ErrorInApplication Expr Type Expr ErrorMessage

163+ | ErrorInApplication Expr Type Expr

167− | ErrorInDataConstructor ProperName ErrorMessage

164+ | ErrorInDataConstructor ProperName

168− | ErrorInTypeConstructor ProperName ErrorMessage

165+ | ErrorInTypeConstructor ProperName

169− | ErrorInBindingGroup [Ident] ErrorMessage

166+ | ErrorInBindingGroup [Ident]

170− | ErrorInDataBindingGroup ErrorMessage

167+ | ErrorInDataBindingGroup

171− | ErrorInTypeSynonym ProperName ErrorMessage

168+ | ErrorInTypeSynonym ProperName

172− | ErrorInValueDeclaration Ident ErrorMessage

169+ | ErrorInValueDeclaration Ident

173− | ErrorInTypeDeclaration Ident ErrorMessage

170+ | ErrorInTypeDeclaration Ident

174− | ErrorInForeignImport Ident ErrorMessage

171+ | ErrorInForeignImport Ident

175− | PositionedError SourceSpan ErrorMessage

172+ | PositionedError SourceSpan

176− | SimpleErrorWrapper SimpleErrorMessage

173+ deriving Show

177− deriving (Show)

174+

175+-- | Categories of hints

176+data HintCategory

177+ = ExprHint

178+ | KindHint

179+ | CheckHint

180+ | PositionHint

181+ | OtherHint

182+ deriving (Show, Eq)

183+

184+data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)

178

185

179instance UnificationError Type ErrorMessage where

186instance UnificationError Type ErrorMessage where

180− occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t

187+ occursCheckFailed t = ErrorMessage [] $ InfiniteType t

181

188

182instance UnificationError Kind ErrorMessage where

189instance UnificationError Kind ErrorMessage where

183− occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k

190+ occursCheckFailed k = ErrorMessage [] $ InfiniteKind k

184

191

185-- |

192-- |

186-- Get the error code for a particular error type

193-- Get the error code for a particular error type

@@ -299,7 +306,7 @@ nonEmpty = not . null . runMultipleErrors

299-- Create an error set from a single simple error message

306-- Create an error set from a single simple error message

300--

307--

301errorMessage :: SimpleErrorMessage -> MultipleErrors

308errorMessage :: SimpleErrorMessage -> MultipleErrors

302−errorMessage err = MultipleErrors [SimpleErrorWrapper err]

309+errorMessage err = MultipleErrors [ErrorMessage [] err]

303

310

304

311

305-- |

312-- |

@@ -308,12 +315,14 @@ errorMessage err = MultipleErrors [SimpleErrorWrapper err]

308singleError :: ErrorMessage -> MultipleErrors

315singleError :: ErrorMessage -> MultipleErrors

309singleError = MultipleErrors . pure

316singleError = MultipleErrors . pure

310

317

311−-- |

312−-- Lift a function on ErrorMessage to a function on MultipleErrors

318+-- | Lift a function on ErrorMessage to a function on MultipleErrors

313−--

314onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors

319onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors

315onErrorMessages f = MultipleErrors . map f . runMultipleErrors

320onErrorMessages f = MultipleErrors . map f . runMultipleErrors

316

321

322+-- | Add a hint to an error message

323+addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors

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

325+

317-- | The various types of things which might need to be relabelled in errors messages.

326-- | The various types of things which might need to be relabelled in errors messages.

318data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord)

327data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord)

319

328

@@ -327,27 +336,7 @@ data Level = Error | Warning deriving Show

327-- Extract nested error messages from wrapper errors

336-- Extract nested error messages from wrapper errors

328--

337--

329unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage

338unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage

330−unwrapErrorMessage em = case em of

339+unwrapErrorMessage (ErrorMessage _ se) = se

331− (ErrorCheckingKind _ err) -> unwrapErrorMessage err

332− (ErrorCheckingType _ _ err) -> unwrapErrorMessage err

333− (ErrorInApplication _ _ _ err) -> unwrapErrorMessage err

334− (ErrorInBindingGroup _ err) -> unwrapErrorMessage err

335− (ErrorInDataBindingGroup err) -> unwrapErrorMessage err

336− (ErrorInDataConstructor _ err) -> unwrapErrorMessage err

337− (ErrorInExpression _ err) -> unwrapErrorMessage err

338− (ErrorInForeignImport _ err) -> unwrapErrorMessage err

339− (ErrorInInstance _ _ err) -> unwrapErrorMessage err

340− (ErrorInModule _ err) -> unwrapErrorMessage err

341− (ErrorInSubsumption _ _ err) -> unwrapErrorMessage err

342− (ErrorInTypeConstructor _ err) -> unwrapErrorMessage err

343− (ErrorInTypeSynonym _ err) -> unwrapErrorMessage err

344− (ErrorInValueDeclaration _ err) -> unwrapErrorMessage err

345− (ErrorInTypeDeclaration _ err) -> unwrapErrorMessage err

346− (ErrorInferringType _ err) -> unwrapErrorMessage err

347− (ErrorUnifyingTypes _ _ err) -> unwrapErrorMessage err

348− (NotYetDefined _ err) -> unwrapErrorMessage err

349− (PositionedError _ err) -> unwrapErrorMessage err

350− (SimpleErrorWrapper sem) -> sem

351

340

352replaceUnknowns :: Type -> State UnknownMap Type

341replaceUnknowns :: Type -> State UnknownMap Type

353replaceUnknowns = everywhereOnTypesM replaceTypes

342replaceUnknowns = everywhereOnTypesM replaceTypes

@@ -363,7 +352,7 @@ replaceUnknowns = everywhereOnTypesM replaceTypes

363 replaceTypes other = return other

352 replaceTypes other = return other

364

353

365onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage

354onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage

366−onTypesInErrorMessageM f = g

355+onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple

367 where

356 where

368 gSimple (InfiniteType t) = InfiniteType <$> f t

357 gSimple (InfiniteType t) = InfiniteType <$> f t

369 gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2

358 gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2

@@ -373,204 +362,191 @@ onTypesInErrorMessageM f = g

373 gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e

362 gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e

374 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t

363 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t

375 gSimple other = pure other

364 gSimple other = pure other

376− g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> f t1 <*> f t2 <*> g em

365+ gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2

377− g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> f t1 <*> f t2 <*> g e

366+ gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2

378− g (ErrorCheckingType e t em) = ErrorCheckingType e <$> f t <*> g em

367+ gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t

379− g (ErrorCheckingKind t em) = ErrorCheckingKind <$> f t <*> g em

368+ gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t

380− g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> f t1 <*> pure e2 <*> g em

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

381− g (NotYetDefined x e) = NotYetDefined x <$> g e

370+ gHint other = pure other

382− g (ErrorInExpression x e) = ErrorInExpression x <$> g e

383− g (ErrorInModule x e) = ErrorInModule x <$> g e

384− g (ErrorInInstance x y e) = ErrorInInstance x y <$> g e

385− g (ErrorInferringType x e) = ErrorInferringType x <$> g e

386− g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> g e

387− g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> g e

388− g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> g e

389− g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> g e

390− g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> g e

391− g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> g e

392− g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> g e

393− g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> g e

394− g (PositionedError x e) = PositionedError x <$> g e

395− g (SimpleErrorWrapper sem) = SimpleErrorWrapper <$> gSimple sem

396

371

397-- |

372-- |

398-- Pretty print a single error, simplifying if necessary

373-- Pretty print a single error, simplifying if necessary

399--

374--

400prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box

375prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box

401−prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

376+prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFirst . reverseHints <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

402 where

377 where

403− -- |

378+

404 -- Pretty print an ErrorMessage

379 -- Pretty print an ErrorMessage

405− --

406 prettyPrintErrorMessage :: ErrorMessage -> Box.Box

380 prettyPrintErrorMessage :: ErrorMessage -> Box.Box

407− prettyPrintErrorMessage em =

381+ prettyPrintErrorMessage (ErrorMessage hints simple) =

408 paras $

382 paras $

383+ map renderHint hints ++

384+ renderSimpleErrorMessage simple :

409− go em:suggestions em ++

385+ suggestions simple ++

410 [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."]

386 [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."]

411 where

387 where

412 wikiUri :: String

388 wikiUri :: String

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

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

414

390

415− go :: ErrorMessage -> Box.Box

391+ renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

416− goSimple (CannotGetFileInfo path) =

392+ renderSimpleErrorMessage (CannotGetFileInfo path) =

417 paras [ line "Unable to read file info: "

393 paras [ line "Unable to read file info: "

418 , indent . line $ path

394 , indent . line $ path

419 ]

395 ]

420− goSimple (CannotReadFile path) =

396+ renderSimpleErrorMessage (CannotReadFile path) =

421 paras [ line "Unable to read file: "

397 paras [ line "Unable to read file: "

422 , indent . line $ path

398 , indent . line $ path

423 ]

399 ]

424− goSimple (CannotWriteFile path) =

400+ renderSimpleErrorMessage (CannotWriteFile path) =

425 paras [ line "Unable to write file: "

401 paras [ line "Unable to write file: "

426 , indent . line $ path

402 , indent . line $ path

427 ]

403 ]

428− goSimple (ErrorParsingExterns err) =

404+ renderSimpleErrorMessage (ErrorParsingExterns err) =

429 paras [ lineWithLevel "parsing externs files: "

405 paras [ lineWithLevel "parsing externs files: "

430 , prettyPrintParseError err

406 , prettyPrintParseError err

431 ]

407 ]

432− goSimple (ErrorParsingFFIModule path) =

408+ renderSimpleErrorMessage (ErrorParsingFFIModule path) =

433 paras [ line "Unable to parse module from FFI file: "

409 paras [ line "Unable to parse module from FFI file: "

434 , indent . line $ path

410 , indent . line $ path

435 ]

411 ]

436− goSimple (ErrorParsingModule err) =

412+ renderSimpleErrorMessage (ErrorParsingModule err) =

437 paras [ line "Unable to parse module: "

413 paras [ line "Unable to parse module: "

438 , prettyPrintParseError err

414 , prettyPrintParseError err

439 ]

415 ]

440− goSimple (MissingFFIModule mn) =

416+ renderSimpleErrorMessage (MissingFFIModule mn) =

441 line $ "Missing FFI implementations for module " ++ runModuleName mn

417 line $ "Missing FFI implementations for module " ++ runModuleName mn

442− goSimple (UnnecessaryFFIModule mn path) =

418+ renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =

443 paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": "

419 paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": "

444 , indent . line $ path

420 , indent . line $ path

445 ]

421 ]

446− goSimple (MultipleFFIModules mn paths) =

422+ renderSimpleErrorMessage (MultipleFFIModules mn paths) =

447 paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": "

423 paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": "

448 , indent . paras $ map line paths

424 , indent . paras $ map line paths

449 ]

425 ]

450− goSimple (InvalidExternsFile path) =

426+ renderSimpleErrorMessage (InvalidExternsFile path) =

451 paras [ line "Externs file is invalid: "

427 paras [ line "Externs file is invalid: "

452 , indent . line $ path

428 , indent . line $ path

453 ]

429 ]

454− goSimple InvalidDoBind =

430+ renderSimpleErrorMessage InvalidDoBind =

455 line "Bind statement cannot be the last statement in a do block. The last statement must be an expression."

431 line "Bind statement cannot be the last statement in a do block. The last statement must be an expression."

456− goSimple InvalidDoLet =

432+ renderSimpleErrorMessage InvalidDoLet =

457 line "Let statement cannot be the last statement in a do block. The last statement must be an expression."

433 line "Let statement cannot be the last statement in a do block. The last statement must be an expression."

458− goSimple CannotReorderOperators =

434+ renderSimpleErrorMessage CannotReorderOperators =

459 line "Unable to reorder operators"

435 line "Unable to reorder operators"

460− goSimple UnspecifiedSkolemScope =

436+ renderSimpleErrorMessage UnspecifiedSkolemScope =

461 line "Skolem variable scope is unspecified"

437 line "Skolem variable scope is unspecified"

462− goSimple OverlappingNamesInLet =

438+ renderSimpleErrorMessage OverlappingNamesInLet =

463 line "Overlapping names in let binding."

439 line "Overlapping names in let binding."

464− goSimple (InfiniteType ty) =

440+ renderSimpleErrorMessage (InfiniteType ty) =

465 paras [ line "An infinite type was inferred for an expression: "

441 paras [ line "An infinite type was inferred for an expression: "

466 , indent $ typeAsBox ty

442 , indent $ typeAsBox ty

467 ]

443 ]

468− goSimple (InfiniteKind ki) =

444+ renderSimpleErrorMessage (InfiniteKind ki) =

469 paras [ line "An infinite kind was inferred for a type: "

445 paras [ line "An infinite kind was inferred for a type: "

470 , indent $ kindAsBox ki

446 , indent $ kindAsBox ki

471 ]

447 ]

472− goSimple (MultipleFixities name) =

448+ renderSimpleErrorMessage (MultipleFixities name) =

473 line $ "Multiple fixity declarations for " ++ showIdent name

449 line $ "Multiple fixity declarations for " ++ showIdent name

474− goSimple (OrphanTypeDeclaration nm) =

450+ renderSimpleErrorMessage (OrphanTypeDeclaration nm) =

475 line $ "Orphan type declaration for " ++ showIdent nm

451 line $ "Orphan type declaration for " ++ showIdent nm

476− goSimple (OrphanFixityDeclaration op) =

452+ renderSimpleErrorMessage (OrphanFixityDeclaration op) =

477 line $ "Orphan fixity declaration for " ++ show op

453 line $ "Orphan fixity declaration for " ++ show op

478− goSimple (RedefinedModule name filenames) =

454+ renderSimpleErrorMessage (RedefinedModule name filenames) =

479 paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")

455 paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")

480 , indent . paras $ map (line . displaySourceSpan) filenames

456 , indent . paras $ map (line . displaySourceSpan) filenames

481 ]

457 ]

482− goSimple (RedefinedIdent name) =

458+ renderSimpleErrorMessage (RedefinedIdent name) =

483 line $ "Name " ++ showIdent name ++ " has been defined multiple times"

459 line $ "Name " ++ showIdent name ++ " has been defined multiple times"

484− goSimple (UnknownModule mn) =

460+ renderSimpleErrorMessage (UnknownModule mn) =

485 line $ "Unknown module " ++ runModuleName mn

461 line $ "Unknown module " ++ runModuleName mn

486− goSimple (UnknownType name) =

462+ renderSimpleErrorMessage (UnknownType name) =

487 line $ "Unknown type " ++ showQualified runProperName name

463 line $ "Unknown type " ++ showQualified runProperName name

488− goSimple (UnknownTypeClass name) =

464+ renderSimpleErrorMessage (UnknownTypeClass name) =

489 line $ "Unknown type class " ++ showQualified runProperName name

465 line $ "Unknown type class " ++ showQualified runProperName name

490− goSimple (UnknownValue name) =

466+ renderSimpleErrorMessage (UnknownValue name) =

491 line $ "Unknown value " ++ showQualified showIdent name

467 line $ "Unknown value " ++ showQualified showIdent name

492− goSimple (UnknownTypeConstructor name) =

468+ renderSimpleErrorMessage (UnknownTypeConstructor name) =

493 line $ "Unknown type constructor " ++ showQualified runProperName name

469 line $ "Unknown type constructor " ++ showQualified runProperName name

494− goSimple (UnknownDataConstructor dc tc) =

470+ renderSimpleErrorMessage (UnknownDataConstructor dc tc) =

495 line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc

471 line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc

496− goSimple (UnknownImportType mn name) =

472+ renderSimpleErrorMessage (UnknownImportType mn name) =

497 line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name

473 line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name

498− goSimple (UnknownExportType name) =

474+ renderSimpleErrorMessage (UnknownExportType name) =

499 line $ "Cannot export unknown type " ++ runProperName name

475 line $ "Cannot export unknown type " ++ runProperName name

500− goSimple (UnknownImportTypeClass mn name) =

476+ renderSimpleErrorMessage (UnknownImportTypeClass mn name) =

501 line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name

477 line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name

502− goSimple (UnknownExportTypeClass name) =

478+ renderSimpleErrorMessage (UnknownExportTypeClass name) =

503 line $ "Cannot export unknown type class " ++ runProperName name

479 line $ "Cannot export unknown type class " ++ runProperName name

504− goSimple (UnknownImportValue mn name) =

480+ renderSimpleErrorMessage (UnknownImportValue mn name) =

505 line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name

481 line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name

506− goSimple (UnknownExportValue name) =

482+ renderSimpleErrorMessage (UnknownExportValue name) =

507 line $ "Cannot export unknown value " ++ showIdent name

483 line $ "Cannot export unknown value " ++ showIdent name

508− goSimple (UnknownExportModule name) =

484+ renderSimpleErrorMessage (UnknownExportModule name) =

509 line $ "Cannot export unknown module " ++ runModuleName name ++ ", it either does not exist or has not been imported by the current module"

485 line $ "Cannot export unknown module " ++ runModuleName name ++ ", it either does not exist or has not been imported by the current module"

510− goSimple (UnknownImportDataConstructor mn tcon dcon) =

486+ renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =

511 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon

487 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon

512− goSimple (UnknownExportDataConstructor tcon dcon) =

488+ renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

513 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ " as it has not been declared"

489 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ " as it has not been declared"

514− goSimple (ConflictingImport nm mn) =

490+ renderSimpleErrorMessage (ConflictingImport nm mn) =

515 line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn

491 line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn

516− goSimple (ConflictingImports nm m1 m2) =

492+ renderSimpleErrorMessage (ConflictingImports nm m1 m2) =

517 line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2

493 line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2

518− goSimple (ConflictingTypeDecls nm) =

494+ renderSimpleErrorMessage (ConflictingTypeDecls nm) =

519 line $ "Conflicting type declarations for " ++ runProperName nm

495 line $ "Conflicting type declarations for " ++ runProperName nm

520− goSimple (ConflictingCtorDecls nm) =

496+ renderSimpleErrorMessage (ConflictingCtorDecls nm) =

521 line $ "Conflicting data constructor declarations for " ++ runProperName nm

497 line $ "Conflicting data constructor declarations for " ++ runProperName nm

522− goSimple (TypeConflictsWithClass nm) =

498+ renderSimpleErrorMessage (TypeConflictsWithClass nm) =

523 line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name"

499 line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name"

524− goSimple (CtorConflictsWithClass nm) =

500+ renderSimpleErrorMessage (CtorConflictsWithClass nm) =

525 line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name"

501 line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name"

526− goSimple (ClassConflictsWithType nm) =

502+ renderSimpleErrorMessage (ClassConflictsWithType nm) =

527 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"

503 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"

528− goSimple (ClassConflictsWithCtor nm) =

504+ renderSimpleErrorMessage (ClassConflictsWithCtor nm) =

529 line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"

505 line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"

530− goSimple (DuplicateClassExport nm) =

506+ renderSimpleErrorMessage (DuplicateClassExport nm) =

531 line $ "Duplicate export declaration for type class " ++ runProperName nm

507 line $ "Duplicate export declaration for type class " ++ runProperName nm

532− goSimple (DuplicateValueExport nm) =

508+ renderSimpleErrorMessage (DuplicateValueExport nm) =

533 line $ "Duplicate export declaration for value " ++ showIdent nm

509 line $ "Duplicate export declaration for value " ++ showIdent nm

534− goSimple (CycleInDeclaration nm) =

510+ renderSimpleErrorMessage (CycleInDeclaration nm) =

535 line $ "Cycle in declaration of " ++ showIdent nm

511 line $ "Cycle in declaration of " ++ showIdent nm

536− goSimple (CycleInModules mns) =

512+ renderSimpleErrorMessage (CycleInModules mns) =

537 line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns)

513 line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns)

538− goSimple (CycleInTypeSynonym pn) =

514+ renderSimpleErrorMessage (CycleInTypeSynonym pn) =

539 line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn

515 line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn

540− goSimple (NameIsUndefined ident) =

516+ renderSimpleErrorMessage (NameIsUndefined ident) =

541 line $ showIdent ident ++ " is undefined"

517 line $ showIdent ident ++ " is undefined"

542− goSimple (NameNotInScope ident) =

518+ renderSimpleErrorMessage (NameNotInScope ident) =

543 line $ showIdent ident ++ " may not be defined in the current scope"

519 line $ showIdent ident ++ " may not be defined in the current scope"

544− goSimple (UndefinedTypeVariable name) =

520+ renderSimpleErrorMessage (UndefinedTypeVariable name) =

545 line $ "Type variable " ++ runProperName name ++ " is undefined"

521 line $ "Type variable " ++ runProperName name ++ " is undefined"

546− goSimple (PartiallyAppliedSynonym name) =

522+ renderSimpleErrorMessage (PartiallyAppliedSynonym name) =

547 paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name

523 paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name

548 , line "Type synonyms must be applied to all of their type arguments."

524 , line "Type synonyms must be applied to all of their type arguments."

549 ]

525 ]

550− goSimple (EscapedSkolem binding) =

526+ renderSimpleErrorMessage (EscapedSkolem binding) =

551 paras $ [ line "A type variable has escaped its scope." ]

527 paras $ [ line "A type variable has escaped its scope." ]

552 <> foldMap (\expr -> [ line "Relevant expression: "

528 <> foldMap (\expr -> [ line "Relevant expression: "

553 , indent $ prettyPrintValue expr

529 , indent $ prettyPrintValue expr

554 ]) binding

530 ]) binding

555− goSimple (TypesDoNotUnify t1 t2)

531+ renderSimpleErrorMessage (TypesDoNotUnify t1 t2)

556 = paras [ line "Cannot unify type"

532 = paras [ line "Cannot unify type"

557 , indent $ typeAsBox t1

533 , indent $ typeAsBox t1

558 , line "with type"

534 , line "with type"

559 , indent $ typeAsBox t2

535 , indent $ typeAsBox t2

560 ]

536 ]

561− goSimple (KindsDoNotUnify k1 k2) =

537+ renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =

562 paras [ line "Cannot unify kind"

538 paras [ line "Cannot unify kind"

563 , indent $ kindAsBox k1

539 , indent $ kindAsBox k1

564 , line "with kind"

540 , line "with kind"

565 , indent $ kindAsBox k2

541 , indent $ kindAsBox k2

566 ]

542 ]

567− goSimple (ConstrainedTypeUnified t1 t2) =

543+ renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =

568 paras [ line "Cannot unify constrained type"

544 paras [ line "Cannot unify constrained type"

569 , indent $ typeAsBox t1

545 , indent $ typeAsBox t1

570 , line "with type"

546 , line "with type"

571 , indent $ typeAsBox t2

547 , indent $ typeAsBox t2

572 ]

548 ]

573− goSimple (OverlappingInstances nm ts (d : ds)) =

549+ renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =

574 paras [ line "Overlapping instances found for"

550 paras [ line "Overlapping instances found for"

575 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

551 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

576 , Box.vcat Box.left (map typeAtomAsBox ts)

552 , Box.vcat Box.left (map typeAtomAsBox ts)

@@ -578,46 +554,46 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

578 , line "The following instances were found:"

554 , line "The following instances were found:"

579 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)

555 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)

580 ]

556 ]

581− goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list"

557+ renderSimpleErrorMessage OverlappingInstances{} = error "OverlappingInstances: empty instance list"

582− goSimple (NoInstanceFound nm ts) =

558+ renderSimpleErrorMessage (NoInstanceFound nm ts) =

583 paras [ line "No instance found for"

559 paras [ line "No instance found for"

584 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

560 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

585 , Box.vcat Box.left (map typeAtomAsBox ts)

561 , Box.vcat Box.left (map typeAtomAsBox ts)

586 ]

562 ]

587 ]

563 ]

588− goSimple (PossiblyInfiniteInstance nm ts) =

564+ renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =

589 paras [ line "Instance for"

565 paras [ line "Instance for"

590 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

566 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

591 , Box.vcat Box.left (map typeAtomAsBox ts)

567 , Box.vcat Box.left (map typeAtomAsBox ts)

592 ]

568 ]

593 , line "is possibly infinite."

569 , line "is possibly infinite."

594 ]

570 ]

595− goSimple (CannotDerive nm ts) =

571+ renderSimpleErrorMessage (CannotDerive nm ts) =

596 paras [ line "Cannot derive an instance for"

572 paras [ line "Cannot derive an instance for"

597 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

573 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

598 , Box.vcat Box.left (map typeAtomAsBox ts)

574 , Box.vcat Box.left (map typeAtomAsBox ts)

599 ]

575 ]

600 ]

576 ]

601− goSimple (CannotFindDerivingType nm) =

577+ renderSimpleErrorMessage (CannotFindDerivingType nm) =

602 line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found."

578 line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found."

603− goSimple (DuplicateLabel l expr) =

579+ renderSimpleErrorMessage (DuplicateLabel l expr) =

604 paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]

580 paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]

605 <> foldMap (\expr' -> [ line "Relevant expression: "

581 <> foldMap (\expr' -> [ line "Relevant expression: "

606 , indent $ prettyPrintValue expr'

582 , indent $ prettyPrintValue expr'

607 ]) expr

583 ]) expr

608− goSimple (DuplicateTypeArgument name) =

584+ renderSimpleErrorMessage (DuplicateTypeArgument name) =

609 line $ "Duplicate type argument " ++ show name

585 line $ "Duplicate type argument " ++ show name

610− goSimple (DuplicateValueDeclaration nm) =

586+ renderSimpleErrorMessage (DuplicateValueDeclaration nm) =

611 line $ "Duplicate value declaration for " ++ showIdent nm

587 line $ "Duplicate value declaration for " ++ showIdent nm

612− goSimple (ArgListLengthsDiffer ident) =

588+ renderSimpleErrorMessage (ArgListLengthsDiffer ident) =

613 line $ "Argument list lengths differ in declaration " ++ showIdent ident

589 line $ "Argument list lengths differ in declaration " ++ showIdent ident

614− goSimple (OverlappingArgNames ident) =

590+ renderSimpleErrorMessage (OverlappingArgNames ident) =

615 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident

591 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident

616− goSimple (MissingClassMember ident) =

592+ renderSimpleErrorMessage (MissingClassMember ident) =

617 line $ "Member " ++ showIdent ident ++ " has not been implemented"

593 line $ "Member " ++ showIdent ident ++ " has not been implemented"

618− goSimple (ExtraneousClassMember ident) =

594+ renderSimpleErrorMessage (ExtraneousClassMember ident) =

619 line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"

595 line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"

620− goSimple (ExpectedType ty kind) =

596+ renderSimpleErrorMessage (ExpectedType ty kind) =

621 paras [ line "In a type-annotated expression x :: t, the type t must have kind *."

597 paras [ line "In a type-annotated expression x :: t, the type t must have kind *."

622 , line "The error arises from the type"

598 , line "The error arises from the type"

623 , indent $ typeAsBox ty

599 , indent $ typeAsBox ty

@@ -625,29 +601,29 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

625 , indent $ kindAsBox kind

601 , indent $ kindAsBox kind

626 , line "instead."

602 , line "instead."

627 ]

603 ]

628− goSimple (IncorrectConstructorArity nm) =

604+ renderSimpleErrorMessage (IncorrectConstructorArity nm) =

629 line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm

605 line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm

630− goSimple SubsumptionCheckFailed = line "Unable to check type subsumption"

606+ renderSimpleErrorMessage SubsumptionCheckFailed = line "Unable to check type subsumption"

631− goSimple (ExprDoesNotHaveType expr ty) =

607+ renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =

632 paras [ line "Expression"

608 paras [ line "Expression"

633 , indent $ prettyPrintValue expr

609 , indent $ prettyPrintValue expr

634 , line "does not have type"

610 , line "does not have type"

635 , indent $ typeAsBox ty

611 , indent $ typeAsBox ty

636 ]

612 ]

637− goSimple (PropertyIsMissing prop row) =

613+ renderSimpleErrorMessage (PropertyIsMissing prop row) =

638 paras [ line "Row"

614 paras [ line "Row"

639 , indent $ prettyPrintRowWith '(' ')' row

615 , indent $ prettyPrintRowWith '(' ')' row

640 , line $ "lacks required property " ++ show prop

616 , line $ "lacks required property " ++ show prop

641 ]

617 ]

642− goSimple (CannotApplyFunction fn arg) =

618+ renderSimpleErrorMessage (CannotApplyFunction fn arg) =

643 paras [ line "Cannot apply function of type"

619 paras [ line "Cannot apply function of type"

644 , indent $ typeAsBox fn

620 , indent $ typeAsBox fn

645 , line "to argument"

621 , line "to argument"

646 , indent $ prettyPrintValue arg

622 , indent $ prettyPrintValue arg

647 ]

623 ]

648− goSimple TypeSynonymInstance =

624+ renderSimpleErrorMessage TypeSynonymInstance =

649 line "Type synonym instances are disallowed"

625 line "Type synonym instances are disallowed"

650− goSimple (OrphanInstance nm cnm ts) =

626+ renderSimpleErrorMessage (OrphanInstance nm cnm ts) =

651 paras [ line $ "Instance " ++ showIdent nm ++ " for "

627 paras [ line $ "Instance " ++ showIdent nm ++ " for "

652 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)

628 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)

653 , Box.vcat Box.left (map typeAtomAsBox ts)

629 , Box.vcat Box.left (map typeAtomAsBox ts)

@@ -656,146 +632,118 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

656 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."

632 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."

657 , line "Consider moving the instance, if possible, or using a newtype wrapper."

633 , line "Consider moving the instance, if possible, or using a newtype wrapper."

658 ]

634 ]

659− goSimple InvalidNewtype =

635+ renderSimpleErrorMessage InvalidNewtype =

660 line "Newtypes must define a single constructor with a single argument"

636 line "Newtypes must define a single constructor with a single argument"

661− goSimple (InvalidInstanceHead ty) =

637+ renderSimpleErrorMessage (InvalidInstanceHead ty) =

662 paras [ line "Invalid type in class instance head:"

638 paras [ line "Invalid type in class instance head:"

663 , indent $ typeAsBox ty

639 , indent $ typeAsBox ty

664 ]

640 ]

665− goSimple (TransitiveExportError x ys) =

641+ renderSimpleErrorMessage (TransitiveExportError x ys) =

666 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

642 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

667 : map (line . prettyPrintExport) ys

643 : map (line . prettyPrintExport) ys

668− goSimple (ShadowedName nm) =

644+ renderSimpleErrorMessage (ShadowedName nm) =

669 line $ "Name '" ++ showIdent nm ++ "' was shadowed"

645 line $ "Name '" ++ showIdent nm ++ "' was shadowed"

670− goSimple (ShadowedTypeVar tv) =

646+ renderSimpleErrorMessage (ShadowedTypeVar tv) =

671 line $ "Type variable '" ++ tv ++ "' was shadowed"

647 line $ "Type variable '" ++ tv ++ "' was shadowed"

672− goSimple (UnusedTypeVar tv) =

648+ renderSimpleErrorMessage (UnusedTypeVar tv) =

673 line $ "Type variable '" ++ tv ++ "' was declared but not used"

649 line $ "Type variable '" ++ tv ++ "' was declared but not used"

674− goSimple (ClassOperator className opName) =

650+ renderSimpleErrorMessage (ClassOperator className opName) =

675 paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."

651 paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."

676 , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"

652 , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"

677 , indent . line $ showIdent opName ++ " = someMember"

653 , indent . line $ showIdent opName ++ " = someMember"

678 ]

654 ]

679− goSimple (MisleadingEmptyTypeImport mn name) =

655+ renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

680 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors"

656 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors"

681− goSimple (ImportHidingModule name) =

657+ renderSimpleErrorMessage (ImportHidingModule name) =

682 line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"

658 line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"

683− goSimple (WildcardInferredType ty) =

659+ renderSimpleErrorMessage (WildcardInferredType ty) =

684 paras [ line "The wildcard type definition has the inferred type "

660 paras [ line "The wildcard type definition has the inferred type "

685 , indent $ typeAsBox ty

661 , indent $ typeAsBox ty

686 ]

662 ]

687− goSimple (NotExhaustivePattern bs b) =

663+ renderSimpleErrorMessage (NotExhaustivePattern bs b) =

688 paras $ [ line "A case expression could not be determined to cover all inputs."

664 paras $ [ line "A case expression could not be determined to cover all inputs."

689 , line "The following additional cases are required to cover all inputs:\n"

665 , line "The following additional cases are required to cover all inputs:\n"

690 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

666 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

691 ] ++

667 ] ++

692 [ line "..." | not b ]

668 [ line "..." | not b ]

693− goSimple (OverlappingPattern bs b) =

669+ renderSimpleErrorMessage (OverlappingPattern bs b) =

694 paras $ [ line "A case expression contains unreachable cases:\n"

670 paras $ [ line "A case expression contains unreachable cases:\n"

695 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

671 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

696 ] ++

672 ] ++

697 [ line "..." | not b ]

673 [ line "..." | not b ]

698− goSimple IncompleteExhaustivityCheck =

674+ renderSimpleErrorMessage IncompleteExhaustivityCheck =

699 paras [ line "An exhaustivity check was abandoned due to too many possible cases."

675 paras [ line "An exhaustivity check was abandoned due to too many possible cases."

700 , line "You may want to decomposing your data types into smaller types."

676 , line "You may want to decomposing your data types into smaller types."

701 ]

677 ]

678+

679+ renderHint :: ErrorMessageHint -> Box.Box

702− go (NotYetDefined names err) =

680+ renderHint (NotYetDefined names) =

703− paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"

681+ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"

704− , go err

705− ]

706− go (ErrorUnifyingTypes t1 t2 err) =

682+ renderHint (ErrorUnifyingTypes t1 t2) =

707 paras [ lineWithLevel "unifying type "

683 paras [ lineWithLevel "unifying type "

708 , indent $ typeAsBox t1

684 , indent $ typeAsBox t1

709 , line "with type"

685 , line "with type"

710 , indent $ typeAsBox t2

686 , indent $ typeAsBox t2

711− , go err

712 ]

687 ]

713− go (ErrorInExpression expr err) =

688+ renderHint (ErrorInExpression expr) =

714 paras [ lineWithLevel "in expression:"

689 paras [ lineWithLevel "in expression:"

715 , indent $ prettyPrintValue expr

690 , indent $ prettyPrintValue expr

716− , go err

717 ]

691 ]

718− go (ErrorInModule mn err) =

692+ renderHint (ErrorInModule mn) =

719 paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"

693 paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"

720− , go err

721 ]

694 ]

722− go (ErrorInSubsumption t1 t2 err) =

695+ renderHint (ErrorInSubsumption t1 t2) =

723 paras [ lineWithLevel "checking that type "

696 paras [ lineWithLevel "checking that type "

724 , indent $ typeAsBox t1

697 , indent $ typeAsBox t1

725 , line "subsumes type"

698 , line "subsumes type"

726 , indent $ typeAsBox t2

699 , indent $ typeAsBox t2

727− , go err

728 ]

700 ]

729− go (ErrorInInstance nm ts err) =

701+ renderHint (ErrorInInstance nm ts) =

730 paras [ lineWithLevel "in type class instance"

702 paras [ lineWithLevel "in type class instance"

731 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

703 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

732 , Box.vcat Box.left (map typeAtomAsBox ts)

704 , Box.vcat Box.left (map typeAtomAsBox ts)

733 ]

705 ]

734− , go err

735 ]

706 ]

736− go (ErrorCheckingKind ty err) =

707+ renderHint (ErrorCheckingKind ty) =

737 paras [ lineWithLevel "checking kind of type "

708 paras [ lineWithLevel "checking kind of type "

738 , indent $ typeAsBox ty

709 , indent $ typeAsBox ty

739− , go err

740 ]

710 ]

741− go (ErrorInferringType expr err) =

711+ renderHint (ErrorInferringType expr) =

742 paras [ lineWithLevel "inferring type of value "

712 paras [ lineWithLevel "inferring type of value "

743 , indent $ prettyPrintValue expr

713 , indent $ prettyPrintValue expr

744− , go err

745 ]

714 ]

746− go (ErrorCheckingType expr ty err) =

715+ renderHint (ErrorCheckingType expr ty) =

747 paras [ lineWithLevel "checking that value "

716 paras [ lineWithLevel "checking that value "

748 , indent $ prettyPrintValue expr

717 , indent $ prettyPrintValue expr

749 , line "has type"

718 , line "has type"

750 , indent $ typeAsBox ty

719 , indent $ typeAsBox ty

751− , go err

752 ]

720 ]

753− go (ErrorInApplication f t a err) =

721+ renderHint (ErrorInApplication f t a) =

754 paras [ lineWithLevel "applying function"

722 paras [ lineWithLevel "applying function"

755 , indent $ prettyPrintValue f

723 , indent $ prettyPrintValue f

756 , line "of type"

724 , line "of type"

757 , indent $ typeAsBox t

725 , indent $ typeAsBox t

758 , line "to argument"

726 , line "to argument"

759 , indent $ prettyPrintValue a

727 , indent $ prettyPrintValue a

760− , go err

761− ]

762− go (ErrorInDataConstructor nm err) =

763− paras [ lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"

764− , go err

765− ]

766− go (ErrorInTypeConstructor nm err) =

767− paras [ lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"

768− , go err

769 ]

728 ]

729+ renderHint (ErrorInDataConstructor nm) =

730+ lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"

731+ renderHint (ErrorInTypeConstructor nm) =

732+ lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"

770− go (ErrorInBindingGroup nms err) =

733+ renderHint (ErrorInBindingGroup nms) =

771− paras [ lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"

734+ lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"

772− , go err

773− ]

774− go (ErrorInDataBindingGroup err) =

735+ renderHint ErrorInDataBindingGroup =

775− paras [ lineWithLevel "in data binding group:"

736+ lineWithLevel "in data binding group:"

776− , go err

777− ]

778− go (ErrorInTypeSynonym name err) =

737+ renderHint (ErrorInTypeSynonym name) =

779− paras [ lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"

738+ lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"

780− , go err

781− ]

782− go (ErrorInValueDeclaration n err) =

739+ renderHint (ErrorInValueDeclaration n) =

783− paras [ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"

740+ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"

784− , go err

785− ]

786− go (ErrorInTypeDeclaration n err) =

741+ renderHint (ErrorInTypeDeclaration n) =

787− paras [ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"

742+ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"

788− , go err

789− ]

790− go (ErrorInForeignImport nm err) =

743+ renderHint (ErrorInForeignImport nm) =

791− paras [ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"

744+ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"

792− , go err

793− ]

794− go (PositionedError srcSpan err) =

745+ renderHint (PositionedError srcSpan) =

795− paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"

746+ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"

796− , go err

797− ]

798− go (SimpleErrorWrapper sem) = goSimple sem

799

747

800 lineWithLevel :: String -> Box.Box

748 lineWithLevel :: String -> Box.Box

801 lineWithLevel text = line $ show level ++ " " ++ text

749 lineWithLevel text = line $ show level ++ " " ++ text

@@ -805,23 +753,19 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

805 Error -> "error"

753 Error -> "error"

806 Warning -> "warning"

754 Warning -> "warning"

807

755

808− suggestions :: ErrorMessage -> [Box.Box]

756+ suggestions :: SimpleErrorMessage -> [Box.Box]

809− suggestions = suggestions' . unwrapErrorMessage

810− where

811− suggestions' (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":"

757+ suggestions (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":"

812 , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")"

758 , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")"

813 ]

759 ]

814− suggestions' (TypesDoNotUnify t1 t2)

760+ suggestions (TypesDoNotUnify t1 t2)

815− | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]

761+ | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]

816− | otherwise = []

762+ | otherwise = []

817− suggestions' _ = []

763+ suggestions _ = []

818

764

819 paras :: [Box.Box] -> Box.Box

765 paras :: [Box.Box] -> Box.Box

820 paras = Box.vcat Box.left

766 paras = Box.vcat Box.left

821

767

822− -- |

823 -- Pretty print and export declaration

768 -- Pretty print and export declaration

824− --

825 prettyPrintExport :: DeclarationRef -> String

769 prettyPrintExport :: DeclarationRef -> String

826 prettyPrintExport (TypeRef pn _) = runProperName pn

770 prettyPrintExport (TypeRef pn _) = runProperName pn

827 prettyPrintExport (ValueRef ident) = showIdent ident

771 prettyPrintExport (ValueRef ident) = showIdent ident

@@ -830,38 +774,44 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

830 prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name

774 prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name

831 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

775 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

832

776

833− -- |

777+ -- Hints get added at the front, so we need to reverse them before rendering

834− -- Simplify an error message

778+ reverseHints :: ErrorMessage -> ErrorMessage

835− --

779+ reverseHints (ErrorMessage hints simple) = ErrorMessage (reverse hints) simple

780+

781+ -- | Put positional hints at the front of the list

836− simplifyErrorMessage :: ErrorMessage -> ErrorMessage

782+ positionHintsFirst :: ErrorMessage -> ErrorMessage

837− simplifyErrorMessage = unwrap Nothing

783+ positionHintsFirst (ErrorMessage hints simple) = ErrorMessage (uncurry (++) $ partition (isPositionHint . hintCategory) hints) simple

838 where

784 where

839− unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

785+ isPositionHint :: HintCategory -> Bool

840− unwrap pos (ErrorInExpression _ err) = unwrap pos err

786+ isPositionHint PositionHint = True

841− unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)

787+ isPositionHint OtherHint = True

842− unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)

788+ isPositionHint _ = False

843− unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err

844− unwrap pos (ErrorInferringType _ err) = unwrap pos err

845− unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err

846− unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)

847− unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)

848− unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err

849− unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)

850− unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)

851− unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)

852− unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)

853− unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)

854− unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)

855− unwrap pos (ErrorInTypeDeclaration nm err) = ErrorInTypeDeclaration nm (unwrap pos err)

856− unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)

857− unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)

858− unwrap _ (PositionedError pos err) = unwrap (Just pos) err

859− unwrap pos other = wrap pos other

860−

861− wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

862− wrap Nothing = id

863− wrap (Just pos) = PositionedError pos

864

789

790+ -- | Simplify an error message

791+ simplifyErrorMessage :: ErrorMessage -> ErrorMessage

792+ simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple

793+ where

794+ -- Take the last instance of each "hint category"

795+ simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]

796+ simplifyHints = reverse . nubBy categoriesEqual . reverse

797+

798+ -- Don't remove hints in the "other" category

799+ categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool

800+ categoriesEqual x y =

801+ case (hintCategory x, hintCategory y) of

802+ (OtherHint, _) -> False

803+ (_, OtherHint) -> False

804+ (c1, c2) -> c1 == c2

805+

806+ hintCategory :: ErrorMessageHint -> HintCategory

807+ hintCategory ErrorCheckingType{} = ExprHint

808+ hintCategory ErrorInferringType{} = ExprHint

809+ hintCategory ErrorInExpression{} = ExprHint

810+ hintCategory ErrorUnifyingTypes{} = CheckHint

811+ hintCategory ErrorInSubsumption{} = CheckHint

812+ hintCategory ErrorInApplication{} = CheckHint

813+ hintCategory PositionedError{} = PositionHint

814+ hintCategory _ = OtherHint

865

815

866-- |

816-- |

867-- Pretty print multiple errors

817-- Pretty print multiple errors

@@ -988,8 +938,7 @@ warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter Multiple

988warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos

938warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos

989

939

990withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage

940withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage

991−withPosition _ (PositionedError pos err) = withPosition pos err

941+withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se

992−withPosition pos err = PositionedError pos err

993

942

994-- |

943-- |

995-- Collect errors in in parallel

944-- Collect errors in in parallel

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

@@ -40,7 +40,7 @@ import Language.PureScript.Linter.Exhaustive as L

40-- |

41-- | Right now, this pass only performs a shadowing check.

42lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()

43−lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds

43+lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds

44 where

45 moduleNames :: S.Set Ident

46 moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))

@@ -58,9 +58,9 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_

58 let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def

60 f' :: Declaration -> MultipleErrors

61− f' (PositionedDeclaration pos _ dec) = onErrorMessages (PositionedError pos) (f' dec)

61+ f' (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' dec)

62− f' dec@(ValueDeclaration name _ _ _) = onErrorMessages (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec)

62+ f' dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec)

63− f' (TypeDeclaration name ty) = onErrorMessages (ErrorInTypeDeclaration name) (checkTypeVars ty)

63+ f' (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)

64 f' dec = f dec <> checkTypeVarsInDecl dec

66 in tell (f' d)

src/Language/PureScript/Linter/Exhaustive.hs+3−3

@@ -281,8 +281,8 @@ checkExhaustiveDecls env mn ds =

281 where

282 convert :: (Ident, NameKind, Expr) -> Declaration

283 convert (name, nk, e) = ValueDeclaration name nk [] (Right e)

284− f' d@(ValueDeclaration name _ _ _) = censor (onErrorMessages (ErrorInValueDeclaration name)) $ f d

284+ f' d@(ValueDeclaration name _ _ _) = censor (addHint (ErrorInValueDeclaration name)) $ f d

285− f' (PositionedDeclaration pos com dec) = PositionedDeclaration pos com <$> censor (onErrorMessages (PositionedError pos)) (f' dec)

285+ f' (PositionedDeclaration pos com dec) = PositionedDeclaration pos com <$> censor (addHint (PositionedError pos)) (f' dec)

286 -- Don't generate two warnings for desugared dictionaries.

287 f' d@TypeInstanceDeclaration{} = return d

288 f' d = f d

@@ -297,4 +297,4 @@ checkExhaustiveDecls env mn ds =

297-- Exhaustivity checking over a single module

298--

299checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()

300−checkExhaustiveModule env (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds

300+checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds

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

@@ -305,15 +305,15 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

305 requiresForeign = not . null . CF.moduleForeign

306

307 getTimestamp :: FilePath -> Make (Maybe UTCTime)

308− getTimestamp path = makeIO (const (SimpleErrorWrapper $ CannotGetFileInfo path)) $ do

308+ getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do

309 exists <- doesFileExist path

310 traverse (const $ getModificationTime path) $ guard exists

311

312 readTextFile :: FilePath -> Make B.ByteString

313− readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ B.readFile path

313+ readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path

314

315 writeTextFile :: FilePath -> B.ByteString -> Make ()

316− writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do

316+ writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do

317 mkdirp path

318 B.writeFile path text

319 where

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

@@ -293,7 +293,7 @@ parseModulesFromFiles toFilePath input = do

293 collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]

294

295toPositionedError :: P.ParseError -> ErrorMessage

296−toPositionedError perr = PositionedError (SourceSpan name start end) (SimpleErrorWrapper (ErrorParsingModule perr))

296+toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr)

297 where

298 name = (P.sourceName . P.errorPos) perr

299 start = (toSourcePos . P.errorPos) perr

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

@@ -70,6 +70,7 @@ prettyPrintValue (Do els) =

70 text "do " <> vcat left (map prettyPrintDoNotationElement els)

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

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

73+prettyPrintValue (TypedValue _ val _) = prettyPrintValue val

73prettyPrintValue (PositionedValue _ _ val) = prettyPrintValue val

74prettyPrintValue (PositionedValue _ _ val) = prettyPrintValue val

74prettyPrintValue expr = prettyPrintValueAtom expr

75prettyPrintValue expr = prettyPrintValueAtom expr

@@ -88,7 +89,7 @@ prettyPrintValueAtom (Constructor name) = text $ runProperName (disqualify name)

88prettyPrintValueAtom (Var ident) = text $ showIdent (disqualify ident)

89prettyPrintValueAtom (Var ident) = text $ showIdent (disqualify ident)

89prettyPrintValueAtom (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue op) `beforeWithSpace` prettyPrintValue val) `before` text ")"

90prettyPrintValueAtom (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue op) `beforeWithSpace` prettyPrintValue val) `before` text ")"

90prettyPrintValueAtom (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue val) `beforeWithSpace` prettyPrintValue op) `before` text ")"

91prettyPrintValueAtom (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue val) `beforeWithSpace` prettyPrintValue op) `before` text ")"

91−prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValue val

92+prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValueAtom val

92prettyPrintValueAtom (PositionedValue _ _ val) = prettyPrintValueAtom val

93prettyPrintValueAtom (PositionedValue _ _ val) = prettyPrintValueAtom val

93prettyPrintValueAtom expr = (text "(" <> prettyPrintValue expr) `before` text ")"

94prettyPrintValueAtom expr = (text "(" <> prettyPrintValue expr) `before` text ")"

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

@@ -184,7 +184,7 @@ toBindingGroup moduleName (CyclicSCC ds') =

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

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

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

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

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

188 cycleError _ _ = error "Expected ValueDeclaration"

189

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

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

@@ -50,7 +50,7 @@ isLeft (Right _) = False

50--

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

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

53− rethrow (onErrorMessages (ErrorInModule name)) $

53+ rethrow (addHint (ErrorInModule name)) $

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

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

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

@@ -98,7 +98,7 @@ desugarImports externs modules = do

99 renameInModule' :: Env -> Module -> m Module

100 renameInModule' env m@(Module _ _ mn _ _) =

101− rethrow (onErrorMessages (ErrorInModule mn)) $ do

101+ rethrow (addHint (ErrorInModule mn)) $ do

102 let (_, imps, exps) = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn env

103 elaborateImports imps <$> renameInModule env imps (elaborateExports exps m)

104

src/Language/PureScript/Sugar/Names/Exports.hs+2−2

@@ -43,7 +43,7 @@ import Language.PureScript.Sugar.Names.Env

43--

44findExportable :: forall m. (Applicative m, MonadError MultipleErrors m) => Module -> m Exports

45findExportable (Module _ _ mn ds _) =

46− rethrow (onErrorMessages (ErrorInModule mn)) $ foldM updateExports nullExports ds

46+ rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds

47 where

48 updateExports :: Exports -> Declaration -> m Exports

49 updateExports exps (TypeClassDeclaration tcn _ _ ds') = do

@@ -67,7 +67,7 @@ findExportable (Module _ _ mn ds _) =

67--

68resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports

69resolveExports env mn imps exps refs =

70− rethrow (onErrorMessages (ErrorInModule mn)) $ do

70+ rethrow (addHint (ErrorInModule mn)) $ do

71 filtered <- filterModule mn exps refs

72 foldM elaborateModuleExports filtered refs

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

@@ -64,7 +64,7 @@ findImports = foldM (go Nothing) M.empty

64--

65resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports

66resolveImports env (Module _ _ currentModule decls _) =

67− censor (onErrorMessages (ErrorInModule currentModule)) $ do

67+ censor (addHint (ErrorInModule currentModule)) $ do

68 scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls

69 foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)

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

@@ -102,7 +102,7 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

102 go [] = return ()

103 go [_] = return ()

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

105− rethrow (onErrorMessages (ErrorInModule mn)) $

105+ rethrow (addHint (ErrorInModule mn)) $

106 rethrowWithPosition pos $

107 throwError . errorMessage $ MultipleFixities name

108 go (_ : rest) = go rest

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

@@ -243,7 +243,7 @@ unit = TypeApp tyObject REmpty

243

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

245typeInstanceDictionaryDeclaration name mn deps className tys decls =

246− rethrow (onErrorMessages (ErrorInInstance className tys)) $ do

246+ rethrow (addHint (ErrorInInstance className tys)) $ do

247 m <- get

248

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

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

@@ -39,7 +39,7 @@ import Language.PureScript.Traversals

39--

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

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

42− rethrow (onErrorMessages (ErrorInModule name)) $

42+ rethrow (addHint (ErrorInModule name)) $

43 Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps

45-- |

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

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

51 env <- getEnv

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

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

54− warnAndRethrow (onErrorMessages (ErrorInDataConstructor dctor)) $

54+ warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $

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

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

@@ -137,7 +137,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

137 where

138 go :: Declaration -> Check Declaration

139 go (DataDeclaration dtype name args dctors) = do

140− warnAndRethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do

140+ warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do

141 when (dtype == Newtype) $ checkNewtype dctors

142 checkDuplicateTypeArguments $ map fst args

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

@@ -150,7 +150,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

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

151 checkNewtype _ = throwError . errorMessage $ InvalidNewtype

152 go (d@(DataBindingGroupDeclaration tys)) = do

153− warnAndRethrow (onErrorMessages ErrorInDataBindingGroup) $ do

153+ warnAndRethrow (addHint ErrorInDataBindingGroup) $ do

154 let syns = mapMaybe toTypeSynonym tys

155 let dataDecls = mapMaybe toDataDecl tys

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

@@ -171,7 +171,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

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

172 toDataDecl _ = Nothing

173 go (TypeSynonymDeclaration name args ty) = do

174− warnAndRethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do

174+ warnAndRethrow (addHint (ErrorInTypeSynonym name)) $ do

175 checkDuplicateTypeArguments $ map fst args

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

177 let args' = args `withKinds` kind

@@ -179,14 +179,14 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

179 return $ TypeSynonymDeclaration name args ty

180 go (TypeDeclaration{}) = error "Type declarations should have been removed"

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

182− warnAndRethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do

182+ warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

183 valueIsNotDefined moduleName name

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

185 addValue moduleName name ty nameKind

186 return $ ValueDeclaration name nameKind [] $ Right val'

187 go (ValueDeclaration{}) = error "Binders were not desugared"

188 go (BindingGroupDeclaration vals) =

189− warnAndRethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

189+ warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

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

191 valueIsNotDefined moduleName name

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

@@ -203,7 +203,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

203 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }

204 return d

205 go (d@(ExternDeclaration name ty)) = do

206− warnAndRethrow (onErrorMessages (ErrorInForeignImport name)) $ do

206+ warnAndRethrow (addHint (ErrorInForeignImport name)) $ do

207 env <- getEnv

208 kind <- kindOf moduleName ty

209 guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star

@@ -269,7 +269,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

269--

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

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

272−typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRethrow (onErrorMessages (ErrorInModule mn)) $ do

272+typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

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

274 decls' <- typeCheckAll mainModuleName mn exps decls

275 forM_ exps $ \e -> do

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

@@ -83,7 +83,7 @@ kindOf _ ty = fst <$> kindOfWithScopedVars ty

83--

84kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])

85kindOfWithScopedVars ty =

86− rethrow (onErrorMessages (ErrorCheckingKind ty)) $

86+ rethrow (addHint (ErrorCheckingKind ty)) $

87 fmap tidyUp . liftUnify $ infer ty

88 where

89 tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k)

@@ -161,7 +161,7 @@ starIfUnknown k = k

161-- Infer a kind for a type

162--

163infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

164−infer ty = rethrow (onErrorMessages (ErrorCheckingKind ty)) $ infer' ty

164+infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty

165

166infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

167infer' (ForAll ident ty _) = do

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

@@ -92,7 +92,7 @@ skolemEscapeCheck root@TypedValue{} =

92 let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def

93 in case f root of

94 [] -> return ()

95− ((binding, val) : _) -> throwError . singleError $ ErrorInExpression val $ SimpleErrorWrapper $ EscapedSkolem binding

95+ ((binding, val) : _) -> throwError . singleError $ ErrorMessage [ ErrorInExpression val ] $ EscapedSkolem binding

96 where

97 def s _ = (s, [])

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

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

37-- Check whether one type subsumes another, rethrowing errors to provide a better error message

38--

39subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)

40−subsumes val ty1 ty2 = rethrow (onErrorMessages (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2

40+subsumes val ty1 ty2 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2

42-- |

43-- Check whether one type subsumes another

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

@@ -50,7 +50,7 @@ buildTypeSubstitution m = go 0 []

50 where

51 go :: Int -> [Type] -> Type -> Either ErrorMessage (Maybe Type)

52 go c args (TypeConstructor ctor) | M.lookup ctor m == Just c = return (Just $ SaturatedTypeSynonym ctor args)

53− go c _ (TypeConstructor ctor) | M.lookup ctor m > Just c = throwError $ SimpleErrorWrapper $ PartiallyAppliedSynonym ctor

53+ go c _ (TypeConstructor ctor) | M.lookup ctor m > Just c = throwError $ ErrorMessage [] $ PartiallyAppliedSynonym ctor

54 go c args (TypeApp f arg) = go (c + 1) (arg:args) f

55 go _ _ _ = return Nothing

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

@@ -103,7 +103,7 @@ typesOf mainModuleName moduleName vals = do

103 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

104 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

105 -- Replace all the wildcards types with their inferred types

106− replace sub (SimpleErrorWrapper (WildcardInferredType ty)) = SimpleErrorWrapper $ WildcardInferredType (sub $? ty)

106+ replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)

107 replace _ em = em

108 -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

109 checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do

@@ -214,7 +214,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)

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

215--

216infer :: Expr -> UnifyT Type Check Expr

217−infer val = rethrow (onErrorMessages (ErrorInferringType val)) $ infer' val

217+infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val

218

219-- |

220-- Infer a type for a value

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

457-- Check the type of a value, rethrowing errors to provide a better error message

458--

459check :: Expr -> Type -> UnifyT Type Check Expr

460−check val ty = rethrow (onErrorMessages (ErrorCheckingType val ty)) $ check' val ty

460+check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty

461

462-- |

463-- Check the type of a value

@@ -646,7 +646,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

646-- Check the type of a function application, rethrowing errors to provide a better error message

647--

648checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)

649−checkFunctionApplication fn fnTy arg ret = rethrow (onErrorMessages (ErrorInApplication fn fnTy arg)) $ do

649+checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication fn fnTy arg)) $ do

650 subst <- unifyCurrentSubstitution <$> UnifyT get

651 checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)

652

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

@@ -63,7 +63,7 @@ instance Unifiable Check Type where

63-- Unify two types, updating the current substitution

64--

65unifyTypes :: Type -> Type -> UnifyT Type Check ()

66−unifyTypes t1 t2 = rethrow (onErrorMessages (ErrorUnifyingTypes t1 t2)) $

66+unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $

67 unifyTypes' t1 t2

68 where

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