679c93c · rowtype-yoga/purescript-native

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

on golang help sign in

Merge master with feature branch

679c93cPhil Freeman11 years ago

.gitignore+1

compare with golang

unifiedsplit

@@ -15,3 +15,4 @@ node_modules

15tmp/

16.stack-work/

17tests/support/flattened/

18+output

INSTALL.md+12−2

@@ -24,15 +24,25 @@ requirements.

24## Compiling from source

26GHC 7.6.1 or newer is required to compile from source. The easiest way is to

27−use `cabal-install`:

27+use stack:

29```

30−$ cabal update && cabal install purescript

30+$ stack install purescript

31```

33+This will then copy the compiler and utilities into `~/.local/bin`.

34+

35+

36+If you don't have stack installed yet there are install instructions

37+[here](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md).

38+

39+If you don't have ghc installed yet, stack will prompt you to run `stack setup`

40+which will install ghc for you.

41+

33The PureScript compiler has been known to run on OS X 10.6 when built with GHC

42The PureScript compiler has been known to run on OS X 10.6 when built with GHC

347.6.

437.6.

45+

36## The "curses" library

46## The "curses" library

38`psci` depends on the `curses` library (via the Haskell package `terminfo`). If

48`psci` depends on the `curses` library (via the Haskell package `terminfo`). If

psci/PSCi.hs+2−2

@@ -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+327−333

@@ -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

@@ -143,45 +142,54 @@ data SimpleErrorMessage

143 | ShadowedTypeVar String

142 | ShadowedTypeVar String

144 | UnusedTypeVar String

143 | UnusedTypeVar String

145 | WildcardInferredType Type

144 | WildcardInferredType Type

145+ | MissingTypeDeclaration Ident

146 | NotExhaustivePattern [[Binder]] Bool

147 | OverlappingPattern [[Binder]] Bool

148 | IncompleteExhaustivityCheck

149 | ClassOperator ProperName Ident

150 | MisleadingEmptyTypeImport ModuleName ProperName

151 | ImportHidingModule ModuleName

152− deriving (Show)

152+ deriving Show

153−

153+

154−-- |

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

155−-- Wrapper of simpler errors

155+data ErrorMessageHint

156−--

157−data ErrorMessage

158− = NotYetDefined [Ident] ErrorMessage

156+ = NotYetDefined [Ident]

159− | ErrorUnifyingTypes Type Type ErrorMessage

157+ | ErrorUnifyingTypes Type Type

160− | ErrorInExpression Expr ErrorMessage

158+ | ErrorInExpression Expr

161− | ErrorInModule ModuleName ErrorMessage

159+ | ErrorInModule ModuleName

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

160+ | ErrorInInstance (Qualified ProperName) [Type]

163− | ErrorInSubsumption Type Type ErrorMessage

161+ | ErrorInSubsumption Type Type

164− | ErrorCheckingType Expr Type ErrorMessage

162+ | ErrorCheckingType Expr Type

165− | ErrorCheckingKind Type ErrorMessage

163+ | ErrorCheckingKind Type

166− | ErrorInferringType Expr ErrorMessage

164+ | ErrorInferringType Expr

167− | ErrorInApplication Expr Type Expr ErrorMessage

165+ | ErrorInApplication Expr Type Expr

168− | ErrorInDataConstructor ProperName ErrorMessage

166+ | ErrorInDataConstructor ProperName

169− | ErrorInTypeConstructor ProperName ErrorMessage

167+ | ErrorInTypeConstructor ProperName

170− | ErrorInBindingGroup [Ident] ErrorMessage

168+ | ErrorInBindingGroup [Ident]

171− | ErrorInDataBindingGroup ErrorMessage

169+ | ErrorInDataBindingGroup

172− | ErrorInTypeSynonym ProperName ErrorMessage

170+ | ErrorInTypeSynonym ProperName

173− | ErrorInValueDeclaration Ident ErrorMessage

171+ | ErrorInValueDeclaration Ident

174− | ErrorInTypeDeclaration Ident ErrorMessage

172+ | ErrorInTypeDeclaration Ident

175− | ErrorInForeignImport Ident ErrorMessage

173+ | ErrorInForeignImport Ident

176− | PositionedError SourceSpan ErrorMessage

174+ | PositionedError SourceSpan

177− | SimpleErrorWrapper SimpleErrorMessage

175+ deriving Show

178− deriving (Show)

176+

177+-- | Categories of hints

178+data HintCategory

179+ = ExprHint

180+ | KindHint

181+ | CheckHint

182+ | PositionHint

183+ | OtherHint

184+ deriving (Show, Eq)

185+

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

179

187

180instance UnificationError Type ErrorMessage where

188instance UnificationError Type ErrorMessage where

181− occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t

189+ occursCheckFailed t = ErrorMessage [] $ InfiniteType t

182

190

183instance UnificationError Kind ErrorMessage where

191instance UnificationError Kind ErrorMessage where

184− occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k

192+ occursCheckFailed k = ErrorMessage [] $ InfiniteKind k

185

193

186-- |

194-- |

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

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

@@ -274,6 +282,7 @@ errorCode em = case unwrapErrorMessage em of

274 ShadowedTypeVar{} -> "ShadowedTypeVar"

282 ShadowedTypeVar{} -> "ShadowedTypeVar"

275 UnusedTypeVar{} -> "UnusedTypeVar"

283 UnusedTypeVar{} -> "UnusedTypeVar"

276 WildcardInferredType{} -> "WildcardInferredType"

284 WildcardInferredType{} -> "WildcardInferredType"

285+ MissingTypeDeclaration{} -> "MissingTypeDeclaration"

277 NotExhaustivePattern{} -> "NotExhaustivePattern"

286 NotExhaustivePattern{} -> "NotExhaustivePattern"

278 OverlappingPattern{} -> "OverlappingPattern"

287 OverlappingPattern{} -> "OverlappingPattern"

279 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"

288 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"

@@ -301,7 +310,7 @@ nonEmpty = not . null . runMultipleErrors

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

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

302--

311--

303errorMessage :: SimpleErrorMessage -> MultipleErrors

312errorMessage :: SimpleErrorMessage -> MultipleErrors

304−errorMessage err = MultipleErrors [SimpleErrorWrapper err]

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

305

314

306

315

307-- |

316-- |

@@ -310,12 +319,14 @@ errorMessage err = MultipleErrors [SimpleErrorWrapper err]

310singleError :: ErrorMessage -> MultipleErrors

319singleError :: ErrorMessage -> MultipleErrors

311singleError = MultipleErrors . pure

320singleError = MultipleErrors . pure

312

321

313−-- |

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

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

315−--

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

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

317onErrorMessages f = MultipleErrors . map f . runMultipleErrors

324onErrorMessages f = MultipleErrors . map f . runMultipleErrors

318

325

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

327+addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors

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

329+

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

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

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

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

321

332

@@ -329,27 +340,7 @@ data Level = Error | Warning deriving Show

329-- Extract nested error messages from wrapper errors

340-- Extract nested error messages from wrapper errors

330--

341--

331unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage

342unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage

332−unwrapErrorMessage em = case em of

343+unwrapErrorMessage (ErrorMessage _ se) = se

333− (ErrorCheckingKind _ err) -> unwrapErrorMessage err

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

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

336− (ErrorInBindingGroup _ err) -> unwrapErrorMessage err

337− (ErrorInDataBindingGroup err) -> unwrapErrorMessage err

338− (ErrorInDataConstructor _ err) -> unwrapErrorMessage err

339− (ErrorInExpression _ err) -> unwrapErrorMessage err

340− (ErrorInForeignImport _ err) -> unwrapErrorMessage err

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

342− (ErrorInModule _ err) -> unwrapErrorMessage err

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

344− (ErrorInTypeConstructor _ err) -> unwrapErrorMessage err

345− (ErrorInTypeSynonym _ err) -> unwrapErrorMessage err

346− (ErrorInValueDeclaration _ err) -> unwrapErrorMessage err

347− (ErrorInTypeDeclaration _ err) -> unwrapErrorMessage err

348− (ErrorInferringType _ err) -> unwrapErrorMessage err

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

350− (NotYetDefined _ err) -> unwrapErrorMessage err

351− (PositionedError _ err) -> unwrapErrorMessage err

352− (SimpleErrorWrapper sem) -> sem

353

344

354replaceUnknowns :: Type -> State UnknownMap Type

345replaceUnknowns :: Type -> State UnknownMap Type

355replaceUnknowns = everywhereOnTypesM replaceTypes

346replaceUnknowns = everywhereOnTypesM replaceTypes

@@ -365,7 +356,7 @@ replaceUnknowns = everywhereOnTypesM replaceTypes

365 replaceTypes other = return other

356 replaceTypes other = return other

366

357

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

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

368−onTypesInErrorMessageM f = g

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

369 where

360 where

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

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

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

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

@@ -375,396 +366,396 @@ onTypesInErrorMessageM f = g

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

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

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

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

377 gSimple other = pure other

368 gSimple other = pure other

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

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

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

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

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

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

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

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

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

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

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

374+ gHint other = pure other

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

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

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

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

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

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

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

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

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

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

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

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

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

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

398

375

399-- |

376-- |

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

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

401--

378--

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

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

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

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

404 where

381 where

405− -- |

382+

406 -- Pretty print an ErrorMessage

383 -- Pretty print an ErrorMessage

407− --

408 prettyPrintErrorMessage :: ErrorMessage -> Box.Box

384 prettyPrintErrorMessage :: ErrorMessage -> Box.Box

409− prettyPrintErrorMessage em =

385+ prettyPrintErrorMessage (ErrorMessage hints simple) =

410 paras $

386 paras $

387+ map renderHint hints ++

388+ renderSimpleErrorMessage simple :

411− go em:suggestions em ++

389+ suggestions simple ++

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

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

413 where

391 where

414 wikiUri :: String

392 wikiUri :: String

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

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

416

394

417− go :: ErrorMessage -> Box.Box

395+ renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

418− goSimple (CannotGetFileInfo path) =

396+ renderSimpleErrorMessage (CannotGetFileInfo path) =

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

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

420 , indent . line $ path

398 , indent . line $ path

421 ]

399 ]

422− goSimple (CannotReadFile path) =

400+ renderSimpleErrorMessage (CannotReadFile path) =

423 paras [ line "Unable to read file: "

401 paras [ line "Unable to read file: "

424 , indent . line $ path

402 , indent . line $ path

425 ]

403 ]

426− goSimple (CannotWriteFile path) =

404+ renderSimpleErrorMessage (CannotWriteFile path) =

427 paras [ line "Unable to write file: "

405 paras [ line "Unable to write file: "

428 , indent . line $ path

406 , indent . line $ path

429 ]

407 ]

430− goSimple (ErrorParsingExterns err) =

408+ renderSimpleErrorMessage (ErrorParsingExterns err) =

431 paras [ lineWithLevel "parsing externs files: "

409 paras [ lineWithLevel "parsing externs files: "

432− , indent . prettyPrintParseError $ err

410+ , prettyPrintParseError err

433 ]

411 ]

434− goSimple (ErrorParsingFFIModule path) =

412+ renderSimpleErrorMessage (ErrorParsingFFIModule path) =

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

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

436 , indent . line $ path

414 , indent . line $ path

437 ]

415 ]

438− goSimple (ErrorParsingModule err) =

416+ renderSimpleErrorMessage (ErrorParsingModule err) =

439 paras [ line "Unable to parse module: "

417 paras [ line "Unable to parse module: "

440− , indent . prettyPrintParseError $ err

418+ , prettyPrintParseError err

441 ]

419 ]

442− goSimple (MissingFFIModule mn) =

420+ renderSimpleErrorMessage (MissingFFIModule mn) =

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

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

444− goSimple (UnnecessaryFFIModule mn path) =

422+ renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =

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

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

446 , indent . line $ path

424 , indent . line $ path

447 ]

425 ]

448− goSimple (MultipleFFIModules mn paths) =

426+ renderSimpleErrorMessage (MultipleFFIModules mn paths) =

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

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

450− ++ map (indent . line) paths

428+ , indent . paras $ map line paths

429+ ]

451− goSimple (InvalidExternsFile path) =

430+ renderSimpleErrorMessage (InvalidExternsFile path) =

452 paras [ line "Externs file is invalid: "

431 paras [ line "Externs file is invalid: "

453 , indent . line $ path

432 , indent . line $ path

454 ]

433 ]

455− goSimple InvalidDoBind =

434+ renderSimpleErrorMessage InvalidDoBind =

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

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

457− goSimple InvalidDoLet =

436+ renderSimpleErrorMessage InvalidDoLet =

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

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

459− goSimple CannotReorderOperators =

438+ renderSimpleErrorMessage CannotReorderOperators =

460 line "Unable to reorder operators"

439 line "Unable to reorder operators"

461− goSimple UnspecifiedSkolemScope =

440+ renderSimpleErrorMessage UnspecifiedSkolemScope =

462 line "Skolem variable scope is unspecified"

441 line "Skolem variable scope is unspecified"

463− goSimple OverlappingNamesInLet =

442+ renderSimpleErrorMessage OverlappingNamesInLet =

464 line "Overlapping names in let binding."

443 line "Overlapping names in let binding."

465− goSimple (InfiniteType ty) =

444+ renderSimpleErrorMessage (InfiniteType ty) =

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

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

467− , indent $ line $ prettyPrintType ty

446+ , indent $ typeAsBox ty

468 ]

447 ]

469− goSimple (InfiniteKind ki) =

448+ renderSimpleErrorMessage (InfiniteKind ki) =

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

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

471− , indent $ line $ prettyPrintKind ki

450+ , indent $ kindAsBox ki

472 ]

451 ]

473− goSimple (MultipleFixities name) =

452+ renderSimpleErrorMessage (MultipleFixities name) =

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

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

475− goSimple (OrphanTypeDeclaration nm) =

454+ renderSimpleErrorMessage (OrphanTypeDeclaration nm) =

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

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

477− goSimple (OrphanFixityDeclaration op) =

456+ renderSimpleErrorMessage (OrphanFixityDeclaration op) =

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

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

479− goSimple (RedefinedModule name filenames) =

458+ renderSimpleErrorMessage (RedefinedModule name filenames) =

480− paras $ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")

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

481− : map (indent . line . displaySourceSpan) filenames

460+ , indent . paras $ map (line . displaySourceSpan) filenames

461+ ]

482− goSimple (RedefinedIdent name) =

462+ renderSimpleErrorMessage (RedefinedIdent name) =

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

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

484− goSimple (UnknownModule mn) =

464+ renderSimpleErrorMessage (UnknownModule mn) =

485 line $ "Unknown module " ++ runModuleName mn

465 line $ "Unknown module " ++ runModuleName mn

486− goSimple (UnknownType name) =

466+ renderSimpleErrorMessage (UnknownType name) =

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

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

488− goSimple (UnknownTypeClass name) =

468+ renderSimpleErrorMessage (UnknownTypeClass name) =

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

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

490− goSimple (UnknownValue name) =

470+ renderSimpleErrorMessage (UnknownValue name) =

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

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

492− goSimple (UnknownTypeConstructor name) =

472+ renderSimpleErrorMessage (UnknownTypeConstructor name) =

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

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

494− goSimple (UnknownDataConstructor dc tc) =

474+ renderSimpleErrorMessage (UnknownDataConstructor dc tc) =

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

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

496− goSimple (UnknownImportType mn name) =

476+ renderSimpleErrorMessage (UnknownImportType mn name) =

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

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

498− goSimple (UnknownExportType name) =

478+ renderSimpleErrorMessage (UnknownExportType name) =

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

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

500− goSimple (UnknownImportTypeClass mn name) =

480+ renderSimpleErrorMessage (UnknownImportTypeClass mn name) =

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

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

502− goSimple (UnknownExportTypeClass name) =

482+ renderSimpleErrorMessage (UnknownExportTypeClass name) =

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

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

504− goSimple (UnknownImportValue mn name) =

484+ renderSimpleErrorMessage (UnknownImportValue mn name) =

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

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

506− goSimple (UnknownExportValue name) =

486+ renderSimpleErrorMessage (UnknownExportValue name) =

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

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

508− goSimple (UnknownExportModule name) =

488+ 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"

489 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) =

490+ renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =

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

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

512− goSimple (UnknownExportDataConstructor tcon dcon) =

492+ renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

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

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

514− goSimple (ConflictingImport nm mn) =

494+ renderSimpleErrorMessage (ConflictingImport nm mn) =

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

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

516− goSimple (ConflictingImports nm m1 m2) =

496+ renderSimpleErrorMessage (ConflictingImports nm m1 m2) =

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

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

518− goSimple (ConflictingTypeDecls nm) =

498+ renderSimpleErrorMessage (ConflictingTypeDecls nm) =

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

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

520− goSimple (ConflictingCtorDecls nm) =

500+ renderSimpleErrorMessage (ConflictingCtorDecls nm) =

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

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

522− goSimple (TypeConflictsWithClass nm) =

502+ renderSimpleErrorMessage (TypeConflictsWithClass nm) =

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

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

524− goSimple (CtorConflictsWithClass nm) =

504+ renderSimpleErrorMessage (CtorConflictsWithClass nm) =

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

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

526− goSimple (ClassConflictsWithType nm) =

506+ renderSimpleErrorMessage (ClassConflictsWithType nm) =

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

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

528− goSimple (ClassConflictsWithCtor nm) =

508+ renderSimpleErrorMessage (ClassConflictsWithCtor nm) =

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

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

530− goSimple (DuplicateModuleName mn) =

510+ renderSimpleErrorMessage (DuplicateModuleName mn) =

531 line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."

511 line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."

532− goSimple (DuplicateClassExport nm) =

512+ renderSimpleErrorMessage (DuplicateClassExport nm) =

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

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

534− goSimple (DuplicateValueExport nm) =

514+ renderSimpleErrorMessage (DuplicateValueExport nm) =

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

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

536− goSimple (CycleInDeclaration nm) =

516+ renderSimpleErrorMessage (CycleInDeclaration nm) =

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

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

538− goSimple (CycleInModules mns) =

518+ renderSimpleErrorMessage (CycleInModules mns) =

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

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

540− goSimple (CycleInTypeSynonym pn) =

520+ renderSimpleErrorMessage (CycleInTypeSynonym pn) =

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

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

542− goSimple (NameIsUndefined ident) =

522+ renderSimpleErrorMessage (NameIsUndefined ident) =

543 line $ showIdent ident ++ " is undefined"

523 line $ showIdent ident ++ " is undefined"

544− goSimple (NameNotInScope ident) =

524+ renderSimpleErrorMessage (NameNotInScope ident) =

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

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

546− goSimple (UndefinedTypeVariable name) =

526+ renderSimpleErrorMessage (UndefinedTypeVariable name) =

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

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

548− goSimple (PartiallyAppliedSynonym name) =

528+ renderSimpleErrorMessage (PartiallyAppliedSynonym name) =

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

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

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

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

551 ]

531 ]

552− goSimple (EscapedSkolem binding) =

532+ renderSimpleErrorMessage (EscapedSkolem binding) =

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

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

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

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

555− , indent $ line $ prettyPrintValue expr

535+ , indent $ prettyPrintValue expr

556 ]) binding

536 ]) binding

557− goSimple (TypesDoNotUnify t1 t2)

537+ renderSimpleErrorMessage (TypesDoNotUnify t1 t2)

558 = paras [ line "Cannot unify type"

538 = paras [ line "Cannot unify type"

559− , indent $ line $ prettyPrintType t1

539+ , indent $ typeAsBox t1

560 , line "with type"

540 , line "with type"

561− , indent $ line $ prettyPrintType t2

541+ , indent $ typeAsBox t2

562 ]

542 ]

563− goSimple (KindsDoNotUnify k1 k2) =

543+ renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =

564 paras [ line "Cannot unify kind"

544 paras [ line "Cannot unify kind"

565− , indent $ line $ prettyPrintKind k1

545+ , indent $ kindAsBox k1

566 , line "with kind"

546 , line "with kind"

567− , indent $ line $ prettyPrintKind k2

547+ , indent $ kindAsBox k2

568 ]

548 ]

569− goSimple (ConstrainedTypeUnified t1 t2) =

549+ renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =

570 paras [ line "Cannot unify constrained type"

550 paras [ line "Cannot unify constrained type"

571− , indent $ line $ prettyPrintType t1

551+ , indent $ typeAsBox t1

572 , line "with type"

552 , line "with type"

573− , indent $ line $ prettyPrintType t2

553+ , indent $ typeAsBox t2

574− ]

554+ ]

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

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

576− paras [ line $ "Overlapping instances found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"

556+ paras [ line "Overlapping instances found for"

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

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

559+ ]

560+ , line "The following instances were found:"

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

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

578 ]

562 ]

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

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

580− goSimple (NoInstanceFound nm ts) =

564+ renderSimpleErrorMessage (NoInstanceFound nm ts) =

581− line $ "No instance found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)

565+ paras [ line "No instance found for"

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

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

568+ ]

569+ ]

582− goSimple (PossiblyInfiniteInstance nm ts) =

570+ renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =

583− line $ "Instance for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is possibly infinite."

571+ paras [ line "Instance for"

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

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

574+ ]

575+ , line "is possibly infinite."

576+ ]

584− goSimple (CannotDerive nm ts) =

577+ renderSimpleErrorMessage (CannotDerive nm ts) =

585− line $ "Cannot derive " ++ showQualified runProperName nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts)

578+ paras [ line "Cannot derive an instance for"

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

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

581+ ]

582+ ]

586− goSimple (CannotFindDerivingType nm) =

583+ renderSimpleErrorMessage (CannotFindDerivingType nm) =

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

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

588− goSimple (DuplicateLabel l expr) =

585+ renderSimpleErrorMessage (DuplicateLabel l expr) =

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

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

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

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

591− , indent $ line $ prettyPrintValue expr'

588+ , indent $ prettyPrintValue expr'

592 ]) expr

589 ]) expr

593− goSimple (DuplicateTypeArgument name) =

590+ renderSimpleErrorMessage (DuplicateTypeArgument name) =

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

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

595− goSimple (DuplicateValueDeclaration nm) =

592+ renderSimpleErrorMessage (DuplicateValueDeclaration nm) =

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

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

597− goSimple (ArgListLengthsDiffer ident) =

594+ renderSimpleErrorMessage (ArgListLengthsDiffer ident) =

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

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

599− goSimple (OverlappingArgNames ident) =

596+ renderSimpleErrorMessage (OverlappingArgNames ident) =

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

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

601− goSimple (MissingClassMember ident) =

598+ renderSimpleErrorMessage (MissingClassMember ident) =

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

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

603− goSimple (ExtraneousClassMember ident) =

600+ renderSimpleErrorMessage (ExtraneousClassMember ident) =

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

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

605− goSimple (ExpectedType ty kind) =

602+ renderSimpleErrorMessage (ExpectedType ty kind) =

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

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

607− , line $ "The error arises from the type " ++ prettyPrintType ty ++ " having the kind " ++ prettyPrintKind kind ++ " instead."

604+ , line "The error arises from the type"

605+ , indent $ typeAsBox ty

606+ , line "having the kind"

607+ , indent $ kindAsBox kind

608+ , line "instead."

608 ]

609 ]

609− goSimple (IncorrectConstructorArity nm) =

610+ renderSimpleErrorMessage (IncorrectConstructorArity nm) =

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

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

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

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

612− goSimple (ExprDoesNotHaveType expr ty) =

613+ renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =

613 paras [ line "Expression"

614 paras [ line "Expression"

614− , indent $ line $ prettyPrintValue expr

615+ , indent $ prettyPrintValue expr

615 , line "does not have type"

616 , line "does not have type"

616− , indent $ line $ prettyPrintType ty

617+ , indent $ typeAsBox ty

617 ]

618 ]

618− goSimple (PropertyIsMissing prop row) =

619+ renderSimpleErrorMessage (PropertyIsMissing prop row) =

620+ paras [ line "Row"

621+ , indent $ prettyPrintRowWith '(' ')' row

619− line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop

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

623+ ]

620− goSimple (CannotApplyFunction fn arg) =

624+ renderSimpleErrorMessage (CannotApplyFunction fn arg) =

621 paras [ line "Cannot apply function of type"

625 paras [ line "Cannot apply function of type"

622− , indent $ line $ prettyPrintType fn

626+ , indent $ typeAsBox fn

623 , line "to argument"

627 , line "to argument"

624− , indent $ line $ prettyPrintValue arg

628+ , indent $ prettyPrintValue arg

625 ]

629 ]

626− goSimple TypeSynonymInstance =

630+ renderSimpleErrorMessage TypeSynonymInstance =

627 line "Type synonym instances are disallowed"

631 line "Type synonym instances are disallowed"

628− goSimple (OrphanInstance nm cnm ts) =

632+ renderSimpleErrorMessage (OrphanInstance nm cnm ts) =

629− paras [ line $ "Instance " ++ showIdent nm ++ " for " ++ showQualified runProperName cnm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is an orphan instance."

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

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

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

636+ ]

637+ , line "is an orphan instance."

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

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

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

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

632 ]

640 ]

633− goSimple InvalidNewtype =

641+ renderSimpleErrorMessage InvalidNewtype =

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

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

635− goSimple (InvalidInstanceHead ty) =

643+ renderSimpleErrorMessage (InvalidInstanceHead ty) =

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

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

637− , indent $ line $ prettyPrintType ty

645+ , indent $ typeAsBox ty

638 ]

646 ]

639− goSimple (TransitiveExportError x ys) =

647+ renderSimpleErrorMessage (TransitiveExportError x ys) =

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

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

641 : map (line . prettyPrintExport) ys

649 : map (line . prettyPrintExport) ys

642− goSimple (ShadowedName nm) =

650+ renderSimpleErrorMessage (ShadowedName nm) =

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

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

644− goSimple (ShadowedTypeVar tv) =

652+ renderSimpleErrorMessage (ShadowedTypeVar tv) =

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

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

646− goSimple (UnusedTypeVar tv) =

654+ renderSimpleErrorMessage (UnusedTypeVar tv) =

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

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

648− goSimple (ClassOperator className opName) =

656+ renderSimpleErrorMessage (ClassOperator className opName) =

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

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

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

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

651− , indent $ line $ showIdent opName ++ " = someMember"

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

652 ]

660 ]

653− goSimple (MisleadingEmptyTypeImport mn name) =

661+ renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

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

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

655− goSimple (ImportHidingModule name) =

663+ renderSimpleErrorMessage (ImportHidingModule name) =

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

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

657− goSimple (WildcardInferredType ty) =

665+ renderSimpleErrorMessage (WildcardInferredType ty) =

658− line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty

666+ paras [ line "The wildcard type definition has the inferred type "

667+ , indent $ typeAsBox ty

668+ ]

669+ renderSimpleErrorMessage (MissingTypeDeclaration ident) =

670+ paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."

671+ , line "It is good practice to provide type declarations as a form of documentation."

672+ , line "Consider using a type wildcard to display the inferred type:"

673+ , indent $ line $ showIdent ident ++ " :: _"

674+ ]

659− goSimple (NotExhaustivePattern bs b) =

675+ renderSimpleErrorMessage (NotExhaustivePattern bs b) =

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

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

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

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

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

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

663 ] ++

679 ] ++

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

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

665− goSimple (OverlappingPattern bs b) =

681+ renderSimpleErrorMessage (OverlappingPattern bs b) =

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

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

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

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

668 ] ++

684 ] ++

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

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

670− goSimple IncompleteExhaustivityCheck =

686+ renderSimpleErrorMessage IncompleteExhaustivityCheck =

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

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

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

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

673 ]

689 ]

690+

691+ renderHint :: ErrorMessageHint -> Box.Box

674− go (NotYetDefined names err) =

692+ renderHint (NotYetDefined names) =

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

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

676− , indent $ go err

677− ]

678− go (ErrorUnifyingTypes t1 t2 err) =

694+ renderHint (ErrorUnifyingTypes t1 t2) =

679 paras [ lineWithLevel "unifying type "

695 paras [ lineWithLevel "unifying type "

680− , indent $ line $ prettyPrintType t1

696+ , indent $ typeAsBox t1

681 , line "with type"

697 , line "with type"

682− , indent $ line $ prettyPrintType t2

698+ , indent $ typeAsBox t2

683− , go err

684 ]

699 ]

685− go (ErrorInExpression expr err) =

700+ renderHint (ErrorInExpression expr) =

686 paras [ lineWithLevel "in expression:"

701 paras [ lineWithLevel "in expression:"

687− , indent $ line $ prettyPrintValue expr

702+ , indent $ prettyPrintValue expr

688− , go err

689 ]

703 ]

690− go (ErrorInModule mn err) =

704+ renderHint (ErrorInModule mn) =

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

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

692− , go err

693 ]

706 ]

694− go (ErrorInSubsumption t1 t2 err) =

707+ renderHint (ErrorInSubsumption t1 t2) =

695 paras [ lineWithLevel "checking that type "

708 paras [ lineWithLevel "checking that type "

696− , indent $ line $ prettyPrintType t1

709+ , indent $ typeAsBox t1

697 , line "subsumes type"

710 , line "subsumes type"

698− , indent $ line $ prettyPrintType t2

711+ , indent $ typeAsBox t2

699− , go err

700 ]

712 ]

701− go (ErrorInInstance name ts err) =

713+ renderHint (ErrorInInstance nm ts) =

702− paras [ lineWithLevel $ "in type class instance " ++ showQualified runProperName name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"

714+ paras [ lineWithLevel "in type class instance"

703− , go err

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

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

717+ ]

704 ]

718 ]

705− go (ErrorCheckingKind ty err) =

719+ renderHint (ErrorCheckingKind ty) =

706 paras [ lineWithLevel "checking kind of type "

720 paras [ lineWithLevel "checking kind of type "

707− , indent $ line $ prettyPrintType ty

721+ , indent $ typeAsBox ty

708− , go err

709 ]

722 ]

710− go (ErrorInferringType expr err) =

723+ renderHint (ErrorInferringType expr) =

711 paras [ lineWithLevel "inferring type of value "

724 paras [ lineWithLevel "inferring type of value "

712− , indent $ line $ prettyPrintValue expr

725+ , indent $ prettyPrintValue expr

713− , go err

714 ]

726 ]

715− go (ErrorCheckingType expr ty err) =

727+ renderHint (ErrorCheckingType expr ty) =

716 paras [ lineWithLevel "checking that value "

728 paras [ lineWithLevel "checking that value "

717− , indent $ line $ prettyPrintValue expr

729+ , indent $ prettyPrintValue expr

718 , line "has type"

730 , line "has type"

719− , indent $ line $ prettyPrintType ty

731+ , indent $ typeAsBox ty

720− , go err

721 ]

732 ]

722− go (ErrorInApplication f t a err) =

733+ renderHint (ErrorInApplication f t a) =

723 paras [ lineWithLevel "applying function"

734 paras [ lineWithLevel "applying function"

724− , indent $ line $ prettyPrintValue f

735+ , indent $ prettyPrintValue f

725 , line "of type"

736 , line "of type"

726− , indent $ line $ prettyPrintType t

737+ , indent $ typeAsBox t

727 , line "to argument"

738 , line "to argument"

728− , indent $ line $ prettyPrintValue a

739+ , indent $ prettyPrintValue a

729− , go err

730− ]

740+ ]

731− go (ErrorInDataConstructor nm err) =

741+ renderHint (ErrorInDataConstructor nm) =

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

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

733− , go err

734− ]

735− go (ErrorInTypeConstructor nm err) =

743+ renderHint (ErrorInTypeConstructor nm) =

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

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

737− , go err

738− ]

739− go (ErrorInBindingGroup nms err) =

745+ renderHint (ErrorInBindingGroup nms) =

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

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

741− , go err

742− ]

743− go (ErrorInDataBindingGroup err) =

747+ renderHint ErrorInDataBindingGroup =

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

748+ lineWithLevel "in data binding group:"

745− , go err

746− ]

747− go (ErrorInTypeSynonym name err) =

749+ renderHint (ErrorInTypeSynonym name) =

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

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

749− , go err

750− ]

751− go (ErrorInValueDeclaration n err) =

751+ renderHint (ErrorInValueDeclaration n) =

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

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

753− , go err

754− ]

755− go (ErrorInTypeDeclaration n err) =

753+ renderHint (ErrorInTypeDeclaration n) =

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

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

757− , go err

758− ]

759− go (ErrorInForeignImport nm err) =

755+ renderHint (ErrorInForeignImport nm) =

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

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

761− , go err

762− ]

763− go (PositionedError srcSpan err) =

757+ renderHint (PositionedError srcSpan) =

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

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

765− , indent $ go err

766− ]

767− go (SimpleErrorWrapper sem) = goSimple sem

768

759

769 lineWithLevel :: String -> Box.Box

760 lineWithLevel :: String -> Box.Box

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

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

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

774 Error -> "error"

765 Error -> "error"

775 Warning -> "warning"

766 Warning -> "warning"

776

767

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

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

778− suggestions = suggestions' . unwrapErrorMessage

779− where

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

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

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

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

782 ]

771 ]

783− suggestions' (TypesDoNotUnify t1 t2)

772+ suggestions (TypesDoNotUnify t1 t2)

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

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

785− | otherwise = []

774+ | otherwise = []

786− suggestions' _ = []

775+ suggestions _ = []

787

776

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

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

789 paras = Box.vcat Box.left

778 paras = Box.vcat Box.left

790

779

791− -- |

792 -- Pretty print and export declaration

780 -- Pretty print and export declaration

793− --

794 prettyPrintExport :: DeclarationRef -> String

781 prettyPrintExport :: DeclarationRef -> String

795 prettyPrintExport (TypeRef pn _) = runProperName pn

782 prettyPrintExport (TypeRef pn _) = runProperName pn

796 prettyPrintExport (ValueRef ident) = showIdent ident

783 prettyPrintExport (ValueRef ident) = showIdent ident

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

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

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

800 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

787 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

801

788

802− -- |

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

803− -- Simplify an error message

790+ reverseHints :: ErrorMessage -> ErrorMessage

804− --

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

792+

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

805− simplifyErrorMessage :: ErrorMessage -> ErrorMessage

794+ positionHintsFirst :: ErrorMessage -> ErrorMessage

806− simplifyErrorMessage = unwrap Nothing

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

807 where

796 where

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

797+ isPositionHint :: HintCategory -> Bool

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

798+ isPositionHint PositionHint = True

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

799+ isPositionHint OtherHint = True

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

800+ isPositionHint _ = False

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

828− unwrap pos other = wrap pos other

829−

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

831− wrap Nothing = id

832− wrap (Just pos) = PositionedError pos

833

801

802+ -- | Simplify an error message

803+ simplifyErrorMessage :: ErrorMessage -> ErrorMessage

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

805+ where

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

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

808+ simplifyHints = reverse . nubBy categoriesEqual . reverse

809+

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

811+ categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool

812+ categoriesEqual x y =

813+ case (hintCategory x, hintCategory y) of

814+ (OtherHint, _) -> False

815+ (_, OtherHint) -> False

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

817+

818+ hintCategory :: ErrorMessageHint -> HintCategory

819+ hintCategory ErrorCheckingType{} = ExprHint

820+ hintCategory ErrorInferringType{} = ExprHint

821+ hintCategory ErrorInExpression{} = ExprHint

822+ hintCategory ErrorUnifyingTypes{} = CheckHint

823+ hintCategory ErrorInSubsumption{} = CheckHint

824+ hintCategory ErrorInApplication{} = CheckHint

825+ hintCategory PositionedError{} = PositionHint

826+ hintCategory _ = OtherHint

834

827

835-- |

828-- |

836-- Pretty print multiple errors

829-- Pretty print multiple errors

@@ -846,11 +839,11 @@ prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox fu

846

839

847-- | Pretty print warnings as a Box

840-- | Pretty print warnings as a Box

848prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box

841prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box

849−prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Multiple warnings found:" full

842+prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full

850

843

851-- | Pretty print errors as a Box

844-- | Pretty print errors as a Box

852prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box

845prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box

853−prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Multiple errors found:" full

846+prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full

854

847

855prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box

848prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box

856prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do

849prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do

@@ -860,11 +853,12 @@ prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do

860 , result

853 , result

861 ]

854 ]

862prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do

855prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do

863− result <- forM es $ liftM (Box.moveRight 2) . prettyPrintSingleError full level

856+ result <- forM es $ prettyPrintSingleError full level

864− return $

857+ return $ Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result

865− Box.vcat Box.left [ Box.text intro

858+ where

866− , Box.vsep 1 Box.left result

859+ withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")

860+ , Box.moveRight 2 err

867− ]

861+ ]

868

862

869-- | Pretty print a Parsec ParseError as a Box

863-- | Pretty print a Parsec ParseError as a Box

870prettyPrintParseError :: P.ParseError -> Box.Box

864prettyPrintParseError :: P.ParseError -> Box.Box

@@ -914,8 +908,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd

914

908

915 clean = nub . filter (not . null)

909 clean = nub . filter (not . null)

916

910

911+-- | Indent to the right, and pad on top and bottom.

917indent :: Box.Box -> Box.Box

912indent :: Box.Box -> Box.Box

918−indent = Box.moveRight 2

913+indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2

919

914

920line :: String -> Box.Box

915line :: String -> Box.Box

921line = Box.text

916line = Box.text

@@ -955,8 +950,7 @@ warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter Multiple

955warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos

950warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos

956

951

957withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage

952withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage

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

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

959−withPosition pos err = PositionedError pos err

960

954

961-- |

955-- |

962-- Collect errors in in parallel

956-- 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+29−20

@@ -46,8 +46,6 @@ import Language.PureScript.Kinds

46import Language.PureScript.Types as P

47import Language.PureScript.Errors

49−import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM)

50−

51-- | There are two modes of failure for the redudancy check:

49-- | There are two modes of failure for the redudancy check:

52--

50--

53-- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.

51-- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.

@@ -273,28 +271,39 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init

273-- Exhaustivity checking over a list of declarations

271-- Exhaustivity checking over a list of declarations

274--

272--

275checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()

273checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()

276−checkExhaustiveDecls env mn ds =

274+checkExhaustiveDecls env mn = mapM_ onDecl

277− let (f, _, _) = everywhereOnValuesTopDownM return checkExpr return

275+ where

276+ onDecl :: Declaration -> m ()

277+ onDecl (BindingGroupDeclaration bs) = mapM_ (onDecl . convert) bs

278+ where

279+ convert :: (Ident, NameKind, Expr) -> Declaration

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

281+ onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr e)

282+ onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)

283+ onDecl _ = return ()

278

284

279− f' :: Declaration -> m Declaration

285+ onExpr :: Expr -> m ()

280− f' d@(BindingGroupDeclaration bs) = mapM_ (f' . convert) bs >> return d

286+ onExpr (UnaryMinus e) = onExpr e

281− where

287+ onExpr (ArrayLiteral es) = mapM_ onExpr es

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

288+ onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es

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

289+ onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e

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

290+ onExpr (Accessor _ e) = onExpr e

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

291+ onExpr (ObjectUpdate o es) = onExpr o >> mapM_ (onExpr . snd) es

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

292+ onExpr (Abs _ e) = onExpr e

287− f' d@TypeInstanceDeclaration{} = return d

293+ onExpr (App e1 e2) = onExpr e1 >> onExpr e2

288− f' d = f d

294+ onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3

295+ onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onExpr es >> mapM_ onCaseAlternative cas

296+ onExpr (TypedValue _ e _) = onExpr e

297+ onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e

298+ onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e)

299+ onExpr _ = return ()

289

300

290− in mapM_ f' ds

301+ onCaseAlternative :: CaseAlternative -> m ()

291− where

302+ onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es

292− checkExpr :: Expr -> m Expr

303+ onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e

293− checkExpr c@(Case expr cas) = checkExhaustive env mn (length expr) cas >> return c

294− checkExpr other = return other

295

304

296-- |

305-- |

297-- Exhaustivity checking over a single module

306-- Exhaustivity checking over a single module

298--

307--

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

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

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

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

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

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

365 requiresForeign = not . null . CF.moduleForeign

366

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

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

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

369 exists <- doesFileExist path

370 traverse (const $ getModificationTime path) $ guard exists

371

372 readTextFile :: FilePath -> Make B.ByteString

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

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

374

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

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

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

377 mkdirp path

378 B.writeFile path text

379 where

src/Language/PureScript/Names.hs+4

@@ -104,6 +104,10 @@ qualify _ (Qualified (Just m) a) = (m, a)

104mkQualified :: a -> ModuleName -> Qualified a

105mkQualified name mn = Qualified (Just mn) name

106

107+-- | Remove the module name from a qualified name

108+disqualify :: Qualified a -> a

109+disqualify (Qualified _ a) = a

110+

107-- |

111-- |

108-- Checks whether a qualified value is actually qualified with a module reference

112-- Checks whether a qualified value is actually qualified with a module reference

109--

113--

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/Common.hs+11

@@ -17,8 +17,11 @@ module Language.PureScript.Pretty.Common where

18import Control.Monad.State

19import Data.List (intercalate)

20+

20import Language.PureScript.Parser.Lexer (reservedPsNames, opChars)

21import Language.PureScript.Parser.Lexer (reservedPsNames, opChars)

23+import Text.PrettyPrint.Boxes

24+

22-- |

25-- |

23-- Wrap a string in parentheses

26-- Wrap a string in parentheses

24--

27--

@@ -67,3 +70,11 @@ prettyPrintObjectKey :: String -> String

67prettyPrintObjectKey s | s `elem` reservedPsNames = show s

70prettyPrintObjectKey s | s `elem` reservedPsNames = show s

68 | any (`elem` opChars) s = show s

71 | any (`elem` opChars) s = show s

69 | otherwise = s

72 | otherwise = s

73+

74+-- | Place a box before another, vertically when the first box takes up multiple lines.

75+before :: Box -> Box -> Box

76+before b1 b2 | rows b1 > 1 = b1 // b2

77+ | otherwise = b1 <> b2

78+

79+beforeWithSpace :: Box -> Box -> Box

80+beforeWithSpace b1 = before (b1 <> text " ")

src/Language/PureScript/Pretty/Kinds.hs+19−15

@@ -14,7 +14,8 @@

14-----------------------------------------------------------------------------

16module Language.PureScript.Pretty.Kinds (

17− prettyPrintKind

17+ prettyPrintKind,

18+ kindAsBox

18) where

19) where

20import Data.Maybe (fromMaybe)

21import Data.Maybe (fromMaybe)

@@ -23,14 +24,15 @@ import Control.Arrow (ArrowPlus(..))

23import Control.PatternArrows

24import Control.PatternArrows

25import Language.PureScript.Kinds

26import Language.PureScript.Kinds

26−import Language.PureScript.Pretty.Common

28+import Text.PrettyPrint.Boxes (Box(), text, render, (<>))

29+

28−typeLiterals :: Pattern () Kind String

30+typeLiterals :: Pattern () Kind Box

29typeLiterals = mkPattern match

31typeLiterals = mkPattern match

30 where

32 where

31− match Star = Just "*"

33+ match Star = Just $ text "*"

32− match Bang = Just "!"

34+ match Bang = Just $ text "!"

33− match (KUnknown u) = Just $ 'u' : show u

35+ match (KUnknown u) = Just $ text $ 'u' : show u

34 match _ = Nothing

36 match _ = Nothing

36matchRow :: Pattern () Kind ((), Kind)

38matchRow :: Pattern () Kind ((), Kind)

@@ -45,15 +47,17 @@ funKind = mkPattern match

45 match (FunKind arg ret) = Just (arg, ret)

47 match (FunKind arg ret) = Just (arg, ret)

46 match _ = Nothing

48 match _ = Nothing

48−-- |

49−-- Generate a pretty-printed string representing a Kind

50+-- | Generate a pretty-printed string representing a Kind

50−--

51prettyPrintKind :: Kind -> String

52+prettyPrintKind = render . kindAsBox

53+

54+kindAsBox :: Kind -> Box

52−prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()

55+kindAsBox = fromMaybe (error "Incomplete pattern") . pattern matchKind ()

53 where

56 where

54− matchKind :: Pattern () Kind String

57+ matchKind :: Pattern () Kind Box

55− matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

58+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap ((text "(" <>) . (<> text ")")) matchKind)

59+

56− operators :: OperatorTable () Kind String

60+ operators :: OperatorTable () Kind Box

57 operators =

61 operators =

58− OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k]

62+ OperatorTable [ [ Wrap matchRow $ \_ k -> text "# " <> k]

59− , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]

63+ , [ AssocR funKind $ \arg ret -> arg <> text " -> " <> ret ] ]

src/Language/PureScript/Pretty/Types.hs+56−34

@@ -14,13 +14,15 @@

14-----------------------------------------------------------------------------

16module Language.PureScript.Pretty.Types (

17+ typeAsBox,

17 prettyPrintType,

18 prettyPrintType,

19+ typeAtomAsBox,

18 prettyPrintTypeAtom,

20 prettyPrintTypeAtom,

21+ prettyPrintRowWith,

19 prettyPrintRow

22 prettyPrintRow

20) where

23) where

22import Data.Maybe (fromMaybe)

25import Data.Maybe (fromMaybe)

23−import Data.List (intercalate)

25import Control.Arrow ((<+>))

27import Control.Arrow ((<+>))

26import Control.PatternArrows

28import Control.PatternArrows

@@ -32,35 +34,54 @@ import Language.PureScript.Pretty.Common

32import Language.PureScript.Pretty.Kinds

34import Language.PureScript.Pretty.Kinds

33import Language.PureScript.Environment

35import Language.PureScript.Environment

37+import Text.PrettyPrint.Boxes hiding ((<+>))

38+

35−typeLiterals :: Pattern () Type String

39+typeLiterals :: Pattern () Type Box

36typeLiterals = mkPattern match

40typeLiterals = mkPattern match

37 where

41 where

38− match TypeWildcard = Just "_"

42+ match TypeWildcard = Just $ text "_"

39− match (TypeVar var) = Just var

43+ match (TypeVar var) = Just $ text var

40− match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

44+ match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row

41− match (TypeConstructor ctor) = Just $ showQualified runProperName ctor

45+ match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor

42− match (TUnknown u) = Just $ '_' : show u

46+ match (TUnknown u) = Just $ text $ '_' : show u

43− match (Skolem name s _) = Just $ name ++ show s

47+ match (Skolem name s _) = Just $ text $ name ++ show s

44− match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> showQualified runProperName pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty

48+ match (ConstrainedType deps ty) = Just $ constraintsAsBox deps `before` (text ") => " <> typeAsBox ty)

45− match REmpty = Just "()"

49+ match REmpty = Just $ text "()"

46− match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")"

50+ match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

47 match _ = Nothing

51 match _ = Nothing

53+constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box

54+constraintsAsBox = vcat left . zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..]

55+ where

56+ constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)

57+

49-- |

58-- |

50-- Generate a pretty-printed string representing a Row

59-- Generate a pretty-printed string representing a Row

51--

60--

52−prettyPrintRow :: Type -> String

61+prettyPrintRowWith :: Char -> Char -> Type -> Box

53−prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []

62+prettyPrintRowWith open close = uncurry listToBox . toList []

54 where

63 where

55− nameAndTypeToPs :: String -> Type -> String

64+ nameAndTypeToPs :: Char -> String -> Type -> Box

56− nameAndTypeToPs name ty = prettyPrintObjectKey name ++ " :: " ++ prettyPrintType ty

65+ nameAndTypeToPs start name ty = text (start : ' ' : prettyPrintObjectKey name ++ " :: ") <> typeAsBox ty

66+

57− tailToPs :: Type -> String

67+ tailToPs :: Type -> Box

58− tailToPs REmpty = ""

68+ tailToPs REmpty = nullBox

59− tailToPs other = " | " ++ prettyPrintType other

69+ tailToPs other = text "| " <> typeAsBox other

70+

71+ listToBox :: [(String, Type)] -> Type -> Box

72+ listToBox [] REmpty = text [open, close]

73+ listToBox [] rest = text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ]

74+ listToBox ts rest = vcat left $

75+ zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++

76+ [ tailToPs rest, text [close] ]

77+

60 toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)

78 toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)

61 toList tys (RCons name ty row) = toList ((name, ty):tys) row

79 toList tys (RCons name ty row) = toList ((name, ty):tys) row

62 toList tys r = (tys, r)

80 toList tys r = (tys, r)

82+prettyPrintRow :: Type -> String

83+prettyPrintRow = render . prettyPrintRowWith '(' ')'

84+

64typeApp :: Pattern () Type (Type, Type)

85typeApp :: Pattern () Type (Type, Type)

65typeApp = mkPattern match

86typeApp = mkPattern match

66 where

87 where

@@ -91,19 +112,19 @@ insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes

91 go idents other = PrettyPrintForAll idents other

112 go idents other = PrettyPrintForAll idents other

92 convertForAlls other = other

113 convertForAlls other = other

114

94−matchTypeAtom :: Pattern () Type String

115+matchTypeAtom :: Pattern () Type Box

95−matchTypeAtom = typeLiterals <+> fmap parens matchType

116+matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType

117

97−matchType :: Pattern () Type String

118+matchType :: Pattern () Type Box

98matchType = buildPrettyPrinter operators matchTypeAtom

119matchType = buildPrettyPrinter operators matchTypeAtom

99 where

120 where

100− operators :: OperatorTable () Type String

121+ operators :: OperatorTable () Type Box

101 operators =

122 operators =

102− OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]

123+ OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]

103− , [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret

124+ , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)

104 ]

125 ]

105− , [ Wrap forall_ $ \idents ty -> "forall " ++ unwords idents ++ ". " ++ ty ]

126+ , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]

106− , [ Wrap kinded $ \k ty -> ty ++ " :: " ++ prettyPrintKind k ]

127+ , [ Wrap kinded $ \k ty -> ty `before` (text " :: " <> kindAsBox k) ]

107 ]

128 ]

108

129

109forall_ :: Pattern () Type ([String], Type)

130forall_ :: Pattern () Type ([String], Type)

@@ -112,15 +133,16 @@ forall_ = mkPattern match

112 match (PrettyPrintForAll idents ty) = Just (idents, ty)

133 match (PrettyPrintForAll idents ty) = Just (idents, ty)

113 match _ = Nothing

134 match _ = Nothing

114

135

115−-- |

136+typeAtomAsBox :: Type -> Box

137+typeAtomAsBox = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders

138+

116−-- Generate a pretty-printed string representing a Type, as it should appear inside parentheses

139+-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses

117−--

118prettyPrintTypeAtom :: Type -> String

140prettyPrintTypeAtom :: Type -> String

119−prettyPrintTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders

141+prettyPrintTypeAtom = render . typeAtomAsBox

120

142

143+typeAsBox :: Type -> Box

144+typeAsBox = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders

121

145

122−-- |

123−-- Generate a pretty-printed string representing a Type

146+-- | Generate a pretty-printed string representing a Type

124−--

125prettyPrintType :: Type -> String

147prettyPrintType :: Type -> String

126−prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders

148+prettyPrintType = render . typeAsBox

src/Language/PureScript/Pretty/Values.hs+92−152

@@ -21,173 +21,113 @@ module Language.PureScript.Pretty.Values (

21 prettyPrintBinderAtom

22) where

24−import Data.Maybe (fromMaybe)

25import Data.List (intercalate)

24import Data.List (intercalate)

27−import Control.Arrow ((<+>), runKleisli, second)

26+import Control.Arrow (second)

28−import Control.PatternArrows

29−import Control.Monad.State

30−#if __GLASGOW_HASKELL__ < 710

31−import Control.Applicative

32−#endif

34import Language.PureScript.AST

28import Language.PureScript.AST

35import Language.PureScript.Names

29import Language.PureScript.Names

36import Language.PureScript.Pretty.Common

30import Language.PureScript.Pretty.Common

37−import Language.PureScript.Pretty.Types (prettyPrintType, prettyPrintTypeAtom)

31+import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox)

39−literals :: Pattern PrinterState Expr String

33+import Text.PrettyPrint.Boxes

40−literals = mkPattern' match

34+

35+-- | Render an aligned list of items separated with commas

36+list :: Char -> Char -> (a -> Box) -> [a] -> Box

37+list open close _ [] = text [open, close]

38+list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ])

41 where

39 where

42− match :: Expr -> StateT PrinterState Maybe String

40+ toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a

41+

42+prettyPrintObject :: [(String, Maybe Expr)] -> Box

43+prettyPrintObject = list '{' '}' prettyPrintObjectProperty

44+ where

45+ prettyPrintObjectProperty :: (String, Maybe Expr) -> Box

46+ prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") prettyPrintValue value

47+

48+-- | Pretty-print an expression

49+prettyPrintValue :: Expr -> Box

50+prettyPrintValue (IfThenElse cond th el) =

51+ (text "if " <> prettyPrintValueAtom cond)

52+ // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom th

53+ , text "else " <> prettyPrintValueAtom el

54+ ])

55+prettyPrintValue (Accessor prop val) = prettyPrintValueAtom val <> text ("." ++ show prop)

56+prettyPrintValue (ObjectUpdate o ps) = prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue val) ps

57+prettyPrintValue (ObjectUpdater o ps) = maybe (text "_") prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") prettyPrintValue val) ps

58+prettyPrintValue (App val arg) = prettyPrintValueAtom val `beforeWithSpace` prettyPrintValueAtom arg

59+prettyPrintValue (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue val)

60+prettyPrintValue (TypeClassDictionaryConstructorApp className ps) =

61+ text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom ps

62+prettyPrintValue (Case values binders) =

63+ (text "case " <> foldl1 beforeWithSpace (map prettyPrintValueAtom values) <> text " of") //

64+ moveRight 2 (vcat left (map prettyPrintCaseAlternative binders))

65+prettyPrintValue (Let ds val) =

66+ text "let" //

67+ moveRight 2 (vcat left (map prettyPrintDeclaration ds)) //

68+ (text "in " <> prettyPrintValue val)

69+prettyPrintValue (Do els) =

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

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

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

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

74+prettyPrintValue (PositionedValue _ _ val) = prettyPrintValue val

75+prettyPrintValue expr = prettyPrintValueAtom expr

76+

77+-- | Pretty-print an atomic expression, adding parentheses if necessary.

78+prettyPrintValueAtom :: Expr -> Box

43− match (NumericLiteral n) = return $ either show show n

79+prettyPrintValueAtom (NumericLiteral n) = text $ either show show n

44− match (StringLiteral s) = return $ show s

80+prettyPrintValueAtom (StringLiteral s) = text $ show s

45− match (CharLiteral c) = return $ show c

81+prettyPrintValueAtom (CharLiteral c) = text $ show c

46− match (BooleanLiteral True) = return "true"

82+prettyPrintValueAtom (BooleanLiteral True) = text "true"

47− match (BooleanLiteral False) = return "false"

83+prettyPrintValueAtom (BooleanLiteral False) = text "false"

48− match (ArrayLiteral xs) = return $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"

84+prettyPrintValueAtom (ArrayLiteral xs) = list '[' ']' prettyPrintValue xs

49− match (ObjectLiteral ps) = prettyPrintObject' $ second Just `map` ps

85+prettyPrintValueAtom (ObjectLiteral ps) = prettyPrintObject $ second Just `map` ps

50− match (ObjectConstructor ps) = prettyPrintObject' ps

86+prettyPrintValueAtom (ObjectConstructor ps) = prettyPrintObject ps

51− match (ObjectGetter prop) = return $ "(." ++ prop ++ ")"

87+prettyPrintValueAtom (ObjectGetter prop) = text $ "_." ++ show prop

52− match (TypeClassDictionaryConstructorApp className ps) = concat <$> sequence

53− [ return (showQualified runProperName className ++ "(\n")

54− , match ps

55− , return ")"

56− ]

57− match (Constructor name) = return $ showQualified runProperName name

88+prettyPrintValueAtom (Constructor name) = text $ runProperName (disqualify name)

58− match (Case values binders) = concat <$> sequence

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

59− [ return "case "

60− , unwords <$> forM values prettyPrintValue'

61− , return " of\n"

62− , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders

63− , currentIndent

64− ]

65− match (Let ds val) = concat <$> sequence

66− [ return "let\n"

67− , withIndent $ prettyPrintMany prettyPrintDeclaration ds

68− , return "\n"

69− , currentIndent

70− , return "in "

71− , prettyPrintValue' val

72− ]

73− match (Var ident) = return $ showQualified showIdent ident

74− match (Do els) = concat <$> sequence

75− [ return "do\n"

76− , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

77− , currentIndent

78− ]

79− match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")"

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

80− match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")"

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

81− match (TypeClassDictionary (name, tys) _) = return $ "<<dict " ++ showQualified runProperName name ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ">>"

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

82− match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ showQualified runProperName name ++ ">>"

83− match (TypedValue _ val _) = prettyPrintValue' val

84− match (PositionedValue _ _ val) = prettyPrintValue' val

93+prettyPrintValueAtom (PositionedValue _ _ val) = prettyPrintValueAtom val

85− match _ = mzero

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

86−

95+

87−prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String

96+prettyPrintDeclaration :: Declaration -> Box

88−prettyPrintDeclaration (TypeDeclaration ident ty) = return $ showIdent ident ++ " :: " ++ prettyPrintType ty

97+prettyPrintDeclaration (TypeDeclaration ident ty) =

98+ text (showIdent ident ++ " :: ") <> typeAsBox ty

89−prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = concat <$> sequence

99+prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) =

90− [ return $ showIdent ident ++ " = "

91− , prettyPrintValue' val

100+ text (showIdent ident ++ " = ") <> prettyPrintValue val

92− ]

93prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d

101prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d

94prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

102prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

103

96−prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

104+prettyPrintCaseAlternative :: CaseAlternative -> Box

97prettyPrintCaseAlternative (CaseAlternative binders result) =

105prettyPrintCaseAlternative (CaseAlternative binders result) =

98− concat <$> sequence

99− [ return (unwords (map prettyPrintBinderAtom binders))

106+ text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result

100− , prettyPrintResult result

101− ]

102 where

107 where

103− prettyPrintResult (Left gs) = concat <$> sequence

108+ prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box

104− [ return "\n"

109+ prettyPrintResult (Left gs) =

105− , withIndent $ prettyPrintMany prettyPrintGuardedValue gs

110+ vcat left (map prettyPrintGuardedValue gs)

106− ]

107− prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v

111+ prettyPrintResult (Right v) = text " -> " <> prettyPrintValue v

108−

112+

109− prettyPrintGuardedValue (grd, val) =

113+ prettyPrintGuardedValue :: (Guard, Expr) -> Box

110− concat <$> sequence

114+ prettyPrintGuardedValue (grd, val) = foldl1 before

111− [ return "| "

115+ [ text " | "

112− , prettyPrintValue' grd

116+ , prettyPrintValue grd

113− , return " -> "

117+ , text " -> "

114− , prettyPrintValue' val

118+ , prettyPrintValue val

115− ]

119+ ]

116−

120+

117−prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String

121+prettyPrintDoNotationElement :: DoNotationElement -> Box

118prettyPrintDoNotationElement (DoNotationValue val) =

122prettyPrintDoNotationElement (DoNotationValue val) =

119− prettyPrintValue' val

123+ prettyPrintValue val

120prettyPrintDoNotationElement (DoNotationBind binder val) =

124prettyPrintDoNotationElement (DoNotationBind binder val) =

121− concat <$> sequence

122− [ return (prettyPrintBinder binder)

125+ text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue val

123− , return " <- "

124− , prettyPrintValue' val

125− ]

126prettyPrintDoNotationElement (DoNotationLet ds) =

127− concat <$> sequence

127+ text "let" //

128− [ return "let "

129− , withIndent $ prettyPrintMany prettyPrintDeclaration ds

128+ moveRight 2 (vcat left (map prettyPrintDeclaration ds))

130− ]

131prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

129prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

132

130

133−prettyPrintObject' :: [(String, Maybe Expr)] -> StateT PrinterState Maybe String

134−prettyPrintObject' [] = return "{}"

135−prettyPrintObject' ps = return $ "{ " ++ intercalate ", " (map prettyPrintObjectProperty ps) ++ "}"

136− where

137− prettyPrintObjectProperty :: (String, Maybe Expr) -> String

138− prettyPrintObjectProperty (key, value) = prettyPrintObjectKey key ++ ": " ++ maybe "_" prettyPrintValue value

139−

140−ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)

141−ifThenElse = mkPattern match

142− where

143− match (IfThenElse cond th el) = Just ((th, el), cond)

144− match _ = Nothing

145−

146−accessor :: Pattern PrinterState Expr (String, Expr)

147−accessor = mkPattern match

148− where

149− match (Accessor prop val) = Just (prop, val)

150− match _ = Nothing

151−

152−objectUpdate :: Pattern PrinterState Expr ([String], Expr)

153−objectUpdate = mkPattern match

154− where

155− match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)

156− match (ObjectUpdater o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ maybe "_" prettyPrintValue val, fromMaybe (Var (Qualified Nothing $ Ident "_")) o)

157− match _ = Nothing

158−

159−app :: Pattern PrinterState Expr (String, Expr)

160−app = mkPattern match

161− where

162− match (App val arg) = Just (prettyPrintValue arg, val)

163− match _ = Nothing

164−

165−lam :: Pattern PrinterState Expr (String, Expr)

166−lam = mkPattern match

167− where

168− match (Abs (Left arg) val) = Just (showIdent arg, val)

169− match _ = Nothing

170−

171−-- |

172−-- Generate a pretty-printed string representing an expression

173−--

174−prettyPrintValue :: Expr -> String

175−prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'

176−

177−prettyPrintValue' :: Expr -> StateT PrinterState Maybe String

178−prettyPrintValue' = runKleisli $ runPattern matchValue

179− where

180− matchValue :: Pattern PrinterState Expr String

181− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

182− operators :: OperatorTable PrinterState Expr String

183− operators =

184− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

185− , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

186− , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]

187− , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]

188− , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]

189− ]

190−

191prettyPrintBinderAtom :: Binder -> String

131prettyPrintBinderAtom :: Binder -> String

192prettyPrintBinderAtom NullBinder = "_"

132prettyPrintBinderAtom NullBinder = "_"

193prettyPrintBinderAtom (StringBinder str) = show str

133prettyPrintBinderAtom (StringBinder str) = show str

@@ -196,7 +136,7 @@ prettyPrintBinderAtom (NumberBinder num) = either show show num

196prettyPrintBinderAtom (BooleanBinder True) = "true"

136prettyPrintBinderAtom (BooleanBinder True) = "true"

197prettyPrintBinderAtom (BooleanBinder False) = "false"

137prettyPrintBinderAtom (BooleanBinder False) = "false"

198prettyPrintBinderAtom (VarBinder ident) = showIdent ident

138prettyPrintBinderAtom (VarBinder ident) = showIdent ident

199−prettyPrintBinderAtom (ConstructorBinder ctor []) = showQualified runProperName ctor

139+prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)

200prettyPrintBinderAtom (ObjectBinder bs) =

140prettyPrintBinderAtom (ObjectBinder bs) =

201 "{ "

141 "{ "

202 ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

142 ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

@@ -216,7 +156,7 @@ prettyPrintBinderAtom b = parens (prettyPrintBinder b)

216-- Generate a pretty-printed string representing a Binder

156-- Generate a pretty-printed string representing a Binder

217--

157--

218prettyPrintBinder :: Binder -> String

158prettyPrintBinder :: Binder -> String

219−prettyPrintBinder (ConstructorBinder ctor []) = showQualified runProperName ctor

159+prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor)

220−prettyPrintBinder (ConstructorBinder ctor args) = showQualified runProperName ctor ++ " " ++ unwords (map prettyPrintBinderAtom args)

160+prettyPrintBinder (ConstructorBinder ctor args) = runProperName (disqualify ctor) ++ " " ++ unwords (map prettyPrintBinderAtom args)

221prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder

161prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder

222prettyPrintBinder b = prettyPrintBinderAtom b

162prettyPrintBinder b = prettyPrintBinderAtom b

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+37−33

@@ -15,18 +15,19 @@

15-----------------------------------------------------------------------------

17{-# LANGUAGE FlexibleContexts #-}

18+{-# LANGUAGE ScopedTypeVariables #-}

18{-# LANGUAGE CPP #-}

19{-# LANGUAGE CPP #-}

20module Language.PureScript.Sugar.TypeDeclarations (

21module Language.PureScript.Sugar.TypeDeclarations (

21− desugarTypeDeclarations,

22 desugarTypeDeclarationsModule

23) where

25#if __GLASGOW_HASKELL__ < 710

26import Control.Applicative

27#endif

28−import Control.Monad (forM)

28+import Control.Monad (forM, when)

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

30+import Control.Monad.Writer.Class (MonadWriter(tell))

31import Language.PureScript.AST

32import Language.PureScript.AST

32import Language.PureScript.Names

33import Language.PureScript.Names

@@ -37,36 +38,39 @@ import Language.PureScript.Traversals

37-- |

38-- |

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

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

39--

40--

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

41+desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]

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

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

42− rethrow (onErrorMessages (ErrorInModule name)) $

43+ rethrow (addHint (ErrorInModule name)) $

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

44+ Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps

44−

45−-- |

46−-- Replace all top level type declarations with type annotations

47−--

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

49−desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

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

51− return (PositionedDeclaration pos com d' : ds')

52−desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

53− (_, nameKind, val) <- fromValueDeclaration d

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

55 where

45 where

46+

47+ desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration]

48+ desugarTypeDeclarations reqd (PositionedDeclaration pos com d : ds) = do

49+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations reqd (d : ds)

50+ return (PositionedDeclaration pos com d' : ds')

51+ desugarTypeDeclarations reqd (TypeDeclaration name ty : d : rest) = do

52+ (_, nameKind, val) <- fromValueDeclaration d

53+ desugarTypeDeclarations reqd (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

54+ where

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

55+ fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)

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

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

58− fromValueDeclaration (PositionedDeclaration pos com d') = do

57+ fromValueDeclaration (PositionedDeclaration pos com d') = do

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

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

60− return (ident, nameKind, PositionedValue pos com val)

59+ return (ident, nameKind, PositionedValue pos com val)

61− fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

60+ fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

62−desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

61+ desugarTypeDeclarations _ [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

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

62+ desugarTypeDeclarations reqd (ValueDeclaration name nameKind bs val : rest) = do

63+ -- At the top level, match a type signature or emit a warning.

64+ when reqd $ case val of

65+ Right TypedValue{} -> return ()

66+ Left _ -> error "desugarTypeDeclarations: cases were not desugared"

67+ _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)

64− let (_, f, _) = everywhereOnValuesTopDownM return go return

68+ let (_, f, _) = everywhereOnValuesTopDownM return go return

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

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

66− f' (Right v) = Right <$> f v

70+ f' (Right v) = Right <$> f v

67− (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest

71+ (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations reqd rest

68− where

72+ where

69− go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'

73+ go (Let ds val') = Let <$> desugarTypeDeclarations False ds <*> pure val'

70− go other = return other

74+ go other = return other

71−desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

75+ desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds

72−desugarTypeDeclarations [] = return []

76+ desugarTypeDeclarations _ [] = return []

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 moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

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 moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

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 moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

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 moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

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 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 moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals

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

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 moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

269--

270typeCheckModule :: Module -> Check Module

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

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

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

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

274 decls' <- typeCheckAll 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

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

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

36--

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

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

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

40-- |

41-- Check whether one type subsumes another

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

@@ -92,7 +92,7 @@ typesOf moduleName vals = do

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

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

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

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

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

96 replace _ em = em

98type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

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

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

198--

199infer :: Expr -> UnifyT Type Check Expr

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

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

201

202-- |

203-- Infer a type for a value

@@ -229,15 +229,10 @@ infer' (ObjectUpdate o ps) = do

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

230 return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row)

231infer' (Accessor prop val) = do

232− typed@(TypedValue _ _ objTy) <- infer val

232+ field <- fresh

233− propTy <- inferProperty objTy prop

233+ rest <- fresh

234− case propTy of

235− Nothing -> do

236− field <- fresh

237− rest <- fresh

238− _ <- subsumes Nothing objTy (TypeApp tyObject (RCons prop field rest))

234+ typed <- check val (TypeApp tyObject (RCons prop field rest))

239− return $ TypedValue True (Accessor prop typed) field

235+ return $ TypedValue True (Accessor prop typed) field

240− Just ty -> return $ TypedValue True (Accessor prop typed) ty

241infer' (Abs (Left arg) ret) = do

236infer' (Abs (Left arg) ret) = do

242 ty <- fresh

237 ty <- fresh

243 Just moduleName <- checkCurrentModule <$> get

238 Just moduleName <- checkCurrentModule <$> get

@@ -322,18 +317,6 @@ inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethr

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

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

323inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"

318inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"

324

319

325−-- |

326−-- Infer the type of a property inside a record with a given type

327−--

328−inferProperty :: Type -> String -> UnifyT Type Check (Maybe Type)

329−inferProperty (TypeApp obj row) prop | obj == tyObject = do

330− let (props, _) = rowToList row

331− return $ lookup prop props

332−inferProperty (ForAll ident ty _) prop = do

333− replaced <- replaceVarWithUnknown ident ty

334− inferProperty replaced prop

335−inferProperty _ _ = return Nothing

336−

337-- |

320-- |

338-- Infer the types of variables brought into scope by a binder

321-- Infer the types of variables brought into scope by a binder

339--

322--

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

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

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

438--

421--

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

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

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

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

441

424

442-- |

425-- |

443-- Check the type of a value

426-- Check the type of a value

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

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

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

624--

607--

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

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

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

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

627 subst <- unifyCurrentSubstitution <$> UnifyT get

610 subst <- unifyCurrentSubstitution <$> UnifyT get

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

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

629

612

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

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

61-- Unify two types, updating the current substitution

62--

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

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

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

65 unifyTypes' t1 t2

66 where

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