67f9282 · elk · git.iko.soy

.travis.yml+17−13

@@ -4,28 +4,32 @@

4

5# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.

6env:

7− - GHCVER=7.6.3

7+ - CABALVER=1.18 GHCVER=7.6.3

8− - GHCVER=7.8.2

8+ - CABALVER=1.18 GHCVER=7.8.3

9+ - CABALVER=1.22 GHCVER=7.10.1

10+

9

11

10# Note: the distinction between `before_install` and `install` is not important.

12# Note: the distinction between `before_install` and `install` is not important.

11before_install:

13before_install:

12 - travis_retry sudo add-apt-repository -y ppa:hvr/ghc

14 - travis_retry sudo add-apt-repository -y ppa:hvr/ghc

13 - travis_retry sudo apt-get update

15 - travis_retry sudo apt-get update

14− - travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy alex # see note about happy/alex

16+ - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex

15− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:$PATH

17+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH

16− - cabal update

17− # Update happy when building with GHC 7.8 or head

18 - |

19− if [ $GHCVER = "head" ] || [ $GHCVER = "7.8.2" ]; then

19+ if [ ${GHCVER%.*} = "7.8" ] || [ ${GHCVER%.*} = "7.10" ]; then

20− cabal install happy alex

20+ travis_retry sudo apt-get install happy-1.19.4 alex-3.1.3

21− export PATH=$HOME/.cabal/bin:$PATH

21+ export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:$PATH

22+ else

23+ travis_retry sudo apt-get install happy alex

22− fi

24+ fi

25+

23

26

24install:

27install:

28+ - travis_retry cabal update

25− - cabal install --only-dependencies --enable-tests --enable-benchmarks

29+ - cabal install --only-dependencies --enable-tests

30+

26

31

27−# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.

28script:

32script:

29 - cabal configure --enable-tests

33 - cabal configure --enable-tests

30 - cabal build

34 - cabal build

31− - cabal test

35+ - cabal test

README.md+1−1

@@ -1,6 +1,6 @@

1Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).

2

3−[![Build Status](https://travis-ci.org/elm-lang/elm-compiler.png)](https://travis-ci.org/elm-lang/elm-compiler)

3+[![Build Status](https://travis-ci.org/elm-lang/elm-compiler.svg)](https://travis-ci.org/elm-lang/elm-compiler)

4

5## Install

6

Setup.hsnew file+2

@@ -0,0 +1,2 @@

1+import Distribution.Simple

2+main = defaultMain

elm-compiler.cabal+22−77

@@ -1,6 +1,6 @@

1

2Name: elm-compiler

3−Version: 0.15

3+Version: 0.15.1

4

5Synopsis:

6 Values to help with elm-package, elm-make, and elm-lang.org.

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

33

34Library

35 ghc-options:

36− -threaded -O2 -W -Werror

36+ -O2 -W

37

38 Hs-Source-Dirs:

39 src

@@ -49,6 +49,7 @@ Library

49 AST.Declaration,

50 AST.Expression.Canonical,

51 AST.Expression.General,

52+ AST.Expression.Optimized,

52 AST.Expression.Source,

53 AST.Expression.Source,

53 AST.Expression.Valid,

54 AST.Expression.Valid,

54 AST.Helpers,

55 AST.Helpers,

@@ -67,15 +68,22 @@ Library

67 Canonicalize.Type,

68 Canonicalize.Type,

68 Canonicalize.Variable,

69 Canonicalize.Variable,

69 Compile,

70 Compile,

71+ Docs.AST,

72+ Docs.Centralize,

73+ Docs.Check,

70 Elm.Compiler.Imports,

74 Elm.Compiler.Imports,

71 Elm.Compiler.Type.Extract,

75 Elm.Compiler.Type.Extract,

72 Elm.Compiler.Version,

76 Elm.Compiler.Version,

73− Generate.Cases,

74 Generate.JavaScript,

77 Generate.JavaScript,

78+ Generate.JavaScript.Crash,

75 Generate.JavaScript.Helpers,

79 Generate.JavaScript.Helpers,

76 Generate.JavaScript.Port,

80 Generate.JavaScript.Port,

77 Generate.JavaScript.Variable,

81 Generate.JavaScript.Variable,

82+ Nitpick.TopLevelTypes,

83+ Optimize,

84+ Optimize.Cases,

78− Generate.Substitute,

85+ Optimize.Substitute,

86+ Optimize.TailCalls,

79 Parse.Binop,

87 Parse.Binop,

80 Parse.Declaration,

88 Parse.Declaration,

81 Parse.Expression,

89 Parse.Expression,

@@ -86,8 +94,11 @@ Library

86 Parse.Pattern,

94 Parse.Pattern,

87 Parse.Type,

95 Parse.Type,

88 Reporting.Annotation,

96 Reporting.Annotation,

97+ Reporting.Crash,

89 Reporting.Error,

98 Reporting.Error,

90 Reporting.Error.Canonicalize,

99 Reporting.Error.Canonicalize,

100+ Reporting.Error.Docs,

101+ Reporting.Error.Helpers,

91 Reporting.Error.Syntax,

102 Reporting.Error.Syntax,

92 Reporting.Error.Type,

103 Reporting.Error.Type,

93 Reporting.PrettyPrint,

104 Reporting.PrettyPrint,

@@ -99,7 +110,6 @@ Library

99 Type.Constrain.Literal,

110 Type.Constrain.Literal,

100 Type.Constrain.Pattern,

111 Type.Constrain.Pattern,

101 Type.Environment,

112 Type.Environment,

102− Type.ExtraChecks,

103 Type.Fragment,

113 Type.Fragment,

104 Type.Inference,

114 Type.Inference,

105 Type.PrettyPrint,

115 Type.PrettyPrint,

@@ -113,6 +123,7 @@ Library

113 Build-depends:

123 Build-depends:

114 aeson >= 0.7 && < 0.9,

124 aeson >= 0.7 && < 0.9,

115 aeson-pretty >= 0.7 && < 0.8,

125 aeson-pretty >= 0.7 && < 0.8,

126+ ansi-terminal >= 0.6.2.1 && < 0.7,

116 base >=4.2 && <5,

127 base >=4.2 && <5,

117 binary >= 0.7.0.0 && < 0.8,

128 binary >= 0.7.0.0 && < 0.8,

118 blaze-html >= 0.5 && < 0.8,

129 blaze-html >= 0.5 && < 0.8,

@@ -125,7 +136,7 @@ Library

125 filepath >= 1 && < 2.0,

136 filepath >= 1 && < 2.0,

126 indents >= 0.3 && < 0.4,

137 indents >= 0.3 && < 0.4,

127 language-ecmascript >= 0.15 && < 0.18,

138 language-ecmascript >= 0.15 && < 0.18,

128− language-glsl >= 0.0.2 && < 0.2,

139+ language-glsl >= 0.0.2 && < 0.3,

129 mtl >= 2.2 && < 3,

140 mtl >= 2.2 && < 3,

130 parsec >= 3.1.1 && < 3.5,

141 parsec >= 3.1.1 && < 3.5,

131 pretty >= 1.0 && < 2.0,

142 pretty >= 1.0 && < 2.0,

@@ -136,56 +147,6 @@ Library

136 unordered-containers >= 0.1 && < 0.3

147 unordered-containers >= 0.1 && < 0.3

137

148

138

149

139−Executable elm-doc

140− ghc-options:

141− -threaded -O2 -W

142−

143− Hs-Source-Dirs:

144− src

145−

146− Main-is:

147− Docs.hs

148−

149− other-modules:

150− Elm.Compiler.Version,

151− AST.Declaration,

152− AST.Expression.General,

153− AST.Helpers,

154− AST.Literal,

155− AST.Module,

156− AST.Pattern,

157− AST.Type,

158− AST.Variable,

159− Parse.Binop,

160− Parse.Declaration,

161− Parse.Expression,

162− Parse.Helpers,

163− Parse.Literal,

164− Parse.Module,

165− Parse.Pattern,

166− Parse.Type

167−

168− Build-depends:

169− aeson >= 0.7 && < 0.9,

170− aeson-pretty >= 0.7 && < 0.8,

171− base >=4.2 && <5,

172− binary >= 0.7.0.0 && < 0.8,

173− bytestring >= 0.9 && < 0.11,

174− cmdargs >= 0.7 && < 0.11,

175− containers >= 0.3 && < 0.6,

176− directory >= 1.0 && < 2.0,

177− filepath >= 1 && < 2.0,

178− indents >= 0.3 && < 0.4,

179− language-glsl >= 0.0.2 && < 0.2,

180− mtl >= 2.2 && < 3,

181− parsec >= 3.1.1 && < 3.5,

182− pretty >= 1.0 && < 2.0,

183− process,

184− text >= 1 && < 2,

185− transformers >= 0.2 && < 0.5,

186− union-find >= 0.2 && < 0.3

187−

188−

189Executable elm

150Executable elm

190 ghc-options:

151 ghc-options:

191 -threaded -O2 -W

152 -threaded -O2 -W

@@ -200,24 +161,9 @@ Executable elm

200 Elm.Compiler.Version

161 Elm.Compiler.Version

201

162

202 Build-depends:

163 Build-depends:

203− aeson >= 0.7 && < 0.9,

204− aeson-pretty >= 0.7 && < 0.8,

205 base >=4.2 && <5,

164 base >=4.2 && <5,

206− binary >= 0.7.0.0 && < 0.8,

207− bytestring >= 0.9 && < 0.11,

208− cmdargs >= 0.7 && < 0.11,

209− containers >= 0.3 && < 0.6,

210 directory >= 1.0 && < 2.0,

165 directory >= 1.0 && < 2.0,

211− filepath >= 1 && < 2.0,

212− indents >= 0.3 && < 0.4,

213− language-glsl >= 0.0.2 && < 0.2,

214− mtl >= 2.2 && < 3,

215− parsec >= 3.1.1 && < 3.5,

216− pretty >= 1.0 && < 2.0,

217− process,

166+ process

218− text >= 1 && < 2,

219− transformers >= 0.2 && < 0.5,

220− union-find >= 0.2 && < 0.3

221

167

222

168

223Test-Suite compiler-tests

169Test-Suite compiler-tests

@@ -236,7 +182,7 @@ Test-Suite compiler-tests

236 Test.Property.Arbitrary

182 Test.Property.Arbitrary

237 AST.Helpers

183 AST.Helpers

238 AST.Literal

184 AST.Literal

239− AST.PrettyPrint

185+ Reporting.PrettyPrint

240

186

241 build-depends:

187 build-depends:

242 test-framework > 0.8 && < 0.9,

188 test-framework > 0.8 && < 0.9,

@@ -246,6 +192,7 @@ Test-Suite compiler-tests

246 QuickCheck >= 2 && < 3,

192 QuickCheck >= 2 && < 3,

247 aeson >= 0.7 && < 0.9,

193 aeson >= 0.7 && < 0.9,

248 aeson-pretty >= 0.7 && < 0.8,

194 aeson-pretty >= 0.7 && < 0.8,

195+ ansi-terminal >= 0.6.2.1 && < 0.7,

249 base >=4.2 && <5,

196 base >=4.2 && <5,

250 binary >= 0.7.0.0 && < 0.8,

197 binary >= 0.7.0.0 && < 0.8,

251 blaze-html >= 0.5 && < 0.8,

198 blaze-html >= 0.5 && < 0.8,

@@ -260,13 +207,11 @@ Test-Suite compiler-tests

260 filepath >= 1 && < 2.0,

207 filepath >= 1 && < 2.0,

261 indents >= 0.3 && < 0.4,

208 indents >= 0.3 && < 0.4,

262 language-ecmascript >= 0.15 && < 0.18,

209 language-ecmascript >= 0.15 && < 0.18,

263− language-glsl >= 0.0.2 && < 0.2,

210+ language-glsl >= 0.0.2 && < 0.3,

264 mtl >= 2.2 && < 3,

211 mtl >= 2.2 && < 3,

265 parsec >= 3.1.1 && < 3.5,

212 parsec >= 3.1.1 && < 3.5,

266 pretty >= 1.0 && < 2.0,

213 pretty >= 1.0 && < 2.0,

267 process,

214 process,

268 text >= 1 && < 2,

215 text >= 1 && < 2,

269 transformers >= 0.2 && < 0.5,

216 transformers >= 0.2 && < 0.5,

270− union-find >= 0.2 && < 0.3,

217+ union-find >= 0.2 && < 0.3

271− unordered-containers >= 0.1 && < 0.3

272−

src/AST/Declaration.hs+5−4

@@ -41,16 +41,17 @@ type SourceDecl' =

41 Declaration' SourcePort Source.Def Type.Raw Source.Expr

42

43

44−type SourceDecl =

44+data SourceDecl

45+ = Comment String

45− A.Located SourceDecl'

46+ | Decl (A.Located SourceDecl')

46

47

48

48type ValidDecl =

49type ValidDecl =

49− A.Located (Declaration' ValidPort Valid.Def Type.Raw Valid.Expr)

50+ A.Commented (Declaration' ValidPort Valid.Def Type.Raw Valid.Expr)

50

51

52

52type CanonicalDecl =

53type CanonicalDecl =

53− A.Located (Declaration' CanonicalPort Canonical.Def Type.Canonical Canonical.Expr)

54+ A.Commented (Declaration' CanonicalPort Canonical.Def Type.Canonical Canonical.Expr)

54

55

56

56-- PORTS

57-- PORTS

src/AST/Expression/Canonical.hs+9−4

@@ -7,6 +7,7 @@ import qualified AST.Expression.General as General

7import qualified AST.Pattern as Pattern

8import qualified AST.Type as Type

9import qualified AST.Variable as Var

10+import qualified Reporting.Annotation as A

10import qualified Reporting.PrettyPrint as P

11import qualified Reporting.PrettyPrint as P

11import qualified Reporting.Region as R

12import qualified Reporting.Region as R

12

13

@@ -23,16 +24,18 @@ type Expr' =

23

24

25

25data Def

26data Def

26− = Definition Pattern.CanonicalPattern Expr (Maybe Type.Canonical)

27+ = Definition Pattern.CanonicalPattern Expr (Maybe (A.Located Type.Canonical))

27 deriving (Show)

28 deriving (Show)

28

29

30

30instance P.Pretty Def where

31instance P.Pretty Def where

31− pretty _ (Definition pattern expr maybeTipe) =

32+ pretty dealiaser _ (Definition pattern expr maybeTipe) =

32 P.vcat [ annotation, definition ]

33 P.vcat [ annotation, definition ]

33 where

34 where

34 definition =

35 definition =

35− P.pretty True pattern <+> P.equals <+> P.pretty False expr

36+ P.pretty dealiaser True pattern

37+ <+> P.equals

38+ <+> P.pretty dealiaser False expr

36

39

37 annotation =

40 annotation =

38 case maybeTipe of

41 case maybeTipe of

@@ -40,4 +43,6 @@ instance P.Pretty Def where

40 P.empty

43 P.empty

41

44

42 Just tipe ->

45 Just tipe ->

43− P.pretty True pattern <+> P.colon <+> P.pretty False tipe

46+ P.pretty dealiaser True pattern

47+ <+> P.colon

48+ <+> P.pretty dealiaser False tipe

src/AST/Expression/General.hs+56−38

@@ -16,6 +16,7 @@ import qualified AST.Pattern as Pattern

16import qualified AST.Type as Type

17import qualified AST.Variable as Var

18import qualified Reporting.Annotation as A

19+import qualified Reporting.Crash as Crash

19import qualified Reporting.PrettyPrint as P

20import qualified Reporting.PrettyPrint as P

20

21

22

@@ -48,7 +49,7 @@ data Expr' ann def var typ

48 | Binop var (Expr ann def var typ) (Expr ann def var typ)

49 | Binop var (Expr ann def var typ) (Expr ann def var typ)

49 | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)

50 | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)

50 | App (Expr ann def var typ) (Expr ann def var typ)

51 | App (Expr ann def var typ) (Expr ann def var typ)

51− | MultiIf [(Expr ann def var typ,Expr ann def var typ)]

52+ | MultiIf [(Expr ann def var typ, Expr ann def var typ)] (Expr ann def var typ)

52 | Let [def] (Expr ann def var typ)

53 | Let [def] (Expr ann def var typ)

53 | Case (Expr ann def var typ) [(Pattern.Pattern ann var, Expr ann def var typ)]

54 | Case (Expr ann def var typ) [(Pattern.Pattern ann var, Expr ann def var typ)]

54 | Data String [Expr ann def var typ]

55 | Data String [Expr ann def var typ]

@@ -60,6 +61,7 @@ data Expr' ann def var typ

60 -- for type checking and code gen only

61 -- for type checking and code gen only

61 | Port (PortImpl (Expr ann def var typ) typ)

62 | Port (PortImpl (Expr ann def var typ) typ)

62 | GLShader String String Literal.GLShaderTipe

63 | GLShader String String Literal.GLShaderTipe

64+ | Crash Crash.Details

63 deriving (Show)

65 deriving (Show)

64

66

65

67

@@ -113,64 +115,75 @@ dummyLet defs =

113-- PRETTY PRINTING

115-- PRETTY PRINTING

114

116

115instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann def var typ) where

117instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann def var typ) where

116− pretty needsParens expression =

118+ pretty dealiaser needsParens expression =

117 case expression of

119 case expression of

118 Literal literal ->

120 Literal literal ->

119− P.pretty needsParens literal

121+ P.pretty dealiaser needsParens literal

120

122

121 Var x ->

123 Var x ->

122− P.pretty needsParens x

124+ P.pretty dealiaser needsParens x

123

125

124 Range lowExpr highExpr ->

126 Range lowExpr highExpr ->

125 P.brackets $

127 P.brackets $

126− P.pretty False lowExpr

128+ P.pretty dealiaser False lowExpr

127 <> P.text ".."

129 <> P.text ".."

128− <> P.pretty False highExpr

130+ <> P.pretty dealiaser False highExpr

129

131

130 ExplicitList elements ->

132 ExplicitList elements ->

131− P.brackets (P.commaCat (map (P.pretty False) elements))

133+ P.brackets (P.commaCat (map (P.pretty dealiaser False) elements))

132

134

133 Binop op (A.A _ (Literal (Literal.IntNum 0))) expr

135 Binop op (A.A _ (Literal (Literal.IntNum 0))) expr

134 | Var.toString op == "-" ->

136 | Var.toString op == "-" ->

135− P.text "-" <> P.pretty True expr

137+ P.text "-" <> P.pretty dealiaser True expr

136

138

137 Binop op leftExpr rightExpr ->

139 Binop op leftExpr rightExpr ->

138 P.parensIf needsParens $

140 P.parensIf needsParens $

139 P.hang

141 P.hang

140− (P.pretty True leftExpr)

142+ (P.pretty dealiaser True leftExpr)

141 2

143 2

142− (P.text op'' <+> P.pretty True rightExpr)

144+ (P.text op'' <+> P.pretty dealiaser True rightExpr)

143 where

145 where

144 op' = Var.toString op

146 op' = Var.toString op

145 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"

147 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"

146

148

147 Lambda pattern expr ->

149 Lambda pattern expr ->

148 P.parensIf needsParens $

150 P.parensIf needsParens $

149− P.text "\\" <> args <+> P.text "->" <+> P.pretty False body

151+ P.text "\\" <> args <+> P.text "->" <+> P.pretty dealiaser False body

150 where

152 where

151 (patterns, body) =

153 (patterns, body) =

152 collectLambdas expr

154 collectLambdas expr

153

155

154 args =

156 args =

155− P.sep (map (P.pretty True) (pattern : patterns))

157+ P.sep (map (P.pretty dealiaser True) (pattern : patterns))

156

158

157 App expr arg ->

159 App expr arg ->

158 P.parensIf needsParens $

160 P.parensIf needsParens $

159 P.hang func 2 (P.sep args)

161 P.hang func 2 (P.sep args)

160 where

162 where

161 func:args =

163 func:args =

162− map (P.pretty True) (collectApps expr ++ [arg])

164+ map (P.pretty dealiaser True) (collectApps expr ++ [arg])

163

165

166+ MultiIf [(condition, thenBranch)] elseBranch ->

167+ P.parensIf needsParens $ P.sep $

168+ [ P.text "if" <+> P.pretty dealiaser False condition <+> P.text "then"

169+ , P.nest 4 (P.pretty dealiaser False thenBranch)

170+ , P.text "else"

171+ , P.nest 4 (P.pretty dealiaser False elseBranch)

172+ ]

173+

164− MultiIf branches ->

174+ MultiIf branches finally ->

165 P.parensIf needsParens $

175 P.parensIf needsParens $

166− P.text "if" $$ nest 3 (vcat $ map iff branches)

176+ P.text "if" $$ nest 3 (vcat $ map iff branches ++ [final])

167 where

177 where

168 iff (condition, branch) =

178 iff (condition, branch) =

169 P.text "|" <+>

179 P.text "|" <+>

170 P.hang

180 P.hang

171− (P.pretty False condition <+> P.text "->")

181+ (P.pretty dealiaser False condition <+> P.text "->")

172 2

182 2

173− (P.pretty False branch)

183+ (P.pretty dealiaser False branch)

184+

185+ final =

186+ P.hang (P.text "| True -> ") 2 (P.pretty dealiaser False finally)

174

187

175 Let defs body ->

188 Let defs body ->

176 P.parensIf needsParens $

189 P.parensIf needsParens $

@@ -178,8 +191,8 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

178 [ P.hang

191 [ P.hang

179 (P.text "let")

192 (P.text "let")

180 4

193 4

181− (P.vcat (map (P.pretty False) defs))

194+ (P.vcat (map (P.pretty dealiaser False) defs))

182− , P.text "in" <+> P.pretty False body

195+ , P.text "in" <+> P.pretty dealiaser False body

183 ]

196 ]

184

197

185 Case expr branches ->

198 Case expr branches ->

@@ -187,16 +200,16 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

187 P.hang pexpr 2 (P.vcat (map pretty' branches))

200 P.hang pexpr 2 (P.vcat (map pretty' branches))

188 where

201 where

189 pexpr =

202 pexpr =

190− P.text "case" <+> P.pretty False expr <+> P.text "of"

203+ P.text "case" <+> P.pretty dealiaser False expr <+> P.text "of"

191

204

192 pretty' (pattern, branch) =

205 pretty' (pattern, branch) =

193− P.pretty False pattern

206+ P.pretty dealiaser False pattern

194 <+> P.text "->"

207 <+> P.text "->"

195− <+> P.pretty False branch

208+ <+> P.pretty dealiaser False branch

196

209

197 Data "::" [hd,tl] ->

210 Data "::" [hd,tl] ->

198 P.parensIf needsParens $

211 P.parensIf needsParens $

199− P.pretty True hd <+> P.text "::" <+> P.pretty True tl

212+ P.pretty dealiaser True hd <+> P.text "::" <+> P.pretty dealiaser True tl

200

213

201 Data "[]" [] ->

214 Data "[]" [] ->

202 P.text "[]"

215 P.text "[]"

@@ -204,49 +217,49 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

204 Data name exprs ->

217 Data name exprs ->

205 if Help.isTuple name

218 if Help.isTuple name

206 then

219 then

207− P.parens (P.commaCat (map (P.pretty False) exprs))

220+ P.parens (P.commaCat (map (P.pretty dealiaser False) exprs))

208 else

221 else

209 P.parensIf (needsParens && not (null exprs)) $

222 P.parensIf (needsParens && not (null exprs)) $

210 P.hang

223 P.hang

211 (P.text name)

224 (P.text name)

212 2

225 2

213− (P.sep (map (P.pretty True) exprs))

226+ (P.sep (map (P.pretty dealiaser True) exprs))

214

227

215 Access record field ->

228 Access record field ->

216− P.pretty True record <> P.text "." <> P.text field

229+ P.pretty dealiaser True record <> P.text "." <> P.text field

217

230

218 Remove record field ->

231 Remove record field ->

219− P.braces (P.pretty False record <+> P.text "-" <+> P.text field)

232+ P.braces (P.pretty dealiaser False record <+> P.text "-" <+> P.text field)

220

233

221 Insert (A.A _ (Remove record oldField)) newField expr ->

234 Insert (A.A _ (Remove record oldField)) newField expr ->

222 P.braces $

235 P.braces $

223 P.hsep

236 P.hsep

224− [ P.pretty False record

237+ [ P.pretty dealiaser False record

225 , P.text "-"

238 , P.text "-"

226 , P.text oldField

239 , P.text oldField

227 , P.text "|"

240 , P.text "|"

228 , P.text newField

241 , P.text newField

229 , P.equals

242 , P.equals

230− , P.pretty False expr

243+ , P.pretty dealiaser False expr

231 ]

244 ]

232

245

233 Insert record field expr ->

246 Insert record field expr ->

234 P.braces $

247 P.braces $

235− P.pretty False record

248+ P.pretty dealiaser False record

236 <+> P.text "|"

249 <+> P.text "|"

237 <+> P.text field

250 <+> P.text field

238 <+> P.equals

251 <+> P.equals

239− <+> P.pretty False expr

252+ <+> P.pretty dealiaser False expr

240

253

241 Modify record fields ->

254 Modify record fields ->

242 P.braces $

255 P.braces $

243 P.hang

256 P.hang

244− (P.pretty False record <+> P.text "|")

257+ (P.pretty dealiaser False record <+> P.text "|")

245 4

258 4

246 (P.commaSep $ map prettyField fields)

259 (P.commaSep $ map prettyField fields)

247 where

260 where

248 prettyField (field, expr) =

261 prettyField (field, expr) =

249− P.text field <+> P.text "<-" <+> P.pretty False expr

262+ P.text field <+> P.text "<-" <+> P.pretty dealiaser False expr

250

263

251 Record fields ->

264 Record fields ->

252 P.sep

265 P.sep

@@ -255,17 +268,20 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

255 ]

268 ]

256 where

269 where

257 field (name, expr) =

270 field (name, expr) =

258− P.text name <+> P.equals <+> P.pretty False expr

271+ P.text name <+> P.equals <+> P.pretty dealiaser False expr

259

272

260 GLShader _ _ _ ->

273 GLShader _ _ _ ->

261 P.text "[glsl| ... |]"

274 P.text "[glsl| ... |]"

262

275

263 Port portImpl ->

276 Port portImpl ->

264− P.pretty needsParens portImpl

277+ P.pretty dealiaser needsParens portImpl

278+

279+ Crash details ->

280+ P.text ("<crash:" ++ Crash.summary details ++ ">")

265

281

266

282

267instance P.Pretty (PortImpl expr tipe) where

283instance P.Pretty (PortImpl expr tipe) where

268− pretty _ impl =

284+ pretty _ _ impl =

269 P.text ("<port:" ++ portName impl ++ ">")

285 P.text ("<port:" ++ portName impl ++ ">")

270

286

271

287

@@ -282,7 +298,9 @@ collectLambdas

282collectLambdas lexpr@(A.A _ expr) =

298collectLambdas lexpr@(A.A _ expr) =

283 case expr of

299 case expr of

284 Lambda pattern body ->

300 Lambda pattern body ->

301+ let

285− let (ps, body') = collectLambdas body

302+ (ps, body') = collectLambdas body

303+ in

286− in (pattern : ps, body')

304+ (pattern : ps, body')

287

305

288 _ -> ([], lexpr)

306 _ -> ([], lexpr)

src/AST/Expression/Optimized.hsnew file+35

@@ -0,0 +1,35 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module AST.Expression.Optimized

3+ ( Expr, Expr'

4+ , Def(..)

5+ , Facts(..), dummyFacts

6+ ) where

7+

8+import qualified AST.Expression.General as General

9+import qualified AST.Pattern as Pattern

10+import qualified AST.Type as Type

11+import qualified AST.Variable as Var

12+

13+

14+type Expr =

15+ General.Expr () Def Var.Canonical Type.Canonical

16+

17+

18+type Expr' =

19+ General.Expr' () Def Var.Canonical Type.Canonical

20+

21+

22+data Def

23+ = Definition Facts Pattern.Optimized Expr

24+ deriving (Show)

25+

26+

27+data Facts = Facts

28+ { tailRecursionDetails :: Maybe String

29+ }

30+ deriving (Show)

31+

32+

33+dummyFacts :: Facts

34+dummyFacts =

35+ Facts Nothing

src/AST/Literal.hs+1−1

@@ -17,7 +17,7 @@ data Literal

17

18

19instance P.Pretty Literal where

20− pretty _ literal =

20+ pretty _ _ literal =

21 case literal of

22 IntNum n -> P.int n

23 FloatNum n -> P.double n

src/AST/Module.hs+27−9

@@ -2,8 +2,8 @@ module AST.Module

2 ( Interfaces

3 , Types, Aliases, ADTs

4 , AdtInfo, CanonicalAdt

5− , SourceModule, ValidModule, CanonicalModule

5+ , SourceModule, ValidModule, CanonicalModule, Optimized

6− , Module(..), CanonicalBody(..)

6+ , Module(..), Body(..)

7 , Header(..)

8 , Name, nameToString, nameIsNative

9 , Interface(..), toInterface

@@ -17,8 +17,10 @@ import qualified Data.Map as Map

17

18import qualified AST.Declaration as Decl

19import qualified AST.Expression.Canonical as Canonical

20+import qualified AST.Expression.Optimized as Optimized

20import qualified AST.Type as Type

21import qualified AST.Type as Type

21import qualified AST.Variable as Var

22import qualified AST.Variable as Var

23+import qualified Docs.AST as Docs

22import qualified Elm.Compiler.Version as Compiler

24import qualified Elm.Compiler.Version as Compiler

23import qualified Reporting.Annotation as A

25import qualified Reporting.Annotation as A

24

26

@@ -38,28 +40,41 @@ type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical)

38-- MODULES

40-- MODULES

39

41

40type SourceModule =

42type SourceModule =

43+ Module

44+ String

45+ [UserImport]

41− Module [UserImport] (Var.Listing Var.Value) [Decl.SourceDecl]

46+ (Var.Listing (A.Located Var.Value))

47+ [Decl.SourceDecl]

48+

42

49

43type ValidModule =

50type ValidModule =

44 Module

51 Module

52+ String

45 ([DefaultImport], [UserImport])

53 ([DefaultImport], [UserImport])

46− (Var.Listing Var.Value)

54+ (Var.Listing (A.Located Var.Value))

47 [Decl.ValidDecl]

55 [Decl.ValidDecl]

48

56

57+

49type CanonicalModule =

58type CanonicalModule =

50− Module [Name] [Var.Value] CanonicalBody

59+ Module Docs.Centralized [Name] [Var.Value] (Body Canonical.Expr)

60+

51

61

62+type Optimized =

63+ Module Docs.Centralized [Name] [Var.Value] (Body Optimized.Expr)

52

64

65+

53−data Module imports exports body = Module

66+data Module docs imports exports body = Module

54 { names :: Name

67 { names :: Name

55 , path :: FilePath

68 , path :: FilePath

69+ , docs :: A.Located (Maybe docs)

56 , exports :: exports

70 , exports :: exports

57 , imports :: imports

71 , imports :: imports

58 , body :: body

72 , body :: body

59 }

73 }

60

74

61−data CanonicalBody = CanonicalBody

75+

76+data Body expr = Body

62− { program :: Canonical.Expr

77+ { program :: expr

63 , types :: Types

78 , types :: Types

64 , fixities :: [(Decl.Assoc, Int, String)]

79 , fixities :: [(Decl.Assoc, Int, String)]

65 , aliases :: Aliases

80 , aliases :: Aliases

@@ -73,7 +88,8 @@ data CanonicalBody = CanonicalBody

73{-| Basic info needed to identify modules and determine dependencies. -}

88{-| Basic info needed to identify modules and determine dependencies. -}

74data Header imports = Header

89data Header imports = Header

75 { _names :: Name

90 { _names :: Name

91+ , _docs :: A.Located (Maybe String)

76− , _exports :: Var.Listing Var.Value

92+ , _exports :: Var.Listing (A.Located Var.Value)

77 , _imports :: imports

93 , _imports :: imports

78 }

94 }

79

95

@@ -121,6 +137,7 @@ data Interface = Interface

121 , iPorts :: [String]

137 , iPorts :: [String]

122 }

138 }

123

139

140+

124toInterface :: CanonicalModule -> Interface

141toInterface :: CanonicalModule -> Interface

125toInterface modul =

142toInterface modul =

126 let body' = body modul in

143 let body' = body modul in

@@ -135,6 +152,7 @@ toInterface modul =

135 , iPorts = ports body'

152 , iPorts = ports body'

136 }

153 }

137

154

155+

138instance Binary Interface where

156instance Binary Interface where

139 get = Interface <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get

157 get = Interface <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get

140 put modul = do

158 put modul = do

src/AST/Pattern.hs+11−7

@@ -38,6 +38,10 @@ type CanonicalPattern =

38 Pattern R.Region Var.Canonical

39

40

41+type Optimized =

42+ Pattern () Var.Canonical

43+

44+

41list :: R.Position -> [RawPattern] -> RawPattern

45list :: R.Position -> [RawPattern] -> RawPattern

42list end patterns =

46list end patterns =

43 case patterns of

47 case patterns of

@@ -103,29 +107,29 @@ boundVarList pattern =

103-- PRETTY PRINTING

107-- PRETTY PRINTING

104

108

105instance Var.ToString var => P.Pretty (Pattern' ann var) where

109instance Var.ToString var => P.Pretty (Pattern' ann var) where

106− pretty needsParens pattern =

110+ pretty dealiaser needsParens pattern =

107 case pattern of

111 case pattern of

108 Var name ->

112 Var name ->

109 P.text name

113 P.text name

110

114

111 Literal literal ->

115 Literal literal ->

112− P.pretty needsParens literal

116+ P.pretty dealiaser needsParens literal

113

117

114 Record fields ->

118 Record fields ->

115 P.braces (P.commaCat (map P.text fields))

119 P.braces (P.commaCat (map P.text fields))

116

120

117 Alias x ptrn ->

121 Alias x ptrn ->

118 P.parensIf needsParens $

122 P.parensIf needsParens $

119− P.pretty True ptrn <+> P.text "as" <+> P.text x

123+ P.pretty dealiaser True ptrn <+> P.text "as" <+> P.text x

120

124

121 Anything ->

125 Anything ->

122 P.text "_"

126 P.text "_"

123

127

124 Data name [A.A _ hd, A.A _ tl]

128 Data name [A.A _ hd, A.A _ tl]

125 | Var.toString name == "::" ->

129 | Var.toString name == "::" ->

126− P.parensIf isCons (P.pretty False hd)

130+ P.parensIf isCons (P.pretty dealiaser False hd)

127 <+> P.text "::"

131 <+> P.text "::"

128− <+> P.pretty False tl

132+ <+> P.pretty dealiaser False tl

129 where

133 where

130 isCons =

134 isCons =

131 case hd of

135 case hd of

@@ -137,7 +141,7 @@ instance Var.ToString var => P.Pretty (Pattern' ann var) where

137 in

141 in

138 if Help.isTuple name'

142 if Help.isTuple name'

139 then

143 then

140− P.parens (P.commaCat (map (P.pretty False) patterns))

144+ P.parens (P.commaCat (map (P.pretty dealiaser False) patterns))

141 else

145 else

142 P.parensIf needsParens $

146 P.parensIf needsParens $

143− P.hsep (P.text name' : map (P.pretty True) patterns)

147+ P.hsep (P.text name' : map (P.pretty dealiaser True) patterns)

src/AST/Type.hs+178−86

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

1module AST.Type

2 ( Raw, Raw'(..)

3 , Canonical(..), Aliased(..)

4− , Port(..), portType

4+ , Port(..), getPortType

5 , deepDealias, dealias

6 , collectLambdas

7 , fieldMap

@@ -12,6 +12,7 @@ import Control.Applicative ((<$>), (<*>))

12import Control.Arrow (second)

13import Data.Binary

14import qualified Data.Map as Map

15+import qualified Data.Maybe as Maybe

15import Text.PrettyPrint as P

16import Text.PrettyPrint as P

16

17

17import qualified AST.Variable as Var

18import qualified AST.Variable as Var

@@ -58,8 +59,8 @@ data Port t

58 deriving (Show)

59 deriving (Show)

59

60

61

61−portType :: Port tipe -> tipe

62+getPortType :: Port tipe -> tipe

62−portType portType =

63+getPortType portType =

63 case portType of

64 case portType of

64 Normal tipe -> tipe

65 Normal tipe -> tipe

65 Signal tipe _ -> tipe

66 Signal tipe _ -> tipe

@@ -151,119 +152,210 @@ dealiasHelp typeTable tipe =

151-- PRETTY PRINTING

152-- PRETTY PRINTING

152

153

153instance (P.Pretty t) => P.Pretty (Port t) where

154instance (P.Pretty t) => P.Pretty (Port t) where

154− pretty needsParens portType =

155+ pretty dealiaser needsParens portType =

155− case portType of

156+ P.pretty dealiaser needsParens (getPortType portType)

156− Normal tipe ->

157− P.pretty needsParens tipe

158−

159− Signal tipe _ ->

160− P.pretty needsParens tipe

161

157

162

158

163instance P.Pretty Raw' where

159instance P.Pretty Raw' where

164− pretty _ tipe =

160+ pretty dealiaser needsParens tipe =

161+ case tipe of

162+ RLambda arg body ->

163+ P.parensIf needsParens (prettyLambda dealiaser getRawLambda arg body)

164+

165+ RVar x ->

165− P.text (show tipe)

166+ P.text x

167+

168+ RType var ->

169+ prettyType dealiaser var

170+

171+ RApp func args ->

172+ let

173+ isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)

174+ isTuple _ = False

175+ in

176+ prettyApp dealiaser needsParens isTuple func args

177+

178+ RRecord fields ext ->

179+ prettyRecord dealiaser (flattenRawRecord fields ext)

166

180

167

181

168instance P.Pretty Canonical where

182instance P.Pretty Canonical where

169− pretty needsParens tipe =

183+ pretty dealiaser needsParens tipe =

170 case tipe of

184 case tipe of

171− Lambda _ _ ->

185+ Lambda arg body ->

172− P.parensIf needsParens $

186+ P.parensIf needsParens (prettyLambda dealiaser getCanLambda arg body)

173− P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

174− where

175− t:ts =

176− map prettyLambda (collectLambdas tipe)

177−

178− prettyLambda t =

179− case t of

180− Lambda _ _ ->

181− P.pretty True t

182− _ ->

183− P.pretty False t

184

187

185 Var x ->

188 Var x ->

186 P.text x

189 P.text x

187

190

188 Type var ->

191 Type var ->

189− let v = Var.toString var

192+ prettyType dealiaser var

193+

194+ App func args ->

195+ let

196+ isTuple (Type name) = Help.isTuple (Var.toString name)

197+ isTuple _ = False

190 in

198 in

191− P.text (if v == "_Tuple0" then "()" else v)

199+ prettyApp dealiaser needsParens isTuple func args

192

200

193− App f args ->

194− case (f,args) of

195− (Type name, _)

196− | Help.isTuple (Var.toString name) ->

197− P.parens $ P.sep $

198− P.punctuate P.comma (map (P.pretty False) args)

199−

200− (_, []) ->

201− P.pretty True f

202−

203− (_, _) ->

204− P.parensIf needsParens $

205− P.hang

206− (P.pretty True f)

207− 2

208− (P.sep (map (P.pretty True) args))

209−

210− Record _ _ ->

201+ Record fields ext ->

211− case flattenRecord tipe of

202+ prettyRecord dealiaser (flattenCanRecord fields ext)

212− ([], Nothing) ->

213− P.text "{}"

214−

215− (fields, Nothing) ->

216− P.sep

217− [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))

218− , P.rbrace

219− ]

220−

221− (fields, Just x) ->

222− P.hang

223− (P.lbrace <+> P.text x <+> P.text "|")

224− 4

225− (P.sep

226− [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))

227− , P.rbrace

228− ])

229− where

230− prettyField (field, tipe) =

231− P.text field <+> P.text ":" <+> P.pretty False tipe

232

203

233 Aliased name args _ ->

204 Aliased name args _ ->

234 P.parensIf (needsParens && not (null args)) $

205 P.parensIf (needsParens && not (null args)) $

235 P.hang

206 P.hang

236− (P.pretty False name)

207+ (P.pretty dealiaser False name)

237 2

208 2

238− (P.sep (map (P.pretty True . snd) args))

209+ (P.sep (map (P.pretty dealiaser True . snd) args))

239

210

240

211

241−collectLambdas :: Canonical -> [Canonical]

212+-- PRETTY HELPERS

242−collectLambdas tipe =

213+

214+prettyType :: (Var.ToString var) => P.Dealiaser -> var -> P.Doc

215+prettyType dealiaser var =

216+ let

217+ v = Var.toString var

218+ in

219+ P.text $

220+ if v == "_Tuple0" then

221+ "()"

222+ else

223+ maybe v id (Map.lookup v dealiaser)

224+

225+

226+-- PRETTY LAMBDAS

227+

228+prettyLambda :: (P.Pretty t) => P.Dealiaser -> (t -> Maybe (t,t)) -> t -> t -> P.Doc

229+prettyLambda dealiaser getLambda arg body =

230+ let

231+ rest =

232+ gatherLambda getLambda body

233+

234+ prettyArg t =

235+ P.pretty dealiaser (Maybe.isJust (getLambda t)) t

236+ in

237+ P.sep

238+ [ prettyArg arg

239+ , P.sep (map (\t -> P.text "->" <+> prettyArg t) rest)

240+ ]

241+

242+

243+getRawLambda :: Raw -> Maybe (Raw, Raw)

244+getRawLambda (A.A _ tipe) =

243 case tipe of

245 case tipe of

244− Lambda arg body ->

246+ RLambda arg body -> Just (arg, body)

245− arg : collectLambdas body

247+ _ -> Nothing

246

248

247− _ ->

249+

250+getCanLambda :: Canonical -> Maybe (Canonical, Canonical)

251+getCanLambda tipe =

252+ case tipe of

253+ Lambda arg body -> Just (arg, body)

254+ _ -> Nothing

255+

256+

257+gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]

258+gatherLambda get tipe =

259+ case get tipe of

260+ Just (arg, body) ->

261+ arg : gatherLambda get body

262+

263+ Nothing ->

248 [tipe]

264 [tipe]

249

265

250

266

251−flattenRecord :: Canonical -> ( [(String, Canonical)], Maybe String )

267+collectLambdas :: Canonical -> [Canonical]

252−flattenRecord tipe =

268+collectLambdas tipe =

253− case tipe of

269+ gatherLambda getCanLambda tipe

254− Var x ->

270+

255− ([], Just x)

271+

272+-- PRETTY APP

273+

274+prettyApp :: (P.Pretty t) => P.Dealiaser -> Bool -> (t -> Bool) -> t -> [t] -> P.Doc

275+prettyApp dealiaser needsParens isTuple func args

276+ | isTuple func =

277+ P.parens $ P.sep $

278+ P.punctuate P.comma (map (P.pretty dealiaser False) args)

279+

280+ | null args =

281+ P.pretty dealiaser needsParens func

282+

283+ | otherwise =

284+ P.parensIf needsParens $

285+ P.hang

286+ (P.pretty dealiaser True func)

287+ 2

288+ (P.sep (map (P.pretty dealiaser True) args))

256

289

290+

291+-- PRETTY RECORD

292+

293+prettyRecord :: (P.Pretty t) => P.Dealiaser -> ([(String, t)], Maybe String) -> P.Doc

294+prettyRecord dealiaser recordInfo =

295+ let

296+ prettyField (field, tipe) =

297+ P.hang

298+ (P.text field <+> P.text ":")

299+ 4

300+ (P.pretty dealiaser False tipe)

301+ in

302+ case recordInfo of

303+ ([], Nothing) ->

304+ P.text "{}"

305+

257− Record fields Nothing ->

306+ (fields, Nothing) ->

307+ P.sep

308+ [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))

309+ , P.rbrace

310+ ]

311+

312+ (fields, Just x) ->

313+ P.hang

314+ (P.lbrace <+> P.text x <+> P.text "|")

315+ 4

316+ (P.sep

317+ [ P.sep (P.punctuate P.comma (map prettyField fields))

318+ , P.rbrace

319+ ]

320+ )

321+

322+

323+flattenRawRecord

324+ :: [(String, Raw)]

325+ -> Maybe Raw

326+ -> ( [(String, Raw)], Maybe String )

327+flattenRawRecord fields ext =

328+ case ext of

329+ Nothing ->

330+ (fields, Nothing)

331+

332+ Just (A.A _ (RVar x)) ->

333+ (fields, Just x)

334+

335+ Just (A.A _ (RRecord fields' ext')) ->

336+ flattenRawRecord (fields' ++ fields) ext'

337+

338+ _ ->

339+ error "Trying to flatten ill-formed record."

340+

341+

342+flattenCanRecord

343+ :: [(String, Canonical)]

344+ -> Maybe Canonical

345+ -> ( [(String, Canonical)], Maybe String )

346+flattenCanRecord fields ext =

347+ case ext of

348+ Nothing ->

258 (fields, Nothing)

349 (fields, Nothing)

259

350

351+ Just (Var x) ->

352+ (fields, Just x)

353+

260− Record fields (Just ext) ->

354+ Just (Record fields' ext') ->

261− let (fields',ext') = flattenRecord ext

262− in

263− (fields' ++ fields, ext')

355+ flattenCanRecord (fields' ++ fields) ext'

264

356

265− Aliased _ args tipe' ->

357+ Just (Aliased _ args tipe) ->

266− flattenRecord (dealias args tipe')

358+ flattenCanRecord fields (Just (dealias args tipe))

267

359

268 _ ->

360 _ ->

269 error "Trying to flatten ill-formed record."

361 error "Trying to flatten ill-formed record."

src/AST/Variable.hs+11−7

@@ -3,6 +3,7 @@ module AST.Variable where

3import Control.Applicative ((<$>), (<*>))

4import Data.Binary

5import qualified Data.List as List

6+import qualified Data.Map as Map

6import qualified Data.Maybe as Maybe

7import qualified Data.Maybe as Maybe

7import Text.PrettyPrint as P

8import Text.PrettyPrint as P

8

9

@@ -203,26 +204,29 @@ getUnion value =

203-- PRETTY VARIABLES

204-- PRETTY VARIABLES

204

205

205instance P.Pretty Raw where

206instance P.Pretty Raw where

206− pretty _ (Raw name) =

207+ pretty _ _ (Raw name) =

207 if Help.isOp name

208 if Help.isOp name

208 then P.parens (P.text name)

209 then P.parens (P.text name)

209 else P.text name

210 else P.text name

210

211

212

212instance P.Pretty Canonical where

213instance P.Pretty Canonical where

213− pretty _ var =

214+ pretty dealiaser _ var =

214− P.text (toString var)

215+ let

216+ name = toString var

217+ in

218+ P.text (maybe name id (Map.lookup name dealiaser))

215

219

216

220

217instance P.Pretty a => P.Pretty (Listing a) where

221instance P.Pretty a => P.Pretty (Listing a) where

218− pretty _ (Listing explicits open) =

222+ pretty dealiaser _ (Listing explicits open) =

219 let dots = [if open then P.text ".." else P.empty]

223 let dots = [if open then P.text ".." else P.empty]

220 in

224 in

221− P.parens (P.commaCat (map (P.pretty False) explicits ++ dots))

225+ P.parens (P.commaCat (map (P.pretty dealiaser False) explicits ++ dots))

222

226

223

227

224instance P.Pretty Value where

228instance P.Pretty Value where

225− pretty _ portable =

229+ pretty dealiaser _ portable =

226 case portable of

230 case portable of

227 Value name ->

231 Value name ->

228 P.text name

232 P.text name

@@ -231,7 +235,7 @@ instance P.Pretty Value where

231 P.text name

235 P.text name

232

236

233 Union name ctors ->

237 Union name ctors ->

234− P.text name <> P.pretty False ctors

238+ P.text name <> P.pretty dealiaser False ctors

235

239

236

240

237-- BINARY SERIALIZATION

241-- BINARY SERIALIZATION

src/Canonicalize.hs+150−92

@@ -8,7 +8,7 @@ import qualified Data.Set as Set

8import qualified Data.Traversable as T

9

10import AST.Expression.General (Expr'(..), dummyLet)

11−import AST.Module (CanonicalBody(..))

11+import AST.Module (Body(..))

12

13import qualified AST.Declaration as D

14import qualified AST.Expression.General as E

@@ -18,9 +18,12 @@ import qualified AST.Module as Module

18import qualified AST.Pattern as P

19import qualified AST.Type as Type

20import qualified AST.Variable as Var

21+import qualified Docs.AST as Docs

22+import qualified Docs.Centralize as Docs

21import qualified Reporting.Annotation as A

23import qualified Reporting.Annotation as A

22import qualified Reporting.Error as Error

24import qualified Reporting.Error as Error

23import qualified Reporting.Error.Canonicalize as CError

25import qualified Reporting.Error.Canonicalize as CError

26+import qualified Reporting.Error.Helpers as ErrorHelp

24import qualified Reporting.Result as R

27import qualified Reporting.Result as R

25import qualified Reporting.Warning as Warning

28import qualified Reporting.Warning as Warning

26import qualified Canonicalize.Declaration as Decls

29import qualified Canonicalize.Declaration as Decls

@@ -39,35 +42,42 @@ module'

39 :: Module.Interfaces

42 :: Module.Interfaces

40 -> Module.ValidModule

43 -> Module.ValidModule

41 -> R.Result Warning.Warning Error.Error Module.CanonicalModule

44 -> R.Result Warning.Warning Error.Error Module.CanonicalModule

42−module' interfaces modul@(Module.Module _ _ _ (_, imports) _) =

45+module' interfaces modul =

46+ let

43− let (Result.Result uses rawResults) =

47+ (Result.Result uses rawResults) =

44− moduleHelp interfaces modul

48+ moduleHelp interfaces modul

45−

46− unusedImportWarnings =

47− Maybe.mapMaybe (warnUnusedImport uses) imports

48 in

49 in

49− R.addWarnings unusedImportWarnings $

50− case rawResults of

50+ case rawResults of

51− Result.Ok canonicalModule ->

51+ Result.Ok (env, almostCanonicalModule) ->

52− return canonicalModule

52+ R.addDealiaser (Env.toDealiaser env) $

53+ filterImports uses almostCanonicalModule

54+

55+ Result.Err msgs ->

56+ R.throwMany (map (A.map Error.Canonicalize) msgs)

57+

53

58

54− Result.Err msgs ->

59+type AlmostCanonicalModule =

55− R.throwMany (map (A.map Error.Canonicalize) msgs)

60+ Module.Module

61+ Docs.Centralized

62+ ([Module.DefaultImport], [Module.UserImport])

63+ [Var.Value]

64+ (Module.Body Canonical.Expr)

56

65

57

66

58moduleHelp

67moduleHelp

59 :: Module.Interfaces

68 :: Module.Interfaces

60 -> Module.ValidModule

69 -> Module.ValidModule

61− -> Result.ResultErr Module.CanonicalModule

70+ -> Result.ResultErr (Env.Environment, AlmostCanonicalModule)

62−moduleHelp interfaces modul@(Module.Module _ _ exports (defaults, imports) decls) =

71+moduleHelp interfaces modul@(Module.Module _ _ comment exports _ decls) =

63 canonicalModule

72 canonicalModule

64 <$> canonicalDeclsResult

73 <$> canonicalDeclsResult

65 <*> resolveExports locals exports

74 <*> resolveExports locals exports

66 where

75 where

67− canonicalModule canonicalDecls canonicalExports =

76+ canonicalModule (env, canonicalDecls) canonicalExports =

77+ (,) env $

68 modul

78 modul

79+ { Module.docs = A.map (fmap (Docs.centralize canonicalDecls)) comment

69− { Module.exports = canonicalExports

80+ , Module.exports = canonicalExports

70− , Module.imports = map fst defaults ++ map (fst . A.drop) imports

71 , Module.body = body canonicalDecls

81 , Module.body = body canonicalDecls

72 }

82 }

73

83

@@ -77,13 +87,13 @@ moduleHelp interfaces modul@(Module.Module _ _ exports (defaults, imports) decls

77

87

78 canonicalDeclsResult =

88 canonicalDeclsResult =

79 Setup.environment interfaces modul

89 Setup.environment interfaces modul

80− `Result.andThen` \env -> T.traverse (declaration env) decls

90+ `Result.andThen` \env -> (,) env <$> T.traverse (declaration env) decls

81

91

82− body :: [D.CanonicalDecl] -> Module.CanonicalBody

92+ body :: [D.CanonicalDecl] -> Module.Body Canonical.Expr

83 body decls =

93 body decls =

84 let nakedDecls = map A.drop decls

94 let nakedDecls = map A.drop decls

85 in

95 in

86− Module.CanonicalBody

96+ Module.Body

87 { program =

97 { program =

88 let expr = Decls.toExpr (Module.names modul) decls

98 let expr = Decls.toExpr (Module.names modul) decls

89 in

99 in

@@ -108,92 +118,130 @@ moduleHelp interfaces modul@(Module.Module _ _ exports (defaults, imports) decls

108

118

109-- IMPORTS / EXPORTS

119-- IMPORTS / EXPORTS

110

120

111−warnUnusedImport

121+filterImports

112 :: Set.Set Module.Name

122 :: Set.Set Module.Name

113− -> Module.UserImport

123+ -> AlmostCanonicalModule

114− -> Maybe (A.Located Warning.Warning)

124+ -> R.Result Warning.Warning e Module.CanonicalModule

125+filterImports uses modul@(Module.Module _ _ _ _ (defaults, imports) _) =

126+ do reducedImports <-

127+ Maybe.catMaybes <$> T.traverse checkImport imports

128+

129+ return $ modul

130+ { Module.imports =

131+ Set.toList (Set.fromList (map fst defaults ++ reducedImports))

132+ }

133+ where

115−warnUnusedImport uses (A.A region (name, _method)) =

134+ checkImport (A.A region (name, _method)) =

116− if Set.member name uses

135+ if Set.member name uses

117− then Nothing

136+ then

137+ return (Just name)

138+ else

118− else Just (A.A region (Warning.UnusedImport name))

139+ do R.warn region (Warning.UnusedImport name)

140+ return Nothing

119

141

120

142

121resolveExports

143resolveExports

122 :: [Var.Value]

144 :: [Var.Value]

123− -> Var.Listing Var.Value

145+ -> Var.Listing (A.Located Var.Value)

124 -> Result.ResultErr [Var.Value]

146 -> Result.ResultErr [Var.Value]

125resolveExports fullList (Var.Listing partialList open) =

147resolveExports fullList (Var.Listing partialList open) =

126 if open

148 if open

127 then Result.ok fullList

149 then Result.ok fullList

128 else

150 else

129 (\xs ys zs -> xs ++ ys ++ zs)

151 (\xs ys zs -> xs ++ ys ++ zs)

130− <$> getValueExports

152+ <$> T.traverse getValueExport values

131 <*> (concat <$> T.traverse getAliasExport aliases)

153 <*> (concat <$> T.traverse getAliasExport aliases)

132 <*> T.traverse getAdtExport adts

154 <*> T.traverse getAdtExport adts

133 where

155 where

134 (allValues, allAliases, allAdts) =

156 (allValues, allAliases, allAdts) =

135− splitValues fullList

157+ maybeUnzip3 (map splitValue fullList)

136

158

137 (values, aliases, adts) =

159 (values, aliases, adts) =

138− splitValues partialList

160+ maybeUnzip3 (map splitLocatedValue partialList)

161+

162+ allValuesSet = Set.fromList allValues

163+ adtTypes = map fst allAdts

139

164

140− getValueExports =

165+ getValueExport (A.A region name) =

141− case Set.toList (Set.difference values' allValues') of

166+ if Set.member name allValuesSet

142− [] -> Result.ok (map Var.Value values)

167+ then Result.ok (Var.Value name)

143− xs -> manyNotFound xs allValues

168+ else manyNotFound region [name] allValues

144− where

145− allValues' = Set.fromList allValues

146− values' = Set.fromList values

147

169

148− getAliasExport alias

170+ getAliasExport (A.A region alias)

149 | alias `elem` allAliases =

171 | alias `elem` allAliases =

150− let recordConstructor =

172+ Result.ok $ (:) (Var.Alias alias) $

151− if alias `elem` allValues then [Var.Value alias] else []

173+ if alias `elem` allValues then [Var.Value alias] else []

152− in

174+

175+ | List.elem alias adtTypes =

153− Result.ok (Var.Alias alias : recordConstructor)

176+ Result.ok [Var.Union alias (Var.Listing [] False)]

154

177

155 | otherwise =

178 | otherwise =

156− case List.find (\(name, _ctors) -> name == alias) allAdts of

157− Nothing -> manyNotFound [alias] allAliases

179+ manyNotFound region [alias] (allAliases ++ adtTypes)

158− Just (name, _ctor) ->

180+

159− Result.ok [Var.Union name (Var.Listing [] False)]

160−

161− getAdtExport (name, Var.Listing ctors open) =

181+ getAdtExport (A.A region (name, Var.Listing ctors open)) =

162− case lookup name allAdts of

182+ case List.lookup name allAdts of

183+ Nothing ->

163− Nothing -> manyNotFound [name] (map fst allAdts)

184+ manyNotFound region [name] adtTypes

185+

164 Just (Var.Listing allCtors _)

186 Just (Var.Listing allCtors _)

165 | open ->

187 | open ->

166 Result.ok (Var.Union name (Var.Listing allCtors False))

188 Result.ok (Var.Union name (Var.Listing allCtors False))

167 | otherwise ->

189 | otherwise ->

168 case filter (`notElem` allCtors) ctors of

190 case filter (`notElem` allCtors) ctors of

191+ [] ->

169− [] -> Result.ok (Var.Union name (Var.Listing ctors False))

192+ Result.ok (Var.Union name (Var.Listing ctors False))

193+ unfoundCtors ->

170− unfoundCtors -> manyNotFound unfoundCtors allCtors

194+ manyNotFound region unfoundCtors allCtors

171

195

172− manyNotFound nameList possibilities =

196+ manyNotFound region nameList possibilities =

173− Result.errors (map (notFound possibilities) nameList)

197+ Result.errors (map (notFound region possibilities) nameList)

174

198

175− notFound possibilities name =

199+ notFound region possibilities name =

176− A.A undefined $ CError.Export name $

200+ A.A region $ CError.Export name $

177− CError.nearbyNames id name possibilities

201+ ErrorHelp.nearbyNames id name possibilities

178

202

179

203

180−splitValues

204+-- GROUPING VALUES

181− :: [Var.Value]

205+

182− -> ([String], [String], [(String, Var.Listing String)])

206+maybeUnzip3 :: [(Maybe a, Maybe b, Maybe c)] -> ([a],[b],[c])

183−splitValues mixedValues =

207+maybeUnzip3 tuples =

184− case mixedValues of

208+ let (as, bs, cs) = unzip3 tuples

185− [] -> ([], [], [])

209+ in

186− x:xs ->

210+ (Maybe.catMaybes as, Maybe.catMaybes bs, Maybe.catMaybes cs)

187− let (values, aliases, adts) = splitValues xs in

211+

188− case x of

189− Var.Value name ->

190− (name : values, aliases, adts)

191

212

192− Var.Alias name ->

213+splitValue

193− (values, name : aliases, adts)

214+ :: Var.Value

215+ -> ( Maybe String, Maybe String, Maybe (String, Var.Listing String) )

216+splitValue value =

217+ case value of

218+ Var.Value name ->

219+ (Just name, Nothing, Nothing)

194

220

221+ Var.Alias name ->

222+ (Nothing, Just name, Nothing)

223+

195− Var.Union name listing ->

224+ Var.Union name listing ->

196− (values, aliases, (name, listing) : adts)

225+ (Nothing, Nothing, Just (name, listing))

226+

227+

228+splitLocatedValue

229+ :: A.Located Var.Value

230+ ->

231+ ( Maybe (A.Located String)

232+ , Maybe (A.Located String)

233+ , Maybe (A.Located (String, Var.Listing String))

234+ )

235+splitLocatedValue (A.A region value) =

236+ case value of

237+ Var.Value name ->

238+ (Just (A.A region name), Nothing, Nothing)

239+

240+ Var.Alias name ->

241+ (Nothing, Just (A.A region name), Nothing)

242+

243+ Var.Union name listing ->

244+ (Nothing, Nothing, Just (A.A region (name, listing)))

197

245

198

246

199-- DECLARATIONS

247-- DECLARATIONS

@@ -220,53 +268,58 @@ declaration

220 :: Env.Environment

268 :: Env.Environment

221 -> D.ValidDecl

269 -> D.ValidDecl

222 -> Result.ResultErr D.CanonicalDecl

270 -> Result.ResultErr D.CanonicalDecl

223−declaration env (A.A region decl) =

271+declaration env (A.A ann@(region,_) decl) =

224− let canonicalize kind _context _pattern env v =

272+ A.A ann <$>

225− kind env v

226− in

227− A.A region <$>

228 case decl of

273 case decl of

229− D.Definition (Valid.Definition p e t) ->

274+ D.Definition (Valid.Definition pat expr typ) ->

230 D.Definition <$> (

275 D.Definition <$> (

231 Canonical.Definition

276 Canonical.Definition

232− <$> canonicalize pattern "definition" p env p

277+ <$> pattern env pat

233− <*> expression env e

278+ <*> expression env expr

234− <*> T.traverse (canonicalize Canonicalize.tipe "definition" p env) t

279+ <*> T.traverse (regionType env) typ

235 )

280 )

236

281

237 D.Datatype name tvars ctors ->

282 D.Datatype name tvars ctors ->

238 D.Datatype name tvars <$> T.traverse canonicalize' ctors

283 D.Datatype name tvars <$> T.traverse canonicalize' ctors

239 where

284 where

240 canonicalize' (ctor,args) =

285 canonicalize' (ctor,args) =

241− (,) ctor <$> T.traverse (canonicalize Canonicalize.tipe "datatype" name env) args

286+ (,) ctor <$> T.traverse (Canonicalize.tipe env) args

242

287

243 D.TypeAlias name tvars expanded ->

288 D.TypeAlias name tvars expanded ->

244 D.TypeAlias name tvars

289 D.TypeAlias name tvars

245− <$> canonicalize Canonicalize.tipe "type alias" name env expanded

290+ <$> Canonicalize.tipe env expanded

246

291

247 D.Port validPort ->

292 D.Port validPort ->

248 Result.addModule ["Native","Port"] $

293 Result.addModule ["Native","Port"] $

249 Result.addModule ["Native","Json"] $

294 Result.addModule ["Native","Json"] $

250 case validPort of

295 case validPort of

251 D.In name tipe ->

296 D.In name tipe ->

252− canonicalize Canonicalize.tipe "port" name env tipe

297+ Canonicalize.tipe env tipe

253 `Result.andThen` \canonicalType ->

298 `Result.andThen` \canonicalType ->

254− D.Port <$> Port.check name Nothing canonicalType

299+ D.Port <$> Port.check region name Nothing canonicalType

255

300

256 D.Out name expr tipe ->

301 D.Out name expr tipe ->

257 let exprTypeResult =

302 let exprTypeResult =

258 (,)

303 (,)

259 <$> expression env expr

304 <$> expression env expr

260− <*> canonicalize Canonicalize.tipe "port" name env tipe

305+ <*> Canonicalize.tipe env tipe

261 in

306 in

262 exprTypeResult

307 exprTypeResult

263 `Result.andThen` \(expr', tipe') ->

308 `Result.andThen` \(expr', tipe') ->

264− D.Port <$> Port.check name (Just expr') tipe'

309+ D.Port <$> Port.check region name (Just expr') tipe'

265

310

266 D.Fixity assoc prec op ->

311 D.Fixity assoc prec op ->

267 Result.ok (D.Fixity assoc prec op)

312 Result.ok (D.Fixity assoc prec op)

268

313

269

314

315+regionType

316+ :: Env.Environment

317+ -> Type.Raw

318+ -> Result.ResultErr (A.Located Type.Canonical)

319+regionType env typ@(A.A region _) =

320+ A.A region <$> Canonicalize.tipe env typ

321+

322+

270expression

323expression

271 :: Env.Environment

324 :: Env.Environment

272 -> Valid.Expr

325 -> Valid.Expr

@@ -314,8 +367,10 @@ expression env (A.A region validExpr) =

314 App func arg ->

367 App func arg ->

315 App <$> go func <*> go arg

368 App <$> go func <*> go arg

316

369

317− MultiIf branches ->

370+ MultiIf branches finally ->

371+ MultiIf

318− MultiIf <$> T.traverse go' branches

372+ <$> T.traverse go' branches

373+ <*> go finally

319 where

374 where

320 go' (condition, branch) =

375 go' (condition, branch) =

321 (,) <$> go condition <*> go branch

376 (,) <$> go condition <*> go branch

@@ -330,7 +385,7 @@ expression env (A.A region validExpr) =

330 Canonical.Definition

385 Canonical.Definition

331 <$> pattern env' p

386 <$> pattern env' p

332 <*> expression env' body

387 <*> expression env' body

333− <*> T.traverse (Canonicalize.tipe env') mtipe

388+ <*> T.traverse (regionType env') mtipe

334

389

335 Var (Var.Raw x) ->

390 Var (Var.Raw x) ->

336 Var <$> Canonicalize.variable region env x

391 Var <$> Canonicalize.variable region env x

@@ -374,6 +429,9 @@ expression env (A.A region validExpr) =

374 GLShader uid src tipe ->

429 GLShader uid src tipe ->

375 Result.ok (GLShader uid src tipe)

430 Result.ok (GLShader uid src tipe)

376

431

432+ Crash details ->

433+ Result.ok (Crash details)

434+

377

435

378pattern

436pattern

379 :: Env.Environment

437 :: Env.Environment

src/Canonicalize/Declaration.hs+10−9

@@ -9,6 +9,7 @@ import qualified AST.Pattern as P

9import qualified AST.Type as T

10import qualified AST.Variable as Var

11import qualified Reporting.Annotation as A

12+import qualified Reporting.Region as R

12

13

14

14toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]

15toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]

@@ -17,7 +18,7 @@ toExpr moduleName decls =

17

18

19

19toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]

20toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]

20−toDefs moduleName (A.A region decl) =

21+toDefs moduleName (A.A (region,_) decl) =

21 let typeVar = Var.fromModule moduleName

22 let typeVar = Var.fromModule moduleName

22

23

23 loc expr =

24 loc expr =

@@ -35,10 +36,10 @@ toDefs moduleName (A.A region decl) =

35 tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)

36 tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)

36 body = loc . E.Data ctor $ map (loc . E.localVar) vars

37 body = loc . E.Data ctor $ map (loc . E.localVar) vars

37 in

38 in

38− [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

39+ [ definition ctor (buildFunction body vars) region (foldr T.Lambda tbody tipes) ]

39

40

40 D.TypeAlias name tvars tipe@(T.Record fields ext) ->

41 D.TypeAlias name tvars tipe@(T.Record fields ext) ->

41− [ definition name (buildFunction record vars) (foldr T.Lambda result args) ]

42+ [ definition name (buildFunction record vars) region (foldr T.Lambda result args) ]

42 where

43 where

43 result =

44 result =

44 T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)

45 T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)

@@ -70,13 +71,13 @@ toDefs moduleName (A.A region decl) =

70 in

71 in

71 case impl of

72 case impl of

72 E.In name tipe ->

73 E.In name tipe ->

73− [ definition name body (T.portType tipe) ]

74+ [ definition name body region (T.getPortType tipe) ]

74

75

75 E.Out name _expr tipe ->

76 E.Out name _expr tipe ->

76− [ definition name body (T.portType tipe) ]

77+ [ definition name body region (T.getPortType tipe) ]

77

78

78 E.Task name _expr tipe ->

79 E.Task name _expr tipe ->

79− [ definition name body (T.portType tipe) ]

80+ [ definition name body region (T.getPortType tipe) ]

80

81

81 -- no constraints are needed for fixity declarations

82 -- no constraints are needed for fixity declarations

82 D.Fixity _ _ _ ->

83 D.Fixity _ _ _ ->

@@ -96,6 +97,6 @@ buildFunction body@(A.A ann _) vars =

96 (map (A.A ann . P.Var) vars)

97 (map (A.A ann . P.Var) vars)

97

98

99

99−definition :: String -> Canonical.Expr -> T.Canonical -> Canonical.Def

100+definition :: String -> Canonical.Expr -> R.Region -> T.Canonical -> Canonical.Def

100−definition name expr@(A.A ann _) tipe =

101+definition name expr@(A.A ann _) region tipe =

101− Canonical.Definition (A.A ann (P.Var name)) expr (Just tipe)

102+ Canonical.Definition (A.A ann (P.Var name)) expr (Just (A.A region tipe))

src/Canonicalize/Environment.hs+34

@@ -3,6 +3,7 @@ module Canonicalize.Environment where

3

4import qualified Data.List as List

5import qualified Data.Map as Map

6+import qualified Data.Maybe as Maybe

6import qualified Data.Set as Set

7import qualified Data.Set as Set

7

8

8import AST.Expression.General (saveEnvName)

9import AST.Expression.General (saveEnvName)

@@ -10,6 +11,7 @@ import qualified AST.Module as Module

10import qualified AST.Pattern as P

11import qualified AST.Pattern as P

11import qualified AST.Type as Type

12import qualified AST.Type as Type

12import qualified AST.Variable as Var

13import qualified AST.Variable as Var

14+import Elm.Utils ((|>))

13

15

14

16

15-- ENVIRONMENT

17-- ENVIRONMENT

@@ -104,3 +106,35 @@ builtinPatches =

104 toTuple :: Int -> (String, Int)

106 toTuple :: Int -> (String, Int)

105 toTuple n =

107 toTuple n =

106 ("_Tuple" ++ show n, n)

108 ("_Tuple" ++ show n, n)

109+

110+

111+-- TO TYPE DEALIASER

112+

113+toDealiaser :: Environment -> Map.Map String String

114+toDealiaser (Env _ _ adts aliases _) =

115+ let

116+ dealiasAdt (localName, canonicalSet) =

117+ case Set.toList canonicalSet of

118+ [canonicalName] ->

119+ Just (Var.toString canonicalName, localName)

120+ _ ->

121+ Nothing

122+

123+ dealiasAlias (localName, canonicalSet) =

124+ case Set.toList canonicalSet of

125+ [(canonicalName,_,_)] ->

126+ Just (Var.toString canonicalName, localName)

127+ _ ->

128+ Nothing

129+

130+ adtPairs =

131+ Maybe.mapMaybe dealiasAdt (Map.toList adts)

132+

133+ aliasPairs =

134+ Maybe.mapMaybe dealiasAlias (Map.toList aliases)

135+

136+ add (key,value) dict =

137+ Map.insertWith (\v v' -> if length v < length v' then v else v') key value dict

138+ in

139+ adtPairs ++ aliasPairs

140+ |> foldr add Map.empty

src/Canonicalize/Port.hs+18−14

@@ -10,30 +10,33 @@ import qualified AST.Type as T

10import qualified AST.Variable as Var

11import qualified Reporting.Annotation as A

12import qualified Reporting.Error.Canonicalize as Error

13+import qualified Reporting.Region as R

13import qualified Canonicalize.Result as Result

14import qualified Canonicalize.Result as Result

14

15

16

16-- CHECK FOR PORT

17-- CHECK FOR PORT

17

18

18check

19check

20+ :: R.Region

19− :: String

21+ -> String

20 -> Maybe Canonical.Expr

22 -> Maybe Canonical.Expr

21 -> T.Canonical

23 -> T.Canonical

22 -> Result.ResultErr D.CanonicalPort

24 -> Result.ResultErr D.CanonicalPort

23−check name maybeExpr rootType =

25+check region name maybeExpr rootType =

24− D.CanonicalPort <$> checkHelp name maybeExpr rootType rootType

26+ D.CanonicalPort <$> checkHelp region name maybeExpr rootType rootType

25

27

26

28

27checkHelp

29checkHelp

30+ :: R.Region

28− :: String

31+ -> String

29 -> Maybe Canonical.Expr

32 -> Maybe Canonical.Expr

30 -> T.Canonical

33 -> T.Canonical

31 -> T.Canonical

34 -> T.Canonical

32 -> Result.ResultErr (E.PortImpl Canonical.Expr T.Canonical)

35 -> Result.ResultErr (E.PortImpl Canonical.Expr T.Canonical)

33−checkHelp name maybeExpr rootType tipe =

36+checkHelp region name maybeExpr rootType tipe =

34 case (maybeExpr, tipe) of

37 case (maybeExpr, tipe) of

35 (_, T.Aliased _ args t) ->

38 (_, T.Aliased _ args t) ->

36− checkHelp name maybeExpr rootType (T.dealias args t)

39+ checkHelp region name maybeExpr rootType (T.dealias args t)

37

40

38 (Just expr, T.App (T.Type task) [ _x, _a ])

41 (Just expr, T.App (T.Type task) [ _x, _a ])

39 | Var.isTask task ->

42 | Var.isTask task ->

@@ -50,37 +53,38 @@ checkHelp name maybeExpr rootType tipe =

50 case maybeExpr of

53 case maybeExpr of

51 Nothing ->

54 Nothing ->

52 const (E.In name (T.Signal rootType arg))

55 const (E.In name (T.Signal rootType arg))

53− <$> validForeignType name True arg arg

56+ <$> validForeignType region name True arg arg

54

57

55 Just expr ->

58 Just expr ->

56 const (E.Out name expr (T.Signal rootType arg))

59 const (E.Out name expr (T.Signal rootType arg))

57− <$> validForeignType name False arg arg

60+ <$> validForeignType region name False arg arg

58

61

59 _ ->

62 _ ->

60 case maybeExpr of

63 case maybeExpr of

61 Nothing ->

64 Nothing ->

62 const (E.In name (T.Normal rootType))

65 const (E.In name (T.Normal rootType))

63− <$> validForeignType name True rootType tipe

66+ <$> validForeignType region name True rootType tipe

64

67

65 Just expr ->

68 Just expr ->

66 const (E.Out name expr (T.Normal rootType))

69 const (E.Out name expr (T.Normal rootType))

67− <$> validForeignType name False rootType tipe

70+ <$> validForeignType region name False rootType tipe

68

71

69

72

70-- CHECK INBOUND AND OUTBOUND TYPES

73-- CHECK INBOUND AND OUTBOUND TYPES

71

74

72validForeignType

75validForeignType

76+ :: R.Region

73− :: String

77+ -> String

74 -> Bool

78 -> Bool

75 -> T.Canonical

79 -> T.Canonical

76 -> T.Canonical

80 -> T.Canonical

77 -> Result.ResultErr ()

81 -> Result.ResultErr ()

78−validForeignType name isInbound rootType tipe =

82+validForeignType region name isInbound rootType tipe =

79 let valid localType =

83 let valid localType =

80− validForeignType name isInbound rootType localType

84+ validForeignType region name isInbound rootType localType

81

85

82 err problem =

86 err problem =

83− Result.err $ A.A undefined $

87+ Result.err $ A.A region $

84 Error.port name isInbound rootType tipe problem

88 Error.port name isInbound rootType tipe problem

85 in

89 in

86 case tipe of

90 case tipe of

src/Canonicalize/Setup.hs+3−2

@@ -17,6 +17,7 @@ import qualified AST.Variable as Var

17import Elm.Utils ((|>))

18import qualified Reporting.Annotation as A

19import qualified Reporting.Error.Canonicalize as Error

20+import qualified Reporting.Error.Helpers as Error

20import qualified Reporting.Region as R

21import qualified Reporting.Region as R

21import qualified Canonicalize.Environment as Env

22import qualified Canonicalize.Environment as Env

22import qualified Canonicalize.Result as Result

23import qualified Canonicalize.Result as Result

@@ -27,7 +28,7 @@ environment

27 :: Module.Interfaces

28 :: Module.Interfaces

28 -> Module.ValidModule

29 -> Module.ValidModule

29 -> Result.ResultErr Env.Environment

30 -> Result.ResultErr Env.Environment

30−environment interfaces modul@(Module.Module _ _ _ (defaults, imports) decls) =

31+environment interfaces modul@(Module.Module _ _ _ _ (defaults, imports) decls) =

31 let moduleName =

32 let moduleName =

32 Module.names modul

33 Module.names modul

33

34

@@ -288,7 +289,7 @@ declToPatches

288 :: Module.Name

289 :: Module.Name

289 -> D.ValidDecl

290 -> D.ValidDecl

290 -> (Maybe Node, [Env.Patch])

291 -> (Maybe Node, [Env.Patch])

291−declToPatches moduleName (A.A region decl) =

292+declToPatches moduleName (A.A (region,_) decl) =

292 let local mkPatch x =

293 let local mkPatch x =

293 mkPatch x (Var.local x)

294 mkPatch x (Var.local x)

294

295

src/Canonicalize/Sort.hs+17−5

@@ -73,17 +73,26 @@ reorder (A.A ann expression) =

73 App func arg ->

74 App <$> reorder func <*> reorder arg

75

76− MultiIf branches ->

76+ MultiIf branches finally ->

77+ MultiIf

77− MultiIf <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

78+ <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

79+ <*> reorder finally

78

80

79 Access record field ->

81 Access record field ->

82+ Access

80− Access <$> reorder record <*> return field

83+ <$> reorder record

84+ <*> return field

81

85

82 Remove record field ->

86 Remove record field ->

87+ Remove

83− Remove <$> reorder record <*> return field

88+ <$> reorder record

89+ <*> return field

84

90

85 Insert record field expr ->

91 Insert record field expr ->

92+ Insert

86− Insert <$> reorder record <*> return field <*> reorder expr

93+ <$> reorder record

94+ <*> return field

95+ <*> reorder expr

87

96

88 Modify record fields ->

97 Modify record fields ->

89 Modify

98 Modify

@@ -109,6 +118,9 @@ reorder (A.A ann expression) =

109 Task name expr tipe ->

118 Task name expr tipe ->

110 (\e -> Task name e tipe) <$> reorder expr

119 (\e -> Task name e tipe) <$> reorder expr

111

120

121+ Crash _ ->

122+ return expression

123+

112 -- Actually do some reordering

124 -- Actually do some reordering

113 Let defs body ->

125 Let defs body ->

114 do body' <- reorder body

126 do body' <- reorder body

src/Canonicalize/Variable.hs+3−2

@@ -11,6 +11,7 @@ import qualified AST.Type as Type

11import qualified AST.Variable as Var

12import qualified Reporting.Annotation as A

13import qualified Reporting.Error.Canonicalize as Error

14+import qualified Reporting.Error.Helpers as Error

14import qualified Reporting.Region as R

15import qualified Reporting.Region as R

15import qualified Canonicalize.Environment as Env

16import qualified Canonicalize.Environment as Env

16import qualified Canonicalize.Result as Result

17import qualified Canonicalize.Result as Result

@@ -211,7 +212,7 @@ qualifiedProblem moduleName name allQualified =

211 in

212 in

212 case Set.member moduleName availableModules of

213 case Set.member moduleName availableModules of

213 True ->

214 True ->

214− ( Error.QualifiedUnknown moduleNameString

215+ ( Error.QualifiedUnknown moduleNameString name

215 , allQualified

216 , allQualified

216 |> filter ((==) moduleName . fst)

217 |> filter ((==) moduleName . fst)

217 |> map snd

218 |> map snd

@@ -219,7 +220,7 @@ qualifiedProblem moduleName name allQualified =

219 )

220 )

220

221

221 False ->

222 False ->

222− ( Error.UnknownQualifier moduleNameString

223+ ( Error.UnknownQualifier moduleNameString name

223 , Set.toList availableModules

224 , Set.toList availableModules

224 |> map Module.nameToString

225 |> map Module.nameToString

225 |> Error.nearbyNames id moduleNameString

226 |> Error.nearbyNames id moduleNameString

src/CommandLineRouter.hs+2−2

@@ -26,10 +26,10 @@ attemptToRun command args =

26 case found of

27 Nothing ->

28 hPutStrLn stderr $

29− "Could not find command '" ++ command ++ "'. Maybe there is a typo?\n\n\

29+ "Could not find command `" ++ command ++ "`. Maybe there is a typo?\n\n\

30 \Default commands include:\n\n"

31 ++ availableCommands ++

32− "\nWhen you try to run the command '" ++ command ++ "' we actually search for an\n\

32+ "\nWhen you try to run the command `" ++ command ++ "` we actually search for an\n\

33 \ executable named elm-" ++ command ++ ". Are you able to run elm-" ++ command ++ "?\n\

34 \ Is it on your PATH?"

35

src/Compile.hs+9−3

@@ -5,6 +5,7 @@ import qualified Data.Map as Map

5import qualified AST.Module as Module

6import qualified Canonicalize

7import Elm.Utils ((|>))

8+import qualified Nitpick.TopLevelTypes as Nitpick

8import qualified Parse.Helpers as Parse

9import qualified Parse.Helpers as Parse

9import qualified Parse.Parse as Parse

10import qualified Parse.Parse as Parse

10import qualified Reporting.Error as Error

11import qualified Reporting.Error as Error

@@ -16,11 +17,12 @@ import qualified Type.Inference as TI

16compile

17compile

17 :: String

18 :: String

18 -> String

19 -> String

20+ -> Bool

19 -> Module.Interfaces

21 -> Module.Interfaces

20 -> String

22 -> String

21 -> Result.Result Warning.Warning Error.Error Module.CanonicalModule

23 -> Result.Result Warning.Warning Error.Error Module.CanonicalModule

22

24

23−compile user projectName interfaces source =

25+compile user projectName isRoot interfaces source =

24 do

26 do

25 -- determine if default imports should be added

27 -- determine if default imports should be added

26 -- only elm-lang/core is exempt

28 -- only elm-lang/core is exempt

@@ -30,7 +32,7 @@ compile user projectName interfaces source =

30 -- Parse the source code

32 -- Parse the source code

31 validModule <-

33 validModule <-

32 Result.mapError Error.Syntax $

34 Result.mapError Error.Syntax $

33− Parse.program needsDefaults (getOpTable interfaces) source

35+ Parse.program needsDefaults isRoot (getOpTable interfaces) source

34

36

35 -- Canonicalize all variables, pinning down where they came from.

37 -- Canonicalize all variables, pinning down where they came from.

36 canonicalModule <-

38 canonicalModule <-

@@ -41,7 +43,11 @@ compile user projectName interfaces source =

41 Result.from Error.Type $

43 Result.from Error.Type $

42 TI.infer interfaces canonicalModule

44 TI.infer interfaces canonicalModule

43

45

46+ -- One last round of checks

47+ Result.mapError Error.Type $

48+ Nitpick.topLevelTypes types (Module.body validModule)

49+

44− -- Add the real list of tyes

50+ -- Add the real list of types

45 let body = (Module.body canonicalModule) { Module.types = types }

51 let body = (Module.body canonicalModule) { Module.types = types }

46

52

47 return $ canonicalModule { Module.body = body }

53 return $ canonicalModule { Module.body = body }

src/Docs.hsdeleted−275

@@ -1,275 +0,0 @@

1−{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}

2−module Main where

3−

4−import System.Console.CmdArgs

5−import System.Directory

6−import System.FilePath

7−import System.Exit

8−import System.IO

9−

10−import Control.Applicative ((<$>))

11−import Control.Arrow (second)

12−import Control.Monad (when)

13−import qualified Data.Aeson.Encode.Pretty as Json

14−import qualified Data.ByteString.Lazy.Char8 as BS

15−import qualified Data.Map as Map

16−import qualified Data.Maybe as Maybe

17−import qualified Data.Set as Set

18−

19−import qualified AST.Declaration as Decl

20−import qualified AST.Expression.Source as Source

21−import qualified AST.Variable as Var

22−

23−import Text.Parsec hiding (newline, spaces)

24−import qualified Parse.Declaration as Parse (typeDecl, infixDecl)

25−import qualified Parse.Expression as Parse (typeAnnotation)

26−import qualified Parse.Helpers as Parse

27−import qualified Parse.Module as Parse (header)

28−import qualified Elm.Compiler.Module as Module

29−import qualified Elm.Compiler.Type.Extract as Type

30−import qualified Elm.Docs as Docs

31−

32−

33−-- FLAGS

34−

35−data Flags = Flags

36− { input :: FilePath

37− , output :: Maybe FilePath

38− }

39− deriving (Data,Typeable,Show,Eq)

40−

41−

42−defaultFlags :: Flags

43−defaultFlags = Flags

44− { input = def &= args &= typ "FILE"

45−

46− , output = Nothing &= typFile

47− &= help "file name for generated JSON documentation"

48−

49− } &= help "Generate documentation for Elm"

50− &= summary "Generate documentation for Elm, (c) Evan Czaplicki"

51−

52−

53−-- GENERATE DOCUMENTATION

54−

55−main :: IO ()

56−main =

57− do flags <- cmdArgs defaultFlags

58− let inputFileName = input flags

59−

60− exists <- doesFileExist inputFileName

61− when (not exists) $

62− do hPutStrLn stderr $

63− if null inputFileName

64− then "Error: you must provide a file to document!"

65− else "Error: could not find a file named '" ++ inputFileName ++ "'"

66− exitFailure

67−

68− source <- readFile inputFileName

69− case Parse.iParse documentation source of

70− Right docs ->

71− let json = Json.encodePretty' config docs in

72− case output flags of

73− Nothing -> BS.putStrLn json

74− Just docPath ->

75− do createDirectoryIfMissing True (dropFileName docPath)

76− BS.writeFile docPath json

77−

78− Left err ->

79− do hPutStrLn stderr (show err)

80− exitFailure

81−

82−

83−config :: Json.Config

84−config =

85− Json.Config

86− { Json.confIndent = 2

87− , Json.confCompare = Json.keyOrder keys

88− }

89− where

90− keys =

91− [ "tag", "name", "comment", "aliases", "types"

92− , "values", "func", "args", "type", "cases"

93− ]

94−

95−

96−-- PARSE DOCUMENTATION

97−

98−documentation :: Parse.IParser Docs.Documentation

99−documentation =

100− do optional Parse.freshLine

101− (names, exports) <- Parse.header

102−

103− manyTill (string " " <|> Parse.newline <?> "more whitespace")

104− (lookAhead (string "{-|") <?> "module documentation comment")

105−

106− overview <- docComment

107−

108− decls <- allDeclarations

109−

110− let (aliases, unions, values) = categorizeDeclarations decls

111−

112− return $

113− Docs.Documentation

114− (Module.Name names)

115− overview

116− (filterAliases exports aliases)

117− (filterUnions exports unions)

118− (filterValues exports values)

119−

120−

121−docComment :: Parse.IParser String

122−docComment =

123− do try (string "{-|")

124− contents <- Parse.closeComment

125−

126− let reversed =

127− dropWhile (`elem` " \n\r") . drop 2 $ reverse contents

128−

129− return $ dropWhile (==' ') (reverse reversed)

130−

131−

132−allDeclarations :: Parse.IParser [(String, Decl.SourceDecl)]

133−allDeclarations =

134− Parse.onFreshLines (:) [] declaration

135−

136−

137−declaration :: Parse.IParser (String, Decl.SourceDecl)

138−declaration =

139− uncommentable <|> commented <|> uncommented ""

140− where

141− uncommentable =

142− (,) "" <$> Parse.infixDecl

143−

144− commented =

145− do comment <- docComment

146− Parse.freshLine

147− uncommented comment

148−

149− uncommented comment =

150− (,) comment

151− <$> choice [ Parse.typeDecl, Decl.Definition <$> Parse.typeAnnotation ]

152−

153−

154−-- CATEGORIZE DECLARATIONS

155−

156−data CategoryInfo = CategoryInfo

157− { aliases :: [Docs.Alias]

158− , unions :: [Docs.Union]

159− , values :: Map.Map String Docs.Value

160− , infixes :: Map.Map String (String, Int)

161− }

162−

163−

164−emptyInfo :: CategoryInfo

165−emptyInfo =

166− CategoryInfo [] [] Map.empty Map.empty

167−

168−

169−categorizeDeclarations :: [(String, Decl.SourceDecl)] -> ([Docs.Alias], [Docs.Union], [Docs.Value])

170−categorizeDeclarations decls =

171− (aliases, unions, Map.elems values)

172− where

173− (CategoryInfo aliases unions rawValues infixes) =

174− foldr collectInfo emptyInfo decls

175−

176− values =

177− Map.union

178− (Map.intersectionWith addInfixInfo rawValues infixes)

179− rawValues

180−

181−

182−addInfixInfo :: Docs.Value -> (String, Int) -> Docs.Value

183−addInfixInfo value infixInfo =

184− value { Docs.valueAssocPrec = Just infixInfo }

185−

186−

187−collectInfo :: (String, Decl.SourceDecl) -> CategoryInfo -> CategoryInfo

188−collectInfo (comment, decl) info =

189− case decl of

190− Decl.Definition def ->

191− case def of

192− Source.Definition _ _ ->

193− error (errorMessage "unannotated definitions")

194−

195− Source.TypeAnnotation name tipe ->

196− let value = Docs.Value name comment (Type.fromInternalType tipe) Nothing

197− in

198− info { values = Map.insert name value (values info) }

199−

200− Decl.Datatype name args cases ->

201− let cases' = map (second (map Type.fromInternalType)) cases

202− union = Docs.Union name comment args cases'

203− in

204− info { unions = union : unions info }

205−

206− Decl.TypeAlias name args tipe ->

207− let alias = Docs.Alias name comment args (Type.fromInternalType tipe)

208− in

209− info { aliases = alias : aliases info }

210−

211− Decl.Fixity assoc prec name ->

212− let infixInfo = (Decl.assocToString assoc, prec)

213− in

214− info { infixes = Map.insert name infixInfo (infixes info) }

215−

216− Decl.Port _ ->

217− error (errorMessage "ports")

218−

219−

220−errorMessage :: String -> String

221−errorMessage name =

222− "Unable to deal with annotations on " ++ name ++ " at this time.\n" ++

223− "Please report your use case to <https://github.com/elm-lang/elm-compiler/issues>"

224−

225−

226−-- FILTER OUT UNEXPORTED VALUES, ALIASES, and UNIONS

227−

228−filterValues :: Var.Listing Var.Value -> [Docs.Value] -> [Docs.Value]

229−filterValues (Var.Listing exports open) values =

230− case open of

231− True -> values

232− False ->

233− let names =

234− Set.fromList (Var.getValues exports)

235− in

236− filter (\value -> Set.member (Docs.valueName value) names) values

237−

238−

239−filterAliases :: Var.Listing Var.Value -> [Docs.Alias] -> [Docs.Alias]

240−filterAliases (Var.Listing exports open) aliases =

241− case open of

242− True -> aliases

243− False ->

244− let names =

245− Set.fromList (Var.getAliases exports)

246− in

247− filter (\value -> Set.member (Docs.aliasName value) names) aliases

248−

249−

250−filterUnions :: Var.Listing Var.Value -> [Docs.Union] -> [Docs.Union]

251−filterUnions (Var.Listing exports open) unions =

252− case open of

253− True -> unions

254− False ->

255− Maybe.mapMaybe (filterUnion exportedUnions) unions

256− where

257− exportedUnions =

258− Map.fromList (Var.getUnions exports)

259−

260−

261−filterUnion :: Map.Map String (Var.Listing String) -> Docs.Union -> Maybe Docs.Union

262−filterUnion exportedUnions union =

263− case Map.lookup (Docs.unionName union) exportedUnions of

264− Nothing ->

265− Nothing

266−

267− Just (Var.Listing tags unionOpen)

268− | unionOpen ->

269− Just union

270− | otherwise ->

271− let publicTags =

272− filter (\(tag, _) -> tag `elem` tags) (Docs.unionCases union)

273− in

274− Just (union { Docs.unionCases = publicTags })

275−

src/Docs/AST.hsnew file+44

@@ -0,0 +1,44 @@

1+module Docs.AST where

2+

3+import qualified Data.Map as Map

4+

5+import qualified Elm.Compiler.Type as Type

6+import qualified Reporting.Annotation as A

7+

8+

9+-- FULL DOCUMENTATION

10+

11+data Docs t = Docs

12+ { comment :: String

13+ , aliases :: Map.Map String (A.Located Alias)

14+ , types :: Map.Map String (A.Located Union)

15+ , values :: Map.Map String (A.Located (Value t))

16+ }

17+

18+

19+type Centralized = Docs (Maybe Type.Type)

20+

21+type Checked = Docs Type.Type

22+

23+

24+-- VALUE DOCUMENTATION

25+

26+data Alias = Alias

27+ { aliasComment :: Maybe String

28+ , aliasArgs :: [String]

29+ , aliasType :: Type.Type

30+ }

31+

32+

33+data Union = Union

34+ { unionComment :: Maybe String

35+ , unionArgs :: [String]

36+ , unionCases :: [(String, [Type.Type])]

37+ }

38+

39+

40+data Value t = Value

41+ { valueComment :: Maybe String

42+ , valueType :: t

43+ , valueAssocPrec :: Maybe (String,Int)

44+ }

src/Docs/Centralize.hsnew file+100

@@ -0,0 +1,100 @@

1+module Docs.Centralize (centralize) where

2+

3+import Control.Arrow (second)

4+import qualified Data.Map as Map

5+

6+import qualified AST.Declaration as D

7+import qualified AST.Expression.Canonical as Canonical

8+import qualified AST.Pattern as P

9+import qualified Docs.AST as Docs

10+import qualified Elm.Compiler.Type as Type

11+import qualified Elm.Compiler.Type.Extract as Extract

12+import qualified Reporting.Annotation as A

13+

14+

15+-- CENTRALIZE DOCUMENTATION

16+

17+centralize :: [D.CanonicalDecl] -> String -> Docs.Centralized

18+centralize decls comment =

19+ let

20+ (Raw aliases types valueInfo fixities) =

21+ toRawDocs decls

22+

23+ values =

24+ Map.fromList (map (toValue fixities) (Map.toList valueInfo))

25+ in

26+ Docs.Docs comment aliases types values

27+

28+

29+toValue

30+ :: Map.Map String (String, Int)

31+ -> ( String, A.Located (Maybe String, Maybe Type.Type) )

32+ -> ( String, A.Located (Docs.Value (Maybe Type.Type)) )

33+toValue fixities (name, A.A region (maybeComment, maybeType)) =

34+ ( name

35+ , A.A region (Docs.Value maybeComment maybeType (Map.lookup name fixities))

36+ )

37+

38+

39+-- GATHER INFORMATION

40+

41+data Raw = Raw

42+ { rawAliases :: Map.Map String (A.Located Docs.Alias)

43+ , rawTypes :: Map.Map String (A.Located Docs.Union)

44+ , rawValues :: Map.Map String (A.Located (Maybe String, Maybe Type.Type))

45+ , rawFixities :: Map.Map String (String, Int)

46+ }

47+

48+

49+toRawDocs :: [D.CanonicalDecl] -> Raw

50+toRawDocs decls =

51+ foldr addDeclToDocs (Raw Map.empty Map.empty Map.empty Map.empty) decls

52+

53+

54+addDeclToDocs :: D.CanonicalDecl -> Raw -> Raw

55+addDeclToDocs (A.A (region,maybeComment) decl) docs =

56+ case decl of

57+ D.Definition (Canonical.Definition (A.A subregion (P.Var name)) _ maybeType) ->

58+ let

59+ info =

60+ ( maybeComment

61+ , fmap (Extract.toAliasedType . A.drop) maybeType

62+ )

63+

64+ newValues =

65+ Map.insert name (A.A subregion info) (rawValues docs)

66+ in

67+ docs { rawValues = newValues }

68+

69+ D.Definition _ ->

70+ docs

71+

72+ D.Datatype name args ctors ->

73+ let

74+ ctors' =

75+ map (second (map Extract.toAliasedType)) ctors

76+

77+ union =

78+ A.A region (Docs.Union maybeComment args ctors')

79+ in

80+ docs { rawTypes = Map.insert name union (rawTypes docs) }

81+

82+ D.TypeAlias name args tipe ->

83+ let

84+ alias =

85+ A.A region (Docs.Alias maybeComment args (Extract.toAliasedType tipe))

86+ in

87+ docs { rawAliases = Map.insert name alias (rawAliases docs) }

88+

89+ D.Port _ ->

90+ docs

91+

92+ D.Fixity assoc precedence name ->

93+ let

94+ fixity =

95+ (D.assocToString assoc, precedence)

96+ in

97+ docs

98+ { rawFixities =

99+ Map.insert name fixity (rawFixities docs)

100+ }

src/Docs/Check.hsnew file+180

@@ -0,0 +1,180 @@

1+module Docs.Check (check) where

2+

3+import Control.Applicative ((<$>),(<*>))

4+import qualified Data.List as List

5+import qualified Data.Map as Map

6+import qualified Data.Set as Set

7+import qualified Data.Traversable as T

8+import Text.Parsec ((<|>), choice, many, setPosition, string)

9+import Text.Parsec.Pos (newPos)

10+

11+import qualified AST.Variable as Var

12+import qualified Docs.AST as Docs

13+import qualified Elm.Compiler.Type as Type

14+import Elm.Utils ((|>))

15+import Parse.Helpers

16+ ( addLocation, anyUntil, commaSep1, iParse, parens, simpleNewline, symOp

17+ , var, whitespace

18+ )

19+import qualified Reporting.Annotation as A

20+import qualified Reporting.Error.Docs as Error

21+import qualified Reporting.Error.Helpers as Error (nearbyNames)

22+import qualified Reporting.Region as R

23+import qualified Reporting.Result as R

24+

25+

26+type Result w a = R.Result w Error.Error a

27+

28+

29+-- CHECK DOCUMENTATION

30+

31+check :: [Var.Value] -> A.Located (Maybe Docs.Centralized) -> Result w Docs.Checked

32+check exports (A.A region maybeDocs) =

33+ case maybeDocs of

34+ Nothing ->

35+ R.throw region Error.NoDocs

36+

37+ Just docs ->

38+ checkHelp region exports docs

39+

40+

41+checkHelp :: R.Region -> [Var.Value] -> Docs.Centralized -> Result w Docs.Checked

42+checkHelp region exports (Docs.Docs comment aliases types values) =

43+ let

44+ docNames =

45+ commentedNames region comment

46+

47+ docSet =

48+ Set.fromList (map A.drop docNames)

49+

50+ checkCategory checkValue dict =

51+ dict

52+ |> Map.filterWithKey (\key _ -> Set.member key docSet)

53+ |> Map.mapWithKey checkValue

54+ |> T.traverse id

55+

56+ exportedUnions =

57+ map (\(tipe, Var.Listing tags _) -> (tipe, tags)) (Var.getUnions exports)

58+ in

59+ (\() -> Docs.Docs comment)

60+ <$> checkModuleComment region exports docNames

61+ <*> checkCategory (checkComment Docs.aliasComment) aliases

62+ <*> checkCategory (checkUnion exportedUnions) types

63+ <*> checkCategory checkValue values

64+

65+

66+checkComment :: (a -> Maybe String) -> String -> A.Located a -> Result w (A.Located a)

67+checkComment getComment name (A.A region value) =

68+ case getComment value of

69+ Nothing ->

70+ R.throw region (Error.NoComment name)

71+

72+ Just _ ->

73+ R.ok (A.A region value)

74+

75+

76+checkUnion :: [(String, [String])] -> String -> A.Located Docs.Union -> Result w (A.Located Docs.Union)

77+checkUnion exportedUnions name value =

78+ const

79+ <$> filterUnionTags exportedUnions name value

80+ <*> checkComment Docs.unionComment name value

81+

82+

83+filterUnionTags :: [(String, [String])] -> String -> A.Located Docs.Union -> Result w (A.Located Docs.Union)

84+filterUnionTags exportedUnions name (A.A region union@(Docs.Union _ _ ctors)) =

85+ let

86+ exportedTags =

87+ maybe [] id (List.lookup name exportedUnions)

88+ in

89+ R.ok $ A.A region $ union

90+ { Docs.unionCases =

91+ filter (\(tag, _) -> elem tag exportedTags) ctors

92+ }

93+

94+

95+

96+checkValue :: String -> A.Located (Docs.Value (Maybe Type.Type)) -> Result w (A.Located (Docs.Value Type.Type))

97+checkValue name value =

98+ const

99+ <$> hasType name value

100+ <*> checkComment Docs.valueComment name value

101+

102+

103+hasType :: String -> A.Located (Docs.Value (Maybe Type.Type)) -> Result w (A.Located (Docs.Value Type.Type))

104+hasType name (A.A region value) =

105+ case Docs.valueType value of

106+ Just tipe ->

107+ R.ok (A.A region (value { Docs.valueType = tipe }))

108+

109+ Nothing ->

110+ R.throw region (Error.NoType name)

111+

112+

113+-- CHECK MODULE COMMENT

114+

115+checkModuleComment :: R.Region -> [Var.Value] -> [A.Located String] -> Result w ()

116+checkModuleComment docRegion exports locatedDocNames =

117+ let

118+ exportNames =

119+ map valueName exports

120+

121+ exportDict =

122+ Map.fromList (map (\name -> (name, ())) exportNames)

123+

124+ docDict =

125+ Map.fromList (map (\(A.A region name) -> (name, region)) locatedDocNames)

126+

127+ extraNameError (name, region) =

128+ R.throw region (Error.OnlyInDocs name (Error.nearbyNames id name exportNames))

129+

130+ docErrors =

131+ Map.difference docDict exportDict

132+ |> Map.toList

133+ |> T.traverse extraNameError

134+

135+ namesOnlyInExports =

136+ Map.difference exportDict docDict

137+ |> Map.toList

138+ |> map fst

139+

140+ exportErrors =

141+ if null namesOnlyInExports then

142+ R.ok ()

143+ else

144+ R.throw docRegion (Error.OnlyInExports namesOnlyInExports)

145+ in

146+ (\_ _ -> ())

147+ <$> exportErrors

148+ <*> docErrors

149+

150+

151+commentedNames :: R.Region -> String -> [A.Located String]

152+commentedNames (R.Region start _) comment =

153+ let

154+ nameParser =

155+ choice

156+ [ do string "@docs"

157+ whitespace

158+ commaSep1 (addLocation (var <|> parens symOp))

159+ , do anyUntil simpleNewline

160+ return []

161+ ]

162+

163+ docCommentParser =

164+ do setPosition (newPos "docs" (R.line start) (R.column start + 3))

165+ concat <$> many nameParser

166+ in

167+ case iParse docCommentParser comment of

168+ Left _ ->

169+ []

170+

171+ Right names ->

172+ names

173+

174+

175+valueName :: Var.Value -> String

176+valueName value =

177+ case value of

178+ Var.Value name -> name

179+ Var.Alias name -> name

180+ Var.Union name _ -> name

src/Elm/Compiler.hs+126−37

@@ -1,24 +1,29 @@

1{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE FlexibleContexts #-}

3module Elm.Compiler

2module Elm.Compiler

4 ( version, rawVersion

3 ( version, rawVersion

5− , parseDependencies, compile

4+ , parseDependencies

5+ , compile, Context(..), Result(..)

6+ , Dealiaser, dummyDealiaser

6− , Error, errorToString

7+ , Error, errorToString, errorToJson, printError

7− , Warning

8+ , Warning, warningToString, warningToJson, printWarning

8 ) where

9 ) where

9

10

10−import Control.Monad.Error.Class (MonadError, throwError)

11+import qualified Data.Aeson as Json

11import qualified Data.Map as Map

12import qualified Data.Map as Map

12

13

13import qualified AST.Module as Module

14import qualified AST.Module as Module

14import qualified Compile

15import qualified Compile

16+import qualified Docs.Check as Docs

15import qualified Elm.Compiler.Module as PublicModule

17import qualified Elm.Compiler.Module as PublicModule

16import qualified Elm.Compiler.Version as Version

18import qualified Elm.Compiler.Version as Version

19+import qualified Elm.Docs as Docs

17import qualified Generate.JavaScript as JS

20import qualified Generate.JavaScript as JS

18−import qualified Parse.Helpers as Help

21+import qualified Optimize

19import qualified Parse.Module as Parse

22import qualified Parse.Module as Parse

23+import qualified Parse.Parse as Parse

20import qualified Reporting.Annotation as A

24import qualified Reporting.Annotation as A

21import qualified Reporting.Error as Error

25import qualified Reporting.Error as Error

26+import qualified Reporting.PrettyPrint as P

22import qualified Reporting.Result as Result

27import qualified Reporting.Result as Result

23import qualified Reporting.Warning as Warning

28import qualified Reporting.Warning as Warning

24

29

@@ -38,56 +43,140 @@ rawVersion =

38-- DEPENDENCIES

43-- DEPENDENCIES

39

44

40parseDependencies

45parseDependencies

41− :: (MonadError String m)

46+ :: String

42− => String

43− -> m (PublicModule.Name, [PublicModule.Name])

47+ -> Either [Error] (PublicModule.Name, [PublicModule.Name])

44−parseDependencies src =

48+parseDependencies sourceCode =

45− case Help.iParse Parse.header src of

49+ let

46− Left msg ->

50+ (Result.Result _warnings rawResult) =

47− throwError (show msg)

51+ Parse.parse sourceCode Parse.header

52+ in

53+ case rawResult of

54+ Result.Err msgs ->

55+ Left $ map (Error . A.map Error.Syntax) msgs

48

56

49− Right (Module.Header names _exports imports) ->

57+ Result.Ok (Module.Header names _docs _exports imports) ->

50− return

58+ Right

51− ( PublicModule.Name names

59+ ( PublicModule.Name names

52− , map (PublicModule.Name . fst . A.drop) imports

60+ , map (PublicModule.Name . fst . A.drop) imports

53− )

61+ )

54

62

55

63

56-- COMPILATION

64-- COMPILATION

57

65

58{-| Compiles Elm source code to JavaScript. -}

66{-| Compiles Elm source code to JavaScript. -}

59compile

67compile

60− :: String

68+ :: Context

61− -> String

62 -> String

69 -> String

63 -> Map.Map PublicModule.Name PublicModule.Interface

70 -> Map.Map PublicModule.Name PublicModule.Interface

64− -> ([Warning], Either [Error] (PublicModule.Interface, String))

71+ -> (Dealiaser, [Warning], Either [Error] Result)

72+

65−compile user packageName source interfaces =

73+compile context source interfaces =

74+ let

75+ (Context user packageName isRoot isExposed) =

76+ context

77+

66− let unwrappedInterfaces =

78+ unwrappedInterfaces =

67− Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces

79+ Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces

80+

81+ (Result.Result (dealiaser, warnings) rawResult) =

82+ do modul <- Compile.compile user packageName isRoot unwrappedInterfaces source

83+ docs <- docsGen isExposed modul

84+

85+ let interface = Module.toInterface modul

86+ let optModule = Optimize.optimize modul

87+ let javascript = JS.generate optModule

68

88

69− (Result.Result warnings rawResult) =

89+ return (Result docs interface javascript)

70− Compile.compile user packageName unwrappedInterfaces source

71 in

90 in

91+ ( maybe dummyDealiaser Dealiaser dealiaser

72− (,) (map Warning warnings) $

92+ , map Warning warnings

73− case rawResult of

93+ , Result.destruct (Left . map Error) Right rawResult

74− Result.Ok modul ->

94+ )

75− Right (Module.toInterface modul, JS.generate modul)

95+

96+

97+data Context = Context

98+ { _user :: String

99+ , _packageName :: String

100+ , _isRoot :: Bool

101+ , _isExposed :: Bool

102+ }

103+

104+

105+data Result = Result

106+ { _docs :: Maybe Docs.Documentation

107+ , _interface :: PublicModule.Interface

108+ , _js :: String

109+ }

110+

111+

112+docsGen

113+ :: Bool

114+ -> Module.CanonicalModule

115+ -> Result.Result w Error.Error (Maybe Docs.Documentation)

116+docsGen isExposed modul =

117+ if not isExposed then

118+ Result.ok Nothing

119+ else

120+ let

121+ getChecked =

122+ Docs.check (Module.exports modul) (Module.docs modul)

123+

124+ toDocs checked =

125+ Docs.fromCheckedDocs (PublicModule.Name (Module.names modul)) checked

126+ in

127+ (Just . toDocs) `fmap` Result.mapError Error.Docs getChecked

128+

76

129

77− Result.Err errors ->

130+-- DEALIASER

78− Left (map Error errors)

131+

132+newtype Dealiaser =

133+ Dealiaser P.Dealiaser

134+

135+

136+dummyDealiaser :: Dealiaser

137+dummyDealiaser =

138+ Dealiaser Map.empty

79

139

80

140

81-- ERRORS

141-- ERRORS

82

142

143+newtype Error =

83−newtype Error = Error (A.Located Error.Error)

144+ Error (A.Located Error.Error)

145+

84

146

147+errorToString :: Dealiaser -> String -> String -> Error -> String

148+errorToString (Dealiaser dealiaser) location source (Error err) =

149+ Error.toString dealiaser location source err

85

150

151+

86−errorToString :: String -> String -> Error -> String

152+printError :: Dealiaser -> String -> String -> Error -> IO ()

87−errorToString location source (Error err) =

153+printError (Dealiaser dealiaser) location source (Error err) =

88− Error.toString location source err

154+ Error.print dealiaser location source err

155+

156+

157+errorToJson :: Dealiaser -> String -> Error -> Json.Value

158+errorToJson (Dealiaser dealiaser) location (Error err) =

159+ Error.toJson dealiaser location err

89

160

90

161

91-- WARNINGS

162-- WARNINGS

92

163

164+newtype Warning =

93−newtype Warning = Warning (A.Located Warning.Warning)

165+ Warning (A.Located Warning.Warning)

166+

167+

168+warningToString :: Dealiaser -> String -> String -> Warning -> String

169+warningToString (Dealiaser dealiaser) location source (Warning err) =

170+ Warning.toString dealiaser location source err

171+

172+

173+printWarning :: Dealiaser -> String -> String -> Warning -> IO ()

174+printWarning (Dealiaser dealiaser) location source (Warning err) =

175+ Warning.print dealiaser location source err

176+

177+

178+warningToJson :: Dealiaser -> String -> Warning -> Json.Value

179+warningToJson (Dealiaser dealiaser) location (Warning err) =

180+ Warning.toJson dealiaser location err

181+

182+

src/Elm/Compiler/Module.hs+4−4

@@ -5,7 +5,7 @@ module Elm.Compiler.Module

5 , hyphenate, dehyphenate

6 , defaultImports

7 , interfacePorts

8− , interfaceTypes

8+ , interfaceAliasedTypes

9 )

10 where

11

@@ -44,9 +44,9 @@ interfacePorts interface =

44 Module.iPorts interface

45

46

47−interfaceTypes :: Interface -> Map.Map String Type.Type

47+interfaceAliasedTypes :: Interface -> Map.Map String Type.Type

48−interfaceTypes interface =

48+interfaceAliasedTypes interface =

49− Map.map Extract.fromInternalType (Module.iTypes interface)

49+ Map.map Extract.toAliasedType (Module.iTypes interface)

50

51

52-- STRING CONVERSIONS for NAMES

src/Elm/Compiler/Type.hs+62−49

@@ -6,13 +6,19 @@ module Elm.Compiler.Type

6

7import Control.Applicative ((<$>), (<*>))

8import Control.Arrow (second)

9−import Data.Aeson ((.:), (.=))

9+import Data.Aeson ((.:))

10import qualified Data.Aeson as Json

11+import qualified Data.Aeson.Types as Json

11import qualified Data.ByteString.Lazy.Char8 as BS

12import qualified Data.ByteString.Lazy.Char8 as BS

12import qualified Data.Text as Text

13import qualified Data.Text as Text

13import Text.PrettyPrint as P

14import Text.PrettyPrint as P

14

15

15import qualified AST.Helpers as Help

16import qualified AST.Helpers as Help

17+import qualified AST.Type as Type

18+import qualified AST.Variable as Var

19+import qualified Parse.Helpers as Parse

20+import qualified Parse.Type as Type

21+import qualified Reporting.Annotation as A

16

22

17

23

18data Type

24data Type

@@ -88,9 +94,10 @@ toDoc context tipe =

88 (P.lbrace <+> P.text x <+> P.text "|")

94 (P.lbrace <+> P.text x <+> P.text "|")

89 4

95 4

90 (P.sep

96 (P.sep

91− [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))

97+ [ P.sep (P.punctuate P.comma (map prettyField fields))

92 , P.rbrace

98 , P.rbrace

93− ])

99+ ]

100+ )

94 where

101 where

95 prettyField (field, tipe) =

102 prettyField (field, tipe) =

96 P.text field <+> P.text ":" <+> toDoc None tipe

103 P.text field <+> P.text ":" <+> toDoc None tipe

@@ -121,62 +128,68 @@ flattenRecord tipe =

121-- JSON for TYPE

128-- JSON for TYPE

122

129

123instance Json.ToJSON Type where

130instance Json.ToJSON Type where

124− toJSON tipe =

131+ toJSON tipe =

125− Json.object (getFields tipe)

132+ Json.String (Text.unwords (Text.words (Text.pack (toString tipe))))

126− where

127− getFields tipe =

128− case tipe of

129− Lambda t1 t2 ->

130− [ "tag" .= ("lambda" :: Text.Text)

131− , "in" .= Json.toJSON t1

132− , "out" .= Json.toJSON t2

133− ]

134

133

135− Var x ->

136− [ "tag" .= ("var" :: Text.Text)

137− , "name" .= Json.toJSON x

138− ]

139

134

140− Type name ->

135+instance Json.FromJSON Type where

141− [ "tag" .= ("type" :: Text.Text)

136+ parseJSON value =

142− , "name" .= Json.toJSON name

137+ let

143− ]

138+ failure _ =

139+ fail $

140+ "Trying to decode a type string, but could not handle this value:\n"

141+ ++ BS.unpack (Json.encode value)

142+ in

143+ case value of

144+ Json.String text ->

145+ either failure (return . fromRawType)

146+ (Parse.iParse Type.expr (Text.unpack text))

144

147

145− App t ts ->

148+ Json.Object obj ->

146− [ "tag" .= ("app" :: Text.Text)

149+ fromObject obj

147− , "func" .= Json.toJSON t

148− , "args" .= Json.toJSON ts

149− ]

150

151− Record fields ext ->

151+ _ ->

152− [ "tag" .= ("record" :: Text.Text)

152+ failure ()

153− , "fields" .= Json.toJSON (map (Json.toJSON . second Json.toJSON) fields)

154− , "extension" .= Json.toJSON ext

155− ]

156

153

157

154

158−instance Json.FromJSON Type where

155+fromObject :: Json.Object -> Json.Parser Type

159− parseJSON (Json.Object obj) =

156+fromObject obj =

160− do tag <- obj .: "tag"

157+ do tag <- obj .: "tag"

161− case (tag :: String) of

158+ case (tag :: String) of

162− "lambda" ->

159+ "lambda" ->

163− Lambda <$> obj .: "in" <*> obj .: "out"

160+ Lambda <$> obj .: "in" <*> obj .: "out"

161+

162+ "var" ->

163+ Var <$> obj .: "name"

164+

165+ "type" ->

166+ Type <$> obj .: "name"

167+

168+ "app" ->

169+ App <$> obj .: "func" <*> obj .: "args"

170+

171+ "record" ->

172+ Record <$> obj .: "fields" <*> obj .: "extension"

173+

174+ _ ->

175+ fail $ "Error when decoding type with tag: " ++ tag

164

176

165− "var" ->

166− Var <$> obj .: "name"

167

177

168− "type" ->

178+fromRawType :: Type.Raw -> Type

169− Type <$> obj .: "name"

179+fromRawType (A.A _ astType) =

180+ case astType of

181+ Type.RLambda t1 t2 ->

182+ Lambda (fromRawType t1) (fromRawType t2)

170

183

171− "app" ->

184+ Type.RVar x ->

172− App <$> obj .: "func" <*> obj .: "args"

185+ Var x

173

186

174− "record" ->

187+ Type.RType var ->

175− Record <$> obj .: "fields" <*> obj .: "extension"

188+ Type (Var.toString var)

176

189

177− _ ->

190+ Type.RApp t ts ->

178− fail $ "Error when decoding type with tag: " ++ tag

191+ App (fromRawType t) (map fromRawType ts)

179

192

193+ Type.RRecord fields ext ->

194+ Record (map (second fromRawType) fields) (fmap fromRawType ext)

180

195

181− parseJSON value =

182− fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)

src/Elm/Compiler/Type/Extract.hs+23−9

@@ -1,4 +1,4 @@

1−module Elm.Compiler.Type.Extract where

1+module Elm.Compiler.Type.Extract (toFullType, toAliasedType) where

2

3import Control.Arrow (second)

4import qualified AST.Type as Type

@@ -6,13 +6,24 @@ import qualified AST.Variable as Var

6import qualified Elm.Compiler.Type as T

7

8

9−-- INTERNAL TYPE to PUBLIC TYPE

9+toFullType :: Type.Canonical -> T.Type

10+toFullType astType =

11+ toType False astType

10

12

13+

11−fromInternalType :: Type.Canonical -> T.Type

14+toAliasedType :: Type.Canonical -> T.Type

12−fromInternalType astType =

15+toAliasedType astType =

16+ toType True astType

17+

18+

19+toType :: Bool -> Type.Canonical -> T.Type

20+toType useAliases astType =

21+ let

22+ go = toType useAliases

23+ in

13 case astType of

24 case astType of

14 Type.Lambda t1 t2 ->

25 Type.Lambda t1 t2 ->

15− T.Lambda (fromInternalType t1) (fromInternalType t2)

26+ T.Lambda (go t1) (go t2)

16

27

17 Type.Var x ->

28 Type.Var x ->

18 T.Var x

29 T.Var x

@@ -21,10 +32,13 @@ fromInternalType astType =

21 T.Type (Var.toString var)

32 T.Type (Var.toString var)

22

33

23 Type.App t ts ->

34 Type.App t ts ->

24− T.App (fromInternalType t) (map fromInternalType ts)

35+ T.App (go t) (map go ts)

25

36

26 Type.Record fields ext ->

37 Type.Record fields ext ->

27− T.Record (map (second fromInternalType) fields) (fmap fromInternalType ext)

38+ T.Record (map (second go) fields) (fmap go ext)

28

39

29− Type.Aliased _name args t ->

40+ Type.Aliased name args t ->

41+ if useAliases then

42+ T.App (T.Type (Var.toString name)) (map (go . snd) args)

43+ else

30− fromInternalType (Type.dealias args t)

44+ go (Type.dealias args t)

src/Elm/Docs.hs+82−3

@@ -1,14 +1,20 @@

1{-# LANGUAGE OverloadedStrings #-}

2module Elm.Docs where

3

4−import Control.Applicative ((<$>),(<*>))

4+import Control.Applicative ((<$>),(<*>),(<|>))

5import Control.Monad

6import Data.Aeson ((.:), (.:?), (.=))

7import qualified Data.Aeson as Json

8+import qualified Data.Aeson.Encode.Pretty as Json

8import qualified Data.ByteString.Lazy.Char8 as BS

9import qualified Data.ByteString.Lazy.Char8 as BS

10+import qualified Data.Map as Map

11+import qualified Data.Text as Text

9

12

13+import qualified Docs.AST as Docs

10import qualified Elm.Compiler.Module as Module

14import qualified Elm.Compiler.Module as Module

11import qualified Elm.Compiler.Type as Type

15import qualified Elm.Compiler.Type as Type

16+import qualified Elm.Compiler.Version as Version

17+import qualified Reporting.Annotation as A

12

18

13

19

14data Documentation = Documentation

20data Documentation = Documentation

@@ -17,6 +23,7 @@ data Documentation = Documentation

17 , aliases :: [Alias]

23 , aliases :: [Alias]

18 , types :: [Union]

24 , types :: [Union]

19 , values :: [Value]

25 , values :: [Value]

26+ , version :: Version

20 }

27 }

21

28

22

29

@@ -40,22 +47,71 @@ data Value = Value

40 { valueName :: String

47 { valueName :: String

41 , valueComment :: String

48 , valueComment :: String

42 , valueType :: Type.Type

49 , valueType :: Type.Type

43− , valueAssocPrec :: Maybe (String,Int)

50+ , valueFix :: Maybe (String,Int)

44 }

51 }

45

52

46

53

54+data Version = NonCanonicalTypes | Version String

55+

56+

57+-- FROM CHECKED DOCS

58+

59+fromCheckedDocs :: Module.Name -> Docs.Checked -> Documentation

60+fromCheckedDocs name (Docs.Docs comment aliases unions values) =

61+ let

62+ unwrap cmnt =

63+ maybe "" id cmnt

64+

65+ toAlias (name, (A.A _ (Docs.Alias cmnt args tipe))) =

66+ Alias name (unwrap cmnt) args tipe

67+

68+ toUnion (name, (A.A _ (Docs.Union cmnt args cases))) =

69+ Union name (unwrap cmnt) args cases

70+

71+ toValue (name, (A.A _ (Docs.Value cmnt tipe fix))) =

72+ Value name (unwrap cmnt) tipe fix

73+ in

74+ Documentation name comment

75+ (map toAlias (Map.toList aliases))

76+ (map toUnion (Map.toList unions))

77+ (map toValue (Map.toList values))

78+ (Version Version.version)

79+

80+

81+-- PRETTY JSON

82+

83+prettyJson :: (Json.ToJSON a) => a -> BS.ByteString

84+prettyJson value =

85+ Json.encodePretty' config value

86+

87+

88+config :: Json.Config

89+config =

90+ Json.Config

91+ { Json.confIndent = 2

92+ , Json.confCompare = Json.keyOrder keys

93+ }

94+ where

95+ keys =

96+ [ "tag", "name", "comment", "aliases", "types"

97+ , "values", "func", "args", "type", "cases"

98+ ]

99+

100+

47-- JSON for DOCUMENTATION

101-- JSON for DOCUMENTATION

48

102

49instance Json.ToJSON Documentation where

103instance Json.ToJSON Documentation where

50− toJSON (Documentation name comment aliases types values) =

104+ toJSON (Documentation name comment aliases types values version) =

51 Json.object

105 Json.object

52 [ "name" .= name

106 [ "name" .= name

53 , "comment" .= comment

107 , "comment" .= comment

54 , "aliases" .= aliases

108 , "aliases" .= aliases

55 , "types" .= types

109 , "types" .= types

56 , "values" .= values

110 , "values" .= values

111+ , "generated-with-elm-version" .= version

57 ]

112 ]

58

113

114+

59instance Json.FromJSON Documentation where

115instance Json.FromJSON Documentation where

60 parseJSON (Json.Object obj) =

116 parseJSON (Json.Object obj) =

61 Documentation

117 Documentation

@@ -64,11 +120,34 @@ instance Json.FromJSON Documentation where

64 <*> obj .: "aliases"

120 <*> obj .: "aliases"

65 <*> obj .: "types"

121 <*> obj .: "types"

66 <*> obj .: "values"

122 <*> obj .: "values"

123+ <*> ((obj .: "generated-with-elm-version") <|> return NonCanonicalTypes)

67

124

68 parseJSON value =

125 parseJSON value =

69 fail $ "Cannot decode Documentation from: " ++ BS.unpack (Json.encode value)

126 fail $ "Cannot decode Documentation from: " ++ BS.unpack (Json.encode value)

70

127

71

128

129+-- JSON for VERSION

130+

131+instance Json.ToJSON Version where

132+ toJSON version =

133+ case version of

134+ NonCanonicalTypes ->

135+ Json.String "old"

136+

137+ Version vsn ->

138+ Json.String (Text.pack vsn)

139+

140+

141+instance Json.FromJSON Version where

142+ parseJSON (Json.String text) =

143+ case Text.unpack text of

144+ "old" -> return NonCanonicalTypes

145+ vrsn -> return (Version vrsn)

146+

147+ parseJSON value =

148+ fail $ "Cannot decode version of documentation from: " ++ BS.unpack (Json.encode value)

149+

150+

72-- JSON for ALIAS

151-- JSON for ALIAS

73

152

74instance Json.ToJSON Alias where

153instance Json.ToJSON Alias where

src/Elm/Utils.hs+30−3

@@ -1,8 +1,15 @@

1{-# OPTIONS_GHC -Wall #-}

2{-# LANGUAGE FlexibleContexts #-}

3+module Elm.Utils

4+ ( (|>), (<|)

5+ , getAsset

3−module Elm.Utils ((|>), (<|), getAsset, run, unwrappedRun, CommandError(..)) where

6+ , run, unwrappedRun

7+ , CommandError(..)

8+ , isDeclaration

9+ ) where

4

10

5import Control.Monad.Except (MonadError, MonadIO, liftIO, throwError)

11import Control.Monad.Except (MonadError, MonadIO, liftIO, throwError)

12+import qualified Data.List as List

6import System.Directory (doesFileExist)

13import System.Directory (doesFileExist)

7import System.Environment (getEnv)

14import System.Environment (getEnv)

8import System.Exit (ExitCode(ExitSuccess, ExitFailure))

15import System.Exit (ExitCode(ExitSuccess, ExitFailure))

@@ -10,7 +17,12 @@ import System.FilePath ((</>))

10import System.IO.Error (tryIOError)

17import System.IO.Error (tryIOError)

11import System.Process (readProcessWithExitCode)

18import System.Process (readProcessWithExitCode)

12

19

20+import qualified AST.Expression.Source as Source

21+import qualified AST.Pattern as Pattern

13import qualified Elm.Compiler.Version as Version

22import qualified Elm.Compiler.Version as Version

23+import qualified Parse.Helpers as Parse

24+import qualified Parse.Expression as Parse

25+import qualified Reporting.Annotation as A

14

26

15

27

16{-| Forward function application `x |> f == f x`. This function is useful

28{-| Forward function application `x |> f == f x`. This function is useful

@@ -75,7 +87,7 @@ unwrappedRun command args =

75missingExe :: String -> CommandError

87missingExe :: String -> CommandError

76missingExe command =

88missingExe command =

77 MissingExe $

89 MissingExe $

78− "Could not find command '" ++ command ++ "'. Do you have it installed?\n\

90+ "Could not find command `" ++ command ++ "`. Do you have it installed?\n\

79 \ Can it be run from anywhere? Is it on your PATH?"

91 \ Can it be run from anywhere? Is it on your PATH?"

80

92

81

93

@@ -116,6 +128,21 @@ errorNotFound name =

116 , " C:/Program Files/Elm Platform/" ++ Version.version ++ "/share"

128 , " C:/Program Files/Elm Platform/" ++ Version.version ++ "/share"

117 , " C:/Program Files (x86)/Elm Platform/" ++ Version.version ++ "/share"

129 , " C:/Program Files (x86)/Elm Platform/" ++ Version.version ++ "/share"

118 , ""

130 , ""

131+ , "If you installed using npm, you have to set ELM_HOME to a certain directory"

132+ , "of the form .../node_modules/elm/share"

133+ , ""

119 , "If it seems like a more complex issue, please report it here:"

134 , "If it seems like a more complex issue, please report it here:"

120 , " <https://github.com/elm-lang/elm-platform/issues>"

135 , " <https://github.com/elm-lang/elm-platform/issues>"

121− ]

136+ ]

137+

138+

139+-- DECL CHECKER

140+

141+isDeclaration :: String -> Maybe String

142+isDeclaration string =

143+ case Parse.iParse Parse.definition string of

144+ Right (A.A _ (Source.Definition pattern _)) ->

145+ Just (List.intercalate "$" (Pattern.boundVarList pattern))

146+

147+ _ ->

148+ Nothing

src/Generate/JavaScript.hs+602−268

@@ -1,17 +1,18 @@

1module Generate.JavaScript (generate) where

2

3import Control.Applicative ((<$>),(<*>))

4−import Control.Arrow (first,(***))

4+import Control.Arrow (first, second, (***))

5import Control.Monad.State

6import qualified Data.List as List

7import qualified Data.Map as Map

8+import qualified Data.Maybe as Maybe

8import qualified Data.Set as Set

9import qualified Data.Set as Set

9import Language.ECMAScript3.PrettyPrint

10import Language.ECMAScript3.PrettyPrint

10import Language.ECMAScript3.Syntax

11import Language.ECMAScript3.Syntax

11

12

12import AST.Module

13import AST.Module

13−import AST.Expression.General

14+import AST.Expression.General as Expr

14−import qualified AST.Expression.Canonical as Canonical

15+import qualified AST.Expression.Optimized as Opt

15import qualified AST.Helpers as Help

16import qualified AST.Helpers as Help

16import AST.Literal

17import AST.Literal

17import qualified AST.Module as Module

18import qualified AST.Module as Module

@@ -19,19 +20,22 @@ import qualified AST.Pattern as P

19import qualified AST.Variable as Var

20import qualified AST.Variable as Var

20import Elm.Utils ((|>))

21import Elm.Utils ((|>))

21import Generate.JavaScript.Helpers as Help

22import Generate.JavaScript.Helpers as Help

22−import qualified Generate.Cases as Case

23+import qualified Generate.JavaScript.Crash as Crash

23import qualified Generate.JavaScript.Port as Port

24import qualified Generate.JavaScript.Port as Port

24import qualified Generate.JavaScript.Variable as Var

25import qualified Generate.JavaScript.Variable as Var

26+import qualified Optimize.Cases as Case

25import qualified Reporting.Annotation as A

27import qualified Reporting.Annotation as A

26−import qualified Reporting.Region as R

28+import qualified Reporting.Crash as Crash

27

29

28

30

31+-- HELPERS

32+

29internalImports :: Module.Name -> [VarDecl ()]

33internalImports :: Module.Name -> [VarDecl ()]

30internalImports name =

34internalImports name =

31 [ varDecl "_N" (obj ["Elm","Native"])

35 [ varDecl "_N" (obj ["Elm","Native"])

32 , include "_U" "Utils"

36 , include "_U" "Utils"

33 , include "_L" "List"

37 , include "_L" "List"

34− , varDecl Help.localModuleName (string (Module.nameToString name))

38+ , varDecl Crash.localModuleName (string (Module.nameToString name))

35 ]

39 ]

36 where

40 where

37 include :: String -> String -> VarDecl ()

41 include :: String -> String -> VarDecl ()

@@ -59,51 +63,131 @@ literal lit =

59 Boolean b -> BoolLit () b

63 Boolean b -> BoolLit () b

60

64

61

65

66+-- CODE CHUNKS

67+

68+data Code

69+ = JsExpr (Expression ())

70+ | JsBlock [Statement ()]

71+

72+

73+jsExpr :: Expression () -> State Int Code

74+jsExpr exp =

75+ return (JsExpr exp)

76+

77+

78+jsBlock :: [Statement ()] -> State Int Code

79+jsBlock exp =

80+ return (JsBlock exp)

81+

82+

83+isBlock :: Code -> Bool

84+isBlock code =

85+ case code of

86+ JsBlock _ -> True

87+ JsExpr _ -> False

88+

89+

90+toStatementList :: Code -> [Statement ()]

91+toStatementList code =

92+ case code of

93+ JsExpr expr ->

94+ [ ret expr ]

95+ JsBlock stmts ->

96+ stmts

97+

98+

99+toStatement :: Code -> Statement ()

100+toStatement code =

101+ case code of

102+ JsExpr expr ->

103+ ret expr

104+ JsBlock [stmt] ->

105+ stmt

106+ JsBlock stmts ->

107+ BlockStmt () stmts

108+

109+

110+toExpr :: Code -> Expression ()

111+toExpr code =

112+ case code of

113+ JsExpr expr ->

114+ expr

115+ JsBlock stmts ->

116+ function [] stmts `call` []

117+

118+

119+-- TAIL CALL CONTEXT

120+

121+type TailCallContext =

122+ Maybe (String, [String], Label)

123+

124+

125+type Label =

126+ Id ()

127+

128+

129+-- EXPRESSIONS

130+

62−expression :: Canonical.Expr -> State Int (Expression ())

131+toJsExpr :: Opt.Expr -> State Int (Expression ())

63−expression (A.A region expr) =

132+toJsExpr =

133+ exprToJsExpr Nothing

134+

135+

136+toCode :: Opt.Expr -> State Int Code

137+toCode =

138+ exprToCode Nothing

139+

140+

141+exprToJsExpr :: TailCallContext -> Opt.Expr -> State Int (Expression ())

142+exprToJsExpr tcc canonicalExpr =

143+ toExpr <$> exprToCode tcc canonicalExpr

144+

145+

146+exprToCode :: TailCallContext -> Opt.Expr -> State Int Code

147+exprToCode tcc annotatedExpr@(A.A _ expr) =

64 case expr of

148 case expr of

65 Var var ->

149 Var var ->

66− return $ Var.canonical var

150+ jsExpr $ Var.canonical var

67

151

68 Literal lit ->

152 Literal lit ->

69− return $ literal lit

153+ jsExpr $ literal lit

70

154

71 Range lo hi ->

155 Range lo hi ->

72− do lo' <- expression lo

156+ do lo' <- toJsExpr lo

73− hi' <- expression hi

157+ hi' <- toJsExpr hi

74− return $ _List "range" `call` [lo',hi']

158+ jsExpr $ _List "range" `call` [lo',hi']

75

159

76− Access e field ->

160+ Access record field ->

77− do e' <- expression e

161+ do record' <- toJsExpr record

78− return $ DotRef () e' (var (Var.varName field))

162+ jsExpr $ DotRef () record' (var (Var.varName field))

79

163

80− Remove e field ->

164+ Remove record field ->

81− do e' <- expression e

165+ do record' <- toJsExpr record

82− return $ _Utils "remove" `call` [ string (Var.varName field), e' ]

166+ jsExpr $ _Utils "remove" `call` [ string (Var.varName field), record' ]

83

167

84− Insert e field value ->

168+ Insert record field value ->

85− do value' <- expression value

169+ do value' <- toJsExpr value

86− e' <- expression e

170+ record' <- toJsExpr record

87− return $ _Utils "insert" `call` [ string (Var.varName field), value', e' ]

171+ jsExpr $ _Utils "insert" `call` [ string (Var.varName field), value', record' ]

88

172

89− Modify e fields ->

173+ Modify record fields ->

90− do e' <- expression e

174+ do record' <- toJsExpr record

91 fields' <-

175 fields' <-

92 forM fields $ \(field, value) ->

176 forM fields $ \(field, value) ->

93− do value' <- expression value

177+ do value' <- toJsExpr value

94 return $ ArrayLit () [ string (Var.varName field), value' ]

178 return $ ArrayLit () [ string (Var.varName field), value' ]

95

179

96− return $ _Utils "replace" `call` [ArrayLit () fields', e']

180+ jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']

97

181

98 Record fields ->

182 Record fields ->

99 do fields' <-

183 do fields' <-

100 forM fields $ \(field, e) ->

184 forM fields $ \(field, e) ->

101− (,) (Var.varName field) <$> expression e

185+ (,) (Var.varName field) <$> toJsExpr e

102

186

103 let fieldMap =

187 let fieldMap =

104 List.foldl' combine Map.empty fields'

188 List.foldl' combine Map.empty fields'

105

189

106− return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap

190+ jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap

107 where

191 where

108 combine record (field, value) =

192 combine record (field, value) =

109 Map.insertWith (++) field [value] record

193 Map.insertWith (++) field [value] record

@@ -115,201 +199,370 @@ expression (A.A region expr) =

115 visible fs =

199 visible fs =

116 map (first prop) (Map.toList (Map.map head fs))

200 map (first prop) (Map.toList (Map.map head fs))

117

201

118− Binop op e1 e2 ->

202+ Binop op leftExpr rightExpr ->

119− binop region op e1 e2

203+ binop op leftExpr rightExpr

120

204

121− Lambda pattern rawBody@(A.A ann _) ->

205+ Lambda _ _ ->

122− do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)

206+ generateFunction (Expr.collectLambdas annotatedExpr)

123− body' <- expression body

207+

124− return $

125− case length args < 2 || length args > 9 of

126− True -> foldr (==>) body' (map (:[]) args)

127− False -> ref ("F" ++ show (length args)) <| (args ==> body')

128− where

129− depattern (args, body) pattern =

130− case pattern of

131− A.A _ (P.Var x) ->

132− return (args ++ [ Var.varName x ], body)

133−

134− _ ->

135− do arg <- Case.newVar

136− return

137− ( args ++ [arg]

138− , A.A ann (Case (A.A ann (localVar arg)) [(pattern, body)])

139− )

140−

141− (patterns, innerBody) =

142− collect [pattern] rawBody

143−

144− collect patterns lexpr@(A.A _ expr) =

145− case expr of

146− Lambda p e -> collect (p:patterns) e

147− _ -> (patterns, lexpr)

148−

149− App e1 e2 ->

208+ App _ _ ->

150− do func' <- expression func

209+ generateApplication tcc annotatedExpr

151− args' <- mapM expression args

210+

152− return $

153− case args' of

154− [arg] -> func' <| arg

155− _ | length args' <= 9 -> ref aN `call` (func':args')

156− | otherwise -> foldl1 (<|) (func':args')

157− where

158− aN = "A" ++ show (length args)

159− (func, args) = getArgs e1 [e2]

160− getArgs func args =

161− case func of

162− (A.A _ (App f arg)) -> getArgs f (arg : args)

163− _ -> (func, args)

164−

165− Let defs e ->

211+ Let defs body ->

166− do let (defs',e') = flattenLets defs e

212+ generateLet tcc defs body

167− stmts <- concat <$> mapM definition defs'

213+

168− exp <- expression e'

169− return $ function [] (stmts ++ [ ret exp ]) `call` []

170−

171− MultiIf branches ->

214+ MultiIf branches finally ->

172− do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

173− return $

174− case last branches of

175− (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->

176− safeIfs branches'

177− (A.A _ (Literal (Boolean True)), _) ->

178− safeIfs branches'

179− _ ->

180− ifs branches' (throw "badIf" region)

181− where

182− safeIfs branches = ifs (init branches) (snd (last branches))

183− ifs branches finally = foldr iff finally branches

215+ generateIf tcc branches finally

184− iff (if', then') else' = CondExpr () if' then' else'

216+

185−

217+ Case expr branches ->

186− Case e cases ->

218+ generateCase tcc expr branches

187− do (tempVar,initialMatch) <- Case.toMatch cases

219+

188− (revisedMatch, stmt) <-

189− case e of

190− A.A _ (Var (Var.Canonical Var.Local x)) ->

191− return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])

192− _ ->

193− do e' <- expression e

194− return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])

195− match' <- match region revisedMatch

196− return (function [] (stmt ++ match') `call` [])

197−

198− ExplicitList es ->

220+ ExplicitList elements ->

199− do es' <- mapM expression es

221+ do jsElements <- mapM toJsExpr elements

200− return $ _List "fromArray" <| ArrayLit () es'

222+ jsExpr $ _List "fromArray" <| ArrayLit () jsElements

201−

223+

202− Data name es ->

224+ Data tag members ->

203− do es' <- mapM expression es

225+ do jsMembers <- mapM toJsExpr members

204− return $ ObjectLit () (ctor : fields es')

226+ jsExpr $ ObjectLit () (ctor : fields jsMembers)

205 where

227 where

206− ctor = (prop "ctor", string name)

228+ ctor = (prop "ctor", string tag)

207 fields =

229 fields =

208 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]

230 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]

209

231

210 GLShader _uid src _tipe ->

232 GLShader _uid src _tipe ->

211− return $ ObjectLit () [(PropString () "src", literal (Str src))]

233+ jsExpr $ ObjectLit () [(PropString () "src", literal (Str src))]

212

234

213 Port impl ->

235 Port impl ->

214 case impl of

236 case impl of

215 In name portType ->

237 In name portType ->

216− return (Port.inbound name portType)

238+ jsExpr (Port.inbound name portType)

217

239

218 Out name expr portType ->

240 Out name expr portType ->

219− do expr' <- expression expr

241+ do expr' <- toJsExpr expr

220− return (Port.outbound name expr' portType)

242+ jsExpr (Port.outbound name expr' portType)

221

243

222 Task name expr portType ->

244 Task name expr portType ->

223− do expr' <- expression expr

245+ do expr' <- toJsExpr expr

224− return (Port.task name expr' portType)

246+ jsExpr (Port.task name expr' portType)

225−

247+

226−

248+ Crash details ->

227−definition :: Canonical.Def -> State Int [Statement ()]

249+ jsExpr $ Crash.crash details

228−definition (Canonical.Definition annPattern expr@(A.A region _) _) =

250+

229− do expr' <- expression expr

251+

230− let assign x = varDecl x expr'

252+-- FUNCTIONS

231− let (A.A patternRegion pattern) = annPattern

253+

232− case pattern of

254+generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code

233− P.Var x

255+generateFunction (args, initialBody) =

234− | Help.isOp x ->

256+ do (argVars, patternDefs) <- destructuredArgs args

235− let op = LBracket () (ref "_op") (string x) in

257+ code <- generateLet Nothing patternDefs initialBody

258+ jsExpr (generateFunctionWithArity argVars code)

259+

260+

261+generateTailFunction :: String -> ([P.Optimized], Opt.Expr) -> State Int (Expression ())

262+generateTailFunction name (args, initialBody) =

263+ do (argVars, patternDefs) <- destructuredArgs args

264+ label <- Id () <$> Case.newVar

265+ code <- generateLet (Just (name, argVars, label)) patternDefs initialBody

266+ let whileLoop =

267+ JsBlock [ LabelledStmt () label (WhileStmt () (BoolLit () True) (toStatement code)) ]

268+ return (generateFunctionWithArity argVars whileLoop)

269+

270+

271+generateFunctionWithArity :: [String] -> Code -> Expression ()

272+generateFunctionWithArity args code =

273+ let

274+ arity = length args

275+ in

276+ if 2 <= arity && arity <= 9 then

277+ let

278+ fN = "F" ++ show arity

279+ in

280+ ref fN <| function args (toStatementList code)

281+ else

282+ let

283+ (lastArg:otherArgs) = reverse args

284+ innerBody = function [lastArg] (toStatementList code)

285+ in

286+ foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs

287+

288+

289+destructuredArgs :: [P.Optimized] -> State Int ([String], [Opt.Def])

290+destructuredArgs args =

291+ do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args

292+ return (argVars, Maybe.catMaybes maybePatternDefs)

293+

294+

295+destructPattern :: P.Optimized -> State Int (String, Maybe Opt.Def)

296+destructPattern pattern@(A.A ann pat) =

297+ case pat of

298+ P.Var x ->

299+ return (Var.varName x, Nothing)

300+

301+ _ ->

302+ do arg <- Case.newVar

303+ return

304+ ( arg

305+ , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))

306+ )

307+

308+

309+-- APPLICATIONS

310+

311+generateApplication :: TailCallContext -> Opt.Expr -> State Int Code

312+generateApplication tcc expr =

313+ let

314+ (func:args) =

315+ Expr.collectApps expr

316+

317+ arity =

318+ length args

319+

320+ reassign name tempName =

236− return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

321+ ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))

237−

322+

238− | otherwise ->

323+ aN =

239− return [ VarDeclStmt () [ assign (Var.varName x) ] ]

324+ "A" ++ show arity

240−

325+ in

241− P.Record fields ->

326+ case isTailCall tcc func arity of

242− let setField f = varDecl f (obj ["$",f]) in

327+ Just (argNames, label) ->

243− return [ VarDeclStmt () (assign "$" : map setField fields) ]

328+ do args' <- mapM toJsExpr args

244−

329+ tempNames <- mapM (\_ -> Case.newVar) args

245− P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

330+ jsBlock $

246− return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

331+ VarDeclStmt () (zipWith varDecl tempNames args')

247− where

332+ : zipWith reassign argNames tempNames

248− vars = getVars patterns

333+ ++ [ContinueStmt () (Just label)]

249− getVars patterns =

250− case patterns of

251− A.A _ (P.Var x) : rest ->

252− (Var.varName x :) `fmap` getVars rest

253− [] ->

254− Just []

255− _ ->

256− Nothing

257−

258− decl x n = varDecl x (obj ["$","_" ++ show n])

259− setup vars

260− | Help.isTuple name = assign "$" : vars

261− | otherwise = assign "_raw" : safeAssign : vars

262−

263− safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

264− if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

265− exception = Help.throw "badCase" region

266

334

267− _ ->

335+ _ ->

336+ do func' <- toJsExpr func

337+ args' <- mapM toJsExpr args

338+ jsExpr $

339+ if 2 <= arity && arity <= 9 then

340+ ref aN `call` (func':args')

341+ else

342+ foldl1 (<|) (func':args')

343+

344+

345+isTailCall :: TailCallContext -> Opt.Expr -> Int -> Maybe ([String], Label)

346+isTailCall tcc (A.A _ func) arity =

347+ case (func, tcc) of

348+ (Var (Var.Canonical Var.Local name), Just (tcName, tcArgs, tcLabel)) ->

349+ if name == tcName && length tcArgs == arity then

350+ Just (tcArgs, tcLabel)

351+ else

352+ Nothing

353+

354+ _ ->

355+ Nothing

356+

357+

358+-- LET EXPRESSIONS

359+

360+generateLet

361+ :: TailCallContext

362+ -> [Opt.Def]

363+ -> Opt.Expr

364+ -> State Int Code

365+generateLet tcc givenDefs givenBody =

366+ do let (defs, body) = flattenLets givenDefs givenBody

367+ stmts <- concat <$> mapM defToStatements defs

368+ code <- exprToCode tcc body

369+ jsBlock (stmts ++ toStatementList code)

370+

371+

372+-- GENERATE IFS

373+

374+generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code

375+generateIf tcc givenBranches givenFinally =

376+ let

377+ (branches, finally) =

378+ crushIfs givenBranches givenFinally

379+

380+ convertBranch (condition, expr) =

381+ (,) <$> toJsExpr condition <*> exprToCode tcc expr

382+

383+ ifExpression (condition, branch) otherwise =

384+ CondExpr () condition branch otherwise

385+

386+ ifStatement (condition, branch) otherwise =

387+ IfStmt () condition branch otherwise

388+ in

389+ do jsBranches <- mapM convertBranch branches

390+ jsFinally <- exprToCode tcc finally

391+

392+ if any isBlock (jsFinally : map snd jsBranches)

393+ then

394+ jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]

395+ else

396+ jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))

397+

398+

399+crushIfs

400+ :: [(Opt.Expr, Opt.Expr)]

401+ -> Opt.Expr

402+ -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)

403+crushIfs branches finally =

404+ crushIfsHelp [] branches finally

405+

406+

407+crushIfsHelp

408+ :: [(Opt.Expr, Opt.Expr)]

409+ -> [(Opt.Expr, Opt.Expr)]

410+ -> Opt.Expr

411+ -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)

412+crushIfsHelp visitedBranches unvisitedBranches finally =

413+ case unvisitedBranches of

414+ [] ->

415+ case finally of

416+ A.A _ (MultiIf subBranches subFinally) ->

417+ crushIfsHelp visitedBranches subBranches subFinally

418+

419+ _ ->

420+ (reverse visitedBranches, finally)

421+

422+ (A.A _ (Literal (Boolean True)), branch) : _ ->

423+ crushIfsHelp visitedBranches [] branch

424+

425+ (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), branch) : _ ->

426+ crushIfsHelp visitedBranches [] branch

427+

428+ visiting : unvisited ->

429+ crushIfsHelp (visiting : visitedBranches) unvisited finally

430+

431+

432+

433+-- DEFINITIONS

434+

435+defToStatements :: Opt.Def -> State Int [Statement ()]

436+defToStatements def@(Opt.Definition facts pattern expr) =

437+ case Opt.tailRecursionDetails facts of

438+ Just name ->

439+ do func <- generateTailFunction name (Expr.collectLambdas expr)

440+ return [ VarDeclStmt () [ varDecl name func ] ]

441+

442+ Nothing ->

443+ defToStatementsHelp facts pattern =<< toJsExpr expr

444+

445+

446+defToStatementsHelp

447+ :: Opt.Facts

448+ -> P.Optimized

449+ -> Expression ()

450+ -> State Int [Statement ()]

451+defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =

452+ let

453+ define x =

454+ varDecl x jsExpr

455+ in

456+ case pattern of

457+ P.Var x ->

458+ if Help.isOp x then

459+ let

460+ op = LBracket () (ref "_op") (string x)

461+ in

462+ return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]

463+ else

464+ return [ VarDeclStmt () [ define (Var.varName x) ] ]

465+

466+ P.Record fields ->

467+ let

468+ setField name =

469+ varDecl name (obj ["$",name])

470+ in

471+ return [ VarDeclStmt () (define "$" : map setField fields) ]

472+

473+ P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

474+ return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

475+ where

476+ vars = getVars patterns

477+ getVars patterns =

478+ case patterns of

479+ A.A _ (P.Var x) : rest ->

480+ (Var.varName x :) `fmap` getVars rest

481+ [] ->

482+ Just []

483+ _ ->

484+ Nothing

485+

486+ decl x n = varDecl x (obj ["$","_" ++ show n])

487+ setup vars

488+ | Help.isTuple name = define "$" : vars

489+ | otherwise = define "_raw" : safeAssign : vars

490+

491+ safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

492+ if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

493+ exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))

494+

495+ _ ->

268− do defs' <- concat <$> mapM toDef vars

496+ do defs' <- concat <$> mapM toDef vars

269− return (VarDeclStmt () [assign "_"] : defs')

497+ return (VarDeclStmt () [define "_"] : defs')

270− where

498+ where

271− vars = P.boundVarList annPattern

499+ vars = P.boundVarList annPattern

272− mkVar = A.A region . localVar

500+ mkVar = A.A () . localVar

273− toDef y =

501+ toDef y =

274− let expr = A.A region $ Case (mkVar "_") [(annPattern, mkVar y)]

502+ let expr = A.A () $ Case (mkVar "_") [(annPattern, mkVar y)]

275− pat = A.A patternRegion (P.Var y)

503+ pat = A.A () (P.Var y)

276− in

504+ in

277− definition (Canonical.Definition pat expr Nothing)

505+ defToStatements (Opt.Definition facts pat expr)

278−

506+

279−

507+

508+-- CASE EXPRESSIONS

509+

510+generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code

511+generateCase tcc expr branches =

512+ do (tempVar, initialMatch) <-

513+ Case.toMatch branches

514+

515+ (revisedMatch, stmt) <-

516+ case expr of

517+ A.A _ (Var (Var.Canonical Var.Local x)) ->

518+ return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])

519+ _ ->

520+ do expr' <- toJsExpr expr

521+ return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])

522+

523+ match' <- match tcc revisedMatch

524+

525+ jsBlock (stmt ++ match')

526+

527+

280−match :: R.Region -> Case.Match -> State Int [Statement ()]

528+match :: TailCallContext -> Case.Match -> State Int [Statement ()]

281−match region mtch =

529+match tcc mtch =

282 case mtch of

530 case mtch of

283 Case.Match name clauses mtch' ->

531 Case.Match name clauses mtch' ->

284− do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses

532+ do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses

285− mtch'' <- match region mtch'

533+ mtch'' <- match tcc mtch'

286 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')

534 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')

287 where

535 where

288 isLiteral p =

536 isLiteral p =

289 case p of

537 case p of

290− Case.Clause (Right _) _ _ -> True

538+ Case.Clause (Right _) _ _ ->

539+ True

540+ _ ->

291− _ -> False

541+ False

292−

542+

293− access name

543+ access name =

294− | any isLiteral clauses = obj [name]

544+ if any isLiteral clauses then

545+ obj [name]

546+ else

295− | otherwise = obj (Help.splitDots name ++ ["ctor"])

547+ obj (Help.splitDots name ++ ["ctor"])

296−

548+

297− format isChars e

549+ format isChars expr =

550+ if or isChars then

298− | or isChars = InfixExpr () OpAdd e (string "")

551+ InfixExpr () OpAdd expr (string "")

299− | otherwise = e

552+ else

553+ expr

300

554

301 Case.Fail ->

555 Case.Fail ->

302− return [ ExprStmt () (Help.throw "badCase" region) ]

556+ return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]

303

557

304 Case.Break ->

558 Case.Break ->

305 return [BreakStmt () Nothing]

559 return [BreakStmt () Nothing]

306

560

307− Case.Other e ->

561+ Case.Other expr ->

308− do e' <- expression e

562+ toStatementList <$> exprToCode tcc expr

309− return [ ret e' ]

310

563

311 Case.Seq ms ->

564 Case.Seq ms ->

312− concat <$> mapM (match region) (dropEnd [] ms)

565+ concat <$> mapM (match tcc) (dropEnd [] ms)

313 where

566 where

314 dropEnd acc [] = acc

567 dropEnd acc [] = acc

315 dropEnd acc (m:ms) =

568 dropEnd acc (m:ms) =

@@ -318,9 +571,10 @@ match region mtch =

318 _ -> dropEnd (acc ++ [m]) ms

571 _ -> dropEnd (acc ++ [m]) ms

319

572

320

573

321−clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())

574+clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())

322−clause region variable (Case.Clause value vars mtch) =

575+clause tcc variable (Case.Clause value vars mtch) =

323− (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)

576+ do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)

577+ return ((,) isChar (CaseClause () pattern statemens))

324 where

578 where

325 vars' =

579 vars' =

326 map (\n -> variable ++ "._" ++ show n) [0..]

580 map (\n -> variable ++ "._" ++ show n) [0..]

@@ -337,14 +591,14 @@ clause region variable (Case.Clause value vars mtch) =

337 string name

591 string name

338

592

339

593

340−flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)

594+flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)

341flattenLets defs lexpr@(A.A _ expr) =

595flattenLets defs lexpr@(A.A _ expr) =

342 case expr of

596 case expr of

343 Let ds body -> flattenLets (defs ++ ds) body

597 Let ds body -> flattenLets (defs ++ ds) body

344 _ -> (defs, lexpr)

598 _ -> (defs, lexpr)

345

599

346

600

347−generate :: CanonicalModule -> String

601+generate :: Module.Optimized -> String

348generate modul =

602generate modul =

349 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

603 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

350 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]

604 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]

@@ -393,7 +647,7 @@ generate modul =

393 Module.program (Module.body modul)

647 Module.program (Module.body modul)

394 |> flattenLets []

648 |> flattenLets []

395 |> fst

649 |> fst

396− |> mapM definition

650+ |> mapM defToStatements

397

651

398 setup namespace path =

652 setup namespace path =

399 map create paths

653 map create paths

@@ -430,63 +684,104 @@ generate modul =

430 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

684 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

431

685

432

686

687+-- BINARY OPERATORS

688+

433binop

689binop

434− :: R.Region

435− -> Var.Canonical

690+ :: Var.Canonical

436− -> Canonical.Expr

691+ -> Opt.Expr

437− -> Canonical.Expr

692+ -> Opt.Expr

438− -> State Int (Expression ())

693+ -> State Int Code

439−binop region func@(Var.Canonical home op) e1 e2 =

694+binop func left right

440− case (home, op) of

441− (Var.Module ["Basics"], ">>") ->

442− do es <- mapM expression (collectLeftAssoc [e2] e1)

443− return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es

444−

445− (Var.Module ["Basics"], "<<") ->

446− do es <- mapM expression (e1 : collectRightAssoc [] e2)

447− return $ ["$"] ==> foldr (<|) (ref "$") es

448−

449− (Var.Module ["Basics"], "<|") ->

450− do e2' <- expression e2

451− es <- mapM expression (collectRightAssoc [] e1)

452− return $ foldr (<|) e2' es

453−

454− (Var.BuiltIn, "::") ->

695+ | func == Var.Canonical Var.BuiltIn "::" =

455− expression (A.A region (Data "::" [e1,e2]))

696+ toCode (A.A () (Data "::" [left,right]))

456−

457− (Var.Module ["Basics"], _) ->

458− do e1' <- expression e1

459− e2' <- expression e2

460− case Map.lookup op basicOps of

461− Just f ->

462− return (f e1' e2')

463−

464− Nothing ->

465− return (ref "A2" `call` [ Var.canonical func, e1', e2' ])

466

697

467− _ ->

698+ | func == forwardCompose =

468− do e1' <- expression e1

699+ compose (collectLeftAssoc forwardCompose left right)

469− e2' <- expression e2

470− return (ref "A2" `call` [ Var.canonical func, e1', e2' ])

471

700

472− where

701+ | func == backwardCompose =

473− collectRightAssoc es e =

702+ compose (collectRightAssoc backwardCompose left right)

474− case e of

703+

475− A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->

704+ | func == forwardApply =

476− collectRightAssoc (es ++ [e1]) e2

705+ pipe (collectLeftAssoc forwardApply left right)

477− _ -> es ++ [e]

706+

478−

707+ | func == backwardApply =

479− collectLeftAssoc es e =

708+ pipe (collectRightAssoc backwardApply left right)

480− case e of

709+

710+ | otherwise =

711+ do jsLeft <- toJsExpr left

712+ jsRight <- toJsExpr right

713+ jsExpr (makeExpr func jsLeft jsRight)

714+

715+

716+-- CONTROL FLOW OPERATOR HELPERS

717+

718+apply :: Expression () -> Expression () -> Expression ()

719+apply arg func =

720+ func <| arg

721+

722+

723+compose :: [Opt.Expr] -> State Int Code

724+compose functions =

725+ do jsFunctions <- mapM toJsExpr functions

726+ jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions

727+

728+

729+pipe :: [Opt.Expr] -> State Int Code

730+pipe expressions =

731+ do (value:functions) <- mapM toJsExpr expressions

732+ jsExpr $ List.foldl' apply value functions

733+

734+

735+forwardCompose :: Var.Canonical

736+forwardCompose =

737+ inBasics ">>"

738+

739+

740+backwardCompose :: Var.Canonical

741+backwardCompose =

742+ inBasics "<<"

743+

744+

745+forwardApply :: Var.Canonical

746+forwardApply =

747+ inBasics "|>"

748+

749+

750+backwardApply :: Var.Canonical

751+backwardApply =

752+ inBasics "<|"

753+

754+

755+inBasics :: String -> Var.Canonical

756+inBasics name =

757+ Var.Canonical (Var.Module ["Basics"]) name

758+

759+

760+-- BINARY OPERATOR HELPERS

761+

762+makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())

763+makeExpr qualifiedOp@(Var.Canonical home op) =

764+ let

765+ simpleMake left right =

766+ ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]

767+ in

481− A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->

768+ if home == Var.Module ["Basics"] then

482− collectLeftAssoc (e2 : es) e1

769+ Map.findWithDefault simpleMake op basicOps

483− _ -> e : es

770+ else

484−

771+ simpleMake

772+

773+

774+basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())

485− basicOps =

775+basicOps =

486− Map.fromList (infixOps ++ specialOps)

776+ Map.fromList (infixOps ++ specialOps)

487−

777+

488− infixOps =

778+

779+infixOps :: [(String, Expression () -> Expression () -> Expression ())]

780+infixOps =

781+ let

782+ infixOp str op =

489− let infixOp str op = (str, InfixExpr () op) in

783+ (str, InfixExpr () op)

784+ in

490 [ infixOp "+" OpAdd

785 [ infixOp "+" OpAdd

491 , infixOp "-" OpSub

786 , infixOp "-" OpSub

492 , infixOp "*" OpMul

787 , infixOp "*" OpMul

@@ -495,17 +790,56 @@ binop region func@(Var.Canonical home op) e1 e2 =

495 , infixOp "||" OpLOr

790 , infixOp "||" OpLOr

496 ]

791 ]

497

792

498− specialOps =

499− [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

500− , (,) "|>" $ flip (<|)

501− , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]

502− , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])

503− , (,) "<" $ cmp OpLT 0

504− , (,) ">" $ cmp OpGT 0

505− , (,) "<=" $ cmp OpLT 1

506− , (,) ">=" $ cmp OpGT (-1)

507− , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

508− ]

509

793

794+specialOps :: [(String, Expression () -> Expression () -> Expression ())]

795+specialOps =

796+ [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

797+ , (,) "|>" $ flip (<|)

798+ , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]

799+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])

800+ , (,) "<" $ cmp OpLT 0

801+ , (,) ">" $ cmp OpGT 0

802+ , (,) "<=" $ cmp OpLT 1

803+ , (,) ">=" $ cmp OpGT (-1)

804+ , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

805+ ]

806+

807+

808+cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()

510− cmp op n a b =

809+cmp op n a b =

511− InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)

810+ InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)

811+

812+

813+-- BINARY OPERATOR COLLECTORS

814+

815+-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff

816+collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]

817+collectRightAssoc desiredOp left right =

818+ collectRightAssocHelp desiredOp [left] right

819+

820+

821+collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]

822+collectRightAssocHelp desiredOp exprList expr =

823+ case expr of

824+ A.A _ (Binop op left right) | op == desiredOp ->

825+ collectRightAssocHelp desiredOp (left : exprList) right

826+

827+ _ ->

828+ expr : exprList

829+

830+

831+-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff

832+collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]

833+collectLeftAssoc desiredOp left right =

834+ collectLeftAssocHelp desiredOp [right] left

835+

836+

837+collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]

838+collectLeftAssocHelp desiredOp exprList expr =

839+ case expr of

840+ A.A _ (Binop op left right) | op == desiredOp ->

841+ collectLeftAssocHelp desiredOp (right : exprList) left

842+

843+ _ ->

844+ expr : exprList

845+

src/Generate/JavaScript/Crash.hsnew file+32

@@ -0,0 +1,32 @@

1+module Generate.JavaScript.Crash where

2+

3+import Language.ECMAScript3.Syntax (Expression)

4+

5+import Generate.JavaScript.Helpers (call, obj, ref, string)

6+import qualified Reporting.Crash as Crash

7+import qualified Reporting.Region as R

8+

9+

10+localModuleName :: String

11+localModuleName =

12+ "$moduleName"

13+

14+

15+crash :: Crash.Details -> Expression ()

16+crash details =

17+ case details of

18+ Crash.IncompleteMultiIf region ->

19+ obj ["_U","badIf"]

20+ `call`

21+ [ ref localModuleName

22+ , string (R.toString region)

23+ ]

24+

25+ Crash.IncompletePatternMatch _region ->

26+ obj ["_U","badCase"]

27+ `call`

28+ [ ref localModuleName

29+ , string "bugs in reporting the exact location right now" -- TODO

30+ ]

31+

32+

src/Generate/JavaScript/Helpers.hs−19

@@ -2,8 +2,6 @@ module Generate.JavaScript.Helpers where

2

3import Language.ECMAScript3.Syntax

4

5−import qualified Reporting.Region as R

6−

7

5

8localRuntime :: String

6localRuntime :: String

9localRuntime =

7localRuntime =

@@ -52,23 +50,6 @@ obj vars =

52 [] -> error "dotSep must be called on a non-empty list of variables"

50 [] -> error "dotSep must be called on a non-empty list of variables"

53

51

54

52

55−-- Specific Utilities

56−

57−localModuleName :: String

58−localModuleName =

59− "$moduleName"

60−

61−

62−throw :: String -> R.Region -> Expression ()

63−throw kind region =

64− let args =

65− [ ref localModuleName

66− , string (R.toString region)

67− ]

68− in

69− obj ["_U",kind] `call` args

70−

71−

72-- Function Calls

53-- Function Calls

73

54

74(<|) :: Expression () -> Expression () -> Expression ()

55(<|) :: Expression () -> Expression () -> Expression ()

src/Generate/JavaScript/Port.hs+4−3

@@ -1,6 +1,7 @@

1module Generate.JavaScript.Port (inbound, outbound, task) where

2

3import qualified Data.List as List

4+import qualified Data.Map as Map

4import Language.ECMAScript3.Syntax

5import Language.ECMAScript3.Syntax

5

6

6import qualified AST.Type as T

7import qualified AST.Type as T

@@ -40,7 +41,7 @@ typeToString tipe =

40 JSString -> "a string"

41 JSString -> "a string"

41 JSArray -> "an array"

42 JSArray -> "an array"

42 JSObject fields ->

43 JSObject fields ->

43− "an object with fields '" ++ List.intercalate "', '" fields ++ "'"

44+ "an object with fields `" ++ List.intercalate "`, `" fields ++ "`"

44

45

46

46_Array :: String -> Expression ()

47_Array :: String -> Expression ()

@@ -96,14 +97,14 @@ inbound name portType =

96 T.Normal tipe ->

97 T.Normal tipe ->

97 _Port "inbound" `call`

98 _Port "inbound" `call`

98 [ string name

99 [ string name

99− , string (show (P.pretty False tipe))

100+ , string (show (P.pretty Map.empty False tipe))

100 , toTypeFunction tipe

101 , toTypeFunction tipe

101 ]

102 ]

102

103

103 T.Signal _root arg ->

104 T.Signal _root arg ->

104 _Port "inboundSignal" `call`

105 _Port "inboundSignal" `call`

105 [ string name

106 [ string name

106− , string (show (P.pretty False arg))

107+ , string (show (P.pretty Map.empty False arg))

107 , toTypeFunction arg

108 , toTypeFunction arg

108 ]

109 ]

109

110

src/Nitpick/TopLevelTypes.hsnew file+115

@@ -0,0 +1,115 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Nitpick.TopLevelTypes (topLevelTypes) where

3+

4+import Prelude hiding (maybe)

5+import qualified Data.Foldable as F

6+import qualified Data.Map as Map

7+

8+import qualified AST.Expression.Valid as Valid

9+import qualified AST.Declaration as Decl

10+import qualified AST.Pattern as P

11+import qualified AST.Type as Type

12+import qualified AST.Variable as Var

13+import qualified Reporting.Annotation as A

14+import qualified Reporting.Error.Type as Error

15+import qualified Reporting.Result as Result

16+import qualified Reporting.Warning as Warning

17+

18+

19+topLevelTypes

20+ :: Map.Map String Type.Canonical

21+ -> [Decl.ValidDecl]

22+ -> Result.Result Warning.Warning Error.Error ()

23+topLevelTypes typeEnv validDecls =

24+ do F.traverse_ (warnMissingAnnotation typeEnv) validDecls

25+ checkMainType typeEnv validDecls

26+

27+

28+-- MISSING ANNOTATIONS

29+

30+warnMissingAnnotation

31+ :: Map.Map String Type.Canonical

32+ -> Decl.ValidDecl

33+ -> Result.Result Warning.Warning Error.Error ()

34+warnMissingAnnotation typeEnv (A.A (region,_) decl) =

35+ case decl of

36+ Decl.Definition (Valid.Definition (A.A _ (P.Var name)) _ Nothing) ->

37+ case Map.lookup name typeEnv of

38+ Nothing ->

39+ return ()

40+ Just tipe ->

41+ Result.warn region (Warning.MissingTypeAnnotation name tipe)

42+ _ ->

43+ return ()

44+

45+

46+-- MAIN TYPE

47+

48+checkMainType

49+ :: Map.Map String Type.Canonical

50+ -> [Decl.ValidDecl]

51+ -> Result.Result w Error.Error ()

52+checkMainType typeEnv decls =

53+ case decls of

54+ A.A (region,_) (Decl.Definition (Valid.Definition (A.A _ (P.Var "main")) _ _)) : _ ->

55+ case Map.lookup "main" typeEnv of

56+ Nothing ->

57+ return ()

58+

59+ Just typeOfMain ->

60+ let tipe = Type.deepDealias typeOfMain

61+ in

62+ if tipe `elem` validMainTypes

63+ then return ()

64+ else Result.throw region (Error.BadMain typeOfMain)

65+

66+ _ : remainingDecls ->

67+ checkMainType typeEnv remainingDecls

68+

69+ [] ->

70+ return ()

71+

72+

73+validMainTypes :: [Type.Canonical]

74+validMainTypes =

75+ [ element

76+ , html

77+ , signal element

78+ , signal html

79+ ]

80+ where

81+ fromModule :: [String] -> String -> Type.Canonical

82+ fromModule home name =

83+ Type.Type (Var.fromModule home name)

84+

85+ html =

86+ fromModule ["VirtualDom"] "Node"

87+

88+ signal tipe =

89+ Type.App (fromModule ["Signal"] "Signal") [ tipe ]

90+

91+ element =

92+ let builtin name =

93+ Type.Type (Var.builtin name)

94+

95+ maybe tipe =

96+ Type.App (fromModule ["Maybe"] "Maybe") [ tipe ]

97+ in

98+ Type.Record

99+ [ ("element", fromModule ["Graphics","Element"] "ElementPrim")

100+ , ("props",

101+ Type.Record

102+ [ ("click" , builtin "_Tuple0")

103+ , ("color" , maybe (fromModule ["Color"] "Color"))

104+ , ("height" , builtin "Int")

105+ , ("hover" , builtin "_Tuple0")

106+ , ("href" , builtin "String")

107+ , ("id" , builtin "Int")

108+ , ("opacity", builtin "Float")

109+ , ("tag" , builtin "String")

110+ , ("width" , builtin "Int")

111+ ]

112+ Nothing

113+ )

114+ ]

115+ Nothing

src/Optimize.hsnew file+19

@@ -0,0 +1,19 @@

1+module Optimize where

2+

3+import qualified AST.Module as M

4+import qualified Optimize.TailCalls as TC

5+

6+

7+optimize :: M.CanonicalModule -> M.Optimized

8+optimize modul =

9+ let

10+ canonicalBody =

11+ M.body modul

12+

13+ optimizedProgram =

14+ TC.optimize (M.program canonicalBody)

15+

16+ optimizedBody =

17+ canonicalBody { M.program = optimizedProgram }

18+ in

19+ modul { M.body = optimizedBody }

src/Generate/Cases.hs → src/Optimize/Cases.hsrenamed+16−12

@@ -1,4 +1,4 @@

1−module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

1+module Optimize.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

2

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

4import Control.Arrow (first)

@@ -8,11 +8,11 @@ import qualified Data.List as List

8import Data.Maybe (fromMaybe)

9

10import qualified AST.Expression.General as Expr

11−import qualified AST.Expression.Canonical as Canonical

11+import qualified AST.Expression.Optimized as Optimized

12import qualified AST.Literal as Literal

13import qualified AST.Pattern as P

14import qualified AST.Variable as Var

15−import qualified Generate.Substitute as S

15+import qualified Optimize.Substitute as S

16import qualified Reporting.Annotation as A

17

18

@@ -22,23 +22,23 @@ data Match

22 = Match String [Clause] Match

23 | Break

24 | Fail

25− | Other Canonical.Expr

25+ | Other Optimized.Expr

26 | Seq [Match]

27− deriving Show

27+ deriving (Show)

28

29

30data Clause =

31 Clause (Either Var.Canonical Literal.Literal) [String] Match

32− deriving Show

32+ deriving (Show)

33

34

35type Branch =

36− ([P.CanonicalPattern], Canonical.Expr)

36+ ([P.Optimized], Optimized.Expr)

37

38

39-- PUBLIC FUNCTIONS

40

41−toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)

41+toMatch :: [(P.Optimized, Optimized.Expr)] -> State Int (String, Match)

42toMatch patterns =

43 do v <- newVar

44 (,) v <$> buildMatch [v] (map (first (:[])) patterns) Fail

@@ -61,8 +61,12 @@ matchSubst pairs match =

61 Seq ms ->

62 Seq (map (matchSubst pairs) ms)

63

64− Other (A.A a e) ->

64+ Other (A.A ann expr) ->

65+ let

66+ substitutions =

65− Other . A.A a $ foldr ($) e $ map (\(x,y) -> S.subst x (Expr.localVar y)) pairs

67+ map (\(x,y) -> S.subst x (Expr.localVar y)) pairs

68+ in

69+ Other $ A.A ann $ foldr ($) expr substitutions

66

70

67 Match n cs m ->

71 Match n cs m ->

68 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

72 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

@@ -258,5 +262,5 @@ matchMix vs branches def =

258

262

259noMatch :: String -> a

263noMatch :: String -> a

260noMatch name =

264noMatch name =

261− error $ "unexpected pattern in '" ++ name ++

265+ error $ "unexpected pattern in `" ++ name ++

262− "' function. Report a compiler issue to <https://github.com/elm-lang/Elm>."

266+ "` function. Report a compiler issue to <https://github.com/elm-lang/Elm>."

src/Generate/Substitute.hs → src/Optimize/Substitute.hsrenamed+17−14

@@ -1,50 +1,50 @@

1{-# OPTIONS_GHC -Wall #-}

2−module Generate.Substitute (subst) where

2+module Optimize.Substitute (subst) where

3

4import Control.Arrow (second, (***))

5

6import AST.Expression.General (Expr'(..), PortImpl(..))

7−import qualified AST.Expression.Canonical as Canonical

7+import qualified AST.Expression.Optimized as Optimized

8import qualified AST.Pattern as Pattern

9import qualified AST.Variable as V

10import Elm.Utils ((|>))

11import qualified Reporting.Annotation as A

12

13

14−subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'

14+subst :: String -> Optimized.Expr' -> Optimized.Expr' -> Optimized.Expr'

15subst old new expression =

16 let f (A.A a e) = A.A a (subst old new e) in

17 case expression of

18− Range e1 e2 ->

18+ Range lo hi ->

19− Range (f e1) (f e2)

19+ Range (f lo) (f hi)

20

21 ExplicitList exprs ->

22 ExplicitList (map f exprs)

23

24− Binop op e1 e2 ->

24+ Binop op left right ->

25− Binop op (f e1) (f e2)

25+ Binop op (f left) (f right)

26

27 Lambda pattern body ->

28 if Pattern.member old pattern

29 then expression

30 else Lambda pattern (f body)

31

32− App e1 e2 ->

32+ App func arg ->

33− App (f e1) (f e2)

33+ App (f func) (f arg)

34

35− MultiIf branches ->

35+ MultiIf branches finally ->

36− MultiIf (map (f *** f) branches)

36+ MultiIf (map (f *** f) branches) (f finally)

37

38 Let defs body ->

39 if anyShadow

40 then expression

41 else Let (map substDef defs) (f body)

42 where

43− substDef (Canonical.Definition p e t) =

43+ substDef (Optimized.Definition facts pattern expr) =

44− Canonical.Definition p (f e) t

44+ Optimized.Definition facts pattern (f expr)

45

46 anyShadow =

47− map (\(Canonical.Definition p _ _) -> p) defs

47+ map (\(Optimized.Definition _ p _) -> p) defs

48 |> any (Pattern.member old)

49

50 Var (V.Canonical home x) ->

@@ -101,3 +101,6 @@ subst old new expression =

101

102 Task name expr tipe ->

103 Task name (f expr) tipe

104+

105+ Crash _ ->

106+ expression

src/Optimize/TailCalls.hsnew file+239

@@ -0,0 +1,239 @@

1+module Optimize.TailCalls where

2+

3+import Control.Applicative

4+import Control.Arrow (first)

5+import qualified Control.Monad as M

6+import qualified Data.List as List

7+import qualified Data.Traversable as T

8+

9+import AST.Expression.General as Expr

10+import qualified AST.Expression.Canonical as Can

11+import qualified AST.Expression.Optimized as Opt

12+import qualified AST.Pattern as P

13+import qualified AST.Variable as Var

14+import qualified Reporting.Annotation as A

15+

16+

17+-- OPTIMIZE FOR TAIL CALLS

18+

19+optimize :: Can.Expr -> Opt.Expr

20+optimize expression =

21+ let

22+ (Result _ optExpr) =

23+ findTailCalls Nothing expression

24+ in

25+ optExpr

26+

27+

28+-- TRACKER TO THREAD FINDINGS THROUGH TRAVERSAL

29+

30+data Result a = Result Bool a

31+

32+

33+instance M.Functor Result where

34+ fmap func (Result hasTailCall value) =

35+ Result hasTailCall (func value)

36+

37+

38+instance Applicative Result where

39+ pure value =

40+ Result False value

41+

42+ (<*>) (Result hasTailCall func) (Result hasTailCall' value) =

43+ Result (hasTailCall || hasTailCall') (func value)

44+

45+

46+mapSnd :: M.Functor box => (a -> box b) -> (x, a) -> box (x, b)

47+mapSnd func (x, a) =

48+ (,) x <$> func a

49+

50+

51+-- CONVERT DEFINITIONS

52+

53+detectTailRecursion :: Can.Def -> Opt.Def

54+detectTailRecursion (Can.Definition pattern expression _) =

55+ let

56+ (args, body) =

57+ Expr.collectLambdas expression

58+

59+ context :: Context

60+ context =

61+ case (pattern, args) of

62+ -- detect if it is a function

63+ (A.A _ (P.Var name), _ : _) ->

64+ Just (name, length args)

65+

66+ _ ->

67+ Nothing

68+

69+ (Result isTailCall optExpr) =

70+ findTailCalls context body

71+

72+ lambda x e =

73+ A.A () (Lambda x e)

74+ in

75+ Opt.Definition

76+ (Opt.Facts (if isTailCall then fmap fst context else Nothing))

77+ (removeAnnotations pattern)

78+ (foldr lambda optExpr (map removeAnnotations args))

79+

80+

81+-- CONVERT EXPRESSIONS

82+

83+type Context = Maybe (String, Int)

84+

85+

86+findTailCalls :: Context -> Can.Expr -> Result Opt.Expr

87+findTailCalls context annExpr@(A.A _ expression) =

88+ let

89+ keepLooking =

90+ findTailCalls context

91+ -- this *might* find a tail call, use this when something is a potential

92+ -- tail call

93+

94+ justConvert =

95+ findTailCalls Nothing

96+ -- this will never find tail calls, use this when you are working with

97+ -- expressions that cannot be turned into tail calls

98+ in

99+ A.A () <$>

100+ case expression of

101+ Literal lit ->

102+ pure (Literal lit)

103+

104+ Var name ->

105+ pure (Var name)

106+

107+ Range lowExpr highExpr ->

108+ Range

109+ <$> justConvert lowExpr

110+ <*> justConvert highExpr

111+

112+ ExplicitList elements ->

113+ ExplicitList

114+ <$> T.traverse justConvert elements

115+

116+ Binop op leftExpr rightExpr ->

117+ Binop op

118+ <$> justConvert leftExpr

119+ <*> justConvert rightExpr

120+

121+ Lambda pattern body ->

122+ Lambda (removeAnnotations pattern) <$> justConvert body

123+

124+ App _ _ ->

125+ let

126+ (func:args) =

127+ Expr.collectApps annExpr

128+

129+ isTailCall =

130+ case (context, func) of

131+ ( Just (name, argNum), A.A _ (Var (Var.Canonical Var.Local name')) ) ->

132+ name == name' && length args == argNum

133+ _ ->

134+ False

135+

136+ (Result _ (A.A _ optFunc)) =

137+ justConvert func

138+

139+ (Result _ optArgs) =

140+ T.traverse justConvert args

141+

142+ apply f arg =

143+ App (A.A () f) arg

144+ in

145+ Result isTailCall (List.foldl' apply optFunc optArgs)

146+

147+

148+ MultiIf branches finally ->

149+ let

150+ crawlBranch (cond,branch) =

151+ (,) <$> justConvert cond <*> keepLooking branch

152+ in

153+ MultiIf

154+ <$> T.traverse crawlBranch branches

155+ <*> keepLooking finally

156+

157+ Let defs body ->

158+ let

159+ optDefs = map detectTailRecursion defs

160+ in

161+ Let optDefs <$> keepLooking body

162+

163+ Case expr cases ->

164+ let

165+ preppedCases =

166+ map (first removeAnnotations) cases

167+ in

168+ Case

169+ <$> justConvert expr

170+ <*> T.traverse (mapSnd keepLooking) preppedCases

171+

172+ Data name exprs ->

173+ Data name <$> T.traverse justConvert exprs

174+

175+ Access record field ->

176+ Access

177+ <$> justConvert record

178+ <*> pure field

179+

180+ Remove record field ->

181+ Remove

182+ <$> justConvert record

183+ <*> pure field

184+

185+ Insert record field expr ->

186+ Insert

187+ <$> justConvert record

188+ <*> pure field

189+ <*> justConvert expr

190+

191+ Modify record fields ->

192+ Modify

193+ <$> justConvert record

194+ <*> T.traverse (mapSnd justConvert) fields

195+

196+ Record fields ->

197+ Record

198+ <$> T.traverse (mapSnd justConvert) fields

199+

200+ GLShader uid src gltipe ->

201+ pure (GLShader uid src gltipe)

202+

203+ Port impl ->

204+ Port <$>

205+ case impl of

206+ In name tipe ->

207+ pure (In name tipe)

208+

209+ Out name expr tipe ->

210+ (\e -> Out name e tipe) <$> justConvert expr

211+

212+ Task name expr tipe ->

213+ (\e -> Task name e tipe) <$> justConvert expr

214+

215+ Crash details ->

216+ pure (Crash details)

217+

218+

219+removeAnnotations :: P.CanonicalPattern -> P.Optimized

220+removeAnnotations (A.A _ pattern) =

221+ A.A () $

222+ case pattern of

223+ P.Var x ->

224+ P.Var x

225+

226+ P.Literal lit ->

227+ P.Literal lit

228+

229+ P.Record fields ->

230+ P.Record fields

231+

232+ P.Anything ->

233+ P.Anything

234+

235+ P.Alias alias realPattern ->

236+ P.Alias alias (removeAnnotations realPattern)

237+

238+ P.Data name patterns ->

239+ P.Data name (map removeAnnotations patterns)

src/Parse/Declaration.hs+11−4

@@ -6,27 +6,32 @@ import Text.Parsec ( (<|>), (<?>), choice, digit, optionMaybe, string, try )

6

7import qualified AST.Declaration as D

8import qualified Parse.Expression as Expr

9−import Parse.Helpers

9+import Parse.Helpers as Help

10import qualified Parse.Type as Type

11

12

13declaration :: IParser D.SourceDecl

14declaration =

15+ choice

16+ [ D.Comment <$> Help.docComment

15− addLocation (typeDecl <|> infixDecl <|> port <|> definition)

17+ , D.Decl <$> addLocation (typeDecl <|> infixDecl <|> port <|> definition)

18+ ]

16

19

17

20

18-- TYPE ANNOTATIONS and DEFINITIONS

21-- TYPE ANNOTATIONS and DEFINITIONS

19

22

20definition :: IParser D.SourceDecl'

23definition :: IParser D.SourceDecl'

21definition =

24definition =

25+ D.Definition

22− D.Definition <$> (Expr.typeAnnotation <|> Expr.definition)

26+ <$> (Expr.typeAnnotation <|> Expr.definition)

27+ <?> "a value definition"

23

28

24

29

25-- TYPE ALIAS and UNION TYPES

30-- TYPE ALIAS and UNION TYPES

26

31

27typeDecl :: IParser D.SourceDecl'

32typeDecl :: IParser D.SourceDecl'

28typeDecl =

33typeDecl =

29− do try (reserved "type") <?> "type declaration"

34+ do try (reserved "type") <?> "a type declaration"

30 forcedWS

35 forcedWS

31 isAlias <- optionMaybe (string "alias" >> forcedWS)

36 isAlias <- optionMaybe (string "alias" >> forcedWS)

32

37

@@ -48,6 +53,7 @@ typeDecl =

48

53

49infixDecl :: IParser D.SourceDecl'

54infixDecl :: IParser D.SourceDecl'

50infixDecl =

55infixDecl =

56+ expecting "an infix declaration" $

51 do assoc <-

57 do assoc <-

52 choice

58 choice

53 [ try (reserved "infixl") >> return D.L

59 [ try (reserved "infixl") >> return D.L

@@ -64,6 +70,7 @@ infixDecl =

64

70

65port :: IParser D.SourceDecl'

71port :: IParser D.SourceDecl'

66port =

72port =

73+ expecting "a port declaration" $

67 do try (reserved "port")

74 do try (reserved "port")

68 whitespace

75 whitespace

69 name <- lowVar

76 name <- lowVar

src/Parse/Expression.hs+84−50

@@ -18,13 +18,15 @@ import qualified AST.Literal as L

18import qualified AST.Pattern as P

19import qualified AST.Variable as Var

20import qualified Reporting.Annotation as A

21+import qualified Reporting.Crash as Crash

22+import qualified Reporting.Region as R

21

23

22

24

23-------- Basic Terms --------

25-------- Basic Terms --------

24

26

25varTerm :: IParser Source.Expr'

27varTerm :: IParser Source.Expr'

26varTerm =

28varTerm =

27− toVar <$> var <?> "variable"

29+ toVar <$> var

28

30

29

31

30toVar :: String -> Source.Expr'

32toVar :: String -> Source.Expr'

@@ -56,7 +58,10 @@ accessor =

56negative :: IParser Source.Expr'

58negative :: IParser Source.Expr'

57negative =

59negative =

58 do (start, nTerm, end) <-

60 do (start, nTerm, end) <-

61+ located $ try $

62+ do char '-'

59− located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

63+ notFollowedBy (char '.' <|> char '-')

64+ term

60

65

61 let ann e =

66 let ann e =

62 A.at start end e

67 A.at start end e

@@ -132,8 +137,11 @@ parensTerm =

132recordTerm :: IParser Source.Expr

137recordTerm :: IParser Source.Expr

133recordTerm =

138recordTerm =

134 addLocation $

139 addLocation $

135− brackets $ choice [ misc, record ]

140+ brackets (choice [ misc, record ])

136 where

141 where

142+ record =

143+ E.Record <$> commaSep field

144+

137 field =

145 field =

138 do label <- rLabel

146 do label <- rLabel

139 patterns <- spacePrefix Pattern.term

147 patterns <- spacePrefix Pattern.term

@@ -141,51 +149,66 @@ recordTerm =

141 body <- expr

149 body <- expr

142 return (label, makeFunction patterns body)

150 return (label, makeFunction patterns body)

143

151

144− record =

152+ misc =

145− E.Record <$> commaSep field

153+ do nextParser <- try miscStarter

146−

147− change =

148− do lbl <- rLabel

149− padded (string "<-")

150− (,) lbl <$> expr

151−

152− remove r =

153− do string "-"

154 whitespace

155− E.Remove r <$> rLabel

155+ nextParser

156

157− insert r =

157+ miscStarter =

158− do string "|"

158+ do start <- getMyPosition

159+ record <- addLocation (E.rawVar <$> rLabel)

159 whitespace

160 whitespace

160− E.Insert r <$> rLabel <*> (padded equals >> expr)

161+ choice

162+ [ string "-" >> return (afterMinus start record)

163+ , string "|" >> return (afterBar record)

164+ ]

161

165

162− modify r =

166+ afterMinus start record =

163− do string "|"

167+ do field <- rLabel

168+ end <- getMyPosition

169+ let subRecord' = E.Remove record field

170+ maybe <- optionMaybe (try (whitespace >> string "|"))

171+ case maybe of

172+ Nothing ->

173+ return subRecord'

174+ Just _ ->

175+ do whitespace

176+ field <- rLabel

177+ padded equals

178+ E.Insert (A.at start end subRecord') field <$> expr

179+

180+ afterBar record =

181+ do field <- rLabel

164 whitespace

182 whitespace

165− E.Modify r <$> commaSep1 change

183+ choice

184+ [ do equals

185+ whitespace

186+ E.Insert record field <$> expr

187+ , do leftArrow

188+ whitespace

189+ value <- expr

190+ updates <- spaceyPrefixBy comma update

191+ return (E.Modify record ((field,value) : updates))

192+ ]

166

193

167− misc =

194+ update =

168− try $ do

195+ do lbl <- rLabel

169− record <- addLocation (E.rawVar <$> rLabel)

196+ padded leftArrow

170− opt <- padded (optionMaybe (addLocation (remove record)))

197+ (,) lbl <$> expr

171− case opt of

172− Just e@(A.A _ e') ->

173− try (insert e) <|> return e'

174− Nothing ->

175− try (insert record) <|> try (modify record)

176

198

177

199

178term :: IParser Source.Expr

200term :: IParser Source.Expr

179term =

201term =

180 addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ])

202 addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ])

181 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

203 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

182− <?> "basic term (4, x, 'c', etc.)"

204+ <?> "an expression"

183

205

184

206

185-------- Applications --------

207-------- Applications --------

186

208

187appExpr :: IParser Source.Expr

209appExpr :: IParser Source.Expr

188appExpr =

210appExpr =

211+ expecting "an expression" $

189 do t <- term

212 do t <- term

190 ts <- constrainedSpacePrefix term $ \str ->

213 ts <- constrainedSpacePrefix term $ \str ->

191 if null str then notFollowedBy (char '-') else return ()

214 if null str then notFollowedBy (char '-') else return ()

@@ -199,7 +222,8 @@ appExpr =

199

222

200expr :: IParser Source.Expr

223expr :: IParser Source.Expr

201expr =

224expr =

202− addLocation (choice [ ifExpr, letExpr, caseExpr ])

225+ addLocation (choice [ letExpr, caseExpr ])

226+ <|> ifExpr

203 <|> lambdaExpr

227 <|> lambdaExpr

204 <|> binaryExpr

228 <|> binaryExpr

205 <?> "an expression"

229 <?> "an expression"

@@ -209,44 +233,54 @@ binaryExpr :: IParser Source.Expr

209binaryExpr =

233binaryExpr =

210 Binop.binops appExpr lastExpr anyOp

234 Binop.binops appExpr lastExpr anyOp

211 where

235 where

236+ lastExpr =

212− lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

237+ addLocation (choice [ letExpr, caseExpr ])

238+ <|> ifExpr

213− <|> lambdaExpr

239+ <|> lambdaExpr

240+ <?> "an expression"

214

241

215

242

216−ifExpr :: IParser Source.Expr'

243+ifExpr :: IParser Source.Expr

217ifExpr =

244ifExpr =

245+ do start <- getMyPosition

218− do try (reserved "if")

246+ try (reserved "if")

219 whitespace

247 whitespace

220− normal <|> multiIf

248+ makeExpr <- normal <|> multiIf

249+ end <- getMyPosition

250+ return (makeExpr (R.Region start end))

221 where

251 where

222 normal =

252 normal =

223− do bool <- expr

253+ do condition <- expr

224 padded (reserved "then")

254 padded (reserved "then")

225 thenBranch <- expr

255 thenBranch <- expr

226 whitespace <?> "an 'else' branch"

256 whitespace <?> "an 'else' branch"

227 reserved "else" <?> "an 'else' branch"

257 reserved "else" <?> "an 'else' branch"

228 whitespace

258 whitespace

229 elseBranch <- expr

259 elseBranch <- expr

230− return $ E.MultiIf

260+ return $ \region -> A.A region (E.MultiIf [(condition, thenBranch)] elseBranch)

231− [ (bool, thenBranch)

232− , (A.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)

233− ]

234

261

235 multiIf =

262 multiIf =

236− E.MultiIf <$> spaceSep1 iff

263+ do branches <- spaceSep1 multiBranch

237− where

264+ return $ \region -> A.A region (E.MultiIf branches (crash region))

238− iff =

265+

266+ crash region =

267+ A.A region (E.Crash (Crash.IncompleteMultiIf region))

268+

269+ multiBranch =

270+ do string "|"

239− do string "|" ; whitespace

271+ whitespace

240− b <- expr ; padded arrow

272+ condition <- expr

241− (,) b <$> expr

273+ padded rightArrow

274+ branch <- expr

275+ return (condition, branch)

242

276

243

277

244lambdaExpr :: IParser Source.Expr

278lambdaExpr :: IParser Source.Expr

245lambdaExpr =

279lambdaExpr =

246− do char '\\' <|> char '\x03BB' <?> "anonymous function"

280+ do char '\\' <|> char '\x03BB' <?> "an anonymous function"

247 whitespace

281 whitespace

248 args <- spaceSep1 Pattern.term

282 args <- spaceSep1 Pattern.term

249− padded arrow

283+ padded rightArrow

250 body <- expr

284 body <- expr

251 return (makeFunction args body)

285 return (makeFunction args body)

252

286

@@ -261,7 +295,7 @@ caseExpr =

261 where

295 where

262 case_ =

296 case_ =

263 do p <- Pattern.expr

297 do p <- Pattern.expr

264− padded arrow

298+ padded rightArrow

265 (,) p <$> expr

299 (,) p <$> expr

266

300

267 with =

301 with =

src/Parse/Helpers.hs+85−50

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

1module Parse.Helpers where

2

3import Prelude hiding (until)

4−import Control.Applicative ((<$>),(<*>))

4+import Control.Applicative ((<$>),(<*>),(<*))

5import Control.Monad (guard, join)

6import Control.Monad.State (State)

7import Data.Char (isUpper)

@@ -18,8 +18,8 @@ import qualified AST.Expression.Source as Source

18import qualified AST.Helpers as Help

19import qualified AST.Literal as L

20import qualified AST.Variable as Variable

21−import Elm.Utils ((|>))

22import qualified Reporting.Annotation as A

21import qualified Reporting.Annotation as A

22+import qualified Reporting.Error.Syntax as Syntax

23import qualified Reporting.Region as R

24

25

@@ -37,9 +37,13 @@ reserveds =

37 ]

38

39

40+-- ERROR HELP

41+

40expecting = flip (<?>)

42expecting = flip (<?>)

41

43

42

44

45+-- SETUP

46+

43type OpTable = Map.Map String (Int, Decl.Assoc)

47type OpTable = Map.Map String (Int, Decl.Assoc)

44type SourceM = State SourcePos

48type SourceM = State SourcePos

45type IParser a = ParsecT String OpTable SourceM a

49type IParser a = ParsecT String OpTable SourceM a

@@ -59,17 +63,17 @@ iParseWithTable sourceName table aParser input =

59

63

60var :: IParser String

64var :: IParser String

61var =

65var =

62− makeVar (letter <|> char '_' <?> "variable")

66+ makeVar (letter <|> char '_') <?> "a name"

63

67

64

68

65lowVar :: IParser String

69lowVar :: IParser String

66lowVar =

70lowVar =

67− makeVar (lower <?> "lower case variable")

71+ makeVar lower <?> "a lower case name"

68

72

69

73

70capVar :: IParser String

74capVar :: IParser String

71capVar =

75capVar =

72− makeVar (upper <?> "upper case variable")

76+ makeVar upper <?> "an upper case name"

73

77

74

78

75qualifiedVar :: IParser String

79qualifiedVar :: IParser String

@@ -84,20 +88,20 @@ rLabel = lowVar

84

88

85innerVarChar :: IParser Char

89innerVarChar :: IParser Char

86innerVarChar =

90innerVarChar =

87− alphaNum <|> char '_' <|> char '\'' <?> ""

91+ alphaNum <|> char '_' <|> char '\'' <?> "more letters in this name"

88

92

89

93

90makeVar :: IParser Char -> IParser String

94makeVar :: IParser Char -> IParser String

91−makeVar p =

95+makeVar firstChar =

92− do v <- (:) <$> p <*> many innerVarChar

96+ do variable <- (:) <$> firstChar <*> many innerVarChar

93− if v `elem` reserveds

97+ if variable `elem` reserveds

94− then fail $ "unexpected keyword '" ++ v ++ "', variables cannot be keywords"

98+ then fail (Syntax.keyword variable)

95− else return v

99+ else return variable

96

100

97

101

98reserved :: String -> IParser String

102reserved :: String -> IParser String

99reserved word =

103reserved word =

100− expecting ("reserved word '" ++ word ++ "'") $

104+ expecting ("reserved word `" ++ word ++ "`") $

101 do string word

105 do string word

102 notFollowedBy innerVarChar

106 notFollowedBy innerVarChar

103 return word

107 return word

@@ -109,7 +113,7 @@ anyOp :: IParser String

109anyOp =

113anyOp =

110 betwixt '`' '`' qualifiedVar

114 betwixt '`' '`' qualifiedVar

111 <|> symOp

115 <|> symOp

112− <?> "infix operator"

116+ <?> "an infix operator like (+)"

113

117

114

118

115symOp :: IParser String

119symOp :: IParser String

@@ -124,13 +128,23 @@ symOp =

124-- COMMON SYMBOLS

128-- COMMON SYMBOLS

125

129

126equals :: IParser String

130equals :: IParser String

127−equals = string "="

131+equals =

132+ string "=" <?> "="

133+

134+

135+rightArrow :: IParser String

136+rightArrow =

137+ string "->" <|> string "\8594" <?> "->"

138+

139+

140+leftArrow :: IParser String

141+leftArrow =

142+ string "<-" <?> "<- for a record update"

128

143

129−arrow :: IParser String

130−arrow = string "->" <|> string "\8594" <?> "arrow (->)"

131

144

132hasType :: IParser String

145hasType :: IParser String

133−hasType = string ":" <?> "':' (a type annotation)'"

146+hasType =

147+ string ":" <?> "the \"has type\" symbol ':'"

134

148

135

149

136commitIf check p =

150commitIf check p =

@@ -143,14 +157,19 @@ commitIf check p =

143-- SEPARATORS

157-- SEPARATORS

144

158

145spaceySepBy1 :: IParser b -> IParser a -> IParser [a]

159spaceySepBy1 :: IParser b -> IParser a -> IParser [a]

146−spaceySepBy1 sep p =

160+spaceySepBy1 sep parser =

147− do a <- p

161+ do value <- parser

162+ (value:) <$> spaceyPrefixBy sep parser

163+

164+

165+spaceyPrefixBy :: IParser sep -> IParser a -> IParser [a]

166+spaceyPrefixBy sep parser =

148− (a:) <$> many (commitIf (whitespace >> sep) (padded sep >> p))

167+ many (commitIf (whitespace >> sep) (padded sep >> parser))

149

168

150

169

151comma :: IParser Char

170comma :: IParser Char

152comma =

171comma =

153− char ',' <?> "comma ','"

172+ char ',' <?> "a comma ','"

154

173

155

174

156commaSep1 :: IParser a -> IParser [a]

175commaSep1 :: IParser a -> IParser [a]

@@ -165,17 +184,17 @@ commaSep =

165

184

166semiSep1 :: IParser a -> IParser [a]

185semiSep1 :: IParser a -> IParser [a]

167semiSep1 =

186semiSep1 =

168− spaceySepBy1 (char ';' <?> "semicolon ';'")

187+ spaceySepBy1 (char ';' <?> "a semicolon ';'")

169

188

170

189

171pipeSep1 :: IParser a -> IParser [a]

190pipeSep1 :: IParser a -> IParser [a]

172pipeSep1 =

191pipeSep1 =

173− spaceySepBy1 (char '|' <?> "type divider '|'")

192+ spaceySepBy1 (char '|' <?> "a vertical bar '|'")

174

193

175

194

176consSep1 :: IParser a -> IParser [a]

195consSep1 :: IParser a -> IParser [a]

177consSep1 =

196consSep1 =

178− spaceySepBy1 (string "::" <?> "cons operator '::'")

197+ spaceySepBy1 (string "::" <?> "a cons operator '::'")

179

198

180

199

181dotSep1 :: IParser a -> IParser [a]

200dotSep1 :: IParser a -> IParser [a]

@@ -192,15 +211,15 @@ spacePrefix p =

192 constrainedSpacePrefix p (\_ -> return ())

211 constrainedSpacePrefix p (\_ -> return ())

193

212

194

213

195−constrainedSpacePrefix p constraint =

214+constrainedSpacePrefix parser constraint =

196 many $ choice

215 many $ choice

197− [ try (spacing >> lookAhead (oneOf "[({")) >> p

216+ [ try (spacing >> lookAhead (oneOf "[({")) >> parser

198− , try (spacing >> p)

217+ , try (spacing >> parser)

199 ]

218 ]

200 where

219 where

201 spacing = do

220 spacing = do

202 n <- whitespace

221 n <- whitespace

203− constraint n

222+ constraint n <?> Syntax.whitespace

204 indented

223 indented

205

224

206

225

@@ -212,17 +231,19 @@ followedBy a b =

212 return x

231 return x

213

232

214

233

234+betwixt :: Char -> Char -> IParser a -> IParser a

215betwixt a b c =

235betwixt a b c =

216 do char a

236 do char a

217 out <- c

237 out <- c

218− char b <?> "closing '" ++ [b] ++ "'"

238+ char b <?> "a closing '" ++ [b] ++ "'"

219 return out

239 return out

220

240

221

241

242+surround :: Char -> Char -> String -> IParser a -> IParser a

222surround a z name p = do

243surround a z name p = do

223 char a

244 char a

224 v <- padded p

245 v <- padded p

225− char z <?> unwords ["closing", name, show z]

246+ char z <?> unwords ["a closing", name, show z]

226 return v

247 return v

227

248

228

249

@@ -268,7 +289,7 @@ accessible exprParser =

268

289

269 annotatedRootExpr@(A.A _ rootExpr) <- exprParser

290 annotatedRootExpr@(A.A _ rootExpr) <- exprParser

270

291

271− access <- optionMaybe (try dot <?> "field access (e.g. List.map)")

292+ access <- optionMaybe (try dot <?> "a field access like .name")

272

293

273 case access of

294 case access of

274 Nothing ->

295 Nothing ->

@@ -276,7 +297,7 @@ accessible exprParser =

276

297

277 Just _ ->

298 Just _ ->

278 accessible $

299 accessible $

279− do v <- var <?> "field access (e.g. List.map)"

300+ do v <- var

280 end <- getMyPosition

301 end <- getMyPosition

281 return . A.at start end $

302 return . A.at start end $

282 case rootExpr of

303 case rootExpr of

@@ -289,7 +310,8 @@ accessible exprParser =

289

310

290dot :: IParser ()

311dot :: IParser ()

291dot =

312dot =

313+ do char '.'

292− char '.' >> notFollowedBy (char '.')

314+ notFollowedBy (char '.')

293

315

294

316

295-- WHITESPACE

317-- WHITESPACE

@@ -304,7 +326,7 @@ padded p =

304

326

305spaces :: IParser String

327spaces :: IParser String

306spaces =

328spaces =

307− let space = string " " <|> multiComment <?> "whitespace"

329+ let space = string " " <|> multiComment <?> Syntax.whitespace

308 in

330 in

309 concat <$> many1 space

331 concat <$> many1 space

310

332

@@ -333,14 +355,14 @@ whitespace =

333

355

334freshLine :: IParser [[String]]

356freshLine :: IParser [[String]]

335freshLine =

357freshLine =

336− try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""

358+ try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> Syntax.freshLine

337 where

359 where

338 space_nl = try $ spaces >> many1 newline

360 space_nl = try $ spaces >> many1 newline

339

361

340

362

341newline :: IParser String

363newline :: IParser String

342newline =

364newline =

343− simpleNewline <|> lineComment <?> "a newline"

365+ simpleNewline <|> lineComment <?> Syntax.newline

344

366

345

367

346simpleNewline :: IParser String

368simpleNewline :: IParser String

@@ -355,16 +377,23 @@ lineComment =

355 return ("--" ++ comment)

377 return ("--" ++ comment)

356

378

357

379

380+docComment :: IParser String

381+docComment =

382+ do try (string "{-|")

383+ contents <- closeComment

384+ return (init (init contents))

385+

386+

358multiComment :: IParser String

387multiComment :: IParser String

359multiComment =

388multiComment =

360− (++) <$> try (string "{-") <*> closeComment

389+ (++) <$> try (string "{-" <* notFollowedBy (string "|")) <*> closeComment

361

390

362

391

363closeComment :: IParser String

392closeComment :: IParser String

364closeComment =

393closeComment =

365 anyUntil $

394 anyUntil $

366 choice $

395 choice $

367− [ try (string "-}") <?> "close comment"

396+ [ try (string "-}") <?> "the end of a comment -}"

368 , concat <$> sequence [ try (string "{-"), closeComment, closeComment ]

397 , concat <$> sequence [ try (string "{-"), closeComment, closeComment ]

369 ]

398 ]

370

399

@@ -404,6 +433,7 @@ ignoreUntil end =

404 choice

433 choice

405 [ try (ignore chr) <|> ignore str

434 [ try (ignore chr) <|> ignore str

406 , ignore multiComment

435 , ignore multiComment

436+ , ignore docComment

407 , ignore anyChar

437 , ignore anyChar

408 ]

438 ]

409

439

@@ -452,14 +482,16 @@ shader =

452 case glSource rawSrc of

482 case glSource rawSrc of

453 Left err -> parserFail . show $ err

483 Left err -> parserFail . show $ err

454 Right tipe -> return (rawSrc, tipe)

484 Right tipe -> return (rawSrc, tipe)

455− where

485+

486+

487+closeShader :: (String -> a) -> IParser a

456− closeShader builder =

488+closeShader builder =

457− choice

489+ choice

458− [ do try (string "|]")

490+ [ do try (string "|]")

459− return (builder "")

491+ return (builder "")

460− , do c <- anyChar

492+ , do c <- anyChar

461− closeShader (builder . (c:))

493+ closeShader (builder . (c:))

462− ]

494+ ]

463

495

464

496

465glSource :: String -> Either ParseError L.GLShaderTipe

497glSource :: String -> Either ParseError L.GLShaderTipe

@@ -472,6 +504,8 @@ glSource src =

472 |> foldr addGLinput emptyDecls

504 |> foldr addGLinput emptyDecls

473 |> Right

505 |> Right

474 where

506 where

507+ (|>) = flip ($)

508+

475 emptyDecls = L.GLShaderTipe Map.empty Map.empty Map.empty

509 emptyDecls = L.GLShaderTipe Map.empty Map.empty Map.empty

476

510

477 addGLinput (qual,tipe,name) glDecls =

511 addGLinput (qual,tipe,name) glDecls =

@@ -513,9 +547,10 @@ glSource src =

513

547

514

548

515str :: IParser String

549str :: IParser String

550+str =

516−str = expecting "String" $ do

551+ expecting "a string" $

517− s <- choice [ multiStr, singleStr ]

552+ do s <- choice [ multiStr, singleStr ]

518− processAs T.stringLiteral . sandwich '\"' $ concat s

553+ processAs T.stringLiteral . sandwich '\"' $ concat s

519 where

554 where

520 rawString quote insides =

555 rawString quote insides =

521 quote >> manyTill insides quote

556 quote >> manyTill insides quote

@@ -555,7 +590,7 @@ escaped delim =

555

590

556chr :: IParser Char

591chr :: IParser Char

557chr =

592chr =

558− betwixt '\'' '\'' character <?> "character"

593+ betwixt '\'' '\'' character <?> "a character"

559 where

594 where

560 nonQuote = satisfy (/='\'')

595 nonQuote = satisfy (/='\'')

561

596

src/Parse/Literal.hs+4−4

@@ -9,19 +9,19 @@ import qualified AST.Literal as L

9

10literal :: IParser L.Literal

11literal =

12− num <|> (L.Str <$> str) <|> (L.Chr <$> chr) <?> "literal"

12+ num <|> (L.Str <$> str) <|> (L.Chr <$> chr)

13

14

15num :: IParser L.Literal

16num =

17− toLiteral <$> (rawNumber <?> "number")

17+ toLiteral <$> (rawNumber <?> "a number")

18

19

20toLiteral :: String -> L.Literal

21toLiteral n

22− | 'x' `elem` n = L.IntNum (read n)

22+ | 'x' `elem` n = L.IntNum (read n)

23 | any (`elem` ".eE") n = L.FloatNum (read n)

24− | otherwise = L.IntNum (read n)

24+ | otherwise = L.IntNum (read n)

25

26

27rawNumber :: IParser String

src/Parse/Module.hs+20−11

@@ -6,6 +6,7 @@ import Text.Parsec hiding (newline, spaces)

6import Parse.Helpers

7import qualified AST.Module as Module

8import qualified AST.Variable as Var

9+import Reporting.Annotation as A

9

10

11

11getModuleName :: String -> Maybe String

12getModuleName :: String -> Maybe String

@@ -25,18 +26,24 @@ header =

25 do optional freshLine

26 do optional freshLine

26 (names, exports) <-

27 (names, exports) <-

27 option (["Main"], Var.openListing) (moduleDecl `followedBy` freshLine)

28 option (["Main"], Var.openListing) (moduleDecl `followedBy` freshLine)

29+ docs <-

30+ choice

31+ [ addLocation (Just <$> docComment) `followedBy` freshLine

32+ , addLocation (return Nothing)

33+ ]

28 imports' <- imports

34 imports' <- imports

29− return (Module.Header names exports imports')

35+ return (Module.Header names docs exports imports')

30

36

31

37

32−moduleDecl :: IParser ([String], Var.Listing Var.Value)

38+moduleDecl :: IParser ([String], Var.Listing (A.Located Var.Value))

33moduleDecl =

39moduleDecl =

40+ expecting "a module declaration" $

34 do try (reserved "module")

41 do try (reserved "module")

35 whitespace

42 whitespace

36− names <- dotSep1 capVar <?> "name of module"

43+ names <- dotSep1 capVar <?> "the name of this module"

44+ whitespace

45+ exports <- option Var.openListing (listing (addLocation value))

37 whitespace

46 whitespace

38− exports <- option Var.openListing (listing value)

39− whitespace <?> "reserved word 'where'"

40 reserved "where"

47 reserved "where"

41 return (names, exports)

48 return (names, exports)

42

49

@@ -48,6 +55,7 @@ imports =

48

55

49import' :: IParser Module.UserImport

56import' :: IParser Module.UserImport

50import' =

57import' =

58+ expecting "an import" $

51 addLocation $

59 addLocation $

52 do try (reserved "import")

60 do try (reserved "import")

53 whitespace

61 whitespace

@@ -57,14 +65,14 @@ import' =

57 method :: String -> IParser Module.ImportMethod

65 method :: String -> IParser Module.ImportMethod

58 method defaultAlias =

66 method defaultAlias =

59 Module.ImportMethod

67 Module.ImportMethod

60− <$> option (Just defaultAlias) (Just <$> as')

68+ <$> option (Just defaultAlias) (Just <$> as' defaultAlias)

61 <*> option Var.closedListing exposing

69 <*> option Var.closedListing exposing

62

70

63− as' :: IParser String

71+ as' :: String -> IParser String

64− as' =

72+ as' moduleName =

65 do try (whitespace >> reserved "as")

73 do try (whitespace >> reserved "as")

66 whitespace

74 whitespace

67− capVar <?> "alias for module"

75+ capVar <?> ("an alias for module `" ++ moduleName ++ "`")

68

76

69 exposing :: IParser (Var.Listing Var.Value)

77 exposing :: IParser (Var.Listing Var.Value)

70 exposing =

78 exposing =

@@ -75,13 +83,14 @@ import' =

75

83

76listing :: IParser a -> IParser (Var.Listing a)

84listing :: IParser a -> IParser (Var.Listing a)

77listing item =

85listing item =

86+ expecting "a listing of values and types to expose, like (..)" $

78 do try (whitespace >> char '(')

87 do try (whitespace >> char '(')

79 whitespace

88 whitespace

80 listing <-

89 listing <-

81 choice

90 choice

82 [ const Var.openListing <$> string ".."

91 [ const Var.openListing <$> string ".."

83 , Var.Listing <$> commaSep1 item <*> return False

92 , Var.Listing <$> commaSep1 item <*> return False

84− ] <?> "listing of values (x,y,z)"

93+ ]

85 whitespace

94 whitespace

86 char ')'

95 char ')'

87 return listing

96 return listing

@@ -89,7 +98,7 @@ listing item =

89

98

90value :: IParser Var.Value

99value :: IParser Var.Value

91value =

100value =

92− val <|> tipe

101+ val <|> tipe <?> "a value or type to expose"

93 where

102 where

94 val =

103 val =

95 Var.Value <$> (lowVar <|> parens symOp)

104 Var.Value <$> (lowVar <|> parens symOp)

src/Parse/Parse.hs+11−10

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

1{-# OPTIONS_GHC -Wall #-}

2−module Parse.Parse (program) where

2+module Parse.Parse (program, parse) where

3

4import Control.Applicative ((<$>), (<*>))

5import qualified Data.Map as Map

6import qualified Data.Traversable as T

7−import Text.Parsec (char, eof, letter, many, optional, putState, (<|>), (<?>))

7+import Text.Parsec (char, eof, letter, many, optional, putState, (<|>))

8import qualified Text.Parsec.Error as Parsec

9

10import qualified AST.Declaration as D

@@ -21,36 +21,37 @@ import qualified Validate

21

22program

23 :: Bool

24+ -> Bool

24 -> OpTable

25 -> OpTable

25 -> String

26 -> String

26 -> Result.Result wrn Error.Error M.ValidModule

27 -> Result.Result wrn Error.Error M.ValidModule

27−program needsDefaults table src =

28+program needsDefaults isRoot table src =

28− do (M.Module names filePath exports imports sourceDecls) <-

29+ do (M.Module names filePath docs exports imports sourceDecls) <-

29 parseWithTable table src programParser

30 parseWithTable table src programParser

30

31

31− validDecls <- Validate.declarations sourceDecls

32+ validDecls <- Validate.declarations isRoot sourceDecls

32

33

33 let ammendedImports =

34 let ammendedImports =

34 (if needsDefaults then Imports.defaults else [], imports)

35 (if needsDefaults then Imports.defaults else [], imports)

35

36

36− return (M.Module names filePath exports ammendedImports validDecls)

37+ return (M.Module names filePath docs exports ammendedImports validDecls)

37

38

39

39-- HEADERS AND DECLARATIONS

40-- HEADERS AND DECLARATIONS

40

41

41programParser :: IParser M.SourceModule

42programParser :: IParser M.SourceModule

42programParser =

43programParser =

43− do (M.Header names exports imports) <- Module.header

44+ do (M.Header names docs exports imports) <- Module.header

44 decls <- declarations

45 decls <- declarations

45 optional freshLine

46 optional freshLine

46 optional spaces

47 optional spaces

47 eof

48 eof

48− return $ M.Module names "" exports imports decls

49+ return $ M.Module names "" docs exports imports decls

49

50

51

51declarations :: IParser [D.SourceDecl]

52declarations :: IParser [D.SourceDecl]

52declarations =

53declarations =

53− (:) <$> (Decl.declaration <?> "at least one datatype or variable definition")

54+ (:) <$> Decl.declaration

54 <*> many freshDef

55 <*> many freshDef

55

56

57

@@ -58,7 +59,7 @@ freshDef :: IParser D.SourceDecl

58freshDef =

59freshDef =

59 commitIf (freshLine >> (letter <|> char '_')) $

60 commitIf (freshLine >> (letter <|> char '_')) $

60 do _ <- freshLine

61 do _ <- freshLine

61− Decl.declaration <?> "another datatype or variable definition"

62+ Decl.declaration

62

63

64

64-- RUN PARSERS

65-- RUN PARSERS

src/Parse/Pattern.hs+2−2

@@ -89,7 +89,7 @@ list =

89term :: IParser P.RawPattern

90term =

91 choice [ record, tuple, list, basic ]

92− <?> "pattern"

92+ <?> "a pattern"

93

94

95patternConstructor :: IParser P.RawPattern

@@ -104,7 +104,7 @@ patternConstructor =

104

105expr :: IParser P.RawPattern

106expr =

107− asPattern subPattern <?> "pattern"

107+ asPattern subPattern <?> "a pattern"

108 where

109 subPattern =

110 do patterns <- consSep1 (patternConstructor <|> term)

src/Parse/Type.hs+3−3

@@ -15,7 +15,7 @@ import qualified Reporting.Region as R

15tvar :: IParser Type.Raw

16tvar =

17 addLocation

18− (Type.RVar <$> lowVar <?> "type variable")

18+ (Type.RVar <$> lowVar <?> "a type variable")

19

20

21tuple :: IParser Type.Raw

@@ -71,7 +71,7 @@ term =

71app :: IParser Type.Raw

72app =

73 do start <- getMyPosition

74− f <- constructor0 <|> try tupleCtor <?> "type constructor"

74+ f <- constructor0 <|> try tupleCtor <?> "a type constructor"

75 args <- spacePrefix term

76 end <- getMyPosition

77 case args of

@@ -89,7 +89,7 @@ expr :: IParser Type.Raw

89expr =

90 do start <- getMyPosition

91 t1 <- app <|> term

92− arr <- optionMaybe $ try (whitespace >> arrow)

92+ arr <- optionMaybe $ try (whitespace >> rightArrow)

93 case arr of

94 Nothing ->

95 return t1

src/Reporting/Annotation.hs+6−2

@@ -16,6 +16,10 @@ type Located a =

16 Annotated R.Region a

17

18

19+type Commented a =

20+ Annotated (R.Region, Maybe String) a

21+

22+

19-- CREATE

23-- CREATE

20

24

21at :: R.Position -> R.Position -> a -> Located a

25at :: R.Position -> R.Position -> a -> Located a

@@ -48,5 +52,5 @@ drop (A _ value) =

48-- PRETTY PRINT

52-- PRETTY PRINT

49

53

50instance (P.Pretty a) => P.Pretty (Annotated info a) where

54instance (P.Pretty a) => P.Pretty (Annotated info a) where

51− pretty parens (A _ value) =

55+ pretty dealiaser parens (A _ value) =

52− P.pretty parens value

56+ P.pretty dealiaser parens value

src/Reporting/Crash.hsnew file+20

@@ -0,0 +1,20 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Reporting.Crash where

3+

4+import qualified Reporting.Region as R

5+

6+

7+data Details

8+ = IncompleteMultiIf R.Region

9+ | IncompletePatternMatch R.Region

10+ deriving (Show)

11+

12+

13+summary :: Details -> String

14+summary details =

15+ case details of

16+ IncompleteMultiIf _ ->

17+ "incomplete-multi-if"

18+

19+ IncompletePatternMatch _ ->

20+ "incomplete-pattern-match"

src/Reporting/Error.hs+60−13

@@ -1,10 +1,17 @@

1+{-# OPTIONS_GHC -Wall #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2module Reporting.Error where

3module Reporting.Error where

3

4

5+import Data.Aeson ((.=))

6+import qualified Data.Aeson as Json

7+import Prelude hiding (print)

8+

4import qualified Reporting.Annotation as A

9import qualified Reporting.Annotation as A

5import qualified Reporting.Error.Canonicalize as Canonicalize

10import qualified Reporting.Error.Canonicalize as Canonicalize

11+import qualified Reporting.Error.Docs as Docs

6import qualified Reporting.Error.Syntax as Syntax

12import qualified Reporting.Error.Syntax as Syntax

7import qualified Reporting.Error.Type as Type

13import qualified Reporting.Error.Type as Type

14+import qualified Reporting.PrettyPrint as P

8import qualified Reporting.Report as Report

15import qualified Reporting.Report as Report

9

16

10

17

@@ -14,28 +21,68 @@ data Error

14 = Syntax Syntax.Error

21 = Syntax Syntax.Error

15 | Canonicalize Canonicalize.Error

22 | Canonicalize Canonicalize.Error

16 | Type Type.Error

23 | Type Type.Error

24+ | Docs Docs.Error

25+

26+

27+-- TO REPORT

28+

29+toReport :: P.Dealiaser -> Error -> Report.Report

30+toReport dealiaser err =

31+ case err of

32+ Syntax syntaxError ->

33+ Syntax.toReport dealiaser syntaxError

34+

35+ Canonicalize canonicalizeError ->

36+ Canonicalize.toReport dealiaser canonicalizeError

37+

38+ Type typeError ->

39+ Type.toReport dealiaser typeError

40+

41+ Docs docsError ->

42+ Docs.toReport docsError

17

43

18

44

19-- TO STRING

45-- TO STRING

20

46

21−toString :: String -> String -> A.Located Error -> String

47+toString :: P.Dealiaser -> String -> String -> A.Located Error -> String

22−toString location source (A.A region err) =

48+toString dealiaser location source (A.A region err) =

49+ Report.toString location region (toReport dealiaser err) source

50+

51+

52+print :: P.Dealiaser -> String -> String -> A.Located Error -> IO ()

53+print dealiaser location source (A.A region err) =

54+ Report.printError location region (toReport dealiaser err) source

55+

56+

57+-- TO JSON

58+

59+toJson :: P.Dealiaser -> FilePath -> A.Located Error -> Json.Value

60+toJson dealiaser filePath (A.A region err) =

23 let

61 let

24− (tag, report) =

62+ (maybeRegion, additionalFields) =

25 case err of

63 case err of

26 Syntax syntaxError ->

64 Syntax syntaxError ->

27− ( "SYNTAX ERROR"

28− , Syntax.toReport syntaxError

65+ Report.toJson [] (Syntax.toReport dealiaser syntaxError)

29− )

30

66

31 Canonicalize canonicalizeError ->

67 Canonicalize canonicalizeError ->

32− ( "NAMING ERROR"

68+ let

69+ suggestions =

70+ maybe []

71+ (\s -> ["suggestions" .= s])

72+ (Canonicalize.extractSuggestions canonicalizeError)

73+ in

33− , Canonicalize.toReport canonicalizeError

74+ Report.toJson suggestions (Canonicalize.toReport dealiaser canonicalizeError)

34− )

35

75

36 Type typeError ->

76 Type typeError ->

37− ( "TYPE ERROR"

38− , Type.toReport typeError

77+ Report.toJson [] (Type.toReport dealiaser typeError)

39− )

78+

79+ Docs docsError ->

80+ Report.toJson [] (Docs.toReport docsError)

40 in

81 in

41− Report.toString tag location region report source

82+ Json.object $

83+ [ "file" .= filePath

84+ , "region" .= region

85+ , "subregion" .= maybeRegion

86+ , "type" .= ("error" :: String)

87+ ]

88+ ++ additionalFields

src/Reporting/Error/Canonicalize.hs+68−67

@@ -1,16 +1,12 @@

1{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3module Reporting.Error.Canonicalize where

2module Reporting.Error.Canonicalize where

4

3

5−import Data.Function (on)

6−import qualified Data.List as List

7−import qualified Text.EditDistance as Dist

8import qualified Text.PrettyPrint as P

4import qualified Text.PrettyPrint as P

9

5

10import qualified AST.Module as Module

6import qualified AST.Module as Module

11import qualified AST.Type as Type

7import qualified AST.Type as Type

12import qualified AST.Variable as Var

8import qualified AST.Variable as Var

13−import Elm.Utils ((|>))

9+import qualified Reporting.Error.Helpers as Help

14import qualified Reporting.PrettyPrint as P

10import qualified Reporting.PrettyPrint as P

15import qualified Reporting.Region as Region

11import qualified Reporting.Region as Region

16import qualified Reporting.Report as Report

12import qualified Reporting.Report as Report

@@ -37,8 +33,8 @@ data VarError = VarError

37

33

38data VarProblem

34data VarProblem

39 = Ambiguous

35 = Ambiguous

40− | UnknownQualifier String

36+ | UnknownQualifier String String

41− | QualifiedUnknown String

37+ | QualifiedUnknown String String

42 | ExposedUnknown

38 | ExposedUnknown

43

39

44

40

@@ -110,53 +106,43 @@ port name isInbound rootType localType maybeMessage =

110 Port (PortError name isInbound rootType localType maybeMessage)

106 Port (PortError name isInbound rootType localType maybeMessage)

111

107

112

108

113−-- NEARBY NAMES

109+-- TO REPORT

114−

115−nearbyNames :: (a -> String) -> a -> [a] -> [a]

116−nearbyNames format name names =

117− let editDistance =

118− if length (format name) < 3 then 1 else 2

119− in

120− names

121− |> map (\x -> (distance (format name) (format x), x))

122− |> List.sortBy (compare `on` fst)

123− |> filter ( (<= editDistance) . abs . fst )

124− |> map snd

125−

126−

127−distance :: String -> String -> Int

128−distance x y =

129− Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y

130

110

111+namingError :: String -> String -> Report.Report

112+namingError pre post =

113+ Report.simple "NAMING ERROR" pre post

131

114

132−-- TO REPORT

133

115

134−toReport :: Error -> Report.Report

116+toReport :: P.Dealiaser -> Error -> Report.Report

135−toReport err =

117+toReport dealiaser err =

136 case err of

118 case err of

137 Var (VarError kind name problem suggestions) ->

119 Var (VarError kind name problem suggestions) ->

138− let var = kind ++ " '" ++ name ++ "'"

120+ let var = kind ++ " `" ++ name ++ "`"

139 in

121 in

140 case problem of

122 case problem of

141 Ambiguous ->

123 Ambiguous ->

142− Report.simple

124+ namingError

143 ("This usage of " ++ var ++ " is ambiguous.")

125 ("This usage of " ++ var ++ " is ambiguous.")

144− (maybeYouWant suggestions)

126+ (Help.maybeYouWant suggestions)

145−

127+

146− UnknownQualifier qualifier ->

128+ UnknownQualifier qualifier localName ->

147− Report.simple

129+ namingError

130+ ("Cannot find " ++ var ++ ".")

148− ("Cannot find " ++ var ++ ", qualifier '" ++ qualifier ++ "' is not in scope.")

131+ ( "The qualifier `" ++ qualifier ++ "` is not in scope. "

149− (maybeYouWant suggestions)

132+ ++ Help.maybeYouWant (map (\modul -> modul ++ "." ++ localName) suggestions)

150−

133+ )

134+

151− QualifiedUnknown qualifier ->

135+ QualifiedUnknown qualifier localName ->

152− Report.simple

136+ namingError

137+ ("Cannot find " ++ var ++ ".")

153− ("Cannot find " ++ var ++ ", module '" ++ qualifier ++ "' does not expose that value.")

138+ ( "`" ++ qualifier ++ "` does not expose `" ++ localName ++ "`. "

154− (maybeYouWant suggestions)

139+ ++ Help.maybeYouWant (map (\v -> qualifier ++ "." ++ v) suggestions)

140+ )

155

141

156 ExposedUnknown ->

142 ExposedUnknown ->

157− Report.simple

143+ namingError

158 ("Cannot find " ++ var)

144 ("Cannot find " ++ var)

159− (maybeYouWant suggestions)

145+ (Help.maybeYouWant suggestions)

160

146

161 Pattern patternError ->

147 Pattern patternError ->

162 case patternError of

148 case patternError of

@@ -169,18 +155,18 @@ toReport err =

169 argMismatchReport "Type" var expected actual

155 argMismatchReport "Type" var expected actual

170

156

171 SelfRecursive name tvars tipe ->

157 SelfRecursive name tvars tipe ->

172− Report.simple "This type alias is recursive, forming an infinite type!" $

158+ Report.simple "ALIAS PROBLEM" "This type alias is recursive, forming an infinite type!" $

173 "Type aliases are just names for more fundamental types, so I go through\n"

159 "Type aliases are just names for more fundamental types, so I go through\n"

174 ++ "and expand them all to know the real underlying type. The problem is that\n"

160 ++ "and expand them all to know the real underlying type. The problem is that\n"

175 ++ "when I expand a recursive type alias, it keeps getting bigger and bigger.\n"

161 ++ "when I expand a recursive type alias, it keeps getting bigger and bigger.\n"

176 ++ "Dealiasing results in an infinitely large type! Try this instead:\n\n"

162 ++ "Dealiasing results in an infinitely large type! Try this instead:\n\n"

177 ++ " type " ++ name ++ concatMap (' ':) tvars ++ " ="

163 ++ " type " ++ name ++ concatMap (' ':) tvars ++ " ="

178− ++ P.render (P.nest 8 (P.hang (P.text name) 2 (P.pretty True tipe)))

164+ ++ P.render (P.nest 8 (P.hang (P.text name) 2 (P.pretty dealiaser True tipe)))

179 ++ "\n\nThis creates a brand new type that cannot be expanded. It is similar types\n"

165 ++ "\n\nThis creates a brand new type that cannot be expanded. It is similar types\n"

180 ++ "like List which are recursive, but do not get expanded into infinite types."

166 ++ "like List which are recursive, but do not get expanded into infinite types."

181

167

182 MutuallyRecursive aliases ->

168 MutuallyRecursive aliases ->

183− Report.simple "This type alias is part of a mutually recursive set of type aliases." $

169+ Report.simple "ALIAS PROBLEM" "This type alias is part of a mutually recursive set of type aliases." $

184 "The following type aliases all depend on each other in some way:\n"

170 "The following type aliases all depend on each other in some way:\n"

185 ++ concatMap showName aliases ++ "\n\n"

171 ++ concatMap showName aliases ++ "\n\n"

186 ++ "The problem is that when you try to expand any of these type aliases, they\n"

172 ++ "The problem is that when you try to expand any of these type aliases, they\n"

@@ -195,19 +181,19 @@ toReport err =

195 in

181 in

196 case importError of

182 case importError of

197 ModuleNotFound suggestions ->

183 ModuleNotFound suggestions ->

198− Report.simple

184+ namingError

199− ("Could not find a module named '" ++ moduleName ++ "'")

185+ ("Could not find a module named `" ++ moduleName ++ "`")

200− (maybeYouWant (map Module.nameToString suggestions))

186+ (Help.maybeYouWant (map Module.nameToString suggestions))

201

187

202 ValueNotFound value suggestions ->

188 ValueNotFound value suggestions ->

203− Report.simple

189+ namingError

204− ("Module '" ++ moduleName ++ "' does not expose '" ++ value ++ "'")

190+ ("Module `" ++ moduleName ++ "` does not expose `" ++ value ++ "`")

205− (maybeYouWant suggestions)

191+ (Help.maybeYouWant suggestions)

206

192

207 Export name suggestions ->

193 Export name suggestions ->

208− Report.simple

194+ namingError

209− ("Could not export '" ++ name ++ "' which is not defined in this module.")

195+ ("Could not export `" ++ name ++ "` which is not defined in this module.")

210− (maybeYouWant suggestions)

196+ (Help.maybeYouWant suggestions)

211

197

212 Port (PortError name isInbound _rootType localType maybeMessage) ->

198 Port (PortError name isInbound _rootType localType maybeMessage) ->

213 let

199 let

@@ -216,16 +202,16 @@ toReport err =

216

202

217 preHint =

203 preHint =

218 "Trying to send " ++ maybe "an unsupported type" id maybeMessage

204 "Trying to send " ++ maybe "an unsupported type" id maybeMessage

219− ++ " through " ++ boundPort ++ " '" ++ name ++ "'"

205+ ++ " through " ++ boundPort ++ " `" ++ name ++ "`"

220

206

221 postHint =

207 postHint =

222 "The specific unsupported type is:\n\n"

208 "The specific unsupported type is:\n\n"

223− ++ P.render (P.nest 4 (P.pretty False localType)) ++ "\n\n"

209+ ++ P.render (P.nest 4 (P.pretty dealiaser False localType)) ++ "\n\n"

224 ++ "The types of values that can flow through " ++ boundPort ++ "s include:\n"

210 ++ "The types of values that can flow through " ++ boundPort ++ "s include:\n"

225 ++ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples,\n"

211 ++ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples,\n"

226 ++ "Json.Values, and concrete records."

212 ++ "Json.Values, and concrete records."

227 in

213 in

228− Report.simple preHint postHint

214+ Report.simple "PORT ERROR" preHint postHint

229

215

230

216

231argMismatchReport :: String -> Var.Canonical -> Int -> Int -> Report.Report

217argMismatchReport :: String -> Var.Canonical -> Int -> Int -> Report.Report

@@ -234,21 +220,36 @@ argMismatchReport kind var expected actual =

234 preHint =

220 preHint =

235 kind ++ " " ++ Var.toString var ++ " has too "

221 kind ++ " " ++ Var.toString var ++ " has too "

236 ++ (if actual < expected then "few" else "many")

222 ++ (if actual < expected then "few" else "many")

237− ++ "arguments."

223+ ++ " arguments."

238

224

239 postHint =

225 postHint =

240 "Expecting " ++ show expected ++ ", but got " ++ show actual ++ "."

226 "Expecting " ++ show expected ++ ", but got " ++ show actual ++ "."

241 in

227 in

242− Report.Report Nothing preHint postHint

228+ Report.simple "ARGUMENT" preHint postHint

243

229

244

230

245−maybeYouWant :: [String] -> String

231+extractSuggestions :: Error -> Maybe [String]

246−maybeYouWant suggestions =

232+extractSuggestions err =

233+ case err of

234+ Var (VarError _ _ _ suggestions) ->

247− case suggestions of

235+ Just suggestions

248− [] ->

236+

249− ""

237+ Pattern _ ->

238+ Nothing

239+

240+ Alias _ ->

241+ Nothing

242+

243+ Import _ importError ->

244+ case importError of

245+ ModuleNotFound suggestions ->

246+ Just (map Module.nameToString suggestions)

247+

248+ ValueNotFound _ suggestions ->

249+ Just suggestions

250

251− _:_ ->

251+ Export _ suggestions ->

252− "Maybe you want one of the following?\n"

253− ++ concatMap ("\n "++) suggestions

252+ Just suggestions

254

253

254+ Port _ ->

255+ Nothing

src/Reporting/Error/Docs.hsnew file+61

@@ -0,0 +1,61 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Reporting.Error.Docs where

3+

4+import qualified Reporting.Error.Helpers as Help

5+import qualified Reporting.Report as Report

6+

7+

8+data Error

9+ = NoDocs

10+ | OnlyInDocs String [String]

11+ | OnlyInExports [String]

12+ | NoComment String

13+ | NoType String

14+

15+

16+-- TO REPORT

17+

18+toReport :: Error -> Report.Report

19+toReport err =

20+ case err of

21+ NoDocs ->

22+ Report.simple "DOCUMENTATION ERROR"

23+ ( "You must have a documentation comment between the module declaration and the\n"

24+ ++ "imports."

25+ )

26+ "Learn how at <http://package.elm-lang.org/help/documentation-format>"

27+

28+ OnlyInDocs name suggestions ->

29+ Report.simple "DOCUMENTATION ERROR"

30+ ("Your module documentation includes `" ++ name ++ "` which is not exported.")

31+ ("Is it misspelled? Should it be exported? " ++ Help.maybeYouWant suggestions)

32+

33+ OnlyInExports names ->

34+ Report.simple

35+ "DOCUMENTATION ERROR"

36+ ( "The following exports do not appear in your module documentation:\n"

37+ ++ concatMap ("\n " ++) names

38+ )

39+ ( "All exports must be listed in the module documentation after a @docs keyword.\n"

40+ ++ "Learn how at <http://package.elm-lang.org/help/documentation-format>"

41+ )

42+

43+ NoComment name ->

44+ Report.simple "DOCUMENTATION ERROR"

45+ ("The value `" ++ name ++ "` does not have a documentation comment.")

46+ ( "Documentation comments start with {-| and end with -}. They should provide a\n"

47+ ++ "clear description of how they work, and ideally a small code example. This is\n"

48+ ++ "extremely valuable for users checking out your package!\n\n"

49+ ++ "If you think the docs are clearer without any words, you can use an empty\n"

50+ ++ "comment {-|-} which should be used sparingly. Maybe you have a section of 20\n"

51+ ++ "values all with the exact same type. The docs may read better if they are all\n"

52+ ++ "described in one place.\n\n"

53+ ++ "Learn more at <http://package.elm-lang.org/help/documentation-format>"

54+ )

55+

56+ NoType name ->

57+ Report.simple "MISSING ANNOTATION"

58+ ("The value `" ++ name ++ "` does not have a type annotation.")

59+ ( "Adding type annotations is best practice and it gives you a chance to name\n"

60+ ++ "types and type variables so they are as easy as possible to understand!"

61+ )

src/Reporting/Error/Helpers.hsnew file+39

@@ -0,0 +1,39 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Reporting.Error.Helpers where

3+

4+import Data.Function (on)

5+import qualified Data.List as List

6+import qualified Text.EditDistance as Dist

7+

8+import Elm.Utils ((|>))

9+

10+

11+-- NEARBY NAMES

12+

13+nearbyNames :: (a -> String) -> a -> [a] -> [a]

14+nearbyNames format name names =

15+ let editDistance =

16+ if length (format name) < 3 then 1 else 2

17+ in

18+ names

19+ |> map (\x -> (distance (format name) (format x), x))

20+ |> List.sortBy (compare `on` fst)

21+ |> filter ( (<= editDistance) . abs . fst )

22+ |> map snd

23+

24+

25+distance :: String -> String -> Int

26+distance x y =

27+ Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y

28+

29+

30+maybeYouWant :: [String] -> String

31+maybeYouWant suggestions =

32+ case suggestions of

33+ [] ->

34+ ""

35+

36+ _:_ ->

37+ "Maybe you want one of the following?\n"

38+ ++ concatMap ("\n "++) (take 4 suggestions)

39+

src/Reporting/Error/Nitpick.hsdeleted−25

@@ -1,25 +0,0 @@

1−module Reporting.Error.Nitpick where

2−

3−import qualified Data.Aeson as Json

4−

5−import qualified AST.Variable as Var

6−import qualified Reporting.Region as R

7−

8−

9−data Error = ConstructorTypeNotFound Var.Canonical

10−

11−-- TO STRING

12−

13−toString :: R.Region -> Error -> String

14−toString region err =

15− case err of

16− _ -> error "Nitpick.toString" region

17−

18−

19−-- TO JSON

20−

21−toJson :: Error -> Json.Value

22−toJson err =

23− case err of

24− _ -> error "Nitpick.toJson"

25−

src/Reporting/Error/Syntax.hs+130−48

@@ -2,13 +2,13 @@

2module Reporting.Error.Syntax where

3

4import qualified Data.List as List

5+import qualified Data.Set as Set

5import qualified Text.Parsec.Error as Parsec

6import qualified Text.Parsec.Error as Parsec

6import qualified Text.PrettyPrint as P

7import qualified Text.PrettyPrint as P

7import Text.PrettyPrint ((<+>))

8import Text.PrettyPrint ((<+>))

8

9

9import qualified AST.Helpers as Help

10import qualified AST.Helpers as Help

10import qualified AST.Type as Type

11import qualified AST.Type as Type

11−import Elm.Utils ((|>))

12import qualified Reporting.PrettyPrint as P

13import qualified Reporting.Report as Report

14

@@ -18,6 +18,7 @@ data Error

18 | InfixDuplicate String

19 | TypeWithoutDefinition String

20 | PortWithoutAnnotation String

21+ | UnexpectedPort

21 | DuplicateValueDeclaration String

22 | DuplicateValueDeclaration String

22 | DuplicateTypeDeclaration String

23 | DuplicateTypeDeclaration String

23 | DuplicateDefinition String

24 | DuplicateDefinition String

@@ -27,16 +28,15 @@ data Error

27

28

28-- TO REPORT

29-- TO REPORT

29

30

30−toReport :: Error -> Report.Report

31+toReport :: P.Dealiaser -> Error -> Report.Report

31−toReport err =

32+toReport dealiaser err =

32 case err of

33 case err of

33 Parse messages ->

34 Parse messages ->

34− Report.simple

35+ parseErrorReport messages

35− "Problem when parsing your code!"

36− (unlines (map parseErrorHint messages))

37

36

38 InfixDuplicate opName ->

37 InfixDuplicate opName ->

39 Report.simple

38 Report.simple

39+ "INFIX OVERLAP"

40 ("The infix declarations for " ++ operator ++ " must be removed.")

41 ("The precedence and associativity can only be set in one place, and\n"

42 ++ "this information has already been set somewhere else."

@@ -49,8 +49,9 @@ toReport err =

49

50 TypeWithoutDefinition valueName ->

51 Report.simple

52+ "MISSING DEFINITION"

52− ("There is a type annotation for '" ++ valueName ++ "' but there"

53+ ("There is a type annotation for `" ++ valueName ++ "` but there"

53− ++ "is no corresponding definition!"

54+ ++ " is no corresponding definition!"

54 )

55 )

55 ("Directly below the type annotation, put a definition like:\n\n"

56 ("Directly below the type annotation, put a definition like:\n\n"

56 ++ " " ++ valueName ++ " = 42"

57 ++ " " ++ valueName ++ " = 42"

@@ -58,35 +59,49 @@ toReport err =

58

59

59 PortWithoutAnnotation portName ->

60 PortWithoutAnnotation portName ->

60 Report.simple

61 Report.simple

62+ "PORT ERROR"

61− ("Port '" ++ portName ++ "' does not have a type annotation!")

63+ ("Port `" ++ portName ++ "` does not have a type annotation!")

62 ("Directly above the port definition, I need something like this:\n\n"

64 ("Directly above the port definition, I need something like this:\n\n"

63 ++ " port " ++ portName ++ " : Signal Int"

65 ++ " port " ++ portName ++ " : Signal Int"

64 )

66 )

65

67

68+

69+ UnexpectedPort ->

70+ Report.simple

71+ "PORT ERROR"

72+ "This module has ports, but ports can only appear in the main module."

73+ ( "Ports in library code would create hidden dependencies where importing a\n"

74+ ++ "module could bring in constraints not captured in the public API. Furthermore,\n"

75+ ++ "if the module is imported twice, do we send values out the port twice?"

76+ )

77+

66 DuplicateValueDeclaration name ->

78 DuplicateValueDeclaration name ->

67 Report.simple

79 Report.simple

80+ "DUPLICATE DEFINITION"

68− ("Naming multiple top-level values '" ++ name ++ "' makes things\n"

81+ ("Naming multiple top-level values `" ++ name ++ "` makes things\n"

69− ++ "ambiguous. When you say '" ++ name ++ "' which one do you want?!"

82+ ++ "ambiguous. When you say `" ++ name ++ "` which one do you want?"

70 )

83 )

71− ("Find all the top-level values named '" ++ name ++ "' and\n"

84+ ("Find all the top-level values named `" ++ name ++ "` and\n"

72 ++ "do some renaming. Make sure the names are distinct!"

85 ++ "do some renaming. Make sure the names are distinct!"

73 )

86 )

74

87

75 DuplicateTypeDeclaration name ->

88 DuplicateTypeDeclaration name ->

76 Report.simple

89 Report.simple

90+ "DUPLICATE DEFINITION"

77− ("Naming multiple types '" ++ name ++ "' makes things ambiguous\n"

91+ ("Naming multiple types `" ++ name ++ "` makes things ambiguous\n"

78− ++ "When you say '" ++ name ++ "' which one do you want?!"

92+ ++ "When you say `" ++ name ++ "` which one do you want?"

79 )

93 )

80− ("Find all the types named '" ++ name ++ "' and\n"

94+ ("Find all the types named `" ++ name ++ "` and\n"

81 ++ "do some renaming. Make sure the names are distinct!"

95 ++ "do some renaming. Make sure the names are distinct!"

82 )

96 )

83

97

84 DuplicateDefinition name ->

98 DuplicateDefinition name ->

85 Report.simple

99 Report.simple

100+ "DUPLICATE DEFINITION"

86− ("Naming multiple values '" ++ name ++ "' in a single let-expression makes\n"

101+ ("Naming multiple values `" ++ name ++ "` in a single let-expression makes\n"

87− ++ "things ambiguous. When you say '" ++ name ++ "' which one do you want?!"

102+ ++ "things ambiguous. When you say `" ++ name ++ "` which one do you want?"

88 )

103 )

89− ("Find all the values named '" ++ name ++ "' in this let-expression and\n"

104+ ("Find all the values named `" ++ name ++ "` in this let-expression and\n"

90 ++ "do some renaming. Make sure the names are distinct!"

105 ++ "do some renaming. Make sure the names are distinct!"

91 )

106 )

92

107

@@ -95,7 +110,7 @@ toReport err =

95 P.hang

110 P.hang

96 (P.text "type alias" <+> P.text typeName <+> P.hsep vars <+> P.equals)

111 (P.text "type alias" <+> P.text typeName <+> P.hsep vars <+> P.equals)

97 4

112 4

98− (P.pretty False tipe)

113+ (P.pretty dealiaser False tipe)

99 where

114 where

100 vars = map P.text (givenVars ++ tvar : tvars)

115 vars = map P.text (givenVars ++ tvar : tvars)

101

116

@@ -110,40 +125,107 @@ toReport err =

110 |> P.nest 4

125 |> P.nest 4

111 ]

126 ]

112 where

127 where

128+ (|>) = flip ($)

113 vars = map P.text (givenVars ++ tvar : tvars)

129 vars = map P.text (givenVars ++ tvar : tvars)

114 toDoc (ctor, args) =

130 toDoc (ctor, args) =

115− P.text ctor <+> P.hsep (map (P.pretty True) args)

131+ P.text ctor <+> P.hsep (map (P.pretty dealiaser True) args)

116

132

117

133

118unboundTypeVars :: String -> String -> [String] -> String -> Report.Report

134unboundTypeVars :: String -> String -> [String] -> String -> Report.Report

119unboundTypeVars typeName tvar tvars revisedDeclaration =

135unboundTypeVars typeName tvar tvars revisedDeclaration =

136+ Report.simple

137+ "UNBOUND TYPE VARS"

138+ ( "Not all type variables in `" ++ typeName ++ "` are listed, making sneaky\n"

139+ ++ "type errors possible. Unbound type variables include: "

140+ ++ List.intercalate ", " (tvar:tvars)

141+ )

142+ ( "You probably want this definition instead:\n"

143+ ++ concatMap ("\n "++) (lines revisedDeclaration) ++ "\n\n"

144+ ++ "Here's why. Imagine one `" ++ typeName ++ "` where `" ++ tvar ++ "` is an Int and\n"

145+ ++ "another where it is a Bool. When we explicitly list the type variables, type\n"

146+ ++ "checker can see that they are actually different types."

147+ )

148+

149+

150+-- TAGGING PARSE ERRORS

151+

152+newline :: String

153+newline = "NEWLINE"

154+

155+freshLine :: String

156+freshLine = "FRESH_LINE"

157+

158+whitespace :: String

159+whitespace = "WHITESPACE"

160+

161+keyword :: String -> String

162+keyword kwd =

163+ "KEYWORD=" ++ kwd

164+

165+unkeyword :: String -> Maybe String

166+unkeyword message =

167+ if List.isPrefixOf "KEYWORD=" message

168+ then Just (drop (length "KEYWORD=") message)

169+ else Nothing

170+

171+

172+-- REPORTING PARSE ERRORS

173+

174+parseErrorReport :: [Parsec.Message] -> Report.Report

175+parseErrorReport messages =

120 let

176 let

121− s = if null tvars then "" else "s"

177+ addMsg message hint =

178+ case message of

179+ Parsec.SysUnExpect _msg ->

180+ hint

181+

182+ Parsec.UnExpect _msg ->

183+ hint

184+

185+ Parsec.Expect msg ->

186+ let

187+ msg' =

188+ if msg `elem` [whitespace, newline, freshLine]

189+ then "whitespace"

190+ else msg

191+ in

192+ hint { _expected = Set.insert msg' (_expected hint) }

193+

194+ Parsec.Message msg ->

195+ hint { _messages = msg : _messages hint }

196+

197+ (ParseHint msgs expects) =

198+ foldr addMsg emptyHint messages

199+

200+ preHint =

201+ case msgs of

202+ [msg] ->

203+ case unkeyword msg of

204+ Just kwd ->

205+ "It looks like the keyword `" ++ kwd ++ "` is being used as a variable.\n"

206+ ++ "Try renaming it to something else."

207+ Nothing ->

208+ msg

209+

210+ _ -> "I ran into something unexpected when parsing your code!"

211+

212+ postHint =

213+ if Set.null expects

214+ then ""

215+ else

216+ "I am looking for one of the following things:\n"

217+ ++ concatMap ("\n "++) (Set.toList expects)

122 in

218 in

123− Report.simple

219+ Report.simple "SYNTAX PROBLEM" preHint postHint

124− ("Type '" ++ typeName ++ "' uses unbound type variable" ++ s ++ ": "

220+

125− ++ List.intercalate ", " (tvar:tvars)

221+

126− )

222+data ParseHint = ParseHint

127− ("All type variables must be listed to avoid sneaky type errors.\n"

223+ { _messages :: [String]

128− ++ "Imagine one '" ++ typeName ++ "' where '" ++ tvar ++ "' is an Int and\n"

224+ , _expected :: Set.Set String

129− ++ "another where it is a Bool. They both look like a '" ++ typeName ++ "'\n"

225+ }

130− ++ "to the type checker, but they are actually different types!\n\n"

226+ deriving (Show)

131− ++ "Maybe you want a definition like this?\n"

227+

132− ++ concatMap ("\n "++) (lines revisedDeclaration)

228+

133− )

229+emptyHint :: ParseHint

134−

230+emptyHint =

135−

231+ ParseHint [] Set.empty

136−parseErrorHint :: Parsec.Message -> String

137−parseErrorHint message =

138− case message of

139− Parsec.SysUnExpect msg ->

140− "SysUnExpect: " ++ msg

141−

142− Parsec.UnExpect msg ->

143− "UnExpect: " ++ msg

144−

145− Parsec.Expect msg ->

146− "UnExpect: " ++ msg

147−

148− Parsec.Message msg ->

149− "UnExpect: " ++ msg

src/Reporting/Error/Type.hs+241−54

@@ -1,9 +1,13 @@

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Type where

3

4+import qualified Data.Char as Char

5+import Text.PrettyPrint ((<+>))

4import qualified Text.PrettyPrint as P

6import qualified Text.PrettyPrint as P

5

7

6−import qualified AST.Type as T

8+import qualified AST.Helpers as Help

9+import qualified AST.Type as Type

10+import qualified AST.Variable as Var

7import qualified Reporting.PrettyPrint as P

11import qualified Reporting.PrettyPrint as P

8import qualified Reporting.Region as Region

12import qualified Reporting.Region as Region

9import qualified Reporting.Report as Report

13import qualified Reporting.Report as Report

@@ -11,113 +15,296 @@ import qualified Reporting.Report as Report

11

15

12data Error

16data Error

13 = Mismatch Mismatch

17 = Mismatch Mismatch

14− | InfiniteType String T.Canonical

18+ | InfiniteType InfiniteType

15− | BadMain T.Canonical

19+ | BadMain Type.Canonical

16

20

17

21

18data Mismatch = MismatchInfo

22data Mismatch = MismatchInfo

19 { _hint :: Hint

23 { _hint :: Hint

20− , _leftType :: T.Canonical

24+ , _leftType :: Type.Canonical

21− , _rightType :: T.Canonical

25+ , _rightType :: Type.Canonical

22− , _note :: Note

26+ , _note :: Maybe String

27+ }

28+

29+

30+data InfiniteType = InfiniteTypeInfo

31+ { _name :: String

32+ , _var :: Type.Canonical

33+ , _type :: Type.Canonical

23 }

34 }

24

35

25

36

26data Hint

37data Hint

27− = None

28− | CaseBranch Int Region.Region

38+ = CaseBranch Int Region.Region

29 | Case

39 | Case

40+ | IfCondition

30 | IfBranches

41 | IfBranches

31 | MultiIfBranch Int Region.Region

42 | MultiIfBranch Int Region.Region

32 | If

43 | If

44+ | List

45+ | ListElement Int Region.Region

46+ | BinopLeft Var.Canonical Region.Region

47+ | BinopRight Var.Canonical Region.Region

48+ | Binop Var.Canonical

49+ | Function (Maybe Var.Canonical)

50+ | UnexpectedArg (Maybe Var.Canonical) Int Region.Region

51+ | FunctionArity (Maybe Var.Canonical) Int Int Region.Region

52+ | BadTypeAnnotation String

53+ | Instance String

54+ | Literal String

55+ | Pattern Pattern

56+ | Shader

57+ | Range

58+ | Lambda

59+ | Record

33

60

34

61

35−data Note

62+data Pattern

36− = PreNote String

63+ = PVar String

37− | NoNote

64+ | PAlias String

38− | PostNote String

65+ | PData String

66+ | PRecord

39

67

40

68

41-- TO REPORT

69-- TO REPORT

42

70

43−toReport :: Error -> Report.Report

71+toReport :: P.Dealiaser -> Error -> Report.Report

44−toReport err =

72+toReport dealiaser err =

45 case err of

73 case err of

46 Mismatch (MismatchInfo hint leftType rightType note) ->

74 Mismatch (MismatchInfo hint leftType rightType note) ->

47 let

75 let

48− (subRegion, preHint) = hintToString hint

76+ (subRegion, preHint, maybePostHint) = hintToString hint

49

77

50 postHint =

78 postHint =

51− "To be more specific, as I infer all the types, I am seeing a conflict between\n"

79+ maybe "" (++"\n\n") note

52− ++ "this type:\n\n"

80+ ++ maybe "" (++"\n\n") maybePostHint

81+ ++ "As I infer the types of values flowing through your program, I see a conflict\n"

82+ ++ "between these two types:\n\n"

53− ++ P.render (P.nest 4 (P.pretty False leftType))

83+ ++ P.render (P.nest 4 (P.pretty dealiaser False leftType))

54− ++ "\n\nand this type:\n\n"

84+ ++ "\n\n"

55− ++ P.render (P.nest 4 (P.pretty False rightType))

85+ ++ P.render (P.nest 4 (P.pretty dealiaser False rightType))

56 in

86 in

57− case note of

58− PreNote msg ->

59− Report.Report subRegion (preHint ++ "\n\n" ++ msg) postHint

60−

61− NoNote ->

62− Report.Report subRegion preHint postHint

63−

64− PostNote msg ->

65− Report.Report subRegion preHint (postHint ++ "\n\n" ++ msg)

87+ Report.Report "TYPE MISMATCH" subRegion preHint postHint

66−

67

88

89+ InfiniteType (InfiniteTypeInfo name var tipe) ->

90+ let

91+ prettyVar =

92+ P.pretty dealiaser False var

68

93

69− InfiniteType var tipe ->

94+ prettyType =

70− Report.simple "This expression is leading me to infer an infinite type." $

95+ P.pretty dealiaser False tipe

71− "Maybe you are trying to do some tricky recursion? Try breaking the expression\n"

96+ in

97+ Report.simple "INFINITE TYPE"

98+ ( "I am inferring weird self-referential type for `" ++ name ++ "`"

99+ )

100+ ( "The bit of the type that is self-referential looks like this:\n\n"

101+ ++ P.render (P.nest 4 (prettyVar <+> P.equals <+> prettyType))

102+ ++ "\n\nThe cause is often that the usage of `" ++ name ++ "` is flipped around.\n\n"

103+ ++ "Maybe you are inserting a data structure into an element? Maybe you are giving\n"

104+ ++ "a function to an argument? Either way, something is probably backwards!\n\n"

105+ ++ "Try breaking the code related to `" ++ name ++ "` into smaller pieces.\n"

72− ++ "into smaller pieces. Give each piece a name and try to write down its type.\n\n"

106+ ++ "Give each piece a name and try to write down its type."

73− ++ "Type inference got stuck when type '" ++ var ++ "' needed equal to:\n\n"

107+ )

74− ++ P.render (P.nest 4 (P.pretty False tipe))

75− ++ "\n\nNotice that type variable '" ++ var ++ "' appears there too, so if we\n"

76− ++ "expanded this type, it would just keep getting bigger and bigger."

77

108

78 BadMain tipe ->

109 BadMain tipe ->

79− Report.simple "The 'main' value has an unsupported type." $

110+ Report.simple "BAD MAIN TYPE" "The 'main' value has an unsupported type." $

80 "I need an Element, Html, (Signal Element), or (Signal Html) so I can render it\n"

111 "I need an Element, Html, (Signal Element), or (Signal Html) so I can render it\n"

81 ++ "on screen, but you gave me:\n\n"

112 ++ "on screen, but you gave me:\n\n"

82− ++ P.render (P.nest 4 (P.pretty False tipe))

113+ ++ P.render (P.nest 4 (P.pretty dealiaser False tipe))

83

114

84

115

85−hintToString :: Hint -> (Maybe Region.Region, String)

116+hintToString :: Hint -> (Maybe Region.Region, String, Maybe String)

86hintToString hint =

117hintToString hint =

87 case hint of

118 case hint of

88− None ->

89− ( Nothing

90− , "This expression is triggering a type mismatch."

91− )

92−

93 CaseBranch branchNumber region ->

119 CaseBranch branchNumber region ->

94 ( Just region

120 ( Just region

95− , "The branches of this case-expression return different types of values.\n\n"

121+ , "The " ++ ordinalize branchNumber ++ " branch of this `case` results in an unexpected type of value."

96− ++ "I noticed the mismatch in branch #" ++ show branchNumber ++ ", but go through and make sure every\n"

122+ , Just "All branches should match so that no matter which one we take, we always get\nback the same type of value."

97− ++ "branch returns the same type of value."

98 )

123 )

99

124

100 Case ->

125 Case ->

101 ( Nothing

126 ( Nothing

102 , "All the branches of this case-expression are consistent, but the overall\n"

127 , "All the branches of this case-expression are consistent, but the overall\n"

103 ++ "type does not match how it is used elsewhere."

128 ++ "type does not match how it is used elsewhere."

129+ , Nothing

130+ )

131+

132+ IfCondition ->

133+ ( Nothing

134+ , "This condition does not evaluate to a boolean value, True or False."

135+ , Just "Elm does not have \"truthiness\" such that ints and strings and lists are\nautomatically converted to booleans. Do that conversion explicitly."

104 )

136 )

105

137

106 IfBranches ->

138 IfBranches ->

107 ( Nothing

139 ( Nothing

108− , "The branches of this if-expression return different types of values.\n"

140+ , "The branches of this `if` result in different types of values."

109− ++ "All branches must have the same return type!"

141+ , Just "All branches should match so that no matter which one we take, we always get\nback the same type of value."

110 )

142 )

111

143

112 MultiIfBranch branchNumber region ->

144 MultiIfBranch branchNumber region ->

113 ( Just region

145 ( Just region

114− , "The branches of this if-expression return different types of values.\n\n"

146+ , "The " ++ ordinalize branchNumber ++ " branch of this `if` results in an unexpected type of value."

115− ++ "I noticed the mismatch in branch #" ++ show branchNumber ++ ", but go through and make sure every\n"

147+ , Just "All branches should match so that no matter which one we take, we always get\nback the same type of value."

116− ++ "branch returns the same type of value."

117 )

148 )

118

149

119 If ->

150 If ->

120 ( Nothing

151 ( Nothing

121 , "All the branches of this if-expression are consistent, but the overall\n"

152 , "All the branches of this if-expression are consistent, but the overall\n"

122 ++ "type does not match how it is used elsewhere."

153 ++ "type does not match how it is used elsewhere."

154+ , Nothing

155+ )

156+

157+ ListElement elementNumber region ->

158+ ( Just region

159+ , "The " ++ ordinalize elementNumber ++ " element of this list is an unexpected type of value."

160+ , Just "All elements should be the same type of value so that we can iterate over the\nlist without running into unexpected values."

161+ )

162+

163+ List ->

164+ ( Nothing

165+ , "All the elements in this list are the same type, but the overall\n"

166+ ++ "type does not match how it is used elsewhere."

167+ , Nothing

168+ )

169+

170+ BinopLeft op region ->

171+ ( Just region

172+ , "The left argument of " ++ prettyOperator op ++ " is causing a type mismatch."

173+ , Nothing

174+ )

175+

176+ BinopRight op region ->

177+ ( Just region

178+ , "The right argument of " ++ prettyOperator op ++ " is causing a type mismatch."

179+ , Nothing

180+ )

181+

182+ Binop op ->

183+ ( Nothing

184+ , "The two arguments to " ++ prettyOperator op ++ " are fine, but the overall type of this expression\n"

185+ ++ "does not match how it is used elsewhere."

186+ , Nothing

187+ )

188+

189+ Function maybeName ->

190+ ( Nothing

191+ , "The return type of " ++ funcName maybeName ++ " is being used in unexpected ways."

192+ , Nothing

193+ )

194+

195+ UnexpectedArg maybeName index region ->

196+ ( Just region

197+ , "The " ++ ordinalize index ++ " argument to " ++ funcName maybeName

198+ ++ " has an unexpected type."

199+ , Nothing

200+ )

201+

202+ FunctionArity maybeName expected actual region ->

203+ let

204+ s = if expected <= 1 then "" else "s"

205+ in

206+ ( Just region

207+ , capitalize (funcName maybeName) ++ " is expecting " ++ show expected

208+ ++ " argument" ++ s ++ ", but was given " ++ show actual ++ "."

209+ , Nothing

210+ )

211+

212+ BadTypeAnnotation name ->

213+ ( Nothing

214+ , "The type annotation for `" ++ name ++ "` does not match its definition."

215+ , Nothing

123 )

216 )

217+

218+ Instance name ->

219+ ( Nothing

220+ , "Given how `" ++ name ++ "` is defined, this use will not work out."

221+ , Nothing

222+ )

223+

224+ Literal name ->

225+ ( Nothing

226+ , "This " ++ name ++ " value is being used as if it is some other type of value."

227+ , Nothing

228+ )

229+

230+ Pattern patErr ->

231+ let

232+ thing =

233+ case patErr of

234+ PVar name -> "variable `" ++ name ++ "`"

235+ PAlias name -> "alias `" ++ name ++ "`"

236+ PData name -> "`" ++ name ++ "`"

237+ PRecord -> "a record"

238+ in

239+ ( Nothing

240+ , "Problem with " ++ thing ++ " in this pattern match."

241+ , Nothing

242+ )

243+

244+ Shader ->

245+ ( Nothing

246+ , "There is some problem with this GLSL shader."

247+ , Nothing

248+ )

249+

250+ Range ->

251+ ( Nothing

252+ , "The low and high members of this list range are not the same type of value."

253+ , Nothing

254+ )

255+

256+ Lambda ->

257+ ( Nothing

258+ , "This anonymous function is being used in an unexpected way."

259+ , Nothing

260+ )

261+

262+ Record ->

263+ ( Nothing

264+ , "This record is being used in an unexpected way."

265+ , Nothing

266+ )

267+

268+

269+prettyOperator :: Var.Canonical -> String

270+prettyOperator (Var.Canonical _ opName) =

271+ if Help.isOp opName

272+ then "(" ++ opName ++ ")"

273+ else "`" ++ opName ++ "`"

274+

275+

276+funcName :: Maybe Var.Canonical -> String

277+funcName maybeVar =

278+ case maybeVar of

279+ Nothing ->

280+ "this function"

281+

282+ Just var ->

283+ "function " ++ prettyOperator var

284+

285+

286+capitalize :: String -> String

287+capitalize string =

288+ case string of

289+ [] -> []

290+ c : cs ->

291+ Char.toUpper c : cs

292+

293+

294+ordinalize :: Int -> String

295+ordinalize number =

296+ let

297+ remainder10 =

298+ number `mod` 10

299+

300+ remainder100 =

301+ number `mod` 100

302+

303+ ending

304+ | remainder100 `elem` [11..13] = "th"

305+ | remainder10 == 1 = "st"

306+ | remainder10 == 2 = "nd"

307+ | remainder10 == 3 = "rd"

308+ | otherwise = "th"

309+ in

310+ show number ++ ending

src/Reporting/PrettyPrint.hs+14−2

@@ -1,19 +1,31 @@

1{-# LANGUAGE FlexibleInstances #-}

2module Reporting.PrettyPrint where

3

4+import qualified Data.Map as Map

4import Text.PrettyPrint as P

5import Text.PrettyPrint as P

6+

5import qualified AST.Helpers as Help

7import qualified AST.Helpers as Help

6

8

7

9

10+-- PRETTY

11+

8class Pretty a where

12class Pretty a where

9− pretty :: Bool -> a -> Doc

13+ pretty :: Dealiaser -> Bool -> a -> Doc

14+

10

15

16+type Dealiaser =

17+ Map.Map String String

18+

19+

20+-- INSTANCES

11

21

12instance Pretty String where

22instance Pretty String where

13− pretty _ str =

23+ pretty _ _ str =

14 P.text str

24 P.text str

15

25

16

26

27+-- HELPERS

28+

17commaCat :: [Doc] -> Doc

29commaCat :: [Doc] -> Doc

18commaCat docs =

30commaCat docs =

19 cat (punctuate comma docs)

31 cat (punctuate comma docs)

src/Reporting/Report.hs+180−52

@@ -1,41 +1,127 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

1module Reporting.Report

3module Reporting.Report

2 ( Report(Report)

4 ( Report(Report)

3 , simple

5 , simple

4 , toString

6 , toString

7+ , toJson

8+ , printError, printWarning

5 ) where

9 ) where

6

10

7−import Elm.Utils ((|>))

11+import Control.Applicative ((<|>))

12+import Control.Monad.Writer (Writer, execWriter, tell)

13+import Data.Aeson ((.=))

14+import qualified Data.Aeson.Types as Json

15+import System.Console.ANSI

16+import System.IO (hPutStr, stderr)

17+

8import qualified Reporting.Region as R

18import qualified Reporting.Region as R

9

19

10

20

11data Report = Report

21data Report = Report

12− { highlight :: Maybe R.Region

22+ { _title :: String

23+ , _highlight :: Maybe R.Region

24+ , _preHint :: String

25+ , _postHint :: String

26+ }

27+

28+

29+simple :: String -> String -> String -> Report

30+simple title pre post =

31+ Report title Nothing pre post

32+

33+

34+toString :: String -> R.Region -> Report -> String -> String

35+toString location region report source =

36+ execWriter (render plain location region report source)

37+

38+

39+printError :: String -> R.Region -> Report -> String -> IO ()

40+printError location region report source =

41+ render (ansi Error) location region report source

42+

43+

44+printWarning :: String -> R.Region -> Report -> String -> IO ()

45+printWarning location region report source =

46+ render (ansi Warning) location region report source

47+

48+

49+render

50+ :: (Monad m)

51+ => Renderer m

52+ -> String

53+ -> R.Region

54+ -> Report

55+ -> String

56+ -> m ()

57+render renderer location region (Report title highlight pre post) source =

58+ do messageBar renderer title location

59+ normal renderer (pre ++ "\n\n")

60+ grabRegion renderer highlight region source

61+ normal renderer ("\n" ++ if null post then "\n" else post ++ "\n\n\n")

62+

63+

64+toJson :: [Json.Pair] -> Report -> (Maybe R.Region, [Json.Pair])

65+toJson extraFields (Report title subregion pre post) =

66+ let

67+ fields =

68+ [ "tag" .= title

69+ , "overview" .= pre

70+ , "details" .= post

71+ ]

72+ in

73+ (subregion, fields ++ extraFields)

74+

75+

76+-- RENDERING

77+

78+data Renderer m = Renderer

13− , preHint :: String

79+ { normal :: String -> m ()

14− , postHint :: String

80+ , header :: String -> m ()

81+ , accent :: String -> m ()

15 }

82 }

16

83

17

84

18−simple :: String -> String -> Report

85+plain :: Renderer (Writer String)

19−simple pre post =

86+plain =

20− Report Nothing pre post

87+ Renderer tell tell tell

88+

89+

90+data Type = Error | Warning

91+

92+

93+ansi :: Type -> Renderer IO

94+ansi tipe =

95+ let

96+ put =

97+ hPutStr stderr

98+

99+ put' intensity color string =

100+ do hSetSGR stderr [SetColor Foreground intensity color]

101+ put string

102+ hSetSGR stderr [Reset]

103+

104+ accentColor =

105+ case tipe of

106+ Error -> Red

107+ Warning -> Yellow

108+ in

109+ Renderer

110+ put

111+ (put' Dull Cyan)

112+ (put' Dull accentColor)

21

113

22

114

23−toString :: String -> String -> R.Region -> Report -> String -> String

24−toString tag location region report source =

25− concat

26− [ messageBar tag location

27− , preHint report ++ "\n\n"

28− , grabRegion (highlight report) region source ++ "\n"

29− , postHint report ++ "\n\n\n"

30− ]

31

115

32

116

33-- REPORT HEADER

117-- REPORT HEADER

34

118

35−messageBar :: String -> String -> String

119+messageBar :: Renderer m -> String -> String -> m ()

36−messageBar tag location =

120+messageBar renderer tag location =

121+ let

37− let usedSpace = 4 + length tag + 1 + length location

122+ usedSpace = 4 + length tag + 1 + length location

38 in

123 in

124+ header renderer $

39 "-- " ++ tag ++ " "

125 "-- " ++ tag ++ " "

40 ++ replicate (max 1 (80 - usedSpace)) '-'

126 ++ replicate (max 1 (80 - usedSpace)) '-'

41 ++ " " ++ location ++ "\n\n"

127 ++ " " ++ location ++ "\n\n"

@@ -43,12 +129,20 @@ messageBar tag location =

43

129

44-- REGIONS

130-- REGIONS

45

131

132+grabRegion

133+ :: (Monad m)

134+ => Renderer m

46−grabRegion :: Maybe R.Region -> R.Region -> String -> String

135+ -> Maybe R.Region

136+ -> R.Region

137+ -> String

138+ -> m ()

47−grabRegion maybeSubRegion (R.Region start end) source =

139+grabRegion renderer maybeSubRegion region@(R.Region start end) source =

48 let

140 let

49 (R.Position startLine startColumn) = start

141 (R.Position startLine startColumn) = start

50 (R.Position endLine endColumn) = end

142 (R.Position endLine endColumn) = end

51

143

144+ (|>) = flip ($)

145+

52 relevantLines =

146 relevantLines =

53 lines source

147 lines source

54 |> drop (startLine - 1)

148 |> drop (startLine - 1)

@@ -56,23 +150,16 @@ grabRegion maybeSubRegion (R.Region start end) source =

56 in

150 in

57 case relevantLines of

151 case relevantLines of

58 [] ->

152 [] ->

59− error "something has gone badly wrong with reporting source locations"

153+ normal renderer ""

60

154

61− [theLine] ->

155+ [sourceLine] ->

62− let

156+ singleLineRegion renderer startLine sourceLine $

63− n = startLine

157+ case maybeSubRegion of

64− w = length (show (n + 1))

158+ Nothing ->

65− underline =

159+ (0, startColumn, endColumn, length sourceLine)

66− replicate (startColumn - 1) ' '

160+

67− ++ replicate (max 1 (endColumn - startColumn)) '^'

161+ Just (R.Region s e) ->

68− number =

162+ (startColumn, R.column s, R.column e, endColumn)

69− addLineNumber Nothing w

70− in

71− unlines

72− [ number (n-1) ""

73− , number n theLine

74− , number (n+1) underline

75− ]

76

163

77 firstLine : rest ->

164 firstLine : rest ->

78 let

165 let

@@ -87,28 +174,69 @@ grabRegion maybeSubRegion (R.Region start end) source =

87 filteredFirstLine : init rest ++ [filteredLastLine]

174 filteredFirstLine : init rest ++ [filteredLastLine]

88

175

89 lineNumbersWidth =

176 lineNumbersWidth =

90− length (show (endLine + 1))

177+ length (show endLine)

178+

179+ subregion =

180+ maybeSubRegion <|> Just region

91

181

92 numberedLines =

182 numberedLines =

93 zipWith

183 zipWith

94− (addLineNumber maybeSubRegion lineNumbersWidth)

184+ (addLineNumber renderer subregion lineNumbersWidth)

95− [startLine - 1 .. endLine + 1]

185+ [startLine .. endLine]

96− ("" : focusedRelevantLines ++ [""])

186+ focusedRelevantLines

97 in

187 in

98− unlines numberedLines

188+ mapM_ (\line -> line >> normal renderer "\n") numberedLines

99−

189+

100−

190+

101−addLineNumber :: Maybe R.Region -> Int -> Int -> String -> String

191+addLineNumber

192+ :: (Monad m)

193+ => Renderer m

194+ -> Maybe R.Region

195+ -> Int

196+ -> Int

197+ -> String

198+ -> m ()

102−addLineNumber maybeSubRegion width n line =

199+addLineNumber renderer maybeSubRegion width n line =

103 let

200 let

104 number =

201 number =

105− if n < 0 then " " else show n

202+ if n < 0 then " " else show n

203+

204+ lineNumber =

205+ replicate (width - length number) ' ' ++ number ++ "|"

106

206

107 spacer (R.Region start end) =

207 spacer (R.Region start end) =

108− if R.line start <= n && n <= R.line end

208+ if R.line start <= n && n <= R.line end

109− then ">"

209+ then accent renderer ">"

110− else " "

210+ else normal renderer " "

211+ in

212+ do normal renderer lineNumber

213+ maybe (normal renderer " ") spacer maybeSubRegion

214+ normal renderer line

215+

216+

217+singleLineRegion

218+ :: (Monad m)

219+ => Renderer m

220+ -> Int

221+ -> String

222+ -> (Int, Int, Int, Int)

223+ -> m ()

224+singleLineRegion renderer lineNum sourceLine (start, innerStart, innerEnd, end) =

225+ let

226+ width =

227+ length (show lineNum)

228+

229+ underline =

230+ replicate (innerStart + width + 1) ' '

231+ ++ replicate (max 1 (innerEnd - innerStart)) '^'

232+

233+ (|>) = flip ($)

234+

235+ trimmedSourceLine =

236+ sourceLine

237+ |> drop (start - 1)

238+ |> take (end - start + 1)

239+ |> (++) (replicate (start - 1) ' ')

111 in

240 in

112− replicate (width - length number) ' ' ++ number

241+ do addLineNumber renderer Nothing width lineNum trimmedSourceLine

113− ++ "|" ++ maybe " " spacer maybeSubRegion

242+ accent renderer $ "\n" ++ underline

114− ++ line

src/Reporting/Result.hs+41−15

@@ -1,17 +1,21 @@

1module Reporting.Result where

2

3−import qualified Control.Applicative as A

3+import Control.Applicative (Applicative, (<*>), (<|>), pure)

4import qualified Control.Monad as M

5import Control.Monad.Except (Except, runExcept)

6

7import qualified Reporting.Annotation as A

8import qualified Reporting.Region as R

9+import qualified Reporting.PrettyPrint as P

9

10

11

11-- TASK

12-- TASK

12

13

13data Result warning error result =

14data Result warning error result =

15+ Result

16+ (Maybe P.Dealiaser, [A.Located warning])

14− Result [A.Located warning] (RawResult [A.Located error] result)

17+ (RawResult [A.Located error] result)

18+

15

19

16data RawResult e a

20data RawResult e a

17 = Ok a

21 = Ok a

@@ -22,17 +26,17 @@ data RawResult e a

22

26

23ok :: a -> Result w e a

27ok :: a -> Result w e a

24ok value =

28ok value =

25− Result [] (Ok value)

29+ Result (Nothing, []) (Ok value)

26

30

27

31

28throw :: R.Region -> e -> Result w e a

32throw :: R.Region -> e -> Result w e a

29throw region err =

33throw region err =

30− Result [] (Err [A.A region err])

34+ Result (Nothing, []) (Err [A.A region err])

31

35

32

36

33throwMany :: [A.Located e] -> Result w e a

37throwMany :: [A.Located e] -> Result w e a

34throwMany errors =

38throwMany errors =

35− Result [] (Err errors)

39+ Result (Nothing, []) (Err errors)

36

40

37

41

38from :: (e -> e') -> Except [A.Located e] a -> Result w e' a

42from :: (e -> e') -> Except [A.Located e] a -> Result w e' a

@@ -58,12 +62,27 @@ mapError f (Result warnings rawResult) =

58

62

59warn :: R.Region -> w -> Result w e ()

63warn :: R.Region -> w -> Result w e ()

60warn region warning =

64warn region warning =

61− Result [A.A region warning] (Ok ())

65+ Result (Nothing, [A.A region warning]) (Ok ())

62

66

63

67

64addWarnings :: [A.Located w] -> Result w e a -> Result w e a

68addWarnings :: [A.Located w] -> Result w e a -> Result w e a

65−addWarnings newWarnings (Result warnings rawResult) =

69+addWarnings newWarnings (Result (dealiaser, warnings) rawResult) =

66− Result (newWarnings ++ warnings) rawResult

70+ Result (dealiaser, newWarnings ++ warnings) rawResult

71+

72+

73+addDealiaser :: P.Dealiaser -> Result w e a -> Result w e a

74+addDealiaser dealiaser (Result (_, warnings) rawResult) =

75+ Result (Just dealiaser, warnings) rawResult

76+

77+

78+destruct :: (e -> b) -> (a -> b) -> RawResult e a -> b

79+destruct errFunc okFunc rawResult =

80+ case rawResult of

81+ Ok answer ->

82+ okFunc answer

83+

84+ Err errors ->

85+ errFunc errors

67

86

68

87

69-- EXTRA FANCY HELPERS

88-- EXTRA FANCY HELPERS

@@ -78,12 +97,12 @@ instance M.Functor (Result w e) where

78 Result warnings (Err msgs)

97 Result warnings (Err msgs)

79

98

80

99

81−instance A.Applicative (Result w e) where

100+instance Applicative (Result w e) where

82 pure value =

101 pure value =

83 ok value

102 ok value

84

103

85− (<*>) (Result warnings resultFunc) (Result warnings' resultVal) =

104+ (<*>) (Result context resultFunc) (Result context' resultVal) =

86− Result (warnings ++ warnings') $

105+ Result (merge context context') $

87 case (resultFunc, resultVal) of

106 case (resultFunc, resultVal) of

88 (Ok func, Ok val) ->

107 (Ok func, Ok val) ->

89 Ok (func val)

108 Ok (func val)

@@ -102,12 +121,19 @@ instance M.Monad (Result w e) where

102 return value =

121 return value =

103 ok value

122 ok value

104

123

105− (>>=) (Result warnings rawResult) callback =

124+ (>>=) (Result context rawResult) callback =

106 case rawResult of

125 case rawResult of

107 Err msg ->

126 Err msg ->

108− Result warnings (Err msg)

127+ Result context (Err msg)

109

128

110 Ok value ->

129 Ok value ->

111− let (Result warnings' rawResult') = callback value

130+ let (Result context' rawResult') = callback value

112 in

131 in

113− Result (warnings ++ warnings') rawResult'

132+ Result (merge context context') rawResult'

133+

134+

135+merge :: (Maybe a, [b]) -> (Maybe a, [b]) -> (Maybe a, [b])

136+merge (dealiaser, warnings) (dealiaser', warnings') =

137+ ( dealiaser <|> dealiaser'

138+ , warnings ++ warnings'

139+ )

src/Reporting/Warning.hs+56−10

@@ -1,27 +1,73 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

1module Reporting.Warning where

3module Reporting.Warning where

2

4

3−import qualified AST.Module as Module

5+import Data.Aeson ((.=))

6+import qualified Data.Aeson as Json

7+import qualified Text.PrettyPrint as P

8+import Text.PrettyPrint ((<+>))

4

9

10+import qualified AST.Module as Module

11+import qualified AST.Type as Type

5import qualified Reporting.Annotation as A

12import qualified Reporting.Annotation as A

13+import qualified Reporting.PrettyPrint as P

14+import qualified Reporting.Report as Report

15+

6

16

17+-- ALL POSSIBLE WARNINGS

7

18

8data Warning

19data Warning

9 = UnusedImport Module.Name

20 = UnusedImport Module.Name

10− | MissingTypeAnnotation String

21+ | MissingTypeAnnotation String Type.Canonical

11

22

12

23

13-- TO STRING

24-- TO STRING

14

25

15−toString :: A.Located Warning -> String

26+toString :: P.Dealiaser -> String -> String -> A.Located Warning -> String

16−toString (A.A region warning) =

27+toString dealiaser location source (A.A region warning) =

17− case warning of

28+ Report.toString location region (toReport dealiaser warning) source

18− _ -> error "Warning.toString" region

19

29

20

30

21−-- TO JSON

31+print :: P.Dealiaser -> String -> String -> A.Located Warning -> IO ()

32+print dealiaser location source (A.A region warning) =

33+ Report.printWarning location region (toReport dealiaser warning) source

22

34

23−toJson :: A.Located Warning -> String

35+

24−toJson (A.A region warning) =

36+toReport :: P.Dealiaser -> Warning -> Report.Report

37+toReport dealiaser warning =

25 case warning of

38 case warning of

26− _ -> error "Warning.toJson" region

39+ UnusedImport moduleName ->

40+ Report.simple

41+ "unused import"

42+ ("Module `" ++ Module.nameToString moduleName ++ "` is unused.")

43+ ""

44+

45+ MissingTypeAnnotation name inferredType ->

46+ Report.simple

47+ "missing type annotation"

48+ ("Top-level value `" ++ name ++ "` does not have a type annotation.")

49+ ( "The type annotation you want looks something like this:\n\n"

50+ ++ P.render (P.nest 4 typeDoc)

51+ )

52+ where

53+ typeDoc =

54+ P.hang

55+ (P.text name <+> P.colon)

56+ 4

57+ (P.pretty dealiaser False inferredType)

58+

59+

60+-- TO JSON

27

61

62+toJson :: P.Dealiaser -> FilePath -> A.Located Warning -> Json.Value

63+toJson dealiaser filePath (A.A region warning) =

64+ let

65+ (maybeRegion, additionalFields) =

66+ Report.toJson [] (toReport dealiaser warning)

67+ in

68+ Json.object $

69+ [ "file" .= filePath

70+ , "region" .= maybe region id maybeRegion

71+ , "type" .= ("warning" :: String)

72+ ]

73+ ++ additionalFields

src/Reporting/Warning/Nitpick.hsdeleted−14

@@ -1,14 +0,0 @@

1−module Reporting.Warning.Nitpick where

2−

3−import qualified AST.Pattern as Pattern

4−import qualified AST.Literal as Literal

5−import qualified Data.Set as Set

6−import qualified AST.Variable as Var

7−

8−

9−data Warning

10− = Redundant Pattern.CanonicalPattern

11− -- The argument is the list of patterns that would have to

12− -- be added for the case expression to be exhaustive.

13− | Inexhaustive [CanonicalPat]

14−

src/Type/Constrain/Expression.hs+270−85

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

2module Type.Constrain.Expression where

3

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

5+import Control.Arrow (second)

5import qualified Control.Monad as Monad

6import qualified Control.Monad as Monad

6import qualified Data.List as List

7import qualified Data.List as List

7import qualified Data.Map as Map

8import qualified Data.Map as Map

@@ -27,9 +28,8 @@ constrain

27 -> Canonical.Expr

28 -> Canonical.Expr

28 -> Type

29 -> Type

29 -> IO TypeConstraint

30 -> IO TypeConstraint

30−constrain env (A.A region expression) tipe =

31+constrain env annotatedExpr@(A.A region expression) tipe =

31 let list t = Env.get env Env.types "List" <| t

32 let list t = Env.get env Env.types "List" <| t

32− (===) = CEqual Error.None region

33 (<?) = CInstance region

34 in

35 case expression of

@@ -57,7 +57,7 @@ constrain env (A.A region expression) tipe =

57 uniform = makeRec Lit.uniform unif

58 varying = makeRec Lit.varying (termN EmptyRecord1)

59 in

60− return (tipe === shaderTipe attribute uniform varying)

60+ return (CEqual Error.Shader region tipe (shaderTipe attribute uniform varying))

61

62 E.Var var ->

63 let name = V.toString var

@@ -68,23 +68,17 @@ constrain env (A.A region expression) tipe =

68 existsNumber $ \n ->

69 do lowCon <- constrain env lowExpr n

70 highCon <- constrain env highExpr n

71− return $ CAnd [lowCon, highCon, list n === tipe]

71+ return $ CAnd

72+ [ lowCon

73+ , highCon

74+ , CEqual Error.Range region (list n) tipe

75+ ]

72

76

73 E.ExplicitList exprs ->

77 E.ExplicitList exprs ->

74− exists $ \x ->

78+ constrainList env region exprs tipe

75− do constraints <- mapM (\e -> constrain env e x) exprs

76− return $ CAnd (list x === tipe : constraints)

77

79

78 E.Binop op leftExpr rightExpr ->

80 E.Binop op leftExpr rightExpr ->

79− exists $ \leftType ->

81+ constrainBinop env region op leftExpr rightExpr tipe

80− exists $ \rightType ->

81− do leftCon <- constrain env leftExpr leftType

82− rightCon <- constrain env rightExpr rightType

83− return $ CAnd

84− [ leftCon

85− , rightCon

86− , V.toString op <? (leftType ==> rightType ==> tipe)

87− ]

88

82

89 E.Lambda pattern body ->

83 E.Lambda pattern body ->

90 exists $ \argType ->

84 exists $ \argType ->

@@ -96,16 +90,16 @@ constrain env (A.A region expression) tipe =

96 (CLet [monoscheme (Fragment.typeEnv fragment)]

90 (CLet [monoscheme (Fragment.typeEnv fragment)]

97 (Fragment.typeConstraint fragment /\ bodyCon)

91 (Fragment.typeConstraint fragment /\ bodyCon)

98 )

92 )

99− return $ con /\ tipe === (argType ==> resType)

93+ return $ con /\ CEqual Error.Lambda region tipe (argType ==> resType)

100

94

101− E.App func arg ->

95+ E.App _ _ ->

102− exists $ \t ->

96+ let

103− do funcCon <- constrain env func (t ==> tipe)

97+ (f:args) = E.collectApps annotatedExpr

104− argCon <- constrain env arg t

98+ in

105− return (funcCon /\ argCon)

99+ constrainApp env region f args tipe

106

100

107− E.MultiIf branches ->

101+ E.MultiIf branches finally ->

108− constrainIf env region branches tipe

102+ constrainIf env region branches finally tipe

109

103

110 E.Case expr branches ->

104 E.Case expr branches ->

111 constrainCase env region expr branches tipe

105 constrainCase env region expr branches tipe

@@ -135,7 +129,11 @@ constrain env (A.A region expression) tipe =

135 recordCon <- constrain env expr recordType

129 recordCon <- constrain env expr recordType

136 let newRecordType =

130 let newRecordType =

137 record (Map.singleton label [valueType]) recordType

131 record (Map.singleton label [valueType]) recordType

132+ return $ CAnd

133+ [ valueCon

134+ , recordCon

138− return (CAnd [valueCon, recordCon, tipe === newRecordType])

135+ , CEqual Error.Record region tipe newRecordType

136+ ]

139

137

140 E.Modify expr fields ->

138 E.Modify expr fields ->

141 exists $ \t ->

139 exists $ \t ->

@@ -145,7 +143,7 @@ constrain env (A.A region expression) tipe =

145

143

146 newVars <- Monad.forM fields $ \_ -> variable Flexible

144 newVars <- Monad.forM fields $ \_ -> variable Flexible

147 let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

145 let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

148− let cNew = tipe === record newFields t

146+ let cNew = CEqual Error.Record region tipe (record newFields t)

149

147

150 cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN newVars)

148 cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN newVars)

151

149

@@ -160,7 +158,7 @@ constrain env (A.A region expression) tipe =

160 (map varN vars)

158 (map varN vars)

161 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

159 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

162 let recordType = record fields' (termN EmptyRecord1)

160 let recordType = record fields' (termN EmptyRecord1)

163− return (ex vars (CAnd (fieldCons ++ [tipe === recordType])))

161+ return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region tipe recordType])))

164

162

165 E.Let defs body ->

163 E.Let defs body ->

166 do bodyCon <- constrain env body tipe

164 do bodyCon <- constrain env body tipe

@@ -171,7 +169,8 @@ constrain env (A.A region expression) tipe =

171 (Info [] [] [] Map.empty CTrue CTrue)

169 (Info [] [] [] Map.empty CTrue CTrue)

172 (concatMap expandPattern defs)

170 (concatMap expandPattern defs)

173

171

172+ let letScheme =

174− let letScheme = [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]

173+ [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]

175

174

176 return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))

175 return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))

177

176

@@ -186,6 +185,151 @@ constrain env (A.A region expression) tipe =

186 E.Task _ expr _ ->

185 E.Task _ expr _ ->

187 constrain env expr tipe

186 constrain env expr tipe

188

187

188+ E.Crash _ ->

189+ return CTrue

190+

191+

192+-- CONSTRAIN APP

193+

194+constrainApp

195+ :: Env.Environment

196+ -> R.Region

197+ -> Canonical.Expr

198+ -> [Canonical.Expr]

199+ -> Type

200+ -> IO TypeConstraint

201+constrainApp env region f args tipe =

202+ do funcVar <- variable Flexible

203+ funcCon <- constrain env f (varN funcVar)

204+

205+ (vars, argCons, numberOfArgsCons, argMatchCons, _, returnVar) <-

206+ argConstraints env maybeName region (length args) funcVar 1 args

207+

208+ let returnCon =

209+ CEqual (Error.Function maybeName) region (varN returnVar) tipe

210+

211+ return $ ex (funcVar : vars) $

212+ CAnd (funcCon : argCons ++ numberOfArgsCons ++ argMatchCons ++ [returnCon])

213+ where

214+ maybeName =

215+ case f of

216+ A.A _ (E.Var canonicalName) ->

217+ Just canonicalName

218+

219+ _ ->

220+ Nothing

221+

222+

223+argConstraints

224+ :: Env.Environment

225+ -> Maybe V.Canonical

226+ -> R.Region

227+ -> Int

228+ -> Variable

229+ -> Int

230+ -> [Canonical.Expr]

231+ -> IO ([Variable], [TypeConstraint], [TypeConstraint], [TypeConstraint], Maybe R.Region, Variable)

232+argConstraints env name region totalArgs overallVar index args =

233+ case args of

234+ [] ->

235+ return ([], [], [], [], Nothing, overallVar)

236+

237+ expr@(A.A subregion _) : rest ->

238+ do argVar <- variable Flexible

239+ argCon <- constrain env expr (varN argVar)

240+ argIndexVar <- variable Flexible

241+ localReturnVar <- variable Flexible

242+

243+ (vars, argConRest, numberOfArgsRest, argMatchRest, restRegion, returnVar) <-

244+ argConstraints env name region totalArgs localReturnVar (index + 1) rest

245+

246+ let arityRegion =

247+ maybe subregion (R.merge subregion) restRegion

248+

249+ let numberOfArgsCon =

250+ CEqual

251+ (Error.FunctionArity name (index - 1) totalArgs arityRegion)

252+ region

253+ (varN argIndexVar ==> varN localReturnVar)

254+ (varN overallVar)

255+

256+ let argMatchCon =

257+ CEqual

258+ (Error.UnexpectedArg name index subregion)

259+ region

260+ (varN argIndexVar)

261+ (varN argVar)

262+

263+ return

264+ ( argVar : argIndexVar : localReturnVar : vars

265+ , argCon : argConRest

266+ , numberOfArgsCon : numberOfArgsRest

267+ , argMatchCon : argMatchRest

268+ , Just arityRegion

269+ , returnVar

270+ )

271+

272+

273+

274+

275+-- CONSTRAIN BINOP

276+

277+constrainBinop

278+ :: Env.Environment

279+ -> R.Region

280+ -> V.Canonical

281+ -> Canonical.Expr

282+ -> Canonical.Expr

283+ -> Type

284+ -> IO TypeConstraint

285+constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightRegion _) tipe =

286+ do leftVar <- variable Flexible

287+ rightVar <- variable Flexible

288+

289+ leftCon <- constrain env leftExpr (varN leftVar)

290+ rightCon <- constrain env rightExpr (varN rightVar)

291+

292+ leftVar' <- variable Flexible

293+ rightVar' <- variable Flexible

294+ answerVar <- variable Flexible

295+

296+ let opType = varN leftVar' ==> varN rightVar' ==> varN answerVar

297+

298+ return $

299+ ex [leftVar,rightVar,leftVar',rightVar',answerVar] $ CAnd $

300+ [ leftCon

301+ , rightCon

302+ , CInstance region (V.toString op) opType

303+ , CEqual (Error.BinopLeft op leftRegion) region (varN leftVar') (varN leftVar)

304+ , CEqual (Error.BinopRight op rightRegion) region (varN rightVar') (varN rightVar)

305+ , CEqual (Error.Binop op) region tipe (varN answerVar)

306+ ]

307+

308+

309+-- CONSTRAIN LISTS

310+

311+constrainList

312+ :: Env.Environment

313+ -> R.Region

314+ -> [Canonical.Expr]

315+ -> Type

316+ -> IO TypeConstraint

317+constrainList env region exprs tipe =

318+ do (exprInfo, exprCons) <-

319+ unzip <$> mapM elementConstraint exprs

320+

321+ (vars, cons) <- pairCons region Error.ListElement varToCon exprInfo

322+

323+ return $ ex vars (CAnd (exprCons ++ cons))

324+ where

325+ elementConstraint expr@(A.A region' _) =

326+ do var <- variable Flexible

327+ con <- constrain env expr (varN var)

328+ return ( (var, region'), con )

329+

330+ varToCon var =

331+ CEqual Error.List region tipe (Env.get env Env.types "List" <| varN var)

332+

189

333

190-- CONSTRAIN IF EXPRESSIONS

334-- CONSTRAIN IF EXPRESSIONS

191

335

@@ -193,51 +337,55 @@ constrainIf

193 :: Env.Environment

337 :: Env.Environment

194 -> R.Region

338 -> R.Region

195 -> [(Canonical.Expr, Canonical.Expr)]

339 -> [(Canonical.Expr, Canonical.Expr)]

340+ -> Canonical.Expr

196 -> Type

341 -> Type

197 -> IO TypeConstraint

342 -> IO TypeConstraint

198−constrainIf env region branches tipe =

343+constrainIf env region branches finally tipe =

199− do (branchInfo, branchExprCons) <-

344+ do let (conditions, branchExprs) =

200− unzip <$> mapM constrainBranch branches

345+ second (++ [finally]) (unzip branches)

201

346

202− return $

347+ (condVars, condCons) <-

203− ex (map fst branchInfo)

348+ unzip <$> mapM constrainCondition conditions

349+

350+ (branchInfo, branchExprCons) <-

351+ unzip <$> mapM constrainBranch branchExprs

352+

353+ (vars,cons) <- branchCons branchInfo

354+

204− (CAnd (branchExprCons ++ branchCons branchInfo))

355+ return $ ex (condVars ++ vars) (CAnd (condCons ++ branchExprCons ++ cons))

205 where

356 where

357+ bool =

206− bool = Env.get env Env.types "Bool"

358+ Env.get env Env.types "Bool"

359+

360+ constrainCondition condition@(A.A condRegion _) =

361+ do condVar <- variable Flexible

362+ condCon <- constrain env condition (varN condVar)

363+ let boolCon = CEqual Error.IfCondition condRegion (varN condVar) bool

364+ return (condVar, CAnd [ condCon, boolCon ])

207

365

208− constrainBranch (cond, expr@(A.A branchRegion _)) =

366+ constrainBranch expr@(A.A branchRegion _) =

209 do branchVar <- variable Flexible

367 do branchVar <- variable Flexible

210− condCon <- constrain env cond bool

211 exprCon <- constrain env expr (varN branchVar)

368 exprCon <- constrain env expr (varN branchVar)

212 return

369 return

213 ( (branchVar, branchRegion)

370 ( (branchVar, branchRegion)

214− , condCon /\ exprCon

371+ , exprCon

215 )

372 )

216

373

217 branchCons branchInfo =

374 branchCons branchInfo =

218 case branchInfo of

375 case branchInfo of

219 [(thenVar, _), (elseVar, _)] ->

376 [(thenVar, _), (elseVar, _)] ->

377+ return

378+ ( [thenVar,elseVar]

220− [ CEqual Error.IfBranches region (varN thenVar) (varN elseVar)

379+ , [ CEqual Error.IfBranches region (varN thenVar) (varN elseVar)

221− , CEqual Error.If region tipe (varN thenVar)

380+ , varToCon thenVar

222− ]

381+ ]

382+ )

223

383

224 _ ->

384 _ ->

225− buildBranchCons 2 branchInfo

385+ pairCons region Error.MultiIfBranch varToCon branchInfo

226−

227− buildBranchCons n branchInfo =

228− case branchInfo of

229− [] ->

230− []

231

386

232− (var,_) : [] ->

387+ varToCon var =

233− [ CEqual Error.If region tipe (varN var) ]

388+ CEqual Error.If region (varN var) tipe

234−

235− (var,_) : (var',region') : rest ->

236− let

237− hint = Error.MultiIfBranch n region'

238− con = CEqual hint region (varN var) (varN var')

239− in

240− con : buildBranchCons (n+1) ((var', region') : rest)

241

389

242

390

243-- CONSTRAIN CASE EXPRESSIONS

391-- CONSTRAIN CASE EXPRESSIONS

@@ -251,15 +399,14 @@ constrainCase

251 -> IO TypeConstraint

399 -> IO TypeConstraint

252constrainCase env region expr branches tipe =

400constrainCase env region expr branches tipe =

253 do exprVar <- variable Flexible

401 do exprVar <- variable Flexible

254−

255 exprCon <- constrain env expr (varN exprVar)

402 exprCon <- constrain env expr (varN exprVar)

256

403

257 (branchInfo, branchExprCons) <-

404 (branchInfo, branchExprCons) <-

258 unzip <$> mapM (branch (varN exprVar)) branches

405 unzip <$> mapM (branch (varN exprVar)) branches

259

406

260− return $

407+ (vars, cons) <- pairCons region Error.CaseBranch varToCon branchInfo

261− ex (exprVar : map fst branchInfo)

408+

262− (CAnd (exprCon : branchExprCons ++ branchCons 2 branchInfo))

409+ return $ ex (exprVar : vars) (CAnd (exprCon : branchExprCons ++ cons))

263 where

410 where

264 branch patternType (pattern, branchExpr@(A.A branchRegion _)) =

411 branch patternType (pattern, branchExpr@(A.A branchRegion _)) =

265 do branchVar <- variable Flexible

412 do branchVar <- variable Flexible

@@ -270,20 +417,52 @@ constrainCase env region expr branches tipe =

270 , CLet [Fragment.toScheme fragment] branchCon

417 , CLet [Fragment.toScheme fragment] branchCon

271 )

418 )

272

419

273− branchCons n branchInfo =

420+ varToCon var =

274− case branchInfo of

421+ CEqual Error.Case region tipe (varN var)

275− [] ->

276− []

277

422

278− (var,_) : [] ->

279− [ CEqual Error.Case region tipe (varN var) ]

280

423

281− (var,_) : (var',region') : rest ->

424+-- COLLECT PAIRS

425+

426+data Pair = Pair

427+ { _index :: Int

428+ , _var1 :: Variable

429+ , _var2 :: Variable

430+ , _region :: R.Region

431+ }

432+

433+

434+pairCons

435+ :: R.Region

436+ -> (Int -> R.Region -> Error.Hint)

437+ -> (Variable -> TypeConstraint)

438+ -> [(Variable, R.Region)]

439+ -> IO ([Variable], [TypeConstraint])

440+pairCons region pairHint varToCon items =

282− let

441+ let

283− hint = Error.CaseBranch n region'

442+ pairToCon (Pair index var1 var2 subregion) =

284− con = CEqual hint region (varN var) (varN var')

443+ CEqual (pairHint index subregion) region (varN var1) (varN var2)

285− in

444+ in

286− con : branchCons (n+1) ((var', region') : rest)

445+ case collectPairs 2 items of

446+ Nothing ->

447+ do var <- variable Flexible

448+ return ([var], [varToCon var])

449+

450+ Just (pairs, var) ->

451+ return (map fst items, map pairToCon pairs ++ [varToCon var])

452+

453+

454+collectPairs :: Int -> [(Variable, R.Region)] -> Maybe ([Pair], Variable)

455+collectPairs index items =

456+ case items of

457+ [] ->

458+ Nothing

459+

460+ (var,_) : [] ->

461+ Just ([], var)

462+

463+ (var,_) : rest@((var',region) : _) ->

464+ do (pairs, summaryVar) <- collectPairs (index+1) rest

465+ return (Pair index var var' region : pairs, summaryVar)

287

466

288

467

289-- EXPAND PATTERNS

468-- EXPAND PATTERNS

@@ -324,22 +503,22 @@ data Info = Info

324 { iSchemes :: [TypeScheme]

503 { iSchemes :: [TypeScheme]

325 , iRigid :: [Variable]

504 , iRigid :: [Variable]

326 , iFlex :: [Variable]

505 , iFlex :: [Variable]

327− , iHeaders :: Map.Map String Type

506+ , iHeaders :: Map.Map String (A.Located Type)

328 , iC2 :: TypeConstraint

507 , iC2 :: TypeConstraint

329 , iC1 :: TypeConstraint

508 , iC1 :: TypeConstraint

330 }

509 }

331

510

332

511

333constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info

512constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info

334−constrainDef env info (Canonical.Definition (A.A _ pattern) expr maybeTipe) =

513+constrainDef env info (Canonical.Definition (A.A patternRegion pattern) expr maybeTipe) =

335 let qs = [] -- should come from the def, but I'm not sure what would live there...

514 let qs = [] -- should come from the def, but I'm not sure what would live there...

336 in

515 in

337 case (pattern, maybeTipe) of

516 case (pattern, maybeTipe) of

338− (P.Var name, Just tipe) ->

517+ (P.Var name, Just (A.A typeRegion tipe)) ->

339− constrainAnnotatedDef env info qs name expr tipe

518+ constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe

340

519

341 (P.Var name, Nothing) ->

520 (P.Var name, Nothing) ->

342− constrainUnannotatedDef env info qs name expr

521+ constrainUnannotatedDef env info qs patternRegion name expr

343

522

344 _ -> error ("problem in constrainDef with " ++ show pattern)

523 _ -> error ("problem in constrainDef with " ++ show pattern)

345

524

@@ -348,11 +527,13 @@ constrainAnnotatedDef

348 :: Env.Environment

527 :: Env.Environment

349 -> Info

528 -> Info

350 -> [String]

529 -> [String]

530+ -> R.Region

531+ -> R.Region

351 -> String

532 -> String

352 -> Canonical.Expr

533 -> Canonical.Expr

353 -> ST.Canonical

534 -> ST.Canonical

354 -> IO Info

535 -> IO Info

355−constrainAnnotatedDef env info qs name expr tipe =

536+constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe =

356 do -- Some mistake may be happening here. Currently, qs is always [].

537 do -- Some mistake may be happening here. Currently, qs is always [].

357 rigidVars <- Monad.forM qs (\_ -> variable Rigid)

538 rigidVars <- Monad.forM qs (\_ -> variable Rigid)

358

539

@@ -369,14 +550,17 @@ constrainAnnotatedDef env info qs name expr tipe =

369 { rigidQuantifiers = []

550 { rigidQuantifiers = []

370 , flexibleQuantifiers = flexiVars ++ vars

551 , flexibleQuantifiers = flexiVars ++ vars

371 , constraint = CTrue

552 , constraint = CTrue

372− , header = Map.singleton name typ

553+ , header = Map.singleton name (A.A patternRegion typ)

373 }

554 }

374

555

556+ var <- variable Flexible

375− c <- constrain env' expr typ

557+ defCon <- constrain env' expr (varN var)

558+ let annCon =

559+ CEqual (Error.BadTypeAnnotation name) typeRegion typ (varN var)

376

560

377 return $ info

561 return $ info

378 { iSchemes = scheme : iSchemes info

562 { iSchemes = scheme : iSchemes info

379− , iC1 = fl rigidVars c /\ iC1 info

563+ , iC1 = iC1 info /\ ex [var] (defCon /\ fl rigidVars annCon)

380 }

564 }

381

565

382

566

@@ -384,10 +568,11 @@ constrainUnannotatedDef

384 :: Env.Environment

568 :: Env.Environment

385 -> Info

569 -> Info

386 -> [String]

570 -> [String]

571+ -> R.Region

387 -> String

572 -> String

388 -> Canonical.Expr

573 -> Canonical.Expr

389 -> IO Info

574 -> IO Info

390−constrainUnannotatedDef env info qs name expr =

575+constrainUnannotatedDef env info qs patternRegion name expr =

391 do -- Some mistake may be happening here. Currently, qs is always [].

576 do -- Some mistake may be happening here. Currently, qs is always [].

392 rigidVars <- Monad.forM qs (\_ -> variable Rigid)

577 rigidVars <- Monad.forM qs (\_ -> variable Rigid)

393

578

@@ -399,11 +584,11 @@ constrainUnannotatedDef env info qs name expr =

399

584

400 let env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

585 let env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

401

586

402− c <- constrain env' expr tipe

587+ con <- constrain env' expr tipe

403

588

404 return $ info

589 return $ info

405 { iRigid = rigidVars ++ iRigid info

590 { iRigid = rigidVars ++ iRigid info

406 , iFlex = v : iFlex info

591 , iFlex = v : iFlex info

407− , iHeaders = Map.insert name tipe (iHeaders info)

592+ , iHeaders = Map.insert name (A.A patternRegion tipe) (iHeaders info)

408− , iC2 = c /\ iC2 info

593+ , iC2 = con /\ iC2 info

409 }

594 }

src/Type/Constrain/Literal.hs+9−1

@@ -15,7 +15,7 @@ constrain

15 -> IO T.TypeConstraint

16constrain env region literal tipe =

17 do tipe' <- litType

18− return (T.CEqual Error.None region tipe tipe')

18+ return (T.CEqual (Error.Literal name) region tipe tipe')

19 where

20 prim name =

21 return (Env.get env Env.types name)

@@ -27,3 +27,11 @@ constrain env region literal tipe =

27 L.Chr _ -> prim "Char"

28 L.Str _ -> prim "String"

29 L.Boolean _ -> prim "Bool"

30+

31+ name =

32+ case literal of

33+ L.IntNum _ -> "number"

34+ L.FloatNum _ -> "float"

35+ L.Chr _ -> "character"

36+ L.Str _ -> "string"

37+ L.Boolean _ -> "boolean"

src/Type/Constrain/Pattern.hs+34−13

@@ -22,7 +22,12 @@ constrain

22 -> Type

23 -> IO Fragment

24constrain env (A.A region pattern) tipe =

25− let (===) = CEqual Error.None region

25+ let

26+ equal patternError leftType rightType =

27+ CEqual (Error.Pattern patternError) region leftType rightType

28+

29+ rvar v =

30+ A.A region (varN v)

26 in

31 in

27 case pattern of

32 case pattern of

28 P.Anything ->

33 P.Anything ->

@@ -35,37 +40,53 @@ constrain env (A.A region pattern) tipe =

35 P.Var name ->

40 P.Var name ->

36 do v <- variable Flexible

41 do v <- variable Flexible

37 return $ Fragment

42 return $ Fragment

38− { typeEnv = Map.singleton name (varN v)

43+ { typeEnv = Map.singleton name (rvar v)

39 , vars = [v]

44 , vars = [v]

40− , typeConstraint = varN v === tipe

45+ , typeConstraint =

46+ equal (Error.PVar name) (varN v) tipe

41 }

47 }

42

48

43 P.Alias name p ->

49 P.Alias name p ->

44 do v <- variable Flexible

50 do v <- variable Flexible

45 fragment <- constrain env p tipe

51 fragment <- constrain env p tipe

46 return $ fragment

52 return $ fragment

47− { typeEnv = Map.insert name (varN v) (typeEnv fragment)

53+ { typeEnv = Map.insert name (rvar v) (typeEnv fragment)

48 , vars = v : vars fragment

54 , vars = v : vars fragment

55+ , typeConstraint =

56+ equal (Error.PAlias name) (varN v) tipe

49− , typeConstraint = varN v === tipe /\ typeConstraint fragment

57+ /\ typeConstraint fragment

50 }

58 }

51

59

52 P.Data name patterns ->

60 P.Data name patterns ->

61+ do let stringName = V.toString name

62+

53− do (_kind, cvars, args, result) <-

63+ (_kind, cvars, args, result) <-

54− Env.freshDataScheme env (V.toString name)

64+ Env.freshDataScheme env stringName

55

65

56 fragList <- Monad.zipWithM (constrain env) patterns args

66 fragList <- Monad.zipWithM (constrain env) patterns args

57 let fragment = joinFragments fragList

67 let fragment = joinFragments fragList

58 return $ fragment

68 return $ fragment

59− { typeConstraint = typeConstraint fragment /\ tipe === result

69+ { vars = cvars ++ vars fragment

60− , vars = cvars ++ vars fragment

70+ , typeConstraint =

71+ typeConstraint fragment

72+ /\ equal (Error.PData stringName) tipe result

61 }

73 }

62

74

63 P.Record fields ->

75 P.Record fields ->

76+ do pairs <-

64− do pairs <- mapM (\name -> (,) name <$> variable Flexible) fields

77+ mapM (\name -> (,) name <$> variable Flexible) fields

78+

79+ let tenv =

65− let tenv = Map.fromList (map (second varN) pairs)

80+ Map.fromList (map (second rvar) pairs)

66− c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

81+

82+ let unannotatedTenv =

83+ Map.map (\v -> [A.drop v]) tenv

84+

85+ con <- exists $ \t ->

86+ return (equal Error.PRecord tipe (record unannotatedTenv t))

87+

67 return $ Fragment

88 return $ Fragment

68 { typeEnv = tenv

89 { typeEnv = tenv

69 , vars = map snd pairs

90 , vars = map snd pairs

70− , typeConstraint = c

91+ , typeConstraint = con

71 }

92 }

src/Type/Environment.hs+3−3

@@ -117,7 +117,7 @@ get :: Environment -> (Environment -> Map.Map String a) -> String -> a

117get env subDict key =

118 Map.findWithDefault (error msg) key (subDict env)

119 where

120− msg = "Could not find type constructor '" ++ key ++ "' while checking types."

120+ msg = "Could not find type constructor `" ++ key ++ "` while checking types."

121

122

123freshDataScheme

@@ -210,8 +210,8 @@ instantiatorHelp env aliasVars sourceType =

210 Just t -> return t

211 Nothing ->

212 error $

213− "Could not find type constructor '" ++

213+ "Could not find type constructor `" ++

214− V.toString name ++ "' while checking types."

214+ V.toString name ++ "` while checking types."

215

216 T.App t ts ->

217 do t' <- go t

src/Type/ExtraChecks.hsdeleted−78

@@ -1,78 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−

3−{-| This module contains checks to be run *after* type inference has completed

4−successfully. At that point we still need to ensure that `main` has an

5−acceptable type.

6−-}

7−module Type.ExtraChecks (mainType) where

8−

9−import Prelude hiding (maybe)

10−import Control.Monad.Except (ExceptT, throwError)

11−import qualified Data.Map as Map

12−

13−import qualified AST.Type as ST

14−import qualified AST.Variable as Var

15−

16−

17−-- MAIN TYPE

18−

19−mainType

20− :: (Monad m)

21− => Map.Map String ST.Canonical

22− -> ExceptT ST.Canonical m ()

23−mainType env =

24− case Map.lookup "main" env of

25− Nothing ->

26− return ()

27−

28− Just typeOfMain ->

29− let tipe = ST.deepDealias typeOfMain

30− in

31− if tipe `elem` validMainTypes

32− then return ()

33− else throwError typeOfMain

34−

35−

36−validMainTypes :: [ST.Canonical]

37−validMainTypes =

38− [ element

39− , html

40− , signal element

41− , signal html

42− ]

43− where

44− fromModule :: [String] -> String -> ST.Canonical

45− fromModule home name =

46− ST.Type (Var.fromModule home name)

47−

48− html =

49− fromModule ["VirtualDom"] "Node"

50−

51− signal tipe =

52− ST.App (fromModule ["Signal"] "Signal") [ tipe ]

53−

54− element =

55− let builtin name =

56− ST.Type (Var.builtin name)

57−

58− maybe tipe =

59− ST.App (fromModule ["Maybe"] "Maybe") [ tipe ]

60− in

61− ST.Record

62− [ ("element", fromModule ["Graphics","Element"] "ElementPrim")

63− , ("props",

64− ST.Record

65− [ ("click" , builtin "_Tuple0")

66− , ("color" , maybe (fromModule ["Color"] "Color"))

67− , ("height" , builtin "Int")

68− , ("hover" , builtin "_Tuple0")

69− , ("href" , builtin "String")

70− , ("id" , builtin "Int")

71− , ("opacity", builtin "Float")

72− , ("tag" , builtin "String")

73− , ("width" , builtin "Int")

74− ]

75− Nothing

76− )

77− ]

78− Nothing

src/Type/Fragment.hs+2−1

@@ -4,11 +4,12 @@ module Type.Fragment where

4import qualified Data.List as List

5import qualified Data.Map as Map

6

7+import Reporting.Annotation as A

7import Type.Type

8import Type.Type

8

9

10

10data Fragment = Fragment

11data Fragment = Fragment

11− { typeEnv :: Map.Map String Type

12+ { typeEnv :: Map.Map String (A.Located Type)

12 , vars :: [Variable]

13 , vars :: [Variable]

13 , typeConstraint :: TypeConstraint

14 , typeConstraint :: TypeConstraint

14 }

15 }

src/Type/Inference.hs+7−15

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

1module Type.Inference where

2

3import Control.Arrow (first, second)

4−import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError, withExceptT)

4+import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)

5import qualified Data.Map as Map

6import qualified Data.Traversable as Traverse

7

@@ -12,7 +12,6 @@ import qualified Reporting.Annotation as A

12import qualified Reporting.Error.Type as Error

13import qualified Type.Constrain.Expression as TcExpr

14import qualified Type.Environment as Env

15−import qualified Type.ExtraChecks as Check

16import qualified Type.Solve as Solve

15import qualified Type.Solve as Solve

17import qualified Type.State as TS

16import qualified Type.State as TS

18import qualified Type.Type as T

17import qualified Type.Type as T

@@ -24,7 +23,7 @@ import System.IO.Unsafe

24

23

25infer

24infer

26 :: Interfaces

25 :: Interfaces

27− -> CanonicalModule

26+ -> Module.CanonicalModule

28 -> Except [A.Located Error.Error] (Map.Map String Type.Canonical)

27 -> Except [A.Located Error.Error] (Map.Map String Type.Canonical)

29infer interfaces modul =

28infer interfaces modul =

30 either throwError return $ unsafePerformIO $ runExceptT $

29 either throwError return $ unsafePerformIO $ runExceptT $

@@ -34,21 +33,14 @@ infer interfaces modul =

34 state <- Solve.solve constraint

33 state <- Solve.solve constraint

35

34

36 let header' = Map.delete "::" header

35 let header' = Map.delete "::" header

37− let types = Map.difference (TS.sSavedEnv state) header'

36+ let types = Map.map A.drop (Map.difference (TS.sSavedEnv state) header')

38

37

39− srcTypes <-

40− liftIO (Traverse.traverse T.toSrcType types)

38+ liftIO (Traverse.traverse T.toSrcType types)

41−

42− withExceptT

43− (\tipe -> [A.A (error "TODO:infer") (Error.BadMain tipe)])

44− (Check.mainType srcTypes)

45−

46− return srcTypes

47

39

48

40

49genConstraints

41genConstraints

50 :: Interfaces

42 :: Interfaces

51− -> CanonicalModule

43+ -> Module.CanonicalModule

52 -> IO (Env.TypeDict, T.TypeConstraint)

44 -> IO (Env.TypeDict, T.TypeConstraint)

53genConstraints interfaces modul =

45genConstraints interfaces modul =

54 do env <-

46 do env <-

@@ -65,7 +57,7 @@ genConstraints interfaces modul =

65 let allTypes = concat (ctors : importedVars)

57 let allTypes = concat (ctors : importedVars)

66 let vars = concatMap (fst . snd) allTypes

58 let vars = concatMap (fst . snd) allTypes

67 let header = Map.map snd (Map.fromList allTypes)

59 let header = Map.map snd (Map.fromList allTypes)

68− let environ = T.CLet [ T.Scheme vars [] T.CTrue header ]

60+ let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]

69

61

70 fvar <- T.variable T.Flexible

62 fvar <- T.variable T.Flexible

71

63

@@ -85,7 +77,7 @@ canonicalizeValues env (moduleName, iface) =

85 return (Module.nameToString moduleName ++ "." ++ name, tipe')

77 return (Module.nameToString moduleName ++ "." ++ name, tipe')

86

78

87

79

88−canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]

80+canonicalizeAdts :: Interfaces -> Module.CanonicalModule -> [CanonicalAdt]

89canonicalizeAdts interfaces modul =

81canonicalizeAdts interfaces modul =

90 localAdts ++ importedAdts

82 localAdts ++ importedAdts

91 where

83 where

src/Type/Solve.hs+55−39

@@ -1,14 +1,16 @@

1module Type.Solve (solve) where

2

3−import Control.Applicative ((<$>), (<*>))

3+import Control.Applicative ((<$>), (<*>), (<|>))

4import Control.Monad

5import Control.Monad.State (StateT, execStateT, liftIO)

6import Control.Monad.Except (ExceptT, throwError)

7+import qualified Data.Foldable as F

7import qualified Data.List as List

8import qualified Data.List as List

8import qualified Data.Map as Map

9import qualified Data.Map as Map

9−import qualified Data.Traversable as Traversable

10+import qualified Data.Traversable as T

10import qualified Data.UnionFind.IO as UF

11import qualified Data.UnionFind.IO as UF

11

12

13+import qualified AST.Type as Type

12import qualified Reporting.Annotation as A

14import qualified Reporting.Annotation as A

13import qualified Reporting.Error.Type as Error

15import qualified Reporting.Error.Type as Error

14import qualified Type.State as TS

16import qualified Type.State as TS

@@ -45,7 +47,7 @@ generalize youngPool =

45 if isRedundant then return var else TS.register var

47 if isRedundant then return var else TS.register var

46

48

47 let rankDict' = Map.delete youngRank rankDict

49 let rankDict' = Map.delete youngRank rankDict

48− Traversable.traverse (mapM registerIfNotRedundant) rankDict'

50+ T.traverse (mapM registerIfNotRedundant) rankDict'

49

51

50 -- For variables with rank youngRank

52 -- For variables with rank youngRank

51 -- If rank < youngRank: register in oldPool

53 -- If rank < youngRank: register in oldPool

@@ -159,23 +161,30 @@ actuallySolve constraint =

159 do env <- TS.getEnv

161 do env <- TS.getEnv

160 freshCopy <-

162 freshCopy <-

161 case Map.lookup name env of

163 case Map.lookup name env of

162− Just tipe ->

164+ Just (A.A _ tipe) ->

163 TS.makeInstance tipe

165 TS.makeInstance tipe

166+

164 Nothing ->

167 Nothing ->

165 if List.isPrefixOf "Native." name

168 if List.isPrefixOf "Native." name

166 then liftIO (variable Flexible)

169 then liftIO (variable Flexible)

167− else error ("Could not find '" ++ name ++ "' when solving type constraints.")

170+ else error ("Could not find `" ++ name ++ "` when solving type constraints.")

168

171

169 t <- TS.flatten term

172 t <- TS.flatten term

170− unify Error.None region freshCopy t

173+ unify (Error.Instance name) region freshCopy t

171

174

172

175

176+solveScheme

177+ :: TypeScheme

173−solveScheme :: TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)

178+ -> StateT TS.SolverState IO (Map.Map String (A.Located Variable))

174solveScheme scheme =

179solveScheme scheme =

180+ let

181+ flatten (A.A region term) =

182+ A.A region <$> TS.flatten term

183+ in

175 case scheme of

184 case scheme of

176 Scheme [] [] constraint header ->

185 Scheme [] [] constraint header ->

177 do actuallySolve constraint

186 do actuallySolve constraint

178− Traversable.traverse TS.flatten header

187+ T.traverse flatten header

179

188

180 Scheme rigidQuantifiers flexibleQuantifiers constraint header ->

189 Scheme rigidQuantifiers flexibleQuantifiers constraint header ->

181 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers

190 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers

@@ -185,7 +194,7 @@ solveScheme scheme =

185 freshPool <- TS.nextRankPool

194 freshPool <- TS.nextRankPool

186 TS.switchToPool freshPool

195 TS.switchToPool freshPool

187 mapM TS.introduce quantifiers

196 mapM TS.introduce quantifiers

188− header' <- Traversable.traverse TS.flatten header

197+ header' <- T.traverse flatten header

189 actuallySolve constraint

198 actuallySolve constraint

190

199

191 allDistinct rigidQuantifiers

200 allDistinct rigidQuantifiers

@@ -234,46 +243,53 @@ crash msg =

234 ++ "<https://github.com/elm-lang/elm-compiler/issues>"

243 ++ "<https://github.com/elm-lang/elm-compiler/issues>"

235

244

236

245

237−occurs :: (String, Variable) -> StateT TS.SolverState IO ()

246+occurs :: (String, A.Located Variable) -> StateT TS.SolverState IO ()

238−occurs (_name, variable) =

247+occurs (name, A.A region variable) =

239− do vars <- liftIO $ infiniteVars [] variable

248+ do maybePair <- liftIO $ occursHelp [] variable

240− case vars of

249+ case maybePair of

241− [] ->

250+ Nothing ->

242− return ()

251+ return ()

243−

252+

244− var : _ ->

253+ Just (t1, t2) ->

245− do desc <- liftIO $ UF.descriptor var

254+ let

246− let region = error "TODO:occurs"

255+ info = Error.InfiniteTypeInfo name t1 t2

247− case structure desc of

248− Nothing ->

249− TS.addError region (Error.InfiniteType undefined (error "TODO:occurs"))

250−

251− Just _ ->

252− TS.addError region (Error.InfiniteType undefined (error "TODO:occurs"))

253− where

254− infiniteVars :: [Variable] -> Variable -> IO [Variable]

255− infiniteVars seen var =

256− let go = infiniteVars (var:seen)

257− in

256+ in

257+ TS.addError region (Error.InfiniteType info)

258+

259+

260+occursHelp

261+ :: [Variable]

262+ -> Variable

263+ -> IO (Maybe (Type.Canonical, Type.Canonical))

264+occursHelp seen var =

258− if var `elem` seen

265+ if elem var seen then

259− then return [var]

266+ do desc <- UF.descriptor var

267+ UF.setDescriptor var (desc { structure = Nothing })

268+ var' <- UF.fresh desc

269+ srcVar <- toSrcType var

270+ srcVar' <- toSrcType var'

271+ return (Just (srcVar, srcVar'))

260− else do

272+ else

261− desc <- UF.descriptor var

273+ do desc <- UF.descriptor var

262 case structure desc of

274 case structure desc of

263− Nothing -> return []

275+ Nothing ->

276+ return Nothing

277+

264 Just struct ->

278 Just struct ->

279+ let go = occursHelp (var:seen)

280+ in

265 case struct of

281 case struct of

266 App1 a b ->

282 App1 a b ->

267− (++) <$> go a <*> go b

283+ (<|>) <$> go a <*> go b

268

284

269 Fun1 a b ->

285 Fun1 a b ->

270− (++) <$> go a <*> go b

286+ (<|>) <$> go a <*> go b

271

287

272 Var1 a ->

288 Var1 a ->

273 go a

289 go a

274

290

275 EmptyRecord1 ->

291 EmptyRecord1 ->

276− return []

292+ return Nothing

277

293

278 Record1 fields ext ->

294 Record1 fields ext ->

279− concat <$> mapM go (ext : concat (Map.elems fields))

295+ F.asum <$> mapM go (ext : concat (Map.elems fields))

src/Type/State.hs+1−1

@@ -33,7 +33,7 @@ emptyPool =

33 }

34

35

36−type Env = Map.Map String Variable

36+type Env = Map.Map String (A.Located Variable)

37

38

39-- Keeps track of the environment, type variable pool, and a list of errors

src/Type/Type.hs+21−13

@@ -13,6 +13,7 @@ import System.IO.Unsafe

13

14import qualified AST.Type as T

15import qualified AST.Variable as Var

16+import qualified Reporting.Annotation as A

16import qualified Reporting.Error.Type as Error

17import qualified Reporting.Error.Type as Error

17import qualified Reporting.Region as R

18import qualified Reporting.Region as R

18import Type.PrettyPrint

19import Type.PrettyPrint

@@ -91,6 +92,7 @@ data Flex

91 | Flexible

92 | Flexible

92 | Constant

93 | Constant

93 | Is SuperType

94 | Is SuperType

95+ | Error

94 deriving (Eq)

96 deriving (Eq)

95

97

96data SuperType

98data SuperType

@@ -118,7 +120,7 @@ data Scheme a b = Scheme

118 { rigidQuantifiers :: [b]

120 { rigidQuantifiers :: [b]

119 , flexibleQuantifiers :: [b]

121 , flexibleQuantifiers :: [b]

120 , constraint :: Constraint a b

122 , constraint :: Constraint a b

121− , header :: Map.Map String a

123+ , header :: Map.Map String (A.Located a)

122 }

124 }

123

125

124

126

@@ -151,20 +153,26 @@ namedVar flex name = UF.fresh $ Descriptor

151

153

152

154

153variable :: Flex -> IO Variable

155variable :: Flex -> IO Variable

154−variable flex = UF.fresh $ Descriptor

156+variable flex =

155− { structure = Nothing

157+ UF.fresh (descriptor flex)

156− , rank = noRank

158+

157− , flex = flex

159+

158− , name = Nothing

160+descriptor :: Flex -> Descriptor

159− , copy = Nothing

161+descriptor flex =

160− , mark = noMark

162+ Descriptor

161− , alias = Nothing

163+ { structure = Nothing

162− }

164+ , rank = noRank

165+ , flex = flex

166+ , name = Nothing

167+ , copy = Nothing

168+ , mark = noMark

169+ , alias = Nothing

170+ }

163

171

164

172

165-- CONSTRAINT HELPERS

173-- CONSTRAINT HELPERS

166

174

167−monoscheme :: Map.Map String a -> Scheme a b

175+monoscheme :: Map.Map String (A.Located a) -> Scheme a b

168monoscheme headers =

176monoscheme headers =

169 Scheme [] [] CTrue headers

177 Scheme [] [] CTrue headers

170

178

@@ -373,8 +381,8 @@ instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where

373 dict =

381 dict =

374 P.parens . commaSep . map prettyPair $ Map.toList headers

382 P.parens . commaSep . map prettyPair $ Map.toList headers

375

383

376− prettyPair (n,t) =

384+ prettyPair (fieldName, A.A _ tipe) =

377− P.text n <+> P.text ":" <+> pretty Never t

385+ P.text fieldName <+> P.text ":" <+> pretty Never tipe

378

386

379

387

380-- CONVERT TO SOURCE TYPES

388-- CONVERT TO SOURCE TYPES

src/Type/Unify.hs+50−30

@@ -42,17 +42,20 @@ type Unify =

42

43

44newtype RawMismatch =

45− RawMismatch (AstType.Canonical, AstType.Canonical, Error.Note)

45+ RawMismatch (AstType.Canonical, AstType.Canonical, Maybe String)

46

47

48typeError

49 :: UF.Point Descriptor

50 -> UF.Point Descriptor

51− -> Error.Note

51+ -> Maybe String

52 -> Unify a

53typeError leftType rightType note =

54 do leftSrcType <- liftIO (toSrcType leftType)

55 rightSrcType <- liftIO (toSrcType rightType)

56+ liftIO $ do

57+ UF.setDescriptor leftType (Type.descriptor Error)

58+ UF.setDescriptor rightType (Type.descriptor Error)

56 throwError (RawMismatch (leftSrcType, rightSrcType, note))

59 throwError (RawMismatch (leftSrcType, rightSrcType, note))

57

60

58

61

@@ -118,25 +121,31 @@ actuallyUnify variable1 variable2 = do

118

121

119 unifyNumber svar (Var.Canonical home name) =

122 unifyNumber svar (Var.Canonical home name) =

120 case home of

123 case home of

121− Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar

124+ Var.BuiltIn | name `elem` ["Int","Float"] ->

122− Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar

125+ flexAndUnify svar

126+

127+ Var.Local | List.isPrefixOf "number" name ->

128+ flexAndUnify svar

123 _ ->

129 _ ->

124− typeError variable1 variable2 Error.NoNote

130+ typeError variable1 variable2 Nothing

125

131

126 comparableError maybeHint =

132 comparableError maybeHint =

127− typeError variable1 variable2 $ Error.PostNote $

133+ typeError variable1 variable2 $ Just $

128 "Note: comparable types include Int, Float, Char, String, lists, and tuples."

134 "Note: comparable types include Int, Float, Char, String, lists, and tuples."

129 ++ maybe "" ("\n"++) maybeHint

135 ++ maybe "" ("\n"++) maybeHint

130

136

131 appendableError =

137 appendableError =

132− typeError variable1 variable2 $ Error.PostNote $

138+ typeError variable1 variable2 $ Just $

133 "Note: appendable types include only Strings, Lists, and Text."

139 "Note: appendable types include only Strings, Lists, and Text."

134

140

135 unifyComparable v (Var.Canonical home name) =

141 unifyComparable v (Var.Canonical home name) =

136 case home of

142 case home of

137− Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v

143+ Var.BuiltIn | name `elem` ["Int","Float","Char","String"] ->

138− Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v

144+ flexAndUnify v

139− _ -> comparableError Nothing

145+ Var.Local | List.isPrefixOf "comparable" name ->

146+ flexAndUnify v

147+ _ ->

148+ comparableError Nothing

140

149

141 unifyComparableStructure varSuper varFlex =

150 unifyComparableStructure varSuper varFlex =

142 do struct <- liftIO $ collectApps varFlex

151 do struct <- liftIO $ collectApps varFlex

@@ -148,11 +157,11 @@ actuallyUnify variable1 variable2 = do

148 do flexAndUnify varSuper

157 do flexAndUnify varSuper

149 unifyHelp v =<< liftIO (variable $ Is Comparable)

158 unifyHelp v =<< liftIO (variable $ Is Comparable)

150

159

151− Tuple vs

160+ Tuple vs ->

152− | length vs > 6 ->

161+ if length vs > 6 then

153 comparableError $ Just $

162 comparableError $ Just $

154 "Furthermore, it cannot be a tuple with more than 6 elements."

163 "Furthermore, it cannot be a tuple with more than 6 elements."

155− | otherwise ->

164+ else

156 do flexAndUnify varSuper

165 do flexAndUnify varSuper

157 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

166 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

158 zipWithM_ unifyHelp vs cmpVars

167 zipWithM_ unifyHelp vs cmpVars

@@ -164,12 +173,8 @@ actuallyUnify variable1 variable2 = do

164 _ -> appendableError

173 _ -> appendableError

165

174

166 rigidError var =

175 rigidError var =

167− let v = render (pretty Never var)

176+ typeError variable1 variable2 $ Just $

168− in

177+ rigidErrorMessage (render (pretty Never var))

169− typeError variable1 variable2 $ Error.PreNote $

170− "Could not unify rigid type variable '" ++ v ++ "'. The problem probably\n"

171− ++ "relates to the type variable being shared between two type annotations.\n"

172− ++ "Try commenting out some type annotations and see what happens."

173

178

174 superUnify =

179 superUnify =

175 case (flex desc1, flex desc2, name desc1, name desc2) of

180 case (flex desc1, flex desc2, name desc1, name desc2) of

@@ -195,17 +200,20 @@ actuallyUnify variable1 variable2 = do

195

200

196 (Rigid, _, _, _) -> rigidError variable1

201 (Rigid, _, _, _) -> rigidError variable1

197 (_, Rigid, _, _) -> rigidError variable2

202 (_, Rigid, _, _) -> rigidError variable2

198− _ -> typeError variable1 variable2 Error.NoNote

203+ _ -> typeError variable1 variable2 Nothing

199

204

200 case (structure desc1, structure desc2) of

205 case (structure desc1, structure desc2) of

201− (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->

206+ (Nothing, Nothing)

202− merge

207+ | flex desc1 == Flexible && flex desc1 == Flexible ->

208+ merge

203

209

204− (Nothing, _) | flex desc1 == Flexible ->

210+ (Nothing, _)

205− merge2

211+ | flex desc1 == Flexible -> merge2

212+ | flex desc1 == Error -> return ()

206

213

207− (_, Nothing) | flex desc2 == Flexible ->

214+ (_, Nothing)

208− merge1

215+ | flex desc2 == Flexible -> merge1

216+ | flex desc2 == Error -> return ()

209

217

210 (Just (Var1 v), _) ->

218 (Just (Var1 v), _) ->

211 unifyHelp v variable2

219 unifyHelp v variable2

@@ -239,7 +247,19 @@ actuallyUnify variable1 variable2 = do

239 (Record1 _ _, Record1 _ _) ->

247 (Record1 _ _, Record1 _ _) ->

240 recordUnify fresh variable1 variable2

248 recordUnify fresh variable1 variable2

241

249

242− _ -> typeError variable1 variable2 Error.NoNote

250+ _ -> typeError variable1 variable2 Nothing

251+

252+

253+-- RIGID ERROR

254+

255+rigidErrorMessage :: String -> String

256+rigidErrorMessage var =

257+ "Could not unify user provided type variable `" ++ var ++ "`. The most likely cases are:\n\n"

258+ ++ " 1. The type you wrote down is too general. It says any type can go through\n"

259+ ++ " but in fact only a certain type can.\n"

260+ ++ " 2. A type variable is probably being shared between two type annotations.\n"

261+ ++ " They are treated as different things in the current implementation, so\n"

262+ ++ " Try commenting out some type annotations and see what happens."

243

263

244

264

245-- RECORD UNIFICATION

265-- RECORD UNIFICATION

@@ -262,14 +282,14 @@ recordUnify fresh variable1 variable2 =

262 let uniqueFields2 = diffFields fields2 fields1

282 let uniqueFields2 = diffFields fields2 fields1

263

283

264 let addFieldMismatchError missingFields =

284 let addFieldMismatchError missingFields =

265− typeError variable1 variable2 $ Error.PreNote $

285+ typeError variable1 variable2 $ Just $

266 fieldMismatchError missingFields

286 fieldMismatchError missingFields

267

287

268 case (ext1, ext2) of

288 case (ext1, ext2) of

269 (Empty _, Empty _) ->

289 (Empty _, Empty _) ->

270 case Map.null uniqueFields1 && Map.null uniqueFields2 of

290 case Map.null uniqueFields1 && Map.null uniqueFields2 of

271 True -> return ()

291 True -> return ()

272− False -> typeError variable1 variable2 Error.NoNote

292+ False -> typeError variable1 variable2 Nothing

273

293

274 (Empty var1, Extension var2) ->

294 (Empty var1, Extension var2) ->

275 case (Map.null uniqueFields1, Map.null uniqueFields2) of

295 case (Map.null uniqueFields1, Map.null uniqueFields2) of

@@ -356,7 +376,7 @@ fieldMismatchError missingFields =

356 case Map.keys missingFields of

376 case Map.keys missingFields of

357 [] -> ""

377 [] -> ""

358 [key] ->

378 [key] ->

359− "Looks like a record is missing the field '" ++ key ++ "'"

379+ "Looks like a record is missing the field `" ++ key ++ "`"

360 keys ->

380 keys ->

361 "Looks like a record is missing fields "

381 "Looks like a record is missing fields "

362 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys

382 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys

src/Validate.hs+60−33

@@ -23,34 +23,43 @@ import qualified Reporting.Result as Result

23-- VALIDATE DECLARATIONS

24

25declarations

26− :: [D.SourceDecl]

26+ :: Bool

27+ -> [D.SourceDecl]

27 -> Result.Result wrn Error.Error [D.ValidDecl]

28 -> Result.Result wrn Error.Error [D.ValidDecl]

28−declarations sourceDecls =

29+declarations isRoot sourceDecls =

29− do validDecls <- validateDecls sourceDecls

30+ do validDecls <- validateDecls Nothing sourceDecls

30 (\_ _ -> validDecls)

31 (\_ _ -> validDecls)

31 <$> declDuplicates validDecls

32 <$> declDuplicates validDecls

32− <*> T.traverse checkDecl validDecls

33+ <*> T.traverse (checkDecl isRoot) validDecls

33

34

35

35validateDecls

36validateDecls

36− :: [D.SourceDecl]

37+ :: Maybe String

38+ -> [D.SourceDecl]

37 -> Result.Result wrn Error.Error [D.ValidDecl]

39 -> Result.Result wrn Error.Error [D.ValidDecl]

38−validateDecls sourceDecls =

40+validateDecls maybeComment sourceDecls =

39 case sourceDecls of

41 case sourceDecls of

40 [] ->

42 [] ->

41 return []

43 return []

42

44

43− decl : decls ->

45+ sourceDecl : decls ->

44− validateDeclsHelp decl decls

46+ case sourceDecl of

47+ D.Comment comment ->

48+ validateDecls (Just comment) decls

49+

50+ D.Decl decl ->

51+ validateDeclsHelp maybeComment decl decls

45

52

46

53

47validateDeclsHelp

54validateDeclsHelp

48− :: D.SourceDecl

55+ :: Maybe String

56+ -> A.Located D.SourceDecl'

49 -> [D.SourceDecl]

57 -> [D.SourceDecl]

50 -> Result.Result wrn Error.Error [D.ValidDecl]

58 -> Result.Result wrn Error.Error [D.ValidDecl]

51−validateDeclsHelp (A.A region decl) decls =

59+validateDeclsHelp comment (A.A region decl) decls =

52 let addRest validDecl =

60 let addRest validDecl =

53− (:) (A.A region validDecl) <$> validateDecls decls

61+ (:) (A.A (region, comment) validDecl)

62+ <$> validateDecls Nothing decls

54 in

63 in

55 case decl of

64 case decl of

56 D.Datatype name tvars ctors ->

65 D.Datatype name tvars ctors ->

@@ -63,21 +72,23 @@ validateDeclsHelp (A.A region decl) decls =

63 addRest (D.Fixity assoc prec op)

72 addRest (D.Fixity assoc prec op)

64

73

65 D.Definition def ->

74 D.Definition def ->

66− defHelp def decls

75+ defHelp comment def decls

67

76

68 D.Port port ->

77 D.Port port ->

69− portHelp region port decls

78+ portHelp comment region port decls

70

79

71

80

72-- VALIDATE DEFINITIONS IN DECLARATIONS

81-- VALIDATE DEFINITIONS IN DECLARATIONS

73

82

74defHelp

83defHelp

75− :: Source.Def

84+ :: Maybe String

85+ -> Source.Def

76 -> [D.SourceDecl]

86 -> [D.SourceDecl]

77 -> Result.Result wrn Error.Error [D.ValidDecl]

87 -> Result.Result wrn Error.Error [D.ValidDecl]

78−defHelp (A.A region def) decls =

88+defHelp comment (A.A region def) decls =

79 let addRest def' rest =

89 let addRest def' rest =

80− (:) (A.A region (D.Definition def')) <$> validateDecls rest

90+ (:) (A.A (region, comment) (D.Definition def'))

91+ <$> validateDecls Nothing rest

81 in

92 in

82 case def of

93 case def of

83 Source.Definition pat expr ->

94 Source.Definition pat expr ->

@@ -87,7 +98,8 @@ defHelp (A.A region def) decls =

87

98

88 Source.TypeAnnotation name tipe ->

99 Source.TypeAnnotation name tipe ->

89 case decls of

100 case decls of

90− A.A _ (D.Definition (A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr))) : rest

101+ D.Decl (A.A _ (D.Definition (A.A _

102+ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr)))) : rest

91 | name == name' ->

103 | name == name' ->

92 do expr' <- Validate.expression expr

104 do expr' <- Validate.expression expr

93 let def' = Valid.Definition pat expr' (Just tipe)

105 let def' = Valid.Definition pat expr' (Just tipe)

@@ -100,13 +112,15 @@ defHelp (A.A region def) decls =

100-- VALIDATE PORTS IN DECLARATIONS

112-- VALIDATE PORTS IN DECLARATIONS

101

113

102portHelp

114portHelp

103− :: R.Region

115+ :: Maybe String

116+ -> R.Region

104 -> D.SourcePort

117 -> D.SourcePort

105 -> [D.SourceDecl]

118 -> [D.SourceDecl]

106 -> Result.Result wrn Error.Error [D.ValidDecl]

119 -> Result.Result wrn Error.Error [D.ValidDecl]

107−portHelp region port decls =

120+portHelp comment region port decls =

108 let addRest port' rest =

121 let addRest port' rest =

109− (:) (A.A region (D.Port port')) <$> validateDecls rest

122+ (:) (A.A (region,comment) (D.Port port'))

123+ <$> validateDecls Nothing rest

110 in

124 in

111 case port of

125 case port of

112 D.PortDefinition name _ ->

126 D.PortDefinition name _ ->

@@ -114,7 +128,7 @@ portHelp region port decls =

114

128

115 D.PortAnnotation name tipe ->

129 D.PortAnnotation name tipe ->

116 case decls of

130 case decls of

117− A.A _ (D.Port (D.PortDefinition name' expr)) : rest

131+ D.Decl (A.A _ (D.Port (D.PortDefinition name' expr))) : rest

118 | name == name' ->

132 | name == name' ->

119 do expr' <- Validate.expression expr

133 do expr' <- Validate.expression expr

120 let port' = D.Out name expr' tipe

134 let port' = D.Out name expr' tipe

@@ -199,8 +213,10 @@ expression (A.A ann sourceExpression) =

199 <$> expression funcExpr

213 <$> expression funcExpr

200 <*> expression argExpr

214 <*> expression argExpr

201

215

202− MultiIf branches ->

216+ MultiIf branches finally ->

203− MultiIf <$> T.traverse both branches

217+ MultiIf

218+ <$> T.traverse both branches

219+ <*> expression finally

204

220

205 Access record field ->

221 Access record field ->

206 Access

222 Access

@@ -249,6 +265,9 @@ expression (A.A ann sourceExpression) =

249 do expr' <- expression expr

265 do expr' <- expression expr

250 return (Task name expr' tipe)

266 return (Task name expr' tipe)

251

267

268+ Crash details ->

269+ return (Crash details)

270+

252

271

253second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)

272second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)

254second (value, expr) =

273second (value, expr) =

@@ -304,7 +323,7 @@ declDuplicates decls =

304

323

305

324

306extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])

325extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])

307−extractValues (A.A region decl) =

326+extractValues (A.A (region, _) decl) =

308 case decl of

327 case decl of

309 D.Definition (Valid.Definition pattern _ _) ->

328 D.Definition (Valid.Definition pattern _ _) ->

310 ( Pattern.boundVars pattern

329 ( Pattern.boundVars pattern

@@ -339,8 +358,8 @@ extractValues (A.A region decl) =

339

358

340-- UNBOUND TYPE VARIABLES

359-- UNBOUND TYPE VARIABLES

341

360

342−checkDecl :: D.ValidDecl -> Result.Result wrn Error.Error ()

361+checkDecl :: Bool -> D.ValidDecl -> Result.Result wrn Error.Error ()

343−checkDecl (A.A region decl) =

362+checkDecl isRoot (A.A (region,_) decl) =

344 case decl of

363 case decl of

345 D.Definition _ ->

364 D.Definition _ ->

346 return ()

365 return ()

@@ -352,21 +371,29 @@ checkDecl (A.A region decl) =

352 [] ->

371 [] ->

353 return ()

372 return ()

354

373

355− v:vs ->

374+ unbound ->

356− Result.throw region

375+ let

357− (Error.UnboundTypeVarsInUnion name boundVars v vs ctors)

376+ (v:vs) = Set.toList (Set.fromList unbound)

377+ in

378+ Result.throw region

379+ (Error.UnboundTypeVarsInUnion name boundVars v vs ctors)

358

380

359 D.TypeAlias name boundVars tipe ->

381 D.TypeAlias name boundVars tipe ->

360 case findUnbound boundVars (freeVars tipe) of

382 case findUnbound boundVars (freeVars tipe) of

361 [] ->

383 [] ->

362 return ()

384 return ()

363

385

364− v:vs ->

386+ unbound ->

365− Result.throw region

387+ let

366− (Error.UnboundTypeVarsInAlias name boundVars v vs tipe)

388+ (v:vs) = Set.toList (Set.fromList unbound)

389+ in

390+ Result.throw region

391+ (Error.UnboundTypeVarsInAlias name boundVars v vs tipe)

367

392

368 D.Port _ ->

393 D.Port _ ->

369− return ()

394+ if isRoot

395+ then return ()

396+ else Result.throw region Error.UnexpectedPort

370

397

371 D.Fixity _ _ _ ->

398 D.Fixity _ _ _ ->

372 return ()

399 return ()

tests/Test.hs+3−3

@@ -3,12 +3,12 @@ module Main where

3import Test.Framework

4

5import Test.Compiler

6−import Test.Property

6+--import Test.Property

7

8

9−main :: IO ()

9+main :: IO ()

10main =

11 defaultMain

12 [ compilerTests

13− , propertyTests

13+-- , propertyTests

14 ]

tests/Test/Compiler.hs+25−10

@@ -12,7 +12,6 @@ import Test.Framework.Providers.HUnit (testCase)

12import Test.HUnit (Assertion, assertFailure, assertBool)

13

14import qualified Elm.Compiler as Compiler

15−import qualified Elm.Compiler.Module as Module

16

15

17

16

18compilerTests :: Test

17compilerTests :: Test

@@ -45,16 +44,25 @@ testsDir =

45-- RUN COMPILER

44-- RUN COMPILER

46

45

47testIf

46testIf

48− :: (Either String (Module.Interface, String) -> Assertion)

47+ :: (Either String Compiler.Result -> Assertion)

49 -> [FilePath]

48 -> [FilePath]

50 -> IO [Test]

49 -> IO [Test]

51testIf handleResult filePaths =

50testIf handleResult filePaths =

52 traverse setupTest filePaths

51 traverse setupTest filePaths

53 where

52 where

54− setupTest filePath =

53+ setupTest filePath = do

55− do source <- readFile filePath

54+ source <- readFile filePath

56− let result = Compiler.compile "elm-lang" "core" source Map.empty

55+

57− return (testCase filePath (handleResult result))

56+ let context =

57+ Compiler.Context "elm-lang" "core" True False

58+ let (dealiaser, _warnings, result) =

59+ Compiler.compile context source Map.empty

60+ let formatErrors errors =

61+ concatMap (Compiler.errorToString dealiaser filePath source) errors

62+ let formattedResult =

63+ either (Left . formatErrors) Right result

64+

65+ return $ testCase filePath (handleResult formattedResult)

58

66

59

67

60-- CHECK RESULTS

68-- CHECK RESULTS

@@ -62,12 +70,19 @@ testIf handleResult filePaths =

62isSuccess :: Either String a -> Assertion

70isSuccess :: Either String a -> Assertion

63isSuccess result =

71isSuccess result =

64 case result of

72 case result of

65− Right _ -> assertBool "" True

73+ Right _ ->

66− Left msg -> assertFailure msg

74+ assertBool "" True

75+

76+ Left errorMessages ->

77+ assertFailure errorMessages

67

78

68

79

69isFailure :: Either a b -> Assertion

80isFailure :: Either a b -> Assertion

70isFailure result =

81isFailure result =

71 case result of

82 case result of

72− Right _ -> assertFailure "Compilation succeeded but should have failed"

83+ Right _ ->

73− Left _ -> assertBool "" True

84+ assertFailure "Compilation succeeded but should have failed"

85+

86+ Left _ ->

87+ assertBool "" True

88+

tests/Test/Property.hs+1−1

@@ -12,7 +12,7 @@ import Text.PrettyPrint as P

12import AST.Literal as Lit

13import qualified AST.Pattern as P

14import qualified AST.Variable as V

15−import AST.PrettyPrint (Pretty, pretty)

15+import Reporting.PrettyPrint (Pretty, pretty)

16import Parse.Helpers (IParser, iParse)

17import Parse.Literal (literal)

18import qualified Parse.Pattern as Pat (expr)

tests/test-files/good/Ports.elm+11−11

@@ -1,21 +1,21 @@

1

2-- incoming

3−input userID : String

3+port userID : String

4−input number : Int

4+port number : Int

5−input tuple : (Float,Bool)

5+port tuple : (Float,Bool)

6−input array : List Int

6+port array : List Int

7−input record : { x:Float, y:Float }

7+port record : { x:Float, y:Float }

8

9-- outgoing

10−output fortyTwo : Int

10+port fortyTwo : Int

11−output fortyTwo =

11+port fortyTwo =

12 42

13

14

15−output time : Float

15+port time : Float

16−output time =

16+port time =

17 3.14

18

19−output students : List { name:String, age:Int }

19+port students : List { name:String, age:Int }

20−output students =

20+port students =

21 [ { name = "Tom", age = 42 } ]

tests/test-files/good/PortsWithTypeAliases.elm+2−2

@@ -7,7 +7,7 @@ type alias Point x y =

7 { x:x, y:y }

8

9

10−input points : Point2D

10+port points : Point2D

11

12

13−input pairs : Point String String

13+port pairs : Point String String