95fdf2e · rowtype-yoga/purescript-native

.gitignore+1

compare with golang

unifiedsplit

@@ -17,3 +17,4 @@ tmp/

17output

18examples/docs/docs/

19core-tests/full-core-docs.md

20+.psc-ide-port

CONTRIBUTORS.md+6−4

@@ -12,7 +12,9 @@ This file lists the contributors to the PureScript compiler project, and the ter

12- [@bagl](https://github.com/bagl) (Petr Vapenka) My existing contributions and all future contributions until further notice are Copyright Petr Vapenka, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

13- [@balajirrao](https://github.com/balajirrao) (Balaji Rao) - My existing contributions and all future contributions until further notice are Copyright Balaji Rao, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

14- [@bergmark](https://github.com/bergmark) (Adam Bergmark) - My existing contributions and all future contributions until further notice are Copyright Adam Bergmark, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

15+- [@bmjames](https://github.com/bmjames) (Ben James) My existing contributions and all future contributions until further notice are Copyright Ben James, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

15- [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

16- [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

17+- [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

16- [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

18- [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

17- [@chrissmoak](https://github.com/chrissmoak) (Chris Smoak) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

19- [@chrissmoak](https://github.com/chrissmoak) (Chris Smoak) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

18- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

20- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

@@ -25,8 +27,10 @@ This file lists the contributors to the PureScript compiler project, and the ter

25- [@erdeszt](https://github.com/erdeszt) (Tibor Erdesz) My existing contributions and all future contributions until further notice are Copyright Tibor Erdesz, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

27- [@erdeszt](https://github.com/erdeszt) (Tibor Erdesz) My existing contributions and all future contributions until further notice are Copyright Tibor Erdesz, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

26- [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

28- [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

27- [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

29- [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

30+- [@felixSchl](https://github.com/felixSchl) (Felix Schlitter) My existing contributions and all future contributions until further notice are Copyright Felix Schlitter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

28- [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

31- [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

29- [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

32- [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

33+- [@ilovezfs](https://github.com/ilovezfs) - My existing contributions and all future contributions until further notice are Copyright ilovezfs, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license

30- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

34- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

31- [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

35- [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

32- [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

36- [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

@@ -35,6 +39,7 @@ This file lists the contributors to the PureScript compiler project, and the ter

35- [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

39- [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

36- [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

40- [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

37- [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

41- [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

42+- [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

38- [@lukerandall](https://github.com/lukerandall) (Luke Randall) My existing contributions and all future contributions until further notice are Copyright Luke Randall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

43- [@lukerandall](https://github.com/lukerandall) (Luke Randall) My existing contributions and all future contributions until further notice are Copyright Luke Randall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

39- [@mgmeier](https://github.com/mgmeier) (Michael Karg) My existing contributions and all future contributions until further notice are Copyright Michael Gilliland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

44- [@mgmeier](https://github.com/mgmeier) (Michael Karg) My existing contributions and all future contributions until further notice are Copyright Michael Gilliland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

40- [@michaelficarra](https://github.com/michaelficarra) (Michael Ficarra) My existing contributions and all future contributions until further notice are Copyright Michael Ficarra, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

45- [@michaelficarra](https://github.com/michaelficarra) (Michael Ficarra) My existing contributions and all future contributions until further notice are Copyright Michael Ficarra, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

@@ -58,6 +63,7 @@ This file lists the contributors to the PureScript compiler project, and the ter

58- [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler.

63- [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler.

59- [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

64- [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

60- [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

65- [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

66+- [@rvion](https://github.com/rvion) (Rémi Vion) My existing contributions and all future contributions until further notice are Copyright Rémi Vion, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

61- [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

67- [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

62- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

68- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

63- [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

69- [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

@@ -69,10 +75,6 @@ This file lists the contributors to the PureScript compiler project, and the ter

69- [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

75- [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

70- [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

76- [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

71- [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

77- [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

72−- [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

73−- [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

74−- [@bmjames](https://github.com/bmjames) (Ben James) My existing contributions and all future contributions until further notice are Copyright Ben James, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

75−- - [@felixSchl](https://github.com/felixSchl) (Felix Schlitter) My existing contributions and all future contributions until further notice are Copyright Felix Schlitter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

76

78

77### Companies

79### Companies

78

80

examples/passing/2252.pursnew file+15

@@ -0,0 +1,15 @@

1+module Main where

2+

3+import Control.Monad.Eff.Console (log)

4+

5+data T a = T

6+

7+ti :: T Int

8+ti = T

9+

10+t :: forall a. T a

11+t = T

12+

13+xs = [ti, t, t]

14+

15+main = log "Done"

purescript.cabal+8−7

@@ -1,5 +1,5 @@

1name: purescript

2−version: 0.9.2

2+version: 0.9.3

3cabal-version: >=1.8

4build-type: Simple

5license: MIT

@@ -101,7 +101,7 @@ source-repository head

101

102library

103 build-depends: base >=4.8 && <5,

104− aeson >= 0.8 && < 0.12,

104+ aeson >= 0.8 && < 1.1,

105 aeson-better-errors >= 0.8,

106 ansi-terminal >= 0.6.2 && < 0.7,

107 base-compat >=0.6.0,

@@ -117,6 +117,7 @@ library

117 fsnotify >= 0.2.1,

118 Glob >= 0.7 && < 0.8,

119 haskeline >= 0.7.0.0,

120+ http-client >= 0.4.30 && <0.5,

120 http-types -any,

121 http-types -any,

121 language-javascript == 0.6.*,

122 language-javascript == 0.6.*,

122 lifted-base >= 0.2.3 && < 0.2.4,

123 lifted-base >= 0.2.3 && < 0.2.4,

@@ -129,7 +130,7 @@ library

129 pipes >= 4.0.0 && < 4.3.0,

130 pipes >= 4.0.0 && < 4.3.0,

130 pipes-http -any,

131 pipes-http -any,

131 process >= 1.2.0 && < 1.5,

132 process >= 1.2.0 && < 1.5,

132− protolude >= 0.1.5,

133+ protolude >= 0.1.6,

133 regex-tdfa -any,

134 regex-tdfa -any,

134 safe >= 0.3.9 && < 0.4,

135 safe >= 0.3.9 && < 0.4,

135 semigroups >= 0.16.2 && < 0.19,

136 semigroups >= 0.16.2 && < 0.19,

@@ -330,7 +331,7 @@ library

330executable psc

331executable psc

331 build-depends: base >=4 && <5,

332 build-depends: base >=4 && <5,

332 purescript -any,

333 purescript -any,

333− aeson >= 0.8 && < 0.12,

334+ aeson >= 0.8 && < 1.1,

334 ansi-terminal >= 0.6.2 && < 0.7,

335 ansi-terminal >= 0.6.2 && < 0.7,

335 base-compat >=0.6.0,

336 base-compat >=0.6.0,

336 bytestring -any,

337 bytestring -any,

@@ -455,7 +456,7 @@ executable psc-ide-server

455 other-modules: Paths_purescript

456 other-modules: Paths_purescript

456 other-extensions:

457 other-extensions:

457 build-depends: base >=4 && <5,

458 build-depends: base >=4 && <5,

458− aeson >= 0.8 && < 0.12,

459+ aeson >= 0.8 && < 1.1,

459 bytestring -any,

460 bytestring -any,

460 purescript -any,

461 purescript -any,

461 base-compat >=0.6.0,

462 base-compat >=0.6.0,

@@ -465,7 +466,7 @@ executable psc-ide-server

465 mtl -any,

466 mtl -any,

466 network -any,

467 network -any,

467 optparse-applicative >= 0.12.1,

468 optparse-applicative >= 0.12.1,

468− protolude >= 0.1.5,

469+ protolude >= 0.1.6,

469 stm -any,

470 stm -any,

470 text -any,

471 text -any,

471 transformers -any,

472 transformers -any,

@@ -533,7 +534,7 @@ test-suite tests

533 optparse-applicative -any,

534 optparse-applicative -any,

534 parsec -any,

535 parsec -any,

535 process -any,

536 process -any,

536− protolude >= 0.1.5,

537+ protolude >= 0.1.6,

537 silently -any,

538 silently -any,

538 stm -any,

539 stm -any,

539 text -any,

540 text -any,

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

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

61 -- A binder with a type annotation

62 --

63 | TypedBinder Type Binder

64− deriving (Show, Read, Eq)

64+ deriving (Show, Eq)

65

66-- |

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

src/Language/PureScript/AST/Declarations.hs+159−18

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

22import Language.PureScript.TypeClassDictionaries

23import Language.PureScript.Comments

24import Language.PureScript.Environment

25+import qualified Language.PureScript.Bundle as Bundle

26+

27+import qualified Text.Parsec as P

28+

29+-- | A map of locally-bound names in scope.

30+type Context = [(Ident, Type)]

31+

32+-- | A type of error messages

33+data SimpleErrorMessage

34+ = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

35+ | ErrorParsingModule P.ParseError

36+ | MissingFFIModule ModuleName

37+ | MultipleFFIModules ModuleName [FilePath]

38+ | UnnecessaryFFIModule ModuleName FilePath

39+ | MissingFFIImplementations ModuleName [Ident]

40+ | UnusedFFIImplementations ModuleName [Ident]

41+ | InvalidFFIIdentifier ModuleName String

42+ | CannotGetFileInfo FilePath

43+ | CannotReadFile FilePath

44+ | CannotWriteFile FilePath

45+ | InfiniteType Type

46+ | InfiniteKind Kind

47+ | MultipleValueOpFixities (OpName 'ValueOpName)

48+ | MultipleTypeOpFixities (OpName 'TypeOpName)

49+ | OrphanTypeDeclaration Ident

50+ | RedefinedModule ModuleName [SourceSpan]

51+ | RedefinedIdent Ident

52+ | OverlappingNamesInLet

53+ | UnknownName (Qualified Name)

54+ | UnknownImport ModuleName Name

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

56+ | UnknownExport Name

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

58+ | ScopeConflict Name [ModuleName]

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

60+ | DeclConflict Name Name

61+ | ExportConflict (Qualified Name) (Qualified Name)

62+ | DuplicateModuleName ModuleName

63+ | DuplicateTypeArgument String

64+ | InvalidDoBind

65+ | InvalidDoLet

66+ | CycleInDeclaration Ident

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

68+ | CycleInModules [ModuleName]

69+ | NameIsUndefined Ident

70+ | UndefinedTypeVariable (ProperName 'TypeName)

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

72+ | EscapedSkolem (Maybe Expr)

73+ | TypesDoNotUnify Type Type

74+ | KindsDoNotUnify Kind Kind

75+ | ConstrainedTypeUnified Type Type

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

77+ | NoInstanceFound Constraint

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

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

80+ | CannotFindDerivingType (ProperName 'TypeName)

81+ | DuplicateLabel String (Maybe Expr)

82+ | DuplicateValueDeclaration Ident

83+ | ArgListLengthsDiffer Ident

84+ | OverlappingArgNames (Maybe Ident)

85+ | MissingClassMember Ident

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

87+ | ExpectedType Type Kind

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

89+ | ExprDoesNotHaveType Expr Type

90+ | PropertyIsMissing String

91+ | AdditionalProperty String

92+ | CannotApplyFunction Type Expr

93+ | TypeSynonymInstance

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

95+ | InvalidNewtype (ProperName 'TypeName)

96+ | InvalidInstanceHead Type

97+ | TransitiveExportError DeclarationRef [DeclarationRef]

98+ | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)

99+ | ShadowedName Ident

100+ | ShadowedTypeVar String

101+ | UnusedTypeVar String

102+ | WildcardInferredType Type Context

103+ | HoleInferredType String Type Context

104+ | MissingTypeDeclaration Ident Type

105+ | OverlappingPattern [[Binder]] Bool

106+ | IncompleteExhaustivityCheck

107+ | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)

108+ | ImportHidingModule ModuleName

109+ | UnusedImport ModuleName

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

111+ | UnusedDctorImport (ProperName 'TypeName)

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

113+ | DuplicateSelectiveImport ModuleName

114+ | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

115+ | DuplicateImportRef Name

116+ | DuplicateExportRef Name

117+ | IntOutOfRange Integer String Integer Integer

118+ | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

119+ | ImplicitImport ModuleName [DeclarationRef]

120+ | HidingImport ModuleName [DeclarationRef]

121+ | CaseBinderLengthDiffers Int [Binder]

122+ | IncorrectAnonymousArgument

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

124+ | DeprecatedRequirePath

125+ | CannotGeneralizeRecursiveFunction Ident Type

126+ deriving (Show)

127+

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

129+data ErrorMessageHint

130+ = ErrorUnifyingTypes Type Type

131+ | ErrorInExpression Expr

132+ | ErrorInModule ModuleName

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

134+ | ErrorInSubsumption Type Type

135+ | ErrorCheckingAccessor Expr String

136+ | ErrorCheckingType Expr Type

137+ | ErrorCheckingKind Type

138+ | ErrorCheckingGuard

139+ | ErrorInferringType Expr

140+ | ErrorInApplication Expr Type Expr

141+ | ErrorInDataConstructor (ProperName 'ConstructorName)

142+ | ErrorInTypeConstructor (ProperName 'TypeName)

143+ | ErrorInBindingGroup [Ident]

144+ | ErrorInDataBindingGroup

145+ | ErrorInTypeSynonym (ProperName 'TypeName)

146+ | ErrorInValueDeclaration Ident

147+ | ErrorInTypeDeclaration Ident

148+ | ErrorInForeignImport Ident

149+ | ErrorSolvingConstraint Constraint

150+ | PositionedError SourceSpan

151+ deriving (Show)

152+

153+-- | Categories of hints

154+data HintCategory

155+ = ExprHint

156+ | KindHint

157+ | CheckHint

158+ | PositionHint

159+ | SolverHint

160+ | OtherHint

161+ deriving (Show, Eq)

162+

163+data ErrorMessage = ErrorMessage

164+ [ErrorMessageHint]

165+ SimpleErrorMessage

166+ deriving (Show)

25

167

26-- |

168-- |

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

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

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

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

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

30--

172--

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

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

32− deriving (Show, Read)

174+ deriving (Show)

33

175

34-- | Return a module's name.

176-- | Return a module's name.

35getModuleName :: Module -> ModuleName

177getModuleName :: Module -> ModuleName

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

88 -- A declaration reference with source position information

230 -- A declaration reference with source position information

89 --

231 --

90 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

232 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

91− deriving (Show, Read)

233+ deriving (Show)

92

234

93instance Eq DeclarationRef where

235instance Eq DeclarationRef where

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

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

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

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

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

150 --

292 --

151 | Hiding [DeclarationRef]

293 | Hiding [DeclarationRef]

152− deriving (Eq, Show, Read)

294+ deriving (Eq, Show)

153

295

154isImplicit :: ImportDeclarationType -> Bool

296isImplicit :: ImportDeclarationType -> Bool

155isImplicit Implicit = True

297isImplicit Implicit = True

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

216 -- A declaration with source position information

358 -- A declaration with source position information

217 --

359 --

218 | PositionedDeclaration SourceSpan [Comment] Declaration

360 | PositionedDeclaration SourceSpan [Comment] Declaration

219− deriving (Show, Read)

361+ deriving (Show)

220

362

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

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

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

364+ deriving (Eq, Ord, Show)

223

365

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

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

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

367+ deriving (Eq, Ord, Show)

226

368

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

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

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

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

229

371

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

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

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

236 = DerivedInstance

378 = DerivedInstance

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

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

238 | ExplicitInstance [Declaration]

380 | ExplicitInstance [Declaration]

239− deriving (Show, Read)

381+ deriving (Show)

240

382

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

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

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

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

@@ -355,12 +497,9 @@ data Expr

355 --

497 --

356 | Parens Expr

498 | Parens Expr

357 -- |

499 -- |

358− -- A record property getter (e.g. `_.x`). This will be removed during

500+ -- An record property accessor expression (e.g. `obj.x` or `_.x`).

501+ -- Anonymous arguments will be removed during desugaring and expanded

359− -- desugaring and expanded into a lambda that reads a property from a record.

502+ -- into a lambda that reads a property from a record.

360− --

361− | ObjectGetter String

362− -- |

363− -- An record property accessor expression

364 --

503 --

365 | Accessor String Expr

504 | Accessor String Expr

366 -- |

505 -- |

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

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

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

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

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

423 --

562 --

563+ | TypeClassDictionary Constraint

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

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

565+ [ErrorMessageHint]

425 -- |

566 -- |

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

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

427 --

568 --

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

442 -- A value with source position information

583 -- A value with source position information

443 --

584 --

444 | PositionedValue SourceSpan [Comment] Expr

585 | PositionedValue SourceSpan [Comment] Expr

445− deriving (Show, Read)

586+ deriving (Show)

446

587

447-- |

588-- |

448-- An alternative in a case statement

589-- An alternative in a case statement

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

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

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

457 --

598 --

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

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

459− } deriving (Show, Read)

600+ } deriving (Show)

460

601

461-- |

602-- |

462-- A statement in a do-notation block

603-- A statement in a do-notation block

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

478 -- A do notation element with source position information

619 -- A do notation element with source position information

479 --

620 --

480 | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement

621 | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement

481− deriving (Show, Read)

622+ deriving (Show)

482

623

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

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

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

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

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

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

34 -- An object literal

35 --

36 | ObjectLiteral [(String, a)]

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

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

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

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

21-- Associativity for infix operators

22--

23data Associativity = Infixl | Infixr | Infix

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

24+ deriving (Show, Eq, Ord)

25

26showAssoc :: Associativity -> String

27showAssoc Infixl = "infixl"

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

44-- Fixity data for infix operators

45--

46data Fixity = Fixity Associativity Precedence

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

47+ deriving (Show, Eq, Ord)

48

49instance A.ToJSON Fixity where

50 toJSON (Fixity associativity precedence) =

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

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

22 -- Column number

23 --

24 , sourcePosColumn :: Int

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

25+ } deriving (Show, Eq, Ord)

26

27displaySourcePos :: SourcePos -> String

28displaySourcePos sp =

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

50 -- End of the span

51 --

52 , spanEnd :: SourcePos

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

53+ } deriving (Show, Eq, Ord)

54

55displayStartEndPos :: SourceSpan -> String

56displayStartEndPos sp =

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

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

582 forDecls (TypeDeclaration _ ty) = f ty

583 forDecls _ = mempty

584

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

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

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

587 forValues (TypedValue _ _ ty) = f ty

588 forValues _ = mempty

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

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

43 | UnableToParseModule String

44 | UnsupportedExport

45 | ErrorInModule ModuleIdentifier ErrorMessage

46− deriving (Show, Read)

46+ deriving (Show)

47

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

49data ModuleType

50 = Regular

51 | Foreign

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

52+ deriving (Show, Eq, Ord)

53

54showModuleType :: ModuleType -> String

55showModuleType Regular = "Regular"

56showModuleType Foreign = "Foreign"

57

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

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

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

60

61moduleName :: ModuleIdentifier -> String

62moduleName (ModuleIdentifier name _) = name

src/Language/PureScript/CodeGen/JS.hs+11−6

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

27import Language.PureScript.CodeGen.JS.Optimizer

28import Language.PureScript.CoreFn

29import Language.PureScript.Crash

30−import Language.PureScript.Errors

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

31+ MultipleErrors(..), rethrow,

32+ errorMessage, rethrowWithPosition, addHint)

31import Language.PureScript.Names

33import Language.PureScript.Names

32import Language.PureScript.Options

34import Language.PureScript.Options

33import Language.PureScript.Traversals (sndM)

35import Language.PureScript.Traversals (sndM)

@@ -280,15 +282,18 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

280 extendObj obj sts = do

282 extendObj obj sts = do

281 newObj <- freshName

283 newObj <- freshName

282 key <- freshName

284 key <- freshName

285+ evaluatedObj <- freshName

283 let

286 let

284 jsKey = JSVar Nothing key

287 jsKey = JSVar Nothing key

285 jsNewObj = JSVar Nothing newObj

288 jsNewObj = JSVar Nothing newObj

289+ jsEvaluatedObj = JSVar Nothing evaluatedObj

286− block = JSBlock Nothing (objAssign:copy:extend ++ [JSReturn Nothing jsNewObj])

290+ block = JSBlock Nothing (evaluate:objAssign:copy:extend ++ [JSReturn Nothing jsNewObj])

291+ evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj)

287 objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])

292 objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])

288− copy = JSForIn Nothing key obj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]

293+ copy = JSForIn Nothing key jsEvaluatedObj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]

289− cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" obj) [jsKey]

294+ cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" jsEvaluatedObj) [jsKey]

290− assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey obj)]

295+ assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey jsEvaluatedObj)]

291− stToAssign (s, js) = JSAssignment Nothing (JSAccessor Nothing s jsNewObj) js

296+ stToAssign (s, js) = JSAssignment Nothing (accessorString s jsNewObj) js

292 extend = map stToAssign sts

297 extend = map stToAssign sts

293 return $ JSApp Nothing (JSFunction Nothing Nothing [] block) []

298 return $ JSApp Nothing (JSFunction Nothing Nothing [] block) []

294

299

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

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

35 -- Constructor

36 --

37 | JSNew

38− deriving (Show, Read, Eq)

38+ deriving (Show, Eq)

39

40-- |

41-- Built-in binary operators

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

117 -- Bitwise right shift with zero-fill

118 --

119 | ZeroFillShiftRight

120− deriving (Show, Read, Eq)

120+ deriving (Show, Eq)

121

122-- |

123-- Data type for simplified Javascript expressions

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

238 -- |

239 -- Commented Javascript

240 --

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

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

242

243withSourceSpan :: SourceSpan -> JS -> JS

244withSourceSpan withSpan = go

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

@@ -35,7 +35,7 @@ identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"

35-- Test if a string is a valid JS identifier without escaping.

36--

37identNeedsEscaping :: String -> Bool

38−identNeedsEscaping s = s /= identToJs (Ident s)

38+identNeedsEscaping s = s /= identToJs (Ident s) || null s

39

40-- |

41-- Attempts to find a human-readable name for a symbol, if none has been specified returns the

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

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

12data Comment

13 = LineComment String

14 | BlockComment String

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

15+ deriving (Show, Eq, Ord)

16

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

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

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

31 -- |

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

33 --

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

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

35

36

37extractBinderAnn :: Binder a -> a

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

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

51 -- A let binding

52 --

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

54− deriving (Show, Read, Functor)

54+ deriving (Show, Functor)

55

56-- |

57-- A let or module binding.

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

64 -- |

65 -- Mutually recursive binding group for several values

66 --

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

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

68

69-- |

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

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

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

84 --

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

86− } deriving (Show, Read)

86+ } deriving (Show)

87

88instance Functor CaseAlternative where

89

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

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

26 -- |

27 -- The contained reference is for a foreign member

28 --

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

29+ | IsForeign deriving (Show, Eq)

30

31-- |

32-- Data constructor metadata

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

39 -- |

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

41 --

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

42+ | SumType deriving (Show, Eq)

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

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

17 , moduleExports :: [Ident]

18 , moduleForeign :: [ForeignDecl]

19 , moduleDecls :: [Bind a]

20− } deriving (Show, Read)

20+ } deriving (Show)

21

22type ForeignDecl = (Ident, Type)

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

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

110data First

111 = First

112 | NotFirst

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

113+ deriving (Show, Eq, Ord)

114

115type Docs = Writer [String] ()

116

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

@@ -158,7 +158,7 @@ insertValueTypes env m =

158 either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent

159

160 lookupName name =

161− let key = (modName m, name)

161+ let key = P.Qualified (Just (modName m)) name

162 in case Map.lookup key (P.names env) of

163 Just (ty, _, _) ->

164 ty

src/Language/PureScript/Environment.hs+7−8

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

25 -- |

26 -- Value names currently in scope

27 --

28− names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

28+ names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility)

29 -- |

30 -- Type names currently in scope

31 --

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

46 -- Type classes

47 --

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

49− } deriving (Show, Read)

49+ } deriving (Show)

50

51-- |

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

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

65 -- |

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

67 --

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

68+ | Defined deriving (Show, Eq)

69

70-- |

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

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

85 -- A name for member introduced by foreign import

86 --

87 | External

88− deriving (Show, Read, Eq)

88+ deriving (Show, Eq)

89

90-- |

91-- The kinds of a type

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

111 -- A scoped type variable

112 --

113 | ScopedTypeVar

114− deriving (Show, Read, Eq)

114+ deriving (Show, Eq)

115

116-- |

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

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

125 -- A newtype constructor

126 --

127 | Newtype

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

128+ deriving (Show, Eq, Ord)

129

130showDataDeclType :: DataDeclType -> String

131showDataDeclType Data = "data"

@@ -273,7 +273,6 @@ isNewtypeConstructor e ctor = case lookupConstructor e ctor of

273-- Finds information about values from the current environment.

274--

275lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility)

276−lookupValue env (Qualified (Just mn) ident) = (mn, ident) `M.lookup` names env

276+lookupValue env ident = ident `M.lookup` names env

277−lookupValue _ _ = Nothing

278

277

279$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)

278$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)

src/Language/PureScript/Errors.hs+58−164

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

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE NamedFieldPuns #-}

3

4−module Language.PureScript.Errors where

4+module Language.PureScript.Errors

5+ ( module Language.PureScript.AST

6+ , module Language.PureScript.Errors

7+ ) where

5

8

6import Prelude.Compat

9import Prelude.Compat

7

10

@@ -14,6 +17,7 @@ import Control.Monad.Writer

14import Data.Char (isSpace)

17import Data.Char (isSpace)

15import Data.Either (lefts, rights)

18import Data.Either (lefts, rights)

16import Data.Foldable (fold)

19import Data.Foldable (fold)

20+import Data.Functor.Identity (Identity(..))

17import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)

21import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)

18import Data.Maybe (maybeToList, fromMaybe, mapMaybe)

22import Data.Maybe (maybeToList, fromMaybe, mapMaybe)

19import Data.Ord (comparing)

23import Data.Ord (comparing)

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

21

25

22import Language.PureScript.AST

26import Language.PureScript.AST

23import Language.PureScript.Crash

27import Language.PureScript.Crash

24−import Language.PureScript.Kinds

25import Language.PureScript.Names

28import Language.PureScript.Names

26import Language.PureScript.Pretty

29import Language.PureScript.Pretty

27import Language.PureScript.Traversals

30import Language.PureScript.Traversals

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

37import qualified Text.PrettyPrint.Boxes as Box

40import qualified Text.PrettyPrint.Boxes as Box

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

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

39

42

40−-- | A type of error messages

41−data SimpleErrorMessage

42− = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

43− | ErrorParsingModule P.ParseError

44− | MissingFFIModule ModuleName

45− | MultipleFFIModules ModuleName [FilePath]

46− | UnnecessaryFFIModule ModuleName FilePath

47− | MissingFFIImplementations ModuleName [Ident]

48− | UnusedFFIImplementations ModuleName [Ident]

49− | InvalidFFIIdentifier ModuleName String

50− | CannotGetFileInfo FilePath

51− | CannotReadFile FilePath

52− | CannotWriteFile FilePath

53− | InfiniteType Type

54− | InfiniteKind Kind

55− | MultipleValueOpFixities (OpName 'ValueOpName)

56− | MultipleTypeOpFixities (OpName 'TypeOpName)

57− | OrphanTypeDeclaration Ident

58− | RedefinedModule ModuleName [SourceSpan]

59− | RedefinedIdent Ident

60− | OverlappingNamesInLet

61− | UnknownName (Qualified Name)

62− | UnknownImport ModuleName Name

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

64− | UnknownExport Name

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

66− | ScopeConflict Name [ModuleName]

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

68− | DeclConflict Name Name

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

70− | DuplicateModuleName ModuleName

71− | DuplicateTypeArgument String

72− | InvalidDoBind

73− | InvalidDoLet

74− | CycleInDeclaration Ident

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

76− | CycleInModules [ModuleName]

77− | NameIsUndefined Ident

78− | UndefinedTypeVariable (ProperName 'TypeName)

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

80− | EscapedSkolem (Maybe Expr)

81− | TypesDoNotUnify Type Type

82− | KindsDoNotUnify Kind Kind

83− | ConstrainedTypeUnified Type Type

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

85− | NoInstanceFound Constraint

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

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

88− | CannotFindDerivingType (ProperName 'TypeName)

89− | DuplicateLabel String (Maybe Expr)

90− | DuplicateValueDeclaration Ident

91− | ArgListLengthsDiffer Ident

92− | OverlappingArgNames (Maybe Ident)

93− | MissingClassMember Ident

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

95− | ExpectedType Type Kind

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

97− | ExprDoesNotHaveType Expr Type

98− | PropertyIsMissing String

99− | AdditionalProperty String

100− | CannotApplyFunction Type Expr

101− | TypeSynonymInstance

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

103− | InvalidNewtype (ProperName 'TypeName)

104− | InvalidInstanceHead Type

105− | TransitiveExportError DeclarationRef [DeclarationRef]

106− | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)

107− | ShadowedName Ident

108− | ShadowedTypeVar String

109− | UnusedTypeVar String

110− | WildcardInferredType Type

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

112− | MissingTypeDeclaration Ident Type

113− | OverlappingPattern [[Binder]] Bool

114− | IncompleteExhaustivityCheck

115− | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)

116− | ImportHidingModule ModuleName

117− | UnusedImport ModuleName

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

119− | UnusedDctorImport (ProperName 'TypeName)

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

121− | DuplicateSelectiveImport ModuleName

122− | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

123− | DuplicateImportRef Name

124− | DuplicateExportRef Name

125− | IntOutOfRange Integer String Integer Integer

126− | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

127− | ImplicitImport ModuleName [DeclarationRef]

128− | HidingImport ModuleName [DeclarationRef]

129− | CaseBinderLengthDiffers Int [Binder]

130− | IncorrectAnonymousArgument

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

132− | DeprecatedRequirePath

133− | CannotGeneralizeRecursiveFunction Ident Type

134− deriving (Show)

135−

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

137−data ErrorMessageHint

138− = ErrorUnifyingTypes Type Type

139− | ErrorInExpression Expr

140− | ErrorInModule ModuleName

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

142− | ErrorInSubsumption Type Type

143− | ErrorCheckingAccessor Expr String

144− | ErrorCheckingType Expr Type

145− | ErrorCheckingKind Type

146− | ErrorCheckingGuard

147− | ErrorInferringType Expr

148− | ErrorInApplication Expr Type Expr

149− | ErrorInDataConstructor (ProperName 'ConstructorName)

150− | ErrorInTypeConstructor (ProperName 'TypeName)

151− | ErrorInBindingGroup [Ident]

152− | ErrorInDataBindingGroup

153− | ErrorInTypeSynonym (ProperName 'TypeName)

154− | ErrorInValueDeclaration Ident

155− | ErrorInTypeDeclaration Ident

156− | ErrorInForeignImport Ident

157− | PositionedError SourceSpan

158− deriving Show

159−

160−-- | Categories of hints

161−data HintCategory

162− = ExprHint

163− | KindHint

164− | CheckHint

165− | PositionHint

166− | OtherHint

167− deriving (Show, Eq)

168−

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

170−

171newtype ErrorSuggestion = ErrorSuggestion String

43newtype ErrorSuggestion = ErrorSuggestion String

172

44

173-- | Get the source span for an error

45-- | Get the source span for an error

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

321

193

322-- | Add a hint to an error message

194-- | Add a hint to an error message

323addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors

195addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors

196+addHint hint = addHints [hint]

197+

198+-- | Add hints to an error message

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

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

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

325

201

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

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

327data TypeMap = TypeMap

203data TypeMap = TypeMap

@@ -368,7 +244,10 @@ replaceUnknowns = everywhereOnTypesM replaceTypes

368 Just (_, s', _) -> return (Skolem name s' sko ss)

244 Just (_, s', _) -> return (Skolem name s' sko ss)

369 replaceTypes other = return other

245 replaceTypes other = return other

370

246

247+onTypesInErrorMessage :: (Type -> Type) -> ErrorMessage -> ErrorMessage

248+onTypesInErrorMessage f = runIdentity . onTypesInErrorMessageM (Identity . f)

249+

371−onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage

250+onTypesInErrorMessageM :: Applicative m => (Type -> m Type) -> ErrorMessage -> m ErrorMessage

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

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

373 where

252 where

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

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

@@ -383,11 +262,10 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

383 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts

262 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts

384 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k

263 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k

385 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts

264 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts

386− gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty

265+ gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx

387− gSimple (HoleInferredType name ty env) = HoleInferredType name <$> f ty <*> traverse (sndM f) env

266+ gSimple (HoleInferredType name ty ctx) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx

388 gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty

267 gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty

389 gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty

268 gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty

390−

391 gSimple other = pure other

269 gSimple other = pure other

392

270

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

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

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

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

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

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

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

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

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

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

399 gHint other = pure other

278 gHint other = pure other

400

279

401wikiUri :: ErrorMessage -> String

280wikiUri :: ErrorMessage -> String

@@ -413,7 +292,7 @@ errorSuggestion err = case err of

413 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

292 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

414 HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing

293 HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing

415 MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintType ty

294 MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintType ty

416− WildcardInferredType ty -> suggest $ prettyPrintType ty

295+ WildcardInferredType ty _ -> suggest $ prettyPrintType ty

417 _ -> Nothing

296 _ -> Nothing

418

297

419 where

298 where

@@ -845,24 +724,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

845 paras [ line "hiding imports cannot be used to hide modules."

724 paras [ line "hiding imports cannot be used to hide modules."

846 , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name)

725 , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name)

847 ]

726 ]

848− renderSimpleErrorMessage (WildcardInferredType ty) =

727+ renderSimpleErrorMessage (WildcardInferredType ty ctx) =

849− paras [ line "Wildcard type definition has the inferred type "

728+ paras $ [ line "Wildcard type definition has the inferred type "

850− , markCodeBox $ indent $ typeAsBox ty

729+ , markCodeBox $ indent $ typeAsBox ty

851− ]

730+ ] ++ renderContext ctx

852− renderSimpleErrorMessage (HoleInferredType name ty env) =

731+ renderSimpleErrorMessage (HoleInferredType name ty ctx) =

853 paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "

732 paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "

854 , markCodeBox $ indent $ typeAsBox ty

733 , markCodeBox $ indent $ typeAsBox ty

855− ] ++ if null env then [] else envInfo

734+ ] ++ renderContext ctx

856− where

857− envInfo :: [Box.Box]

858− envInfo = [ line "in the following context:"

859− , indent $ paras

860− [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")

861− , markCodeBox $ typeAsBox ty'

862− ]

863− | (ident, ty') <- take 5 env

864− ]

865− ]

866 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

735 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

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

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

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

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

@@ -1062,11 +931,31 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

1062 paras [ detail

931 paras [ detail

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

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

1064 ]

933 ]

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

935+ paras [ detail

936+ , line "while solving type class constriant"

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

938+ [ line (showQualified runProperName nm)

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

940+ ]

941+ ]

1065 renderHint (PositionedError srcSpan) detail =

942 renderHint (PositionedError srcSpan) detail =

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

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

1067 , detail

944 , detail

1068 ]

945 ]

1069

946

947+ renderContext :: Context -> [Box.Box]

948+ renderContext [] = []

949+ renderContext ctx =

950+ [ line "in the following context:"

951+ , indent $ paras

952+ [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")

953+ , markCodeBox $ typeAsBox ty'

954+ ]

955+ | (ident, ty') <- take 5 ctx

956+ ]

957+ ]

958+

1070 printName :: Qualified Name -> String

959 printName :: Qualified Name -> String

1071 printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn)

960 printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn)

1072

961

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

1139 where

1028 where

1140 isUnifyHint ErrorUnifyingTypes{} = True

1029 isUnifyHint ErrorUnifyingTypes{} = True

1141 isUnifyHint _ = False

1030 isUnifyHint _ = False

1031+ stripRedudantHints NoInstanceFound{} = stripFirst isSolverHint

1032+ where

1033+ isSolverHint ErrorSolvingConstraint{} = True

1034+ isSolverHint _ = False

1142 stripRedudantHints _ = id

1035 stripRedudantHints _ = id

1143

1036

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

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

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

1150 stripFirst _ [] = []

1043 stripFirst _ [] = []

1151

1044

1152 hintCategory :: ErrorMessageHint -> HintCategory

1045 hintCategory :: ErrorMessageHint -> HintCategory

1153− hintCategory ErrorCheckingType{} = ExprHint

1046+ hintCategory ErrorCheckingType{} = ExprHint

1154− hintCategory ErrorInferringType{} = ExprHint

1047+ hintCategory ErrorInferringType{} = ExprHint

1155− hintCategory ErrorInExpression{} = ExprHint

1048+ hintCategory ErrorInExpression{} = ExprHint

1156− hintCategory ErrorUnifyingTypes{} = CheckHint

1049+ hintCategory ErrorUnifyingTypes{} = CheckHint

1157− hintCategory ErrorInSubsumption{} = CheckHint

1050+ hintCategory ErrorInSubsumption{} = CheckHint

1158− hintCategory ErrorInApplication{} = CheckHint

1051+ hintCategory ErrorInApplication{} = CheckHint

1159− hintCategory ErrorCheckingKind{} = CheckHint

1052+ hintCategory ErrorCheckingKind{} = CheckHint

1053+ hintCategory ErrorSolvingConstraint{} = SolverHint

1160− hintCategory PositionedError{} = PositionHint

1054+ hintCategory PositionedError{} = PositionHint

1161− hintCategory _ = OtherHint

1055+ hintCategory _ = OtherHint

1162

1056

1163-- Pretty print and export declaration

1057-- Pretty print and export declaration

1164prettyPrintExport :: DeclarationRef -> String

1058prettyPrintExport :: DeclarationRef -> String

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

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

50 , efTypeFixities :: [ExternsTypeFixity]

51 -- | List of type and value declaration

52 , efDeclarations :: [ExternsDeclaration]

53− } deriving (Show, Read)

53+ } deriving (Show)

54

55-- | A module import in an externs file

56data ExternsImport = ExternsImport

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

61 , eiImportType :: ImportDeclarationType

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

63 , eiImportedAs :: Maybe ModuleName

64− } deriving (Show, Read)

64+ } deriving (Show)

65

66-- | A fixity declaration in an externs file

67data ExternsFixity = ExternsFixity

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

74 , efOperator :: OpName 'ValueOpName

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

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

77− } deriving (Show, Read)

77+ } deriving (Show)

78

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

80data ExternsTypeFixity = ExternsTypeFixity

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

87 , efTypeOperator :: OpName 'TypeOpName

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

89 , efTypeAlias :: Qualified (ProperName 'TypeName)

90− } deriving (Show, Read)

90+ } deriving (Show)

91

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

93data ExternsDeclaration =

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

130 , edInstanceTypes :: [Type]

131 , edInstanceConstraints :: Maybe [Constraint]

132 }

133− deriving (Show, Read)

133+ deriving (Show)

134

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

136applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment

@@ -140,7 +140,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar

140 applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) }

141 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }

142 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }

143− applyDecl env (EDValue ident ty) = env { names = M.insert (efModuleName, ident) (ty, External, Defined) (names env) }

143+ applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }

144 applyDecl env (EDClass pn args members cs) = env { typeClasses = M.insert (qual pn) (args, members, cs) (typeClasses env) }

145 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }

146 where

@@ -201,7 +201,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

201 ]

202 _ -> internalError "toExternsDeclaration: Invalid input"

203 toExternsDeclaration (ValueRef ident)

204− | Just (ty, _, _) <- (mn, ident) `M.lookup` names env

204+ | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env

205 = [ EDValue ident ty ]

206 toExternsDeclaration (TypeClassRef className)

207 | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env

src/Language/PureScript/Ide/Command.hs−1

@@ -24,7 +24,6 @@ import Language.PureScript.Ide.CaseSplit

24import Language.PureScript.Ide.Filter

25import Language.PureScript.Ide.Matcher

26import Language.PureScript.Ide.Types

27−import System.FilePath

28

27

29data Command

28data Command

30 = Load [P.ModuleName]

29 = Load [P.ModuleName]

src/Language/PureScript/Ide/Externs.hs−1

@@ -33,7 +33,6 @@ import Language.PureScript.Ide.Types

33import Language.PureScript.Ide.Util

34

35import qualified Language.PureScript as P

36−import System.FilePath

37

36

38readExternFile :: (MonadIO m, MonadError PscIdeError m) =>

37readExternFile :: (MonadIO m, MonadError PscIdeError m) =>

39 FilePath -> m P.ExternsFile

38 FilePath -> m P.ExternsFile

src/Language/PureScript/Ide/Imports.hs−1

@@ -40,7 +40,6 @@ import Language.PureScript.Ide.Filter

40import Language.PureScript.Ide.State

41import Language.PureScript.Ide.Types

42import Language.PureScript.Ide.Util

43−import System.FilePath

44

43

45data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)

44data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)

46 deriving (Eq, Show)

45 deriving (Eq, Show)

src/Language/PureScript/Ide/Pursuit.hs+2−2

@@ -19,7 +19,7 @@ module Language.PureScript.Ide.Pursuit

19 , findPackagesForModuleIdent

20 ) where

21

22−import Protolude

22+import Protolude hiding (fromStrict)

23

24import qualified Control.Exception as E

25import Data.Aeson

@@ -36,7 +36,7 @@ import qualified Pipes.Prelude as P

36queryPursuit :: Text -> IO ByteString

37queryPursuit q = do

38 let qClean = T.dropWhileEnd (== '.') q

39− req' <- parseUrl "http://pursuit.purescript.org/search"

39+ req' <- parseRequest "http://pursuit.purescript.org/search"

40 let req = req'

41 { queryString= "q=" <> (fromString . T.unpack) qClean

42 , requestHeaders=[(hAccept, "application/json")]

src/Language/PureScript/Ide/Rebuild.hs+2−2

@@ -22,7 +22,6 @@ import Language.PureScript.Ide.State

22import Language.PureScript.Ide.Types

23import Language.PureScript.Ide.Util

24import System.IO.UTF8 (readUTF8File)

25−import System.FilePath

26

25

27-- | Given a filepath performs the following steps:

26-- | Given a filepath performs the following steps:

28--

27--

@@ -145,7 +144,8 @@ sortExterns m ex = do

145 . M.elems

144 . M.elems

146 . M.delete (P.getModuleName m) $ ex

145 . M.delete (P.getModuleName m) $ ex

147 case sorted' of

146 case sorted' of

148− Left _ -> throwError (GeneralError "There was a cycle in the dependencies")

147+ Left err ->

148+ throwError (RebuildError (toJSONErrors False P.Error err))

149 Right (sorted, graph) -> do

150 let deps = fromJust (List.lookup (P.getModuleName m) graph)

151 pure $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted)

src/Language/PureScript/Ide/SourceFile.hs−1

@@ -26,7 +26,6 @@ import qualified Language.PureScript as P

26import Language.PureScript.Ide.Error

27import Language.PureScript.Ide.Util

28import Language.PureScript.Ide.Types

29−import System.FilePath

30import System.IO.UTF8 (readUTF8File)

29import System.IO.UTF8 (readUTF8File)

31

30

32parseModule

31parseModule

src/Language/PureScript/Ide/State.hs−1

@@ -44,7 +44,6 @@ import Language.PureScript.Ide.Types

44import Language.PureScript.Ide.Util

45import qualified Language.PureScript as P

46import System.Clock

47−import System.FilePath

48

47

49-- | Resets all State inside psc-ide

48-- | Resets all State inside psc-ide

50resetIdeState :: Ide m => m ()

49resetIdeState :: Ide m => m ()

src/Language/PureScript/Ide/Types.hs−1

@@ -25,7 +25,6 @@ import Data.Map.Lazy as M

25import qualified Language.PureScript.Errors.JSON as P

26import qualified Language.PureScript as P

27import Language.PureScript.Ide.Conversions

28−import System.FilePath

29import Text.Parsec as Parsec

28import Text.Parsec as Parsec

30import Text.Parsec.Text

29import Text.Parsec.Text

31

30

src/Language/PureScript/Ide/Util.hs+1−1

@@ -27,7 +27,7 @@ module Language.PureScript.Ide.Util

27 , module Language.PureScript.Ide.Conversions

28 ) where

29

30−import Protolude

30+import Protolude hiding (decodeUtf8, encodeUtf8)

31import Data.Aeson

32import qualified Data.Text as T

33import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

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

@@ -234,7 +234,7 @@ handleTypeOf val = do

234 case e of

235 Left errs -> printErrors errs

236 Right (_, env') ->

237− case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of

237+ case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName [P.ProperName "$PSCI"])) (P.names env') of

238 Just (ty, _, _) -> liftIO . putStrLn . P.prettyPrintType $ ty

239 Nothing -> liftIO $ putStrLn "Could not find type"

240

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

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

91 | CtxIdentifier

92 | CtxType

93 | CtxFixed String

94− deriving (Show, Read)

94+ deriving (Show)

95

96-- |

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

src/Language/PureScript/Interactive/Printer.hs+8−5

@@ -19,9 +19,10 @@ import qualified Text.PrettyPrint.Boxes as Box

19printModuleSignatures :: P.ModuleName -> P.Environment -> String

20printModuleSignatures moduleName (P.Environment {..}) =

21 -- get relevant components of a module from environment

22− let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names

22+ let moduleNamesIdent = byModuleName names

23− moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses

23+ moduleTypeClasses = byModuleName typeClasses

24− moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types

24+ moduleTypes = byModuleName types

25+ byModuleName = filter ((== Just moduleName) . P.getQual) . M.keys

25

26

26 in

27 in

27 -- print each component

28 -- print each component

@@ -33,8 +34,10 @@ printModuleSignatures moduleName (P.Environment {..}) =

33

34

34 where printModule's showF = Box.vsep 1 Box.left . showF

35 where printModule's showF = Box.vsep 1 Box.left . showF

35

36

36− findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))

37+ findNameType :: M.Map (P.Qualified P.Ident) (P.Type, P.NameKind, P.NameVisibility)

38+ -> P.Qualified P.Ident

39+ -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))

37− findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

40+ findNameType envNames m = (P.disqualify m, M.lookup m envNames)

38

41

39 showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box

42 showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box

40 showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

43 showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

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

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

20 | FunKind Kind Kind

21 -- | Type-level strings

22 | Symbol

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

23+ deriving (Show, Eq, Ord)

24

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

26

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

@@ -36,6 +36,7 @@ import Control.Monad.Trans.Except

36import Control.Monad.Writer.Class (MonadWriter(..))

37

38import Data.Aeson (encode, decode)

39+import Data.ByteString.Builder (toLazyByteString, stringUtf8)

39import Data.Either (partitionEithers)

40import Data.Either (partitionEithers)

40import Data.Foldable (for_)

41import Data.Foldable (for_)

41import Data.List (foldl', sort)

42import Data.List (foldl', sort)

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

85-- | Progress messages from the make process

86-- | Progress messages from the make process

86data ProgressMessage

87data ProgressMessage

87 = CompilingModule ModuleName

88 = CompilingModule ModuleName

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

89+ deriving (Show, Eq, Ord)

89

90

90-- | Render a progress message

91-- | Render a progress message

91renderProgressMessage :: ProgressMessage -> String

92renderProgressMessage :: ProgressMessage -> String

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

129 -- | Never rebuild this module

130 -- | Never rebuild this module

130 = RebuildNever

131 = RebuildNever

131 -- | Always rebuild this module

132 -- | Always rebuild this module

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

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

133

134

134-- | Rebuild a single module

135-- | Rebuild a single module

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

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

@@ -252,7 +253,7 @@ make ma@MakeActions{..} ms = do

252

253

253 decodeExterns :: Externs -> Maybe ExternsFile

254 decodeExterns :: Externs -> Maybe ExternsFile

254 decodeExterns bs = do

255 decodeExterns bs = do

255− externs <- decode (fromString bs)

256+ externs <- decode (toLazyByteString (stringUtf8 bs))

256 guard $ efVersion externs == showVersion Paths.version

257 guard $ efVersion externs == showVersion Paths.version

257 return externs

258 return externs

258

259

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

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

64 -- A generated name for an identifier

65 --

66 | GenIdent (Maybe String) Integer

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

67+ deriving (Show, Eq, Ord)

68

69runIdent :: Ident -> String

70runIdent (Ident i) = i

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

84-- Operator alias names.

85--

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

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

87+ deriving (Show, Eq, Ord)

88

89instance ToJSON (OpName a) where

90 toJSON = toJSON . runOpName

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

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

105--

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

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

107+ deriving (Show, Eq, Ord)

108

109instance ToJSON (ProperName a) where

110 toJSON = toJSON . runProperName

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

129-- Module names

130--

131newtype ModuleName = ModuleName [ProperName 'Namespace]

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

132+ deriving (Show, Eq, Ord)

133

134runModuleName :: ModuleName -> String

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

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

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

147--

148data Qualified a = Qualified (Maybe ModuleName) a

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

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

150

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

152showQualified f (Qualified Nothing a) = f a

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

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

104 | StringLiteral String

105 | Number (Either Integer Double)

106 | HoleLit String

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

107+ deriving (Show, Eq, Ord)

108

109prettyPrintToken :: Token -> String

110prettyPrintToken LParen = "("

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

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

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

61prettyPrintValue d (Do els) =

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

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

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

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

65prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

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

@@ -75,7 +75,6 @@ prettyPrintValue d expr@Op{} = prettyPrintValueAtom d expr

75prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr

76prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr

77prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr

78−prettyPrintValue d expr@ObjectGetter{} = prettyPrintValueAtom d expr

79

78

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

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

81prettyPrintValueAtom :: Int -> Expr -> Box

80prettyPrintValueAtom :: Int -> Expr -> Box

@@ -92,7 +91,6 @@ prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val

92prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val

91prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val

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

92prettyPrintValueAtom d (Parens expr) = (text "(" <> prettyPrintValue d expr) `before` text ")"

94prettyPrintValueAtom d (UnaryMinus expr) = text "(-" <> prettyPrintValue d expr <> text ")"

93prettyPrintValueAtom d (UnaryMinus expr) = text "(-" <> prettyPrintValue d expr <> text ")"

95−prettyPrintValueAtom _ (ObjectGetter field) = text "_." <> text field

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

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

97

95

98prettyPrintLiteralValue :: Int -> Literal Expr -> Box

96prettyPrintLiteralValue :: Int -> Literal Expr -> Box

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

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

169 Left err ->

170 userError (CompileError err)

171

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

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

173

174getGitWorkingTreeStatus :: PrepareM TreeStatus

175getGitWorkingTreeStatus = do

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

273 | ResolvedVersion String

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

275 -- "v0.1.0").

276− deriving (Show, Read, Eq)

276+ deriving (Show, Eq)

277

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

279-- extract their versions.

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

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

49 , importSourceModule :: ModuleName

50 , importProvenance :: ImportProvenance

51 }

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

52+ deriving (Eq, Ord, Show)

53

54-- |

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

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

61 | FromExplicit

62 | Local

63 | Prim

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

64+ deriving (Eq, Ord, Show)

65

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

67

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

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

105 --

106 , importedQualModules :: S.Set ModuleName

107− } deriving (Show, Read)

107+ } deriving (Show)

108

109nullImports :: Imports

110nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty

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

155 -- from.

156 --

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

158− } deriving (Show, Read)

158+ } deriving (Show)

159

160-- |

161-- An empty 'Exports' value.

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

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

329

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

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

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

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

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

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

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

335 goExpr pos (SuperClassDictionary cls tys) = do

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

337 return (pos, SuperClassDictionary cls tys')

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

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

11import Prelude.Compat

12

13import Language.PureScript.Crash

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

15import Language.PureScript.Environment

14import Language.PureScript.Environment

16−import Language.PureScript.Errors

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

17import Language.PureScript.Kinds

16import Language.PureScript.Kinds

18import Language.PureScript.Names

17import Language.PureScript.Names

19import Language.PureScript.Externs

18import Language.PureScript.Externs

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

@@ -91,7 +91,7 @@ valueIsNotDefined

91 -> m ()

92valueIsNotDefined moduleName name = do

93 env <- getEnv

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

94+ case M.lookup (Qualified (Just moduleName) name) (names env) of

95 Just _ -> throwError . errorMessage $ RedefinedIdent name

96 Nothing -> return ()

97

@@ -104,7 +104,7 @@ addValue

104 -> m ()

105addValue moduleName name ty nameKind = do

106 env <- getEnv

107− putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })

107+ putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, nameKind, Defined) (names env) })

108

109addTypeClass

110 :: (MonadState CheckState m)

@@ -259,9 +259,9 @@ typeCheckAll moduleName _ = traverse go

259 env <- getEnv

260 kind <- kindOf ty

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

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

262+ case M.lookup (Qualified (Just moduleName) name) (names env) of

263 Just _ -> throwError . errorMessage $ RedefinedIdent name

264− Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })

264+ Nothing -> putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, External, Defined) (names env) })

265 return d

266 go d@FixityDeclaration{} = return d

267 go d@ImportDeclaration{} = return d

@@ -360,7 +360,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) =

360 Just (_, _, ty, _) -> checkExport dr extract ty

361 return ()

362 checkMemberExport extract dr@(ValueRef name) = do

363− ty <- lookupVariable mn (Qualified (Just mn) name)

363+ ty <- lookupVariable (Qualified (Just mn) name)

364 checkExport dr extract ty

365 checkMemberExport _ _ = return ()

366

src/Language/PureScript/TypeChecker/Entailment.hs+21−19

@@ -2,7 +2,7 @@

2-- Type class entailment

3--

4module Language.PureScript.TypeChecker.Entailment

5− ( Context

5+ ( InstanceContext

6 , replaceTypeClassDictionaries

7 ) where

8

@@ -22,24 +22,25 @@ import Language.PureScript.AST

22import Language.PureScript.Crash

23import Language.PureScript.Errors

24import Language.PureScript.Names

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

25import Language.PureScript.TypeChecker.Unify

26import Language.PureScript.TypeChecker.Unify

26import Language.PureScript.TypeClassDictionaries

27import Language.PureScript.TypeClassDictionaries

27import Language.PureScript.Types

28import Language.PureScript.Types

28import qualified Language.PureScript.Constants as C

29import qualified Language.PureScript.Constants as C

29

30

30−-- | The 'Context' tracks those constraints which can be satisfied.

31+-- | The 'InstanceContext' tracks those constraints which can be satisfied.

31−type Context = M.Map (Maybe ModuleName)

32+type InstanceContext = M.Map (Maybe ModuleName)

32− (M.Map (Qualified (ProperName 'ClassName))

33+ (M.Map (Qualified (ProperName 'ClassName))

33− (M.Map (Qualified Ident)

34+ (M.Map (Qualified Ident)

34− TypeClassDictionaryInScope))

35+ TypeClassDictionaryInScope))

35

36

36-- | Merge two type class contexts

37-- | Merge two type class contexts

37−combineContexts :: Context -> Context -> Context

38+combineContexts :: InstanceContext -> InstanceContext -> InstanceContext

38combineContexts = M.unionWith (M.unionWith M.union)

39combineContexts = M.unionWith (M.unionWith M.union)

39

40

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

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

41replaceTypeClassDictionaries

42replaceTypeClassDictionaries

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

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

43 => Bool

44 => Bool

44 -> ModuleName

45 -> ModuleName

45 -> Expr

46 -> Expr

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

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

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

49 in flip evalStateT M.empty . runWriterT . f

50 in flip evalStateT M.empty . runWriterT . f

50 where

51 where

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

52+ go (TypeClassDictionary constraint dicts hints) =

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

52 go other = return (other, [])

54 go other = return (other, [])

53

55

54-- |

56-- |

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

57--

59--

58entails

60entails

59 :: forall m

61 :: forall m

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

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

61 => Bool

63 => Bool

62 -> ModuleName

64 -> ModuleName

63− -> Context

65+ -> InstanceContext

64 -> Constraint

66 -> Constraint

65− -> StateT Context m (Expr, [(Ident, Constraint)])

67+ -> StateT InstanceContext m (Expr, [(Ident, Constraint)])

66entails shouldGeneralize moduleName context = solve

68entails shouldGeneralize moduleName context = solve

67 where

69 where

68− forClassName :: Context -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

70+ forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

69 forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

71 forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

70 forClassName _ _ _ = internalError "forClassName: expected qualified class name"

72 forClassName _ _ _ = internalError "forClassName: expected qualified class name"

71

73

@@ -75,15 +77,15 @@ entails shouldGeneralize moduleName context = solve

75 ctorModules (TypeApp ty _) = ctorModules ty

77 ctorModules (TypeApp ty _) = ctorModules ty

76 ctorModules _ = Nothing

78 ctorModules _ = Nothing

77

79

78− findDicts :: Context -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

80+ findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

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

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

80

82

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

83+ solve :: Constraint -> StateT InstanceContext m (Expr, [(Ident, Constraint)])

82− solve con = do

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

83 (dict, unsolved) <- go 0 con

85 (dict, unsolved) <- go 0 con

84 return (dictionaryValueToValue dict, unsolved)

86 return (dictionaryValueToValue dict, unsolved)

85 where

87 where

86− go :: Int -> Constraint -> StateT Context m (DictionaryValue, [(Ident, Constraint)])

88+ go :: Int -> Constraint -> StateT InstanceContext m (DictionaryValue, [(Ident, Constraint)])

87 go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

89 go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

88 go work con'@(Constraint className' tys' _) = do

90 go work con'@(Constraint className' tys' _) = do

89 -- Get the inferred constraint context so far, and merge it with the global context

91 -- Get the inferred constraint context so far, and merge it with the global context

@@ -106,7 +108,7 @@ entails shouldGeneralize moduleName context = solve

106 -- Generate a fresh name for the unsolved constraint's new dictionary

108 -- Generate a fresh name for the unsolved constraint's new dictionary

107 ident <- freshIdent ("dict" ++ runProperName pn)

109 ident <- freshIdent ("dict" ++ runProperName pn)

108 let qident = Qualified Nothing ident

110 let qident = Qualified Nothing ident

109− -- Store the new dictionary in the Context so that we can solve this goal in

111+ -- Store the new dictionary in the InstanceContext so that we can solve this goal in

110 -- future.

112 -- future.

111 let newDict = TypeClassDictionaryInScope qident [] unsolvedClassName unsolvedTys Nothing

113 let newDict = TypeClassDictionaryInScope qident [] unsolvedClassName unsolvedTys Nothing

112 newContext = M.singleton Nothing (M.singleton unsolvedClassName (M.singleton qident newDict))

114 newContext = M.singleton Nothing (M.singleton unsolvedClassName (M.singleton qident newDict))

@@ -143,7 +145,7 @@ entails shouldGeneralize moduleName context = solve

143 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

145 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

144 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

146 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

145 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

147 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

146− solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Context m (Maybe [DictionaryValue], [(Ident, Constraint)])

148+ solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT InstanceContext m (Maybe [DictionaryValue], [(Ident, Constraint)])

147 solveSubgoals _ Nothing = return (Nothing, [])

149 solveSubgoals _ Nothing = return (Nothing, [])

148 solveSubgoals subst (Just subgoals) = do

150 solveSubgoals subst (Just subgoals) = do

149 zipped <- traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars subst))) subgoals

151 zipped <- traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars subst))) subgoals

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

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

107 Type ->

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

109kindOfWithScopedVars ty =

110− rethrow (addHint (ErrorCheckingKind ty)) $

110+ withErrorMessageHint (ErrorCheckingKind ty) $

111 fmap tidyUp . liftUnify $ infer ty

112 where

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

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

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

201 => Type

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

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

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

204

205infer'

206 :: forall m

src/Language/PureScript/TypeChecker/Monad.hs+68−27

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

35

36-- | State required for type checking

37data CheckState = CheckState

38+ { checkEnv :: Environment

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

39+ -- ^ The current @Environment@

40+ , checkNextType :: Int

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

41+ -- ^ The next type unification variable

42+ , checkNextKind :: Int

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

43+ -- ^ The next kind unification variable

44+ , checkNextSkolem :: Int

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

45+ -- ^ The next skolem variable

46+ , checkNextSkolemScope :: Int

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

47+ -- ^ The next skolem scope constant

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

48+ , checkCurrentModule :: Maybe ModuleName

49+ -- ^ The current module

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

50+ , checkSubstitution :: Substitution

51+ -- ^ The current substitution

52+ , checkHints :: [ErrorMessageHint]

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

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

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

56+ -- during instance resolution.

45 }

57 }

46

58

47-- | Create an empty @CheckState@

59-- | Create an empty @CheckState@

48emptyCheckState :: Environment -> CheckState

60emptyCheckState :: Environment -> CheckState

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

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

50

62

51-- | Unification variables

63-- | Unification variables

52type Unknown = Int

64type Unknown = Int

@@ -54,7 +66,7 @@ type Unknown = Int

54-- | Temporarily bind a collection of names to values

66-- | Temporarily bind a collection of names to values

55bindNames

67bindNames

56 :: MonadState CheckState m

68 :: MonadState CheckState m

57− => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

69+ => M.Map (Qualified Ident) (Type, NameKind, NameVisibility)

58 -> m a

70 -> m a

59 -> m a

71 -> m a

60bindNames newNames action = do

72bindNames newNames action = do

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

91 tell . errorMessage $ ShadowedTypeVar name

103 tell . errorMessage $ ShadowedTypeVar name

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

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

93

105

106+withErrorMessageHint

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

108+ => ErrorMessageHint

109+ -> m a

110+ -> m a

111+withErrorMessageHint hint action = do

112+ orig <- get

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

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

115+ a <- rethrow (addHint hint) action

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

117+ return a

118+

119+rethrowWithPositionTC

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

121+ => SourceSpan

122+ -> m a

123+ -> m a

124+rethrowWithPositionTC pos = withErrorMessageHint (PositionedError pos)

125+

126+warnAndRethrowWithPositionTC

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

128+ => SourceSpan

129+ -> m a

130+ -> m a

131+warnAndRethrowWithPositionTC pos = rethrowWithPositionTC pos . warnWithPosition pos

132+

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

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

95withTypeClassDictionaries

134withTypeClassDictionaries

96 :: MonadState CheckState m

135 :: MonadState CheckState m

@@ -121,12 +160,11 @@ lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDict

121-- | Temporarily bind a collection of names to local variables

160-- | Temporarily bind a collection of names to local variables

122bindLocalVariables

161bindLocalVariables

123 :: (MonadState CheckState m)

162 :: (MonadState CheckState m)

124− => ModuleName

125− -> [(Ident, Type, NameVisibility)]

163+ => [(Ident, Type, NameVisibility)]

126 -> m a

164 -> m a

127 -> m a

165 -> m a

128−bindLocalVariables moduleName bindings =

166+bindLocalVariables bindings =

129− bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))

167+ bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> (Qualified Nothing name, (ty, Private, visibility)))

130

168

131-- | Temporarily bind a collection of names to local type variables

169-- | Temporarily bind a collection of names to local type variables

132bindLocalTypeVariables

170bindLocalTypeVariables

@@ -157,35 +195,32 @@ preservingNames action = do

157-- | Lookup the type of a value by name in the @Environment@

195-- | Lookup the type of a value by name in the @Environment@

158lookupVariable

196lookupVariable

159 :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

197 :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

160− => ModuleName

161− -> Qualified Ident

198+ => Qualified Ident

162 -> m Type

199 -> m Type

163−lookupVariable currentModule (Qualified moduleName var) = do

200+lookupVariable qual = do

164 env <- getEnv

201 env <- getEnv

165− case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

202+ case M.lookup qual (names env) of

166− Nothing -> throwError . errorMessage $ NameIsUndefined var

203+ Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual)

167 Just (ty, _, _) -> return ty

204 Just (ty, _, _) -> return ty

168

205

169-- | Lookup the visibility of a value by name in the @Environment@

206-- | Lookup the visibility of a value by name in the @Environment@

170getVisibility

207getVisibility

171 :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

208 :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

172− => ModuleName

173− -> Qualified Ident

209+ => Qualified Ident

174 -> m NameVisibility

210 -> m NameVisibility

175−getVisibility currentModule (Qualified moduleName var) = do

211+getVisibility qual = do

176 env <- getEnv

212 env <- getEnv

177− case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

213+ case M.lookup qual (names env) of

178− Nothing -> throwError . errorMessage $ NameIsUndefined var

214+ Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual)

179 Just (_, _, vis) -> return vis

215 Just (_, _, vis) -> return vis

180

216

181-- | Assert that a name is visible

217-- | Assert that a name is visible

182checkVisibility

218checkVisibility

183 :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

219 :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

184− => ModuleName

185− -> Qualified Ident

220+ => Qualified Ident

186 -> m ()

221 -> m ()

187−checkVisibility currentModule name@(Qualified _ var) = do

222+checkVisibility name@(Qualified _ var) = do

188− vis <- getVisibility currentModule name

223+ vis <- getVisibility name

189 case vis of

224 case vis of

190 Undefined -> throwError . errorMessage $ CycleInDeclaration var

225 Undefined -> throwError . errorMessage $ CycleInDeclaration var

191 _ -> return ()

226 _ -> return ()

@@ -206,6 +241,12 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do

206getEnv :: (MonadState CheckState m) => m Environment

241getEnv :: (MonadState CheckState m) => m Environment

207getEnv = checkEnv <$> get

242getEnv = checkEnv <$> get

208

243

244+-- | Get locally-bound names in context, to create an error message.

245+getLocalContext :: MonadState CheckState m => m Context

246+getLocalContext = do

247+ env <- getEnv

248+ return [ (ident, ty') | ((Qualified Nothing ident@Ident{}), (ty', _, Defined)) <- M.toList (names env) ]

249+

209-- | Update the @Environment@

250-- | Update the @Environment@

210putEnv :: (MonadState CheckState m) => Environment -> m ()

251putEnv :: (MonadState CheckState m) => Environment -> m ()

211putEnv env = modify (\s -> s { checkEnv = env })

252putEnv env = modify (\s -> s { checkEnv = env })

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

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

8import Prelude.Compat

9

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

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

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

12

13import Data.List (sortBy)

14import Data.Ord (comparing)

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

24

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

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

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

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

28

29-- | Check tahat one type subsumes another

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

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

52 subsumes val ty1 ty2

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

54 dicts <- getTypeClassDictionaries

55+ hints <- gets checkHints

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

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

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

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

57 let

58 let

58 (ts1, r1') = rowToList r1

59 (ts1, r1') = rowToList r1

src/Language/PureScript/TypeChecker/Types.hs+60−66

@@ -26,7 +26,6 @@ module Language.PureScript.TypeChecker.Types

26

27import Prelude.Compat

28

29−import Control.Arrow (second)

30import Control.Monad

29import Control.Monad

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

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

32import Control.Monad.State.Class (MonadState(..), gets)

31import Control.Monad.State.Class (MonadState(..), gets)

@@ -71,7 +70,7 @@ typesOf ::

71 m [(Ident, (Expr, Type))]

70 m [(Ident, (Expr, Type))]

72typesOf bindingGroupType moduleName vals = do

71typesOf bindingGroupType moduleName vals = do

73 tys <- fmap tidyUp . escalateWarningWhen isHoleError . liftUnifyWarnings replace $ do

72 tys <- fmap tidyUp . escalateWarningWhen isHoleError . liftUnifyWarnings replace $ do

74− (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

73+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals

75 ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

74 ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

76 ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

75 ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

77 return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)

76 return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)

@@ -117,26 +116,21 @@ typesOf bindingGroupType moduleName vals = do

117 tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts

116 tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts

118

117

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

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

120− replace sub (ErrorMessage hints (WildcardInferredType ty)) =

121− ErrorMessage hints . WildcardInferredType $ substituteType sub ty

122− replace sub (ErrorMessage hints (HoleInferredType name ty env)) =

123− ErrorMessage hints $ HoleInferredType name (substituteType sub ty)

124− (map (second (substituteType sub)) env)

119+ replace sub = onTypesInErrorMessage (substituteType sub)

125− replace _ em = em

126

120

127 isHoleError :: ErrorMessage -> Bool

121 isHoleError :: ErrorMessage -> Bool

128 isHoleError (ErrorMessage _ HoleInferredType{}) = True

122 isHoleError (ErrorMessage _ HoleInferredType{}) = True

129 isHoleError _ = False

123 isHoleError _ = False

130

124

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

125+type TypeData = M.Map (Qualified Ident) (Type, NameKind, NameVisibility)

132

126

133type UntypedData = [(Ident, Type)]

127type UntypedData = [(Ident, Type)]

134

128

135−typeDictionaryForBindingGroup ::

129+typeDictionaryForBindingGroup

136− (MonadState CheckState m) =>

130+ :: (MonadState CheckState m)

137− ModuleName ->

131+ => Maybe ModuleName

138− [(Ident, Expr)] ->

132+ -> [(Ident, Expr)]

139− m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)

133+ -> m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)

140typeDictionaryForBindingGroup moduleName vals = do

134typeDictionaryForBindingGroup moduleName vals = do

141 let

135 let

142 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed

136 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed

@@ -154,15 +148,15 @@ typeDictionaryForBindingGroup moduleName vals = do

154 -- Make a map of names to the unification variables of untyped declarations

148 -- Make a map of names to the unification variables of untyped declarations

155 untypedDict = zip (map fst untyped) untypedNames

149 untypedDict = zip (map fst untyped) untypedNames

156 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking

150 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking

157− dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict)

151+ dict = M.fromList (map (\(ident, ty) -> ((Qualified moduleName ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict)

158 return (untyped, typed, dict, untypedDict)

152 return (untyped, typed, dict, untypedDict)

159

153

160−checkTypedBindingGroupElement ::

154+checkTypedBindingGroupElement

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

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

162− ModuleName ->

156+ => ModuleName

163− (Ident, (Expr, Type, Bool)) ->

157+ -> (Ident, (Expr, Type, Bool))

164− TypeData ->

158+ -> TypeData

165− m (Ident, (Expr, Type))

159+ -> m (Ident, (Expr, Type))

166checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

160checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

167 -- Replace type wildcards

161 -- Replace type wildcards

168 ty' <- replaceTypeWildcards ty

162 ty' <- replaceTypeWildcards ty

@@ -176,12 +170,12 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

176 else return (TypedValue False val' ty'')

170 else return (TypedValue False val' ty'')

177 return (ident, (val'', ty''))

171 return (ident, (val'', ty''))

178

172

179−typeForBindingGroupElement ::

173+typeForBindingGroupElement

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

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

181− (Ident, Expr) ->

175+ => (Ident, Expr)

182− TypeData ->

176+ -> TypeData

183− UntypedData ->

177+ -> UntypedData

184− m (Ident, (Expr, Type))

178+ -> m (Ident, (Expr, Type))

185typeForBindingGroupElement (ident, val) dict untypedDict = do

179typeForBindingGroupElement (ident, val) dict untypedDict = do

186 -- Infer the type with the new names in scope

180 -- Infer the type with the new names in scope

187 TypedValue _ val' ty <- bindNames dict $ infer val

181 TypedValue _ val' ty <- bindNames dict $ infer val

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

201 where

195 where

202 g :: Expr -> Expr

196 g :: Expr -> Expr

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

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

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

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

205 g other = other

199 g other = other

206

200

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

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

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

227 instantiatePolyTypeWithUnknowns val ty'

221 instantiatePolyTypeWithUnknowns val ty'

228instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

222instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

229 dicts <- getTypeClassDictionaries

223 dicts <- getTypeClassDictionaries

224+ hints <- gets checkHints

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

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

231instantiatePolyTypeWithUnknowns val ty = return (val, ty)

226instantiatePolyTypeWithUnknowns val ty = return (val, ty)

232

227

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

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

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

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

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

236 Expr ->

231 Expr ->

237 m Expr

232 m Expr

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

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

239

234

240-- | Infer a type for a value

235-- | Infer a type for a value

241infer' ::

236infer' ::

@@ -250,8 +245,11 @@ infer' v@(Literal (BooleanLiteral _)) = return $ TypedValue True v tyBoolean

250infer' (Literal (ArrayLiteral vals)) = do

245infer' (Literal (ArrayLiteral vals)) = do

251 ts <- traverse infer vals

246 ts <- traverse infer vals

252 els <- freshType

247 els <- freshType

248+ ts' <- forM ts $ \(TypedValue ch val t) -> do

249+ (val', t') <- instantiatePolyTypeWithUnknowns val t

253− forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t

250+ unifyTypes els t'

251+ return (TypedValue ch val' t')

254− return $ TypedValue True (Literal (ArrayLiteral ts)) (TypeApp tyArray els)

252+ return $ TypedValue True (Literal (ArrayLiteral ts')) (TypeApp tyArray els)

255infer' (Literal (ObjectLiteral ps)) = do

253infer' (Literal (ObjectLiteral ps)) = do

256 ensureNoDuplicateProperties ps

254 ensureNoDuplicateProperties ps

257 ts <- traverse (infer . snd) ps

255 ts <- traverse (infer . snd) ps

@@ -267,15 +265,14 @@ infer' (ObjectUpdate o ps) = do

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

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

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

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

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

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

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

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

271 field <- freshType

269 field <- freshType

272 rest <- freshType

270 rest <- freshType

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

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

274 return $ TypedValue True (Accessor prop typed) field

272 return $ TypedValue True (Accessor prop typed) field

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

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

276 ty <- freshType

274 ty <- freshType

277− Just moduleName <- checkCurrentModule <$> get

278− withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do

275+ withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do

279 body@(TypedValue _ _ bodyTy) <- infer' ret

276 body@(TypedValue _ _ bodyTy) <- infer' ret

280 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy

277 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy

281infer' (Abs (Right _) _) = internalError "Binder was not desugared"

278infer' (Abs (Right _) _) = internalError "Binder was not desugared"

@@ -284,13 +281,13 @@ infer' (App f arg) = do

284 (ret, app) <- checkFunctionApplication f' ft arg Nothing

281 (ret, app) <- checkFunctionApplication f' ft arg Nothing

285 return $ TypedValue True app ret

282 return $ TypedValue True app ret

286infer' (Var var) = do

283infer' (Var var) = do

287− Just moduleName <- checkCurrentModule <$> get

288− checkVisibility moduleName var

284+ checkVisibility var

289− ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable moduleName $ var

285+ ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var

290 case ty of

286 case ty of

291 ConstrainedType constraints ty' -> do

287 ConstrainedType constraints ty' -> do

292 dicts <- getTypeClassDictionaries

288 dicts <- getTypeClassDictionaries

289+ hints <- gets checkHints

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

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

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

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

295infer' v@(Constructor c) = do

292infer' v@(Constructor c) = do

296 env <- getEnv

293 env <- getEnv

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

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

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

317infer' (SuperClassDictionary className tys) = do

314infer' (SuperClassDictionary className tys) = do

318 dicts <- getTypeClassDictionaries

315 dicts <- getTypeClassDictionaries

316+ hints <- gets checkHints

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

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

320infer' (TypedValue checkType val ty) = do

318infer' (TypedValue checkType val ty) = do

321 Just moduleName <- checkCurrentModule <$> get

319 Just moduleName <- checkCurrentModule <$> get

322 (kind, args) <- kindOfWithScopedVars ty

320 (kind, args) <- kindOfWithScopedVars ty

@@ -326,12 +324,10 @@ infer' (TypedValue checkType val ty) = do

326 return $ TypedValue True val' ty'

324 return $ TypedValue True val' ty'

327infer' (Hole name) = do

325infer' (Hole name) = do

328 ty <- freshType

326 ty <- freshType

329− env <- M.toList . names <$> getEnv

327+ ctx <- getLocalContext

330− Just moduleName <- checkCurrentModule <$> get

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

332 tell . errorMessage $ HoleInferredType name ty ctx

328 tell . errorMessage $ HoleInferredType name ty ctx

333 return $ TypedValue True (Hole name) ty

329 return $ TypedValue True (Hole name) ty

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

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

335 TypedValue t v ty <- infer' val

331 TypedValue t v ty <- infer' val

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

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

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

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

@@ -348,27 +344,26 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue

348 Just moduleName <- checkCurrentModule <$> get

344 Just moduleName <- checkCurrentModule <$> get

349 (kind, args) <- kindOfWithScopedVars ty

345 (kind, args) <- kindOfWithScopedVars ty

350 checkTypeKind ty kind

346 checkTypeKind ty kind

351− let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)

347+ let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined)

352 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

348 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

353 TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv

349 TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv

354− bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j

350+ bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j

355inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do

351inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do

356 valTy <- freshType

352 valTy <- freshType

357− Just moduleName <- checkCurrentModule <$> get

358− let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined)

353+ let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined)

359 TypedValue _ val' valTy' <- bindNames dict $ infer val

354 TypedValue _ val' valTy' <- bindNames dict $ infer val

360 unifyTypes valTy valTy'

355 unifyTypes valTy valTy'

361− bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j

356+ bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j

362inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

357inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

363 Just moduleName <- checkCurrentModule <$> get

358 Just moduleName <- checkCurrentModule <$> get

364− (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

359+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds)

365 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

360 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

366 ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

361 ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

367 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']

362 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']

368 bindNames dict $ do

363 bindNames dict $ do

369 makeBindingGroupVisible

364 makeBindingGroupVisible

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

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

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

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

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

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

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

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

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

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

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

426 m <- inferBinder val binder

421 m <- inferBinder val binder

427 return $ M.insert name val m

422 return $ M.insert name val m

428inferBinder val (PositionedBinder pos _ binder) =

423inferBinder val (PositionedBinder pos _ binder) =

429− warnAndRethrowWithPosition pos $ inferBinder val binder

424+ warnAndRethrowWithPositionTC pos $ inferBinder val binder

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

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

431-- change the definition of `binderRequiresMonotype`,

426-- change the definition of `binderRequiresMonotype`,

432-- and use `kindOfWithScopedVars`.

427-- and use `kindOfWithScopedVars`.

@@ -480,14 +475,13 @@ checkBinders _ _ [] = return []

480checkBinders nvals ret (CaseAlternative binders result : bs) = do

475checkBinders nvals ret (CaseAlternative binders result : bs) = do

481 guardWith (errorMessage $ OverlappingArgNames Nothing) $

476 guardWith (errorMessage $ OverlappingArgNames Nothing) $

482 let ns = concatMap binderNames binders in length (nub ns) == length ns

477 let ns = concatMap binderNames binders in length (nub ns) == length ns

483− Just moduleName <- checkCurrentModule <$> get

484 m1 <- M.unions <$> zipWithM inferBinder nvals binders

478 m1 <- M.unions <$> zipWithM inferBinder nvals binders

485− r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $

479+ r <- bindLocalVariables [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $

486 CaseAlternative binders <$>

480 CaseAlternative binders <$>

487 case result of

481 case result of

488 Left gs -> do

482 Left gs -> do

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

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

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

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

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

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

492 return (grd', val')

486 return (grd', val')

493 return $ Left gs'

487 return $ Left gs'

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

505 Expr ->

499 Expr ->

506 Type ->

500 Type ->

507 m Expr

501 m Expr

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

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

509

503

510-- |

504-- |

511-- Check the type of a value

505-- Check the type of a value

@@ -574,8 +568,7 @@ check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do

574 return $ TypedValue True array t

568 return $ TypedValue True array t

575check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

569check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

576 unifyTypes t tyFunction

570 unifyTypes t tyFunction

577− Just moduleName <- checkCurrentModule <$> get

578− ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy

571+ ret' <- withBindingGroupVisible $ bindLocalVariables [(arg, argTy, Defined)] $ check ret retTy

579 return $ TypedValue True (Abs (Left arg) ret') ty

572 return $ TypedValue True (Abs (Left arg) ret') ty

580check' (Abs (Right _) _) _ = internalError "Binder was not desugared"

573check' (Abs (Right _) _) _ = internalError "Binder was not desugared"

581check' (App f arg) ret = do

574check' (App f arg) ret = do

@@ -583,9 +576,8 @@ check' (App f arg) ret = do

583 (_, app) <- checkFunctionApplication f' ft arg (Just ret)

576 (_, app) <- checkFunctionApplication f' ft arg (Just ret)

584 return $ TypedValue True app ret

577 return $ TypedValue True app ret

585check' v@(Var var) ty = do

578check' v@(Var var) ty = do

586− Just moduleName <- checkCurrentModule <$> get

587− checkVisibility moduleName var

579+ checkVisibility var

588− repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var

580+ repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var

589 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

581 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

590 v' <- subsumes (Just v) repl ty'

582 v' <- subsumes (Just v) repl ty'

591 case v' of

583 case v' of

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

599 -- declaration gets desugared.

591 -- declaration gets desugared.

600 -}

592 -}

601 dicts <- getTypeClassDictionaries

593 dicts <- getTypeClassDictionaries

594+ hints <- gets checkHints

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

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

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

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

604 Just moduleName <- checkCurrentModule <$> get

597 Just moduleName <- checkCurrentModule <$> get

605 (kind, args) <- kindOfWithScopedVars ty1

598 (kind, args) <- kindOfWithScopedVars ty1

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

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

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

639 ps' <- checkProperties e ps row True

632 ps' <- checkProperties e ps row True

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

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

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

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

642 rest <- freshType

635 rest <- freshType

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

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

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

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

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

659 checkTypeKind ty kind

652 checkTypeKind ty kind

660 val' <- check' val ty

653 val' <- check' val ty

661 return $ TypedValue True val' kt

654 return $ TypedValue True val' kt

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

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

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

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

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

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

665check' val ty = do

658check' val ty = do

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

713 Expr ->

706 Expr ->

714 Maybe Type ->

707 Maybe Type ->

715 m (Type, Expr)

708 m (Type, Expr)

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

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

717 subst <- gets checkSubstitution

710 subst <- gets checkSubstitution

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

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

719

712

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

749 checkFunctionApplication fn ty arg ret

742 checkFunctionApplication fn ty arg ret

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

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

751 dicts <- getTypeClassDictionaries

744 dicts <- getTypeClassDictionaries

745+ hints <- gets checkHints

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

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

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

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

754 return (fnTy, App fn dict)

748 return (fnTy, App fn dict)

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

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

src/Language/PureScript/TypeChecker/Unify.hs+9−5

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

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

81unifyTypes t1 t2 = do

82 sub <- gets checkSubstitution

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

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

84 where

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

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

@@ -112,9 +112,11 @@ unifyTypes t1 t2 = do

112 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2

113 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

114 unifyTypes' r1 r2@REmpty = unifyRows r1 r2

115+ unifyTypes' ty1@(ConstrainedType _ _) ty2 =

115− unifyTypes' ty1@(ConstrainedType _ _) ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2

116+ throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2

116 unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3

117 unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3

118+ unifyTypes' t3 t4 =

117− unifyTypes' t3 t4 = throwError . errorMessage $ TypesDoNotUnify t3 t4

119+ throwError . errorMessage $ TypesDoNotUnify t3 t4

118

120

119-- |

121-- |

120-- Unify two rows, updating the current substitution

122-- Unify two rows, updating the current substitution

@@ -147,7 +149,8 @@ unifyRows r1 r2 =

147 unifyRows' [] REmpty [] REmpty = return ()

149 unifyRows' [] REmpty [] REmpty = return ()

148 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

150 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

149 unifyRows' [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = return ()

151 unifyRows' [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = return ()

152+ unifyRows' _ _ _ _ =

150− unifyRows' _ _ _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2

153+ throwError . errorMessage $ TypesDoNotUnify r1 r2

151

154

152-- |

155-- |

153-- Check that two types unify

156-- Check that two types unify

@@ -195,7 +198,8 @@ replaceTypeWildcards = everywhereOnTypesM replace

195 where

198 where

196 replace (TypeWildcard ss) = do

199 replace (TypeWildcard ss) = do

197 t <- freshType

200 t <- freshType

201+ ctx <- getLocalContext

198− warnWithPosition ss $ tell . errorMessage $ WildcardInferredType t

202+ warnWithPosition ss $ tell . errorMessage $ WildcardInferredType t ctx

199 return t

203 return t

200 replace other = return other

204 replace other = return other

201

205

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

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

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

22 , tcdDependencies :: Maybe [Constraint]

23 }

24− deriving (Show, Read)

24+ deriving (Show)

25

26-- |

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

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

44 -- A subclass dictionary

45 --

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

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

47+ deriving (Show, Ord, Eq)

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

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

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

24--

25newtype SkolemScope = SkolemScope { runSkolemScope :: Int }

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

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

27

28-- |

29-- The type of types

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

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

72 -- since it prevents certain traversals from matching.

73 | ParensInType Type

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

74+ deriving (Show, Eq, Ord)

75

76-- | Additional data relevant to type class constraints

77data ConstraintData

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

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

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

83 -- dependency in the module graph.

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

84+ deriving (Show, Eq, Ord)

85

86-- | A typeclass constraint

87data Constraint = Constraint

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

91 -- ^ type arguments

92 , constraintData :: Maybe ConstraintData

93 -- ^ additional data relevant to this constraint

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

94+ } deriving (Show, Eq, Ord)

95

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

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

stack-ghc-8.0.yaml+1−1

@@ -1,4 +1,4 @@

1−resolver: nightly-2016-05-29

1+resolver: nightly-2016-07-19

2packages:

3- '.'

4extra-deps:

stack.yaml+7−3

@@ -1,5 +1,9 @@

1−resolver: lts-6.1

1+resolver: lts-6.10

2packages:

3- '.'

4−extra-deps: []

4+extra-deps:

5+- aeson-1.0.0.0

6+- semigroups-0.18.2

5−flags: {}

7+flags:

8+ semigroups:

9+ bytestring-builder: false

tests/Language/PureScript/Ide/ImportsSpec.hs+1−1

@@ -3,7 +3,7 @@

3module Language.PureScript.Ide.ImportsSpec where

4

5import Protolude

6−import Unsafe (fromJust)

6+import Data.Maybe (fromJust)

7

8import qualified Language.PureScript as P

9import Language.PureScript.Ide.Imports

tests/Language/PureScript/Ide/Integration.hs+1−1

@@ -48,7 +48,7 @@ module Language.PureScript.Ide.Integration

48 ) where

49

50import Protolude

51−import Unsafe (fromJust)

51+import Data.Maybe (fromJust)

52

53import Data.Aeson

54import Data.Aeson.Types

tests/TestPscPublish.hs+1−1

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

30 = ParseFailed String

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

32 | Pass ByteString

33− deriving (Show, Read)

33+ deriving (Show)

34

35roundTrip :: UploadedPackage -> TestResult

36roundTrip pkg =