3925082 · elk · git.iko.soy

.gitignore+2

compare with master

unifiedsplit

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

1dist

2cabal-dev

3+.cabal-sandbox/

4+cabal.sandbox.config

3*.o

5*.o

4*.hi

6*.hi

5*.chi

7*.chi

.gitmodules−3

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

1[submodule "IO"]

2 path = IO

3 url = https://github.com/maxsnew/IO.git

4−[submodule "automaton"]

5− path = automaton

6− url = https://github.com/evancz/automaton.git

7[submodule "Elm-Test"]

4[submodule "Elm-Test"]

8 path = Elm-Test

5 path = Elm-Test

9 url = https://github.com/deadfoxygrandpa/Elm-Test.git

6 url = https://github.com/deadfoxygrandpa/Elm-Test.git

CONTRIBUTING.md+30−23

@@ -1,36 +1,43 @@

1# Contributing to Elm

2

3−Thanks helping with the development of Elm! This document

3+Thanks helping with the development of Elm! This document describes the basic

4−describes the basic standards for opening pull requests:

4+standards for opening pull requests and making the review process as smooth as

5+possible.

6+

7+## Licensing

8+

9+You need to sign the [contributor agreement](ContributorAgreement.pdf)

10+and send it to <info@elm-lang.org> before opening your pull request.

11+

12+## Style Guide

13+

14+ * Haskell — conform to [these guidelines][haskell]

15+ * JavaScript — use [Google's JS style guide][js]

16+

17+[haskell]: https://gist.github.com/evancz/0a1f3717c92fe71702be

18+[js]: https://google-styleguide.googlecode.com/svn/trunk/javascriptguide.xml

5

19

6## Branches

20## Branches

7

21

8− * [The master branch](https://github.com/elm-lang/Elm/tree/master) is the

9− home of the next release of the compiler so new features and improvements

22+ * [The master branch][master] is the home of the next release of the compiler

23+ so new features and improvements get merged there. Most pull requests

10− get merged there. Most pull requests should target this branch!

24+ should target this branch!

11

25

12− * [The stable branch](https://github.com/elm-lang/Elm/tree/stable) is for

13− tagging previous releases and critical bug fixes. This branch is handy for

26+ * [The stable branch][stable] is for tagging releases and critical bug fixes.

14− folks who want to build the most recent public release from source.

27+ This branch is handy for folks who want to build the most recent public

28+ release from source.

29+

30+[master]: http://github.com/elm-lang/elm/tree/master

31+[stable]: http://github.com/elm-lang/elm/tree/stable

15

32

16If you are working on a fairly large feature, we will probably want to merge it

33If you are working on a fairly large feature, we will probably want to merge it

17in as its own branch and do some testing before bringing it into the master

34in as its own branch and do some testing before bringing it into the master

18branch. This way we can keep releases of the master branch independent of new

35branch. This way we can keep releases of the master branch independent of new

19features.

36features.

20

37

21−## Opening a pull request

38+Note that the master branch of the compiler should always be in sync with the

22−

39+master branch of the [website][], and the stable branch of the compiler should

23−**Please open PRs against the [master branch of

40+always be in sync with the stable branch of the [website][]. Make sure that

24−Elm](http://github.com/elm-lang/elm/tree/master) whenever possible.**

41+your changes maintain this compatibility.

25

42

26−Note that changes in the master branch of [Elm](https://github.com/elm-lang/Elm/)

27−are able to be compiled against the master branch of the [elm-lang.org

28−repo](https://github.com/elm-lang/elm-lang.org), and the stable branch of

29−[Elm](https://github.com/elm-lang/Elm/) is able to be built with the stable

30−branch of the [elm-lang.org repo](https://github.com/elm-lang/elm-lang.org).

43+[website]: https://github.com/elm-lang/elm-lang.org

31−Please make sure that your changes maintain this compatibility.

32−

33−## Licensing

34−

35−You need to sign the [contributor agreement](ContributorAgreement.pdf)

36−and send it to <info@elm-lang.org> before opening your pull request.

Elm-Test+1−1

Submodule changed.

Elm.cabal+142−134

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

1Name: Elm

2−Version: 0.12.2

2+Version: 0.13

3Synopsis: The Elm language module.

4Description: Elm aims to make client-side web-development more pleasant.

5 It is a statically/strongly typed, functional reactive

@@ -37,28 +37,36 @@ Library

37 Elm.Internal.Utils,

38 Elm.Internal.Version

39 Hs-Source-Dirs: compiler

40− other-modules: SourceSyntax.Annotation,

40+ other-modules: AST.Annotation,

41− SourceSyntax.Declaration,

41+ AST.Declaration,

42+ AST.Expression.General,

43+ AST.Expression.Source,

42− SourceSyntax.Expression,

44+ AST.Expression.Valid,

45+ AST.Expression.Canonical,

43− SourceSyntax.Helpers,

46+ AST.Helpers,

44− SourceSyntax.Literal,

47+ AST.Literal,

45− SourceSyntax.Module,

48+ AST.Module,

46− SourceSyntax.Pattern,

49+ AST.Pattern,

47− SourceSyntax.PrettyPrint,

50+ AST.PrettyPrint,

48− SourceSyntax.Type,

51+ AST.Type,

49− SourceSyntax.Variable,

52+ AST.Variable,

50 Generate.JavaScript,

53 Generate.JavaScript,

51 Generate.JavaScript.Helpers,

54 Generate.JavaScript.Helpers,

52 Generate.JavaScript.Ports,

55 Generate.JavaScript.Ports,

56+ Generate.JavaScript.Variable,

53 Generate.Markdown,

57 Generate.Markdown,

54 Generate.Html,

58 Generate.Html,

55 Generate.Cases,

59 Generate.Cases,

56 Transform.Canonicalize,

60 Transform.Canonicalize,

61+ Transform.Canonicalize.Environment,

62+ Transform.Canonicalize.Setup,

63+ Transform.Canonicalize.Type,

64+ Transform.Canonicalize.Variable,

57 Transform.Check,

65 Transform.Check,

58 Transform.Expression,

66 Transform.Expression,

59 Transform.Declaration,

67 Transform.Declaration,

60 Transform.Definition,

68 Transform.Definition,

61− Transform.SafeNames,

69+ Transform.Interface,

62 Transform.SortDefinitions,

70 Transform.SortDefinitions,

63 Transform.Substitute,

71 Transform.Substitute,

64 Metadata.Prelude,

72 Metadata.Prelude,

@@ -71,8 +79,6 @@ Library

71 Parse.Parse,

79 Parse.Parse,

72 Parse.Pattern,

80 Parse.Pattern,

73 Parse.Type,

81 Parse.Type,

74− Type.Alias,

75− Type.Constrain.Declaration,

76 Type.Constrain.Expression,

82 Type.Constrain.Expression,

77 Type.Constrain.Literal,

83 Type.Constrain.Literal,

78 Type.Constrain.Pattern,

84 Type.Constrain.Pattern,

@@ -94,57 +100,64 @@ Library

94 Build.Utils,

100 Build.Utils,

95 Paths_Elm

101 Paths_Elm

96

102

97− Build-depends: aeson,

103+ Build-depends: aeson >= 0.7 && < 0.9,

98− aeson-pretty,

104+ aeson-pretty >= 0.7 && < 0.8,

99 base >=4.2 && <5,

105 base >=4.2 && <5,

100− binary >= 0.7.0.0,

106+ binary >= 0.7.0.0 && < 0.8,

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

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

102− blaze-markup,

108+ blaze-markup >= 0.5.1 && < 0.7,

103− bytestring,

109+ bytestring >= 0.9 && < 0.11,

110+ cheapskate >= 0.1 && < 0.2,

104− cmdargs,

111+ cmdargs >= 0.7 && < 0.11,

105− containers >= 0.3,

112+ containers >= 0.3 && < 0.6,

106− directory,

113+ directory >= 1.0 && < 2.0,

107− filepath,

114+ filepath >= 1 && < 2.0,

115+ highlighting-kate >= 0.5 && < 0.6,

108− indents,

116+ indents >= 0.3 && < 0.4,

109− language-ecmascript >=0.15 && < 1.0,

117+ language-ecmascript >=0.15 && < 0.17,

110− language-glsl,

118+ language-glsl >= 0.0.2 && < 0.2,

111− mtl >= 2,

119+ mtl >= 2 && < 3,

112− pandoc >= 1.10,

113− parsec >= 3.1.1,

120+ parsec >= 3.1.1 && < 3.5,

114− pretty,

121+ pretty >= 1.0 && < 2.0,

115− scientific,

116− text,

122+ text >= 1 && < 2,

117− transformers >= 0.2,

123+ transformers >= 0.2 && < 0.5,

118− union-find,

124+ union-find >= 0.2 && < 0.3,

119− unordered-containers,

125+ unordered-containers >= 0.1 && < 0.3

120− yaml

121

126

122Executable elm

127Executable elm

123 Main-is: Compiler.hs

128 Main-is: Compiler.hs

124 ghc-options: -threaded -O2

129 ghc-options: -threaded -O2

125 Hs-Source-Dirs: compiler

130 Hs-Source-Dirs: compiler

126− other-modules: SourceSyntax.Annotation,

131+ other-modules: AST.Annotation,

127− SourceSyntax.Declaration,

132+ AST.Declaration,

133+ AST.Expression.General,

134+ AST.Expression.Source,

128− SourceSyntax.Expression,

135+ AST.Expression.Valid,

136+ AST.Expression.Canonical,

129− SourceSyntax.Helpers,

137+ AST.Helpers,

130− SourceSyntax.Literal,

138+ AST.Literal,

131− SourceSyntax.Module,

139+ AST.Module,

132− SourceSyntax.Pattern,

140+ AST.Pattern,

133− SourceSyntax.PrettyPrint,

141+ AST.PrettyPrint,

134− SourceSyntax.Type,

142+ AST.Type,

135− SourceSyntax.Variable,

143+ AST.Variable,

136 Generate.JavaScript,

144 Generate.JavaScript,

137 Generate.JavaScript.Helpers,

145 Generate.JavaScript.Helpers,

138 Generate.JavaScript.Ports,

146 Generate.JavaScript.Ports,

147+ Generate.JavaScript.Variable,

139 Generate.Markdown,

148 Generate.Markdown,

140 Generate.Html,

149 Generate.Html,

141 Generate.Cases,

150 Generate.Cases,

142 Transform.Canonicalize,

151 Transform.Canonicalize,

152+ Transform.Canonicalize.Environment,

153+ Transform.Canonicalize.Setup,

154+ Transform.Canonicalize.Type,

155+ Transform.Canonicalize.Variable,

143 Transform.Check,

156 Transform.Check,

144 Transform.Expression,

157 Transform.Expression,

145 Transform.Declaration,

158 Transform.Declaration,

146 Transform.Definition,

159 Transform.Definition,

147− Transform.SafeNames,

160+ Transform.Interface,

148 Transform.SortDefinitions,

161 Transform.SortDefinitions,

149 Transform.Substitute,

162 Transform.Substitute,

150 Metadata.Prelude,

163 Metadata.Prelude,

@@ -157,8 +170,6 @@ Executable elm

157 Parse.Parse,

170 Parse.Parse,

158 Parse.Pattern,

171 Parse.Pattern,

159 Parse.Type,

172 Parse.Type,

160− Type.Alias,

161− Type.Constrain.Declaration,

162 Type.Constrain.Expression,

173 Type.Constrain.Expression,

163 Type.Constrain.Literal,

174 Type.Constrain.Literal,

164 Type.Constrain.Pattern,

175 Type.Constrain.Pattern,

@@ -180,44 +191,43 @@ Executable elm

180 Build.Utils,

191 Build.Utils,

181 Paths_Elm

192 Paths_Elm

182

193

183− Build-depends: aeson,

194+ Build-depends: aeson >= 0.7 && < 0.9,

184− aeson-pretty,

195+ aeson-pretty >= 0.7 && < 0.8,

185 base >=4.2 && <5,

196 base >=4.2 && <5,

186− binary >= 0.7.0.0,

197+ binary >= 0.7.0.0 && < 0.8,

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

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

188− blaze-markup,

199+ blaze-markup >= 0.5.1 && < 0.7,

189− bytestring,

200+ bytestring >= 0.9 && < 0.11,

201+ cheapskate >= 0.1 && < 0.2,

190− cmdargs,

202+ cmdargs >= 0.7 && < 0.11,

191− containers >= 0.3,

203+ containers >= 0.3 && < 0.6,

192− directory,

204+ directory >= 1.0 && < 2.0,

193− filepath,

205+ filepath >= 1 && < 2.0,

206+ highlighting-kate >= 0.5 && < 0.6,

194− indents,

207+ indents >= 0.3 && < 0.4,

195− language-ecmascript >=0.15 && < 1.0,

208+ language-ecmascript >=0.15 && < 0.17,

196− language-glsl,

209+ language-glsl >= 0.0.2 && < 0.2,

197− mtl >= 2,

210+ mtl >= 2 && < 3,

198− pandoc >= 1.10,

199− parsec >= 3.1.1,

211+ parsec >= 3.1.1 && < 3.5,

200− scientific,

201− pretty,

212+ pretty >= 1.0 && < 2.0,

202− text,

213+ text >= 1 && < 2,

203− transformers >= 0.2,

214+ transformers >= 0.2 && < 0.5,

204− union-find,

215+ union-find >= 0.2 && < 0.3,

205− unordered-containers,

216+ unordered-containers >= 0.1 && < 0.3

206− yaml

207

217

208Executable elm-doc

218Executable elm-doc

209 Main-is: Docs.hs

219 Main-is: Docs.hs

210 Hs-Source-Dirs: compiler

220 Hs-Source-Dirs: compiler

211− other-modules: SourceSyntax.Annotation,

221+ other-modules: AST.Annotation,

212− SourceSyntax.Declaration,

222+ AST.Declaration,

213− SourceSyntax.Expression,

223+ AST.Expression.General,

214− SourceSyntax.Helpers,

224+ AST.Helpers,

215− SourceSyntax.Literal,

225+ AST.Literal,

216− SourceSyntax.Module,

226+ AST.Module,

217− SourceSyntax.Pattern,

227+ AST.Pattern,

218− SourceSyntax.PrettyPrint,

228+ AST.PrettyPrint,

219− SourceSyntax.Type,

229+ AST.Type,

220− SourceSyntax.Variable,

230+ AST.Variable,

221 Parse.Binop,

231 Parse.Binop,

222 Parse.Declaration,

232 Parse.Declaration,

223 Parse.Expression,

233 Parse.Expression,

@@ -227,25 +237,23 @@ Executable elm-doc

227 Parse.Pattern,

237 Parse.Pattern,

228 Parse.Type

238 Parse.Type

229

239

230− Build-depends: aeson,

240+ Build-depends: aeson >= 0.7 && < 0.9,

231− aeson-pretty,

241+ aeson-pretty >= 0.7 && < 0.8,

232 base >=4.2 && <5,

242 base >=4.2 && <5,

233− binary >= 0.7.0.0,

243+ binary >= 0.7.0.0 && < 0.8,

234− bytestring,

244+ bytestring >= 0.9 && < 0.11,

235− cmdargs,

245+ cmdargs >= 0.7 && < 0.11,

236− containers >= 0.3,

246+ containers >= 0.3 && < 0.6,

237− directory,

247+ directory >= 1.0 && < 2.0,

238− filepath,

248+ filepath >= 1 && < 2.0,

239− indents,

249+ indents >= 0.3 && < 0.4,

240− language-glsl,

250+ language-glsl >= 0.0.2 && < 0.2,

241− mtl >= 2,

251+ mtl >= 2 && < 3,

242− pandoc >= 1.10,

243− parsec >= 3.1.1,

252+ parsec >= 3.1.1 && < 3.5,

244− pretty,

253+ pretty >= 1.0 && < 2.0,

245− scientific,

246− text,

254+ text >= 1 && < 2,

255+ transformers >= 0.2 && < 0.5,

247− union-find,

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

248− yaml

249

257

250Test-Suite compiler-tests

258Test-Suite compiler-tests

251 Type: exitcode-stdio-1.0

259 Type: exitcode-stdio-1.0

@@ -254,47 +262,47 @@ Test-Suite compiler-tests

254 other-modules: Tests.Compiler

262 other-modules: Tests.Compiler

255 Tests.Property

263 Tests.Property

256 Tests.Property.Arbitrary

264 Tests.Property.Arbitrary

257− SourceSyntax.Helpers

265+ AST.Helpers

258− SourceSyntax.Literal

266+ AST.Literal

259− SourceSyntax.PrettyPrint

267+ AST.PrettyPrint

260− build-depends: test-framework,

268+ build-depends: test-framework > 0.8 && < 0.9,

261− test-framework-hunit,

269+ test-framework-hunit >= 0.3 && < 0.4,

262− test-framework-quickcheck2 >= 0.3,

270+ test-framework-quickcheck2 >= 0.3 && < 0.4,

263− HUnit,

271+ HUnit >= 1.1 && < 2,

264 QuickCheck >= 2 && < 3,

272 QuickCheck >= 2 && < 3,

265− aeson,

273+ aeson >= 0.7 && < 0.9,

266− aeson-pretty,

274+ aeson-pretty >= 0.7 && < 0.8,

267 base >=4.2 && <5,

275 base >=4.2 && <5,

268− binary >= 0.7.0.0,

276+ binary >= 0.7.0.0 && < 0.8,

269− blaze-html,

277+ blaze-html >= 0.5 && < 0.8,

270− blaze-markup,

278+ blaze-markup >= 0.5.1 && < 0.7,

271− bytestring,

279+ bytestring >= 0.9 && < 0.11,

280+ cheapskate >= 0.1 && < 0.2,

272− cmdargs,

281+ cmdargs >= 0.7 && < 0.11,

273− containers >= 0.3,

282+ containers >= 0.3 && < 0.6,

274− directory,

283+ directory >= 1.0 && < 2.0,

275 Elm,

284 Elm,

276− filemanip,

285+ filemanip >= 0.3.5 && < 0.4,

277− filepath,

286+ filepath >= 1 && < 2.0,

287+ highlighting-kate >= 0.5 && < 0.6,

278− indents,

288+ indents >= 0.3 && < 0.4,

279− language-ecmascript >=0.15 && < 1.0,

289+ language-ecmascript >=0.15 && < 0.17,

280− language-glsl,

290+ language-glsl >= 0.0.2 && < 0.2,

281− mtl >= 2,

291+ mtl >= 2 && < 3,

282− pandoc >= 1.10,

283− parsec >= 3.1.1,

292+ parsec >= 3.1.1 && < 3.5,

284− pretty,

293+ pretty >= 1.0 && < 2.0,

285− scientific,

294+ process,

286− text,

295+ text >= 1 && < 2,

287− transformers >= 0.2,

296+ transformers >= 0.2 && < 0.5,

288− union-find,

297+ union-find >= 0.2 && < 0.3,

289− unordered-containers,

298+ unordered-containers >= 0.1 && < 0.3

290− yaml

291

299

292Test-Suite library-tests

300Test-Suite library-tests

293 Type: exitcode-stdio-1.0

301 Type: exitcode-stdio-1.0

294 Hs-Source-Dirs: tests/libraries

302 Hs-Source-Dirs: tests/libraries

295 Main-is: LibraryTest.hs

303 Main-is: LibraryTest.hs

296− build-depends: base,

304+ build-depends: base >= 4.2 && <5,

297− directory,

305+ directory >= 1.0 && < 2.0,

298 Elm,

306 Elm,

299− filepath,

307+ filepath >= 1 && < 2.0,

300− process

308+ process >= 1 && < 2.0

IO+1−1

Submodule changed.

Setup.hs+61−94

@@ -1,55 +1,40 @@

1+{-# OPTIONS_GHC -W #-}

1import Distribution.Simple

2import Distribution.Simple

2import Distribution.Simple.LocalBuildInfo

3import Distribution.Simple.LocalBuildInfo

3import Distribution.Simple.Setup

4import Distribution.Simple.Setup

4import Distribution.PackageDescription

5import Distribution.PackageDescription

5

6

6−import System.Cmd

7import System.Directory

8import System.FilePath

9import System.IO

10import System.Process

11

12−import Control.Monad

13import qualified Data.Binary as Binary

12import qualified Data.Binary as Binary

14import qualified Data.ByteString.Lazy as BS

13import qualified Data.ByteString.Lazy as BS

15import qualified Data.List as List

14import qualified Data.List as List

16

15

17−-- Part 1

16+-- OVERVIEW

18−-- ------

17+-- --------

19−-- Add a build callout

20−-- We need to build elm-doc and run it because that generates the file "docs.json"

21−-- needs by Libraries.hs which is part of the elm library and executable

22−-- Unfort. there seems to be no way to tell cabal that:

23−-- (a) elm-doc generates docs.json, and

24−-- (b) elm (library) depends on docs.json

25−-- Therefore, we either use make instead (or a script), or hack around in cabal

26−

27−-- Part 2

28−-- ------

29−-- Add a post-build callout.

18+-- Add a post-build callout that compiles the standard libraries with the new

30−-- We need to build the runtime.js after we've built elm (because we use elm to generate some of the JavaScript),

19+-- compiler before cabal copies static files to actually install things.

31−-- but before cabal does the install file copy step

20+

32−

21+assetsDir :: FilePath

33−-- Assumptions

22+assetsDir = "data"

34−-- Elm.cabal expects the generated files to end up in dist/data

23+

35−-- git won't look in dist + cabal will clean it

36−rtsDir :: LocalBuildInfo -> FilePath

37−rtsDir lbi = "data"

38−

39−tempDir :: LocalBuildInfo -> FilePath

24+tempDir :: FilePath

40−tempDir lbi = "temp"

25+tempDir = "temp"

41

26

42-- The runtime is called:

27-- The runtime is called:

43−rts :: LocalBuildInfo -> FilePath

28+runtime :: FilePath

44−rts lbi = rtsDir lbi </> "elm-runtime.js"

29+runtime = assetsDir </> "elm-runtime.js"

45

30

46-- The runtime is called:

31-- The runtime is called:

47−docs :: LocalBuildInfo -> FilePath

32+docs :: FilePath

48−docs lbi = rtsDir lbi </> "docs.json"

33+docs = assetsDir </> "docs.json"

49

34

50-- The interfaces for the Standard Libraries live in:

35-- The interfaces for the Standard Libraries live in:

51−interfaces :: LocalBuildInfo -> FilePath

36+interfaces :: FilePath

52−interfaces lbi = rtsDir lbi </> "interfaces.data"

37+interfaces = assetsDir </> "interfaces.data"

53

38

54elm :: LocalBuildInfo -> FilePath

39elm :: LocalBuildInfo -> FilePath

55elm lbi = buildDir lbi </> "elm" </> "elm"

40elm lbi = buildDir lbi </> "elm" </> "elm"

@@ -65,63 +50,47 @@ main :: IO ()

65main = defaultMainWithHooks simpleUserHooks { postBuild = myPostBuild }

50main = defaultMainWithHooks simpleUserHooks { postBuild = myPostBuild }

66

51

67

52

68−-- Build

69−

70−-- note(1): We use to include docs.json directly into LoadLibraries at compile time

71−-- If docs.json is used in other (template) haskell files, they should be copied

72−-- and compiled in a separate directory (eg, dist/copiedSrc).

73−-- This is to make sure they are re-compiled on docs.json changes.

74−-- Copying is a better solution than 'touch'ing the source files

75−-- (touch is non-portable and confusing wrt RCS).

76−

77−-- In the PackageDescription, the list of stuff to build is held in library

78−-- (in a Maybe) and the executables list. We want a PackageDescription that

79−-- only mentions the executable 'name'

80−filterExe :: String -> PackageDescription -> PackageDescription

81−filterExe name pd = pd {

82− library = Nothing,

83− executables = filter (\x -> (exeName x == name)) (executables pd)

84− }

85−

86

53

87-- Post Build

54-- Post Build

88

55

89myPostBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()

56myPostBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()

90−myPostBuild as bfs pd lbi = do

57+myPostBuild args flags packageDescription lbi = do

91 putStrLn "Custom build step: compiling standard libraries"

58 putStrLn "Custom build step: compiling standard libraries"

92 (elmos, elmis) <- compileLibraries lbi

59 (elmos, elmis) <- compileLibraries lbi

93 putStrLn "Custom build step: build interfaces.data"

60 putStrLn "Custom build step: build interfaces.data"

94− buildInterfaces lbi elmis

61+ buildInterfaces elmis

95 putStrLn "Custom build step: build elm-runtime.js"

62 putStrLn "Custom build step: build elm-runtime.js"

96− buildRuntime lbi elmos

63+ buildRuntime elmos

97 putStrLn "Custom build step: build docs.json"

64 putStrLn "Custom build step: build docs.json"

98− buildDocs lbi

65+ buildDocs

99− removeDirectoryRecursive (tempDir lbi)

66+ removeDirectoryRecursive tempDir

100 removeDirectoryRecursive ("libraries" </> "docs")

67 removeDirectoryRecursive ("libraries" </> "docs")

101− postBuild simpleUserHooks as bfs pd lbi

68+ postBuild simpleUserHooks args flags packageDescription lbi

102

69

103

70

104compileLibraries lbi = do

71compileLibraries lbi = do

105− let temp = tempDir lbi -- temp

106− rts = rtsDir lbi -- data

107− createDirectoryIfMissing True temp

72+ createDirectoryIfMissing True tempDir

108− createDirectoryIfMissing True rts

73+ createDirectoryIfMissing True assetsDir

109− out_c <- canonicalizePath temp -- temp (root folder)

74+ out_c <- canonicalizePath tempDir -- temp (root folder)

110 elm_c <- canonicalizePath (elm lbi) -- dist/build/elm/elm

75 elm_c <- canonicalizePath (elm lbi) -- dist/build/elm/elm

111 doc_c <- canonicalizePath (document lbi) -- dist/build/elm-doc/elm-doc

76 doc_c <- canonicalizePath (document lbi) -- dist/build/elm-doc/elm-doc

112− rtd_c <- canonicalizePath rts -- data

77+ rtd_c <- canonicalizePath assetsDir -- data

113

78

114 let make file = do

79 let make file = do

115− -- replace 'system' call with 'runProcess' which handles args better

80+ let args =

116− -- and allows env variable "Elm_datadir" which is used by LoadLibraries

81+ [ "--only-js"

117− -- to find docs.json

82+ , "--make"

118− let args = [ "--only-js", "--make", "--no-prelude"

83+ , "--no-prelude"

119− , "--cache-dir="++out_c, "--build-dir="++out_c, file ]

84+ , "--cache-dir=" ++ out_c

85+ , "--build-dir=" ++ out_c

86+ , file

87+ ]

120− arg = Just [("Elm_datadir", rtd_c)]

88+ let arg = Just [("Elm_datadir", rtd_c)]

121 handle <- runProcess elm_c args Nothing arg Nothing Nothing Nothing

89 handle <- runProcess elm_c args Nothing arg Nothing Nothing Nothing

122− exitCode <- waitForProcess handle

90+ _exitCode <- waitForProcess handle

123 return ( out_c </> replaceExtension file "elmo"

91 return ( out_c </> replaceExtension file "elmo"

124− , out_c </> replaceExtension file "elmi")

92+ , out_c </> replaceExtension file "elmi"

93+ )

125

94

126 setCurrentDirectory "libraries"

95 setCurrentDirectory "libraries"

127 paths <- getFiles ".elm" "."

96 paths <- getFiles ".elm" "."

@@ -130,11 +99,10 @@ compileLibraries lbi = do

130 setCurrentDirectory ".."

99 setCurrentDirectory ".."

131 return files

100 return files

132

101

133−buildInterfaces :: LocalBuildInfo -> [FilePath] -> IO ()

102+buildInterfaces :: [FilePath] -> IO ()

134−buildInterfaces lbi elmis = do

103+buildInterfaces elmis = do

135− createDirectoryIfMissing True (rtsDir lbi)

104+ createDirectoryIfMissing True assetsDir

136− let ifaces = interfaces lbi

137− ifaceHandle <- openBinaryFile ifaces WriteMode

105+ ifaceHandle <- openBinaryFile interfaces WriteMode

138 BS.hPut ifaceHandle (Binary.encode (length elmis))

106 BS.hPut ifaceHandle (Binary.encode (length elmis))

139 let append file = do

107 let append file = do

140 handle <- openBinaryFile file ReadMode

108 handle <- openBinaryFile file ReadMode

@@ -144,27 +112,26 @@ buildInterfaces lbi elmis = do

144 mapM_ append elmis

112 mapM_ append elmis

145 hClose ifaceHandle

113 hClose ifaceHandle

146

114

147−buildRuntime :: LocalBuildInfo -> [FilePath] -> IO ()

115+buildRuntime :: [FilePath] -> IO ()

148−buildRuntime lbi elmos = do

116+buildRuntime elmos = do

149− createDirectoryIfMissing True (rtsDir lbi)

117+ createDirectoryIfMissing True assetsDir

150− let rts' = rts lbi

118+ writeFile runtime

151− writeFile rts' "'use strict';\n\

119+ "'use strict';\n\

152− \var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\

120+ \var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\

153− \var ElmRuntime = {}; ElmRuntime.Render = {};\n"

121+ \var ElmRuntime = {}; ElmRuntime.Render = {};\n"

154− mapM_ (appendTo rts') =<< getFiles ".js" "libraries"

122+ mapM_ (appendTo runtime) =<< getFiles ".js" "libraries"

155− mapM_ (appendTo rts') elmos

123+ mapM_ (appendTo runtime) elmos

156− mapM_ (appendTo rts') =<< getFiles ".js" "runtime"

124+ mapM_ (appendTo runtime) =<< getFiles ".js" "runtime"

157−

125+

158−buildDocs :: LocalBuildInfo -> IO ()

126+buildDocs :: IO ()

159−buildDocs lbi = do

127+buildDocs = do

160− createDirectoryIfMissing True (rtsDir lbi)

128+ createDirectoryIfMissing True assetsDir

161− let docs' = docs lbi

162− writeFile docs' "[\n"

129+ writeFile docs "[\n"

163 json <- getFiles ".json" ("libraries" </> "docs")

130 json <- getFiles ".json" ("libraries" </> "docs")

164− let appends = map (appendTo docs') json

131+ let appends = map (appendTo docs) json

165− addCommas = List.intersperse (appendFile docs' ",\n")

132+ addCommas = List.intersperse (appendFile docs ",\n")

166 sequence_ (addCommas appends)

133 sequence_ (addCommas appends)

167− appendFile docs' "\n]"

134+ appendFile docs "\n]"

168

135

169getFiles ext dir = do

136getFiles ext dir = do

170 contents <- map (dir </>) `fmap` getDirectoryContents dir

137 contents <- map (dir </>) `fmap` getDirectoryContents dir

automatondeleted−1

Submodule changed.

changelog.md+37−1

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

1

2+## 0.13

3+

4+#### Improvements:

5+

6+ * Type aliases in port types

7+ * Add Keyboard.alt and Keyboard.meta

8+ * Add Debug.crash, Debug.watch, Debug.watchSummary, and Debug.trace

9+ * Add List.indexedMap and List.filterMap

10+ * Add Maybe.map

11+ * Add Basics.negate

12+ * Add (>>) to Basics as in F#

13+ * Add --bundle-runtime flag which creates stand-alone Elm programs

14+ * Error on ambiguious use of imported variables

15+ * Replace dependency on Pandoc with cheapskate+kate

16+ * Better architecture for compiler. Uses types to make compilation pipeline

17+ safer, setting things up for giving programmatic access to the AST to

18+ improve editor and IDE support.

19+

20+#### Breaking Changes:

21+

22+ * Rename (.) to (<<) as in F#

23+ * Rename Basics.id to Basics.identity

24+ * Rename Basics.div to (//)

25+ * Rename Basics.mod to (%)

26+ * Remove Maybe.justs for (List.filterMap identity)

27+ * Remove List.and for (List.foldl (&&) True)

28+ * Remove List.or for (List.foldl (||) False)

29+ * Unambiguous syntax for importing ADTs and type aliases

30+ * sqrt and logBase both only work on Floats now

31+

32+## 0.12.3

33+

34+ * Minor changes to support webgl as a separate library

35+ * Switch from HSV to HSL

36+ * Programmatic access to colors with toHsl and toRgb

37+

2## 0.12.1

38## 0.12.1

3

39

4−## Improvements:

40+#### Improvements:

5

41

6 * New Array library (thanks entirely to @Xashili)

42 * New Array library (thanks entirely to @Xashili)

7 * Json.Value can flow through ports

43 * Json.Value can flow through ports

compiler/SourceSyntax/Annotation.hs → compiler/AST/Annotation.hsrenamed+2−2

@@ -1,9 +1,9 @@

1{-# OPTIONS_GHC -W #-}

2−module SourceSyntax.Annotation where

2+module AST.Annotation where

3

4import qualified Text.Parsec.Pos as Parsec

5import qualified Text.PrettyPrint as P

6−import SourceSyntax.PrettyPrint

6+import AST.PrettyPrint

7

8data Annotated annotation expr = A annotation expr

9 deriving (Show)

compiler/SourceSyntax/Declaration.hs → compiler/AST/Declaration.hsrenamed+27−20

@@ -1,16 +1,19 @@

1{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Declaration where

2+module AST.Declaration where

3

4import Data.Binary

5−import qualified SourceSyntax.Expression as Expr

5+import qualified AST.Expression.Source as Source

6+import qualified AST.Expression.Valid as Valid

7+import qualified AST.Expression.Canonical as Canonical

6−import qualified SourceSyntax.Type as T

8+import qualified AST.Type as T

9+import qualified AST.Variable as Var

7−import SourceSyntax.PrettyPrint

10+import AST.PrettyPrint

8import Text.PrettyPrint as P

11import Text.PrettyPrint as P

9

12

10−data Declaration' port def

13+data Declaration' port def var

11 = Definition def

14 = Definition def

12− | Datatype String [String] [(String,[T.Type])]

15+ | Datatype String [String] [(String, [T.Type var])]

13− | TypeAlias String [String] T.Type

16+ | TypeAlias String [String] (T.Type var)

14 | Port port

17 | Port port

15 | Fixity Assoc Int String

18 | Fixity Assoc Int String

16 deriving (Show)

19 deriving (Show)

@@ -18,25 +21,28 @@ data Declaration' port def

18data Assoc = L | N | R

21data Assoc = L | N | R

19 deriving (Eq)

22 deriving (Eq)

20

23

21−data ParsePort

24+data RawPort

22− = PPAnnotation String T.Type

25+ = PPAnnotation String T.RawType

23− | PPDef String Expr.ParseExpr

26+ | PPDef String Source.Expr

24 deriving (Show)

27 deriving (Show)

25

28

26−data Port

29+data Port expr var

27− = Out String Expr.Expr T.Type

30+ = Out String expr (T.Type var)

28− | In String T.Type

31+ | In String (T.Type var)

29 deriving (Show)

32 deriving (Show)

30

33

34+type SourceDecl = Declaration' RawPort Source.Def Var.Raw

35+type ValidDecl = Declaration' (Port Valid.Expr Var.Raw) Valid.Def Var.Raw

36+type CanonicalDecl = Declaration' (Port Canonical.Expr Var.Canonical)

37+ Canonical.Def

38+ Var.Canonical

39+

31−portName :: Port -> String

40+portName :: Port expr var -> String

32portName port =

41portName port =

33 case port of

42 case port of

34 Out name _ _ -> name

43 Out name _ _ -> name

35 In name _ -> name

44 In name _ -> name

36

45

37−type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

38−type Declaration = Declaration' Port Expr.Def

39−

40instance Show Assoc where

46instance Show Assoc where

41 show assoc =

47 show assoc =

42 case assoc of

48 case assoc of

@@ -54,7 +60,8 @@ instance Binary Assoc where

54

60

55 put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }

61 put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }

56

62

63+instance (Pretty port, Pretty def, Pretty var, Var.ToString var) =>

57−instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where

64+ Pretty (Declaration' port def var) where

58 pretty decl =

65 pretty decl =

59 case decl of

66 case decl of

60 Definition def -> pretty def

67 Definition def -> pretty def

@@ -81,13 +88,13 @@ instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where

81 N -> P.empty

88 N -> P.empty

82 R -> P.text "r"

89 R -> P.text "r"

83

90

84−instance Pretty ParsePort where

91+instance Pretty RawPort where

85 pretty port =

92 pretty port =

86 case port of

93 case port of

87 PPAnnotation name tipe -> prettyPort name ":" tipe

94 PPAnnotation name tipe -> prettyPort name ":" tipe

88 PPDef name expr -> prettyPort name "=" expr

95 PPDef name expr -> prettyPort name "=" expr

89

96

90−instance Pretty Port where

97+instance (Pretty expr, Pretty var, Var.ToString var) => Pretty (Port expr var) where

91 pretty port =

98 pretty port =

92 case port of

99 case port of

93 In name tipe -> prettyPort name ":" tipe

100 In name tipe -> prettyPort name ":" tipe

compiler/AST/Expression/Canonical.hsnew file+30

@@ -0,0 +1,30 @@

1+{-# OPTIONS_GHC -Wall #-}

2+

3+module AST.Expression.Canonical where

4+

5+import AST.PrettyPrint

6+import Text.PrettyPrint as P

7+import qualified AST.Expression.General as General

8+import AST.Type (CanonicalType)

9+import qualified AST.Annotation as Annotation

10+import qualified AST.Pattern as Pattern

11+import qualified AST.Variable as Var

12+

13+

14+{-| Canonicalized expressions. All variables are fully resolved to the module

15+they came from.

16+-}

17+type Expr = General.Expr Annotation.Region Def Var.Canonical

18+type Expr' = General.Expr' Annotation.Region Def Var.Canonical

19+

20+data Def = Definition Pattern.CanonicalPattern Expr (Maybe CanonicalType)

21+ deriving (Show)

22+

23+instance Pretty Def where

24+ pretty (Definition pattern expr maybeTipe) =

25+ P.vcat [ annotation, definition ]

26+ where

27+ definition = pretty pattern <+> P.equals <+> pretty expr

28+ annotation = case maybeTipe of

29+ Nothing -> P.empty

30+ Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

compiler/SourceSyntax/Expression.hs → compiler/AST/Expression/General.hsrenamed+50−87

@@ -6,16 +6,17 @@ The others are specialized versions of the AST that represent specific phases

6of the compilation process. I expect there to be more phases as we begin to

7enrich the AST with more information.

8-}

9−module SourceSyntax.Expression where

9+module AST.Expression.General where

10

11−import SourceSyntax.PrettyPrint

11+import AST.PrettyPrint

12import Text.PrettyPrint as P

13−import qualified SourceSyntax.Helpers as Help

13+import AST.Type (Type)

14+

15+import qualified AST.Annotation as Annotation

16+import qualified AST.Helpers as Help

14−import qualified SourceSyntax.Annotation as Annotation

17+import qualified AST.Literal as Literal

15−import qualified SourceSyntax.Pattern as Pattern

18+import qualified AST.Pattern as Pattern

16−import qualified SourceSyntax.Type as SrcType

19+import qualified AST.Variable as Var

17−import qualified SourceSyntax.Literal as Literal

18−import qualified SourceSyntax.Variable as Variable

19

20

20---- GENERAL AST ----

21---- GENERAL AST ----

21

22

@@ -34,80 +35,57 @@ move through the compilation process. The type holes are used to represent:

34 with information about what module a variable came from.

35 with information about what module a variable came from.

35

36

36-}

37-}

37−type GeneralExpr annotation definition variable =

38+type Expr annotation definition variable =

38− Annotation.Annotated annotation (GeneralExpr' annotation definition variable)

39+ Annotation.Annotated annotation (Expr' annotation definition variable)

39

40

40−data GeneralExpr' ann def var

41+data Expr' ann def var

41 = Literal Literal.Literal

42 = Literal Literal.Literal

42 | Var var

43 | Var var

43− | Range (GeneralExpr ann def var) (GeneralExpr ann def var)

44+ | Range (Expr ann def var) (Expr ann def var)

44− | ExplicitList [GeneralExpr ann def var]

45+ | ExplicitList [Expr ann def var]

45− | Binop String (GeneralExpr ann def var) (GeneralExpr ann def var)

46+ | Binop var (Expr ann def var) (Expr ann def var)

46− | Lambda Pattern.Pattern (GeneralExpr ann def var)

47+ | Lambda (Pattern.Pattern var) (Expr ann def var)

47− | App (GeneralExpr ann def var) (GeneralExpr ann def var)

48+ | App (Expr ann def var) (Expr ann def var)

48− | MultiIf [(GeneralExpr ann def var,GeneralExpr ann def var)]

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

49− | Let [def] (GeneralExpr ann def var)

50+ | Let [def] (Expr ann def var)

50− | Case (GeneralExpr ann def var) [(Pattern.Pattern, GeneralExpr ann def var)]

51+ | Case (Expr ann def var) [(Pattern.Pattern var, Expr ann def var)]

51− | Data String [GeneralExpr ann def var]

52+ | Data String [Expr ann def var]

52− | Access (GeneralExpr ann def var) String

53+ | Access (Expr ann def var) String

53− | Remove (GeneralExpr ann def var) String

54+ | Remove (Expr ann def var) String

54− | Insert (GeneralExpr ann def var) String (GeneralExpr ann def var)

55+ | Insert (Expr ann def var) String (Expr ann def var)

55− | Modify (GeneralExpr ann def var) [(String, GeneralExpr ann def var)]

56+ | Modify (Expr ann def var) [(String, Expr ann def var)]

56− | Record [(String, GeneralExpr ann def var)]

57+ | Record [(String, Expr ann def var)]

57− | Markdown String String [GeneralExpr ann def var]

58+ | Markdown String String [Expr ann def var]

58 -- for type checking and code gen only

59 -- for type checking and code gen only

59− | PortIn String SrcType.Type

60+ | PortIn String (Type var)

60− | PortOut String SrcType.Type (GeneralExpr ann def var)

61+ | PortOut String (Type var) (Expr ann def var)

61 | GLShader String String Literal.GLShaderTipe

62 | GLShader String String Literal.GLShaderTipe

62 deriving (Show)

63 deriving (Show)

63

64

65

65−---- SPECIALIZED ASTs ----

66−

67−{-| Expressions created by the parser. These use a split representation of type

68−annotations and definitions, which is how they appear in source code and how

69−they are parsed.

70−-}

71−type ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw

72−type ParseExpr' = GeneralExpr' Annotation.Region ParseDef Variable.Raw

73−

74−data ParseDef

75− = Def Pattern.Pattern ParseExpr

76− | TypeAnnotation String SrcType.Type

77− deriving (Show)

78−

79−{-| "Normal" expressions. When the compiler checks that type annotations and

80−ports are all paired with definitions in the appropriate order, it collapses

81−them into a Def that is easier to work with in later phases of compilation.

82−-}

83−type Expr = GeneralExpr Annotation.Region Def Variable.Raw

84−type Expr' = GeneralExpr' Annotation.Region Def Variable.Raw

85−

86−data Def = Definition Pattern.Pattern Expr (Maybe SrcType.Type)

87− deriving (Show)

88−

89−

90−

91---- UTILITIES ----

66---- UTILITIES ----

92

67

93−rawVar :: String -> GeneralExpr' ann def Variable.Raw

68+rawVar :: String -> Expr' ann def Var.Raw

94−rawVar x = Var (Variable.Raw x)

69+rawVar x = Var (Var.Raw x)

70+

71+localVar :: String -> Expr' ann def Var.Canonical

72+localVar x = Var (Var.Canonical Var.Local x)

95

73

96−tuple :: [GeneralExpr ann def var] -> GeneralExpr' ann def var

74+tuple :: [Expr ann def var] -> Expr' ann def var

97tuple es = Data ("_Tuple" ++ show (length es)) es

75tuple es = Data ("_Tuple" ++ show (length es)) es

98

76

99−delist :: GeneralExpr ann def var -> [GeneralExpr ann def var]

77+delist :: Expr ann def var -> [Expr ann def var]

100delist (Annotation.A _ (Data "::" [h,t])) = h : delist t

78delist (Annotation.A _ (Data "::" [h,t])) = h : delist t

101delist _ = []

79delist _ = []

102

80

103saveEnvName :: String

81saveEnvName :: String

104saveEnvName = "_save_the_environment!!!"

82saveEnvName = "_save_the_environment!!!"

105

83

106−dummyLet :: (Pretty def) => [def] -> GeneralExpr Annotation.Region def Variable.Raw

84+dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical

107dummyLet defs =

85dummyLet defs =

108− Annotation.none $ Let defs (Annotation.none $ rawVar saveEnvName)

86+ Annotation.none $ Let defs (Annotation.none $ Var (Var.builtin saveEnvName))

109

87

110−instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where

88+instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where

111 pretty expr =

89 pretty expr =

112 case expr of

90 case expr of

113 Literal lit -> pretty lit

91 Literal lit -> pretty lit

@@ -118,12 +96,14 @@ instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where

118

96

119 ExplicitList es -> P.brackets (commaCat (map pretty es))

97 ExplicitList es -> P.brackets (commaCat (map pretty es))

120

98

121− Binop "-" (Annotation.A _ (Literal (Literal.IntNum 0))) e ->

99+ Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) e

100+ | Var.toString op == "-" ->

122− P.text "-" <> prettyParens e

101+ P.text "-" <> prettyParens e

123

102

124− Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]

103+ Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op'', prettyParens e2 ]

125 where

104 where

105+ op' = Var.toString op

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

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

127

107

128 Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body

108 Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body

129 where

109 where

@@ -179,36 +159,19 @@ instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where

179

159

180 Markdown _ _ _ -> P.text "[markdown| ... |]"

160 Markdown _ _ _ -> P.text "[markdown| ... |]"

181

161

182− GLShader _ _ _ -> P.text "[glShader| ... |]"

162+ GLShader _ _ _ -> P.text "[glsl| ... |]"

183

163

184 PortIn name _ -> P.text $ "<port:" ++ name ++ ">"

164 PortIn name _ -> P.text $ "<port:" ++ name ++ ">"

185

165

186 PortOut _ _ signal -> pretty signal

166 PortOut _ _ signal -> pretty signal

187

167

188−instance Pretty ParseDef where

189− pretty def =

190− case def of

191− TypeAnnotation name tipe ->

192− variable name <+> P.colon <+> pretty tipe

193− Def pattern expr ->

194− pretty pattern <+> P.equals <+> pretty expr

195−

196−instance Pretty Def where

197− pretty (Definition pattern expr maybeTipe) =

198− P.vcat [ annotation, definition ]

199− where

200− definition = pretty pattern <+> P.equals <+> pretty expr

201− annotation = case maybeTipe of

202− Nothing -> P.empty

203− Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

204−

205−collectApps :: GeneralExpr ann def var -> [GeneralExpr ann def var]

168+collectApps :: Expr ann def var -> [Expr ann def var]

206collectApps annExpr@(Annotation.A _ expr) =

169collectApps annExpr@(Annotation.A _ expr) =

207 case expr of

170 case expr of

208 App a b -> collectApps a ++ [b]

171 App a b -> collectApps a ++ [b]

209 _ -> [annExpr]

172 _ -> [annExpr]

210

173

211−collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)

174+collectLambdas :: Expr ann def var -> ([Pattern.Pattern var], Expr ann def var)

212collectLambdas lexpr@(Annotation.A _ expr) =

175collectLambdas lexpr@(Annotation.A _ expr) =

213 case expr of

176 case expr of

214 Lambda pattern body ->

177 Lambda pattern body ->

@@ -217,7 +180,7 @@ collectLambdas lexpr@(Annotation.A _ expr) =

217

180

218 _ -> ([], lexpr)

181 _ -> ([], lexpr)

219

182

220−prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc

183+prettyParens :: (Pretty def, Pretty var, Var.ToString var) => Expr ann def var -> Doc

221prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)

184prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)

222 where

185 where

223 needed =

186 needed =

@@ -228,5 +191,5 @@ prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)

228 MultiIf _ -> True

191 MultiIf _ -> True

229 Let _ _ -> True

192 Let _ _ -> True

230 Case _ _ -> True

193 Case _ _ -> True

231− Data name (_:_) -> name /= "::"

194+ Data name (_:_) -> not (name == "::" || Help.isTuple name)

232 _ -> False

195 _ -> False

compiler/AST/Expression/Source.hsnew file+32

@@ -0,0 +1,32 @@

1+{-# OPTIONS_GHC -Wall #-}

2+

3+module AST.Expression.Source where

4+

5+import AST.PrettyPrint

6+import Text.PrettyPrint as P

7+import qualified AST.Expression.General as General

8+import AST.Type (RawType)

9+import qualified AST.Variable as Var

10+import qualified AST.Annotation as Annotation

11+import qualified AST.Pattern as Pattern

12+

13+

14+{-| Expressions created by the parser. These use a split representation of type

15+annotations and definitions, which is how they appear in source code and how

16+they are parsed.

17+-}

18+type Expr = General.Expr Annotation.Region Def Var.Raw

19+type Expr' = General.Expr' Annotation.Region Def Var.Raw

20+

21+data Def

22+ = Definition Pattern.RawPattern Expr

23+ | TypeAnnotation String RawType

24+ deriving (Show)

25+

26+instance Pretty Def where

27+ pretty def =

28+ case def of

29+ TypeAnnotation name tipe ->

30+ variable name <+> P.colon <+> pretty tipe

31+ Definition pattern expr ->

32+ pretty pattern <+> P.equals <+> pretty expr

compiler/AST/Expression/Valid.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# OPTIONS_GHC -Wall #-}

2+

3+module AST.Expression.Valid where

4+

5+import AST.PrettyPrint

6+import Text.PrettyPrint as P

7+import qualified AST.Expression.General as General

8+import AST.Type (RawType)

9+import qualified AST.Variable as Var

10+import qualified AST.Annotation as Annotation

11+import qualified AST.Pattern as Pattern

12+

13+

14+{-| "Normal" expressions. When the compiler checks that type annotations and

15+ports are all paired with definitions in the appropriate order, it collapses

16+them into a Def that is easier to work with in later phases of compilation.

17+-}

18+type Expr = General.Expr Annotation.Region Def Var.Raw

19+type Expr' = General.Expr' Annotation.Region Def Var.Raw

20+

21+data Def = Definition Pattern.RawPattern Expr (Maybe RawType)

22+ deriving (Show)

23+

24+instance Pretty Def where

25+ pretty (Definition pattern expr maybeTipe) =

26+ P.vcat [ annotation, definition ]

27+ where

28+ definition = pretty pattern <+> P.equals <+> pretty expr

29+ annotation = case maybeTipe of

30+ Nothing -> P.empty

31+ Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

compiler/SourceSyntax/Helpers.hs → compiler/AST/Helpers.hsrenamed+1−1

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

1{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Helpers where

2+module AST.Helpers where

3

4import qualified Data.Char as Char

5

compiler/SourceSyntax/Literal.hs → compiler/AST/Literal.hsrenamed+2−2

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

1{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Literal where

2+module AST.Literal where

3

4+import AST.PrettyPrint

4import Data.Map (Map)

5import Data.Map (Map)

5−import SourceSyntax.PrettyPrint

6import qualified Text.PrettyPrint as PP

7

8data Literal = IntNum Int

compiler/AST/Module.hsnew file+128

@@ -0,0 +1,128 @@

1+{-# OPTIONS_GHC -W #-}

2+module AST.Module where

3+

4+import Data.Binary

5+import qualified Data.List as List

6+import qualified Data.Map as Map

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

8+

9+import qualified AST.Expression.Canonical as Canonical

10+import qualified AST.Declaration as Decl

11+import qualified AST.Type as Type

12+import qualified AST.Variable as Var

13+

14+import AST.PrettyPrint

15+import Text.PrettyPrint as P

16+

17+import qualified Elm.Internal.Version as Version

18+

19+data Module exs body = Module

20+ { names :: [String]

21+ , path :: FilePath

22+ , exports :: exs

23+ , imports :: [(String, ImportMethod)]

24+ , body :: body

25+ }

26+

27+getName :: Module exs body -> String

28+getName modul =

29+ List.intercalate "." (names modul)

30+

31+data CanonicalBody = CanonicalBody

32+ { program :: Canonical.Expr

33+ , types :: Types

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

35+ , aliases :: Aliases

36+ , datatypes :: ADTs

37+ , ports :: [String]

38+ }

39+

40+type SourceModule = Module (Var.Listing Var.Value) [Decl.SourceDecl]

41+type ValidModule = Module (Var.Listing Var.Value) [Decl.ValidDecl]

42+type CanonicalModule = Module [Var.Value] CanonicalBody

43+

44+type Interfaces = Map.Map String Interface

45+

46+type Types = Map.Map String Type.CanonicalType

47+type Aliases = Map.Map String ( [String], Type.CanonicalType )

48+type ADTs = Map.Map String (AdtInfo String)

49+

50+type AdtInfo v = ( [String], [(v, [Type.CanonicalType])] )

51+type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical)

52+

53+data Interface = Interface

54+ { iVersion :: Version.Version

55+ , iExports :: [Var.Value]

56+ , iTypes :: Types

57+ , iImports :: [(String, ImportMethod)]

58+ , iAdts :: ADTs

59+ , iAliases :: Aliases

60+ , iFixities :: [(Decl.Assoc, Int, String)]

61+ , iPorts :: [String]

62+ }

63+

64+toInterface :: CanonicalModule -> Interface

65+toInterface modul =

66+ let body' = body modul in

67+ Interface

68+ { iVersion = Version.elmVersion

69+ , iExports = exports modul

70+ , iTypes = types body'

71+ , iImports = imports modul

72+ , iAdts = datatypes body'

73+ , iAliases = aliases body'

74+ , iFixities = fixities body'

75+ , iPorts = ports body'

76+ }

77+

78+instance Binary Interface where

79+ get = Interface <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get

80+ put modul = do

81+ put (iVersion modul)

82+ put (iExports modul)

83+ put (iTypes modul)

84+ put (iImports modul)

85+ put (iAdts modul)

86+ put (iAliases modul)

87+ put (iFixities modul)

88+ put (iPorts modul)

89+

90+data ImportMethod

91+ = As !String

92+ | Open !(Var.Listing Var.Value)

93+

94+open :: ImportMethod

95+open = Open (Var.openListing)

96+

97+importing :: [Var.Value] -> ImportMethod

98+importing xs = Open (Var.Listing xs False)

99+

100+instance Binary ImportMethod where

101+ put method =

102+ case method of

103+ As alias -> putWord8 0 >> put alias

104+ Open listing -> putWord8 1 >> put listing

105+

106+ get = do tag <- getWord8

107+ case tag of

108+ 0 -> As <$> get

109+ 1 -> Open <$> get

110+ _ -> error "Error reading valid ImportMethod type from serialized string"

111+

112+instance (Pretty exs, Pretty body) => Pretty (Module exs body) where

113+ pretty (Module names _ exs ims body) =

114+ P.vcat [modul, P.text "", prettyImports, P.text "", pretty body]

115+ where

116+ modul = P.text "module" <+> name <+> pretty exs <+> P.text "where"

117+ name = P.text (List.intercalate "." names)

118+

119+ prettyImports = P.vcat $ map prettyMethod ims

120+

121+prettyMethod :: (String, ImportMethod) -> Doc

122+prettyMethod (name, method) =

123+ case method of

124+ As alias

125+ | name == alias -> P.empty

126+ | otherwise -> P.text "as" <+> P.text alias

127+

128+ Open listing -> pretty listing

compiler/AST/Pattern.hsnew file+79

@@ -0,0 +1,79 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module AST.Pattern where

3+

4+import qualified AST.Helpers as Help

5+import AST.PrettyPrint

6+import Text.PrettyPrint as PP

7+import qualified Data.Set as Set

8+

9+import qualified AST.Variable as Var

10+import AST.Literal as Literal

11+

12+data Pattern var

13+ = Data var [Pattern var]

14+ | Record [String]

15+ | Alias String (Pattern var)

16+ | Var String

17+ | Anything

18+ | Literal Literal.Literal

19+ deriving (Eq, Ord, Show)

20+

21+type RawPattern = Pattern Var.Raw

22+type CanonicalPattern = Pattern Var.Canonical

23+

24+cons :: RawPattern -> RawPattern -> RawPattern

25+cons h t = Data (Var.Raw "::") [h,t]

26+

27+nil :: RawPattern

28+nil = Data (Var.Raw "[]") []

29+

30+list :: [RawPattern] -> RawPattern

31+list = foldr cons nil

32+

33+tuple :: [RawPattern] -> RawPattern

34+tuple es = Data (Var.Raw ("_Tuple" ++ show (length es))) es

35+

36+boundVarList :: Pattern var -> [String]

37+boundVarList = Set.toList . boundVars

38+

39+boundVars :: Pattern var -> Set.Set String

40+boundVars pattern =

41+ case pattern of

42+ Var x -> Set.singleton x

43+ Alias x p -> Set.insert x (boundVars p)

44+ Data _ ps -> Set.unions (map boundVars ps)

45+ Record fields -> Set.fromList fields

46+ Anything -> Set.empty

47+ Literal _ -> Set.empty

48+

49+

50+instance Var.ToString var => Pretty (Pattern var) where

51+ pretty pattern =

52+ case pattern of

53+ Var x -> variable x

54+ Literal lit -> pretty lit

55+ Record fs -> PP.braces (commaCat $ map variable fs)

56+ Alias x p -> prettyParens p <+> PP.text "as" <+> variable x

57+ Anything -> PP.text "_"

58+ Data name [hd,tl] | Var.toString name == "::" ->

59+ parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl

60+ where

61+ isCons = case hd of

62+ Data ctor _ -> Var.toString ctor == "::"

63+ _ -> False

64+

65+ Data name ps

66+ | Help.isTuple name' -> PP.parens . commaCat $ map pretty ps

67+ | otherwise -> hsep (PP.text name' : map prettyParens ps)

68+ where

69+ name' = Var.toString name

70+

71+prettyParens :: Var.ToString var => Pattern var -> Doc

72+prettyParens pattern =

73+ parensIf needsThem (pretty pattern)

74+ where

75+ needsThem =

76+ case pattern of

77+ Data name (_:_) | not (Help.isTuple (Var.toString name)) -> True

78+ Alias _ _ -> True

79+ _ -> False

compiler/SourceSyntax/PrettyPrint.hs → compiler/AST/PrettyPrint.hsrenamed+14−11

@@ -1,14 +1,18 @@

1+{-# LANGUAGE FlexibleInstances #-}

2+module AST.PrettyPrint where

1

3

2−module SourceSyntax.PrettyPrint where

4+import Control.Monad.Trans.Error

3−

4−import Text.PrettyPrint

5+import Text.PrettyPrint as P

5−import qualified SourceSyntax.Helpers as Help

6+import qualified AST.Helpers as Help

6

7

7class Pretty a where

8class Pretty a where

8 pretty :: a -> Doc

9 pretty :: a -> Doc

9

10

10−instance Pretty () where

11+instance Pretty Doc where

11− pretty () = empty

12+ pretty doc = doc

13+

14+instance Pretty String where

15+ pretty = P.text

12

16

13renderPretty :: (Pretty a) => a -> String

17renderPretty :: (Pretty a) => a -> String

14renderPretty e = render (pretty e)

18renderPretty e = render (pretty e)

@@ -21,11 +25,7 @@ parensIf bool doc = if bool then parens doc else doc

21

25

22variable :: String -> Doc

26variable :: String -> Doc

23variable x =

27variable x =

24− if Help.isOp x then parens (text x)

28+ if Help.isOp x then parens (text x) else text x

25− else text (reprime x)

26−

27−reprime :: String -> String

28−reprime = map (\c -> if c == '$' then '\'' else c)

29

30eightyCharLines :: Int -> String -> String

31eightyCharLines indent message = answer

@@ -37,3 +37,6 @@ eightyCharLines indent message = answer

37 step (sentence, slen, space) (word, wlen)

38 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")

39 | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")

40+

41+instance ErrorList Doc where

42+ listMsg str = [ P.text str ]

compiler/AST/Type.hsnew file+138

@@ -0,0 +1,138 @@

1+{-# OPTIONS_GHC -W #-}

2+module AST.Type where

3+

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

5+import Data.Binary

6+import qualified Data.Map as Map

7+

8+import qualified AST.Variable as Var

9+import AST.PrettyPrint

10+import qualified AST.Helpers as Help

11+import Text.PrettyPrint as P

12+

13+data Type var

14+ = Lambda (Type var) (Type var)

15+ | Var String

16+ | Type var

17+ | App (Type var) [Type var]

18+ | Record [(String, Type var)] (Maybe (Type var))

19+ | Aliased Var.Canonical (Type var)

20+ deriving (Eq,Show)

21+

22+type RawType = Type Var.Raw

23+type CanonicalType = Type Var.Canonical

24+

25+fieldMap :: [(String,a)] -> Map.Map String [a]

26+fieldMap fields =

27+ foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields

28+

29+recordOf :: [(String, Type var)] -> Type var

30+recordOf fields = Record fields Nothing

31+

32+listOf :: RawType -> RawType

33+listOf t = App (Type (Var.Raw "_List")) [t]

34+

35+tupleOf :: [RawType] -> RawType

36+tupleOf ts = App (Type t) ts

37+ where

38+ t = Var.Raw ("_Tuple" ++ show (length ts))

39+

40+instance (Var.ToString var, Pretty var) => Pretty (Type var) where

41+ pretty tipe =

42+ case tipe of

43+ Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

44+ where

45+ t:ts = map prettyLambda (collectLambdas tipe)

46+ prettyLambda t = case t of

47+ Lambda _ _ -> P.parens (pretty t)

48+ _ -> pretty t

49+

50+ Var x -> P.text x

51+

52+ Type var ->

53+ let v = Var.toString var in

54+ P.text (if v == "_Tuple0" then "()" else v)

55+

56+ App f args ->

57+ case (f,args) of

58+ (Type name, [t])

59+ | Var.toString name == "_List" -> P.brackets (pretty t)

60+

61+ (Type name, _)

62+ | Help.isTuple (Var.toString name) ->

63+ P.parens . P.sep . P.punctuate P.comma $ map pretty args

64+

65+ _ -> P.hang (pretty f) 2 (P.sep $ map prettyParens args)

66+

67+ Record _ _ ->

68+ P.braces $ case flattenRecord tipe of

69+ (fields, Nothing) -> prettyFields fields

70+ (fields, Just x) ->

71+ P.hang (P.text x <+> P.text "|") 4 (prettyFields fields)

72+ where

73+ prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

74+ prettyFields fields = commaSep (map prettyField fields)

75+

76+ Aliased name t ->

77+ let t' = pretty t in

78+ if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]

79+ then t'

80+ else pretty name

81+

82+collectLambdas :: Type var -> [Type var]

83+collectLambdas tipe =

84+ case tipe of

85+ Lambda arg body -> arg : collectLambdas body

86+ _ -> [tipe]

87+

88+prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc

89+prettyParens tipe = parensIf (needed tipe) (pretty tipe)

90+ where

91+ needed t =

92+ case t of

93+ Aliased _ t' -> needed t'

94+

95+ Lambda _ _ -> True

96+

97+ App (Type name) [_] | Var.toString name == "_List" -> False

98+ App (Type name) _ | Help.isTuple (Var.toString name) -> False

99+ App t' [] -> needed t'

100+ App _ _ -> True

101+

102+ _ -> False

103+

104+flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )

105+flattenRecord tipe =

106+ case tipe of

107+ Var x -> ([], Just x)

108+

109+ Record fields Nothing -> (fields, Nothing)

110+

111+ Record fields (Just ext) ->

112+ let (fields',ext') = flattenRecord ext

113+ in (fields' ++ fields, ext')

114+

115+ Aliased _ tipe' -> flattenRecord tipe'

116+

117+ _ -> error "Trying to flatten ill-formed record."

118+

119+instance Binary var => Binary (Type var) where

120+ put tipe =

121+ case tipe of

122+ Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2

123+ Var x -> putWord8 1 >> put x

124+ Type name -> putWord8 2 >> put name

125+ App t1 t2 -> putWord8 3 >> put t1 >> put t2

126+ Record fs ext -> putWord8 4 >> put fs >> put ext

127+ Aliased var t -> putWord8 5 >> put var >> put t

128+

129+ get = do

130+ n <- getWord8

131+ case n of

132+ 0 -> Lambda <$> get <*> get

133+ 1 -> Var <$> get

134+ 2 -> Type <$> get

135+ 3 -> App <$> get <*> get

136+ 4 -> Record <$> get <*> get

137+ 5 -> Aliased <$> get <*> get

138+ _ -> error "Error reading a valid type from serialized string"

compiler/AST/Variable.hsnew file+152

@@ -0,0 +1,152 @@

1+{-# OPTIONS_GHC -W #-}

2+module AST.Variable where

3+

4+import Data.Binary

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

6+import Text.PrettyPrint as P

7+import qualified AST.Helpers as Help

8+import AST.PrettyPrint

9+

10+newtype Raw = Raw String

11+ deriving (Eq,Ord,Show)

12+

13+data Home

14+ = BuiltIn

15+ | Module !String

16+ | Local

17+ deriving (Eq,Ord,Show)

18+

19+data Canonical = Canonical

20+ { home :: !Home

21+ , name :: !String

22+ } deriving (Eq,Ord,Show)

23+

24+local :: String -> Canonical

25+local x = Canonical Local x

26+

27+builtin :: String -> Canonical

28+builtin x = Canonical BuiltIn x

29+

30+-- To help with pattern matching on some common canonical variables:

31+is :: String -> String -> Canonical -> Bool

32+is home name var =

33+ var == Canonical (Module home) name

34+

35+isJson :: Canonical -> Bool

36+isJson = is "Json" "Value"

37+

38+isMaybe :: Canonical -> Bool

39+isMaybe = is "Maybe" "Maybe"

40+

41+isArray :: Canonical -> Bool

42+isArray = is "Array" "Array"

43+

44+isSignal :: Canonical -> Bool

45+isSignal = is "Signal" "Signal"

46+

47+isList :: Canonical -> Bool

48+isList v = v == Canonical BuiltIn "_List"

49+

50+isTuple :: Canonical -> Bool

51+isTuple v =

52+ case v of

53+ Canonical BuiltIn name -> Help.isTuple name

54+ _ -> False

55+

56+isPrimitive :: Canonical -> Bool

57+isPrimitive v =

58+ case v of

59+ Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"]

60+ _ -> False

61+

62+isPrim :: String -> Canonical -> Bool

63+isPrim prim v =

64+ case v of

65+ Canonical BuiltIn name -> name == prim

66+ _ -> False

67+

68+isText :: Canonical -> Bool

69+isText = is "Text" "Text"

70+

71+class ToString a where

72+ toString :: a -> String

73+

74+instance ToString Raw where

75+ toString (Raw x) = x

76+

77+instance ToString Canonical where

78+ toString (Canonical home name) =

79+ case home of

80+ BuiltIn -> name

81+ Module path -> path ++ "." ++ name

82+ Local -> name

83+

84+-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)

85+data Listing a = Listing

86+ { _explicits :: [a]

87+ , _open :: Bool

88+ } deriving (Eq,Ord,Show)

89+

90+openListing :: Listing a

91+openListing = Listing [] True

92+

93+-- | A value that can be imported or exported

94+data Value

95+ = Value !String

96+ | Alias !String

97+ | ADT !String !(Listing String)

98+ deriving (Eq,Ord,Show)

99+

100+instance Pretty Raw where

101+ pretty (Raw var) = variable var

102+

103+instance Pretty Canonical where

104+ pretty var = P.text (toString var)

105+

106+instance Pretty a => Pretty (Listing a) where

107+ pretty (Listing explicits open) =

108+ P.parens (commaCat (map pretty explicits ++ dots))

109+ where

110+ dots = [if open then P.text ".." else P.empty]

111+

112+instance Pretty Value where

113+ pretty portable =

114+ case portable of

115+ Value name -> P.text name

116+ Alias name -> P.text name

117+ ADT name ctors ->

118+ P.text name <> pretty (ctors { _explicits = map P.text (_explicits ctors) })

119+

120+instance Binary Canonical where

121+ put (Canonical home name) =

122+ case home of

123+ BuiltIn -> putWord8 0 >> put name

124+ Module path -> putWord8 1 >> put path >> put name

125+ Local -> putWord8 2 >> put name

126+

127+ get = do tag <- getWord8

128+ case tag of

129+ 0 -> Canonical BuiltIn <$> get

130+ 1 -> Canonical . Module <$> get <*> get

131+ 2 -> Canonical Local <$> get

132+ _ -> error "Unexpected tag when deserializing canonical variable"

133+

134+instance Binary Value where

135+ put portable =

136+ case portable of

137+ Value name -> putWord8 0 >> put name

138+ Alias name -> putWord8 1 >> put name

139+ ADT name ctors -> putWord8 2 >> put name >> put ctors

140+

141+ get = do tag <- getWord8

142+ case tag of

143+ 0 -> Value <$> get

144+ 1 -> Alias <$> get

145+ 2 -> ADT <$> get <*> get

146+ _ -> error "Error reading valid import/export information from serialized string"

147+

148+instance (Binary a) => Binary (Listing a) where

149+ put (Listing explicits open) =

150+ put explicits >> put open

151+

152+ get = Listing <$> get <*> get

compiler/Build/Dependencies.hs+1−1

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

10import System.Directory

11import System.FilePath as FP

12

13−import qualified SourceSyntax.Module as Module

13+import qualified AST.Module as Module

14import qualified Parse.Parse as Parse

15import qualified Elm.Internal.Paths as Path

16import qualified Elm.Internal.Name as N

compiler/Build/File.hs+15−17

@@ -23,8 +23,7 @@ import qualified Build.Source as Source

23import qualified Build.Utils as Utils

24import qualified Generate.JavaScript as JS

25import qualified Parse.Module as Parser

26−import qualified SourceSyntax.Module as M

26+import qualified AST.Module as Module

27−import qualified Transform.Canonicalize as Canonical

28

27

29-- Reader: Runtime flags, always accessible

28-- Reader: Runtime flags, always accessible

30-- Writer: Remember the last module to be accessed

29-- Writer: Remember the last module to be accessed

@@ -33,10 +32,10 @@ type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a

33type Build a = BuildT IO a

32type Build a = BuildT IO a

34

33

35-- Interfaces, remembering if something was recompiled

34-- Interfaces, remembering if something was recompiled

36−type BInterfaces = Map.Map String (Bool, M.ModuleInterface)

35+type BInterfaces = Map.Map String (Bool, Module.Interface)

37

36

38−evalBuild :: Flag.Flags -> M.Interfaces -> Build ()

37+evalBuild :: Flag.Flags -> Module.Interfaces -> Build ()

39− -> IO (Map.Map String M.ModuleInterface, Maybe String)

38+ -> IO (Map.Map String Module.Interface, Maybe String)

40evalBuild flags interfaces build =

39evalBuild flags interfaces build =

41 do (ifaces, moduleNames) <- execRWST build flags (fmap notUpdated interfaces)

40 do (ifaces, moduleNames) <- execRWST build flags (fmap notUpdated interfaces)

42 return (fmap snd ifaces, getLast moduleNames)

41 return (fmap snd ifaces, getLast moduleNames)

@@ -45,7 +44,7 @@ evalBuild flags interfaces build =

45

44

46-- | Builds a list of files, returning the moduleName of the last one.

45-- | Builds a list of files, returning the moduleName of the last one.

47-- Returns \"\" if the list is empty

46-- Returns \"\" if the list is empty

48−build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String

47+build :: Flag.Flags -> Module.Interfaces -> [FilePath] -> IO String

49build flags interfaces files =

48build flags interfaces files =

50 do (ifaces, topName) <- evalBuild flags interfaces (buildAll files)

49 do (ifaces, topName) <- evalBuild flags interfaces (buildAll files)

51 let removeTopName = Maybe.maybe id Map.delete topName

50 let removeTopName = Maybe.maybe id Map.delete topName

@@ -56,7 +55,7 @@ build flags interfaces files =

56 | null ports = return ()

55 | null ports = return ()

57 | otherwise = Print.failure msg

56 | otherwise = Print.failure msg

58 where

57 where

59− ports = M.iPorts iface

58+ ports = Module.iPorts iface

60 msg = concat

59 msg = concat

61 [ "Port Error: ports may only appear in the main module, but\n"

60 [ "Port Error: ports may only appear in the main module, but\n"

62 , " sub-module ", name, " declares the following port"

61 , " sub-module ", name, " declares the following port"

@@ -123,9 +122,7 @@ retrieve filePath = do

123 iface <- liftIO $ Interface.load (Utils.elmi flags filePath)

122 iface <- liftIO $ Interface.load (Utils.elmi flags filePath)

124 case Interface.isValid filePath iface of

123 case Interface.isValid filePath iface of

125 Right (name, interface) ->

124 Right (name, interface) ->

126− do binterfaces <- get

127− let interfaces = snd <$> binterfaces

128− liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)

125+ do liftIO $ when (Flag.print_types flags) (Print.types (Module.iTypes interface))

129 update name interface False

126 update name interface False

130

127

131 Left err -> liftIO $ Print.failure err

128 Left err -> liftIO $ Print.failure err

@@ -142,16 +139,17 @@ compile number filePath =

142 createDirectoryIfMissing True (Flag.cache_dir flags)

139 createDirectoryIfMissing True (Flag.cache_dir flags)

143 createDirectoryIfMissing True (Flag.build_dir flags)

140 createDirectoryIfMissing True (Flag.build_dir flags)

144

141

145− metaModule <-

142+ canonicalModule <-

146 liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of

143 liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of

147 Right modul -> return modul

144 Right modul -> return modul

148 Left errors -> do Print.errors errors

145 Left errors -> do Print.errors errors

149 exitFailure

146 exitFailure

150

147

151− liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule

148+ liftIO $ when (Flag.print_types flags) $ do

149+ Print.types (Module.types (Module.body canonicalModule))

152

150

153− let newInters = Canonical.interface name $ M.metaToInterface metaModule

151+ let newInters = Module.toInterface canonicalModule

154− generateCache name newInters metaModule

152+ generateCache name newInters canonicalModule

155 update name newInters True

153 update name newInters True

156

154

157 where

155 where

@@ -164,15 +162,15 @@ compile number filePath =

164 , replicate (max 1 (20 - length name)) ' '

162 , replicate (max 1 (20 - length name)) ' '

165 , "( " ++ filePath ++ " )" ]

163 , "( " ++ filePath ++ " )" ]

166

164

167− generateCache name interfs metaModule = do

165+ generateCache name interfs canonicalModule = do

168 flags <- ask

166 flags <- ask

169 liftIO $ do

167 liftIO $ do

170 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath

168 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath

171− writeFile (Utils.elmo flags filePath) (JS.generate metaModule)

169+ writeFile (Utils.elmo flags filePath) (JS.generate canonicalModule)

172 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->

170 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->

173 L.hPut handle (Binary.encode (name, interfs))

171 L.hPut handle (Binary.encode (name, interfs))

174

172

175−update :: String -> M.ModuleInterface -> Bool -> Build ()

173+update :: String -> Module.Interface -> Bool -> Build ()

176update name inter wasUpdated =

174update name inter wasUpdated =

177 do modify (Map.insert name (wasUpdated, inter))

175 do modify (Map.insert name (wasUpdated, inter))

178 tell (Last . Just $ name)

176 tell (Last . Just $ name)

compiler/Build/Flags.hs+27−11

@@ -9,6 +9,7 @@ data Flags = Flags

9 , files :: [FilePath]

10 , set_runtime :: Maybe FilePath

11 , get_runtime :: Bool

12+ , bundle_runtime :: Bool

12 , only_js :: Bool

13 , only_js :: Bool

13 , print_types :: Bool

14 , print_types :: Bool

14 , scripts :: [FilePath]

15 , scripts :: [FilePath]

@@ -18,29 +19,44 @@ data Flags = Flags

18 , src_dir :: [FilePath]

19 , src_dir :: [FilePath]

19 }

20 }

20 deriving (Data,Typeable,Show,Eq)

21 deriving (Data,Typeable,Show,Eq)

21−

22+

23+flags :: Flags

22flags = Flags

24flags = Flags

23 { files = def &= args &= typ "FILES"

25 { files = def &= args &= typ "FILES"

26+

24 , make = False

27 , make = False

25− &= help "automatically compile dependencies."

28+ &= help "automatically compile dependencies."

29+

26 , only_js = False

30 , only_js = False

27− &= help "Compile only to JavaScript."

31+ &= help "Compile only to JavaScript."

32+

28 , no_prelude = False

33 , no_prelude = False

29− &= help "Do not import Prelude by default, used only when compiling standard libraries."

34+ &= help "Do not import Prelude by default, used only when compiling standard libraries."

35+

30 , scripts = [] &= typFile

36 , scripts = [] &= typFile

31− &= help "Load JavaScript files in generated HTML. Files will be included in the given order."

37+ &= help "Load JavaScript files in generated HTML. Files will be included in the given order."

38+

32 , set_runtime = Nothing &= typFile

39 , set_runtime = Nothing &= typFile

33− &= help "Specify a custom location for Elm's runtime system."

40+ &= help "Specify a custom location for Elm's runtime system."

41+

34 , get_runtime = False

42 , get_runtime = False

35− &= help "Print the absolute path to the default Elm runtime."

43+ &= help "Print the absolute path to the default Elm runtime."

44+

45+ , bundle_runtime = False

46+ &= help "Bundle the runtime with the generated html or js to create a standalone file."

47+

36 , cache_dir = "cache" &= typFile

48 , cache_dir = "cache" &= typFile

37− &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."

49+ &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."

50+

38 , build_dir = "build" &= typFile

51 , build_dir = "build" &= typFile

39− &= help "Directory for generated HTML and JS files. Defaults to build/ directory."

52+ &= help "Directory for generated HTML and JS files. Defaults to build/ directory."

53+

40 , src_dir = ["."] &= typFile

54 , src_dir = ["."] &= typFile

41− &= help "Additional source directories besides project root. Searched when using --make"

55+ &= help "Additional source directories besides project root. Searched when using --make"

56+

42 , print_types = False

57 , print_types = False

43− &= help "Print out inferred types of top-level definitions."

58+ &= help "Print out inferred types of top-level definitions."

59+

44 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."

60 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."

45 &= helpArg [explicit, name "help", name "h"]

61 &= helpArg [explicit, name "help", name "h"]

46 &= versionArg [explicit, name "version", name "v", summary (show Version.elmVersion)]

62 &= versionArg [explicit, name "version", name "v", summary (show Version.elmVersion)]

compiler/Build/Interface.hs+2−2

@@ -7,7 +7,7 @@ import qualified Data.Binary as Binary

7import qualified Build.Print as Print

8import qualified Elm.Internal.Version as Version

9import System.Directory (doesFileExist)

10−import SourceSyntax.Module

10+import AST.Module as Module

11

12load :: Binary.Binary a => FilePath -> IO a

13load filePath =

@@ -28,7 +28,7 @@ load filePath =

28 , " Please remove the file and try again."

29 ]

30

31−isValid :: FilePath -> (String, ModuleInterface) -> Either String (String, ModuleInterface)

31+isValid :: FilePath -> (String, Module.Interface) -> Either String (String, Module.Interface)

32isValid filePath (name, interface) =

33 let version = iVersion interface in

34 if version == Version.elmVersion

compiler/Build/Print.hs+7−25

@@ -5,42 +5,24 @@ import System.Exit (exitFailure)

5

6import qualified Data.Map as Map

7import qualified Data.List as List

8−import qualified SourceSyntax.Type as T

8+import qualified AST.Module as Module

9−import qualified SourceSyntax.Module as M

10−import qualified SourceSyntax.PrettyPrint as Pretty

9+import qualified AST.PrettyPrint as Pretty

11−import qualified Type.Alias as Alias

12import qualified Text.PrettyPrint as P

10import qualified Text.PrettyPrint as P

13

11

14−metaTypes :: Map.Map String M.ModuleInterface -> M.MetadataModule -> IO ()

12+types :: Module.Types -> IO ()

15−metaTypes interfaces meta =

13+types ts =

16− types interfaces (M.types meta) (M.aliases meta) (M.imports meta)

17−

18−interfaceTypes :: Map.Map String M.ModuleInterface -> M.ModuleInterface -> IO ()

19−interfaceTypes interfaces iface =

20− types interfaces (M.iTypes iface) (M.iAliases iface) (M.iImports iface)

21−

22−types :: Map.Map k M.ModuleInterface

23− -> Map.Map String T.Type

24− -> [M.Alias]

25− -> [(String, M.ImportMethod)]

26− -> IO ()

27−types interfaces types' aliases imports =

28 do putStrLn ""

14 do putStrLn ""

29− mapM_ printType (Map.toList types')

15+ mapM_ printType (Map.toList ts)

30 putStrLn ""

16 putStrLn ""

31 where

17 where

32− rules = Alias.rules interfaces aliases imports

33−

34 printType (n,t) = do

18 printType (n,t) = do

35 print $ P.hsep [ Pretty.variable n

19 print $ P.hsep [ Pretty.variable n

36 , P.text ":"

20 , P.text ":"

37− , Pretty.pretty (Alias.realias rules t) ]

21+ , Pretty.pretty t ]

38

22

39errors :: [P.Doc] -> IO ()

23errors :: [P.Doc] -> IO ()

40errors errs =

24errors errs =

41 mapM_ print (List.intersperse (P.text " ") errs)

25 mapM_ print (List.intersperse (P.text " ") errs)

42

26

43failure :: String -> IO a

27failure :: String -> IO a

44−failure msg =

45− do hPutStrLn stderr msg

28+failure msg = hPutStrLn stderr msg >> exitFailure

46− exitFailure

compiler/Build/Source.hs+22−45

@@ -2,57 +2,34 @@

2module Build.Source (build) where

3

4import qualified Data.Map as Map

5−import System.FilePath as FP

6import Text.PrettyPrint (Doc)

5import Text.PrettyPrint (Doc)

7

6

8−import SourceSyntax.Declaration

7+import qualified AST.Module as Module

9−import SourceSyntax.Module

10−import qualified SourceSyntax.Expression as Expr

11−import qualified SourceSyntax.Pattern as Pattern

12−import qualified SourceSyntax.Type as Type

13import qualified Parse.Parse as Parse

8import qualified Parse.Parse as Parse

14import qualified Metadata.Prelude as Prelude

9import qualified Metadata.Prelude as Prelude

15import qualified Transform.Check as Check

10import qualified Transform.Check as Check

16−import qualified Transform.SortDefinitions as SD

17import qualified Type.Inference as TI

11import qualified Type.Inference as TI

18−import qualified Type.Constrain.Declaration as TcDecl

19import qualified Transform.Canonicalize as Canonical

12import qualified Transform.Canonicalize as Canonical

20

13

21−build :: Bool -> Interfaces -> String -> Either [Doc] MetadataModule

14+build :: Bool -> Module.Interfaces -> String -> Either [Doc] Module.CanonicalModule

22build noPrelude interfaces source =

15build noPrelude interfaces source =

23− do let add = Prelude.add noPrelude

24− infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))

16+ do let infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))

25− . concatMap iFixities $ Map.elems interfaces

17+ . concatMap Module.iFixities $ Map.elems interfaces

26−

18+

27− Module names exs ims decls <- do

19+ -- Parse the source code and validate that it is well formed.

20+ validModule <- do

28− modul@(Module _ _ _ decls) <- add `fmap` Parse.program infixes source

21+ modul <- Prelude.add noPrelude `fmap` Parse.program infixes source

29− case Check.mistakes decls of

22+ case Check.mistakes (Module.body modul) of

30− [] -> return modul

23+ [] -> return modul

31− ms -> Left ms

24+ ms -> Left ms

32−

25+

33− let exports'

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

34− | null exs =

35− let get = Pattern.boundVarList in

36− concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++

37− concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++

38− [ name | TypeAlias name _ (Type.Record _ _) <- decls ]

39− | otherwise = exs

40−

41− metaModule <- Canonical.metadataModule interfaces $

27+ canonicalModule <- Canonical.module' interfaces validModule

42− MetadataModule

28+

43− { names = names

29+ -- Run type inference on the program.

44− , path = FP.joinPath names

45− , exports = exports'

46− , imports = ims

47− -- reorder AST into strongly connected components

48− , program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls

49− , types = Map.empty

50− , datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ]

51− , fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ]

52− , aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ]

53− , ports = [ portName port | Port port <- decls ]

54− }

55−

56− types <- TI.infer interfaces metaModule

30+ types <- TI.infer interfaces canonicalModule

57−

31+

58− return $ metaModule { types = types }

32+ -- Add the real list of tyes

33+ let body = (Module.body canonicalModule) { Module.types = types }

34+

35+ return $ canonicalModule { Module.body = body }

compiler/Build/Utils.hs+22−2

@@ -5,6 +5,7 @@ import Control.Monad.Error

5import System.Directory (doesFileExist)

6import System.Environment (getEnv)

7import System.FilePath ((</>), replaceExtension)

8+import System.IO.Error (tryIOError)

8import qualified Build.Flags as Flag

9import qualified Build.Flags as Flag

9import qualified Build.Print as Print

10import qualified Build.Print as Print

10import qualified Paths_Elm as This

11import qualified Paths_Elm as This

@@ -33,8 +34,27 @@ getDataFile name = do

33 if exists

34 if exists

34 then return path

35 then return path

35 else do

36 else do

36− env <- getEnv "ELM_HOME"

37+ environment <- tryIOError (getEnv "ELM_HOME")

38+ case environment of

37− return (env </> name)

39+ Right env -> return (env </> "compiler" </> name)

40+ Left _ ->

41+ fail $ unlines

42+ [ "Unable to find the ELM_HOME environment variable when searching"

43+ , "for the " ++ name ++ " file."

44+ , ""

45+ , "If you installed Elm Platform with the Mac or Windows installer, it looks like"

46+ , "ELM_HOME was not set automatically. Look up how to set environment variables"

47+ , "on your platform and set ELM_HOME to the directory that contains Elm's static"

48+ , "files:"

49+ , ""

50+ , " * On Mac it is /usr/local/share/elm"

51+ , " * On Windows it is one of the following:"

52+ , " C:/Program Files/Elm Platform/0.13/share"

53+ , " C:/Program Files (x86)/Elm Platform/0.13/share"

54+ , ""

55+ , "If it seems like a more complex issue, please report it here:"

56+ , " <https://github.com/elm-lang/elm-platform/issues>"

57+ ]

38

58

39run :: ErrorT String IO a -> IO a

59run :: ErrorT String IO a -> IO a

40run command = do

60run command = do

compiler/Compiler.hs+28−12

@@ -25,12 +25,12 @@ main = do setNumCapabilities =<< getNumProcessors

25

26compileArgs :: Flag.Flags -> IO ()

27compileArgs flags =

28− do when (Flag.get_runtime flags) $

28+ do when (Flag.get_runtime flags) $ do

29− do putStrLn Path.runtime

29+ putStrLn Path.runtime

30− exitSuccess

30+ exitSuccess

31 case Flag.files flags of

32− [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"

32+ [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"

33− fs -> mapM_ (build flags) fs

33+ fs -> mapM_ (build flags) fs

34

35build :: Flag.Flags -> FilePath -> IO ()

36build flags rootFile =

@@ -50,9 +50,9 @@ build flags rootFile =

50 (extension, code) <-

51 if Flag.only_js flags

52 then do putStr "Generating JavaScript ... "

53− return ("js", js)

53+ makeJs js

54 else do putStr "Generating HTML ... "

55− return (makeHtml js moduleName)

55+ makeHtml js moduleName

56

57 let targetFile = Utils.buildPath flags rootFile extension

58 createDirectoryIfMissing True (takeDirectory targetFile)

@@ -65,9 +65,25 @@ build flags rootFile =

65 src <- BS.readFile filePath

66 return (BS.append src js)

67

68− sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ]

68+ getRuntime :: IO Html.JSSource

69+ getRuntime =

70+ let runtimePath = Maybe.fromMaybe Path.runtime (Flag.set_runtime flags) in

71+ case Flag.bundle_runtime flags of

72+ False -> return (Html.Link runtimePath)

73+ True -> Html.Source `fmap` BS.readFile runtimePath

69

74

75+ makeJs :: BS.ByteString -> IO (String, BS.ByteString)

76+ makeJs js =

77+ do runtime <- getRuntime

78+ case runtime of

79+ Html.Link _ -> return ("js", js)

80+ Html.Source rts -> return ("js", BS.append rts js)

81+

82+ makeHtml :: BS.ByteString -> String -> IO (String, BS.ByteString)

83+ makeHtml js moduleName =

84+ do runtime <- getRuntime

70− makeHtml js moduleName = ("html", BS.pack $ renderHtml html)

85+ return ("html", BS.pack $ renderHtml (html runtime))

71− where

86+ where

72− rtsPath = Maybe.fromMaybe Path.runtime (Flag.set_runtime flags)

87+ sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ]

88+ html runtime =

73− html = Html.generate rtsPath (takeBaseName rootFile) (sources js) moduleName ""

89+ Html.generate runtime (takeBaseName rootFile) (sources js) moduleName ""

compiler/Docs.hs+103−66

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

1+{-# OPTIONS_GHC -W #-}

1{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}

2{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}

2module Main where

3module Main where

3

4

@@ -11,15 +12,17 @@ import Control.Applicative ((<$>))

11import Control.Arrow (second)

12import Control.Arrow (second)

12import Data.Aeson

13import Data.Aeson

13import Data.Aeson.Encode.Pretty

14import Data.Aeson.Encode.Pretty

15+import Data.Aeson.Types (Pair)

14import qualified Data.List as List

16import qualified Data.List as List

15import qualified Data.Map as Map

17import qualified Data.Map as Map

16import qualified Data.ByteString.Lazy as BS

18import qualified Data.ByteString.Lazy as BS

17import qualified Data.Text as Text

19import qualified Data.Text as Text

18

20

19−import qualified SourceSyntax.Helpers as Help

21+import qualified AST.Helpers as Help

20−import qualified SourceSyntax.Type as T

22+import qualified AST.Type as T

21−import qualified SourceSyntax.Expression as E

23+import qualified AST.Declaration as D

22−import qualified SourceSyntax.Declaration as D

24+import qualified AST.Expression.Source as Src

25+import qualified AST.Variable as Var

23

26

24import Text.Parsec hiding (newline,spaces)

27import Text.Parsec hiding (newline,spaces)

25import Parse.Declaration (alias,datatype,infixDecl)

28import Parse.Declaration (alias,datatype,infixDecl)

@@ -63,9 +66,9 @@ parseFile path = do

63

66

64docs :: IParser Value

67docs :: IParser Value

65docs = do

68docs = do

66− (name, exports, structure) <- moduleDocs

69+ (name, _exports, structure) <- moduleDocs

67 things <- document

70 things <- document

68− return $ documentToJson name exports structure things

71+ return $ documentToJson name structure things

69

72

70docComment :: IParser String

73docComment :: IParser String

71docComment = do

74docComment = do

@@ -74,7 +77,7 @@ docComment = do

74 let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents

77 let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents

75 return $ dropWhile (==' ') (reverse reversed)

78 return $ dropWhile (==' ') (reverse reversed)

76

79

77−moduleDocs :: IParser (String, [String], String)

80+moduleDocs :: IParser (String, Var.Listing Var.Value, String)

78moduleDocs = do

81moduleDocs = do

79 optional freshLine

82 optional freshLine

80 (names,exports) <- moduleDef

83 (names,exports) <- moduleDef

@@ -83,10 +86,10 @@ moduleDocs = do

83 structure <- docComment

86 structure <- docComment

84 return (List.intercalate "." names, exports, structure)

87 return (List.intercalate "." names, exports, structure)

85

88

86−document :: IParser [(String, D.ParseDeclaration, String)]

89+document :: IParser [(String, D.SourceDecl, String)]

87document = onFreshLines (\t ts -> ts ++ [t]) [] docThing

90document = onFreshLines (\t ts -> ts ++ [t]) [] docThing

88

91

89−docThing :: IParser (String, D.ParseDeclaration, String)

92+docThing :: IParser (String, D.SourceDecl, String)

90docThing = uncommentable <|> commented <|> uncommented ""

93docThing = uncommentable <|> commented <|> uncommented ""

91 where

94 where

92 uncommentable = do

95 uncommentable = do

@@ -103,24 +106,28 @@ docThing = uncommentable <|> commented <|> uncommented ""

103 return (comment, def, src)

106 return (comment, def, src)

104

107

105

108

109+documentToJson :: String -> String -> [(String, D.SourceDecl, String)] -> Value

106−documentToJson name exports structure things =

110+documentToJson name structure things =

111+ object

107− object $ [ "name" .= name

112+ [ "name" .= name

108− , "document" .= structure

113+ , "document" .= structure

109− , "values" .= toList values

114+ , "values" .= toList values

110− , "aliases" .= toList aliases

115+ , "aliases" .= toList aliases

111− , "datatypes" .= toList adts

116+ , "datatypes" .= toList adts

112− ]

117+ ]

113 where

118 where

119+ (values, aliases, adts) =

114− (values, aliases, adts) = collect Map.empty Map.empty Map.empty Map.empty things

120+ collect Map.empty Map.empty Map.empty Map.empty things

115

121

122+ toList :: Map.Map String [Pair] -> [Value]

123+ toList dict =

116− toList dict = map object . Map.elems $ filterPublics dict

124+ map object (Map.elems dict)

117

125

118− exportMap = Map.fromList (zip exports exports)

126+type Pairs = Map.Map String [Pair]

119− filterPublics dict =

120− case Map.null exportMap of

121− True -> dict

122− False -> Map.filterWithKey (\k _ -> Map.member k exportMap) dict

123

127

128+collect :: Map.Map String (D.Assoc, Int) -> Pairs -> Pairs -> Pairs

129+ -> [(String, D.SourceDecl, String)]

130+ -> (Pairs, Pairs, Pairs)

124collect infixes types aliases adts things =

131collect infixes types aliases adts things =

125 case things of

132 case things of

126 [] -> (Map.union customOps nonCustomOps, aliases, adts)

133 [] -> (Map.union customOps nonCustomOps, aliases, adts)

@@ -135,53 +142,83 @@ collect infixes types aliases adts things =

135 [ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs

142 [ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs

136

143

137 (comment, decl, source) : rest ->

144 (comment, decl, source) : rest ->

145+ let insert name fields dict = Map.insert name (obj name fields) dict

146+ obj name fields =

147+ [ "name" .= name

148+ , "raw" .= source

149+ , "comment" .= comment

150+ ] ++ fields

151+ in

138 case decl of

152 case decl of

139− D.Fixity assoc prec name ->

153+ D.Definition def ->

140− collect (Map.insert name (assoc,prec) infixes) types aliases adts rest

154+ case def of

141− D.Definition (E.TypeAnnotation name tipe) ->

155+ Src.TypeAnnotation name tipe ->

142− collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest

156+ collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest

143− D.TypeAlias name vars tipe ->

157+

144− let fields = ["typeVariables" .= vars, "type" .= tipe ]

158+ Src.Definition _ _ ->

145− in collect infixes types (insert name fields aliases) adts rest

159+ collect infixes types aliases adts rest

160+

146 D.Datatype name vars ctors ->

161 D.Datatype name vars ctors ->

147− let tipe = T.Data name (map T.Var vars)

162+ let tipe = T.App (T.Type (Var.Raw name)) (map T.Var vars)

148− fields = ["typeVariables" .= vars

163+ fields = [ "typeVariables" .= vars

149− , "constructors" .= map (ctorToJson tipe) ctors ]

164+ , "constructors" .= map (ctorToJson tipe) ctors

165+ ]

150 in collect infixes types aliases (insert name fields adts) rest

166 in collect infixes types aliases (insert name fields adts) rest

151− where

152− insert name fields dict = Map.insert name (obj name fields) dict

153− obj name fields =

154− [ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields

155

167

168+ D.TypeAlias name vars tipe ->

169+ let fields = [ "typeVariables" .= vars, "type" .= tipe ]

170+ in collect infixes types (insert name fields aliases) adts rest

171+

172+ D.Port _ ->

173+ collect infixes types aliases adts rest

174+

175+ D.Fixity assoc prec name ->

176+ collect (Map.insert name (assoc,prec) infixes) types aliases adts rest

177+

178+

156−instance ToJSON T.Type where

179+instance Var.ToString var => ToJSON (T.Type var) where

157 toJSON tipe =

180 toJSON tipe =

158− object $

181+ object (getFields tipe)

182+ where

183+ getFields tipe =

159− case tipe of

184+ case tipe of

160− T.Lambda _ _ ->

185+ T.Lambda _ _ ->

161− let tipes = T.collectLambdas tipe in

186+ let tipes = T.collectLambdas tipe in

162− [ "tag" .= ("function" :: Text.Text)

187+ [ "tag" .= ("function" :: Text.Text)

163− , "args" .= toJSON (init tipes)

188+ , "args" .= toJSON (init tipes)

164− , "result" .= toJSON (last tipes)

189+ , "result" .= toJSON (last tipes)

165− ]

190+ ]

166−

191+

167− T.Var x ->

192+ T.Var x ->

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

193+ [ "tag" .= ("var" :: Text.Text)

169− , "name" .= toJSON x

194+ , "name" .= toJSON x

170− ]

195+ ]

171−

196+

172− T.Data name ts ->

197+ T.Type name ->

198+ [ "tag" .= ("adt" :: Text.Text)

199+ , "name" .= toJSON (Var.toString name)

200+ , "args" .= ([] :: [()])

201+ ]

202+

203+ T.App (T.Type name) ts ->

173− [ "tag" .= ("adt" :: Text.Text)

204+ [ "tag" .= ("adt" :: Text.Text)

174− , "name" .= toJSON name

205+ , "name" .= toJSON (Var.toString name)

175− , "args" .= map toJSON ts

206+ , "args" .= map toJSON ts

176− ]

207+ ]

177−

208+

209+ T.App _ _ -> error "This is an unexpected error with elm-doc, please report it at <https://github.com/elm-lang/Elm/issues>"

210+

178− T.Record fields ext ->

211+ T.Record fields ext ->

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

212+ [ "tag" .= ("record" :: Text.Text)

180− , "fields" .= toJSON (map (toJSON . second toJSON) fields)

213+ , "fields" .= toJSON (map (toJSON . second toJSON) fields)

181− , "extension" .= toJSON ext

214+ , "extension" .= toJSON ext

182− ]

215+ ]

183−

216+

217+ T.Aliased _ t ->

218+ getFields t

219+

184−ctorToJson :: T.Type -> (String, [T.Type]) -> Value

220+ctorToJson :: T.RawType -> (String, [T.RawType]) -> Value

185ctorToJson tipe (ctor, tipes) =

221ctorToJson tipe (ctor, tipes) =

186 object [ "name" .= ctor

222 object [ "name" .= ctor

187− , "type" .= foldr T.Lambda tipe tipes ]

223+ , "type" .= foldr T.Lambda tipe tipes

224+ ]

compiler/Dummy.cabal+220−99

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

1−-- This is a dummy .cabal file that makes it possible to build the

2−-- compiler with GHCi from within emacs. Do not actually use this

3−-- file to install things.

4−

5Name: Elm

1Name: Elm

6−Version: 0.8.0.3

2+Version: 0.12

7Synopsis: The Elm language module.

3Synopsis: The Elm language module.

8Description: Elm aims to make client-side web-development more pleasant.

4Description: Elm aims to make client-side web-development more pleasant.

9 It is a statically/strongly typed, functional reactive

5 It is a statically/strongly typed, functional reactive

@@ -18,153 +14,278 @@ License-file: LICENSE

18

14

19Author: Evan Czaplicki

15Author: Evan Czaplicki

20Maintainer: info@elm-lang.org

16Maintainer: info@elm-lang.org

22

18

23Category: Compiler, Language

19Category: Compiler, Language

24

20

25Build-type: Custom

21Build-type: Custom

26

22

27−Extra-source-files: changelog.txt

23+Extra-source-files: changelog.md

28−Data-dir: dist/data

24+Data-dir: data

29−Data-files: elm-runtime.js docs.json

25+Data-files: elm-runtime.js interfaces.data docs.json

30−Cabal-version: >=1.8

26+Cabal-version: >=1.9

31

27

32source-repository head

28source-repository head

33 type: git

29 type: git

34 location: git://github.com/evancz/Elm.git

30 location: git://github.com/evancz/Elm.git

35

31

36Library

32Library

37− exposed-modules: Language.Elm,

33+ exposed-modules: Elm.Internal.Dependencies,

38− Language.Elm.Quasi

34+ Elm.Internal.Documentation,

35+ Elm.Internal.Name,

36+ Elm.Internal.Paths,

37+ Elm.Internal.Utils,

38+ Elm.Internal.Version

39 Hs-Source-Dirs: compiler

40− other-modules: Unique,

40+ other-modules: AST.Annotation,

41+ AST.Declaration,

42+ AST.Expression.General,

43+ AST.Expression.Source,

44+ AST.Expression.Valid,

45+ AST.Expression.Canonical,

41− SourceSyntax.Helpers,

46+ AST.Helpers,

42− SourceSyntax.Location,

43− SourceSyntax.Literal,

47+ AST.Literal,

48+ AST.Module,

44− SourceSyntax.Pattern,

49+ AST.Pattern,

45− SourceSyntax.Expression,

50+ AST.PrettyPrint,

46− SourceSyntax.Declaration,

51+ AST.Type,

47− SourceSyntax.Module,

52+ AST.Variable,

48 Generate.JavaScript,

53 Generate.JavaScript,

49− Generate.Noscript,

54+ Generate.JavaScript.Helpers,

55+ Generate.JavaScript.Ports,

56+ Generate.Markdown,

50 Generate.Html,

57 Generate.Html,

51 Generate.Cases,

58 Generate.Cases,

59+ Transform.Canonicalize,

60+ Transform.Check,

61+ Transform.Expression,

62+ Transform.Declaration,

63+ Transform.Definition,

64+ Transform.SortDefinitions,

52 Transform.Substitute,

65 Transform.Substitute,

53− Transform.Optimize,

54− Metadata.Libraries,

66+ Metadata.Prelude,

55− Metadata.LoadLibraries,

56− Initialize,

57 Parse.Binop,

67 Parse.Binop,

68+ Parse.Declaration,

58 Parse.Expression,

69 Parse.Expression,

59− Parse.Foreign,

60 Parse.Helpers,

70 Parse.Helpers,

71+ Parse.Literal,

61 Parse.Module,

72 Parse.Module,

62− Parse.Parser,

73+ Parse.Parse,

63 Parse.Pattern,

74 Parse.Pattern,

64 Parse.Type,

75 Parse.Type,

65− Types.Alias,

76+ Type.Alias,

66− Types.Types,

77+ Type.Constrain.Expression,

78+ Type.Constrain.Literal,

67− Types.Constrain,

79+ Type.Constrain.Pattern,

68− Types.Hints,

80+ Type.Environment,

69− Types.Solver,

81+ Type.ExtraChecks,

70− Types.Substitutions,

82+ Type.Fragment,

83+ Type.Inference,

84+ Type.PrettyPrint,

85+ Type.Solve,

86+ Type.State,

87+ Type.Type,

71− Types.Unify,

88+ Type.Unify,

89+ Build.Dependencies,

90+ Build.File,

91+ Build.Flags,

92+ Build.Interface,

93+ Build.Print,

94+ Build.Source,

95+ Build.Utils,

72 Paths_Elm

96 Paths_Elm

73

97

74− Build-depends: base >=4.2 && <5,

98+ Build-depends: aeson,

99+ base >=4.2 && <5,

100+ binary >= 0.7.0.0,

101+ blaze-html >= 0.5 && < 0.8,

102+ blaze-markup,

103+ bytestring,

104+ cmdargs,

75 containers >= 0.3,

105 containers >= 0.3,

76− transformers >= 0.2,

106+ directory,

107+ filepath,

108+ indents,

109+ language-ecmascript >=0.15 && < 1.0,

110+ language-glsl,

77 mtl >= 2,

111 mtl >= 2,

78− deepseq,

112+ pandoc >= 1.10,

79 parsec >= 3.1.1,

113 parsec >= 3.1.1,

80− blaze-html == 0.5.* || == 0.6.*,

114+ pretty,

81− blaze-markup == 0.5.1.*,

82 text,

115 text,

83− shakespeare >= 1,

116+ transformers >= 0.2,

84− template-haskell,

117+ union-find,

85− pandoc >= 1.10,

118+ unordered-containers

86− bytestring,

87− uniplate,

88− hjsmin,

89− indents,

90− filepath,

91− json,

92− directory

93

119

94Executable elm

120Executable elm

95 Main-is: Compiler.hs

121 Main-is: Compiler.hs

122+ ghc-options: -threaded -O2

96 Hs-Source-Dirs: compiler

123 Hs-Source-Dirs: compiler

97− other-modules: Unique,

124+ other-modules: AST.Annotation,

125+ AST.Declaration,

126+ AST.Expression.General,

127+ AST.Expression.Source,

128+ AST.Expression.Valid,

129+ AST.Expression.Canonical,

98− SourceSyntax.Helpers,

130+ AST.Helpers,

99− SourceSyntax.Location,

100− SourceSyntax.Literal,

131+ AST.Literal,

132+ AST.Module,

101− SourceSyntax.Pattern,

133+ AST.Pattern,

102− SourceSyntax.Expression,

134+ AST.PrettyPrint,

103− SourceSyntax.Declaration,

135+ AST.Type,

104− SourceSyntax.Module,

136+ AST.Variable,

105 Generate.JavaScript,

137 Generate.JavaScript,

106− Generate.Noscript,

138+ Generate.JavaScript.Helpers,

139+ Generate.JavaScript.Ports,

140+ Generate.Markdown,

107 Generate.Html,

141 Generate.Html,

108 Generate.Cases,

142 Generate.Cases,

143+ Transform.Canonicalize,

144+ Transform.Check,

145+ Transform.Expression,

146+ Transform.Declaration,

147+ Transform.Definition,

148+ Transform.SortDefinitions,

109 Transform.Substitute,

149 Transform.Substitute,

110− Transform.Optimize,

111− Metadata.Libraries,

150+ Metadata.Prelude,

112− Metadata.LoadLibraries,

113− Initialize,

114 Parse.Binop,

151 Parse.Binop,

152+ Parse.Declaration,

115 Parse.Expression,

153 Parse.Expression,

116− Parse.Foreign,

117 Parse.Helpers,

154 Parse.Helpers,

155+ Parse.Literal,

118 Parse.Module,

156 Parse.Module,

119− Parse.Parser,

157+ Parse.Parse,

120 Parse.Pattern,

158 Parse.Pattern,

121 Parse.Type,

159 Parse.Type,

122− Types.Alias,

160+ Type.Alias,

123− Types.Types,

161+ Type.Constrain.Expression,

162+ Type.Constrain.Literal,

124− Types.Constrain,

163+ Type.Constrain.Pattern,

125− Types.Hints,

164+ Type.Environment,

126− Types.Solver,

165+ Type.ExtraChecks,

127− Types.Substitutions,

166+ Type.Fragment,

167+ Type.Inference,

168+ Type.PrettyPrint,

169+ Type.Solve,

170+ Type.State,

171+ Type.Type,

128− Types.Unify,

172+ Type.Unify,

173+ Build.Dependencies,

174+ Build.File,

175+ Build.Flags,

176+ Build.Interface,

177+ Build.Print,

178+ Build.Source,

179+ Build.Utils,

129 Paths_Elm

180 Paths_Elm

130

181

131− Build-depends: base >=4.2 && <5,

182+ Build-depends: aeson,

183+ base >=4.2 && <5,

184+ binary >= 0.7.0.0,

185+ blaze-html >= 0.5 && < 0.8,

186+ blaze-markup,

187+ bytestring,

188+ cmdargs,

132 containers >= 0.3,

189 containers >= 0.3,

133− transformers >= 0.2,

190+ directory,

191+ filepath,

192+ indents,

193+ language-ecmascript >=0.15 && < 1.0,

194+ language-glsl,

134 mtl >= 2,

195 mtl >= 2,

135− deepseq,

136− parsec >= 3.1.1,

137− blaze-html == 0.5.* || == 0.6.*,

138− blaze-markup == 0.5.1.*,

139− cmdargs,

140 pandoc >= 1.10,

196 pandoc >= 1.10,

141− bytestring,

197+ parsec >= 3.1.1,

142− uniplate,

198+ pretty,

143− hjsmin,

199+ text,

144− indents,

200+ transformers >= 0.2,

145− filepath,

201+ union-find,

146− json,

202+ unordered-containers

147− directory

148

203

149Executable elm-doc

204Executable elm-doc

150 Main-is: Docs.hs

205 Main-is: Docs.hs

151 Hs-Source-Dirs: compiler

206 Hs-Source-Dirs: compiler

152− other-modules: SourceSyntax.Helpers,

207+ other-modules: AST.Annotation,

153− SourceSyntax.Location,

208+ AST.Declaration,

209+ AST.Expression.General,

210+ AST.Helpers,

154− SourceSyntax.Literal,

211+ AST.Literal,

155− SourceSyntax.Pattern,

156− SourceSyntax.Expression,

157− SourceSyntax.Declaration,

158− SourceSyntax.Module,

212+ AST.Module,

213+ AST.Pattern,

214+ AST.PrettyPrint,

215+ AST.Type,

216+ AST.Variable,

217+ Parse.Binop,

218+ Parse.Declaration,

219+ Parse.Expression,

159 Parse.Helpers,

220 Parse.Helpers,

221+ Parse.Literal,

160− Parse.Module

222+ Parse.Module,

223+ Parse.Pattern,

224+ Parse.Type

161

225

162− Build-depends: base >=4.2 && <5,

226+ Build-depends: aeson,

227+ aeson-pretty,

228+ base >=4.2 && <5,

229+ binary >= 0.7.0.0,

230+ bytestring,

231+ cmdargs,

163 containers >= 0.3,

232 containers >= 0.3,

164− transformers >= 0.2,

233+ directory,

234+ filepath,

235+ indents,

236+ language-glsl,

165 mtl >= 2,

237 mtl >= 2,

166− parsec >= 3.1.1,

167 pandoc >= 1.10,

238 pandoc >= 1.10,

239+ parsec >= 3.1.1,

240+ pretty,

241+ text,

242+ union-find

243+

244+Test-Suite compiler-tests

245+ Type: exitcode-stdio-1.0

246+ Hs-Source-Dirs: tests/hs, compiler

247+ Main-is: CompilerTest.hs

248+ other-modules: Tests.Compiler

249+ Tests.Property

250+ Tests.Property.Arbitrary

251+ AST.Helpers

252+ AST.Literal

253+ AST.PrettyPrint

254+ build-depends: test-framework,

255+ test-framework-hunit,

256+ test-framework-quickcheck2 >= 0.3,

257+ HUnit,

258+ QuickCheck >= 2 && < 3,

259+ aeson,

260+ base >=4.2 && <5,

261+ binary >= 0.7.0.0,

262+ blaze-html == 0.5.* || == 0.6.*,

263+ blaze-markup == 0.5.1.*,

264+ bytestring,

168− cmdargs,

265+ cmdargs,

266+ containers >= 0.3,

267+ directory,

268+ Elm,

269+ filemanip,

169− filepath,

270+ filepath,

170− indents

271+ indents,

272+ language-ecmascript >=0.15 && < 1.0,

273+ language-glsl,

274+ mtl >= 2,

275+ pandoc >= 1.10,

276+ parsec >= 3.1.1,

277+ pretty,

278+ text,

279+ transformers >= 0.2,

280+ union-find,

281+ unordered-containers

282+

283+Test-Suite lib-tests

284+ Type: exitcode-stdio-1.0

285+ Hs-Source-Dirs: tests/hs

286+ Main-is: LibTest.hs

287+ build-depends: base,

288+ directory,

289+ Elm,

290+ filepath,

291+ process >= 1.2

compiler/Elm/Internal/Utils.hs+3−3

@@ -5,9 +5,9 @@ module Elm.Internal.Utils (compile, moduleName, nameAndImports) where

5import qualified Data.List as List

6import qualified Generate.JavaScript as JS

7import qualified Build.Source as Source

8−import Parse.Module (getModuleName)

8+import qualified Parse.Module as Parser

9+import qualified AST.Module as M

9import Parse.Parse (dependencies)

10import Parse.Parse (dependencies)

10−import qualified SourceSyntax.Module as M

11import qualified Text.PrettyPrint as P

12import qualified Metadata.Prelude as Prelude

13import System.IO.Unsafe

@@ -26,7 +26,7 @@ interfaces = unsafePerformIO $ Prelude.interfaces False

26

27-- |This function extracts the module name of a given source program.

28moduleName :: String -> Maybe String

29−moduleName = getModuleName

29+moduleName = Parser.getModuleName

30

31-- |This function extracts the module name and imported modules from a given

32-- source program.

compiler/Generate/Cases.hs+156−78

@@ -1,133 +1,211 @@

1+{-# OPTIONS_GHC -W #-}

1module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

2module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

2

3

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

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

4import Control.Arrow (first)

5import Control.Arrow (first)

5−import Control.Monad.State

6+import Control.Monad.State (State)

7+import qualified Control.Monad.State as State

6import Data.List (groupBy,sortBy)

8import Data.List (groupBy,sortBy)

7import Data.Maybe (fromMaybe)

9import Data.Maybe (fromMaybe)

8

10

9−import SourceSyntax.Annotation

11+import qualified AST.Annotation as A

10−import SourceSyntax.Expression

12+import qualified AST.Expression.General as Expr

11−import SourceSyntax.Literal

13+import qualified AST.Expression.Canonical as Canonical

14+import qualified AST.Literal as Literal

12−import qualified SourceSyntax.Pattern as P

15+import qualified AST.Pattern as P

13−import qualified SourceSyntax.Variable as V

16+import qualified AST.Variable as Var

14−import Transform.Substitute

17+import Transform.Substitute (subst)

15

18

16−toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)

19+toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)

17toMatch patterns = do

20toMatch patterns = do

18 v <- newVar

21 v <- newVar

19 (,) v <$> match [v] (map (first (:[])) patterns) Fail

22 (,) v <$> match [v] (map (first (:[])) patterns) Fail

20

23

24+

21newVar :: State Int String

25newVar :: State Int String

22−newVar = do n <- get

26+newVar =

27+ do n <- State.get

23− modify (+1)

28+ State.modify (+1)

24− return $ "_v" ++ show n

29+ return $ "_v" ++ show n

30+

25

31

26data Match

32data Match

27 = Match String [Clause] Match

33 = Match String [Clause] Match

28 | Break

34 | Break

29 | Fail

35 | Fail

30− | Other Expr

36+ | Other Canonical.Expr

31 | Seq [Match]

37 | Seq [Match]

32 deriving Show

38 deriving Show

33

39

40+

34data Clause =

41data Clause =

35− Clause (Either String Literal) [String] Match

42+ Clause (Either Var.Canonical Literal.Literal) [String] Match

36 deriving Show

43 deriving Show

37

44

45+

46+type Case =

47+ ([P.CanonicalPattern], Canonical.Expr)

48+

49+

38matchSubst :: [(String,String)] -> Match -> Match

50matchSubst :: [(String,String)] -> Match -> Match

39matchSubst pairs match =

51matchSubst pairs match =

40 case match of

52 case match of

41 Break -> Break

53 Break -> Break

54+

42− Fail -> Fail

55+ Fail -> Fail

56+

57+ Seq ms ->

43− Seq ms -> Seq (map (matchSubst pairs) ms)

58+ Seq (map (matchSubst pairs) ms)

59+

44− Other (A a e) ->

60+ Other (A.A a e) ->

45− Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs

61+ Other . A.A a $ foldr ($) e $ map (\(x,y) -> subst x (Expr.localVar y)) pairs

62+

46 Match n cs m ->

63 Match n cs m ->

47 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

64 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

48− where

65+ where

49− varSubst v = fromMaybe v (lookup v pairs)

66+ varSubst v = fromMaybe v (lookup v pairs)

50− clauseSubst (Clause c vs m) =

67+ clauseSubst (Clause c vs m) =

51− Clause c (map varSubst vs) (matchSubst pairs m)

68+ Clause c (map varSubst vs) (matchSubst pairs m)

52

69

70+

71+isCon :: ([P.Pattern var], expr) -> Bool

72+isCon ([] , _) = noMatch "isCon"

53isCon (p:_, _) =

73isCon (p:_, _) =

54− case p of

74+ case p of

55− P.Data _ _ -> True

75+ P.Data _ _ -> True

56− P.Literal _ -> True

76+ P.Literal _ -> True

57− _ -> False

77+ _ -> False

58

78

79+

80+isVar :: ([P.Pattern var], expr) -> Bool

59isVar p = not (isCon p)

81isVar p = not (isCon p)

60

82

61−match :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

62−match [] [] def = return def

63−match [] [([],e)] Fail = return $ Other e

64−match [] [([],e)] Break = return $ Other e

65−match [] cs def = return $ Seq (map (Other . snd) cs ++ [def])

66−match vs@(v:_) cs def

67− | all isVar cs' = matchVar vs cs' def

68− | all isCon cs' = matchCon vs cs' def

69− | otherwise = matchMix vs cs' def

70− where

71− cs' = map (dealias v) cs

72

83

73−dealias :: String -> ([P.Pattern],Expr) -> ([P.Pattern],Expr)

84+match :: [String] -> [Case] -> Match -> State Int Match

85+match variables cases match =

86+ case (variables, cases, match) of

87+ ([], [], _) ->

88+ return match

89+

90+ ([], [([], expr)], Fail) ->

91+ return $ Other expr

92+

93+ ([], [([], expr)], Break) ->

94+ return $ Other expr

95+

96+ ([], _, _) ->

97+ return $ Seq (map (Other . snd) cases ++ [match])

98+

99+ (var:_, _, _)

100+ | all isVar cases' -> matchVar variables cases' match

101+ | all isCon cases' -> matchCon variables cases' match

102+ | otherwise -> matchMix variables cases' match

103+ where

104+ cases' = map (dealias var) cases

105+

106+

107+dealias :: String -> Case -> Case

108+dealias _ ([], _) = noMatch "dealias"

74−dealias v c@(p:ps, A a e) =

109+dealias v c@(p:ps, A.A a e) =

75 case p of

110 case p of

76− P.Alias x pattern -> (pattern:ps, A a $ subst x (rawVar v) e)

111+ P.Alias x pattern -> (pattern:ps, A.A a $ subst x (Expr.localVar v) e)

77 _ -> c

112 _ -> c

78

113

114+

79−matchVar :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

115+matchVar :: [String] -> [Case] -> Match -> State Int Match

116+matchVar [] _ _ = noMatch "matchVar"

117+matchVar (v:vs) cs def =

80−matchVar (v:vs) cs def = match vs (map subVar cs) def

118+ match vs (map subVar cs) def

81 where

119 where

120+ subVar ([], _) = noMatch "matchVar.subVar"

121+ subVar (p:ps, (A.A a expr)) =

82− subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)

122+ (ps, A.A a $ subOnePattern p expr)

83− where

123+ where

84− subOnePattern pattern e =

124+ subOnePattern pattern expr =

85 case pattern of

125 case pattern of

86− P.Var x -> subst x (rawVar v) e

126+ P.Anything -> expr

87− P.Anything -> e

127+

128+ P.Var x ->

129+ subst x (Expr.localVar v) expr

130+

88 P.Record fs ->

131 P.Record fs ->

89− foldr (\x -> subst x (Access (A a (rawVar v)) x)) e fs

132+ foldr (\x -> subst x (Expr.Access (A.A a (Expr.localVar v)) x)) expr fs

90

133

91−matchCon :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

134+ _ -> noMatch "matchVar.subVar"

92−matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

135+

93− where

136+

94− css = groupBy eq (sortBy cmp cs)

137+matchCon :: [String] -> [Case] -> Match -> State Int Match

95−

138+matchCon variables cases match =

96− cmp (p1:_,_) (p2:_,_) =

139+ case variables of

97− case (p1,p2) of

140+ [] -> noMatch "matchCon"

98− (P.Data n1 _, P.Data n2 _) -> compare n1 n2

141+

99− _ -> compare p1 p2

142+ var : _vars ->

100−

143+ flip (Match var) match <$> mapM toClause caseGroups

101− eq (p1:_,_) (p2:_,_) =

144+ where

102− case (p1,p2) of

145+ caseGroups :: [[Case]]

103− (P.Data n1 _, P.Data n2 _) -> n1 == n2

146+ caseGroups =

104− _ -> p1 == p2

147+ groupBy eq (sortBy cmp cases)

105−

148+

106− toClause cs =

149+ eq :: Case -> Case -> Bool

107− case head cs of

150+ eq (patterns1, _) (patterns2, _) =

108− (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break

151+ case (patterns1, patterns2) of

109− (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break

152+ (pattern1:_, pattern2:_) ->

110−

153+ case (pattern1, pattern2) of

111−matchClause :: Either String Literal

154+ (P.Data name1 _, P.Data name2 _) -> name1 == name2

112− -> [String]

155+ (_, _) -> pattern1 == pattern2

113− -> [([P.Pattern],Expr)]

156+ (_, _) -> noMatch "matchCon.eq"

114− -> Match

157+

158+ cmp :: Case -> Case -> Ordering

159+ cmp (patterns1, _) (patterns2, _) =

160+ case (patterns1, patterns2) of

161+ (pattern1:_, pattern2:_) ->

162+ case (pattern1, pattern2) of

163+ (P.Data name1 _, P.Data name2 _) -> compare name1 name2

164+ (_, _) -> compare pattern1 pattern2

165+ (_, _) -> noMatch "matchCon.cmp"

166+

167+ toClause :: [Case] -> State Int Clause

168+ toClause cases =

169+ case head cases of

170+ (P.Data name _ : _, _) ->

171+ matchClause (Left name) variables cases Break

172+

173+ (P.Literal lit : _, _) ->

174+ matchClause (Right lit) variables cases Break

175+

176+ _ -> noMatch "matchCon"

177+

178+

179+matchClause :: Either Var.Canonical Literal.Literal -> [String] -> [Case] -> Match

115 -> State Int Clause

180 -> State Int Clause

116−matchClause c (_:vs) cs def =

181+matchClause _ [] _ _ = noMatch "matchClause"

182+matchClause c (_:vs) cs mtch =

117 do vs' <- getVars

183 do vs' <- getVars

118− Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def

184+ Clause c vs' <$> match (vs' ++ vs) (map flatten cs) mtch

119 where

185 where

120−

186+ flatten ([], _) = noMatch "matchClause.flatten"

121 flatten (p:ps, e) =

187 flatten (p:ps, e) =

122 case p of

188 case p of

123 P.Data _ ps' -> (ps' ++ ps, e)

189 P.Data _ ps' -> (ps' ++ ps, e)

124 P.Literal _ -> (ps, e)

190 P.Literal _ -> (ps, e)

191+ _ -> noMatch "matchClause.flatten"

125

192

193+ getVars :: State Int [String]

126 getVars =

194 getVars =

127 case head cs of

195 case head cs of

128− (P.Data _ ps : _, _) -> forM ps (const newVar)

196+ (P.Data _ ps : _, _) -> State.forM ps (const newVar)

129 (P.Literal _ : _, _) -> return []

197 (P.Literal _ : _, _) -> return []

198+ _ -> noMatch "matchClause.getVars"

199+

200+

201+matchMix :: [String] -> [Case] -> Match -> State Int Match

202+matchMix vs cs def =

203+ State.foldM (flip $ match vs) def (reverse css)

204+ where

205+ css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

206+

130

207

131−matchMix :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

208+noMatch :: String -> a

132−matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

209+noMatch name =

133− where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

210+ error $ "unexpected pattern in '" ++ name ++

211+ "' function. Report a compiler issue to <https://github.com/elm-lang/Elm>."

compiler/Generate/Html.hs+3−3

@@ -17,13 +17,13 @@ makeScript source =

17 H.script ! A.type_ "text/javascript" $

18 preEscapedToMarkup $ BS.unpack src

19

20−generate :: FilePath -> String -> [JSSource] -> String -> String -> H.Html

20+generate :: JSSource -> String -> [JSSource] -> String -> String -> H.Html

21−generate libLoc title scripts moduleName noscript =

21+generate runtime title scripts moduleName noscript =

22 H.docTypeHtml $ do

23 H.head $ do

24 H.meta ! A.charset "UTF-8"

25 H.title . H.toHtml $ title

26− makeScript (Link libLoc)

26+ makeScript runtime

27 mapM_ makeScript scripts

28 H.body $ do

29 H.script ! A.type_ "text/javascript" $

compiler/Generate/JavaScript.hs+173−129

@@ -10,59 +10,66 @@ import qualified Data.Set as Set

10import Language.ECMAScript3.PrettyPrint

11import Language.ECMAScript3.Syntax

12

13−import Generate.JavaScript.Helpers

13+import Generate.JavaScript.Helpers as Help

14import qualified Generate.Cases as Case

15import qualified Generate.JavaScript.Ports as Port

16+import qualified Generate.JavaScript.Variable as Var

16import qualified Generate.Markdown as MD

17import qualified Generate.Markdown as MD

17−import SourceSyntax.Annotation

18+

18−import SourceSyntax.Expression

19+import AST.Annotation

19−import qualified SourceSyntax.Helpers as Help

20+import AST.Module

20−import SourceSyntax.Literal

21+import AST.Expression.General

21−import SourceSyntax.Module

22+import qualified AST.Expression.Canonical as Canonical

22−import qualified SourceSyntax.Pattern as P

23+import qualified AST.Module as Module

23−import SourceSyntax.PrettyPrint (renderPretty)

24+import qualified AST.Helpers as Help

24−import qualified SourceSyntax.Variable as V

25+import AST.Literal

25−import qualified Transform.SafeNames as MakeSafe

26+import qualified AST.Pattern as P

27+import qualified AST.Variable as Var

26

28

27varDecl :: String -> Expression () -> VarDecl ()

29varDecl :: String -> Expression () -> VarDecl ()

28varDecl x expr =

30varDecl x expr =

29 VarDecl () (var x) (Just expr)

31 VarDecl () (var x) (Just expr)

30

32

31−include :: String -> String -> VarDecl ()

33+internalImports :: String -> [VarDecl ()]

32−include alias moduleName =

33− varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")

34−

35−internalImports :: String -> Statement ()

36internalImports name =

34internalImports name =

37− VarDeclStmt ()

35+ [ varDecl "_N" (obj ["Elm","Native"])

38− [ varDecl "_N" (obj "Elm.Native")

36+ , include "_U" "Utils"

39− , include "_U" "_N.Utils"

37+ , include "_L" "List"

40− , include "_L" "_N.List"

38+ , include "_A" "Array"

41− , include "_A" "_N.Array"

39+ , include "_E" "Error"

42− , include "_E" "_N.Error"

40+ , varDecl Help.localModuleName (string name)

43− , varDecl "$moduleName" (string name)

44 ]

41 ]

42+ where

43+ include :: String -> String -> VarDecl ()

44+ include alias modul =

45+ varDecl alias (obj ["_N", modul, "make"] <| ref "_elm")

46+

47+_Utils :: String -> Expression ()

48+_Utils x = obj ["_U", x]

49+

50+_List :: String -> Expression ()

51+_List x = obj ["_L", x]

45

52

46literal :: Literal -> Expression ()

53literal :: Literal -> Expression ()

47literal lit =

54literal lit =

48 case lit of

55 case lit of

49− Chr c -> obj "_U.chr" <| string [c]

56+ Chr c -> _Utils "chr" <| string [c]

50 Str s -> string s

57 Str s -> string s

51 IntNum n -> IntLit () n

58 IntNum n -> IntLit () n

52 FloatNum n -> NumLit () n

59 FloatNum n -> NumLit () n

53 Boolean b -> BoolLit () b

60 Boolean b -> BoolLit () b

54

61

55−expression :: Expr -> State Int (Expression ())

62+expression :: Canonical.Expr -> State Int (Expression ())

56expression (A region expr) =

63expression (A region expr) =

57 case expr of

64 case expr of

58− Var (V.Raw x) -> return $ obj x

65+ Var var -> return $ Var.canonical var

59

66

60 Literal lit -> return $ literal lit

67 Literal lit -> return $ literal lit

61

68

62 Range lo hi ->

69 Range lo hi ->

63 do lo' <- expression lo

70 do lo' <- expression lo

64 hi' <- expression hi

71 hi' <- expression hi

65− return $ obj "_L.range" `call` [lo',hi']

72+ return $ _List "range" `call` [lo',hi']

66

73

67 Access e x ->

74 Access e x ->

68 do e' <- expression e

75 do e' <- expression e

@@ -70,19 +77,19 @@ expression (A region expr) =

70

77

71 Remove e x ->

78 Remove e x ->

72 do e' <- expression e

79 do e' <- expression e

73− return $ obj "_U.remove" `call` [string x, e']

80+ return $ _Utils "remove" `call` [string x, e']

74

81

75 Insert e x v ->

82 Insert e x v ->

76 do v' <- expression v

83 do v' <- expression v

77 e' <- expression e

84 e' <- expression e

78− return $ obj "_U.insert" `call` [string x, v', e']

85+ return $ _Utils "insert" `call` [string x, v', e']

79

86

80 Modify e fs ->

87 Modify e fs ->

81 do e' <- expression e

88 do e' <- expression e

82 fs' <- forM fs $ \(f,v) -> do

89 fs' <- forM fs $ \(f,v) -> do

83 v' <- expression v

90 v' <- expression v

84 return $ ArrayLit () [string f, v']

91 return $ ArrayLit () [string f, v']

85− return $ obj "_U.replace" `call` [ArrayLit () fs', e']

92+ return $ _Utils "replace" `call` [ArrayLit () fs', e']

86

93

87 Record fields ->

94 Record fields ->

88 do fields' <- forM fields $ \(f,e) -> do

95 do fields' <- forM fields $ \(f,e) -> do

@@ -106,10 +113,10 @@ expression (A region expr) =

106 where

113 where

107 depattern (args, body) pattern =

114 depattern (args, body) pattern =

108 case pattern of

115 case pattern of

109− P.Var x -> return (args ++ [x], body)

116+ P.Var x -> return (args ++ [ Var.varName x ], body)

110 _ -> do arg <- Case.newVar

117 _ -> do arg <- Case.newVar

111 return ( args ++ [arg]

118 return ( args ++ [arg]

112− , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))

119+ , A ann (Case (A ann (localVar arg)) [(pattern, body)]))

113

120

114 (patterns, innerBody) = collect [p] e

121 (patterns, innerBody) = collect [p] e

115

122

@@ -140,22 +147,23 @@ expression (A region expr) =

140 return $ function [] (stmts ++ [ ret exp ]) `call` []

147 return $ function [] (stmts ++ [ ret exp ]) `call` []

141

148

142 MultiIf branches ->

149 MultiIf branches ->

143− do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

150+ do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

144− return $ case last branches of

151+ return $ case last branches of

145− (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'

152+ (A _ (Var (Var.Canonical (Var.Module "Basics") "otherwise")), _) ->

146− (A _ (Literal (Boolean True)), _) -> safeIfs branches'

153+ safeIfs branches'

147− _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])

154+ (A _ (Literal (Boolean True)), _) -> safeIfs branches'

148− where

155+ _ -> ifs branches' (throw "If" region)

149− safeIfs branches = ifs (init branches) (snd (last branches))

156+ where

150− ifs branches finally = foldr iff finally branches

157+ safeIfs branches = ifs (init branches) (snd (last branches))

151− iff (if', then') else' = CondExpr () if' then' else'

158+ ifs branches finally = foldr iff finally branches

159+ iff (if', then') else' = CondExpr () if' then' else'

152

160

153 Case e cases ->

161 Case e cases ->

154 do (tempVar,initialMatch) <- Case.toMatch cases

162 do (tempVar,initialMatch) <- Case.toMatch cases

155 (revisedMatch, stmt) <-

163 (revisedMatch, stmt) <-

156 case e of

164 case e of

157− A _ (Var (V.Raw x)) ->

165+ A _ (Var (Var.Canonical Var.Local x)) ->

158− return (Case.matchSubst [(tempVar,x)] initialMatch, [])

166+ return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])

159 _ ->

167 _ ->

160 do e' <- expression e

168 do e' <- expression e

161 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])

169 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])

@@ -164,7 +172,7 @@ expression (A region expr) =

164

172

165 ExplicitList es ->

173 ExplicitList es ->

166 do es' <- mapM expression es

174 do es' <- mapM expression es

167− return $ obj "_L.fromArray" <| ArrayLit () es'

175+ return $ _List "fromArray" <| ArrayLit () es'

168

176

169 Data name es ->

177 Data name es ->

170 do es' <- mapM expression es

178 do es' <- mapM expression es

@@ -175,7 +183,7 @@ expression (A region expr) =

175

183

176 Markdown uid doc es ->

184 Markdown uid doc es ->

177 do es' <- mapM expression es

185 do es' <- mapM expression es

178− return $ obj "Text.markdown" `call` (string md : string uid : es')

186+ return $ Var.value "Text" "markdown" `call` (string md : string uid : es')

179 where

187 where

180 pad = "<div style=\"height:0;width:0;\"> </div>"

188 pad = "<div style=\"height:0;width:0;\"> </div>"

181 md = pad ++ MD.toHtml doc ++ pad

189 md = pad ++ MD.toHtml doc ++ pad

@@ -184,15 +192,16 @@ expression (A region expr) =

184 return $ ObjectLit () [(PropString () "src", literal (Str src))]

192 return $ ObjectLit () [(PropString () "src", literal (Str src))]

185

193

186 PortIn name tipe ->

194 PortIn name tipe ->

187− return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]

195+ return $ Var.value "Native.Ports" "portIn" `call`

196+ [ string name, Port.incoming tipe ]

188

197

189 PortOut name tipe value ->

198 PortOut name tipe value ->

190 do value' <- expression value

199 do value' <- expression value

191− return $ obj "Native.Ports.portOut" `call`

200+ return $ Var.value "Native.Ports" "portOut" `call`

192 [ string name, Port.outgoing tipe, value' ]

201 [ string name, Port.outgoing tipe, value' ]

193

202

194−definition :: Def -> State Int [Statement ()]

203+definition :: Canonical.Def -> State Int [Statement ()]

195−definition (Definition pattern expr@(A region _) _) = do

204+definition (Canonical.Definition pattern expr@(A region _) _) = do

196 expr' <- expression expr

205 expr' <- expression expr

197 let assign x = varDecl x expr'

206 let assign x = varDecl x expr'

198 case pattern of

207 case pattern of

@@ -201,39 +210,39 @@ definition (Definition pattern expr@(A region _) _) = do

201 let op = LBracket () (ref "_op") (string x) in

210 let op = LBracket () (ref "_op") (string x) in

202 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

211 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

203 | otherwise ->

212 | otherwise ->

204− return [ VarDeclStmt () [ assign x ] ]

213+ return [ VarDeclStmt () [ assign (Var.varName x) ] ]

205

214

206 P.Record fields ->

215 P.Record fields ->

207− let setField f = varDecl f (dotSep ["$",f]) in

216+ let setField f = varDecl f (obj ["$",f]) in

208 return [ VarDeclStmt () (assign "$" : map setField fields) ]

217 return [ VarDeclStmt () (assign "$" : map setField fields) ]

209

218

210− P.Data name patterns | vars /= Nothing ->

219+ P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

211 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

220 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

212 where

221 where

213 vars = getVars patterns

222 vars = getVars patterns

214 getVars patterns =

223 getVars patterns =

215 case patterns of

224 case patterns of

216− P.Var x : rest -> (x:) `fmap` getVars rest

225+ P.Var x : rest -> (Var.varName x :) `fmap` getVars rest

217 [] -> Just []

226 [] -> Just []

218 _ -> Nothing

227 _ -> Nothing

219

228

220− decl x n = varDecl x (dotSep ["$","_" ++ show n])

229+ decl x n = varDecl x (obj ["$","_" ++ show n])

221 setup vars

230 setup vars

222 | Help.isTuple name = assign "$" : vars

231 | Help.isTuple name = assign "$" : vars

223 | otherwise = assign "_raw" : safeAssign : vars

232 | otherwise = assign "_raw" : safeAssign : vars

224

233

225− safeAssign = varDecl "$" (CondExpr () if' (obj "_raw") exception)

234+ safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

226− if' = InfixExpr () OpStrictEq (obj "_raw.ctor") (string name)

235+ if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

227− exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]

236+ exception = Help.throw "Case" region

228

237

229 _ ->

238 _ ->

230 do defs' <- concat <$> mapM toDef vars

239 do defs' <- concat <$> mapM toDef vars

231 return (VarDeclStmt () [assign "_"] : defs')

240 return (VarDeclStmt () [assign "_"] : defs')

232 where

241 where

233 vars = P.boundVarList pattern

242 vars = P.boundVarList pattern

234− mkVar = A region . rawVar

243+ mkVar = A region . localVar

235 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]

244 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]

236− in definition $ Definition (P.Var y) expr Nothing

245+ in definition $ Canonical.Definition (P.Var y) expr Nothing

237

246

238match :: Region -> Case.Match -> State Int [Statement ()]

247match :: Region -> Case.Match -> State Int [Statement ()]

239match region mtch =

248match region mtch =

@@ -248,15 +257,15 @@ match region mtch =

248 _ -> False

257 _ -> False

249

258

250 access name

259 access name

251− | any isLiteral clauses = obj name

260+ | any isLiteral clauses = obj [name]

252− | otherwise = dotSep (split name ++ ["ctor"])

261+ | otherwise = obj (Help.splitDots name ++ ["ctor"])

253

262

254 format isChars e

263 format isChars e

255 | or isChars = InfixExpr () OpAdd e (string "")

264 | or isChars = InfixExpr () OpAdd e (string "")

256 | otherwise = e

265 | otherwise = e

257

266

258 Case.Fail ->

267 Case.Fail ->

259− return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]

268+ return [ ExprStmt () (Help.throw "Case" region) ]

260

269

261 Case.Break -> return [BreakStmt () Nothing]

270 Case.Break -> return [BreakStmt () Nothing]

262

271

@@ -283,98 +292,133 @@ clause region variable (Case.Clause value vars mtch) =

283 _ -> (,) False $ case value of

292 _ -> (,) False $ case value of

284 Right (Boolean b) -> BoolLit () b

293 Right (Boolean b) -> BoolLit () b

285 Right lit -> literal lit

294 Right lit -> literal lit

286− Left name -> string $ case List.elemIndices '.' name of

295+ Left (Var.Canonical _ name) ->

287− [] -> name

296+ string name

288− is -> drop (last is + 1) name

289

297

290−flattenLets :: [Def] -> Expr -> ([Def], Expr)

298+flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)

291flattenLets defs lexpr@(A _ expr) =

299flattenLets defs lexpr@(A _ expr) =

292 case expr of

300 case expr of

293 Let ds body -> flattenLets (defs ++ ds) body

301 Let ds body -> flattenLets (defs ++ ds) body

294 _ -> (defs, lexpr)

302 _ -> (defs, lexpr)

295

303

296−generate :: MetadataModule -> String

304+generate :: CanonicalModule -> String

297−generate unsafeModule =

305+generate modul =

298− show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++

306+ show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

299− [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]

307+ [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]

300 where

308 where

301− modul = MakeSafe.metadataModule unsafeModule

309+ names :: [String]

302− thisModule = dotSep ("_elm" : names modul ++ ["values"])

310+ names = Module.names modul

311+

312+ thisModule :: Expression ()

313+ thisModule = obj ("_elm" : names ++ ["values"])

314+

315+ programStmts :: [Statement ()]

303 programStmts =

316 programStmts =

304 concat

317 concat

305− [ [ ExprStmt () $ string "use strict" ]

318+ [ [ ExprStmt () (string "use strict") ]

306− , setup (Just "_elm") (names modul ++ ["values"])

319+ , setup "_elm" (names ++ ["values"])

307 , [ IfSingleStmt () thisModule (ret thisModule) ]

320 , [ IfSingleStmt () thisModule (ret thisModule) ]

308− , [ internalImports (List.intercalate "." (names modul)) ]

321+ , [ VarDeclStmt () localVars ]

309− , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul

322+ , body

310− , [ assign ["_op"] (ObjectLit () []) ]

311− , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0

312 , [ jsExports ]

323 , [ jsExports ]

313 , [ ret thisModule ]

324 , [ ret thisModule ]

314 ]

325 ]

315

326

316− jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)

327+ localVars :: [VarDecl ()]

328+ localVars = varDecl "_op" (ObjectLit () []) :

329+ internalImports (Module.getName modul) ++

330+ explicitImports

331+ where

332+ explicitImports :: [VarDecl ()]

333+ explicitImports =

334+ map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul

335+

336+ jsImport :: String -> VarDecl ()

337+ jsImport name =

338+ varDecl (Var.moduleName name) $

339+ obj ("Elm" : Help.splitDots name ++ ["make"]) <| ref "_elm"

340+

341+ body :: [Statement ()]

342+ body = concat $ evalState defs 0

343+ where

344+ defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)

345+

346+ setup namespace path = map create paths

347+ where

348+ create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))

349+ paths = drop 2 . init . List.inits $ namespace : path

350+

351+ jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)

317 where

352 where

318− exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul

353+ exs = map entry $ "_op" : concatMap extract (exports modul)

319 entry x = (prop x, ref x)

354 entry x = (prop x, ref x)

355+ extract value =

356+ case value of

357+ Var.Alias _ -> []

358+ Var.Value x | Help.isOp x -> []

359+ | otherwise -> [Var.varName x]

360+ Var.ADT _ (Var.Listing ctors _) -> map Var.varName ctors

320

361

321 assign path expr =

362 assign path expr =

322 case path of

363 case path of

323 [x] -> VarDeclStmt () [ varDecl x expr ]

364 [x] -> VarDeclStmt () [ varDecl x expr ]

324 _ -> ExprStmt () $

365 _ -> ExprStmt () $

325− AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr

366+ AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

326−

367+

327− jsImport modul = setup Nothing path ++ [ include ]

368+binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr

328− where

369+ -> State Int (Expression ())

329− path = Help.splitDots modul

370+binop region func@(Var.Canonical home op) e1 e2 =

330− include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"

371+ case (home, op) of

331−

372+ (Var.Module "Basics", ">>") ->

332− setup namespace path = map create paths

373+ do es <- mapM expression (collectLeftAssoc [e2] e1)

333− where

374+ return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es

334− create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))

375+

335− paths = case namespace of

376+ (Var.Module "Basics", "<<") ->

336− Nothing -> tail . init $ List.inits path

377+ do es <- mapM expression (e1 : collectRightAssoc [] e2)

337− Just nmspc -> drop 2 . init . List.inits $ nmspc : path

338−

339−binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())

340−binop region op e1 e2 =

341− case op of

342− "Basics.." ->

343− do es <- mapM expression (e1 : collect [] e2)

344 return $ ["$"] ==> foldr (<|) (ref "$") es

378 return $ ["$"] ==> foldr (<|) (ref "$") es

345− "Basics.<|" ->

379+

380+ (Var.Module "Basics", "<|") ->

346 do e2' <- expression e2

381 do e2' <- expression e2

347− es <- mapM expression (collect [] e1)

382+ es <- mapM expression (collectRightAssoc [] e1)

348 return $ foldr (<|) e2' es

383 return $ foldr (<|) e2' es

349− "List.++" ->

384+

385+ (Var.Module "List", "++") ->

350 do e1' <- expression e1

386 do e1' <- expression e1

351 e2' <- expression e2

387 e2' <- expression e2

352− return $ obj "_L.append" `call` [e1', e2']

388+ return $ _List "append" `call` [e1', e2']

353− "::" -> expression (A region (Data "::" [e1,e2]))

389+

354− _ ->

390+ (Var.BuiltIn, "::") ->

391+ expression (A region (Data "::" [e1,e2]))

392+

393+ (Var.Module "Basics", _) ->

355 do e1' <- expression e1

394 do e1' <- expression e1

356 e2' <- expression e2

395 e2' <- expression e2

357− return $ case Map.lookup op opDict of

396+ return $ case Map.lookup op basicOps of

358 Just f -> f e1' e2'

397 Just f -> f e1' e2'

359− Nothing -> ref "A2" `call` [ func, e1', e2' ]

398+ Nothing -> ref "A2" `call` [ Var.canonical func, e1', e2' ]

399+

400+ _ ->

401+ do e1' <- expression e1

402+ e2' <- expression e2

403+ return (ref "A2" `call` [ Var.canonical func, e1', e2' ])

404+

360 where

405 where

361− collect es e =

406+ collectRightAssoc es e =

362 case e of

407 case e of

363− A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2

408+ A _ (Binop (Var.Canonical (Var.Module "Basics") "<<") e1 e2) ->

409+ collectRightAssoc (es ++ [e1]) e2

364 _ -> es ++ [e]

410 _ -> es ++ [e]

365

411

366− func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)

412+ collectLeftAssoc es e =

367− | otherwise = dotSep parts

413+ case e of

368− where

414+ A _ (Binop (Var.Canonical (Var.Module "Basics") ">>") e1 e2) ->

369− parts = Help.splitDots op

415+ collectLeftAssoc (e2 : es) e1

370− operator = last parts

416+ _ -> e : es

371−

372− opDict = Map.fromList (infixOps ++ specialOps)

373

417

374− specialOp str func = [ (str, func), ("Basics." ++ str, func) ]

418+ basicOps = Map.fromList (infixOps ++ specialOps)

375− infixOp str op = specialOp str (InfixExpr () op)

376

419

377− infixOps = concat

420+ infixOps =

421+ let infixOp str op = (str, InfixExpr () op) in

378 [ infixOp "+" OpAdd

422 [ infixOp "+" OpAdd

379 , infixOp "-" OpSub

423 , infixOp "-" OpSub

380 , infixOp "*" OpMul

424 , infixOp "*" OpMul

@@ -383,16 +427,16 @@ binop region op e1 e2 =

383 , infixOp "||" OpLOr

427 , infixOp "||" OpLOr

384 ]

428 ]

385

429

386− specialOps = concat

430+ specialOps =

387− [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]

431+ [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

388− , specialOp "|>" $ flip (<|)

432+ , (,) "|>" $ flip (<|)

389− , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]

433+ , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]

390− , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])

434+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])

391− , specialOp "<" $ cmp OpLT 0

435+ , (,) "<" $ cmp OpLT 0

392− , specialOp ">" $ cmp OpGT 0

436+ , (,) ">" $ cmp OpGT 0

393− , specialOp "<=" $ cmp OpLT 1

437+ , (,) "<=" $ cmp OpLT 1

394− , specialOp ">=" $ cmp OpGT (-1)

438+ , (,) ">=" $ cmp OpGT (-1)

395− , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

439+ , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

396 ]

440 ]

397

441

398− cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)

442+ cmp op n a b = InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)

compiler/Generate/JavaScript/Helpers.hs+45−16

@@ -1,37 +1,66 @@

1{-# OPTIONS_GHC -W #-}

2module Generate.JavaScript.Helpers where

3

4−import qualified SourceSyntax.Helpers as Help

4+import AST.Annotation (Region)

5+import qualified AST.PrettyPrint as PP

5import Language.ECMAScript3.Syntax

6import Language.ECMAScript3.Syntax

6

7

7−split :: String -> [String]

8+-- Creating Variables

8−split = go []

9− where

10− go vars str =

11− case break (=='.') str of

12− (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]

13− | otherwise -> go (vars ++ [x]) rest

14− (x,[]) -> vars ++ [x]

15

9

10+var :: String -> Id ()

16var name = Id () name

11var name = Id () name

12+

13+ref :: String -> Expression ()

17ref name = VarRef () (var name)

14ref name = VarRef () (var name)

15+

16+prop :: String -> Prop ()

18prop name = PropId () (var name)

17prop name = PropId () (var name)

19−f <| x = CallExpr () f [x]

18+

20−ret e = ReturnStmt () (Just e)

21−args ==> e = FuncExpr () Nothing (map var args) [ ret e ]

22−function args stmts = FuncExpr () Nothing (map var args) stmts

23−call = CallExpr ()

24string = StringLit ()

19string = StringLit ()

25

20

26−dotSep vars =

21+obj :: [String] -> Expression ()

22+obj vars =

27 case vars of

23 case vars of

28 x:xs -> foldl (DotRef ()) (ref x) (map var xs)

24 x:xs -> foldl (DotRef ()) (ref x) (map var xs)

29 [] -> error "dotSep must be called on a non-empty list of variables"

25 [] -> error "dotSep must be called on a non-empty list of variables"

30

26

31−obj = dotSep . split

27+-- Specific Utilities

32

28

29+localModuleName :: String

30+localModuleName = "$moduleName"

31+

32+throw :: String -> Region -> Expression ()

33+throw kind region =

34+ obj ["_E",kind] `call` [ ref localModuleName, string (PP.renderPretty region) ]

35+

36+-- Function Calls

37+

38+(<|) :: Expression () -> Expression () -> Expression ()

39+(<|) f x = CallExpr () f [x]

40+

41+ret :: Expression () -> Statement ()

42+ret e = ReturnStmt () (Just e)

43+

44+(==>) :: [String] -> Expression () -> Expression ()

45+(==>) args e = FuncExpr () Nothing (map var args) [ ret e ]

46+

47+function :: [String] -> [Statement ()] -> Expression ()

48+function args stmts = FuncExpr () Nothing (map var args) stmts

49+

50+call :: Expression () -> [Expression ()] -> Expression ()

51+call = CallExpr ()

52+

53+-- Checks

54+

55+equal :: Expression () -> Expression () -> Expression ()

33equal a b = InfixExpr () OpStrictEq a b

56equal a b = InfixExpr () OpStrictEq a b

57+

58+instanceof :: String -> Expression () -> Expression ()

34instanceof tipe x =

59instanceof tipe x =

35 InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))

60 InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))

61+

62+typeof :: String -> Expression () -> Expression ()

36typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)

63typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)

64+

65+member :: String -> Expression () -> Expression ()

37member field x = InfixExpr () OpIn (string field) x

66member field x = InfixExpr () OpIn (string field) x

compiler/Generate/JavaScript/Ports.hs+105−74

@@ -2,8 +2,9 @@

2module Generate.JavaScript.Ports (incoming, outgoing) where

3

4import Generate.JavaScript.Helpers

5−import qualified SourceSyntax.Helpers as Help

5+import qualified Generate.JavaScript.Variable as V

6−import SourceSyntax.Type as T

6+import AST.Type as T

7+import qualified AST.Variable as Var

7import Language.ECMAScript3.Syntax

8import Language.ECMAScript3.Syntax

8

9

9data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]

10data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]

@@ -14,64 +15,68 @@ check x jsType continue =

14 CondExpr () (jsFold OpLOr checks x) continue throw

15 CondExpr () (jsFold OpLOr checks x) continue throw

15 where

16 where

16 jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)

17 jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)

17− throw = obj "_E.raise" <| InfixExpr () OpAdd msg x

18+ throw = obj ["_E","raise"] <| InfixExpr () OpAdd msg x

18 msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")

19 msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")

19− checks = case jsType of

20+ checks =

20− JSNumber -> [typeof "number"]

21+ case jsType of

21− JSBoolean -> [typeof "boolean"]

22+ JSNumber -> [typeof "number"]

22− JSString -> [typeof "string", instanceof "String"]

23+ JSBoolean -> [typeof "boolean"]

23− JSArray -> [(obj "_U.isJSArray" <|)]

24+ JSString -> [typeof "string", instanceof "String"]

24− JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]

25+ JSArray -> [(obj ["_U","isJSArray"] <|)]

25−

26+ JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]

26−incoming :: Type -> Expression ()

27+

28+incoming :: CanonicalType -> Expression ()

27incoming tipe =

29incoming tipe =

28 case tipe of

30 case tipe of

29− Data "Signal.Signal" [t] ->

31+ Aliased _ t -> incoming t

30− obj "Native.Ports.incomingSignal" <| incoming t

32+

33+ App (Type v) [t]

34+ | Var.isSignal v -> V.value "Native.Ports" "incomingSignal" <| incoming t

35+

31 _ -> ["v"] ==> inc tipe (ref "v")

36 _ -> ["v"] ==> inc tipe (ref "v")

32

37

33−inc :: Type -> Expression () -> Expression ()

38+inc :: CanonicalType -> Expression () -> Expression ()

34inc tipe x =

39inc tipe x =

35 case tipe of

40 case tipe of

36 Lambda _ _ -> error "functions should not be allowed through input ports"

41 Lambda _ _ -> error "functions should not be allowed through input ports"

37 Var _ -> error "type variables should not be allowed through input ports"

42 Var _ -> error "type variables should not be allowed through input ports"

38−

43+ Aliased _ t ->

39− Data "Json.Value" [] ->

44+ inc t x

40− obj "Native.Json.fromJS" <| x

45+

41−

46+ Type (Var.Canonical Var.BuiltIn name)

42− Data ctor []

47+ | name == "Int" -> from JSNumber

43− | ctor == "Int" -> from JSNumber

48+ | name == "Float" -> from JSNumber

44− | ctor == "Float" -> from JSNumber

49+ | name == "Bool" -> from JSBoolean

45− | ctor == "Bool" -> from JSBoolean

50+ | name == "String" -> from JSString

46− | ctor == "String" -> from JSString

47 where

51 where

48 from checks = check x checks x

52 from checks = check x checks x

49

53

50− Data ctor [t]

54+ Type name

51− | ctor == "Maybe.Maybe" ->

55+ | Var.isJson name -> V.value "Native.Json" "fromJS" <| x

52− CondExpr () (equal x (NullLit ()))

56+ | Var.isTuple name -> incomingTuple [] x

53− (obj "Maybe.Nothing")

57+ | otherwise -> error "bad type got to incoming port generation code"

54− (obj "Maybe.Just" <| inc t x)

55

58

56− | ctor == "_List" ->

59+ App f args ->

57− check x JSArray (obj "_L.fromArray" <| array)

60+ case f : args of

61+ Type name : [t]

62+ | Var.isMaybe name ->

63+ CondExpr ()

64+ (equal x (NullLit ()))

65+ (V.value "Maybe" "Nothing")

66+ (V.value "Maybe" "Just" <| inc t x)

58

67

59− | ctor == "Array.Array" ->

68+ | Var.isList name ->

60− check x JSArray (obj "_A.fromJSArray" <| array)

69+ check x JSArray (obj ["_L","fromArray"] <| array)

61

70

62− where

71+ | Var.isArray name ->

63− array = DotRef () x (var "map") <| incoming t

72+ check x JSArray (obj ["_A","fromJSArray"] <| array)

73+ where

74+ array = DotRef () x (var "map") <| incoming t

64

75

65− Data ctor ts

76+ Type name : ts

66− | Help.isTuple ctor -> check x JSArray tuple

77+ | Var.isTuple name -> incomingTuple ts x

67− where

68− tuple = ObjectLit () $ (prop "ctor", string ctor) : values

69− values = zipWith convert [0..] ts

70− convert n t = ( prop ('_':show n)

71− , inc t (BracketRef () x (IntLit () n)))

72

78

73− Data _ _ ->

79+ _ -> error "bad ADT got to incoming port generation code"

74− error "bad ADT got to incoming port generation code"

75

80

76 Record _ (Just _) ->

81 Record _ (Just _) ->

77 error "bad record got to incoming port generation code"

82 error "bad record got to incoming port generation code"

@@ -83,15 +88,34 @@ inc tipe x =

83 keys = map convert fields

88 keys = map convert fields

84 convert (f,t) = (prop f, inc t (DotRef () x (var f)))

89 convert (f,t) = (prop f, inc t (DotRef () x (var f)))

85

90

91+incomingTuple :: [CanonicalType] -> Expression () -> Expression ()

92+incomingTuple types x =

93+ check x JSArray (ObjectLit () fields)

94+ where

95+ fields = (prop "ctor", ctor) : zipWith convert [0..] types

96+

97+ ctor = string ("_Tuple" ++ show (length types))

98+

99+ convert n t =

100+ ( prop ('_':show n)

101+ , inc t (BracketRef () x (IntLit () n))

102+ )

103+

104+outgoing :: CanonicalType -> Expression ()

86outgoing tipe =

105outgoing tipe =

87 case tipe of

106 case tipe of

88− Data "Signal.Signal" [t] ->

107+ Aliased _ t -> outgoing t

89− obj "Native.Ports.outgoingSignal" <| outgoing t

108+

109+ App (Type v) [t]

110+ | Var.isSignal v -> V.value "Native.Ports" "outgoingSignal" <| outgoing t

111+

90 _ -> ["v"] ==> out tipe (ref "v")

112 _ -> ["v"] ==> out tipe (ref "v")

91

113

92−out :: Type -> Expression () -> Expression ()

114+out :: CanonicalType -> Expression () -> Expression ()

93out tipe x =

115out tipe x =

94 case tipe of

116 case tipe of

117+ Aliased _ t -> out t x

118+

95 Lambda _ _

119 Lambda _ _

96 | numArgs > 1 && numArgs < 10 ->

120 | numArgs > 1 && numArgs < 10 ->

97 func (ref ('A':show numArgs) `call` (x:values))

121 func (ref ('A':show numArgs) `call` (x:values))

@@ -101,36 +125,43 @@ out tipe x =

101 numArgs = length ts - 1

125 numArgs = length ts - 1

102 args = map (\n -> '_' : show n) [0..]

126 args = map (\n -> '_' : show n) [0..]

103 values = zipWith inc (init ts) (map ref args)

127 values = zipWith inc (init ts) (map ref args)

104− func body = function (take numArgs args)

128+ func body =

105− [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]

129+ function (take numArgs args)

106− , ret (out (last ts) (ref "_r"))

130+ [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]

107− ]

131+ , ret (out (last ts) (ref "_r"))

132+ ]

108

133

109 Var _ -> error "type variables should not be allowed through input ports"

134 Var _ -> error "type variables should not be allowed through input ports"

110− Data ctor []

135+

111− | ctor `elem` ["Int","Float","Bool","String"] -> x

136+ Type (Var.Canonical Var.BuiltIn name)

112− | ctor == "Json.Value" ->

137+ | name `elem` ["Int","Float","Bool","String"] -> x

113− obj "Native.Json.toJS" <| x

138+

114−

139+ Type name

115− Data ctor [t]

140+ | Var.isJson name -> V.value "Native.Json" "toJS" <| x

116− | ctor == "Maybe.Maybe" ->

141+ | Var.isTuple name -> ArrayLit () []

117− CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))

142+ | otherwise -> error "bad type got to outgoing port generation code"

118− (NullLit ())

143+

119− (out t (DotRef () x (var "_0")))

144+ App f args ->

120−

145+ case f : args of

121− | ctor == "_List" ->

146+ Type name : [t]

122− DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t

147+ | Var.isMaybe name ->

123−

148+ CondExpr ()

124− | ctor == "Array.Array" ->

149+ (equal (DotRef () x (var "ctor")) (string "Nothing"))

125− DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t

150+ (NullLit ())

126−

151+ (out t (DotRef () x (var "_0")))

127− Data ctor ts

152+

128− | Help.isTuple ctor ->

153+ | Var.isArray name ->

129− let convert n t = out t $ DotRef () x $ var ('_':show n)

154+ DotRef () (obj ["_A","toJSArray"] <| x) (var "map") <| outgoing t

130− in ArrayLit () $ zipWith convert [0..] ts

155+

131−

156+ | Var.isList name ->

132− Data _ _ ->

157+ DotRef () (obj ["_L","toArray"] <| x) (var "map") <| outgoing t

133− error "bad ADT got to outgoing port generation code"

158+

159+ Type name : ts

160+ | Var.isTuple name ->

161+ let convert n t = out t $ DotRef () x $ var ('_':show n)

162+ in ArrayLit () $ zipWith convert [0..] ts

163+

164+ _ -> error "bad ADT got to outgoing port generation code"

134

165

135 Record _ (Just _) ->

166 Record _ (Just _) ->

136 error "bad record got to outgoing port generation code"

167 error "bad record got to outgoing port generation code"

compiler/Generate/JavaScript/Variable.hsnew file+53

@@ -0,0 +1,53 @@

1+{-# OPTIONS_GHC -W #-}

2+module Generate.JavaScript.Variable where

3+

4+import qualified AST.Helpers as Help

5+import qualified AST.Variable as Var

6+import qualified Data.Set as Set

7+import qualified Generate.JavaScript.Helpers as JS

8+import qualified Language.ECMAScript3.Syntax as JS

9+

10+swap :: Char -> Char -> Char -> Char

11+swap from to c = if c == from then to else c

12+

13+canonical :: Var.Canonical -> JS.Expression ()

14+canonical (Var.Canonical home name) =

15+ case Help.isOp name of

16+ True -> JS.BracketRef () (JS.obj (home' ++ ["_op"])) (JS.string name)

17+ False -> JS.obj (home' ++ [ varName name ])

18+ where

19+ home' =

20+ case home of

21+ Var.Local -> []

22+ Var.BuiltIn -> []

23+ Var.Module path -> [ moduleName path ]

24+

25+moduleName :: String -> String

26+moduleName x = '$' : map (swap '.' '$') x

27+

28+varName :: String -> String

29+varName x = map (swap '\'' '$') x'

30+ where

31+ x' = if Set.member x jsReserveds then '$' : x else x

32+

33+value :: String -> String -> JS.Expression ()

34+value home name =

35+ canonical (Var.Canonical (Var.Module home) name)

36+

37+jsReserveds :: Set.Set String

38+jsReserveds = Set.fromList

39+ [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"

40+ , "arguments", "int", "byte", "char", "goto", "long", "final", "float"

41+ , "short", "double", "native", "throws", "boolean", "abstract", "volatile"

42+ , "transient", "synchronized", "function", "break", "case", "catch"

43+ , "continue", "debugger", "default", "delete", "do", "else", "finally"

44+ , "for", "function", "if", "in", "instanceof", "new", "return", "switch"

45+ , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"

46+ , "const", "enum", "export", "extends", "import", "super", "implements"

47+ , "interface", "let", "package", "private", "protected", "public"

48+ , "static", "yield"

49+ -- reserved by the Elm runtime system

50+ , "Elm", "ElmRuntime"

51+ , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"

52+ , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"

53+ ]

compiler/Generate/Markdown.hs+34−31

@@ -1,39 +1,42 @@

1module Generate.Markdown where

2

3−import Text.Pandoc

3+import qualified Cheapskate as CS

4+import qualified Cheapskate.Html as CS

4import qualified Data.Set as Set

5import qualified Data.Set as Set

6+import qualified Data.Text as Text

7+import qualified Text.Blaze.Html.Renderer.String as Blaze

8+import qualified Text.Highlighting.Kate as Kate

9+

10+import Debug.Trace

11+

12+(|>) :: a -> (a -> b) -> b

13+x |> f = f x

5

14

6toHtml :: String -> String

15toHtml :: String -> String

7−toHtml = writeHtmlString writeOptions . readMarkdown readOptions

16+toHtml rawMarkdown =

17+ Text.pack rawMarkdown

18+ |> CS.markdown options

19+ |> CS.walk highlightCode

20+ |> CS.renderDoc

21+ |> Blaze.renderHtml

8

22

9−readOptions =

23+options :: CS.Options

10− def { readerExtensions = elmExtensions

24+options =

11− , readerApplyMacros = False

25+ CS.Options

12− }

26+ { CS.sanitize = False

27+ , CS.allowRawHtml = True

28+ , CS.preserveHardBreaks = False

29+ , CS.debug = False

30+ }

13

31

14−writeOptions =

32+highlightCode :: CS.Block -> CS.Block

15− def { writerExtensions = elmExtensions

33+highlightCode block =

16− , writerHighlight = True

34+ case block of

17− }

35+ CS.CodeBlock (CS.CodeAttr lang _info) src ->

36+ Kate.highlightAs (Text.unpack lang) (Text.unpack src)

37+ |> Kate.formatHtmlBlock Kate.defaultFormatOpts

38+ |> Blaze.renderHtml

39+ |> Text.pack

40+ |> CS.HtmlBlock

18

41

19−elmExtensions :: Set.Set Extension

42+ _ -> block

20−elmExtensions = Set.fromList

21− [ Ext_raw_html

22− , Ext_fenced_code_blocks

23− , Ext_fenced_code_attributes

24− , Ext_backtick_code_blocks

25− , Ext_inline_code_attributes

26− , Ext_markdown_in_html_blocks

27− , Ext_escaped_line_breaks

28− , Ext_fancy_lists

29− , Ext_startnum

30− , Ext_definition_lists

31− , Ext_example_lists

32− , Ext_all_symbols_escapable

33− , Ext_intraword_underscores

34− , Ext_blank_before_blockquote

35− , Ext_blank_before_header

36− , Ext_auto_identifiers

37− , Ext_header_attributes

38− , Ext_implicit_header_references

39− ]

compiler/Language/Elm/DevTools.hsdeleted−46

@@ -1,46 +0,0 @@

1−{- | This module aims to make it easier to create dev tools for Elm.

2−

3− It provides the ability to:

4−

5− * Detect problems in a program

6− * Figure out types of particular expressions

7− * Canonicalize variables

8− * Convert expressions to JS and HTML

9−

10− This module gives limeted access to the structure of an Elm Program.

11− Giving full access would expose many internal details that are likely to

12− change as Elm progresses. These details have been hidden to avoid breaking

13− changes.

14−-}

15−module Language.Elm.DevTools where

16−

17−data Program

18−

19−-- | Parse an Elm program into an AST.

20−parse :: String -> Either [Problem] Program

21−

22−-- | Get the type of a region of the program. Lets you look

23−-- up the type of particular values and expressions.

24−typeOf :: Program -> Region -> Either [Problem] String

25−

26−-- | Canonicalize a variable. So in a normal module `map` would be canonicalized

27−-- to `List.map`.

28−canonicalize :: Program -> Region -> [String]

29−

30−-- | Any problem that may come up while parsing or typing a program.

31−-- All problems come with a region that is causing the problem.

32−data Problem = Problem { message :: String, region :: Region }

33−

34−type Row = Int

35−type Column = Int

36−

37−-- | Represents a region, spanning two points in the source code.

38−data Region = Region { start :: (Row,Column), end :: (Row,Column) }

39−

40−-- | Takes a specific point in the source code, such as the cursor position.

41−-- It then determines the region that best represents that point. When the

42−-- cursor is within a variable, it chooses the variable. When the cursor is

43−-- on parentheses, it selects the region within the parentheses. When the

44−-- cursor is on keywords like let, it chooses the whole let-expression.

45−region :: (Row,Column) -> Region

46−region pos = Region pos pos

compiler/Metadata/Prelude.hs+84−19

@@ -2,32 +2,97 @@

2module Metadata.Prelude (interfaces, add) where

3

4import qualified Data.Map as Map

5+import qualified Data.Set as Set

5import qualified Control.Exception as E

6import qualified Control.Exception as E

6import System.Exit

7import System.Exit

7import System.IO

8import System.IO

8−import SourceSyntax.Module

9+import AST.Module as Module

10+import qualified AST.Variable as Var

9import qualified Build.Interface as Interface

11import qualified Build.Interface as Interface

10import Build.Utils (getDataFile)

12import Build.Utils (getDataFile)

11

13

12−add :: Bool -> Module def -> Module def

13−add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls

14− where

15− customIms = if noPrelude then [] else concatMap addModule prelude

16

14

17− addModule (n, method) = case lookup n ims of

15+-- DEFINITION OF THE PRELUDE

18− Nothing -> [(n, method)]

19− Just (As _) -> [(n, method)]

20− Just _ -> []

21

16

22−prelude :: [(String, ImportMethod)]

17+type ImportDict =

23−prelude = string ++ text ++ map (\n -> (n, Hiding [])) modules

18+ Map.Map String ([String], Var.Listing Var.Value)

19+

20+prelude :: ImportDict

21+prelude = Map.unions [ string, text, maybe, openImports ]

22+ where

23+ importing :: String -> [Var.Value] -> ImportDict

24+ importing name values =

25+ Map.singleton name ([], Var.Listing values False)

26+

27+ openImports :: ImportDict

28+ openImports =

29+ Map.fromList $ map (\name -> (name, ([], Var.openListing))) $

30+ [ "Basics", "Signal", "List", "Time", "Color"

31+ , "Graphics.Element", "Graphics.Collage"

32+ , "Native.Ports", "Native.Json"

33+ ]

34+

35+ maybe :: ImportDict

36+ maybe = importing "Maybe" [ Var.ADT "Maybe" Var.openListing ]

37+

38+ string :: ImportDict

39+ string = importing "String" [Var.Value "show"]

40+

41+ text :: ImportDict

42+ text = importing "Text" (Var.ADT "Text" (Var.Listing [] False) : values)

43+ where

44+ values =

45+ map Var.Value

46+ [ "toText", "leftAligned", "rightAligned", "centered", "justified"

47+ , "plainText", "asText", "typeface", "monospace", "bold", "italic"

48+ ]

49+

50+

51+-- ADDING PRELUDE TO A MODULE

52+

53+add :: Bool -> Module exs body -> Module exs body

54+add noPrelude (Module moduleName path exports imports decls) =

55+ Module moduleName path exports ammendedImports decls

56+ where

57+ ammendedImports =

58+ importDictToList $

59+ foldr addImport (if noPrelude then Map.empty else prelude) imports

60+

61+importDictToList :: ImportDict -> [(String, ImportMethod)]

62+importDictToList dict =

63+ concatMap toImports (Map.toList dict)

64+ where

65+ toImports (name, (qualifiers, listing@(Var.Listing explicits open))) =

66+ map (\qualifier -> (name, As qualifier)) qualifiers

67+ ++

68+ if open || not (null explicits)

69+ then [(name, Open listing)]

70+ else []

71+

72+addImport :: (String, ImportMethod) -> ImportDict -> ImportDict

73+addImport (name, method) importDict =

74+ Map.alter mergeMethods name importDict

24 where

75 where

25− text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]

76+ mergeMethods :: Maybe ([String], Var.Listing Var.Value)

26− string = map ((,) "String") [ As "String", Importing ["show"] ]

77+ -> Maybe ([String], Var.Listing Var.Value)

27− modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Color"

78+ mergeMethods entry =

28− , "Graphics.Element", "Graphics.Collage"

79+ let (qualifiers, listing) =

29− , "Native.Ports", "Native.Json"

80+ case entry of

30− ]

81+ Nothing -> ([], Var.Listing [] False)

82+ Just v -> v

83+ in

84+ case method of

85+ As qualifier -> Just (qualifier : qualifiers, listing)

86+ Open newListing ->

87+ Just (qualifiers, mergeListings newListing listing)

88+

89+ mergeListings (Var.Listing explicits1 open1) (Var.Listing explicits2 open2) =

90+ Var.Listing

91+ (Set.toList (Set.fromList (explicits1 ++ explicits2)))

92+ (open1 || open2)

93+

94+

95+-- EXTRACT INTERFACES FROM STATIC FILE

31

96

32interfaces :: Bool -> IO Interfaces

97interfaces :: Bool -> IO Interfaces

33interfaces noPrelude =

98interfaces noPrelude =

@@ -42,14 +107,14 @@ safeReadDocs name =

42 hPutStrLn stderr $ unlines $

107 hPutStrLn stderr $ unlines $

43 [ "Error reading types for standard library from file " ++ name

108 [ "Error reading types for standard library from file " ++ name

44 , " If you are using a stable version of Elm, please report an issue at"

109 , " If you are using a stable version of Elm, please report an issue at"

45− , " <http://github.com/evancz/Elm/issues> specifying version numbers for"

110+ , " <http://github.com/elm-lang/Elm/issues> specifying version numbers for"

46 , " Elm and your OS." ]

111 , " Elm and your OS." ]

47 exitFailure

112 exitFailure

48

113

49readDocs :: FilePath -> IO Interfaces

114readDocs :: FilePath -> IO Interfaces

50readDocs filePath = do

115readDocs filePath = do

51 interfaces <- Interface.load filePath

116 interfaces <- Interface.load filePath

52− case mapM (Interface.isValid filePath) (interfaces :: [(String, ModuleInterface)]) of

117+ case mapM (Interface.isValid filePath) (interfaces :: [(String, Module.Interface)]) of

53 Left err -> do

118 Left err -> do

54 hPutStrLn stderr err

119 hPutStrLn stderr err

55 exitFailure

120 exitFailure

compiler/Parse/Binop.hs+19−17

@@ -5,9 +5,11 @@ import Control.Applicative ((<$>))

5import qualified Data.List as List

6import qualified Data.Map as Map

7

8−import SourceSyntax.Annotation (merge)

8+import AST.Annotation (merge)

9−import qualified SourceSyntax.Expression as E

9+import AST.Declaration (Assoc(..))

10−import SourceSyntax.Declaration (Assoc(..))

10+import AST.Expression.General (Expr'(Binop))

11+import qualified AST.Expression.Source as Source

12+import qualified AST.Variable as Var

11import Text.Parsec

13import Text.Parsec

12import Parse.Helpers

14import Parse.Helpers

13

15

@@ -17,13 +19,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table

17opAssoc :: OpTable -> String -> Assoc

19opAssoc :: OpTable -> String -> Assoc

18opAssoc table op = snd $ Map.findWithDefault (9,L) op table

20opAssoc table op = snd $ Map.findWithDefault (9,L) op table

19

21

20−hasLevel :: OpTable -> Int -> (String, E.ParseExpr) -> Bool

22+hasLevel :: OpTable -> Int -> (String, Source.Expr) -> Bool

21hasLevel table n (op,_) = opLevel table op == n

23hasLevel table n (op,_) = opLevel table op == n

22

24

23−binops :: IParser E.ParseExpr

25+binops :: IParser Source.Expr

24− -> IParser E.ParseExpr

26+ -> IParser Source.Expr

25 -> IParser String

27 -> IParser String

26− -> IParser E.ParseExpr

28+ -> IParser Source.Expr

27binops term last anyOp =

29binops term last anyOp =

28 do e <- term

30 do e <- term

29 table <- getState

31 table <- getState

@@ -39,9 +41,9 @@ binops term last anyOp =

39

41

40split :: OpTable

42split :: OpTable

41 -> Int

43 -> Int

42− -> E.ParseExpr

44+ -> Source.Expr

43− -> [(String, E.ParseExpr)]

45+ -> [(String, Source.Expr)]

44− -> IParser E.ParseExpr

46+ -> IParser Source.Expr

45split _ _ e [] = return e

47split _ _ e [] = return e

46split table n e eops = do

48split table n e eops = do

47 assoc <- getAssoc table n eops

49 assoc <- getAssoc table n eops

@@ -50,26 +52,26 @@ split table n e eops = do

50 case assoc of R -> joinR es ops

52 case assoc of R -> joinR es ops

51 _ -> joinL es ops

53 _ -> joinL es ops

52

54

53−splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]

55+splitLevel :: OpTable -> Int -> Source.Expr -> [(String, Source.Expr)]

54− -> [IParser E.ParseExpr]

56+ -> [IParser Source.Expr]

55splitLevel table n e eops =

57splitLevel table n e eops =

56 case break (hasLevel table n) eops of

58 case break (hasLevel table n) eops of

57 (lops, (_op,e'):rops) ->

59 (lops, (_op,e'):rops) ->

58 split table (n+1) e lops : splitLevel table n e' rops

60 split table (n+1) e lops : splitLevel table n e' rops

59 (lops, []) -> [ split table (n+1) e lops ]

61 (lops, []) -> [ split table (n+1) e lops ]

60

62

61−joinL :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr

63+joinL :: [Source.Expr] -> [String] -> IParser Source.Expr

62joinL [e] [] = return e

64joinL [e] [] = return e

63−joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops

65+joinL (a:b:es) (op:ops) = joinL (merge a b (Binop (Var.Raw op) a b) : es) ops

64joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

66joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

65

67

66−joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr

68+joinR :: [Source.Expr] -> [String] -> IParser Source.Expr

67joinR [e] [] = return e

69joinR [e] [] = return e

68joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

70joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

69− return (merge a e (E.Binop op a e))

71+ return (merge a e (Binop (Var.Raw op) a e))

70joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

72joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

71

73

72−getAssoc :: OpTable -> Int -> [(String,E.ParseExpr)] -> IParser Assoc

74+getAssoc :: OpTable -> Int -> [(String,Source.Expr)] -> IParser Assoc

73getAssoc table n eops

75getAssoc table n eops

74 | all (==L) assocs = return L

76 | all (==L) assocs = return L

75 | all (==R) assocs = return R

77 | all (==R) assocs = return R

compiler/Parse/Declaration.hs+7−8

@@ -7,16 +7,15 @@ import Text.Parsec hiding (newline,spaces)

7import Parse.Helpers

8import qualified Parse.Expression as Expr

9import qualified Parse.Type as Type

10−import qualified SourceSyntax.Declaration as D

10+import qualified AST.Declaration as D

11

12−

12+declaration :: IParser D.SourceDecl

13−declaration :: IParser D.ParseDeclaration

14declaration = alias <|> datatype <|> infixDecl <|> port <|> definition

13declaration = alias <|> datatype <|> infixDecl <|> port <|> definition

15

14

16−definition :: IParser D.ParseDeclaration

15+definition :: IParser D.SourceDecl

17definition = D.Definition <$> Expr.def

16definition = D.Definition <$> Expr.def

18

17

19−alias :: IParser D.ParseDeclaration

18+alias :: IParser D.SourceDecl

20alias = do

19alias = do

21 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

20 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

22 forcedWS

21 forcedWS

@@ -26,7 +25,7 @@ alias = do

26 tipe <- Type.expr

25 tipe <- Type.expr

27 return (D.TypeAlias name args tipe)

26 return (D.TypeAlias name args tipe)

28

27

29−datatype :: IParser D.ParseDeclaration

28+datatype :: IParser D.SourceDecl

30datatype = do

29datatype = do

31 reserved "data" <?> "datatype definition (data T = A | B | ...)"

30 reserved "data" <?> "datatype definition (data T = A | B | ...)"

32 forcedWS

31 forcedWS

@@ -37,7 +36,7 @@ datatype = do

37 return $ D.Datatype name args tcs

36 return $ D.Datatype name args tcs

38

37

39

38

40−infixDecl :: IParser D.ParseDeclaration

39+infixDecl :: IParser D.SourceDecl

41infixDecl = do

40infixDecl = do

42 assoc <- choice [ reserved "infixl" >> return D.L

41 assoc <- choice [ reserved "infixl" >> return D.L

43 , reserved "infix" >> return D.N

42 , reserved "infix" >> return D.N

@@ -48,7 +47,7 @@ infixDecl = do

48 D.Fixity assoc (read [n]) <$> anyOp

47 D.Fixity assoc (read [n]) <$> anyOp

49

48

50

49

51−port :: IParser D.ParseDeclaration

50+port :: IParser D.SourceDecl

52port =

51port =

53 do try (reserved "port")

52 do try (reserved "port")

54 whitespace

53 whitespace

compiler/Parse/Expression.hs+38−35

@@ -6,45 +6,47 @@ import Text.Parsec hiding (newline,spaces)

6import Text.Parsec.Indent

7

8import Parse.Binop

9−import Parse.Helpers

9+import Parse.Helpers as Help

10import Parse.Literal

11import qualified Parse.Pattern as Pattern

12import qualified Parse.Type as Type

13

14−import SourceSyntax.Annotation as Annotation

14+import AST.Annotation as Annotation

15−import qualified SourceSyntax.Pattern as P

15+import AST.Expression.General

16−import qualified SourceSyntax.Literal as L

16+import qualified AST.Expression.Source as Source

17−import SourceSyntax.Expression

17+import qualified AST.Literal as L

18+import qualified AST.Pattern as P

19+import qualified AST.Variable as Var

18

20

19

21

20-------- Basic Terms --------

22-------- Basic Terms --------

21

23

22−varTerm :: IParser ParseExpr'

24+varTerm :: IParser Source.Expr'

23varTerm = toVar <$> var <?> "variable"

25varTerm = toVar <$> var <?> "variable"

24

26

25−toVar :: String -> ParseExpr'

27+toVar :: String -> Source.Expr'

26toVar v = case v of "True" -> Literal (L.Boolean True)

28toVar v = case v of "True" -> Literal (L.Boolean True)

27 "False" -> Literal (L.Boolean False)

29 "False" -> Literal (L.Boolean False)

28 _ -> rawVar v

30 _ -> rawVar v

29

31

30−accessor :: IParser ParseExpr'

32+accessor :: IParser Source.Expr'

31accessor = do

33accessor = do

32 (start, lbl, end) <- located (try (string "." >> rLabel))

34 (start, lbl, end) <- located (try (string "." >> rLabel))

33 let loc e = Annotation.at start end e

35 let loc e = Annotation.at start end e

34 return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))

36 return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))

35

37

36−negative :: IParser ParseExpr'

38+negative :: IParser Source.Expr'

37negative = do

39negative = do

38 (start, nTerm, end) <-

40 (start, nTerm, end) <-

39 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

41 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

40 let loc e = Annotation.at start end e

42 let loc e = Annotation.at start end e

41− return (Binop "-" (loc $ Literal (L.IntNum 0)) nTerm)

43+ return (Binop (Var.Raw "-") (loc $ Literal (L.IntNum 0)) nTerm)

42

44

43

45

44-------- Complex Terms --------

46-------- Complex Terms --------

45

47

46−listTerm :: IParser ParseExpr'

48+listTerm :: IParser Source.Expr'

47−listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> commaSep expr)

49+listTerm = markdown' <|> shader' <|> braces (try range <|> ExplicitList <$> commaSep expr)

48 where

50 where

49 range = do

51 range = do

50 lo <- expr

52 lo <- expr

@@ -54,17 +56,18 @@ listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> co

54 markdown' = do

56 markdown' = do

55 pos <- getPosition

57 pos <- getPosition

56 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

58 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

57− (rawText, exprs) <- markdown (interpolation uid)

59+ (rawText, exprs) <- Help.markdown (interpolation uid)

58 return (Markdown uid (filter (/='\r') rawText) exprs)

60 return (Markdown uid (filter (/='\r') rawText) exprs)

59

61

60− glShader' = do

62+ shader' = do

61 pos <- getPosition

63 pos <- getPosition

62 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

64 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

63− (rawSrc, tipe) <- glShader

65+ (rawSrc, tipe) <- Help.shader

64 return $ GLShader uid (filter (/='\r') rawSrc) tipe

66 return $ GLShader uid (filter (/='\r') rawSrc) tipe

65

67

66 span uid index =

68 span uid index =

67− "<span id=\"md-" ++ uid ++ "-" ++ show index ++ "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"

69+ "<span id=\"md-" ++ uid ++ "-" ++ show index ++

70+ "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"

68

71

69 interpolation uid exprs = do

72 interpolation uid exprs = do

70 try (string "{{")

73 try (string "{{")

@@ -72,14 +75,14 @@ listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> co

72 string "}}"

75 string "}}"

73 return (span uid (length exprs), exprs ++ [e])

76 return (span uid (length exprs), exprs ++ [e])

74

77

75−parensTerm :: IParser ParseExpr

78+parensTerm :: IParser Source.Expr

76parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

79parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

77 where

80 where

78 opFn = do

81 opFn = do

79 (start, op, end) <- located anyOp

82 (start, op, end) <- located anyOp

80 let loc = Annotation.at start end

83 let loc = Annotation.at start end

81 return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $

84 return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $

82− Binop op (loc $ rawVar "x") (loc $ rawVar "y")

85+ Binop (Var.Raw op) (loc (rawVar "x")) (loc (rawVar "y"))

83

86

84 tupleFn = do

87 tupleFn = do

85 let comma = char ',' <?> "comma ','"

88 let comma = char ',' <?> "comma ','"

@@ -95,7 +98,7 @@ parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

95 [e] -> e

98 [e] -> e

96 _ -> Annotation.at start end (tuple es)

99 _ -> Annotation.at start end (tuple es)

97

100

98−recordTerm :: IParser ParseExpr

101+recordTerm :: IParser Source.Expr

99recordTerm = brackets $ choice [ misc, addLocation record ]

102recordTerm = brackets $ choice [ misc, addLocation record ]

100 where

103 where

101 field = do

104 field = do

@@ -129,14 +132,14 @@ recordTerm = brackets $ choice [ misc, addLocation record ]

129 Nothing -> try (insert record) <|> try (modify record)

132 Nothing -> try (insert record) <|> try (modify record)

130

133

131

134

132−term :: IParser ParseExpr

135+term :: IParser Source.Expr

133term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

136term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

134 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

137 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

135 <?> "basic term (4, x, 'c', etc.)"

138 <?> "basic term (4, x, 'c', etc.)"

136

139

137-------- Applications --------

140-------- Applications --------

138

141

139−appExpr :: IParser ParseExpr

142+appExpr :: IParser Source.Expr

140appExpr = do

143appExpr = do

141 t <- term

144 t <- term

142 ts <- constrainedSpacePrefix term $ \str ->

145 ts <- constrainedSpacePrefix term $ \str ->

@@ -147,12 +150,12 @@ appExpr = do

147

150

148-------- Normal Expressions --------

151-------- Normal Expressions --------

149

152

150−binaryExpr :: IParser ParseExpr

153+binaryExpr :: IParser Source.Expr

151binaryExpr = binops appExpr lastExpr anyOp

154binaryExpr = binops appExpr lastExpr anyOp

152 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

155 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

153 <|> lambdaExpr

156 <|> lambdaExpr

154

157

155−ifExpr :: IParser ParseExpr'

158+ifExpr :: IParser Source.Expr'

156ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

159ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

157 where

160 where

158 normal = do

161 normal = do

@@ -168,7 +171,7 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

168 b <- expr ; padded arrow

171 b <- expr ; padded arrow

169 (,) b <$> expr

172 (,) b <$> expr

170

173

171−lambdaExpr :: IParser ParseExpr

174+lambdaExpr :: IParser Source.Expr

172lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

175lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

173 whitespace

176 whitespace

174 args <- spaceSep1 Pattern.term

177 args <- spaceSep1 Pattern.term

@@ -176,17 +179,17 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

176 body <- expr

179 body <- expr

177 return (makeFunction args body)

180 return (makeFunction args body)

178

181

179−defSet :: IParser [ParseDef]

182+defSet :: IParser [Source.Def]

180defSet = block (do d <- def ; whitespace ; return d)

183defSet = block (do d <- def ; whitespace ; return d)

181

184

182−letExpr :: IParser ParseExpr'

185+letExpr :: IParser Source.Expr'

183letExpr = do

186letExpr = do

184 reserved "let" ; whitespace

187 reserved "let" ; whitespace

185 defs <- defSet

188 defs <- defSet

186 padded (reserved "in")

189 padded (reserved "in")

187 Let defs <$> expr

190 Let defs <$> expr

188

191

189−caseExpr :: IParser ParseExpr'

192+caseExpr :: IParser Source.Expr'

190caseExpr = do

193caseExpr = do

191 reserved "case"; e <- padded expr; reserved "of"; whitespace

194 reserved "case"; e <- padded expr; reserved "of"; whitespace

192 Case e <$> (with <|> without)

195 Case e <$> (with <|> without)

@@ -196,13 +199,13 @@ caseExpr = do

196 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

199 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

197 without = block (do c <- case_ ; whitespace ; return c)

200 without = block (do c <- case_ ; whitespace ; return c)

198

201

199−expr :: IParser ParseExpr

202+expr :: IParser Source.Expr

200expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

203expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

201 <|> lambdaExpr

204 <|> lambdaExpr

202 <|> binaryExpr

205 <|> binaryExpr

203 <?> "an expression"

206 <?> "an expression"

204

207

205−defStart :: IParser [P.Pattern]

208+defStart :: IParser [P.RawPattern]

206defStart =

209defStart =

207 choice [ do p1 <- try Pattern.term

210 choice [ do p1 <- try Pattern.term

208 infics p1 <|> func p1

211 infics p1 <|> func p1

@@ -222,24 +225,24 @@ defStart =

222 return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]

225 return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]

223 else [ P.Var (o:p), p1, p2 ]

226 else [ P.Var (o:p), p1, p2 ]

224

227

225−makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr

228+makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr

226makeFunction args body@(A ann _) =

229makeFunction args body@(A ann _) =

227 foldr (\arg body' -> A ann $ Lambda arg body') body args

230 foldr (\arg body' -> A ann $ Lambda arg body') body args

228

231

229−definition :: IParser ParseDef

232+definition :: IParser Source.Def

230definition = withPos $ do

233definition = withPos $ do

231 (name:args) <- defStart

234 (name:args) <- defStart

232 padded equals

235 padded equals

233 body <- expr

236 body <- expr

234− return . Def name $ makeFunction args body

237+ return . Source.Definition name $ makeFunction args body

235

238

236−typeAnnotation :: IParser ParseDef

239+typeAnnotation :: IParser Source.Def

237−typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

240+typeAnnotation = Source.TypeAnnotation <$> try start <*> Type.expr

238 where

241 where

239 start = do

242 start = do

240 v <- lowVar <|> parens symOp

243 v <- lowVar <|> parens symOp

241 padded hasType

244 padded hasType

242 return v

245 return v

243

246

244−def :: IParser ParseDef

247+def :: IParser Source.Def

245def = typeAnnotation <|> definition

248def = typeAnnotation <|> definition

compiler/Parse/Helpers.hs+14−31

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

6import Control.Monad

7import Control.Monad.State

8import Data.Char (isUpper)

9−import qualified Data.Set as Set

10import qualified Data.Map as Map

9import qualified Data.Map as Map

11import qualified Language.GLSL.Parser as GLP

10import qualified Language.GLSL.Parser as GLP

12import Language.GLSL.Syntax as GLS

11import Language.GLSL.Syntax as GLS

@@ -14,13 +13,14 @@ import Text.Parsec hiding (newline,spaces,State)

14import Text.Parsec.Indent

13import Text.Parsec.Indent

15import qualified Text.Parsec.Token as T

14import qualified Text.Parsec.Token as T

16

15

17−import SourceSyntax.Annotation as Annotation

16+import AST.Annotation as Annotation

18−import SourceSyntax.Declaration (Assoc)

17+import AST.Declaration (Assoc)

19−import SourceSyntax.Expression

18+import AST.Expression.General

20−import SourceSyntax.Helpers as Help

19+import qualified AST.Expression.Source as Source

21−import SourceSyntax.Literal as Literal

20+import AST.Helpers as Help

22−import SourceSyntax.PrettyPrint

21+import AST.Literal as Literal

23−import SourceSyntax.Variable as Variable

22+import AST.PrettyPrint

23+import qualified AST.Variable as Variable

24

25reserveds = [ "if", "then", "else"

26 , "case", "of"

@@ -29,25 +29,8 @@ reserveds = [ "if", "then", "else"

29 , "module", "where"

30 , "import", "as", "hiding", "open"

31 , "export", "foreign"

32− , "deriving", "port" ]

32+ , "deriving", "port"

33−

33+ ]

34−jsReserveds :: Set.Set String

35−jsReserveds = Set.fromList

36− [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"

37− , "arguments", "int", "byte", "char", "goto", "long", "final", "float"

38− , "short", "double", "native", "throws", "boolean", "abstract", "volatile"

39− , "transient", "synchronized", "function", "break", "case", "catch"

40− , "continue", "debugger", "default", "delete", "do", "else", "finally"

41− , "for", "function", "if", "in", "instanceof", "new", "return", "switch"

42− , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"

43− , "const", "enum", "export", "extends", "import", "super", "implements"

44− , "interface", "let", "package", "private", "protected", "public"

45− , "static", "yield"

46− -- reserved by the Elm runtime system

47− , "Elm", "ElmRuntime"

48− , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"

49− , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"

50− ]

51

34

52expecting = flip (<?>)

35expecting = flip (<?>)

53

36

@@ -200,7 +183,7 @@ located p = do

200 end <- getPosition

183 end <- getPosition

201 return (start, e, end)

184 return (start, e, end)

202

185

203−accessible :: IParser ParseExpr -> IParser ParseExpr

186+accessible :: IParser Source.Expr -> IParser Source.Expr

204accessible expr = do

187accessible expr = do

205 start <- getPosition

188 start <- getPosition

206 ce@(A _ e) <- expr

189 ce@(A _ e) <- expr

@@ -324,9 +307,9 @@ markdown interpolation =

324 closeMarkdown (markdownBuilder . (c:)) stuff

307 closeMarkdown (markdownBuilder . (c:)) stuff

325 ]

308 ]

326

309

327−glShader :: IParser (String, Literal.GLShaderTipe)

310+shader :: IParser (String, Literal.GLShaderTipe)

328−glShader =

311+shader =

329− do try (string "[glShader|")

312+ do try (string "[glsl|")

330 rawSrc <- closeShader id

313 rawSrc <- closeShader id

331 case glSource rawSrc of

314 case glSource rawSrc of

332 Left err -> parserFail . show $ err

315 Left err -> parserFail . show $ err

compiler/Parse/Literal.hs+1−1

@@ -4,7 +4,7 @@ module Parse.Literal (literal) where

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

5import Text.Parsec hiding (newline,spaces)

6import Parse.Helpers

7−import SourceSyntax.Literal

7+import AST.Literal

8

9literal :: IParser Literal

10literal = num <|> (Str <$> str) <|> (Chr <$> chr) <?> "literal"

compiler/Parse/Module.hs+31−14

@@ -5,10 +5,8 @@ import Data.List (intercalate)

5import Text.Parsec hiding (newline,spaces)

6

7import Parse.Helpers

8−import SourceSyntax.Module (ImportMethod(..), Imports)

8+import AST.Module (ImportMethod(..))

9−

9+import AST.Variable (Listing(..), Value(..), openListing)

10−varList :: IParser [String]

11−varList = commaSep1 (var <|> parens symOp)

12

10

13getModuleName :: String -> Maybe String

11getModuleName :: String -> Maybe String

14getModuleName source =

12getModuleName source =

@@ -21,18 +19,18 @@ getModuleName source =

21 (names, _) <- moduleDef

19 (names, _) <- moduleDef

22 return (intercalate "." names)

20 return (intercalate "." names)

23

21

24−moduleDef :: IParser ([String], [String])

22+moduleDef :: IParser ([String], Listing Value)

25moduleDef = do

23moduleDef = do

26 try (reserved "module")

24 try (reserved "module")

27 whitespace

25 whitespace

28 names <- dotSep1 capVar <?> "name of module"

26 names <- dotSep1 capVar <?> "name of module"

29 whitespace

27 whitespace

30− exports <- option [] (parens varList)

28+ exports <- option (Listing [] True) (listing value)

31 whitespace <?> "reserved word 'where'"

29 whitespace <?> "reserved word 'where'"

32 reserved "where"

30 reserved "where"

33 return (names, exports)

31 return (names, exports)

34

32

35−imports :: IParser Imports

33+imports :: IParser [(String, ImportMethod)]

36imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))

34imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))

37

35

38import' :: IParser (String, ImportMethod)

36import' :: IParser (String, ImportMethod)

@@ -43,17 +41,36 @@ import' =

43 (,) name <$> option (As name) method

41 (,) name <$> option (As name) method

44 where

42 where

45 method :: IParser ImportMethod

43 method :: IParser ImportMethod

46− method = try $ do whitespace

44+ method = as' <|> importing'

47− as' <|> importing'

48

45

49 as' :: IParser ImportMethod

46 as' :: IParser ImportMethod

50 as' = do

47 as' = do

51− reserved "as"

48+ try (whitespace >> reserved "as")

52 whitespace

49 whitespace

53 As <$> capVar <?> "alias for module"

50 As <$> capVar <?> "alias for module"

54

51

55 importing' :: IParser ImportMethod

52 importing' :: IParser ImportMethod

56− importing' =

53+ importing' = Open <$> listing value

57− parens (choice [ const (Hiding []) <$> string ".."

54+

58− , Importing <$> varList

55+listing :: IParser a -> IParser (Listing a)

59− ] <?> "listing of imported values (x,y,z)")

56+listing item =

57+ do try (whitespace >> char '(')

58+ whitespace

59+ listing <- choice [ const openListing <$> string ".."

60+ , Listing <$> commaSep1 item <*> return False

61+ ] <?> "listing of values (x,y,z)"

62+ whitespace

63+ char ')'

64+ return listing

65+

66+value :: IParser Value

67+value = val <|> tipe

68+ where

69+ val = Value <$> (lowVar <|> parens symOp)

70+

71+ tipe = do

72+ name <- capVar

73+ maybeCtors <- optionMaybe (listing capVar)

74+ case maybeCtors of

75+ Nothing -> return (Alias name)

76+ Just ctors -> return (ADT name ctors)

compiler/Parse/Parse.hs+13−9

@@ -7,8 +7,9 @@ import qualified Data.Map as Map

7import Text.Parsec hiding (newline,spaces)

8import qualified Text.PrettyPrint as P

9

10−import qualified SourceSyntax.Declaration as D

10+import qualified AST.Declaration as D

11−import qualified SourceSyntax.Module as M

11+import qualified AST.Module as M

12+import qualified AST.Variable as Var

12import Parse.Helpers

13import Parse.Helpers

13import Parse.Declaration (infixDecl)

14import Parse.Declaration (infixDecl)

14import Parse.Module

15import Parse.Module

@@ -22,21 +23,24 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

22decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

23decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

23 (d:) <$> many freshDef

24 (d:) <$> many freshDef

24

25

25−program :: OpTable -> String -> Either [P.Doc] (M.Module D.Declaration)

26+program :: OpTable -> String -> Either [P.Doc] M.ValidModule

26program table src =

27program table src =

27− do (M.Module names exs ims parseDecls) <- setupParserWithTable table programParser src

28+ do (M.Module names filePath exs ims parseDecls) <-

28− decls <- either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)

29+ setupParserWithTable table programParser src

29− return $ M.Module names exs ims decls

30+ decls <-

31+ either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)

32+ return $ M.Module names filePath exs ims decls

30

33

31−programParser :: IParser (M.Module D.ParseDeclaration)

34+programParser :: IParser M.SourceModule

32programParser =

35programParser =

33 do optional freshLine

36 do optional freshLine

34− (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

37+ (names,exports) <-

38+ option (["Main"], Var.openListing) (moduleDef `followedBy` freshLine)

35 is <- (do try (lookAhead $ reserved "import")

39 is <- (do try (lookAhead $ reserved "import")

36 imports `followedBy` freshLine) <|> return []

40 imports `followedBy` freshLine) <|> return []

37 declarations <- decls

41 declarations <- decls

38 optional freshLine ; optional spaces ; eof

42 optional freshLine ; optional spaces ; eof

39− return $ M.Module names exports is declarations

43+ return $ M.Module names "" exports is declarations

40

44

41dependencies :: String -> Either [P.Doc] (String, [String])

45dependencies :: String -> Either [P.Doc] (String, [String])

42dependencies =

46dependencies =

compiler/Parse/Pattern.hs+13−12

@@ -8,54 +8,55 @@ import Text.Parsec hiding (newline,spaces,State)

8

9import Parse.Helpers

10import Parse.Literal

11−import SourceSyntax.Literal

11+import AST.Literal

12−import qualified SourceSyntax.Pattern as P

12+import qualified AST.Pattern as P

13+import qualified AST.Variable as Var

13

14

14−basic :: IParser P.Pattern

15+basic :: IParser P.RawPattern

15basic = choice

16basic = choice

16 [ char '_' >> return P.Anything

17 [ char '_' >> return P.Anything

17 , do v <- var

18 , do v <- var

18 return $ case v of

19 return $ case v of

19 "True" -> P.Literal (Boolean True)

20 "True" -> P.Literal (Boolean True)

20 "False" -> P.Literal (Boolean False)

21 "False" -> P.Literal (Boolean False)

21− c:_ | isUpper c -> P.Data v []

22+ c:_ | isUpper c -> P.Data (Var.Raw v) []

22 _ -> P.Var v

23 _ -> P.Var v

23 , P.Literal <$> literal

24 , P.Literal <$> literal

24 ]

25 ]

25

26

26−asPattern :: P.Pattern -> IParser P.Pattern

27+asPattern :: P.RawPattern -> IParser P.RawPattern

27asPattern pattern = do

28asPattern pattern = do

28 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))

29 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))

29 return $ case var of

30 return $ case var of

30 Just v -> P.Alias v pattern

31 Just v -> P.Alias v pattern

31 Nothing -> pattern

32 Nothing -> pattern

32

33

33−record :: IParser P.Pattern

34+record :: IParser P.RawPattern

34record = P.Record <$> brackets (commaSep1 lowVar)

35record = P.Record <$> brackets (commaSep1 lowVar)

35

36

36−tuple :: IParser P.Pattern

37+tuple :: IParser P.RawPattern

37tuple = do

38tuple = do

38 ps <- parens (commaSep expr)

39 ps <- parens (commaSep expr)

39 return $ case ps of

40 return $ case ps of

40 [p] -> p

41 [p] -> p

41 _ -> P.tuple ps

42 _ -> P.tuple ps

42

43

43−list :: IParser P.Pattern

44+list :: IParser P.RawPattern

44list = P.list <$> braces (commaSep expr)

45list = P.list <$> braces (commaSep expr)

45

46

46−term :: IParser P.Pattern

47+term :: IParser P.RawPattern

47term =

48term =

48 (choice [ record, tuple, list, basic ]) <?> "pattern"

49 (choice [ record, tuple, list, basic ]) <?> "pattern"

49

50

50−patternConstructor :: IParser P.Pattern

51+patternConstructor :: IParser P.RawPattern

51patternConstructor = do

52patternConstructor = do

52 v <- List.intercalate "." <$> dotSep1 capVar

53 v <- List.intercalate "." <$> dotSep1 capVar

53 case v of

54 case v of

54 "True" -> return $ P.Literal (Boolean True)

55 "True" -> return $ P.Literal (Boolean True)

55 "False" -> return $ P.Literal (Boolean False)

56 "False" -> return $ P.Literal (Boolean False)

56− _ -> P.Data v <$> spacePrefix term

57+ _ -> P.Data (Var.Raw v) <$> spacePrefix term

57

58

58−expr :: IParser P.Pattern

59+expr :: IParser P.RawPattern

59expr = do

60expr = do

60 patterns <- consSep1 (patternConstructor <|> term)

61 patterns <- consSep1 (patternConstructor <|> term)

61 asPattern (foldr1 P.cons patterns) <?> "pattern"

62 asPattern (foldr1 P.cons patterns) <?> "pattern"

compiler/Parse/Type.hs+21−17

@@ -5,22 +5,23 @@ import Control.Applicative ((<$>),(<*>),(<*))

5import Data.List (intercalate)

6import Text.Parsec

7

8−import SourceSyntax.Type as T

8+import qualified AST.Type as T

9+import qualified AST.Variable as Var

9import Parse.Helpers

10import Parse.Helpers

10

11

11−tvar :: IParser T.Type

12+tvar :: IParser T.RawType

12tvar = T.Var <$> lowVar <?> "type variable"

13tvar = T.Var <$> lowVar <?> "type variable"

13

14

14−list :: IParser T.Type

15+list :: IParser T.RawType

15−list = listOf <$> braces expr

16+list = T.listOf <$> braces expr

16

17

17−tuple :: IParser T.Type

18+tuple :: IParser T.RawType

18tuple = do ts <- parens (commaSep expr)

19tuple = do ts <- parens (commaSep expr)

19 return $ case ts of

20 return $ case ts of

20 [t] -> t

21 [t] -> t

21− _ -> tupleOf ts

22+ _ -> T.tupleOf ts

22

23

23−record :: IParser T.Type

24+record :: IParser T.RawType

24record =

25record =

25 do char '{' ; whitespace

26 do char '{' ; whitespace

26 rcrd <- extended <|> normal

27 rcrd <- extended <|> normal

@@ -33,7 +34,7 @@ record =

33 extended = do

34 extended = do

34 ext <- try (lowVar <* (whitespace >> string "|"))

35 ext <- try (lowVar <* (whitespace >> string "|"))

35 whitespace

36 whitespace

36− flip T.Record (Just ext) <$> commaSep1 field

37+ flip T.Record (Just (T.Var ext)) <$> commaSep1 field

37

38

38 field = do

39 field = do

39 lbl <- rLabel

40 lbl <- rLabel

@@ -43,25 +44,28 @@ record =

43capTypeVar :: IParser String

44capTypeVar :: IParser String

44capTypeVar = intercalate "." <$> dotSep1 capVar

45capTypeVar = intercalate "." <$> dotSep1 capVar

45

46

46−constructor0 :: IParser T.Type

47+constructor0 :: IParser T.RawType

47constructor0 =

48constructor0 =

48 do name <- capTypeVar

49 do name <- capTypeVar

49− return (T.Data name [])

50+ return (T.Type (Var.Raw name))

50

51

51−term :: IParser T.Type

52+term :: IParser T.RawType

52term = list <|> tuple <|> record <|> tvar <|> constructor0

53term = list <|> tuple <|> record <|> tvar <|> constructor0

53

54

54−app :: IParser T.Type

55+app :: IParser T.RawType

55app =

56app =

56− do name <- capTypeVar <|> try tupleCtor <?> "type constructor"

57+ do f <- constructor0 <|> try tupleCtor <?> "type constructor"

57 args <- spacePrefix term

58 args <- spacePrefix term

58− return (T.Data name args)

59+ return $ case args of

60+ [] -> f

61+ _ -> T.App f args

59 where

62 where

60 tupleCtor = do

63 tupleCtor = do

61 n <- length <$> parens (many (char ','))

64 n <- length <$> parens (many (char ','))

62− return $ "_Tuple" ++ show (if n == 0 then 0 else n+1)

65+ let ctor = "_Tuple" ++ show (if n == 0 then 0 else n+1)

66+ return (T.Type (Var.Raw ctor))

63

67

64−expr :: IParser T.Type

68+expr :: IParser T.RawType

65expr =

69expr =

66 do t1 <- app <|> term

70 do t1 <- app <|> term

67 arr <- optionMaybe $ try (whitespace >> arrow)

71 arr <- optionMaybe $ try (whitespace >> arrow)

@@ -69,6 +73,6 @@ expr =

69 Just _ -> T.Lambda t1 <$> (whitespace >> expr)

73 Just _ -> T.Lambda t1 <$> (whitespace >> expr)

70 Nothing -> return t1

74 Nothing -> return t1

71

75

72−constructor :: IParser (String, [T.Type])

76+constructor :: IParser (String, [T.RawType])

73constructor = (,) <$> (capTypeVar <?> "another type constructor")

77constructor = (,) <$> (capTypeVar <?> "another type constructor")

74 <*> spacePrefix term

78 <*> spacePrefix term

compiler/SourceSyntax/Module.hsdeleted−119

@@ -1,119 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module SourceSyntax.Module where

3−

4−import Data.Binary

5−import qualified Data.List as List

6−import qualified Data.Map as Map

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

8−import Text.PrettyPrint as P

9−

10−import SourceSyntax.Expression (Expr)

11−import SourceSyntax.Declaration

12−import SourceSyntax.PrettyPrint

13−import SourceSyntax.Type

14−

15−import qualified Elm.Internal.Version as Version

16−

17−data Module def =

18− Module [String] Exports Imports [def]

19− deriving (Show)

20−

21−type Exports = [String]

22−

23−type Imports = [(String, ImportMethod)]

24−data ImportMethod = As String | Importing [String] | Hiding [String]

25− deriving (Eq, Ord, Show)

26−

27−instance (Pretty def) => Pretty (Module def) where

28− pretty (Module modNames exports imports decls) =

29− P.vcat [modul, P.text "", prettyImports, P.text "", prettyDecls]

30− where

31− prettyDecls = P.sep $ map pretty decls

32−

33− modul = P.text "module" <+> moduleName <+> prettyExports <+> P.text "where"

34− moduleName = P.text $ List.intercalate "." modNames

35− prettyExports =

36− case exports of

37− [] -> P.empty

38− _ -> P.parens . commaCat $ map P.text exports

39−

40− prettyImports = P.vcat $ map prettyImport imports

41−

42− prettyImport (name, method) =

43− P.text "import" <+>

44− case method of

45− As alias ->

46− P.text $ name ++ (if name == alias then "" else " as " ++ alias)

47−

48− Importing values ->

49− P.text name <+> P.parens (commaCat (map P.text values))

50−

51− Hiding [] -> P.text ("open " ++ name)

52− Hiding _ -> error "invalid import declaration"

53−

54−instance Binary ImportMethod where

55− put method =

56− let put' n info = putWord8 n >> put info in

57− case method of

58− As s -> put' 0 s

59− Importing ss -> put' 1 ss

60− Hiding ss -> put' 2 ss

61−

62− get = do tag <- getWord8

63− case tag of

64− 0 -> As <$> get

65− 1 -> Importing <$> get

66− 2 -> Hiding <$> get

67− _ -> error "Error reading valid ImportMethod type from serialized string"

68−

69−data MetadataModule =

70− MetadataModule

71− { names :: [String]

72− , path :: FilePath

73− , exports :: [String]

74− , imports :: [(String, ImportMethod)]

75− , program :: Expr

76− , types :: Map.Map String Type

77− , fixities :: [(Assoc, Int, String)]

78− , aliases :: [Alias]

79− , datatypes :: [ADT]

80− , ports :: [String]

81− } deriving Show

82−

83−type Interfaces = Map.Map String ModuleInterface

84−type ADT = (String, [String], [(String,[Type])])

85−type Alias = (String, [String], Type)

86−

87−data ModuleInterface =

88− ModuleInterface

89− { iVersion :: Version.Version

90− , iTypes :: Map.Map String Type

91− , iImports :: [(String, ImportMethod)]

92− , iAdts :: [ADT]

93− , iAliases :: [Alias]

94− , iFixities :: [(Assoc, Int, String)]

95− , iPorts :: [String]

96− } deriving Show

97−

98−metaToInterface :: MetadataModule -> ModuleInterface

99−metaToInterface metaModule =

100− ModuleInterface

101− { iVersion = Version.elmVersion

102− , iTypes = types metaModule

103− , iImports = imports metaModule

104− , iAdts = datatypes metaModule

105− , iAliases = aliases metaModule

106− , iFixities = fixities metaModule

107− , iPorts = ports metaModule

108− }

109−

110−instance Binary ModuleInterface where

111− get = ModuleInterface <$> get <*> get <*> get <*> get <*> get <*> get <*> get

112− put modul = do

113− put (iVersion modul)

114− put (iTypes modul)

115− put (iImports modul)

116− put (iAdts modul)

117− put (iAliases modul)

118− put (iFixities modul)

119− put (iPorts modul)

compiler/SourceSyntax/Pattern.hsdeleted−69

@@ -1,69 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Pattern where

3−

4−import qualified SourceSyntax.Helpers as Help

5−import SourceSyntax.PrettyPrint

6−import Text.PrettyPrint as PP

7−import qualified Data.Set as Set

8−import SourceSyntax.Literal as Literal

9−

10−data Pattern

11− = Data String [Pattern]

12− | Record [String]

13− | Alias String Pattern

14− | Var String

15− | Anything

16− | Literal Literal.Literal

17− deriving (Eq, Ord, Show)

18−

19−cons :: Pattern -> Pattern -> Pattern

20−cons h t = Data "::" [h,t]

21−

22−nil :: Pattern

23−nil = Data "[]" []

24−

25−list :: [Pattern] -> Pattern

26−list = foldr cons nil

27−

28−tuple :: [Pattern] -> Pattern

29−tuple es = Data ("_Tuple" ++ show (length es)) es

30−

31−boundVarList :: Pattern -> [String]

32−boundVarList = Set.toList . boundVars

33−

34−boundVars :: Pattern -> Set.Set String

35−boundVars pattern =

36− case pattern of

37− Var x -> Set.singleton x

38− Alias x p -> Set.insert x (boundVars p)

39− Data _ ps -> Set.unions (map boundVars ps)

40− Record fields -> Set.fromList fields

41− Anything -> Set.empty

42− Literal _ -> Set.empty

43−

44−

45−instance Pretty Pattern where

46− pretty pattern =

47− case pattern of

48− Var x -> variable x

49− Literal lit -> pretty lit

50− Record fs -> PP.braces (commaCat $ map variable fs)

51− Alias x p -> prettyParens p <+> PP.text "as" <+> variable x

52− Anything -> PP.text "_"

53− Data "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl

54− where isCons = case hd of

55− Data "::" _ -> True

56− _ -> False

57− Data name ps ->

58− if Help.isTuple name then

59− PP.parens . commaCat $ map pretty ps

60− else hsep (PP.text name : map prettyParens ps)

61−

62−prettyParens :: Pattern -> Doc

63−prettyParens pattern = parensIf needsThem (pretty pattern)

64− where

65− needsThem =

66− case pattern of

67− Data name (_:_) | not (Help.isTuple name) -> True

68− Alias _ _ -> True

69− _ -> False

compiler/SourceSyntax/Type.hsdeleted−89

@@ -1,89 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module SourceSyntax.Type where

3−

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

5−import Data.Binary

6−import qualified Data.Map as Map

7−import SourceSyntax.PrettyPrint

8−import qualified SourceSyntax.Helpers as Help

9−import Text.PrettyPrint as P

10−

11−data Type = Lambda Type Type

12− | Var String

13− | Data String [Type]

14− | Record [(String,Type)] (Maybe String)

15− deriving (Eq,Show)

16−

17−fieldMap :: [(String,a)] -> Map.Map String [a]

18−fieldMap fields =

19− foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields

20−

21−recordOf :: [(String,Type)] -> Type

22−recordOf fields = Record fields Nothing

23−

24−listOf :: Type -> Type

25−listOf t = Data "_List" [t]

26−

27−tupleOf :: [Type] -> Type

28−tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts

29−

30−instance Pretty Type where

31− pretty tipe =

32− case tipe of

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

34− where

35− t:ts = map prettyLambda (collectLambdas tipe)

36− prettyLambda t = case t of

37− Lambda _ _ -> P.parens (pretty t)

38− _ -> pretty t

39−

40− Var x -> P.text x

41− Data "_List" [t] -> P.brackets (pretty t)

42− Data name tipes

43− | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes

44− | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)

45− Record fields ext ->

46− P.braces $ case ext of

47− Nothing -> prettyFields

48− Just x -> P.hang (P.text x <+> P.text "|") 4 prettyFields

49− where

50− prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

51− prettyFields = commaSep . map prettyField $ fields

52−

53−collectLambdas :: Type -> [Type]

54−collectLambdas tipe =

55− case tipe of

56− Lambda arg body -> arg : collectLambdas body

57− _ -> [tipe]

58−

59−prettyParens :: Type -> Doc

60−prettyParens tipe = parensIf needed (pretty tipe)

61− where

62− needed =

63− case tipe of

64− Lambda _ _ -> True

65− Data "_List" [_] -> False

66− Data _ [] -> False

67− Data _ _ -> True

68− _ -> False

69−

70−instance Binary Type where

71− put tipe =

72− case tipe of

73− Lambda t1 t2 ->

74− putWord8 0 >> put t1 >> put t2

75− Var x ->

76− putWord8 1 >> put x

77− Data ctor tipes ->

78− putWord8 2 >> put ctor >> put tipes

79− Record fs ext ->

80− putWord8 3 >> put fs >> put ext

81−

82− get = do

83− n <- getWord8

84− case n of

85− 0 -> Lambda <$> get <*> get

86− 1 -> Var <$> get

87− 2 -> Data <$> get <*> get

88− 3 -> Record <$> get <*> get

89− _ -> error "Error reading a valid type from serialized string"

compiler/SourceSyntax/Variable.hsdeleted−11

@@ -1,11 +0,0 @@

1−

2−module SourceSyntax.Variable where

3−

4−import qualified Text.PrettyPrint as P

5−import SourceSyntax.PrettyPrint

6−

7−newtype Raw = Raw String

8− deriving (Eq,Ord,Show)

9−

10−instance Pretty Raw where

11− pretty (Raw var) = variable var

compiler/Transform/Canonicalize.hs+246−162

@@ -1,192 +1,276 @@

1−{-# OPTIONS_GHC -Wall #-}

1+{-# OPTIONS_GHC -W #-}

2−module Transform.Canonicalize (interface, metadataModule) where

2+module Transform.Canonicalize (module') where

3

4−import Control.Arrow ((***))

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

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

5+import Control.Monad.Error (runErrorT, throwError)

6−import Control.Monad.Identity

6+import Control.Monad.State (runState)

7−import qualified Data.Either as Either

8import qualified Data.List as List

7import qualified Data.List as List

9import qualified Data.Map as Map

8import qualified Data.Map as Map

10import qualified Data.Set as Set

9import qualified Data.Set as Set

11import qualified Data.Traversable as T

10import qualified Data.Traversable as T

12−import SourceSyntax.Annotation as A

11+

13−import SourceSyntax.Expression

12+import AST.Expression.General (Expr'(..), dummyLet)

14−import SourceSyntax.Module

13+import qualified AST.Expression.Valid as Valid

15−import SourceSyntax.PrettyPrint (pretty)

14+import qualified AST.Expression.Canonical as Canonical

16−import qualified SourceSyntax.Pattern as P

15+

17−import qualified SourceSyntax.Type as Type

16+import AST.Module (CanonicalBody(..))

18−import qualified SourceSyntax.Variable as Var

17+import qualified AST.Module as Module

18+import qualified AST.Type as Type

19+import qualified AST.Variable as Var

20+import qualified AST.Annotation as A

21+import qualified AST.Declaration as D

22+import AST.PrettyPrint (pretty, commaSep)

23+import qualified AST.Pattern as P

19import Text.PrettyPrint as P

24import Text.PrettyPrint as P

20

25

21−interface :: String -> ModuleInterface -> ModuleInterface

26+import Transform.Canonicalize.Environment as Env

22−interface moduleName iface =

27+import qualified Transform.Canonicalize.Setup as Setup

23− ModuleInterface

28+import qualified Transform.Canonicalize.Type as Canonicalize

24− { iVersion = iVersion iface

29+import qualified Transform.Canonicalize.Variable as Canonicalize

25− , iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))

30+import qualified Transform.SortDefinitions as Transform

26− , iImports = iImports iface

31+import qualified Transform.Declaration as Transform

27− , iAdts = map (both prefix renameCtors) (iAdts iface)

32+

28− , iAliases = map (both prefix renameType') (iAliases iface)

33+module' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule

29− , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

34+module' interfaces modul =

30− , iPorts = iPorts iface

35+ filterImports <$> modul'

31− }

32 where

36 where

33− both f g (a,b,c) = (f a, b, g c)

37+ (modul', usedModules) =

34− prefix name = moduleName ++ "." ++ name

38+ runState (runErrorT (moduleHelp interfaces modul)) Set.empty

35−

39+

36− pair name = (name, moduleName ++ "." ++ name)

40+ filterImports m =

37− canon (name,_,_) = pair name

41+ let used (name,_) = Set.member name usedModules

38− canons = Map.fromList $ concat

42+ in m { Module.imports = filter used (Module.imports m) }

39− [ map canon (iAdts iface), map canon (iAliases iface) ]

43+

40−

44+moduleHelp :: Module.Interfaces -> Module.ValidModule

41− renameCtors ctors =

45+ -> Canonicalizer [Doc] Module.CanonicalModule

42− map (prefix *** map renameType') ctors

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

43− renameType' =

47+ do env <- Setup.environment interfaces modul

44− runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

48+ canonicalDecls <- mapM (declaration env) decls

45−

49+ exports' <- resolveExports locals exports

46−renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type

50+ return $ modul { Module.exports = exports'

47−renameType renamer tipe =

51+ , Module.body = body canonicalDecls

48− let rnm = renameType renamer in

52+ }

49− case tipe of

50− Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b

51− Type.Var _ -> return tipe

52− Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts

53− Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext

54− where rnm' (f,t) = (,) f <$> rnm t

55−

56−metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule

57−metadataModule ifaces modul =

58− do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

59− [] -> Right ()

60− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ++

61− "\n You may need to compile with the --make flag to detect modules you have written."

62− ]

63− program' <- rename initialEnv (program modul)

64− aliases' <- mapM (three3 renameType') (aliases modul)

65− datatypes' <- mapM (three3 (mapM (two2 (mapM renameType')))) (datatypes modul)

66− return $ modul { program = program'

67− , aliases = aliases'

68− , datatypes = datatypes' }

69 where

53 where

70− two2 f (a,b) = (,) a <$> f b

54+ locals :: [Var.Value]

71− three3 f (a,b,c) = (,,) a b <$> f c

55+ locals = concatMap declToValue decls

72− renameType' =

56+

73− Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)

57+ body :: [D.CanonicalDecl] -> Module.CanonicalBody

74−

58+ body decls =

75− get1 (a,_,_) = a

59+ Module.CanonicalBody

76− canon (name, importMethod) =

60+ { program =

77− let pair pre var = (pre ++ drop (length name + 1) var, var)

61+ let expr = Transform.toExpr (Module.getName modul) decls

78− iface = ifaces Map.! name

62+ in Transform.sortDefs (dummyLet expr)

79− allNames = concat [ Map.keys (iTypes iface)

63+ , types = Map.empty

80− , map get1 (iAliases iface)

64+ , datatypes =

81− , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]

65+ Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]

82− in case importMethod of

66+ , fixities =

83− As alias -> map (pair (alias ++ ".")) allNames

67+ [ (assoc,level,op) | D.Fixity assoc level op <- decls ]

84− Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

68+ , aliases =

85− where vs = Set.fromList vars

69+ Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]

86− Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames

70+ , ports =

87− where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars

71+ [ D.portName port | D.Port port <- decls ]

88−

72+ }

89− two n = (n,n)

73+

90− localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))

74+resolveExports :: [Var.Value] -> Var.Listing Var.Value -> Canonicalizer [Doc] [Var.Value]

91− globalEnv =

75+resolveExports fullList (Var.Listing partialList open) =

92− map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++

76+ if open

93− map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]

77+ then return fullList

94− realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)

78+ else do

95− initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)

79+ valueExports <- getValueExports

96−

80+ aliasExports <- concat `fmap` mapM getAliasExport aliases

97−type Env = Map.Map String String

81+ adtExports <- mapM getAdtExport adts

98−

82+ return $ valueExports ++ aliasExports ++ adtExports

99−extend :: Env -> P.Pattern -> Env

83+ where

100−extend env pattern = Map.union (Map.fromList (zip xs xs)) env

84+ (allValues, allAliases, allAdts) = splitValues fullList

101− where xs = P.boundVarList pattern

85+

102−

86+ (values, aliases, adts) = splitValues partialList

103−replace :: String -> Env -> String -> Either String String

87+

104−replace variable env v =

88+ getValueExports =

105− if List.isPrefixOf "Native." v then return v else

89+ case Set.toList (Set.difference values' allValues') of

106− case Map.lookup v env of

90+ [] -> return (map Var.Value values)

107− Just v' -> return v'

91+ xs -> notFound xs

108− Nothing -> Left $ "Could not find " ++ variable ++ " '" ++ v ++ "'." ++ msg

92+ where

93+ allValues' = Set.fromList allValues

94+ values' = Set.fromList values

95+

96+ getAliasExport alias

97+ | alias `elem` allAliases =

98+ let recordConstructor =

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

100+ in

101+ return $ Var.Alias alias : recordConstructor

102+

103+ | otherwise =

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

105+ Nothing -> notFound [alias]

106+ Just (name, _ctor) ->

107+ return [Var.ADT name (Var.Listing [] False)]

108+

109+ getAdtExport (name, Var.Listing ctors open) =

110+ case lookup name allAdts of

111+ Nothing -> notFound [name]

112+ Just (Var.Listing allCtors _)

113+ | open -> return $ Var.ADT name (Var.Listing allCtors False)

114+ | otherwise ->

115+ case filter (`notElem` allCtors) ctors of

116+ [] -> return $ Var.ADT name (Var.Listing ctors False)

117+ unfoundCtors -> notFound unfoundCtors

118+

119+ notFound xs =

120+ throwError [ P.text "Export Error: trying to export non-existent values:" <+>

121+ commaSep (map pretty xs)

122+ ]

123+

124+{-| Split a list of values into categories so we can work with them

125+independently.

126+-}

127+splitValues :: [Var.Value] -> ([String], [String], [(String, Var.Listing String)])

128+splitValues mixedValues =

129+ case mixedValues of

130+ [] -> ([], [], [])

131+ x:xs ->

132+ let (values, aliases, adts) = splitValues xs in

133+ case x of

134+ Var.Value name -> (name : values, aliases, adts)

135+ Var.Alias name -> (values, name : aliases, adts)

136+ Var.ADT name listing ->

137+ (values, aliases, (name, listing) : adts)

138+

139+

140+

141+declToValue :: D.ValidDecl -> [Var.Value]

142+declToValue decl =

143+ case decl of

144+ D.Definition (Valid.Definition pattern _ _) ->

145+ map Var.Value (P.boundVarList pattern)

146+

147+ D.Datatype name _tvs ctors ->

148+ [ Var.ADT name (Var.Listing (map fst ctors) False) ]

149+

150+ D.TypeAlias name _ tipe ->

151+ case tipe of

152+ Type.Record _ _ ->

153+ [ Var.Alias name, Var.Value name ]

154+ _ -> [ Var.Alias name ]

155+

156+ _ -> []

157+

158+declaration :: Environment -> D.ValidDecl -> Canonicalizer [Doc] D.CanonicalDecl

159+declaration env decl =

160+ let canonicalize kind context pattern env v =

161+ let ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon

162+ throw err = P.vcat [ ctx, P.text err ]

163+ in

164+ Env.onError throw (kind env v)

165+ in

166+ case decl of

167+ D.Definition (Valid.Definition p e t) ->

168+ do p' <- canonicalize pattern "definition" p env p

169+ e' <- expression env e

170+ t' <- T.traverse (canonicalize Canonicalize.tipe "definition" p env) t

171+ return $ D.Definition (Canonical.Definition p' e' t')

172+

173+ D.Datatype name tvars ctors ->

174+ D.Datatype name tvars <$> mapM canonicalize' ctors

109 where

175 where

110− matches = filter (List.isInfixOf v) (Map.keys env)

176+ canonicalize' (ctor,args) =

111− msg = if null matches then "" else

177+ (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args

112− "\nClose matches include: " ++ List.intercalate ", " matches

178+

113−

179+ D.TypeAlias name tvars expanded ->

114−-- TODO: Var.Raw -> Var.Canonical

180+ do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded

115−rename :: Env -> Expr -> Either [Doc] Expr

181+ return (D.TypeAlias name tvars expanded')

116−rename env (A ann expr) =

182+

117− let rnm = rename env

183+ D.Port port -> do

118− throw err = Left [ P.vcat [ P.text "Error" <+> pretty ann <> P.colon

184+ Env.uses "Native.Ports"

119− , P.text err

185+ Env.uses "Native.Json"

120− ]

186+ D.Port <$> case port of

121− ]

187+ D.In name t ->

122− format = Either.either throw return

188+ do t' <- canonicalize Canonicalize.tipe "port" name env t

123− renameType' environ = renameType (format . replace "variable" environ)

189+ return (D.In name t')

190+ D.Out name e t ->

191+ do e' <- expression env e

192+ t' <- canonicalize Canonicalize.tipe "port" name env t

193+ return (D.Out name e' t')

194+

195+ D.Fixity assoc prec op -> return $ D.Fixity assoc prec op

196+

197+

198+expression :: Environment -> Valid.Expr -> Canonicalizer [Doc] Canonical.Expr

199+expression env (A.A ann expr) =

200+ let go = expression env

201+ tipe' environ = format . Canonicalize.tipe environ

202+ throw err = P.vcat [ P.text "Error" <+> pretty ann <> P.colon

203+ , P.text err ]

204+ format = Env.onError throw

124 in

205 in

125− A ann <$>

206+ A.A ann <$>

126 case expr of

207 case expr of

127− Literal _ -> return expr

208+ Literal lit -> return (Literal lit)

128

209

129− Range e1 e2 -> Range <$> rnm e1 <*> rnm e2

210+ Range e1 e2 -> Range <$> go e1 <*> go e2

130

211

131− Access e x -> Access <$> rnm e <*> return x

212+ Access e x -> Access <$> go e <*> return x

132

213

133− Remove e x -> flip Remove x <$> rnm e

214+ Remove e x -> flip Remove x <$> go e

134

215

135− Insert e x v -> flip Insert x <$> rnm e <*> rnm v

216+ Insert e x v -> flip Insert x <$> go e <*> go v

136

217

137 Modify e fs ->

218 Modify e fs ->

138− Modify <$> rnm e <*> mapM (\(k,v) -> (,) k <$> rnm v) fs

219+ Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fs

139

220

140− Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs

221+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fs

141

222

142− Binop op e1 e2 ->

223+ Binop (Var.Raw op) e1 e2 ->

143− do op' <- format (replace "variable" env op)

224+ do op' <- format (Canonicalize.variable env op)

144− Binop op' <$> rnm e1 <*> rnm e2

225+ Binop op' <$> go e1 <*> go e2

145

226

146− Lambda pattern e ->

227+ Lambda p e ->

147− let env' = extend env pattern in

228+ let env' = update p env in

148− Lambda <$> format (renamePattern env' pattern) <*> rename env' e

229+ Lambda <$> format (pattern env' p) <*> expression env' e

149

230

150− App e1 e2 -> App <$> rnm e1 <*> rnm e2

231+ App e1 e2 -> App <$> go e1 <*> go e2

151

232

152− MultiIf ps -> MultiIf <$> mapM grnm ps

233+ MultiIf ps -> MultiIf <$> mapM go' ps

153− where grnm (b,e) = (,) <$> rnm b <*> rnm e

234+ where go' (b,e) = (,) <$> go b <*> go e

154

235

155− Let defs e -> Let <$> mapM rename' defs <*> rename env' e

236+ Let defs e -> Let <$> mapM rename' defs <*> expression env' e

156 where

237 where

157− env' = foldl extend env $ map (\(Definition p _ _) -> p) defs

238+ env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs

158− rename' (Definition p body mtipe) =

239+ rename' (Valid.Definition p body mtipe) =

159− Definition <$> format (renamePattern env' p)

240+ Canonical.Definition

160− <*> rename env' body

241+ <$> format (pattern env' p)

161− <*> T.traverse (renameType' env') mtipe

242+ <*> expression env' body

243+ <*> T.traverse (tipe' env') mtipe

162

244

163− -- TODO: Raw -> Canonical

245+ Var (Var.Raw x) -> Var <$> format (Canonicalize.variable env x)

164− Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)

165

246

166− Data name es -> Data name <$> mapM rnm es

247+ Data name es -> Data name <$> mapM go es

167

248

168− ExplicitList es -> ExplicitList <$> mapM rnm es

249+ ExplicitList es -> ExplicitList <$> mapM go es

169

250

170− Case e cases -> Case <$> rnm e <*> mapM branch cases

251+ Case e cases -> Case <$> go e <*> mapM branch cases

171 where

252 where

172− branch (pattern,b) = (,) <$> format (renamePattern env pattern)

253+ branch (p,b) = (,) <$> format (pattern env p)

173− <*> rename (extend env pattern) b

254+ <*> expression (update p env) b

174−

255+

175− Markdown uid md es -> Markdown uid md <$> mapM rnm es

256+ Markdown uid md es ->

176−

257+ do Env.uses "Text"

177− PortIn name st -> PortIn name <$> renameType' env st

258+ Markdown uid md <$> mapM go es

178−

259+

179− PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

260+ PortIn name st -> PortIn name <$> tipe' env st

180−

261+

181− GLShader _ _ _ -> return expr

262+ PortOut name st signal -> PortOut name <$> tipe' env st <*> go signal

182−

263+

183−renamePattern :: Env -> P.Pattern -> Either String P.Pattern

264+ GLShader uid src tipe -> return (GLShader uid src tipe)

184−renamePattern env pattern =

265+

185− case pattern of

266+pattern :: Environment -> P.RawPattern -> Canonicalizer String P.CanonicalPattern

186− P.Var _ -> return pattern

267+pattern env ptrn =

187− P.Literal _ -> return pattern

268+ case ptrn of

188− P.Record _ -> return pattern

269+ P.Var x -> return $ P.Var x

189− P.Anything -> return pattern

270+ P.Literal lit -> return $ P.Literal lit

190− P.Alias x p -> P.Alias x <$> renamePattern env p

271+ P.Record fs -> return $ P.Record fs

191− P.Data name ps -> P.Data <$> replace "pattern" env name

272+ P.Anything -> return P.Anything

192− <*> mapM (renamePattern env) ps

273+ P.Alias x p -> P.Alias x <$> pattern env p

274+ P.Data (Var.Raw name) ps ->

275+ P.Data <$> Canonicalize.pvar env name

276+ <*> mapM (pattern env) ps

compiler/Transform/Canonicalize/Environment.hsnew file+84

@@ -0,0 +1,84 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Canonicalize.Environment where

3+

4+import Control.Arrow (second)

5+import qualified Control.Monad.Error as Error

6+import qualified Control.Monad.State as State

7+import qualified Data.Map as Map

8+import qualified Data.Set as Set

9+

10+import AST.Expression.General (saveEnvName)

11+import qualified AST.Pattern as P

12+import qualified AST.Type as Type

13+import qualified AST.Variable as Var

14+

15+import Text.PrettyPrint (Doc)

16+

17+type Dict a = Map.Map String [a]

18+

19+dict :: [(String,a)] -> Dict a

20+dict pairs = Map.fromList $ map (second (:[])) pairs

21+

22+insert :: String -> a -> Dict a -> Dict a

23+insert key value = Map.insertWith (++) key [value]

24+

25+type Canonicalizer err a = Error.ErrorT err (State.State (Set.Set String)) a

26+

27+uses :: (Error.Error e) => String -> Canonicalizer e ()

28+uses home =

29+ Error.lift (State.modify (Set.insert home))

30+

31+using :: Var.Canonical -> Canonicalizer String Var.Canonical

32+using var@(Var.Canonical home _) =

33+ do case home of

34+ Var.BuiltIn -> return ()

35+ Var.Module path -> uses path

36+ Var.Local -> return ()

37+ return var

38+

39+onError :: (String -> Doc) -> Canonicalizer String a -> Canonicalizer [Doc] a

40+onError handler canonicalizer =

41+ do usedModules <- Error.lift State.get

42+ let (result, usedModules') =

43+ State.runState (Error.runErrorT canonicalizer) usedModules

44+ Error.lift (State.put usedModules')

45+ case result of

46+ Left err -> Error.throwError [handler err]

47+ Right x -> return x

48+

49+data Environment = Env

50+ { _home :: String

51+ , _values :: Dict Var.Canonical

52+ , _adts :: Dict Var.Canonical

53+ , _aliases :: Dict (Var.Canonical, [String], Type.CanonicalType)

54+ , _patterns :: Dict Var.Canonical

55+ }

56+

57+builtIns :: String -> Environment

58+builtIns home =

59+ Env { _home = home

60+ , _values = builtIn (tuples ++ [saveEnvName])

61+ , _adts = builtIn (tuples ++ ["_List","Int","Float","Char","Bool","String"])

62+ , _aliases = dict []

63+ , _patterns = builtIn (tuples ++ ["::","[]"])

64+ }

65+ where

66+ builtIn xs = dict $ map (\x -> (x, Var.Canonical Var.BuiltIn x)) xs

67+ tuples = map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]

68+

69+update :: P.Pattern var -> Environment -> Environment

70+update ptrn env =

71+ env { _values = foldr put (_values env) (P.boundVarList ptrn) }

72+ where

73+ put x = Map.insert x [Var.local x]

74+

75+merge :: Environment -> Environment -> Environment

76+merge (Env n1 v1 t1 a1 p1) (Env n2 v2 t2 a2 p2)

77+ | n1 /= n2 = error "trying to merge incompatable environments"

78+ | otherwise =

79+ Env { _home = n1

80+ , _values = Map.unionWith (++) v1 v2

81+ , _adts = Map.unionWith (++) t1 t2

82+ , _aliases = Map.unionWith (++) a1 a2

83+ , _patterns = Map.unionWith (++) p1 p2

84+ }

compiler/Transform/Canonicalize/Setup.hsnew file+230

@@ -0,0 +1,230 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Canonicalize.Setup (environment) where

3+

4+import Control.Arrow (first)

5+import Control.Monad (foldM)

6+import Control.Monad.Error (throwError)

7+import qualified Data.Graph as Graph

8+import qualified Data.List as List

9+import qualified Data.Map as Map

10+

11+import qualified AST.Expression.Valid as Valid

12+

13+import AST.Module (Interface(iAdts, iTypes, iAliases))

14+import qualified AST.Module as Module

15+import qualified AST.Type as Type

16+import qualified AST.Variable as Var

17+import qualified AST.Declaration as D

18+import AST.PrettyPrint (pretty, eightyCharLines)

19+import qualified AST.Pattern as P

20+import Text.PrettyPrint as P

21+

22+import Transform.Canonicalize.Environment as Env

23+import qualified Transform.Canonicalize.Type as Canonicalize

24+import qualified Transform.Interface as Interface

25+

26+environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment

27+environment interfaces modul@(Module.Module _ _ _ imports decls) =

28+ do () <- allImportsAvailable

29+ let moduleName = Module.getName modul

30+ nonLocalEnv <- foldM (addImports moduleName interfaces) (builtIns moduleName) imports

31+ let (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls

32+ addTypeAliases moduleName aliases env

33+ where

34+ allImportsAvailable :: Canonicalizer [Doc] ()

35+ allImportsAvailable =

36+ case filter (not . found) modules of

37+ [] -> return ()

38+ missings -> throwError [ P.text (missingModuleError missings) ]

39+ where

40+ modules = map fst imports

41+

42+ found m = Map.member m interfaces || List.isPrefixOf "Native." m

43+

44+ missingModuleError missings =

45+ concat [ "The following imports were not found: "

46+ , List.intercalate ", " missings

47+ , "\n You may need to compile with the --make "

48+ , "flag to detect modules you have written." ]

49+

50+addImports :: String -> Module.Interfaces -> Environment -> (String, Module.ImportMethod)

51+ -> Canonicalizer [Doc] Environment

52+addImports moduleName interfaces environ (name, method)

53+ | List.isPrefixOf "Native." name = return environ

54+ | otherwise =

55+ case method of

56+ Module.As name' ->

57+ return (updateEnviron (name' ++ "."))

58+

59+ Module.Open (Var.Listing vs open)

60+ | open -> return (updateEnviron "")

61+ | otherwise -> foldM (addValue name interface) environ vs

62+ where

63+ interface = Interface.filterExports ((Map.!) interfaces name)

64+

65+ updateEnviron prefix =

66+ let dict' = dict . map (first (prefix++)) in

67+ merge environ $

68+ Env { _home = moduleName

69+ , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors

70+ , _adts = dict' $ map pair (Map.keys (iAdts interface))

71+ , _aliases = dict' $ map alias (Map.toList (iAliases interface))

72+ , _patterns = dict' $ ctors

73+ }

74+

75+ canonical :: String -> Var.Canonical

76+ canonical = Var.Canonical (Var.Module name)

77+

78+ pair :: String -> (String, Var.Canonical)

79+ pair key = (key, canonical key)

80+

81+ alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))

82+

83+ ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))

84+

85+addValue :: String -> Module.Interface -> Environment -> Var.Value

86+ -> Canonicalizer [Doc] Environment

87+addValue name interface env value =

88+ let insert' x = insert x (Var.Canonical (Var.Module name) x)

89+ msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++

90+ "'.\n It is not exported by module " ++ name ++ "."

91+ notFound x = throwError [ P.text (msg x) ]

92+ in

93+ case value of

94+ Var.Value x

95+ | Map.notMember x (iTypes interface) -> notFound x

96+ | otherwise ->

97+ return $ env { _values = insert' x (_values env) }

98+

99+ Var.Alias x ->

100+ case Map.lookup x (iAliases interface) of

101+ Just (tvars, t) ->

102+ return $ env

103+ { _aliases = insert x v (_aliases env)

104+ , _values = updatedValues

105+ }

106+ where

107+ v = (Var.Canonical (Var.Module name) x, tvars, t)

108+ updatedValues =

109+ if Map.member x (iTypes interface)

110+ then insert' x (_values env)

111+ else _values env

112+

113+ Nothing ->

114+ case Map.lookup x (iAdts interface) of

115+ Nothing -> notFound x

116+ Just (_,_) ->

117+ return $ env { _adts = insert' x (_adts env) }

118+

119+ Var.ADT x (Var.Listing xs open) ->

120+ case Map.lookup x (iAdts interface) of

121+ Nothing -> notFound x

122+ Just (_tvars, ctors) ->

123+ do ctors' <- filterNames (map fst ctors)

124+ return $ env { _adts = insert' x (_adts env)

125+ , _values = foldr insert' (_values env) ctors'

126+ , _patterns = foldr insert' (_patterns env) ctors'

127+ }

128+ where

129+ filterNames names

130+ | open = return names

131+ | otherwise =

132+ case filter (`notElem` names) xs of

133+ [] -> return names

134+ c:_ -> notFound c

135+

136+type Node = ((String, [String], Type.RawType), String, [String])

137+

138+node :: String -> [String] -> Type.RawType -> Node

139+node name tvars alias = ((name, tvars, alias), name, edges alias)

140+ where

141+ edges tipe =

142+ case tipe of

143+ Type.Lambda t1 t2 -> edges t1 ++ edges t2

144+ Type.Var _ -> []

145+ Type.Type (Var.Raw x) -> [x]

146+ Type.App t ts -> edges t ++ concatMap edges ts

147+ Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs

148+ Type.Aliased _ t -> edges t

149+

150+addTypeAliases :: String -> [Node] -> Environment -> Canonicalizer [Doc] Environment

151+addTypeAliases moduleName nodes environ =

152+ foldM addTypeAlias environ (Graph.stronglyConnComp nodes)

153+ where

154+ addTypeAlias :: Environment -> Graph.SCC (String, [String], Type.RawType)

155+ -> Canonicalizer [Doc] Environment

156+ addTypeAlias env scc =

157+ case Graph.flattenSCC scc of

158+ [(name, tvars, alias)] ->

159+ do alias' <- Env.onError throw (Canonicalize.tipe env alias)

160+ let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')

161+ return $ env { _aliases = insert name value (_aliases env) }

162+ where

163+ throw err =

164+ let msg = "Problem with type alias '" ++ name ++ "':"

165+ in P.vcat [ P.text msg, P.text err ]

166+

167+ aliases ->

168+ throwError [ P.vcat [ P.text (eightyCharLines 0 msg1)

169+ , indented (map typeAlias aliases)

170+ , P.text (eightyCharLines 0 msg2)

171+ , indented (map datatype aliases)

172+ , P.text (eightyCharLines 0 msg3)

173+ ]

174+ ]

175+

176+ typeAlias (n,ts,t) = D.TypeAlias n ts t

177+ datatype (n,ts,t) = D.Datatype n ts [(n,[t])]

178+

179+ indented :: [D.ValidDecl] -> Doc

180+ indented decls = P.vcat (map prty decls) <> P.text "\n"

181+ where

182+ prty decl = P.text "\n " <> pretty decl

183+

184+ msg1 = "The following type aliases are mutually recursive, forming an \

185+ \infinite type. When you expand them, they just keep getting bigger:"

186+ msg2 = "Instead, you can try something like this:"

187+ msg3 = "It looks very similar, but an algebraic data type (ADT) \

188+ \actually creates a new type. Unlike with a type alias, this \

189+ \freshly created type is meaningful on its own, so an ADT \

190+ \does not need to be expanded."

191+

192+

193+-- When canonicalizing, all _values should be Local, but all _adts and _patterns

194+-- should be fully namespaced. With _adts, they may appear in types that can

195+-- escape the module.

196+addDecl :: String -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)

197+addDecl moduleName info@(nodes,env) decl =

198+ let namespacedVar = Var.Canonical (Var.Module moduleName)

199+ addLocal x e = insert x (Var.local x) e

200+ addNamespaced x e = insert x (namespacedVar x) e

201+ in

202+ case decl of

203+ D.Definition (Valid.Definition pattern _ _) ->

204+ (,) nodes $ env

205+ { _values = foldr addLocal (_values env) (P.boundVarList pattern) }

206+

207+ D.Datatype name _ ctors ->

208+ (,) nodes $ env

209+ { _values = addCtors addLocal (_values env)

210+ , _adts = addNamespaced name (_adts env)

211+ , _patterns = addCtors addNamespaced (_patterns env)

212+ }

213+ where

214+ addCtors how e = foldr how e (map fst ctors)

215+

216+ D.TypeAlias name tvars alias ->

217+ (,) (node name tvars alias : nodes) $ env

218+ { _values = case alias of

219+ Type.Record _ _ -> addLocal name (_values env)

220+ _ -> _values env

221+ }

222+

223+ D.Port port ->

224+ let portName = case port of

225+ D.Out name _ _ -> name

226+ D.In name _ -> name

227+ in

228+ (,) nodes $ env { _values = addLocal portName (_values env) }

229+

230+ D.Fixity _ _ _ -> info

compiler/Transform/Canonicalize/Type.hsnew file+71

@@ -0,0 +1,71 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Canonicalize.Type (tipe) where

3+

4+import Control.Arrow (second)

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

6+import Control.Monad.Error

7+import qualified Data.Map as Map

8+import Data.Traversable (traverse)

9+

10+import qualified AST.Type as T

11+import qualified AST.Variable as Var

12+

13+import Transform.Canonicalize.Environment

14+import qualified Transform.Canonicalize.Variable as Canonicalize

15+

16+tipe :: Environment -> T.RawType -> Canonicalizer String T.CanonicalType

17+tipe env typ =

18+ let go = tipe env in

19+ case typ of

20+ T.Var x -> return (T.Var x)

21+ T.Type _ -> canonicalizeApp env typ []

22+ T.App t ts -> canonicalizeApp env t ts

23+

24+ T.Lambda a b -> T.Lambda <$> go a <*> go b

25+ T.Aliased name t -> T.Aliased name <$> go t

26+

27+ T.Record fields ext ->

28+ let go' (f,t) = (,) f <$> go t

29+ in T.Record <$> mapM go' fields <*> traverse go ext

30+

31+canonicalizeApp :: Environment -> T.RawType -> [T.RawType]

32+ -> Canonicalizer String T.CanonicalType

33+canonicalizeApp env f args =

34+ case f of

35+ T.Type (Var.Raw rawName) ->

36+ do answer <- Canonicalize.tvar env rawName

37+ case answer of

38+ Right alias -> canonicalizeAlias env alias args

39+ Left name -> case args of

40+ [] -> return (T.Type name)

41+ _:_ -> T.App (T.Type name) <$> mapM (tipe env) args

42+

43+ _ -> T.App <$> tipe env f <*> mapM (tipe env) args

44+

45+canonicalizeAlias :: Environment -> (Var.Canonical, [String], T.CanonicalType)

46+ -> [T.RawType]

47+ -> Canonicalizer String T.CanonicalType

48+canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =

49+ do when (tipesLen /= tvarsLen) (throwError msg)

50+ tipes' <- mapM (tipe env) tipes

51+ let tipe' = replace (Map.fromList (zip tvars tipes')) dealiasedTipe

52+ return $ T.Aliased name tipe'

53+ where

54+ tipesLen = length tipes

55+ tvarsLen = length tvars

56+

57+ msg :: String

58+ msg = "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++

59+ " type argument" ++ (if tvarsLen == 1 then "" else "s") ++

60+ " but was given " ++ show tipesLen

61+

62+ replace :: Map.Map String T.CanonicalType -> T.CanonicalType -> T.CanonicalType

63+ replace typeTable t =

64+ let go = replace typeTable in

65+ case t of

66+ T.Lambda a b -> T.Lambda (go a) (go b)

67+ T.Var x -> Map.findWithDefault t x typeTable

68+ T.Record fields ext -> T.Record (map (second go) fields) (fmap go ext)

69+ T.Aliased original t' -> T.Aliased original (go t')

70+ T.Type _ -> t

71+ T.App f args -> T.App (go f) (map go args)

compiler/Transform/Canonicalize/Variable.hsnew file+94

@@ -0,0 +1,94 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Canonicalize.Variable where

3+

4+import Control.Monad.Error

5+import qualified Data.List as List

6+import qualified Data.Map as Map

7+import Data.Maybe (fromMaybe)

8+

9+import AST.Helpers as Help

10+import qualified AST.Type as Type

11+import qualified AST.Variable as Var

12+import Transform.Canonicalize.Environment as Env

13+

14+variable :: Environment -> String -> Canonicalizer String Var.Canonical

15+variable env var =

16+ case modul of

17+ Just ms@(m:_)

18+ | m == "Native" -> Env.using (Var.Canonical home name)

19+ where

20+ home = Var.Module (List.intercalate "." ms)

21+

22+ _ ->

23+ case Map.lookup var (_values env) of

24+ Just [v] -> Env.using v

25+ Just vs -> preferLocals env "variable" vs var

26+ Nothing -> notFound "variable" (Map.keys (_values env)) var

27+ where

28+ (modul, name) =

29+ case Help.splitDots var of

30+ [x] -> (Nothing, x)

31+ xs -> (Just (init xs), last xs)

32+

33+tvar :: Environment -> String

34+ -> Canonicalizer String (Either Var.Canonical (Var.Canonical, [String], Type.CanonicalType))

35+tvar env var =

36+ case adts ++ aliases of

37+ [] -> notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var

38+ [v] -> found extract v

39+ vs -> preferLocals' env extract "type" vs var

40+ where

41+ adts = map Left . fromMaybe [] $ Map.lookup var (_adts env)

42+ aliases = map Right . fromMaybe [] $ Map.lookup var (_aliases env)

43+

44+ extract value =

45+ case value of

46+ Left v -> v

47+ Right (v,_,_) -> v

48+

49+pvar :: Environment -> String -> Canonicalizer String Var.Canonical

50+pvar env var =

51+ case Map.lookup var (_patterns env) of

52+ Just [v] -> Env.using v

53+ Just vs -> preferLocals env "pattern" vs var

54+ Nothing -> notFound "pattern" (Map.keys (_patterns env)) var

55+

56+found :: (a -> Var.Canonical) -> a -> Canonicalizer String a

57+found extract v = do

58+ _ <- Env.using (extract v)

59+ return v

60+

61+notFound :: String -> [String] -> String -> Canonicalizer String a

62+notFound kind possibilities var =

63+ throwError $ "Could not find " ++ kind ++ " '" ++ var ++ "'." ++ msg

64+ where

65+ matches = filter (List.isInfixOf var) possibilities

66+ msg = if null matches then "" else

67+ "\nClose matches include: " ++ List.intercalate ", " matches

68+

69+preferLocals :: Environment -> String -> [Var.Canonical] -> String

70+ -> Canonicalizer String Var.Canonical

71+preferLocals env = preferLocals' env id

72+

73+preferLocals' :: Environment -> (a -> Var.Canonical) -> String -> [a] -> String

74+ -> Canonicalizer String a

75+preferLocals' env extract kind possibilities var =

76+ case filter (isLocal . extract) possibilities of

77+ [] -> ambiguous possibilities

78+ [v] -> found extract v

79+ locals -> ambiguous locals

80+ where

81+ isLocal :: Var.Canonical -> Bool

82+ isLocal (Var.Canonical home _) =

83+ case home of

84+ Var.Local -> True

85+ Var.BuiltIn -> False

86+ Var.Module name -> name == Env._home env

87+

88+ ambiguous possibleVars =

89+ throwError msg

90+ where

91+ vars = map (Var.toString . extract) possibleVars

92+ msg = "Ambiguous usage of " ++ kind ++ " '" ++ var ++ "'.\n" ++

93+ " Disambiguate between: " ++ List.intercalate ", " vars

94+

compiler/Transform/Check.hs+24−18

@@ -6,17 +6,18 @@ import qualified Data.List as List

6import qualified Data.Maybe as Maybe

7import qualified Data.Set as Set

8

9−import qualified SourceSyntax.Expression as E

9+import qualified AST.Expression.Valid as Valid

10−import qualified SourceSyntax.Declaration as D

10+import qualified AST.Declaration as D

11−import qualified SourceSyntax.Pattern as Pattern

11+import qualified AST.Pattern as Pattern

12−import qualified SourceSyntax.Type as T

12+import qualified AST.Type as T

13+import qualified AST.Variable as Var

13import qualified Transform.Expression as Expr

14import qualified Transform.Expression as Expr

14

15

15−import SourceSyntax.PrettyPrint

16+import AST.PrettyPrint

16import Text.PrettyPrint as P

17import Text.PrettyPrint as P

17

18

19

19−mistakes :: [D.Declaration] -> [Doc]

20+mistakes :: [D.ValidDecl] -> [Doc]

20mistakes decls =

21mistakes decls =

21 concat [ infiniteTypeAliases decls

22 concat [ infiniteTypeAliases decls

22 , illFormedTypes decls

23 , illFormedTypes decls

@@ -30,7 +31,7 @@ dupErr :: String -> String -> String

30dupErr err x =

31dupErr err x =

31 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."

32 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."

32

33

33−duplicates :: [D.Declaration] -> [String]

34+duplicates :: [D.ValidDecl] -> [String]

34duplicates decls =

35duplicates decls =

35 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++

36 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++

36 case mapM exprDups (portExprs ++ defExprs) of

37 case mapM exprDups (portExprs ++ defExprs) of

@@ -41,7 +42,7 @@ duplicates decls =

41 msg = dupErr "definition of"

42 msg = dupErr "definition of"

42

43

43 (defPatterns, defExprs) =

44 (defPatterns, defExprs) =

44− unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]

45+ unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]

45

46

46 (portNames, portExprs) =

47 (portNames, portExprs) =

47 Arrow.second concat $ unzip $

48 Arrow.second concat $ unzip $

@@ -50,17 +51,17 @@ duplicates decls =

50 D.Out name expr _ -> (name, [expr])

51 D.Out name expr _ -> (name, [expr])

51 D.In name _ -> (name, [])

52 D.In name _ -> (name, [])

52

53

53− exprDups :: E.Expr -> Either String E.Expr

54+ exprDups :: Valid.Expr -> Either String Valid.Expr

54 exprDups expr = Expr.crawlLet defsDups expr

55 exprDups expr = Expr.crawlLet defsDups expr

55

56

56− defsDups :: [E.Def] -> Either String [E.Def]

57+ defsDups :: [Valid.Def] -> Either String [Valid.Def]

57 defsDups defs =

58 defsDups defs =

58− let varsIn (E.Definition pattern _ _) = Pattern.boundVarList pattern in

59+ let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in

59 case dups $ concatMap varsIn defs of

60 case dups $ concatMap varsIn defs of

60 [] -> Right defs

61 [] -> Right defs

61 name:_ -> Left name

62 name:_ -> Left name

62

63

63−duplicateConstructors :: [D.Declaration] -> [String]

64+duplicateConstructors :: [D.ValidDecl] -> [String]

64duplicateConstructors decls =

65duplicateConstructors decls =

65 map (dupErr "definition of type constructor") (dups typeCtors) ++

66 map (dupErr "definition of type constructor") (dups typeCtors) ++

66 map (dupErr "definition of data constructor") (dups dataCtors)

67 map (dupErr "definition of data constructor") (dups dataCtors)

@@ -68,7 +69,7 @@ duplicateConstructors decls =

68 typeCtors = [ name | D.Datatype name _ _ <- decls ]

69 typeCtors = [ name | D.Datatype name _ _ <- decls ]

69 dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]

70 dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]

70

71

71−illFormedTypes :: [D.Declaration] -> [Doc]

72+illFormedTypes :: [D.ValidDecl] -> [Doc]

72illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

73illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

73 where

74 where

74 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]

75 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]

@@ -78,9 +79,11 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

78 case tipe of

79 case tipe of

79 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

80 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

80 T.Var x -> Set.singleton x

81 T.Var x -> Set.singleton x

81− T.Data _ ts -> Set.unions (map freeVars ts)

82+ T.Type _ -> Set.empty

83+ T.App t ts -> Set.unions (map freeVars (t:ts))

82 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)

84 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)

83− where ext' = maybe Set.empty Set.singleton ext

85+ where ext' = maybe Set.empty freeVars ext

86+ T.Aliased _ t -> freeVars t

84

87

85 undeclared tvars tipes = Set.difference used declared

88 undeclared tvars tipes = Set.difference used declared

86 where

89 where

@@ -113,20 +116,23 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

113 quote tvar = "'" ++ tvar ++ "'"

116 quote tvar = "'" ++ tvar ++ "'"

114

117

115

118

116−infiniteTypeAliases :: [D.Declaration] -> [Doc]

119+infiniteTypeAliases :: [D.ValidDecl] -> [Doc]

117infiniteTypeAliases decls =

120infiniteTypeAliases decls =

118 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls

121 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls

119 , infiniteType name tipe ]

122 , infiniteType name tipe ]

120 where

123 where

124+ infiniteType :: String -> T.Type Var.Raw -> Bool

121 infiniteType name tipe =

125 infiniteType name tipe =

122 let infinite = infiniteType name in

126 let infinite = infiniteType name in

123 case tipe of

127 case tipe of

124 T.Lambda a b -> infinite a || infinite b

128 T.Lambda a b -> infinite a || infinite b

125 T.Var _ -> False

129 T.Var _ -> False

126− T.Data name' ts -> name == name' || any infinite ts

130+ T.Type (Var.Raw name') -> name == name'

131+ T.App t ts -> any infinite (t:ts)

127 T.Record fields _ -> any (infinite . snd) fields

132 T.Record fields _ -> any (infinite . snd) fields

133+ T.Aliased _ t -> infinite t

128

134

129− indented :: D.Declaration -> Doc

135+ indented :: D.ValidDecl -> Doc

130 indented decl = P.text "\n " <> pretty decl <> P.text "\n"

136 indented decl = P.text "\n " <> pretty decl <> P.text "\n"

131

137

132 report name args tipe =

138 report name args tipe =

compiler/Transform/Declaration.hs+89−24

@@ -1,16 +1,23 @@

1{-# OPTIONS_GHC -Wall #-}

2−module Transform.Declaration where

2+module Transform.Declaration (combineAnnotations, toExpr) where

3

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

5−import qualified SourceSyntax.Pattern as P

5+

6−import SourceSyntax.Expression as E

6+import qualified AST.Annotation as A

7−import SourceSyntax.Declaration as D

7+import qualified AST.Declaration as D

8+import qualified AST.Expression.General as E

9+import qualified AST.Expression.Source as Source

10+import qualified AST.Expression.Valid as Valid

11+import qualified AST.Expression.Canonical as Canonical

12+import qualified AST.Pattern as P

13+import qualified AST.Type as T

14+import qualified AST.Variable as Var

8

15

9import qualified Transform.Expression as Expr

16import qualified Transform.Expression as Expr

10import qualified Transform.Definition as Def

17import qualified Transform.Definition as Def

11

18

12

19

13−combineAnnotations :: [ParseDeclaration] -> Either String [Declaration]

20+combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]

14combineAnnotations = go

21combineAnnotations = go

15 where

22 where

16 msg x = "Syntax Error: The type annotation for '" ++ x ++

23 msg x = "Syntax Error: The type annotation for '" ++ x ++

@@ -23,41 +30,99 @@ combineAnnotations = go

23 -- simple cases, pass them through with no changes

30 -- simple cases, pass them through with no changes

24 [] -> return []

31 [] -> return []

25

32

26− Datatype name tvars ctors : rest ->

33+ D.Datatype name tvars ctors : rest ->

27− (:) (Datatype name tvars ctors) <$> go rest

34+ (:) (D.Datatype name tvars ctors) <$> go rest

28

35

29− TypeAlias name tvars alias : rest ->

36+ D.TypeAlias name tvars alias : rest ->

30− (:) (TypeAlias name tvars alias) <$> go rest

37+ (:) (D.TypeAlias name tvars alias) <$> go rest

31

38

32− Fixity assoc prec op : rest ->

39+ D.Fixity assoc prec op : rest ->

33− (:) (Fixity assoc prec op) <$> go rest

40+ (:) (D.Fixity assoc prec op) <$> go rest

34

41

35 -- combine definitions

42 -- combine definitions

36 D.Definition def : defRest ->

43 D.Definition def : defRest ->

37 case def of

44 case def of

38− Def pat expr ->

45+ Source.Definition pat expr ->

39 do expr' <- exprCombineAnnotations expr

46 do expr' <- exprCombineAnnotations expr

40− let def' = E.Definition pat expr' Nothing

47+ let def' = Valid.Definition pat expr' Nothing

41 (:) (D.Definition def') <$> go defRest

48 (:) (D.Definition def') <$> go defRest

42

49

43− TypeAnnotation name tipe ->

50+ Source.TypeAnnotation name tipe ->

44 case defRest of

51 case defRest of

45− D.Definition (Def pat@(P.Var name') expr) : rest | name == name' ->

52+ D.Definition (Source.Definition pat@(P.Var name') expr) : rest

46− do expr' <- exprCombineAnnotations expr

53+ | name == name' ->

47− let def' = E.Definition pat expr' (Just tipe)

54+ do expr' <- exprCombineAnnotations expr

48− (:) (D.Definition def') <$> go rest

55+ let def' = Valid.Definition pat expr' (Just tipe)

56+ (:) (D.Definition def') <$> go rest

49

57

50 _ -> Left (msg name)

58 _ -> Left (msg name)

51

59

52 -- combine ports

60 -- combine ports

53− Port port : portRest ->

61+ D.Port port : portRest ->

54 case port of

62 case port of

55− PPDef name _ -> Left (msg name)

63+ D.PPDef name _ -> Left (msg name)

56− PPAnnotation name tipe ->

64+ D.PPAnnotation name tipe ->

57 case portRest of

65 case portRest of

58− Port (PPDef name' expr) : rest | name == name' ->

66+ D.Port (D.PPDef name' expr) : rest | name == name' ->

59 do expr' <- exprCombineAnnotations expr

67 do expr' <- exprCombineAnnotations expr

60− (:) (Port (Out name expr' tipe)) <$> go rest

68+ (:) (D.Port (D.Out name expr' tipe)) <$> go rest

69+

70+ _ -> (:) (D.Port (D.In name tipe)) <$> go portRest

71+

72+

73+toExpr :: String -> [D.CanonicalDecl] -> [Canonical.Def]

74+toExpr moduleName = concatMap (toDefs moduleName)

75+

76+toDefs :: String -> D.CanonicalDecl -> [Canonical.Def]

77+toDefs moduleName decl =

78+ let typeVar = Var.Canonical (Var.Module moduleName) in

79+ case decl of

80+ D.Definition def -> [def]

81+

82+ D.Datatype name tvars constructors -> concatMap toDefs' constructors

83+ where

84+ toDefs' (ctor, tipes) =

85+ let vars = take (length tipes) arguments

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

87+ body = A.none . E.Data ctor $ map (A.none . E.localVar) vars

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

89+

90+ D.TypeAlias name _ tipe@(T.Record fields ext) ->

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

92+ where

93+ result = T.Aliased (typeVar name) tipe

94+

95+ args = map snd fields ++ maybe [] (:[]) ext

96+

97+ var = A.none . E.localVar

98+ vars = take (length args) arguments

99+

100+ efields = zip (map fst fields) (map var vars)

101+ record = case ext of

102+ Nothing -> A.none $ E.Record efields

103+ Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields

104+

105+ -- Type aliases must be added to an extended equality dictionary,

106+ -- but they do not require any basic constraints.

107+ D.TypeAlias _ _ _ -> []

108+

109+ D.Port port ->

110+ case port of

111+ D.Out name expr@(A.A s _) tipe ->

112+ [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]

113+ D.In name tipe ->

114+ [ definition name (A.none $ E.PortIn name tipe) tipe ]

115+

116+ -- no constraints are needed for fixity declarations

117+ D.Fixity _ _ _ -> []

118+

119+

120+arguments :: [String]

121+arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

61

122

62− _ -> (:) (Port (In name tipe)) <$> go portRest

123+buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr

124+buildFunction body@(A.A s _) vars =

125+ foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)

63

126

127+definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def

128+definition name expr tipe = Canonical.Definition (P.Var name) expr (Just tipe)

compiler/Transform/Definition.hs+14−10

@@ -2,11 +2,12 @@

2module Transform.Definition where

3

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

5−import qualified SourceSyntax.Pattern as P

5+import qualified AST.Pattern as P

6−import SourceSyntax.Expression

6+import qualified AST.Expression.Source as Source

7+import qualified AST.Expression.Valid as Valid

7import qualified Transform.Expression as Expr

8import qualified Transform.Expression as Expr

8

9

9−combineAnnotations :: [ParseDef] -> Either String [Def]

10+combineAnnotations :: [Source.Def] -> Either String [Valid.Def]

10combineAnnotations = go

11combineAnnotations = go

11 where

12 where

12 msg x = "Syntax Error: The type annotation for '" ++ x ++

13 msg x = "Syntax Error: The type annotation for '" ++ x ++

@@ -16,16 +17,19 @@ combineAnnotations = go

16

17

17 go defs =

18 go defs =

18 case defs of

19 case defs of

19− TypeAnnotation name tipe : Def pat@(P.Var name') expr : rest | name == name' ->

20+ Source.TypeAnnotation name tipe : rest ->

20− do expr' <- exprCombineAnnotations expr

21+ case rest of

21− let def = Definition pat expr' (Just tipe)

22+ Source.Definition pat@(P.Var name') expr : rest'

22− (:) def <$> go rest

23+ | name == name' ->

24+ do expr' <- exprCombineAnnotations expr

25+ let def = Valid.Definition pat expr' (Just tipe)

26+ (:) def <$> go rest'

23

27

24− TypeAnnotation name _ : _ -> Left (msg name)

28+ _ -> Left (msg name)

25

29

26− Def pat expr : rest ->

30+ Source.Definition pat expr : rest ->

27 do expr' <- exprCombineAnnotations expr

31 do expr' <- exprCombineAnnotations expr

28− let def = Definition pat expr' Nothing

32+ let def = Valid.Definition pat expr' Nothing

29 (:) def <$> go rest

33 (:) def <$> go rest

30

34

31 [] -> return []

35 [] -> return []

compiler/Transform/Expression.hs+15−14

@@ -2,31 +2,32 @@

2module Transform.Expression (crawlLet, checkPorts) where

3

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

5−import SourceSyntax.Annotation ( Annotated(A) )

5+import AST.Annotation ( Annotated(A) )

6−import SourceSyntax.Expression

6+import AST.Expression.General

7−import SourceSyntax.Type (Type)

7+import qualified AST.Expression.Canonical as Canonical

8+import AST.Type (Type, CanonicalType)

8

9

9crawlLet :: ([def] -> Either a [def'])

10crawlLet :: ([def] -> Either a [def'])

10− -> GeneralExpr ann def var

11+ -> Expr ann def var

11− -> Either a (GeneralExpr ann def' var)

12+ -> Either a (Expr ann def' var)

12crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())

13crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())

13

14

14−checkPorts :: (String -> Type -> Either a ())

15+checkPorts :: (String -> CanonicalType -> Either a ())

15− -> (String -> Type -> Either a ())

16+ -> (String -> CanonicalType -> Either a ())

16− -> Expr

17+ -> Canonical.Expr

17− -> Either a Expr

18+ -> Either a Canonical.Expr

18checkPorts inCheck outCheck expr =

19checkPorts inCheck outCheck expr =

19 crawl inCheck outCheck (mapM checkDef) expr

20 crawl inCheck outCheck (mapM checkDef) expr

20 where

21 where

21− checkDef def@(Definition _ body _) =

22+ checkDef def@(Canonical.Definition _ body _) =

22 do _ <- checkPorts inCheck outCheck body

23 do _ <- checkPorts inCheck outCheck body

23 return def

24 return def

24

25

25−crawl :: (String -> Type -> Either a ())

26+crawl :: (String -> Type var -> Either a ())

26− -> (String -> Type -> Either a ())

27+ -> (String -> Type var -> Either a ())

27 -> ([def] -> Either a [def'])

28 -> ([def] -> Either a [def'])

28− -> GeneralExpr ann def var

29+ -> Expr ann def var

29− -> Either a (GeneralExpr ann def' var)

30+ -> Either a (Expr ann def' var)

30crawl portInCheck portOutCheck defsTransform = go

31crawl portInCheck portOutCheck defsTransform = go

31 where

32 where

32 go (A srcSpan expr) =

33 go (A srcSpan expr) =

compiler/Transform/Interface.hsnew file+58

@@ -0,0 +1,58 @@

1+{-# OPTIONS_GHC -W #-}

2+module Transform.Interface (filterExports) where

3+

4+import qualified Data.Map as Map

5+import qualified AST.Module as Module

6+import qualified AST.Type as Type

7+import qualified AST.Variable as Var

8+

9+filterExports :: Module.Interface -> Module.Interface

10+filterExports interface =

11+ interface

12+ { Module.iTypes =

13+ Map.fromList (concatMap getTypes exportedValues)

14+ , Module.iAliases =

15+ Map.fromList (concatMap getAliases exportedValues)

16+ , Module.iAdts =

17+ Map.fromList (concatMap getAdts exportedValues)

18+ }

19+ where

20+ exportedValues :: [Var.Value]

21+ exportedValues = Module.iExports interface

22+

23+ get :: Map.Map String a -> String -> [(String, a)]

24+ get dict x =

25+ case Map.lookup x dict of

26+ Just t -> [(x,t)]

27+ Nothing -> []

28+

29+ getTypes :: Var.Value -> [(String, Type.CanonicalType)]

30+ getTypes value =

31+ case value of

32+ Var.Value x -> getType x

33+ Var.Alias _ -> []

34+ Var.ADT _ (Var.Listing ctors _) -> concatMap getType ctors

35+

36+ getType :: String -> [(String, Type.CanonicalType)]

37+ getType name =

38+ get (Module.iTypes interface) name

39+

40+ getAliases :: Var.Value -> [(String, ([String], Type.CanonicalType))]

41+ getAliases value =

42+ case value of

43+ Var.Value _ -> []

44+ Var.Alias name -> get (Module.iAliases interface) name

45+ Var.ADT _ _ -> []

46+

47+ getAdts :: Var.Value -> [(String, Module.AdtInfo String)]

48+ getAdts value =

49+ case value of

50+ Var.Value _ -> []

51+ Var.Alias _ -> []

52+ Var.ADT name (Var.Listing exportedCtors _) ->

53+ case Map.lookup name (Module.iAdts interface) of

54+ Nothing -> []

55+ Just (tvars, ctors) ->

56+ [(name, (tvars, filter isExported ctors))]

57+ where

58+ isExported (ctor, _) = ctor `elem` exportedCtors

compiler/Transform/SafeNames.hsdeleted−78

@@ -1,78 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.SafeNames (metadataModule) where

3−

4−import Control.Arrow (first, (***))

5−import qualified Data.List as List

6−import qualified Data.Set as Set

7−

8−import qualified Parse.Helpers as PHelp

9−import SourceSyntax.Annotation

10−import SourceSyntax.Expression

11−import qualified SourceSyntax.Helpers as SHelp

12−import SourceSyntax.Module

13−import qualified SourceSyntax.Pattern as P

14−import qualified SourceSyntax.Variable as Variable

15−

16−var :: String -> String

17−var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots

18− where

19− deprime = map (\c -> if c == '\'' then '$' else c)

20− dereserve x = case Set.member x PHelp.jsReserveds of

21− False -> x

22− True -> "$" ++ x

23−

24−pattern :: P.Pattern -> P.Pattern

25−pattern pat =

26− case pat of

27− P.Var x -> P.Var (var x)

28− P.Literal _ -> pat

29− P.Record fs -> P.Record (map var fs)

30− P.Anything -> pat

31− P.Alias x p -> P.Alias (var x) (pattern p)

32− P.Data name ps -> P.Data name (map pattern ps)

33−

34−-- TODO: should be "normal expression" -> "expression for JS generation"

35−expression :: Expr -> Expr

36−expression (A ann expr) =

37− let f = expression in

38− A ann $

39− case expr of

40− Literal _ -> expr

41− Var (Variable.Raw x) -> rawVar (var x)

42− Range e1 e2 -> Range (f e1) (f e2)

43− ExplicitList es -> ExplicitList (map f es)

44− Binop op e1 e2 -> Binop op (f e1) (f e2)

45− Lambda p e -> Lambda (pattern p) (f e)

46− App e1 e2 -> App (f e1) (f e2)

47− MultiIf ps -> MultiIf (map (f *** f) ps)

48− Let defs body -> Let (map definition defs) (f body)

49− Case e cases -> Case (f e) $ map (pattern *** f) cases

50− Data name es -> Data name (map f es)

51− Access e x -> Access (f e) (var x)

52− Remove e x -> Remove (f e) (var x)

53− Insert e x v -> Insert (f e) (var x) (f v)

54− Modify r fs -> Modify (f r) (map (var *** f) fs)

55− Record fs -> Record (map (var *** f) fs)

56− Markdown uid md es -> Markdown uid md (map f es)

57− GLShader _ _ _ -> expr

58− PortIn name st -> PortIn name st

59− PortOut name st signal -> PortOut name st (f signal)

60−

61−definition :: Def -> Def

62−definition (Definition p e t) =

63− Definition (pattern p) (expression e) t

64−

65−metadataModule :: MetadataModule -> MetadataModule

66−metadataModule modul =

67− modul

68− { names = map var (names modul)

69− , exports = map var (exports modul)

70− , imports = map (first var) (imports modul)

71− , program = expression (program modul)

72− , aliases =

73− let makeSafe (name,tvars,tipe) = (var name, tvars, tipe)

74− in map makeSafe (aliases modul)

75− , datatypes =

76− let makeSafe (name,tvars,ctors) = (var name, tvars, map (first var) ctors)

77− in map makeSafe (datatypes modul)

78− }

compiler/Transform/SortDefinitions.hs+37−21

@@ -7,42 +7,57 @@ import qualified Data.Graph as Graph

7import qualified Data.Map as Map

8import qualified Data.Maybe as Maybe

9import qualified Data.Set as Set

10−import SourceSyntax.Annotation

11−import SourceSyntax.Expression

12−import qualified SourceSyntax.Pattern as P

13−import qualified SourceSyntax.Variable as V

14

10

15−ctors :: P.Pattern -> [String]

11+import AST.Annotation

12+import AST.Expression.General (Expr'(..))

13+import qualified AST.Expression.Canonical as Canonical

14+import qualified AST.Pattern as P

15+import qualified AST.Variable as V

16+

17+ctors :: P.CanonicalPattern -> [String]

16ctors pattern =

18ctors pattern =

17 case pattern of

19 case pattern of

18 P.Var _ -> []

20 P.Var _ -> []

19 P.Alias _ p -> ctors p

21 P.Alias _ p -> ctors p

20− P.Data ctor ps -> ctor : concatMap ctors ps

21 P.Record _ -> []

22 P.Record _ -> []

22 P.Anything -> []

23 P.Anything -> []

23 P.Literal _ -> []

24 P.Literal _ -> []

25+ P.Data (V.Canonical home name) ps ->

26+ case home of

27+ V.Local -> name : rest

28+ V.BuiltIn -> rest

29+ V.Module _ -> rest

30+ where

31+ rest = concatMap ctors ps

24

32

25free :: String -> State (Set.Set String) ()

33free :: String -> State (Set.Set String) ()

26free x = modify (Set.insert x)

34free x = modify (Set.insert x)

27

35

36+freeIfLocal :: V.Canonical -> State (Set.Set String) ()

37+freeIfLocal (V.Canonical home name) =

38+ do case home of

39+ V.Local -> free name

40+ V.BuiltIn -> return ()

41+ V.Module _ -> return ()

42+

28bound :: Set.Set String -> State (Set.Set String) ()

43bound :: Set.Set String -> State (Set.Set String) ()

29bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

44bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

30

45

31−sortDefs :: Expr -> Expr

46+sortDefs :: Canonical.Expr -> Canonical.Expr

32sortDefs expr = evalState (reorder expr) Set.empty

47sortDefs expr = evalState (reorder expr) Set.empty

33

48

34−reorder :: Expr -> State (Set.Set String) Expr

49+reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr

35reorder (A ann expr) =

50reorder (A ann expr) =

36 A ann <$>

51 A ann <$>

37 case expr of

52 case expr of

38 -- Be careful adding and restricting freeVars

53 -- Be careful adding and restricting freeVars

39− Var (V.Raw x) -> free x >> return expr

54+ Var var -> freeIfLocal var >> return expr

40

55

41 Lambda p e ->

56 Lambda p e ->

42 uncurry Lambda <$> bindingReorder (p,e)

57 uncurry Lambda <$> bindingReorder (p,e)

43

58

44 Binop op e1 e2 ->

59 Binop op e1 e2 ->

45− do free op

60+ do freeIfLocal op

46 Binop op <$> reorder e1 <*> reorder e2

61 Binop op <$> reorder e1 <*> reorder e2

47

62

48 Case e cases ->

63 Case e cases ->

@@ -102,7 +117,7 @@ reorder (A ann expr) =

102 let defss = map Graph.flattenSCC sccs

117 let defss = map Graph.flattenSCC sccs

103

118

104 -- remove let-bound variables from the context

119 -- remove let-bound variables from the context

105− forM_ defs $ \(Definition pattern _ _) -> do

120+ forM_ defs $ \(Canonical.Definition pattern _ _) -> do

106 bound (P.boundVars pattern)

121 bound (P.boundVars pattern)

107 mapM free (ctors pattern)

122 mapM free (ctors pattern)

108

123

@@ -110,7 +125,8 @@ reorder (A ann expr) =

110

125

111 return let'

126 return let'

112

127

113−bindingReorder :: (P.Pattern, Expr) -> State (Set.Set String) (P.Pattern, Expr)

128+bindingReorder :: (P.CanonicalPattern, Canonical.Expr)

129+ -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)

114bindingReorder (pattern,expr) =

130bindingReorder (pattern,expr) =

115 do expr' <- reorder expr

131 do expr' <- reorder expr

116 bound (P.boundVars pattern)

132 bound (P.boundVars pattern)

@@ -118,8 +134,8 @@ bindingReorder (pattern,expr) =

118 return (pattern, expr')

134 return (pattern, expr')

119

135

120

136

121−reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])

137+reorderAndGetDependencies :: Canonical.Def -> State (Set.Set String) (Canonical.Def, [String])

122−reorderAndGetDependencies (Definition pattern expr mType) =

138+reorderAndGetDependencies (Canonical.Definition pattern expr mType) =

123 do globalFrees <- get

139 do globalFrees <- get

124 -- work in a fresh environment

140 -- work in a fresh environment

125 put Set.empty

141 put Set.empty

@@ -127,28 +143,28 @@ reorderAndGetDependencies (Definition pattern expr mType) =

127 localFrees <- get

143 localFrees <- get

128 -- merge with global frees

144 -- merge with global frees

129 modify (Set.union globalFrees)

145 modify (Set.union globalFrees)

130− return (Definition pattern expr' mType, Set.toList localFrees)

146+ return (Canonical.Definition pattern expr' mType, Set.toList localFrees)

131

147

132

148

133-- This also reorders the all of the sub-expressions in the Def list.

149-- This also reorders the all of the sub-expressions in the Def list.

134−buildDefDict :: [Def] -> State (Set.Set String) [(Def, Int, [Int])]

150+buildDefDict :: [Canonical.Def] -> State (Set.Set String) [(Canonical.Def, Int, [Int])]

135buildDefDict defs =

151buildDefDict defs =

136 do pdefsDeps <- mapM reorderAndGetDependencies defs

152 do pdefsDeps <- mapM reorderAndGetDependencies defs

137 return $ realDeps (addKey pdefsDeps)

153 return $ realDeps (addKey pdefsDeps)

138

154

139 where

155 where

140− addKey :: [(Def, [String])] -> [(Def, Int, [String])]

156+ addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]

141 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

157 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

142

158

143− variableToKey :: (Def, Int, [String]) -> [(String, Int)]

159+ variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]

144− variableToKey (Definition pattern _ _, key, _) =

160+ variableToKey (Canonical.Definition pattern _ _, key, _) =

145 [ (var, key) | var <- Set.toList (P.boundVars pattern) ]

161 [ (var, key) | var <- Set.toList (P.boundVars pattern) ]

146

162

147− variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int

163+ variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int

148 variableToKeyMap pdefsDeps =

164 variableToKeyMap pdefsDeps =

149 Map.fromList (concatMap variableToKey pdefsDeps)

165 Map.fromList (concatMap variableToKey pdefsDeps)

150

166

151− realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]

167+ realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]

152 realDeps pdefsDeps = map convert pdefsDeps

168 realDeps pdefsDeps = map convert pdefsDeps

153 where

169 where

154 varDict = variableToKeyMap pdefsDeps

170 varDict = variableToKeyMap pdefsDeps

compiler/Transform/Substitute.hs+78−32

@@ -4,42 +4,88 @@ module Transform.Substitute (subst) where

4import Control.Arrow (second, (***))

5import qualified Data.Set as Set

6

7−import SourceSyntax.Annotation

7+import AST.Annotation

8−import SourceSyntax.Expression

8+import AST.Expression.General (Expr'(..))

9−import qualified SourceSyntax.Pattern as Pattern

9+import qualified AST.Expression.Canonical as Canonical

10−import qualified SourceSyntax.Variable as V

10+import qualified AST.Pattern as Pattern

11+import qualified AST.Variable as V

11

12

12−subst :: String -> Expr' -> Expr' -> Expr'

13+

13−subst old new expr =

14+subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'

15+subst old new expression =

14 let f (A a e) = A a (subst old new e) in

16 let f (A a e) = A a (subst old new e) in

15− case expr of

17+ case expression of

16− Range e1 e2 -> Range (f e1) (f e2)

18+ Range e1 e2 ->

17− ExplicitList es -> ExplicitList (map f es)

19+ Range (f e1) (f e2)

18− Binop op e1 e2 -> Binop op (f e1) (f e2)

20+

19− Lambda p e

21+ ExplicitList exprs ->

20− | Set.member old (Pattern.boundVars p) -> expr

22+ ExplicitList (map f exprs)

21− | otherwise -> Lambda p (f e)

23+

22− App e1 e2 -> App (f e1) (f e2)

24+ Binop op e1 e2 ->

23− MultiIf ps -> MultiIf (map (f *** f) ps)

25+ Binop op (f e1) (f e2)

26+

27+ Lambda pattern body

28+ | Set.member old (Pattern.boundVars pattern) -> expression

29+ | otherwise -> Lambda pattern (f body)

30+

31+ App e1 e2 ->

32+ App (f e1) (f e2)

33+

34+ MultiIf branches ->

35+ MultiIf (map (f *** f) branches)

24

36

25 Let defs body

37 Let defs body

26− | anyShadow -> expr

38+ | anyShadow -> expression

27 | otherwise -> Let (map substDef defs) (f body)

39 | otherwise -> Let (map substDef defs) (f body)

28 where

40 where

29− substDef (Definition p e t) = Definition p (f e) t

41+ substDef (Canonical.Definition p e t) =

42+ Canonical.Definition p (f e) t

43+

30 anyShadow =

44 anyShadow =

31− any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]

45+ any (Set.member old . Pattern.boundVars)

32−

46+ [ pattern | Canonical.Definition pattern _ _ <- defs ]

33− Var (V.Raw x) -> if x == old then new else expr

47+

34− Case e cases -> Case (f e) $ map (second f) cases

48+ Var (V.Canonical home x) ->

35− Data name es -> Data name (map f es)

49+ case home of

36− Access e x -> Access (f e) x

50+ V.Module _ -> expression

37− Remove e x -> Remove (f e) x

51+ V.BuiltIn -> expression

38− Insert e x v -> Insert (f e) x (f v)

52+ V.Local -> if x == old then new else expression

39− Modify r fs -> Modify (f r) (map (second f) fs)

53+

40− Record fs -> Record (map (second f) fs)

54+ Case e cases ->

41− Literal _ -> expr

55+ Case (f e) (map substCase cases)

42− Markdown uid md es -> Markdown uid md (map f es)

56+ where

43− GLShader _ _ _ -> expr

57+ substCase (pattern, expr) =

44− PortIn name st -> PortIn name st

58+ if Set.member old (Pattern.boundVars pattern)

45− PortOut name st signal -> PortOut name st (f signal)

59+ then (pattern, expr)

60+ else (pattern, f expr)

61+

62+ Data tag values ->

63+ Data tag (map f values)

64+

65+ Access record field ->

66+ Access (f record) field

67+

68+ Remove record field ->

69+ Remove (f record) field

70+

71+ Insert record field value ->

72+ Insert (f record) field (f value)

73+

74+ Modify record fields ->

75+ Modify (f record) (map (second f) fields)

76+

77+ Record fields ->

78+ Record (map (second f) fields)

79+

80+ Literal _ -> expression

81+

82+ Markdown uid md exprs ->

83+ Markdown uid md (map f exprs)

84+

85+ GLShader _ _ _ -> expression

86+

87+ PortIn name st ->

88+ PortIn name st

89+

90+ PortOut name st signal ->

91+ PortOut name st (f signal)

compiler/Type/Alias.hsdeleted−139

@@ -1,139 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Type.Alias (realias, rules, canonicalRealias, Rules) where

3−

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

5−import Control.Monad

6−import Control.Arrow (second)

7−import Data.Map ((!))

8−import qualified Data.Map as Map

9−import qualified Data.List as List

10−import SourceSyntax.Type

11−import SourceSyntax.Module

12−

13−type Rules = ([Alias], Type -> Type)

14−

15−rules interfaces moduleAliases moduleImports =

16− (collect interfaces moduleAliases, localizer moduleImports)

17−

18−collect interfaces moduleAliases =

19− filter (not . isPrimitive) rawAliases

20− where

21− rawAliases =

22− moduleAliases ++ concatMap iAliases (Map.elems interfaces)

23−

24− isPrimitive (_,_,tipe) =

25− case tipe of

26− Data _ [] -> True

27− _ -> False

28−

29−localizer moduleImports = go

30− where

31− go tipe =

32− case tipe of

33− Var _ -> tipe

34− Lambda t1 t2 -> Lambda (go t1) (go t2)

35− Data name ts -> Data (localize name) (map go ts)

36− Record fs ext -> Record (map (second go) fs) ext

37−

38− byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)

39− Map.empty moduleImports

40−

41− separate name =

42− case List.elemIndices '.' name of

43− [] -> ("",name)

44− is -> let i = last is in

45− (take i name, drop (i+1) name)

46−

47− shortest = List.minimumBy (\a b -> compare (length a) (length b))

48−

49− localize name = shortest (name : concatMap (localize' value) methods)

50− where (modul, value) = separate name

51− methods = Map.findWithDefault [] modul byMethod

52−

53− localize' name method =

54− case method of

55− As modul -> [modul ++ "." ++ name]

56− Hiding xs | name `notElem` xs -> [name]

57− Importing xs | name `elem` xs -> [name]

58− _ -> []

59−

60−realias :: Rules -> Type -> Type

61−realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)

62−

63−-- Realias using canonical aliases, so results will have aliases

64−-- that are fully qualified and possible to compare.

65−canonicalRealias :: [Alias] -> Type -> Type

66−canonicalRealias aliases tipe =

67− case concatMap tryRealias aliases of

68− [] -> if tipe == tipe' then tipe else f tipe'

69− tipes -> f (bestType tipes)

70− where

71− tryRealias (name, args, aliasTipe) =

72− case diff aliasTipe tipe of

73− Nothing -> []

74− Just kvs ->

75− let holes = collectFields kvs

76− hasArgs = List.sort args == Map.keys holes

77− isConsistent = all allEqual (Map.elems holes)

78− in case hasArgs && isConsistent of

79− False -> []

80− True -> [Data name $ map (\arg -> head (holes ! arg)) args]

81−

82− f = canonicalRealias aliases

83− tipe' =

84− case tipe of

85− Var _ -> tipe

86− Lambda t1 t2 -> Lambda (f t1) (f t2)

87− Data name ts -> Data name (map f ts)

88− Record fs ext -> Record (map (second f) fs) ext

89−

90−allEqual [] = True

91−allEqual (x:xs) = all (==x) xs

92−

93−bestType tipes = fst $ List.minimumBy (\a b -> compare (snd a) (snd b)) pairs

94− where

95− pairs :: [(Type,Int)]

96− pairs = zip tipes (map numFields tipes)

97−

98− numFields :: Type -> Int

99− numFields tipe =

100− case tipe of

101− Lambda t1 t2 -> numFields t1 + numFields t2

102− Var _ -> 0

103− Data _ ts -> sum (map numFields ts)

104− Record fields _ -> length fields + sum (map (numFields . snd) fields)

105−

106−diff :: Type -> Type -> Maybe [(String,Type)]

107−diff general specific =

108− case (general, specific) of

109− (Lambda g1 g2, Lambda s1 s2) -> (++) <$> diff g1 s1 <*> diff g2 s2

110− (Var x, t) -> Just [(x,t)]

111− (Data gname gts, Data sname sts)

112− | gname == sname && length gts == length sts ->

113− concat <$> zipWithM diff gts sts

114− (Record [] Nothing, Record [] Nothing) -> Just []

115− (Record _ _, Record [] Nothing) -> Nothing

116− (Record [] Nothing, Record _ _) -> Nothing

117− (Record gfs gext, Record sfs sext) ->

118− let gfields = collectFields gfs

119− sfields = collectFields sfs

120−

121− overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields

122− isAligned = Map.size gfields == Map.size overlap && and (Map.elems overlap)

123− in

124− case isAligned of

125− False -> Nothing

126− True -> let remaining = Map.difference sfields gfields

127− sext' = case sext of

128− Just x | Map.null remaining -> Var x

129− _ -> Record (flattenFields remaining) sext

130− gext' = maybe (Record [] Nothing) Var gext

131− matchMap = Map.intersectionWith (zipWith diff) gfields sfields

132− in concat <$> sequence (diff gext' sext' : concat (Map.elems matchMap))

133− (_,_) -> Nothing

134−

135−collectFields fields =

136− foldr (\(f,t) fs -> Map.insertWith (++) f [t] fs) Map.empty fields

137−

138−flattenFields fields =

139− concatMap (\(f,ts) -> map ((,) f) ts) (Map.toList fields)

compiler/Type/Constrain/Declaration.hsdeleted−62

@@ -1,62 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Type.Constrain.Declaration where

3−

4−import qualified SourceSyntax.Annotation as A

5−import qualified SourceSyntax.Declaration as D

6−import qualified SourceSyntax.Expression as E

7−import qualified SourceSyntax.Pattern as P

8−import qualified SourceSyntax.Type as T

9−

10−toExpr :: [D.Declaration] -> [E.Def]

11−toExpr = concatMap toDefs

12−

13−toDefs :: D.Declaration -> [E.Def]

14−toDefs decl =

15− case decl of

16− D.Definition def -> [def]

17−

18− D.Datatype name tvars constructors -> concatMap toDefs' constructors

19− where

20− toDefs' (ctor, tipes) =

21− let vars = take (length tipes) arguments

22− tbody = T.Data name $ map T.Var tvars

23− body = A.none . E.Data ctor $ map (A.none . E.rawVar) vars

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

25−

26− D.TypeAlias name _ tipe@(T.Record fields ext) ->

27− [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]

28− where

29− args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext

30−

31− var = A.none . E.rawVar

32− vars = take (length args) arguments

33−

34− efields = zip (map fst fields) (map var vars)

35− record = case ext of

36− Nothing -> A.none $ E.Record efields

37− Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields

38−

39− -- Type aliases must be added to an extended equality dictionary,

40− -- but they do not require any basic constraints.

41− D.TypeAlias _ _ _ -> []

42−

43− D.Port port ->

44− case port of

45− D.Out name expr@(A.A s _) tipe ->

46− [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]

47− D.In name tipe ->

48− [ definition name (A.none $ E.PortIn name tipe) tipe ]

49−

50− -- no constraints are needed for fixity declarations

51− D.Fixity _ _ _ -> []

52−

53−

54−arguments :: [String]

55−arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

56−

57−buildFunction :: E.Expr -> [String] -> E.Expr

58−buildFunction body@(A.A s _) vars =

59− foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)

60−

61−definition :: String -> E.Expr -> T.Type -> E.Def

62−definition name expr tipe = E.Definition (P.Var name) expr (Just tipe)

compiler/Type/Constrain/Expression.hs+40−36

@@ -8,19 +8,21 @@ import qualified Data.List as List

8import qualified Data.Map as Map

9import qualified Text.PrettyPrint as PP

10

11−import SourceSyntax.Literal as Lit

11+import AST.Literal as Lit

12−import SourceSyntax.Annotation as Ann

12+import AST.Annotation as Ann

13−import SourceSyntax.Expression

13+import AST.Expression.General

14−import qualified SourceSyntax.Pattern as P

14+import qualified AST.Expression.Canonical as Canonical

15−import qualified SourceSyntax.Type as ST

15+import qualified AST.Pattern as P

16−import qualified SourceSyntax.Variable as V

16+import qualified AST.Type as ST

17+import qualified AST.Variable as V

17import Type.Type hiding (Descriptor(..))

18import Type.Type hiding (Descriptor(..))

18import Type.Fragment

19import Type.Fragment

19import qualified Type.Environment as Env

20import qualified Type.Environment as Env

20import qualified Type.Constrain.Literal as Literal

21import qualified Type.Constrain.Literal as Literal

21import qualified Type.Constrain.Pattern as Pattern

22import qualified Type.Constrain.Pattern as Pattern

22

23

23−constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint

24+constrain :: Env.Environment -> Canonical.Expr -> Type

25+ -> ErrorT [PP.Doc] IO TypeConstraint

24constrain env (A region expr) tipe =

26constrain env (A region expr) tipe =

25 let list t = Env.get env Env.types "_List" <| t

27 let list t = Env.get env Env.types "_List" <| t

26 and = A region . CAnd

28 and = A region . CAnd

@@ -45,12 +47,14 @@ constrain env (A region expr) tipe =

45 else record (Map.map (\t -> [glTipe t]) decls) baseRec

47 else record (Map.map (\t -> [glTipe t]) decls) baseRec

46 attribute = makeRec Lit.attribute attr

48 attribute = makeRec Lit.attribute attr

47 uniform = makeRec Lit.uniform unif

49 uniform = makeRec Lit.uniform unif

48− varying = makeRec Lit.varying (TermN EmptyRecord1)

50+ varying = makeRec Lit.varying (termN EmptyRecord1)

49 in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)

51 in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)

50

52

51− Var (V.Raw name)

53+ Var var

52 | name == saveEnvName -> return (A region CSaveEnv)

54 | name == saveEnvName -> return (A region CSaveEnv)

53 | otherwise -> return (name <? tipe)

55 | otherwise -> return (name <? tipe)

56+ where

57+ name = V.toString var

54

58

55 Range lo hi ->

59 Range lo hi ->

56 existsNumber $ \n -> do

60 existsNumber $ \n -> do

@@ -68,7 +72,7 @@ constrain env (A region expr) tipe =

68 exists $ \t2 -> do

72 exists $ \t2 -> do

69 c1 <- constrain env e1 t1

73 c1 <- constrain env e1 t1

70 c2 <- constrain env e2 t2

74 c2 <- constrain env e2 t2

71− return $ and [ c1, c2, op <? (t1 ==> t2 ==> tipe) ]

75+ return $ and [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]

72

76

73 Lambda p e ->

77 Lambda p e ->

74 exists $ \t1 ->

78 exists $ \t1 ->

@@ -102,8 +106,8 @@ constrain env (A region expr) tipe =

102 and . (:) ce <$> mapM branch branches

106 and . (:) ce <$> mapM branch branches

103

107

104 Data name exprs ->

108 Data name exprs ->

105− do vars <- forM exprs $ \_ -> liftIO (var Flexible)

109+ do vars <- forM exprs $ \_ -> liftIO (variable Flexible)

106− let pairs = zip exprs (map VarN vars)

110+ let pairs = zip exprs (map varN vars)

107 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

111 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

108 return $ ex vars (cs /\ name <? ctipe)

112 return $ ex vars (cs /\ name <? ctipe)

109 where

113 where

@@ -129,28 +133,28 @@ constrain env (A region expr) tipe =

129

133

130 Modify e fields ->

134 Modify e fields ->

131 exists $ \t -> do

135 exists $ \t -> do

132− oldVars <- forM fields $ \_ -> liftIO (var Flexible)

136+ oldVars <- forM fields $ \_ -> liftIO (variable Flexible)

133− let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))

137+ let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

134 cOld <- ex oldVars <$> constrain env e (record oldFields t)

138 cOld <- ex oldVars <$> constrain env e (record oldFields t)

135

139

136− newVars <- forM fields $ \_ -> liftIO (var Flexible)

140+ newVars <- forM fields $ \_ -> liftIO (variable Flexible)

137− let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))

141+ let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

138 let cNew = tipe === record newFields t

142 let cNew = tipe === record newFields t

139

143

140− cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)

144+ cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)

141

145

142 return $ cOld /\ ex newVars (and (cNew : cs))

146 return $ cOld /\ ex newVars (and (cNew : cs))

143

147

144 Record fields ->

148 Record fields ->

145− do vars <- forM fields $ \_ -> liftIO (var Flexible)

149+ do vars <- forM fields $ \_ -> liftIO (variable Flexible)

146− cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)

150+ cs <- zipWithM (constrain env) (map snd fields) (map varN vars)

147− let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))

151+ let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

148− recordType = record fields' (TermN EmptyRecord1)

152+ recordType = record fields' (termN EmptyRecord1)

149 return . ex vars . and $ tipe === recordType : cs

153 return . ex vars . and $ tipe === recordType : cs

150

154

151 Markdown _ _ es ->

155 Markdown _ _ es ->

152− do vars <- forM es $ \_ -> liftIO (var Flexible)

156+ do vars <- forM es $ \_ -> liftIO (variable Flexible)

153− let tvars = map VarN vars

157+ let tvars = map varN vars

154 cs <- zipWithM (constrain env) es tvars

158 cs <- zipWithM (constrain env) es tvars

155 return . ex vars $ and ("Text.markdown" <? tipe : cs)

159 return . ex vars $ and ("Text.markdown" <? tipe : cs)

156

160

@@ -169,16 +173,16 @@ constrain env (A region expr) tipe =

169 PortOut _ _ signal ->

173 PortOut _ _ signal ->

170 constrain env signal tipe

174 constrain env signal tipe

171

175

172−constrainDef env info (Definition pattern expr maybeTipe) =

176+constrainDef env info (Canonical.Definition pattern expr maybeTipe) =

173 let qs = [] -- should come from the def, but I'm not sure what would live there...

177 let qs = [] -- should come from the def, but I'm not sure what would live there...

174 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

178 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

175 in

179 in

176− do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.

180+ do rigidVars <- forM qs (\_ -> liftIO $ variable Rigid) -- Some mistake may be happening here.

177 -- Currently, qs is always [].

181 -- Currently, qs is always [].

178 case (pattern, maybeTipe) of

182 case (pattern, maybeTipe) of

179 (P.Var name, Just tipe) -> do

183 (P.Var name, Just tipe) -> do

180− flexiVars <- forM qs (\_ -> liftIO $ var Flexible)

184+ flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)

181− let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars

185+ let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars

182 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

186 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

183 (vars, typ) <- Env.instantiateType env tipe Map.empty

187 (vars, typ) <- Env.instantiateType env tipe Map.empty

184 let scheme = Scheme { rigidQuantifiers = [],

188 let scheme = Scheme { rigidQuantifiers = [],

@@ -194,9 +198,9 @@ constrainDef env info (Definition pattern expr maybeTipe) =

194 , fl rigidVars c /\ c1 )

198 , fl rigidVars c /\ c1 )

195

199

196 (P.Var name, Nothing) -> do

200 (P.Var name, Nothing) -> do

197− v <- liftIO $ var Flexible

201+ v <- liftIO $ variable Flexible

198− let tipe = VarN v

202+ let tipe = varN v

199− inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars

203+ inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars

200 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

204 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

201 c <- constrain env' expr tipe

205 c <- constrain env' expr tipe

202 return ( schemes

206 return ( schemes

@@ -206,18 +210,18 @@ constrainDef env info (Definition pattern expr maybeTipe) =

206 , c /\ c2

210 , c /\ c2

207 , c1 )

211 , c1 )

208

212

209− _ -> error (show pattern)

213+ _ -> error ("problem in constrainDef with " ++ show pattern)

210

214

211−expandPattern :: Def -> [Def]

215+expandPattern :: Canonical.Def -> [Canonical.Def]

212−expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =

216+expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =

213 case pattern of

217 case pattern of

214 P.Var _ -> [def]

218 P.Var _ -> [def]

215− _ -> Definition (P.Var x) lexpr maybeType : map toDef vars

219+ _ -> Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars

216 where

220 where

217 vars = P.boundVarList pattern

221 vars = P.boundVarList pattern

218 x = "$" ++ concat vars

222 x = "$" ++ concat vars

219− mkVar = A r . rawVar

223+ mkVar = A r . localVar

220− toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

224+ toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

221

225

222try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

226try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

223try region computation = do

227try region computation = do

compiler/Type/Constrain/Literal.hs+3−3

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

1{-# OPTIONS_GHC -W #-}

2module Type.Constrain.Literal where

3

4−import SourceSyntax.Annotation

4+import AST.Annotation

5−import SourceSyntax.Literal

5+import AST.Literal

6import Type.Type

7import Type.Environment as Env

8

@@ -15,7 +15,7 @@ constrain env region literal tipe =

15

16 litType =

17 case literal of

18− IntNum _ -> VarN `fmap` var (Is Number)

18+ IntNum _ -> varN `fmap` variable (Is Number)

19 FloatNum _ -> prim "Float"

20 Chr _ -> prim "Char"

21 Str _ -> prim "String"

compiler/Type/Constrain/Pattern.hs+18−15

@@ -9,20 +9,21 @@ import Control.Monad.Error

9import qualified Data.Map as Map

10import qualified Text.PrettyPrint as PP

11

12−import qualified SourceSyntax.Annotation as A

12+import qualified AST.Annotation as A

13−import qualified SourceSyntax.Pattern as P

13+import qualified AST.Pattern as P

14−import SourceSyntax.PrettyPrint (pretty)

14+import qualified AST.Variable as V

15+import AST.PrettyPrint (pretty)

15import Type.Type

16import Type.Type

16import Type.Fragment

17import Type.Fragment

17import Type.Environment as Env

18import Type.Environment as Env

18import qualified Type.Constrain.Literal as Literal

19import qualified Type.Constrain.Literal as Literal

19

20

21

21−constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment

22+constrain :: Environment -> P.CanonicalPattern -> Type

23+ -> ErrorT (A.Region -> PP.Doc) IO Fragment

22constrain env pattern tipe =

24constrain env pattern tipe =

23 let region = A.None (pretty pattern)

25 let region = A.None (pretty pattern)

24 t1 === t2 = A.A region (CEqual t1 t2)

26 t1 === t2 = A.A region (CEqual t1 t2)

25− x <? t = A.A region (CInstance x t)

26 in

27 in

27 case pattern of

28 case pattern of

28 P.Anything -> return emptyFragment

29 P.Anything -> return emptyFragment

@@ -32,23 +33,25 @@ constrain env pattern tipe =

32 return $ emptyFragment { typeConstraint = c }

33 return $ emptyFragment { typeConstraint = c }

33

34

34 P.Var name -> do

35 P.Var name -> do

35− v <- liftIO $ var Flexible

36+ v <- liftIO $ variable Flexible

36 return $ Fragment {

37 return $ Fragment {

37− typeEnv = Map.singleton name (VarN v),

38+ typeEnv = Map.singleton name (varN v),

38 vars = [v],

39 vars = [v],

39− typeConstraint = VarN v === tipe

40+ typeConstraint = varN v === tipe

40 }

41 }

41

42

42 P.Alias name p -> do

43 P.Alias name p -> do

44+ v <- liftIO $ variable Flexible

43 fragment <- constrain env p tipe

45 fragment <- constrain env p tipe

44− return $ fragment {

46+ return $ fragment

45− typeEnv = Map.insert name tipe (typeEnv fragment),

47+ { typeEnv = Map.insert name (varN v) (typeEnv fragment)

46− typeConstraint = name <? tipe /\ typeConstraint fragment

48+ , vars = v : vars fragment

49+ , typeConstraint = varN v === tipe /\ typeConstraint fragment

47 }

50 }

48

51

49 P.Data name patterns -> do

52 P.Data name patterns -> do

50− (kind, cvars, args, result) <- liftIO $ freshDataScheme env name

53+ (kind, cvars, args, result) <- liftIO $ freshDataScheme env (V.toString name)

51− let msg = concat [ "Constructor '", name, "' expects ", show kind

54+ let msg = concat [ "Constructor '", V.toString name, "' expects ", show kind

52 , " argument", if kind == 1 then "" else "s"

55 , " argument", if kind == 1 then "" else "s"

53 , " but was given ", show (length patterns), "." ]

56 , " but was given ", show (length patterns), "." ]

54 err span = PP.vcat [ PP.text $ "Type error " ++ show span

57 err span = PP.vcat [ PP.text $ "Type error " ++ show span

@@ -63,8 +66,8 @@ constrain env pattern tipe =

63 }

66 }

64

67

65 P.Record fields -> do

68 P.Record fields -> do

66− pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields

69+ pairs <- liftIO $ mapM (\name -> (,) name <$> variable Flexible) fields

67− let tenv = Map.fromList (map (second VarN) pairs)

70+ let tenv = Map.fromList (map (second varN) pairs)

68 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

71 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

69 return $ Fragment {

72 return $ Fragment {

70 typeEnv = tenv,

73 typeEnv = tenv,

compiler/Type/Environment.hs+84−86

@@ -4,7 +4,6 @@ module Type.Environment where

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

5import Control.Exception (try, SomeException)

6import Control.Monad

7−import Control.Monad.Trans.Error (ErrorList(..))

8import Control.Monad.Error (ErrorT, throwError, liftIO)

7import Control.Monad.Error (ErrorT, throwError, liftIO)

9import qualified Control.Monad.State as State

8import qualified Control.Monad.State as State

10import qualified Data.Traversable as Traverse

9import qualified Data.Traversable as Traverse

@@ -12,55 +11,59 @@ import qualified Data.Map as Map

12import Data.List (isPrefixOf)

11import Data.List (isPrefixOf)

13import qualified Text.PrettyPrint as PP

12import qualified Text.PrettyPrint as PP

14

13

15−import qualified SourceSyntax.Type as Src

14+import qualified AST.Type as T

16−import SourceSyntax.Module (ADT, Alias)

15+import qualified AST.Variable as V

16+import AST.Module (CanonicalAdt, AdtInfo)

17import Type.Type

18

19type TypeDict = Map.Map String Type

20type VarDict = Map.Map String Variable

21

22−data Environment = Environment {

22+data Environment = Environment

23− constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),

23+ { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))

24− aliases :: Map.Map String ([String], Src.Type),

24+ , types :: TypeDict

25− types :: TypeDict,

25+ , value :: TypeDict

26− value :: TypeDict

26+ }

27−}

28

27

29−initialEnvironment :: [ADT] -> [Alias] -> IO Environment

28+initialEnvironment :: [CanonicalAdt] -> IO Environment

30−initialEnvironment datatypes aliases = do

29+initialEnvironment datatypes = do

31 types <- makeTypes datatypes

30 types <- makeTypes datatypes

32− let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases

31+ let env = Environment

33− env = Environment {

32+ { constructor = Map.empty

34− constructor = Map.empty,

33+ , value = Map.empty

35− value = Map.empty,

34+ , types = types

36− types = types,

35+ }

37− aliases = aliases' }

38−

39 return $ env { constructor = makeConstructors env datatypes }

36 return $ env { constructor = makeConstructors env datatypes }

40

37

41−makeTypes :: [ADT] -> IO TypeDict

38+makeTypes :: [CanonicalAdt] -> IO TypeDict

42−makeTypes datatypes =

39+makeTypes datatypes =

43− Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

40+ do adts <- mapM makeImported datatypes

41+ bs <- mapM makeBuiltin builtins

42+ return (Map.fromList (adts ++ bs))

44 where

43 where

45− nameAndKind (name, tvars, _) = (name, length tvars)

44+ makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)

46−

45+ makeImported (var, _) = do

47− makeCtor (name, _) = do

46+ tvar <- namedVar Constant var

48− ctor <- VarN <$> namedVar Constant name

47+ return (V.toString var, varN tvar)

49− return (name, ctor)

50

48

51− tuple n = ("_Tuple" ++ show n, n)

49+ makeBuiltin :: (String, Int) -> IO (String, Type)

50+ makeBuiltin (name, _) = do

51+ name' <- namedVar Constant (V.builtin name)

52+ return (name, varN name')

52

53

53− kind n names = map (\name -> (name, n)) names

54+ builtins :: [(String, Int)]

54−

55− builtins :: [(String,Int)]

56 builtins = concat [ map tuple [0..9]

55 builtins = concat [ map tuple [0..9]

57 , kind 1 ["_List"]

56 , kind 1 ["_List"]

58 , kind 0 ["Int","Float","Char","String","Bool"]

57 , kind 0 ["Int","Float","Char","String","Bool"]

59 ]

58 ]

59+ where

60+ tuple n = ("_Tuple" ++ show n, n)

61+ kind n names = map (\name -> (name, n)) names

62+

60

63

61

64

62makeConstructors :: Environment

65makeConstructors :: Environment

63− -> [ADT]

66+ -> [CanonicalAdt]

64 -> Map.Map String (IO (Int, [Variable], [Type], Type))

67 -> Map.Map String (IO (Int, [Variable], [Type], Type))

65makeConstructors env datatypes = Map.fromList builtins

68makeConstructors env datatypes = Map.fromList builtins

66 where

69 where

@@ -68,8 +71,8 @@ makeConstructors env datatypes = Map.fromList builtins

68

71

69 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

72 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

70 inst numTVars tipe = do

73 inst numTVars tipe = do

71− vars <- forM [1..numTVars] $ \_ -> var Flexible

74+ vars <- forM [1..numTVars] $ \_ -> variable Flexible

72− let (args, result) = tipe (map VarN vars)

75+ let (args, result) = tipe (map (varN) vars)

73 return (length args, vars, args, result)

76 return (length args, vars, args, result)

74

77

75 tupleCtor n =

78 tupleCtor n =

@@ -83,88 +86,83 @@ makeConstructors env datatypes = Map.fromList builtins

83 ++ concatMap (ctorToType env) datatypes

86 ++ concatMap (ctorToType env) datatypes

84

87

85

88

86−ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

89+ctorToType :: Environment

87−ctorToType env (name, tvars, ctors) =

90+ -> (V.Canonical, AdtInfo V.Canonical)

88− zip (map fst ctors) (map inst ctors)

91+ -> [(String, IO (Int, [Variable], [Type], Type))]

92+ctorToType env (name, (tvars, ctors)) =

93+ zip (map (V.toString . fst) ctors) (map inst ctors)

89 where

94 where

90− inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

95+ inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)

91 inst ctor = do

96 inst ctor = do

92− ((args, tipe), (dict,_)) <- State.runStateT (go ctor) (Map.empty, Map.empty)

97+ ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty

93 return (length args, Map.elems dict, args, tipe)

98 return (length args, Map.elems dict, args, tipe)

94

99

95

100

96− go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)

101+ go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)

97 go (_, args) = do

102 go (_, args) = do

98 types <- mapM (instantiator env) args

103 types <- mapM (instantiator env) args

99− returnType <- instantiator env (Src.Data name (map Src.Var tvars))

104+ returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))

100 return (types, returnType)

105 return (types, returnType)

101

106

102

107

103get :: Environment -> (Environment -> Map.Map String a) -> String -> a

108get :: Environment -> (Environment -> Map.Map String a) -> String -> a

104−get env subDict key = Map.findWithDefault err key (subDict env)

109+get env subDict key = Map.findWithDefault (error msg) key (subDict env)

105 where

110 where

106− err = error $ "\nCould not find type constructor '" ++ key ++ "' while checking types."

111+ msg = "Could not find type constructor '" ++ key ++ "' while checking types."

107

112

108

113

109freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

114freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

110freshDataScheme env name = get env constructor name

115freshDataScheme env name = get env constructor name

111

116

112−instance ErrorList PP.Doc where

117+instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)

113− listMsg str = [PP.text str]

114−

115−instantiateType :: Environment -> Src.Type -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)

116instantiateType env sourceType dict =

118instantiateType env sourceType dict =

117− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) (dict, Map.empty))

119+ do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)

118− case result :: Either SomeException (Type, (VarDict, TypeDict)) of

120+ case result :: Either SomeException (Type, VarDict) of

119 Left someError -> throwError [ PP.text $ show someError ]

121 Left someError -> throwError [ PP.text $ show someError ]

120− Right (tipe, (dict',_)) -> return (Map.elems dict', tipe)

122+ Right (tipe, dict') -> return (Map.elems dict', tipe)

121

123

122−instantiator :: Environment -> Src.Type

124+instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type

123− -> State.StateT (VarDict, TypeDict) IO Type

124instantiator env sourceType = go sourceType

125instantiator env sourceType = go sourceType

125 where

126 where

126− go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type

127+ go :: T.CanonicalType -> State.StateT VarDict IO Type

127 go sourceType =

128 go sourceType =

128 case sourceType of

129 case sourceType of

129− Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2

130+ T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2

130−

131+

131− Src.Var x -> do

132+ T.Var x -> do

132− (dict, aliases) <- State.get

133+ dict <- State.get

133− case (Map.lookup x dict, Map.lookup x aliases) of

134+ case Map.lookup x dict of

134− (_, Just t) -> return t

135+ Just v -> return (varN v)

135− (Just v, _) -> return (VarN v)

136+ Nothing ->

136− _ ->

137+ do v <- State.liftIO $ namedVar flex (V.local x)

137− do var <- State.liftIO $ namedVar flex x

138+ State.put (Map.insert x v dict)

138− State.put (Map.insert x var dict, aliases)

139+ return (varN v)

139− return (VarN var)

140 where

141 flex | "number" `isPrefixOf` x = Is Number

142 | "comparable" `isPrefixOf` x = Is Comparable

143 | "appendable" `isPrefixOf` x = Is Appendable

144 | otherwise = Flexible

145

146− Src.Data name ts -> do

146+ T.Aliased name t -> do

147+ t' <- go t

148+ case t' of

149+ VarN _ v -> return (VarN (Just name) v)

150+ TermN _ term -> return (TermN (Just name) term)

151+

152+ T.Type name ->

153+ case Map.lookup (V.toString name) (types env) of

154+ Just t -> return t

155+ Nothing -> error $ "Could not find type constructor '" ++

156+ V.toString name ++ "' while checking types."

157+

158+ T.App t ts -> do

159+ t' <- go t

147 ts' <- mapM go ts

160 ts' <- mapM go ts

148− case (Map.lookup name (types env), Map.lookup name (aliases env)) of

161+ return $ foldl (<|) t' ts'

149− (Just t, _) -> return $ foldl (<|) t ts'

162+

150− (_, Just (tvars, t)) ->

163+ T.Record fields ext -> do

151− let tvarLen = length tvars

164+ fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)

152− msg = "\nType alias '" ++ name ++ "' expects " ++ show tvarLen ++

153− " type argument" ++ (if tvarLen == 1 then "" else "s") ++

154− " but was given " ++ show (length ts')

155− in if length ts' /= length tvars then error msg else

156− do (dict, aliases) <- State.get

157− let aliases' = Map.union (Map.fromList $ zip tvars ts') aliases

158− State.put (dict, aliases')

159− t' <- go t

160− State.put (dict, aliases)

161− return t'

162− _ -> error $ "\nCould not find type constructor '" ++

163− name ++ "' while checking types."

164−

165− Src.Record fields ext -> do

166− fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)

167 ext' <- case ext of

165 ext' <- case ext of

168− Nothing -> return $ TermN EmptyRecord1

166+ Nothing -> return $ termN EmptyRecord1

169− Just x -> go (Src.Var x)

167+ Just x -> go x

170− return $ TermN (Record1 fields' ext')

168+ return $ termN (Record1 fields' ext')

compiler/Type/ExtraChecks.hs+53−43

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

1−{-# OPTIONS_GHC -W #-}

1+{-# OPTIONS_GHC -Wall #-}

2

3{-| This module contains checks to be run *after* type inference has completed

4successfully. At that point we still need to do occurs checks and ensure that

@@ -7,62 +7,79 @@ successfully. At that point we still need to do occurs checks and ensure that

7module Type.ExtraChecks (mainType, occurs, portTypes) where

8

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

10+import Control.Monad.Error

10import Control.Monad.State

11import Control.Monad.State

11import qualified Data.Map as Map

12import qualified Data.Map as Map

12import qualified Data.Traversable as Traverse

13import qualified Data.Traversable as Traverse

13import qualified Data.UnionFind.IO as UF

14import qualified Data.UnionFind.IO as UF

14import Text.PrettyPrint as P

15import Text.PrettyPrint as P

15

16

16−import qualified SourceSyntax.Annotation as A

17+import qualified AST.Annotation as A

17−import qualified SourceSyntax.Expression as E

18+import qualified AST.Expression.Canonical as Canonical

18−import qualified SourceSyntax.Helpers as Help

19+import qualified AST.PrettyPrint as PP

19−import qualified SourceSyntax.PrettyPrint as SPP

20+import qualified AST.Type as ST

20−import qualified SourceSyntax.Type as ST

21+import qualified AST.Variable as V

21import qualified Transform.Expression as Expr

22import qualified Transform.Expression as Expr

22import qualified Type.Type as TT

23import qualified Type.Type as TT

23import qualified Type.State as TS

24import qualified Type.State as TS

24−import qualified Type.Alias as Alias

25

26+throw :: [Doc] -> Either [Doc] a

26throw err = Left [ P.vcat err ]

27throw err = Left [ P.vcat err ]

27

28

28−mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))

29+mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)

29−mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env

30+mainType environment =

31+ do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment

32+ mainCheck environment'

30 where

33 where

31− mainCheck :: Alias.Rules -> Map.Map String ST.Type -> Either [P.Doc] (Map.Map String ST.Type)

34+ mainCheck :: (Monad m) => Map.Map String ST.CanonicalType

32− mainCheck rules env =

35+ -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)

36+ mainCheck env =

33 case Map.lookup "main" env of

37 case Map.lookup "main" env of

34− Nothing -> Right env

38+ Nothing -> return env

35− Just mainType

39+ Just typeOfMain

36− | tipe `elem` acceptable -> Right env

40+ | tipe `elem` acceptable -> return env

37− | otherwise -> throw err

41+ | otherwise -> throwError err

38 where

42 where

39 acceptable = [ "Graphics.Element.Element"

43 acceptable = [ "Graphics.Element.Element"

40 , "Signal.Signal Graphics.Element.Element" ]

44 , "Signal.Signal Graphics.Element.Element" ]

41

45

42− tipe = SPP.renderPretty $ Alias.canonicalRealias (fst rules) mainType

46+ tipe = PP.renderPretty typeOfMain

43 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

47 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

44 , P.text "Instead 'main' has type:\n"

48 , P.text "Instead 'main' has type:\n"

45− , P.nest 4 . SPP.pretty $ Alias.realias rules mainType

49+ , P.nest 4 (PP.pretty typeOfMain)

46 , P.text " " ]

50 , P.text " " ]

47

51

48data Direction = In | Out

52data Direction = In | Out

49

53

50−portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()

54+portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()

51−portTypes rules expr =

55+portTypes expr =

52− const () <$> Expr.checkPorts (check In) (check Out) expr

56+ case Expr.checkPorts (check In) (check Out) expr of

57+ Left err -> throwError err

58+ Right _ -> return ()

53 where

59 where

54 check = isValid True False False

60 check = isValid True False False

55 isValid isTopLevel seenFunc seenSignal direction name tipe =

61 isValid isTopLevel seenFunc seenSignal direction name tipe =

56 case tipe of

62 case tipe of

57− ST.Data ctor ts

63+ ST.Aliased _ t -> valid t

58− | validConstructor -> mapM_ valid ts

64+

59− | ctor == "Signal.Signal" -> handleSignal ts

65+ ST.Type v

60− | otherwise -> err' True "an unsupported type"

66+ | V.isJson v -> return ()

61− where

67+ | V.isPrimitive v -> return ()

62− primitives =

68+ | V.isTuple v -> return ()

63− ["Int","Float","String","Bool","Maybe.Maybe","_List","Array.Array","Json.Value"]

69+ | otherwise -> err "an unsupported type"

64− validConstructor =

70+

65− ctor `elem` primitives || Help.isTuple ctor

71+ ST.App t [] -> valid t

72+

73+ ST.App (ST.Type v) [t]

74+ | V.isSignal v -> handleSignal t

75+ | V.isMaybe v -> valid t

76+ | V.isArray v -> valid t

77+ | V.isList v -> valid t

78+

79+ ST.App (ST.Type v) ts

80+ | V.isTuple v -> mapM_ valid ts

81+

82+ ST.App _ _ -> err "an unsupported type"

66

83

67 ST.Var _ -> err "free type variables"

84 ST.Var _ -> err "free type variables"

68

85

@@ -84,30 +101,24 @@ portTypes rules expr =

84 isValid' = isValid False

101 isValid' = isValid False

85 valid = isValid' seenFunc seenSignal direction name

102 valid = isValid' seenFunc seenSignal direction name

86

103

87− handleSignal ts

104+ handleSignal t

88 | seenFunc = err "functions that involve signals"

105 | seenFunc = err "functions that involve signals"

89 | seenSignal = err "signals-of-signals"

106 | seenSignal = err "signals-of-signals"

90− | isTopLevel = mapM_ (isValid' seenFunc True direction name) ts

107+ | isTopLevel = isValid' seenFunc True direction name t

91 | otherwise = err "a signal within a data stucture"

108 | otherwise = err "a signal within a data stucture"

92

109

93 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }

110 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }

94 txt = P.text . concat

111 txt = P.text . concat

95

112

96− err = err' False

113+ err kind =

97− err' couldBeAlias kind =

98 throw $

114 throw $

99 [ txt [ "Type Error: the value ", dir "coming in" "sent out"

115 [ txt [ "Type Error: the value ", dir "coming in" "sent out"

100 , " through port '", name, "' is invalid." ]

116 , " through port '", name, "' is invalid." ]

101 , txt [ "It contains ", kind, ":\n" ]

117 , txt [ "It contains ", kind, ":\n" ]

102− , (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"

118+ , P.nest 4 (PP.pretty tipe) <> P.text "\n"

103 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]

119 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]

104− , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples," ]

120+ , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]

105 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]

121 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]

106− ] ++ if couldBeAlias then aliasWarning else []

107−

108− aliasWarning =

109− [ txt [ "\nType aliases are not expanded for this check (yet) so you need to do that" ]

110− , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]

111 ]

122 ]

112

123

113occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()

124occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()

@@ -119,17 +130,16 @@ occurs (name, variable) =

119 desc <- liftIO $ UF.descriptor var

130 desc <- liftIO $ UF.descriptor var

120 case TT.structure desc of

131 case TT.structure desc of

121 Nothing ->

132 Nothing ->

122− modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

133+ modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }

123 Just _ ->

134 Just _ ->

124 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })

135 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })

125 var' <- liftIO $ UF.fresh desc

136 var' <- liftIO $ UF.fresh desc

126 TS.addError (A.None (P.text name)) (Just msg) var var'

137 TS.addError (A.None (P.text name)) (Just msg) var var'

127 where

138 where

128 msg = "Infinite types are not allowed"

139 msg = "Infinite types are not allowed"

129− fallback _ = return $ P.text msg

130

140

131 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]

141 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]

132− infiniteVars seen var =

142+ infiniteVars seen var =

133 let go = infiniteVars (var:seen) in

143 let go = infiniteVars (var:seen) in

134 if var `elem` seen

144 if var `elem` seen

135 then return [var]

145 then return [var]

compiler/Type/Fragment.hs+2−2

@@ -4,8 +4,8 @@ import qualified Data.List as List

4import qualified Data.Map as Map

5

6import Type.Type

7−import SourceSyntax.Pattern

7+import AST.Pattern

8−import SourceSyntax.Annotation (noneNoDocs)

8+import AST.Annotation (noneNoDocs)

9

10data Fragment = Fragment

11 { typeEnv :: Map.Map String Type

compiler/Type/Inference.hs+74−38

@@ -8,50 +8,86 @@ import qualified Type.Environment as Env

8import qualified Type.Constrain.Expression as TcExpr

9import qualified Type.Solve as Solve

10

11−import SourceSyntax.Module as Module

11+import qualified AST.Annotation as A

12−import SourceSyntax.Annotation (noneNoDocs)

12+import AST.Module as Module

13−import SourceSyntax.Type (Type)

13+import AST.Type (CanonicalType)

14+import qualified AST.Variable as Var

14import Text.PrettyPrint

15import Text.PrettyPrint

15import qualified Type.State as TS

16import qualified Type.State as TS

16import qualified Type.ExtraChecks as Check

17import qualified Type.ExtraChecks as Check

18+import Control.Arrow (first, second)

17import Control.Monad.State (execStateT, forM)

19import Control.Monad.State (execStateT, forM)

18−import Control.Monad.Error (runErrorT, liftIO)

20+import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)

19−import qualified Type.Alias as Alias

20

21

21import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

22import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

22 -- the IO monad. I don't think that'd be worthwhile.

23 -- the IO monad. I don't think that'd be worthwhile.

23

24

25

25−infer :: Interfaces -> MetadataModule -> Either [Doc] (Map.Map String Type)

26+infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)

26−infer interfaces modul = unsafePerformIO $ do

27+infer interfaces modul = unsafePerformIO $ runErrorT $ do

27− env <- Env.initialEnvironment

28+ (header, constraint) <- genConstraints interfaces modul

28− (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

29+

29− (aliases modul ++ concatMap iAliases (Map.elems interfaces))

30+ state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState

30− ctors <- forM (Map.keys (Env.constructor env)) $ \name ->

31+

31− do (_, vars, args, result) <- Env.freshDataScheme env name

32+ () <- case TS.sErrors state of

32− return (name, (vars, foldr (T.==>) result args))

33+ errors@(_:_) -> throwError errors

33−

34+ [] -> return ()

34− attemptConstraint <- runErrorT $ do

35+

35− importedVars <-

36+ () <- Check.portTypes (program (body modul))

36− forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->

37+

37− (,) name `fmap` Env.instantiateType env tipe Map.empty

38+ let header' = Map.delete "::" header

38−

39+ types = Map.difference (TS.sSavedEnv state) header'

39− let allTypes = ctors ++ importedVars

40+

40− vars = concatMap (fst . snd) allTypes

41+ Check.mainType types

41− header = Map.map snd (Map.fromList allTypes)

42+

42− environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]

43+

43−

44+genConstraints :: Interfaces -> CanonicalModule

44− fvar <- liftIO $ T.var T.Flexible

45+ -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)

45− c <- TcExpr.constrain env (program modul) (T.VarN fvar)

46+genConstraints interfaces modul = do

46− return (header, environ c)

47+ env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)

47−

48+

48− case attemptConstraint of

49+ ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do

49− Left err -> return $ Left err

50+ (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name

50− Right (header, constraint) -> do

51+ return (name, (vars, foldr (T.==>) result args))

51− state <- execStateT (Solve.solve constraint) TS.initialState

52+

52− let rules = Alias.rules interfaces (aliases modul) (imports modul)

53+ importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)

53− case TS.sErrors state of

54+

54− errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

55+ let allTypes = concat (ctors : importedVars)

55− [] -> case Check.portTypes rules (program modul) of

56+ vars = concatMap (fst . snd) allTypes

56− Right () -> Check.mainType rules (Map.difference (TS.sSavedEnv state) header)

57+ header = Map.map snd (Map.fromList allTypes)

57− Left err -> return (Left err)

58+ environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]

59+

60+ fvar <- liftIO $ T.variable T.Flexible

61+ c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)

62+ return (header, environ c)

63+

64+

65+canonicalizeValues :: Env.Environment -> (String, Interface)

66+ -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]

67+canonicalizeValues env (moduleName, iface) =

68+ forM (Map.toList (iTypes iface)) $ \(name,tipe) -> do

69+ tipe' <- Env.instantiateType env tipe Map.empty

70+ return (moduleName ++ "." ++ name, tipe')

71+

72+canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]

73+canonicalizeAdts interfaces modul =

74+ localAdts ++ importedAdts

75+ where

76+ localAdts :: [CanonicalAdt]

77+ localAdts = format (Module.getName modul, datatypes (body modul))

78+

79+ importedAdts :: [CanonicalAdt]

80+ importedAdts = concatMap (format . second iAdts) (Map.toList interfaces)

81+

82+ format :: (String, Module.ADTs) -> [CanonicalAdt]

83+ format (home, adts) =

84+ map canonical (Map.toList adts)

85+ where

86+ canonical :: (String, AdtInfo String) -> CanonicalAdt

87+ canonical (name, (tvars, ctors)) =

88+ ( toVar name

89+ , (tvars, map (first toVar) ctors)

90+ )

91+

92+ toVar :: String -> Var.Canonical

93+ toVar = Var.Canonical (Var.Module home)

compiler/Type/PrettyPrint.hs+3−3

@@ -2,15 +2,15 @@

2module Type.PrettyPrint where

3

4import Text.PrettyPrint

5−import qualified SourceSyntax.PrettyPrint as Src

5+import qualified AST.PrettyPrint as Src

6

7data ParensWhen = Fn | App | Never

8

9class PrettyType a where

10 pretty :: ParensWhen -> a -> Doc

11

12+commaSep :: [Doc] -> Doc

12commaSep docs = sep (punctuate comma docs)

13commaSep docs = sep (punctuate comma docs)

13

14

15+parensIf :: Bool -> Doc -> Doc

14parensIf bool doc = if bool then parens doc else doc

16parensIf bool doc = if bool then parens doc else doc

15−

16−reprime = Src.reprime

compiler/Type/Solve.hs+31−27

@@ -11,7 +11,7 @@ import Type.Type

11import Type.Unify

12import qualified Type.ExtraChecks as Check

13import qualified Type.State as TS

14−import qualified SourceSyntax.Annotation as A

14+import qualified AST.Annotation as A

15

16

17-- | Every variable has rank less than or equal to the maxRank of the pool.

@@ -21,9 +21,9 @@ generalize youngPool = do

21 youngMark <- TS.uniqueMark

22 let youngRank = TS.maxRank youngPool

23 insert dict var = do

24− desc <- liftIO $ UF.descriptor var

24+ descriptor <- liftIO $ UF.descriptor var

25 liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })

26− return $ Map.insertWith (++) (rank desc) [var] dict

26+ return $ Map.insertWith (++) (rank descriptor) [var] dict

27

28 -- Sort the youngPool variables by rank.

29 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)

@@ -32,7 +32,8 @@ generalize youngPool = do

32 -- start at low ranks so that we only have to pass

33 -- over the information once.

34 visitedMark <- TS.uniqueMark

35− mapM (\(poolRank, vars) -> mapM (adjustRank youngMark visitedMark poolRank) vars) (Map.toList rankDict)

35+ forM (Map.toList rankDict) $ \(poolRank, vars) ->

36+ mapM (adjustRank youngMark visitedMark poolRank) vars

36

37

37 -- For variables that have rank lowerer than youngRank, register them in

38 -- For variables that have rank lowerer than youngRank, register them in

38 -- the old pool if they are not redundant.

39 -- the old pool if they are not redundant.

@@ -64,35 +65,38 @@ generalize youngPool = do

64-- adjust the ranks of variables such that ranks never increase as you

65-- adjust the ranks of variables such that ranks never increase as you

65-- move deeper into a variable.

66-- move deeper into a variable.

66adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int

67adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int

67−adjustRank youngMark visitedMark groupRank variable =

68+adjustRank youngMark visitedMark groupRank var =

68− let adjust = adjustRank youngMark visitedMark groupRank in

69+ do descriptor <- liftIO $ UF.descriptor var

69− do desc <- liftIO $ UF.descriptor variable

70 case () of

71− () | mark desc == youngMark ->

71+ () | mark descriptor == youngMark ->

72 do -- Set the variable as marked first because it may be cyclic.

73− liftIO $ UF.modifyDescriptor variable $ \desc -> desc { mark = visitedMark }

73+ liftIO $ UF.modifyDescriptor var $ \desc ->

74− rank' <- case structure desc of

74+ desc { mark = visitedMark }

75− Nothing -> return groupRank

75+ rank' <- maybe (return groupRank) adjustTerm (structure descriptor)

76− Just term ->

76+ liftIO $ UF.modifyDescriptor var $ \desc ->

77− case term of

77+ desc { rank = rank' }

78− App1 a b -> max `liftM` adjust a `ap` adjust b

79− Fun1 a b -> max `liftM` adjust a `ap` adjust b

80− Var1 x -> adjust x

81− EmptyRecord1 -> return outermostRank

82− Record1 fields extension ->

83− do ranks <- mapM adjust (concat (Map.elems fields))

84− rnk <- adjust extension

85− return . maximum $ rnk : ranks

86− liftIO $ UF.modifyDescriptor variable $ \desc -> desc { rank = rank' }

87 return rank'

78 return rank'

88

79

89− | mark desc /= visitedMark ->

80+ | mark descriptor /= visitedMark ->

90− do let rank' = min groupRank (rank desc)

81+ do let rank' = min groupRank (rank descriptor)

91− liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })

82+ liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' })

92 return rank'

83 return rank'

93

84

94− | otherwise -> return (rank desc)

85+ | otherwise -> return (rank descriptor)

86+

87+ where

88+ adjust = adjustRank youngMark visitedMark groupRank

95

89

90+ adjustTerm term =

91+ case term of

92+ App1 a b -> max `liftM` adjust a `ap` adjust b

93+ Fun1 a b -> max `liftM` adjust a `ap` adjust b

94+ Var1 x -> adjust x

95+ EmptyRecord1 -> return outermostRank

96+ Record1 fields extension ->

97+ do ranks <- mapM adjust (concat (Map.elems fields))

98+ rnk <- adjust extension

99+ return . maximum $ rnk : ranks

96

100

97

101

98solve :: TypeConstraint -> StateT TS.SolverState IO ()

102solve :: TypeConstraint -> StateT TS.SolverState IO ()

@@ -129,7 +133,7 @@ solve (A.A region constraint) =

129 case Map.lookup name env of

133 case Map.lookup name env of

130 Just tipe -> TS.makeInstance tipe

134 Just tipe -> TS.makeInstance tipe

131 Nothing

135 Nothing

132− | List.isPrefixOf "Native." name -> liftIO (var Flexible)

136+ | List.isPrefixOf "Native." name -> liftIO (variable Flexible)

133 | otherwise ->

137 | otherwise ->

134 error ("Could not find '" ++ name ++ "' when solving type constraints.")

138 error ("Could not find '" ++ name ++ "' when solving type constraints.")

135

139

compiler/Type/State.hs+40−35

@@ -1,16 +1,15 @@

1{-# OPTIONS_GHC -W #-}

2module Type.State where

3

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

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

5import Control.Monad.State

6import qualified Data.Map as Map

7import qualified Data.Traversable as Traversable

8import qualified Data.UnionFind.IO as UF

9

10−import qualified SourceSyntax.Annotation as A

10+import qualified AST.Annotation as A

11−import SourceSyntax.PrettyPrint

11+import AST.PrettyPrint

12import Text.PrettyPrint as P

13−import qualified Type.Alias as Alias

14import Type.Type

13import Type.Type

15

14

16-- Pool

15-- Pool

@@ -18,10 +17,10 @@ import Type.Type

18-- The rank of each variable is less than or equal to the pool's "maxRank"

17-- The rank of each variable is less than or equal to the pool's "maxRank"

19-- The young pool exists to make it possible to identify these vars in constant time.

18-- The young pool exists to make it possible to identify these vars in constant time.

20

19

21−data Pool = Pool {

20+data Pool = Pool

22− maxRank :: Int,

21+ { maxRank :: Int

23− inhabitants :: [Variable]

22+ , inhabitants :: [Variable]

24−} deriving Show

23+ } deriving Show

25

24

26emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }

25emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }

27

26

@@ -33,7 +32,7 @@ data SolverState = SS {

33 sSavedEnv :: Env,

32 sSavedEnv :: Env,

34 sPool :: Pool,

33 sPool :: Pool,

35 sMark :: Int,

34 sMark :: Int,

36− sErrors :: [Alias.Rules -> IO P.Doc]

35+ sErrors :: [P.Doc]

37}

36}

38

37

39initialState = SS {

38initialState = SS {

@@ -47,13 +46,15 @@ initialState = SS {

47modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }

46modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }

48modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

47modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

49

48

49+addError :: A.Region -> Maybe String -> UF.Point Descriptor -> UF.Point Descriptor

50+ -> StateT SolverState IO ()

50addError region hint t1 t2 =

51addError region hint t1 t2 =

51− modify $ \state -> state { sErrors = makeError : sErrors state }

52+ do err <- liftIO makeError

53+ modify $ \state -> state { sErrors = err : sErrors state }

52 where

54 where

53− makeError rules = do

55+ makeError = do

54− let prettiest = pretty . Alias.realias rules

56+ t1' <- pretty <$> toSrcType t1

55− t1' <- prettiest <$> toSrcType t1

57+ t2' <- pretty <$> toSrcType t2

56− t2' <- prettiest <$> toSrcType t2

57 return . P.vcat $

58 return . P.vcat $

58 [ P.text "Type error" <+> pretty region <> P.colon

59 [ P.text "Type error" <+> pretty region <> P.colon

59 , maybe P.empty P.text hint

60 , maybe P.empty P.text hint

@@ -103,17 +104,20 @@ introduce variable = do

103flatten :: Type -> StateT SolverState IO Variable

104flatten :: Type -> StateT SolverState IO Variable

104flatten term =

105flatten term =

105 case term of

106 case term of

106− VarN v -> return v

107+ VarN maybeAlias v -> do

107− TermN t -> do

108+ liftIO $ UF.modifyDescriptor v $ \desc -> desc { alias = maybeAlias <|> alias desc }

109+ return v

110+ TermN maybeAlias t -> do

108 flatStructure <- traverseTerm flatten t

111 flatStructure <- traverseTerm flatten t

109 pool <- getPool

112 pool <- getPool

110− var <- liftIO . UF.fresh $ Descriptor {

113+ var <- liftIO . UF.fresh $ Descriptor

111− structure = Just flatStructure,

114+ { structure = Just flatStructure

112− rank = maxRank pool,

115+ , rank = maxRank pool

113− flex = Flexible,

116+ , flex = Flexible

114− name = Nothing,

117+ , name = Nothing

115− copy = Nothing,

118+ , copy = Nothing

116− mark = noMark

119+ , mark = noMark

120+ , alias = maybeAlias

117 }

121 }

118 register var

122 register var

119

123

@@ -139,18 +143,19 @@ makeCopy alreadyCopied variable = do

139

143

140 | otherwise -> do

144 | otherwise -> do

141 pool <- getPool

145 pool <- getPool

142− newVar <- liftIO $ UF.fresh $ Descriptor {

146+ newVar <- liftIO $ UF.fresh $ Descriptor

143− structure = Nothing,

147+ { structure = Nothing

144− rank = maxRank pool,

148+ , rank = maxRank pool

145− mark = noMark,

149+ , mark = noMark

146− flex = case flex desc of

150+ , flex = case flex desc of

147− Is s -> Is s

151+ Is s -> Is s

148− _ -> Flexible,

152+ _ -> Flexible

149− copy = Nothing,

153+ , copy = Nothing

150− name = case flex desc of

154+ , name = case flex desc of

151− Rigid -> Nothing

155+ Rigid -> Nothing

152− _ -> name desc

156+ _ -> name desc

153− }

157+ , alias = Nothing

158+ }

154 register newVar

159 register newVar

155

160

156 -- Link the original variable to the new variable. This lets us

161 -- Link the original variable to the new variable. This lets us

compiler/Type/Type.hs+142−106

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

1+{-# OPTIONS_GHC -W #-}

1module Type.Type where

2module Type.Type where

2

3

3import qualified Data.Char as Char

4import qualified Data.Char as Char

@@ -8,12 +9,13 @@ import Type.PrettyPrint

8import Text.PrettyPrint as P

9import Text.PrettyPrint as P

9import System.IO.Unsafe

10import System.IO.Unsafe

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

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

11−import Control.Monad.State

12+import Control.Monad.State (StateT, get, put, execStateT, runStateT)

12−import Control.Monad.Error

13+import Control.Monad.Error (ErrorT, Error, liftIO)

13import Data.Traversable (traverse)

14import Data.Traversable (traverse)

14−import SourceSyntax.Annotation

15+import AST.Annotation

15−import SourceSyntax.Helpers (isTuple)

16+import qualified AST.PrettyPrint as PP

16−import qualified SourceSyntax.Type as Src

17+import qualified AST.Type as T

18+import qualified AST.Variable as Var

17

19

18data Term1 a

20data Term1 a

19 = App1 a a

21 = App1 a a

@@ -24,18 +26,24 @@ data Term1 a

24 deriving Show

26 deriving Show

25

27

26data TermN a

28data TermN a

27− = VarN a

29+ = VarN (Maybe Var.Canonical) a

28− | TermN (Term1 (TermN a))

30+ | TermN (Maybe Var.Canonical) (Term1 (TermN a))

29 deriving Show

31 deriving Show

30

32

33+varN :: a -> TermN a

34+varN = VarN Nothing

35+

36+termN :: (Term1 (TermN a)) -> TermN a

37+termN = TermN Nothing

38+

31record :: Map.Map String [TermN a] -> TermN a -> TermN a

39record :: Map.Map String [TermN a] -> TermN a -> TermN a

32−record fs rec = TermN (Record1 fs rec)

40+record fs rec = termN (Record1 fs rec)

33

41

34type Type = TermN Variable

42type Type = TermN Variable

35type Variable = UF.Point Descriptor

43type Variable = UF.Point Descriptor

36

44

37type SchemeName = String

45type SchemeName = String

38−type TypeName = String

46+type TypeName = Var.Canonical

39

47

40type Constraint a b = Located (BasicConstraint a b)

48type Constraint a b = Located (BasicConstraint a b)

41data BasicConstraint a b

49data BasicConstraint a b

@@ -57,6 +65,7 @@ data Scheme a b = Scheme {

57type TypeConstraint = Constraint Type Variable

65type TypeConstraint = Constraint Type Variable

58type TypeScheme = Scheme Type Variable

66type TypeScheme = Scheme Type Variable

59

67

68+monoscheme :: Map.Map String a -> Scheme a b

60monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

69monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

61

70

62infixl 8 /\

71infixl 8 /\

@@ -70,23 +79,31 @@ a@(A _ c1) /\ b@(A _ c2) =

70

79

71infixr 9 ==>

80infixr 9 ==>

72(==>) :: Type -> Type -> Type

81(==>) :: Type -> Type -> Type

73−a ==> b = TermN (Fun1 a b)

82+a ==> b = termN (Fun1 a b)

74−

83+

75−f <| a = TermN (App1 f a)

84+(<|) :: TermN a -> TermN a -> TermN a

76−

85+f <| a = termN (App1 f a)

77−data Descriptor = Descriptor {

86+

78− structure :: Maybe (Term1 Variable),

87+data Descriptor = Descriptor

79− rank :: Int,

88+ { structure :: Maybe (Term1 Variable)

80− flex :: Flex,

89+ , rank :: Int

81− name :: Maybe TypeName,

90+ , flex :: Flex

82− copy :: Maybe Variable,

91+ , name :: Maybe TypeName

83− mark :: Int

92+ , copy :: Maybe Variable

84−} deriving Show

93+ , mark :: Int

85−

94+ , alias :: Maybe Var.Canonical

95+ } deriving Show

96+

97+noRank :: Int

86noRank = -1

98noRank = -1

87−outermostRank = 0 :: Int

88

99

100+outermostRank :: Int

101+outermostRank = 0

102+

103+noMark :: Int

89noMark = 0

104noMark = 0

105+

106+initialMark :: Int

90initialMark = 1

107initialMark = 1

91

108

92data Flex = Rigid | Flexible | Constant | Is SuperType

109data Flex = Rigid | Flexible | Constant | Is SuperType

@@ -95,34 +112,26 @@ data Flex = Rigid | Flexible | Constant | Is SuperType

95data SuperType = Number | Comparable | Appendable

112data SuperType = Number | Comparable | Appendable

96 deriving (Show, Eq)

113 deriving (Show, Eq)

97

114

98−namedVar :: Flex -> String -> IO Variable

115+namedVar :: Flex -> Var.Canonical -> IO Variable

99−namedVar flex name = UF.fresh $ Descriptor {

116+namedVar flex name = UF.fresh $ Descriptor

100− structure = Nothing,

117+ { structure = Nothing

101− rank = noRank,

118+ , rank = noRank

102− flex = flex,

119+ , flex = flex

103− name = Just name,

120+ , name = Just name

104− copy = Nothing,

121+ , copy = Nothing

105− mark = noMark

122+ , mark = noMark

123+ , alias = Nothing

106 }

124 }

107

125

108−var :: Flex -> IO Variable

126+variable :: Flex -> IO Variable

109−var flex = UF.fresh $ Descriptor {

127+variable flex = UF.fresh $ Descriptor

110− structure = Nothing,

128+ { structure = Nothing

111− rank = noRank,

129+ , rank = noRank

112− flex = flex,

130+ , flex = flex

113− name = Nothing,

131+ , name = Nothing

114− copy = Nothing,

132+ , copy = Nothing

115− mark = noMark

133+ , mark = noMark

116− }

134+ , alias = Nothing

117−

118−structuredVar :: Term1 Variable -> IO Variable

119−structuredVar structure = UF.fresh $ Descriptor {

120− structure = Just structure,

121− rank = noRank,

122− flex = Flexible,

123− name = Nothing,

124− copy = Nothing,

125− mark = noMark

126 }

135 }

127

136

128

137

@@ -138,13 +147,13 @@ fl rqs constraint@(A ann _) =

138

147

139exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

148exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

140exists f = do

149exists f = do

141− v <- liftIO $ var Flexible

150+ v <- liftIO $ variable Flexible

142− ex [v] <$> f (VarN v)

151+ ex [v] <$> f (varN v)

143

152

144existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

153existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

145existsNumber f = do

154existsNumber f = do

146− v <- liftIO $ var (Is Number)

155+ v <- liftIO $ variable (Is Number)

147− ex [v] <$> f (VarN v)

156+ ex [v] <$> f (varN v)

148

157

149

158

150instance Show a => Show (UF.Point a) where

159instance Show a => Show (UF.Point a) where

@@ -187,23 +196,32 @@ instance PrettyType a => PrettyType (Term1 a) where

187 prettyExt = prty ext

196 prettyExt = prty ext

188 extend | P.render prettyExt == "{}" = P.empty

197 extend | P.render prettyExt == "{}" = P.empty

189 | otherwise = prettyExt <+> P.text "|"

198 | otherwise = prettyExt <+> P.text "|"

190− mkPretty f t = P.text (reprime f) <+> P.text ":" <+> prty t

199+ mkPretty f t = P.text f <+> P.text ":" <+> prty t

191 prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)

200 prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)

192

201

193

202

194instance PrettyType a => PrettyType (TermN a) where

203instance PrettyType a => PrettyType (TermN a) where

195 pretty when term =

204 pretty when term =

196 case term of

205 case term of

197− VarN x -> pretty when x

206+ VarN alias x -> either alias (pretty when x)

198− TermN t1 -> pretty when t1

207+ TermN alias t1 -> either alias (pretty when t1)

199−

208+ where

209+ either maybeAlias doc =

210+ case maybeAlias of

211+ Just alias -> PP.pretty alias

212+ Nothing -> doc

200

213

201instance PrettyType Descriptor where

214instance PrettyType Descriptor where

202− pretty when desc =

215+ pretty when desc = do

203− case (structure desc, name desc) of

216+ case (alias desc, structure desc, name desc) of

204− (Just term, _) -> pretty when term

217+ (Just name, _, _) -> PP.pretty name

205− (_, Just name) -> if not (isTuple name) then P.text (reprime name) else

218+ (_, Just term, _) -> pretty when term

206− P.parens . P.text $ replicate (read (drop 6 name) - 1) ','

219+ (_, _, Just name)

220+ | Var.isTuple name ->

221+ P.parens . P.text $ replicate (read (drop 6 (Var.toString name)) - 1) ','

222+ | otherwise ->

223+ P.text (Var.toString name)

224+

207 _ -> P.text "?"

225 _ -> P.text "?"

208

226

209

227

@@ -269,7 +287,7 @@ addNames value = do

269 (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)

287 (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)

270 let vars = map head . List.group $ List.sort rawVars

288 let vars = map head . List.group $ List.sort rawVars

271 suffix s = map (++s) (map (:[]) ['a'..'z'])

289 suffix s = map (++s) (map (:[]) ['a'..'z'])

272− allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]

290+ allVars = concatMap suffix $ ["","'","_"] ++ map show [ (0 :: Int) .. ]

273 okayVars = filter (`notElem` vars) allVars

291 okayVars = filter (`notElem` vars) allVars

274 runStateT (crawl rename value) (okayVars, 0, 0, 0)

292 runStateT (crawl rename value) (okayVars, 0, 0, 0)

275 return value

293 return value

@@ -277,23 +295,20 @@ addNames value = do

277 getNames desc state@(vars, a, b, c) =

295 getNames desc state@(vars, a, b, c) =

278 let name' = name desc in

296 let name' = name desc in

279 case name' of

297 case name' of

280− Just var -> (name', (var:vars, a, b, c))

298+ Just (Var.Canonical _ var) -> (name', (var:vars, a, b, c))

281− Nothing -> (name', state)

299+ _ -> (name', state)

282

300

283 rename desc state@(vars, a, b, c) =

301 rename desc state@(vars, a, b, c) =

284 case name desc of

302 case name desc of

285 Just var -> (Just var, state)

303 Just var -> (Just var, state)

286 Nothing ->

304 Nothing ->

287 case flex desc of

305 case flex desc of

288− Is Number -> (Just $ "number" ++ replicate a '\'', (vars, a+1, b, c))

306+ Is Number -> (local $ "number" ++ replicate a '\'', (vars, a+1, b, c))

289− Is Comparable -> (Just $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

307+ Is Comparable -> (local $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

290− Is Appendable -> (Just $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

308+ Is Appendable -> (local $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

291− other -> (Just $ head vars, (tail vars, a, b, c))

309+ _ -> (local $ head vars, (tail vars, a, b, c))

292− where mark = case other of

310+ where

293− Flexible -> ""

311+ local v = Just (Var.local v)

294− Rigid -> "!"

295− Constant -> "#"

296−

297

312

298type CrawlState = ([String], Int, Int, Int)

313type CrawlState = ([String], Int, Int, Int)

299

314

@@ -329,8 +344,8 @@ instance (Crawl t, Crawl v) => Crawl (Scheme t v) where

329instance Crawl t => Crawl (TermN t) where

344instance Crawl t => Crawl (TermN t) where

330 crawl nextState tipe =

345 crawl nextState tipe =

331 case tipe of

346 case tipe of

332− VarN x -> VarN <$> crawl nextState x

347+ VarN a x -> VarN a <$> crawl nextState x

333− TermN term -> TermN <$> crawl nextState term

348+ TermN a term -> TermN a <$> crawl nextState term

334

349

335instance Crawl t => Crawl (Term1 t) where

350instance Crawl t => Crawl (Term1 t) where

336 crawl nextState term =

351 crawl nextState term =

@@ -359,50 +374,71 @@ instance Crawl Descriptor where

359 return $ desc { name = name', structure = structure' }

374 return $ desc { name = name', structure = structure' }

360

375

361

376

362−toSrcType :: Variable -> IO Src.Type

377+toSrcType :: Variable -> IO T.CanonicalType

363−toSrcType variable = do

378+toSrcType var =

364− desc <- UF.descriptor =<< addNames variable

379+ go =<< addNames var

365− case structure desc of

380+ where

366− Just term ->

381+ go v = do

382+ desc <- UF.descriptor v

383+ srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)

384+ return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc)

385+

386+ backupSrcType desc =

387+ case name desc of

388+ Just v@(Var.Canonical _ x@(c:_))

389+ | Char.isLower c -> return (T.Var x)

390+ | otherwise -> return $ T.Type v

391+

392+ _ -> error $ concat

393+ [ "Problem converting the following type "

394+ , "from a type-checker type to a source-syntax type:"

395+ , P.render (pretty Never var) ]

396+

397+ termToSrcType term =

367 case term of

398 case term of

368 App1 a b -> do

399 App1 a b -> do

369− Src.Data name ts <- toSrcType a

400+ a' <- go a

370− b' <- toSrcType b

401+ b' <- go b

371− return (Src.Data name (ts ++ [b']))

402+ case a' of

372− Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b

403+ T.App f args -> return $ T.App f (args ++ [b'])

373− Var1 a -> toSrcType a

404+ _ -> return $ T.App a' [b']

374− EmptyRecord1 -> return $ Src.Record [] Nothing

405+

406+ Fun1 a b -> T.Lambda <$> go a <*> go b

407+

408+ Var1 a -> go a

409+

410+ EmptyRecord1 -> return $ T.Record [] Nothing

411+

375 Record1 tfields extension -> do

412 Record1 tfields extension -> do

376− fields' <- traverse (mapM toSrcType) tfields

413+ fields' <- traverse (mapM go) tfields

377 let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

414 let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

378− ext' <- toSrcType extension

415+ ext' <- dealias <$> go extension

379 return $ case ext' of

416 return $ case ext' of

380− Src.Record fs ext -> Src.Record (fs ++ fields) ext

417+ T.Record fs ext -> T.Record (fs ++ fields) ext

381− Src.Var x -> Src.Record fields (Just x)

418+ T.Var _ -> T.Record fields (Just ext')

382 _ -> error "Used toSrcType on a type that is not well-formed"

419 _ -> error "Used toSrcType on a type that is not well-formed"

383− Nothing ->

420+

384− case name desc of

421+ dealias :: T.CanonicalType -> T.CanonicalType

385− Just x@(c:_) | Char.isLower c -> return (Src.Var x)

422+ dealias t =

386− | otherwise -> return (Src.Data x [])

423+ case t of

387− _ -> error $ concat

424+ T.Aliased _ t' -> t'

388− [ "Problem converting the following type "

425+ _ -> t

389− , "from a type-checker type to a source-syntax type:"

426+

390− , P.render (pretty Never variable) ]

391

427

392data AppStructure = List Variable | Tuple [Variable] | Other

428data AppStructure = List Variable | Tuple [Variable] | Other

393

429

394collectApps :: Variable -> IO AppStructure

430collectApps :: Variable -> IO AppStructure

395−collectApps variable = go [] variable

431+collectApps var = go [] var

396 where

432 where

397− go vars variable = do

433+ go vars var = do

398− desc <- UF.descriptor variable

434+ desc <- UF.descriptor var

399 case (structure desc, vars) of

435 case (structure desc, vars) of

400 (Nothing, [v]) -> case name desc of

436 (Nothing, [v]) -> case name desc of

401− Just "_List" -> return (List v)

437+ Just n | Var.isList n -> return (List v)

402− _ -> return Other

438+ _ -> return Other

403 (Nothing, vs) -> case name desc of

439 (Nothing, vs) -> case name desc of

404− Just ctor | isTuple ctor -> return (Tuple vs)

440+ Just n | Var.isTuple n -> return (Tuple vs)

405− _ -> return Other

441+ _ -> return Other

406 (Just term, _) -> case term of

442 (Just term, _) -> case term of

407 App1 a b -> go (vars ++ [b]) a

443 App1 a b -> go (vars ++ [b]) a

408 _ -> return Other

444 _ -> return Other

compiler/Type/Unify.hs+81−52

@@ -1,11 +1,14 @@

1{-# OPTIONS_GHC -W #-}

2module Type.Unify (unify) where

3

4+import Control.Applicative ((<|>))

4import Control.Monad.State

5import Control.Monad.State

6+import qualified Data.List as List

5import qualified Data.Map as Map

7import qualified Data.Map as Map

6import qualified Data.Maybe as Maybe

8import qualified Data.Maybe as Maybe

7import qualified Data.UnionFind.IO as UF

9import qualified Data.UnionFind.IO as UF

8−import qualified SourceSyntax.Annotation as A

10+import qualified AST.Annotation as A

11+import qualified AST.Variable as Var

9import qualified Type.State as TS

12import qualified Type.State as TS

10import Type.Type

13import Type.Type

11import Type.PrettyPrint

14import Type.PrettyPrint

@@ -23,64 +26,55 @@ actuallyUnify region variable1 variable2 = do

23 desc2 <- liftIO $ UF.descriptor variable2

26 desc2 <- liftIO $ UF.descriptor variable2

24 let unify' = unify region

27 let unify' = unify region

25

28

26− name' :: Maybe String

29+ (name', flex', rank', alias') = combinedDescriptors desc1 desc2

27− name' = case (name desc1, name desc2) of

28− (Just name1, Just name2) ->

29− case (flex desc1, flex desc2) of

30− (_, Flexible) -> Just name1

31− (Flexible, _) -> Just name2

32− (Is Number, Is _) -> Just name1

33− (Is _, Is Number) -> Just name2

34− (Is _, Is _) -> Just name1

35− (_, _) -> Nothing

36− (Just name1, _) -> Just name1

37− (_, Just name2) -> Just name2

38− _ -> Nothing

39−

40− flex' :: Flex

41− flex' = case (flex desc1, flex desc2) of

42− (f, Flexible) -> f

43− (Flexible, f) -> f

44− (Is Number, Is _) -> Is Number

45− (Is _, Is Number) -> Is Number

46− (Is super, Is _) -> Is super

47− (_, _) -> Flexible

48−

49− rank' :: Int

50− rank' = min (rank desc1) (rank desc2)

51

30

52 merge1 :: StateT TS.SolverState IO ()

31 merge1 :: StateT TS.SolverState IO ()

53 merge1 = liftIO $ do

32 merge1 = liftIO $ do

54 if rank desc1 < rank desc2 then UF.union variable2 variable1

33 if rank desc1 < rank desc2 then UF.union variable2 variable1

55 else UF.union variable1 variable2

34 else UF.union variable1 variable2

56 UF.modifyDescriptor variable1 $ \desc ->

35 UF.modifyDescriptor variable1 $ \desc ->

57− desc { structure = structure desc1, flex = flex', name = name' }

36+ desc { structure = structure desc1

37+ , flex = flex'

38+ , name = name'

39+ , alias = alias'

40+ }

58

41

59 merge2 :: StateT TS.SolverState IO ()

42 merge2 :: StateT TS.SolverState IO ()

60 merge2 = liftIO $ do

43 merge2 = liftIO $ do

61 if rank desc1 < rank desc2 then UF.union variable2 variable1

44 if rank desc1 < rank desc2 then UF.union variable2 variable1

62 else UF.union variable1 variable2

45 else UF.union variable1 variable2

63 UF.modifyDescriptor variable2 $ \desc ->

46 UF.modifyDescriptor variable2 $ \desc ->

64− desc { structure = structure desc2, flex = flex', name = name' }

47+ desc { structure = structure desc2

48+ , flex = flex'

49+ , name = name'

50+ , alias = alias'

51+ }

65

52

66 merge = if rank desc1 < rank desc2 then merge1 else merge2

53 merge = if rank desc1 < rank desc2 then merge1 else merge2

67

54

68 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable

55 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable

69 fresh structure = do

56 fresh structure = do

70− var <- liftIO . UF.fresh $ Descriptor {

57+ v <- liftIO . UF.fresh $ Descriptor

71− structure = structure, rank = rank', flex = flex',

58+ { structure = structure

72− name = name', copy = Nothing, mark = noMark

59+ , rank = rank'

73− }

60+ , flex = flex'

74− TS.register var

61+ , name = name'

75−

62+ , copy = Nothing

76− flexAndUnify var = do

63+ , mark = noMark

77− liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }

64+ , alias = alias'

65+ }

66+ TS.register v

67+

68+ flexAndUnify v = do

69+ liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }

78 unify' variable1 variable2

70 unify' variable1 variable2

79

71

80− unifyNumber svar name

72+ unifyNumber svar (Var.Canonical home name) =

81− | name `elem` ["Int","Float","number"] = flexAndUnify svar

73+ case home of

82− | otherwise = TS.addError region (Just hint) variable1 variable2

74+ Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar

83− where hint = "A number must be an Int or Float."

75+ Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar

76+ _ -> let hint = "A number must be an Int or Float."

77+ in TS.addError region (Just hint) variable1 variable2

84

78

85 comparableError maybe =

79 comparableError maybe =

86 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

80 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

@@ -90,22 +84,24 @@ actuallyUnify region variable1 variable2 = do

90 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

84 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

91 where msg = "An appendable must be of type String, List, or Text."

85 where msg = "An appendable must be of type String, List, or Text."

92

86

93− unifyComparable var name

87+ unifyComparable v (Var.Canonical home name) =

94− | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var

88+ case home of

95− | otherwise = comparableError Nothing

89+ Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v

90+ Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v

91+ _ -> comparableError Nothing

96

92

97 unifyComparableStructure varSuper varFlex =

93 unifyComparableStructure varSuper varFlex =

98 do struct <- liftIO $ collectApps varFlex

94 do struct <- liftIO $ collectApps varFlex

99 case struct of

95 case struct of

100 Other -> comparableError Nothing

96 Other -> comparableError Nothing

101 List v -> do flexAndUnify varSuper

97 List v -> do flexAndUnify varSuper

102− unify' v =<< liftIO (var $ Is Comparable)

98+ unify' v =<< liftIO (variable $ Is Comparable)

103 Tuple vs

99 Tuple vs

104 | length vs > 6 ->

100 | length vs > 6 ->

105 comparableError $ Just "Cannot compare a tuple with more than 6 elements."

101 comparableError $ Just "Cannot compare a tuple with more than 6 elements."

106 | otherwise ->

102 | otherwise ->

107 do flexAndUnify varSuper

103 do flexAndUnify varSuper

108− cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)

104+ cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

109 zipWithM_ unify' vs cmpVars

105 zipWithM_ unify' vs cmpVars

110

106

111 unifyAppendable varSuper varFlex =

107 unifyAppendable varSuper varFlex =

@@ -114,10 +110,10 @@ actuallyUnify region variable1 variable2 = do

114 List _ -> flexAndUnify varSuper

110 List _ -> flexAndUnify varSuper

115 _ -> appendableError Nothing

111 _ -> appendableError Nothing

116

112

117− rigidError variable = TS.addError region (Just hint) variable1 variable2

113+ rigidError var = TS.addError region (Just hint) variable1 variable2

118 where

114 where

119− var = "'" ++ render (pretty Never variable) ++ "'"

115+ var' = "'" ++ render (pretty Never var) ++ "'"

120− hint = "Cannot unify rigid type variable " ++ var ++

116+ hint = "Cannot unify rigid type variable " ++ var' ++

121 ".\nThe problem probably relates to a type annotation. Note that rigid type\n\

117 ".\nThe problem probably relates to a type annotation. Note that rigid type\n\

122 \variables are not shared between a top-level and let-bound type annotations."

118 \variables are not shared between a top-level and let-bound type annotations."

123

119

@@ -136,10 +132,10 @@ actuallyUnify region variable1 variable2 = do

136 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2

132 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2

137 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1

133 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1

138

134

139− (Is Appendable, _, _, Just ctor)

135+ (Is Appendable, _, _, Just name)

140− | ctor `elem` ["Text.Text","String"] -> flexAndUnify variable1

136+ | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1

141− (_, Is Appendable, Just ctor, _)

137+ (_, Is Appendable, Just name, _)

142− | ctor `elem` ["Text.Text","String"] -> flexAndUnify variable2

138+ | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2

143 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2

139 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2

144 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1

140 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1

145

141

@@ -202,3 +198,36 @@ actuallyUnify region variable1 variable2 = do

202

198

203 _ -> TS.addError region Nothing variable1 variable2

199 _ -> TS.addError region Nothing variable1 variable2

204

200

201+combinedDescriptors :: Descriptor -> Descriptor

202+ -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)

203+combinedDescriptors desc1 desc2 =

204+ (name', flex', rank', alias')

205+ where

206+ rank' :: Int

207+ rank' = min (rank desc1) (rank desc2)

208+

209+ alias' :: Maybe Var.Canonical

210+ alias' = alias desc1 <|> alias desc2

211+

212+ name' :: Maybe Var.Canonical

213+ name' = case (name desc1, name desc2) of

214+ (Just name1, Just name2) ->

215+ case (flex desc1, flex desc2) of

216+ (_, Flexible) -> Just name1

217+ (Flexible, _) -> Just name2

218+ (Is Number, Is _) -> Just name1

219+ (Is _, Is Number) -> Just name2

220+ (Is _, Is _) -> Just name1

221+ (_, _) -> Nothing

222+ (Just name1, _) -> Just name1

223+ (_, Just name2) -> Just name2

224+ _ -> Nothing

225+

226+ flex' :: Flex

227+ flex' = case (flex desc1, flex desc2) of

228+ (f, Flexible) -> f

229+ (Flexible, f) -> f

230+ (Is Number, Is _) -> Is Number

231+ (Is _, Is Number) -> Is Number

232+ (Is super, Is _) -> Is super

233+ (_, _) -> Flexible

libraries/Basics.elm+61−23

@@ -22,7 +22,7 @@ are your tuples so big?

22@docs not, (&&), (||), xor, otherwise

23

24# Mathematics

25−@docs (+), (-), (*), (/), (^), div, rem, mod, abs, sqrt, clamp, logBase, e

25+@docs (+), (-), (*), (/), (^), (//), rem, (%), negate, abs, sqrt, clamp, logBase, e

26

27# Trigonometry

28@docs pi, cos, sin, tan, acos, asin, atan, atan2

@@ -46,7 +46,7 @@ which happen to be radians.

46@docs fst, snd

47

48# Higher-Order Helpers

49−@docs id, (<|), (|>), (.), always, flip, curry, uncurry

49+@docs identity, always, (<|), (|>), (<<), (>>), flip, curry, uncurry

50

51-}

52

@@ -58,25 +58,25 @@ radians t = t

58

59{-| Convert degrees to standard Elm angles (radians). -}

60degrees : Float -> Float

61−degrees d = d * Native.Basics.pi / 180

61+degrees = Native.Basics.degrees

62

63{-| Convert turns to standard Elm angles (radians).

64One turn is equal to 360°.

65-}

66turns : Float -> Float

67−turns r = 2 * Native.Basics.pi * r

67+turns = Native.Basics.turns

68

69{-| Start with polar coordinates (r,θ)

70and get out cartesian coordinates (x,y).

71-}

72fromPolar : (Float,Float) -> (Float,Float)

73−fromPolar (r,t) = (r * Native.Basics.cos t, r * Native.Basics.sin t)

73+fromPolar = Native.Basics.fromPolar

74

75{-| Start with cartesian coordinates (x,y)

76and get out polar coordinates (r,θ).

77-}

78toPolar : (Float,Float) -> (Float,Float)

79−toPolar (x,y) = (Native.Basics.sqrt (x^2 + y^2), Native.Basics.atan2 y x)

79+toPolar = Native.Basics.toPolar

80

81(+) : number -> number -> number

82(+) = Native.Basics.add

@@ -97,21 +97,29 @@ infixl 7 *

97infixl 7 /

98infixl 8 ^

99

100−infixl 7 `div`

100+infixl 7 //

101−infixl 7 `mod`

101+infixl 7 %

102infixl 7 `rem`

103

104{-| Integer division, remainder is discarded. -}

105−div : Int -> Int -> Int

105+(//) : Int -> Int -> Int

106−div = Native.Basics.div

106+(//) = Native.Basics.div

107

108−{-| Finds the remainder after dividing one number by another: ``4 `rem` 3 == 1`` -}

108+{-| Finds the remainder after dividing one number by another:

109+

110+ 7 `rem` 2 == 1

111+ -1 `rem` 4 == 1

112+-}

109rem : Int -> Int -> Int

113rem : Int -> Int -> Int

110rem = Native.Basics.rem

114rem = Native.Basics.rem

111

115

112−{-| Perform modular arithmetic: ``7 `mod` 2 == 1`` -}

116+{-| Perform [modular arithmetic](http://en.wikipedia.org/wiki/Modular_arithmetic):

113−mod : Int -> Int -> Int

117+

114−mod = Native.Basics.mod

118+ 7 % 2 == 1

119+ -1 % 4 == 3

120+-}

121+(%) : Int -> Int -> Int

122+(%) = Native.Basics.mod

115

123

116{-| Exponentiation: `3^2 == 9` -}

124{-| Exponentiation: `3^2 == 9` -}

117(^) : number -> number -> number

125(^) : number -> number -> number

@@ -150,15 +158,19 @@ atan2 : Float -> Float -> Float

150atan2 = Native.Basics.atan2

158atan2 = Native.Basics.atan2

151

159

152{-| Take the square root of a number. -}

160{-| Take the square root of a number. -}

153−sqrt : number -> number

161+sqrt : Float -> Float

154sqrt = Native.Basics.sqrt

162sqrt = Native.Basics.sqrt

155

163

164+{-| Negate any number: `negate 42 == -42` -}

165+negate : number -> number

166+negate = Native.Basics.negate

167+

156{-| Take the absolute value of a number. -}

168{-| Take the absolute value of a number. -}

157abs : number -> number

169abs : number -> number

158abs = Native.Basics.abs

170abs = Native.Basics.abs

159

171

160{-| Calculate the logarithm of a number with a given base: `logBase 10 100 == 2` -}

172{-| Calculate the logarithm of a number with a given base: `logBase 10 100 == 2` -}

161−logBase : number -> number -> number

173+logBase : Float -> Float -> Float

162logBase = Native.Basics.logBase

174logBase = Native.Basics.logBase

163

175

164{-| Clamps a number within a given range. With the expression

176{-| Clamps a number within a given range. With the expression

@@ -301,9 +313,32 @@ isInfinite = Native.Basics.isInfinite

301

313

302-- Function Helpers

314-- Function Helpers

303

315

304−{-| Function composition: `(f . g == (\\x -> f (g x)))` -}

316+{-| Function composition, passing results along in the suggested direction. For

305−(.) : (b -> c) -> (a -> b) -> (a -> c)

317+example, the following code checks if the square root of a number is odd:

306−(.) f g x = f (g x)

318+

319+ not << isEven << sqrt

320+

321+You can think of this operator as equivalent to the following:

322+

323+ (g << f) == (\x -> g (f x))

324+

325+So our example expands out to something like this:

326+

327+ \n -> not (isEven (sqrt n))

328+-}

329+(<<) : (b -> c) -> (a -> b) -> (a -> c)

330+(<<) g f x = g (f x)

331+

332+{-| Function composition, passing results along in the suggested direction. For

333+example, the following code checks if the square root of a number is odd:

334+

335+ sqrt >> isEven >> not

336+

337+This direction of function composition seems less pleasant than `(<<)` which

338+reads nicely in expressions like: `filter (not << isRegistered) students`

339+-}

340+(>>) : (a -> b) -> (b -> c) -> (a -> c)

341+(>>) f g x = g (f x)

307

342

308{-| Forward function application `x |> f == f x`. This function is useful

343{-| Forward function application `x |> f == f x`. This function is useful

309for avoiding parenthesis and writing code in a more natural way.

344for avoiding parenthesis and writing code in a more natural way.

@@ -332,13 +367,16 @@ This can also be written as:

332(<|) : (a -> b) -> a -> b

367(<|) : (a -> b) -> a -> b

333f <| x = f x

368f <| x = f x

334

369

335−infixr 9 .

370+infixr 9 <<

371+infixl 9 >>

336infixr 0 <|

372infixr 0 <|

337infixl 0 |>

373infixl 0 |>

338

374

339−{-| Given a value, returns exactly the same value. -}

375+{-| Given a value, returns exactly the same value. This is called

340−id : a -> a

376+[the identity function](http://en.wikipedia.org/wiki/Identity_function).

341−id x = x

377+-}

378+identity : a -> a

379+identity x = x

342

380

343{-| Creates a [constant function](http://en.wikipedia.org/wiki/Constant_function),

381{-| Creates a [constant function](http://en.wikipedia.org/wiki/Constant_function),

344a function that *always* returns the same value regardless of what input you give.

382a function that *always* returns the same value regardless of what input you give.

libraries/Color.elm+4−4

@@ -60,7 +60,7 @@ with an alpha component for transparency.

60-}

61hsla : Float -> Float -> Float -> Float -> Color

62hsla hue saturation lightness alpha =

63− HSLA (hue - toFloat (floor (hue / (2*pi)))) saturation lightness alpha

63+ HSLA (hue - turns (toFloat (floor (hue / (2*pi))))) saturation lightness alpha

64

65{-| Create [HSL colors](http://en.wikipedia.org/wiki/HSL_and_HSV). This gives

66you access to colors more like a color wheel, where all hues are aranged in a

@@ -97,7 +97,7 @@ complement color =

97 RGBA r g b a -> let (h,s,l) = rgbToHsl r g b

98 in hsla (h + degrees 180) s l a

99

100−{-| Extract the the components of a color in the HSL format.

100+{-| Extract the components of a color in the HSL format.

101-}

102toHsl : Color -> { hue:Float, saturation:Float, lightness:Float, alpha:Float }

103toHsl color =

@@ -107,7 +107,7 @@ toHsl color =

107 let (h,s,l) = rgbToHsl r g b

108 in { hue=h, saturation=s, lightness=l, alpha=a }

109

110−{-| Extract the the components of a color in the RGB format.

110+{-| Extract the components of a color in the RGB format.

111-}

112toRgb : Color -> { red:Int, green:Int, blue:Int, alpha:Float }

113toRgb color =

@@ -124,7 +124,7 @@ toRgb color =

124fmod : Float -> Int -> Float

125fmod f n =

126 let integer = floor f

127− in toFloat (integer `mod` n) + f - toFloat integer

127+ in toFloat (integer % n) + f - toFloat integer

128

129rgbToHsl : Int -> Int -> Int -> (Float,Float,Float)

130rgbToHsl red green blue =

libraries/Debug.elm+71−2

@@ -2,10 +2,16 @@ module Debug where

2{-| This library is for investigating bugs or performance problems. It should

3*not* be used in production code.

4

5−@docs log

5+# Console Debugging

6+@docs log, crash

7+

8+# Time-Travel Debugging

9+@docs watch, watchSummary, trace

6-}

10-}

7

11

12+import Graphics.Collage (Form)

8import Native.Debug

13import Native.Debug

14+import Native.Error

9

15

10{-| Log a tagged value on the developer console, and then return the value.

16{-| Log a tagged value on the developer console, and then return the value.

11

17

@@ -16,4 +22,67 @@ Notice that `log` is not a pure function! It should *only* be used for

16investigating bugs or performance problems.

22investigating bugs or performance problems.

17-}

23-}

18log : String -> a -> a

24log : String -> a -> a

19−log = Native.Debug.log

25+log = Native.Debug.log

26+

27+{-| Crash the program with an error message. This is an uncatchable error,

28+intended for code that is soon-to-be-implemented. For example, if you are

29+working with a large ADT and have partially completed a case expression, it may

30+make sense to do this:

31+

32+ data Entity = Ship | Fish | Captain | Seagull

33+

34+ drawEntity entity =

35+ case entity of

36+ Ship -> ...

37+ Fish -> ...

38+ _ -> Debug.crash ("drawEntity not implemented for " ++ show entity ++ " yet!")

39+

40+Note that incomplete pattern matches are *very* bad practice! They are one of

41+the very few ways to crash an Elm program, and they are completely avoidable.

42+Production code should not have incomplete pattern matches!

43+

44+**Use this if** you want to do some testing while you are partway through

45+writing a function.

46+

47+**Do not use this if** you want to do some typical try-catch exception handling.

48+Use the `Maybe` or `Either` libraries instead.

49+-}

50+crash : String -> a

51+crash = Native.Error.raise

52+

53+{-| Watch a particular value in the debugger. Say we want to know the value of

54+a variable called `velocity` because it may not be updated correctly. Adding

55+`Debug.watch` allows us to name the value and show it with the debugger.

56+

57+ Debug.watch "velocity" velocity == velocity

58+

59+Notice that the result of evaluating this expression is exactly the same as

60+not having the expression at all. That means it's easy to add to any value.

61+-}

62+watch : String -> a -> a

63+watch = Native.Debug.watch

64+

65+{-| Watch a summary of a particular value in the debugger. This function is

66+pretty much the same as `watch` but it lets you specify a way to summarize

67+the value you are interested in. For example, maybe you only want to see part

68+of a record:

69+

70+ Debug.watchSummary "velocity" .velocity object

71+

72+This is the same as just writing `object`, but it creates a watch that *only*

73+looks at the value of `object.velocity`. You can also show summary statistics

74+like length of a list:

75+

76+ Debug.watchSummary "Number of clicks" length clicks

77+

78+Again, this evaluates to `clicks` but we get to see how long that list is in

79+the debugger.

80+-}

81+watchSummary : String -> (a -> b) -> a -> a

82+watchSummary = Native.Debug.watchSummary

83+

84+{-| Trace all past positions of a `Form` in the debugger. Add this to a `Form`

85+and you will see a line tracing its entire history.

86+-}

87+trace : String -> Form -> Form

88+trace = Native.Debug.tracePath

libraries/Dict.elm+35−27

@@ -1,13 +1,15 @@

1−module Dict (empty,singleton,insert,update

1+module Dict

2− ,get,getOrElse,getOrFail

2+ ( Dict

3− ,remove,member

3+ , empty, singleton, insert, update

4− ,filter

4+ , get, getOrElse, getOrFail

5− ,partition

5+ , remove, member

6− ,foldl,foldr,map

6+ , filter

7− ,union,intersect,diff

7+ , partition

8− ,keys,values

8+ , foldl, foldr, map

9− ,toList,fromList

9+ , union, intersect, diff

10− ) where

10+ , keys, values

11+ , toList, fromList

12+ ) where

11

13

12{-| A dictionary mapping unique keys to values. The keys can be any comparable

14{-| A dictionary mapping unique keys to values. The keys can be any comparable

13type. This includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or

15type. This includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or

@@ -37,36 +39,42 @@ import Basics (..)

37import Maybe (..)

39import Maybe (..)

38import Native.Error

40import Native.Error

39import List

41import List

42+import List ((::))

40import Native.Utils

43import Native.Utils

41

44

45+type Fakeout = (Int, Int)

46+

47+type Another = (Int, Int)

48+

42-- BBlack and NBlack should only be used during the deletion

49-- BBlack and NBlack should only be used during the deletion

43-- algorithm. Any other occurrence is a bug and should fail an assert.

50-- algorithm. Any other occurrence is a bug and should fail an assert.

44−data NColor = Red

51+data NColor

45− | Black

52+ = Red

46− -- ^ Double Black, counts as 2 blacks for the invariant

53+ | Black

47− | BBlack

54+ | BBlack -- Double Black, counts as 2 blacks for the invariant

48− -- ^ Negative Black, counts as -1 blacks for the invariant

55+ | NBlack -- Negative Black, counts as -1 blacks for the invariant

49− | NBlack

50

56

51

57

52showNColor : NColor -> String

58showNColor : NColor -> String

53−showNColor c = case c of

59+showNColor c =

54− Red -> "Red"

60+ case c of

55− Black -> "Black"

61+ Red -> "Red"

56− BBlack -> "BBlack"

62+ Black -> "Black"

57− NBlack -> "NBlack"

63+ BBlack -> "BBlack"

64+ NBlack -> "NBlack"

58

65

59−data LeafColor = LBlack

66+data LeafColor

60− -- ^ Double Black, counts as 2

67+ = LBlack

61− | LBBlack

68+ | LBBlack -- Double Black, counts as 2

62

69

63showLColor : LeafColor -> String

70showLColor : LeafColor -> String

64showLColor c = case c of

71showLColor c = case c of

65 LBlack -> "LBlack"

72 LBlack -> "LBlack"

66 LBBlack -> "LBBlack"

73 LBBlack -> "LBBlack"

67

74

68−data Dict k v = RBNode NColor k v (Dict k v) (Dict k v)

75+data Dict k v

69− | RBEmpty LeafColor

76+ = RBNode NColor k v (Dict k v) (Dict k v)

77+ | RBEmpty LeafColor

70

78

71{-| Create an empty dictionary. -}

79{-| Create an empty dictionary. -}

72empty : Dict comparable v

80empty : Dict comparable v

@@ -248,7 +256,7 @@ reportRemBug msg c lgot rgot =

248 lgot,

256 lgot,

249 " ",

257 " ",

250 rgot,

258 rgot,

251− "\nPlease report this bug to https://github.com/evancz/Elm/issues"

259+ "\nPlease report this bug to https://github.com/elm-lang/Elm/issues"

252 ]

260 ]

253

261

254-- Remove the top node from the tree, may leave behind BBlacks

262-- Remove the top node from the tree, may leave behind BBlacks

libraries/Either.elm+2−1

@@ -14,8 +14,9 @@ module Either where

14-}

15

16import List

17+import List ((::))

17

18

18−{-| Represents any data may take two forms. For example, a user ID may be

19+{-| Represents any data that can take two forms. For example, a user ID may be

19either an `Int` or a `String`.

20either an `Int` or a `String`.

20

21

21This can also be used for error handling `(Either String a)` where

22This can also be used for error handling `(Either String a)` where

libraries/Graphics/Collage.elm+4−3

@@ -32,8 +32,9 @@ it as a single unit.

32

33import Basics (..)

34import List

35−import Either (Either, Left, Right)

35+import Either (Either(Left, Right))

36−import Transform2D (Transform2D, identity)

36+import Transform2D (Transform2D)

37+import Transform2D as T

37import Native.Graphics.Collage

38import Native.Graphics.Collage

38import Graphics.Element (Element)

39import Graphics.Element (Element)

39import Color (Color, black, Gradient)

40import Color (Color, black, Gradient)

@@ -153,7 +154,7 @@ toForm e = form (FElement e)

153as a single unit, making it possible to build small, modular components.

154as a single unit, making it possible to build small, modular components.

154-}

155-}

155group : [Form] -> Form

156group : [Form] -> Form

156−group fs = form (FGroup identity fs)

157+group fs = form (FGroup T.identity fs)

157

158

158{-| Flatten many forms into a single `Form` and then apply a matrix

159{-| Flatten many forms into a single `Form` and then apply a matrix

159transformation.

160transformation.

libraries/Graphics/Element.elm+1−1

@@ -41,7 +41,7 @@ import Basics (..)

41import Native.Utils

42import List as List

43import Color (..)

44−import Maybe (Maybe, Just, Nothing)

44+import Maybe ( Maybe(..) )

45

46type Properties = {

47 id : Int,

libraries/Graphics/Input/Field.elm+4−4

@@ -33,8 +33,8 @@ edges all have width 1:

33uniformly : Int -> Dimensions

34uniformly n = Dimensions n n n n

35

36−{-| For setting dimensions of a fields padding or border. The left, right, top,

36+{-| For setting dimensions of a field's padding or outline. The left, right,

37−and bottom may all have different sizes. The following example creates

37+top, and bottom may all have different sizes. The following example creates

38dimensions such that the left and right are twice as wide as the top and bottom:

39

40 myDimensions : Int -> Dimensions

@@ -69,8 +69,8 @@ noHighlight : Highlight

69noHighlight = Highlight Color.blue 0

70

71{-| Describe the style of a text box. `style` describes the style of the text

72−itself using [`Text.Style`](/Text#Style). `outline` describes the glowing blue

72+itself using [`Text.Style`](/Text#Style). `highlight` describes the glowing blue

73−outline that shows up when the field has focus. `outline` describes the line

73+highlight that shows up when the field has focus. `outline` describes the line

74surrounding the text field, and `padding` adds whitespace between the `outline`

75and the text.

76

libraries/Keyboard.elm+15−8

@@ -8,7 +8,10 @@ module Keyboard where

8@docs arrows, wasd, directions

9

10# Specific Keys

11−@docs shift, enter, space, ctrl

11+The following signals are `True` when the particular key is pressed and `False`

12+otherwise.

13+

14+@docs enter, space, ctrl, shift, alt, meta

12

15

13# General Keypresses

16# General Keypresses

14@docs isDown, keysDown, lastPressed

17@docs isDown, keysDown, lastPressed

@@ -50,19 +53,23 @@ wasd = directions 87 83 65 68

50isDown : KeyCode -> Signal Bool

53isDown : KeyCode -> Signal Bool

51isDown = Native.Keyboard.isDown

54isDown = Native.Keyboard.isDown

52

55

53−{-| Whether the shift key is pressed. -}

56+alt : Signal Bool

57+alt = Native.Keyboard.alt

58+

59+ctrl : Signal Bool

60+ctrl = isDown 17

61+

62+{-| The meta key is the Windows key on Windows and the Command key on Mac.

63+-}

64+meta : Signal Bool

65+meta = Native.Keyboard.meta

66+

54shift : Signal Bool

67shift : Signal Bool

55shift = isDown 16

68shift = isDown 16

56

69

57−{-| Whether the control key is pressed. -}

58−ctrl : Signal Bool

59−ctrl = isDown 17

60−

61−{-| Whether the space key is pressed. -}

62space : Signal Bool

70space : Signal Bool

63space = isDown 32

71space = isDown 32

64

72

65−{-| Whether the enter key is pressed. -}

66enter : Signal Bool

73enter : Signal Bool

67enter = isDown 13

74enter = isDown 13

68

75

libraries/List.elm+59−11

@@ -10,22 +10,35 @@ list must have the same type.

10@docs head, tail, last, filter, take, drop

11

12# Putting Lists Together

13−@docs concat, concatMap, join, intersperse, zip, zipWith, repeat

13+@docs concat, join, intersperse, zip, zipWith, repeat

14

15# Taking Lists Apart

16@docs partition, unzip

17

18# Folds

19−@docs foldr, foldl, foldr1, foldl1, scanl, scanl1

19+@docs foldr, foldl

20+

21+# Special Maps

22+@docs filterMap, concatMap, indexedMap

20

23

21# Special Folds

24# Special Folds

22−@docs sum, product, maximum, minimum, all, any, and, or

25+@docs sum, product, maximum, minimum, all, any, foldr1, foldl1, scanl, scanl1

23

26

24# Sorting

27# Sorting

25@docs sort, sortBy, sortWith

28@docs sort, sortBy, sortWith

29+

30+# Additional Zips

31+@docs zip3, zip4, zip5, zipWith3, zipWith4, zipWith5

32+

33+If you can think of a legitimate use of `zipN` or `zipWithN` where `N` is 6 or

34+more, please let us know on [the

35+list](https://groups.google.com/forum/#!forum/elm-discuss). The current

36+sentiment is that it is already quite error prone once you get to 4 and

37+possibly should be approached another way.

26-}

38-}

27

39

28import Basics (..)

40import Basics (..)

41+import Maybe ( Maybe(Just,Nothing) )

29import Native.List

42import Native.List

30

43

31{-| Add an element to the front of a list `(1 :: [2,3] == [1,2,3])` -}

44{-| Add an element to the front of a list `(1 :: [2,3] == [1,2,3])` -}

@@ -72,6 +85,15 @@ isEmpty xs =

72map : (a -> b) -> [a] -> [b]

85map : (a -> b) -> [a] -> [b]

73map = Native.List.map

86map = Native.List.map

74

87

88+{-| Same as `map` but the function is also applied to the index of each

89+element (starting at zero).

90+

91+ indexedMap (,) ["Tom","Sue","Bob"] == [ (0,"Tom"), (1,"Sue"), (2,"Bob") ]

92+-}

93+indexedMap : (Int -> a -> b) -> [a] -> [b]

94+indexedMap f xs =

95+ zipWith f [ 0 .. length xs - 1 ] xs

96+

75{-| Reduce a list from the left: `(foldl (::) [] [1,2,3] == [3,2,1])` -}

97{-| Reduce a list from the left: `(foldl (::) [] [1,2,3] == [3,2,1])` -}

76foldl : (a -> b -> b) -> b -> [a] -> b

98foldl : (a -> b -> b) -> b -> [a] -> b

77foldl = Native.List.foldl

99foldl = Native.List.foldl

@@ -108,6 +130,22 @@ scanl1 = Native.List.scanl1

108filter : (a -> Bool) -> [a] -> [a]

130filter : (a -> Bool) -> [a] -> [a]

109filter = Native.List.filter

131filter = Native.List.filter

110

132

133+{-| Apply a function that may succeed to all values in the list, but only keep

134+the successes.

135+

136+ toInt : String -> Maybe Int

137+

138+ filterMap toInt ["3", "4.0", "5", "hats"] == [3,5]

139+-}

140+filterMap : (a -> Maybe b) -> [a] -> [b]

141+filterMap f xs = foldr (maybeCons f) [] xs

142+

143+maybeCons : (a -> Maybe b) -> a -> [b] -> [b]

144+maybeCons f mx xs =

145+ case f mx of

146+ Just x -> x :: xs

147+ Nothing -> xs

148+

111{-| Determine the length of a list: `(length [1,2,3] == 3)` -}

149{-| Determine the length of a list: `(length [1,2,3] == 3)` -}

112length : [a] -> Int

150length : [a] -> Int

113length = Native.List.length

151length = Native.List.length

@@ -124,14 +162,6 @@ all = Native.List.all

124any : (a -> Bool) -> [a] -> Bool

162any : (a -> Bool) -> [a] -> Bool

125any = Native.List.any

163any = Native.List.any

126

164

127−{-| Check to see if all elements are True. -}

128−and : [Bool] -> Bool

129−and = foldl (&&) True

130−

131−{-| Check to see if any elements are True. -}

132−or : [Bool] -> Bool

133−or = foldl (||) False

134−

135{-| Concatenate a list of appendable things:

165{-| Concatenate a list of appendable things:

136

166

137 concat [[1,2],[3],[4,5]] == [1,2,3,4,5]

167 concat [[1,2],[3],[4,5]] == [1,2,3,4,5]

@@ -186,6 +216,15 @@ If one list is longer, the extra elements are dropped.

186zip : [a] -> [b] -> [(a,b)]

216zip : [a] -> [b] -> [(a,b)]

187zip = Native.List.zip

217zip = Native.List.zip

188

218

219+zip3 : [a] -> [b] -> [c] -> [(a,b,c)]

220+zip3 = Native.List.zipWith3 (,,)

221+

222+zip4 : [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]

223+zip4 = Native.List.zipWith4 (,,,)

224+

225+zip5 : [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]

226+zip5 = Native.List.zipWith5 (,,,,)

227+

189{-| Combine two lists, combining them with the given function.

228{-| Combine two lists, combining them with the given function.

190If one list is longer, the extra elements are dropped.

229If one list is longer, the extra elements are dropped.

191

230

@@ -194,6 +233,15 @@ If one list is longer, the extra elements are dropped.

194zipWith : (a -> b -> c) -> [a] -> [b] -> [c]

233zipWith : (a -> b -> c) -> [a] -> [b] -> [c]

195zipWith = Native.List.zipWith

234zipWith = Native.List.zipWith

196

235

236+zipWith3 : (a -> b -> c -> x) -> [a] -> [b] -> [c] -> [x]

237+zipWith3 = Native.List.zipWith3

238+

239+zipWith4 : (a -> b -> c -> d -> x) -> [a] -> [b] -> [c] -> [d] -> [x]

240+zipWith4 = Native.List.zipWith4

241+

242+zipWith5 : (a -> b -> c -> d -> e -> x) -> [a] -> [b] -> [c] -> [d] -> [e] -> [x]

243+zipWith5 = Native.List.zipWith5

244+

197{-| Decompose a list of tuples.

245{-| Decompose a list of tuples.

198

246

199 unzip [(0, True), (17, False), (1337, True)] == ([0,17,1337], [True,False,True])

247 unzip [(0, True), (17, False), (1337, True)] == ([0,17,1337], [True,False,True])

libraries/Maybe.elm+16−20

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

1−module Maybe where

1+module Maybe (Maybe(..), maybe, isJust, isNothing, map) where

2

3{-| Represents an optional value. Maybe it is there, maybe it is not.

4

@@ -8,13 +8,10 @@ module Maybe where

8# Taking Maybes apart

9@docs maybe, isJust, isNothing

10

11−# Maybes and Lists

11+# Map

12−@docs justs

12+@docs map

13-}

14

15−import Basics (not, (.))

16−import List (foldr)

17−

18{-| The Maybe datatype. Useful when a computation may or may not

15{-| The Maybe datatype. Useful when a computation may or may not

19result in a value (e.g. logarithm is defined only for positive

16result in a value (e.g. logarithm is defined only for positive

20numbers).

17numbers).

@@ -27,14 +24,12 @@ function to the associated value.

27

24

28 isPositive : Maybe Int -> Bool

25 isPositive : Maybe Int -> Bool

29 isPositive maybeInt = maybe False (\n -> n > 0) maybeInt

26 isPositive maybeInt = maybe False (\n -> n > 0) maybeInt

30−

31− map : (a -> b) -> Maybe a -> Maybe b

32− map f m = maybe Nothing (\x -> Just (f x)) m

33-}

27-}

34maybe : b -> (a -> b) -> Maybe a -> b

28maybe : b -> (a -> b) -> Maybe a -> b

35−maybe b f m = case m of

29+maybe b f m =

36− Just v -> f v

30+ case m of

37− Nothing -> b

31+ Just v -> f v

32+ Nothing -> b

38

33

39{-| Check if a maybe happens to be a `Just`.

34{-| Check if a maybe happens to be a `Just`.

40

35

@@ -52,14 +47,15 @@ isJust = maybe False (\_ -> True)

52 isNothing Nothing == True

47 isNothing Nothing == True

53-}

48-}

54isNothing : Maybe a -> Bool

49isNothing : Maybe a -> Bool

55−isNothing = not . isJust

50+isNothing = maybe True (\_ -> False)

56−

57−cons : Maybe a -> [a] -> [a]

58−cons mx xs = maybe xs (\x -> x :: xs) mx

59

51

60−{-| Filters out Nothings and extracts the remaining values.

52+{-| Transform the contents of a `Maybe` with a given function:

61

53

62− justs [Just 0, Nothing, Just 5, Just 7] == [0,5,7]

54+ map sqrt (Just 9) == Just 3

55+ map sqrt Nothing == Nothing

63-}

56-}

64−justs : [Maybe a] -> [a]

57+map : (a -> b) -> Maybe a -> Maybe b

65−justs = foldr cons []

58+map f maybe =

59+ case maybe of

60+ Just v -> Just (f v)

61+ Nothing -> Nothing

libraries/Native/Array.js+117−51

@@ -35,8 +35,10 @@ Elm.Native.Array.make = function(elm) {

35 function unsafeGet(i, array) {

36 for (var x = array.height; x > 0; x--) {

37 var slot = i >> (x * 5);

38+ while (array.lengths[slot] <= i) {

39+ slot++;

40+ }

38 if (slot > 0) {

41 if (slot > 0) {

39− while (array.lengths[slot - 1] > i) { slot--; }

40 i -= array.lengths[slot - 1];

42 i -= array.lengths[slot - 1];

41 }

43 }

42 array = array.table[slot];

44 array = array.table[slot];

@@ -255,15 +257,27 @@ Elm.Native.Array.make = function(elm) {

255 }

257 }

256

258

257 function foldl(f, b, a) {

259 function foldl(f, b, a) {

258− for (var i = 0; i < a.table.length; i++) {

260+ if (a.height == 0) {

259− b = A2(f, a.height == 0 ? a.table[i] : foldl(f, b, a.table[i]), b);

261+ for (var i = 0; i < a.table.length; i++) {

262+ b = A2(f, a.table[i], b);

263+ }

264+ } else {

265+ for (var i = 0; i < a.table.length; i++) {

266+ b = foldl(f, b, a.table[i]);

267+ }

260 }

268 }

261 return b;

269 return b;

262 }

270 }

263

271

264 function foldr(f, b, a) {

272 function foldr(f, b, a) {

265− for (var i = a.table.length; i--; ) {

273+ if (a.height == 0) {

266− b = A2(f, a.height == 0 ? a.table[i] : foldr(f, b, a.table[i]), b);

274+ for (var i = a.table.length; i--; ) {

275+ b = A2(f, a.table[i], b);

276+ }

277+ } else {

278+ for (var i = a.table.length; i--; ) {

279+ b = foldl(f, b, a.table[i]);

280+ }

267 }

281 }

268 return b;

282 return b;

269 }

283 }

@@ -299,10 +313,12 @@ Elm.Native.Array.make = function(elm) {

299

313

300 // Create new node.

314 // Create new node.

301 var newA = { ctor:"_Array", height:a.height

315 var newA = { ctor:"_Array", height:a.height

302− , table:a.table.slice(0, right + 1)

316+ , table:a.table.slice(0, right)

303− , lengths:a.lengths.slice(0, right + 1) };

317+ , lengths:a.lengths.slice(0, right) };

304− newA.table[right] = sliced;

318+ if (sliced.table.length > 0) {

305− newA.lengths[right] = length(sliced) + (right > 0 ? newA.lengths[right - 1] : 0);

319+ newA.table[right] = sliced;

320+ newA.lengths[right] = length(sliced) + (right > 0 ? newA.lengths[right - 1] : 0);

321+ }

306 return newA;

322 return newA;

307 }

323 }

308

324

@@ -331,7 +347,7 @@ Elm.Native.Array.make = function(elm) {

331 var newA = { ctor:"_Array", height:a.height

347 var newA = { ctor:"_Array", height:a.height

332 , table:a.table.slice(left, a.table.length + 1)

348 , table:a.table.slice(left, a.table.length + 1)

333 , lengths:new Array(a.table.length - left) };

349 , lengths:new Array(a.table.length - left) };

334− newA.table[left] = sliced;

350+ newA.table[0] = sliced;

335 var len = 0;

351 var len = 0;

336 for (var i = 0; i < newA.table.length; i++) {

352 for (var i = 0; i < newA.table.length; i++) {

337 len += length(newA.table[i]);

353 len += length(newA.table[i]);

@@ -342,68 +358,116 @@ Elm.Native.Array.make = function(elm) {

342 }

358 }

343

359

344 // Appends two trees.

360 // Appends two trees.

345− // TODO: Add support for appending trees of different sizes. Current

346− // behavior will just rise the lower tree and then append them.

347 function append(a,b) {

361 function append(a,b) {

348− if (b.height > a.height) { return append(parentise(a, b.height), b); }

362+ if (a.table.length === 0) {

349− if (a.height > b.height) { return append(a, parentise(b, a.height)); }

363+ return b;

350− if (a.height == 0) { return append(parentise(a, 1), parentise(b, 1)); }

364+ }

365+ if (b.table.length === 0) {

366+ return a;

367+ }

351

368

352 var c = append_(a, b);

369 var c = append_(a, b);

353− if (c[1].table.length > 0) {

370+

354− return siblise(c[0], c[1]);

371+ // Check if both nodes can be crunshed together.

355− } else {

372+ if (c[0].table.length + c[1].table.length <= M) {

373+ if (c[0].table.length === 0) {

374+ return c[1];

375+ }

376+ if (c[1].table.length === 0) {

377+ return c[0];

378+ }

379+

380+ // Adjust .table and .lengths

381+ c[0].table = c[0].table.concat(c[1].table);

382+ if (c[0].height > 0) {

383+ var len = length(c[0]);

384+ for (var i = 0; i < c[1].lengths.length; i++) {

385+ c[1].lengths[i] += len;

386+ }

387+ c[0].lengths = c[0].lengths.concat(c[1].lengths);

388+ }

389+

356 return c[0];

390 return c[0];

357 }

391 }

392+

393+ var toRemove = calcToRemove(a, b);

394+ if (toRemove > E) {

395+ c = shuffle(c[0], c[1], toRemove);

396+ }

397+

398+ return siblise(c[0], c[1]);

358 }

399 }

359

400

360− // Returns an array of two nodes. The second node _may_ be empty. This case

401+ // Returns an array of two nodes; right and left. One node _may_ be empty.

361− // needs to be handled by the function, that called append_. May be only

362− // called for trees with an minimal height of 1.

363 function append_(a, b) {

402 function append_(a, b) {

364− if (a.height == 1) {

403+ if (a.height === 0 && b.height === 0) {

365− // Check if balancing is needed and return based on that.

404+ return [a, b];

366− var toRemove = calcToRemove(a, b);

367− if (toRemove <= E) {

368− return [a,b];

369− }

370−

371− return shuffle(a, b, toRemove);

372 }

405 }

373

406

374− var appended = append_(botRight(a), botLeft(b));

407+ if (a.height !== 1 || b.height !== 1) {

375− a = nodeCopy(a), b = nodeCopy(b);

408+ if (a.height === b.height) {

409+ a = nodeCopy(a);

410+ b = nodeCopy(b);

411+ var appended = append_(botRight(a), botLeft(b));

376

412

377− // Adjust the bottom right side of the new tree.

413+ insertRight(a, appended[1]);

378− a.table[a.table.length - 1] = appended[0];

414+ insertLeft(b, appended[0]);

379− a.lengths[a.lengths.length - 1] = length(appended[0])

415+ } else if (a.height > b.height) {

380− a.lengths[a.lengths.length - 1] += a.lengths.length > 1 ? a.lengths[a.lengths.length - 2] : 0;

416+ a = nodeCopy(a);

417+ var appended = append_(botRight(a), b);

381

418

382− // Adjust the bottom left side of the new tree.

419+ insertRight(a, appended[0]);

383− if (appended[1].table.length > 0) {

420+ b = parentise(appended[1], appended[1].height + 1);

384− b.table[0] = appended[1];

421+ } else {

385− b.lengths[0] = length(appended[1]);

422+ b = nodeCopy(b);

386− for (var i = 1, len = length(b.table[0]); i < b.lengths.length; i++) {

423+ var appended = append_(a, botLeft(b));

387− len += length(b.table[i]);

424+

388− b.lengths[i] = len;

425+ var left = appended[0].table.length === 0 ? 0 : 1;

389− }

426+ var right = left === 0 ? 1 : 0;

390− } else {

427+ insertLeft(b, appended[left]);

391− b.table.shift();

428+ a = parentise(appended[right], appended[right].height + 1);

392− for (var i = 1; i < b.lengths.length; i++) {

393− b.lengths[i] = b.lengths[i] - b.lengths[0];

394 }

429 }

395− b.lengths.shift();

396 }

430 }

397

431

398 // Check if balancing is needed and return based on that.

432 // Check if balancing is needed and return based on that.

399− var toRemove = calcToRemove(a, b);

433+ if (a.table.length === 0 || b.table.length === 0) {

400− if (toRemove <= E || b.table.length == 0) {

401 return [a,b];

434 return [a,b];

402 }

435 }

403

436

437+ var toRemove = calcToRemove(a, b);

438+ if (toRemove <= E) {

439+ return [a,b];

440+ }

404 return shuffle(a, b, toRemove);

441 return shuffle(a, b, toRemove);

405 }

442 }

406

443

444+ // Helperfunctions for append_. Replaces a child node at the side of the parent.

445+ function insertRight(parent, node) {

446+ var index = parent.table.length - 1;

447+ parent.table[index] = node;

448+ parent.lengths[index] = length(node)

449+ parent.lengths[index] += index > 0 ? parent.lengths[index - 1] : 0;

450+ }

451+

452+ function insertLeft(parent, node) {

453+ if (node.table.length > 0) {

454+ parent.table[0] = node;

455+ parent.lengths[0] = length(node);

456+

457+ var len = length(parent.table[0]);

458+ for (var i = 1; i < parent.lengths.length; i++) {

459+ len += length(parent.table[i]);

460+ parent.lengths[i] = len;

461+ }

462+ } else {

463+ parent.table.shift();

464+ for (var i = 1; i < parent.lengths.length; i++) {

465+ parent.lengths[i] = parent.lengths[i] - parent.lengths[0];

466+ }

467+ parent.lengths.shift();

468+ }

469+ }

470+

407 // Returns the extra search steps for E. Refer to the paper.

471 // Returns the extra search steps for E. Refer to the paper.

408 function calcToRemove(a, b) {

472 function calcToRemove(a, b) {

409 var subLengths = 0;

473 var subLengths = 0;

@@ -544,7 +608,9 @@ Elm.Native.Array.make = function(elm) {

544 // find the exact slot via forward searching in "lengths". Returns the index.

608 // find the exact slot via forward searching in "lengths". Returns the index.

545 function getSlot(i, a) {

609 function getSlot(i, a) {

546 var slot = i >> (5 * a.height);

610 var slot = i >> (5 * a.height);

547− while (a.lengths[slot - 1] > i) { slot--; }

611+ while (a.lengths[slot] <= i) {

612+ slot++;

613+ }

548 return slot;

614 return slot;

549 }

615 }

550

616

libraries/Native/Basics.js+94−45

@@ -8,54 +8,103 @@ Elm.Native.Basics.make = function(elm) {

8 var JS = Elm.Native.JavaScript.make(elm);

9 var Utils = Elm.Native.Utils.make(elm);

10

11− function div(a,b) { return (a/b)|0; }

11+ function div(a, b) {

12− function rem(a,b) { return a % b; }

12+ return (a/b)|0;

13+ }

14+ function rem(a, b) {

15+ return a % b;

16+ }

13 var mod = Utils.mod;

17 var mod = Utils.mod;

14− function abs(x) { return x < 0 ? -x : x; }

18+ function logBase(base, n) {

15− function logBase(base,n) { return Math.log(n) / Math.log(base); }

19+ return Math.log(n) / Math.log(base);

16− function min(a,b) { return Utils.cmp(a,b) < 0 ? a : b; }

20+ }

17− function max(a,b) { return Utils.cmp(a,b) > 0 ? a : b; }

21+ function negate(n) {

18− function clamp(lo,hi,n) {

22+ return -n;

19− return Utils.cmp(n,lo) < 0 ? lo : Utils.cmp(n,hi) > 0 ? hi : n; }

23+ }

20− function xor(a,b) { return a !== b; }

24+ function abs(n) {

21− function not(b) { return !b; }

25+ return n < 0 ? -n : n;

22− function isInfinite(n) { return n === Infinity || n === -Infinity }

26+ }

23−

27+

24− function truncate(n) { return n|0; }

28+ function min(a, b) {

29+ return Utils.cmp(a,b) < 0 ? a : b;

30+ }

31+ function max(a, b) {

32+ return Utils.cmp(a,b) > 0 ? a : b;

33+ }

34+ function clamp(lo, hi, n) {

35+ return Utils.cmp(n,lo) < 0 ? lo : Utils.cmp(n,hi) > 0 ? hi : n;

36+ }

37+

38+ function xor(a, b) {

39+ return a !== b;

40+ }

41+ function not(b) {

42+ return !b;

43+ }

44+ function isInfinite(n) {

45+ return n === Infinity || n === -Infinity

46+ }

47+

48+ function truncate(n) {

49+ return n|0;

50+ }

51+

52+ function degrees(d) {

53+ return d * Math.PI / 180;

54+ }

55+ function turns(t) {

56+ return 2 * Math.PI * t;

57+ }

58+ function fromPolar(point) {

59+ var r = point._0;

60+ var t = point._1;

61+ return Utils.Tuple2(r * Math.cos(t), r * Math.sin(t));

62+ }

63+ function toPolar(point) {

64+ var x = point._0;

65+ var y = point._1;

66+ return Utils.Tuple2(Math.sqrt(x * x + y * y), Math.atan2(y,x));

67+ }

25

68

26 var basics = {

69 var basics = {

27− div:F2(div),

70+ div: F2(div),

28− rem:F2(rem),

71+ rem: F2(rem),

29− mod:mod,

72+ mod: mod,

30−

73+

31− pi:Math.PI,

74+ pi: Math.PI,

32− e:Math.E,

75+ e: Math.E,

33− cos:Math.cos,

76+ cos: Math.cos,

34− sin:Math.sin,

77+ sin: Math.sin,

35− tan:Math.tan,

78+ tan: Math.tan,

36− acos:Math.acos,

79+ acos: Math.acos,

37− asin:Math.asin,

80+ asin: Math.asin,

38− atan:Math.atan,

81+ atan: Math.atan,

39− atan2:F2(Math.atan2),

82+ atan2: F2(Math.atan2),

40−

83+

41− sqrt:Math.sqrt,

84+ degrees: degrees,

42− abs:abs,

85+ turns: turns,

43− logBase:F2(logBase),

86+ fromPolar: fromPolar,

44− min:F2(min),

87+ toPolar: toPolar,

45− max:F2(max),

88+

46− clamp:F3(clamp),

89+ sqrt: Math.sqrt,

47− compare:Utils.compare,

90+ logBase: F2(logBase),

48−

91+ negate: negate,

49− xor:F2(xor),

92+ abs: abs,

50− not:not,

93+ min: F2(min),

51−

94+ max: F2(max),

52− truncate:truncate,

95+ clamp: F3(clamp),

53− ceiling:Math.ceil,

96+ compare: Utils.compare,

54− floor:Math.floor,

97+

55− round:Math.round,

98+ xor: F2(xor),

56− toFloat:function(x) { return x; },

99+ not: not,

57− isNaN:isNaN,

100+

58− isInfinite:isInfinite

101+ truncate: truncate,

102+ ceiling: Math.ceil,

103+ floor: Math.floor,

104+ round: Math.round,

105+ toFloat: function(x) { return x; },

106+ isNaN: isNaN,

107+ isInfinite: isInfinite

59 };

108 };

60

109

61 return elm.Native.Basics.values = basics;

110 return elm.Native.Basics.values = basics;

libraries/Native/Char.js+6−4

@@ -4,6 +4,8 @@ Elm.Native.Char.make = function(elm) {

4 elm.Native.Char = elm.Native.Char || {};

5 if (elm.Native.Char.values) return elm.Native.Char.values;

6

7+ var Utils = Elm.Native.Utils.make(elm);

8+

7 function isBetween(lo,hi) { return function(chr) {

9 function isBetween(lo,hi) { return function(chr) {

8 var c = chr.charCodeAt(0);

10 var c = chr.charCodeAt(0);

9 return lo <= c && c <= hi;

11 return lo <= c && c <= hi;

@@ -16,10 +18,10 @@ Elm.Native.Char.make = function(elm) {

16 return elm.Native.Char.values = {

18 return elm.Native.Char.values = {

17 fromCode : function(c) { return String.fromCharCode(c); },

19 fromCode : function(c) { return String.fromCharCode(c); },

18 toCode : function(c) { return c.toUpperCase().charCodeAt(0); },

20 toCode : function(c) { return c.toUpperCase().charCodeAt(0); },

19− toUpper : function(c) { return c.toUpperCase(); },

21+ toUpper : function(c) { return Utils.chr(c.toUpperCase()); },

20− toLower : function(c) { return c.toLowerCase(); },

22+ toLower : function(c) { return Utils.chr(c.toLowerCase()); },

21− toLocaleUpper : function(c) { return c.toLocaleUpperCase(); },

23+ toLocaleUpper : function(c) { return Utils.chr(c.toLocaleUpperCase()); },

22− toLocaleLower : function(c) { return c.toLocaleLowerCase(); },

24+ toLocaleLower : function(c) { return Utils.chr(c.toLocaleLowerCase()); },

23 isLower : isBetween('a'.charCodeAt(0),'z'.charCodeAt(0)),

25 isLower : isBetween('a'.charCodeAt(0),'z'.charCodeAt(0)),

24 isUpper : isBetween('A'.charCodeAt(0),'Z'.charCodeAt(0)),

26 isUpper : isBetween('A'.charCodeAt(0),'Z'.charCodeAt(0)),

25 isDigit : isDigit,

27 isDigit : isDigit,

libraries/Native/Debug.js+40−4

@@ -3,10 +3,13 @@ Elm.Native.Debug.make = function(elm) {

3 elm.Native = elm.Native || {};

4 elm.Native.Debug = elm.Native.Debug || {};

5 if (elm.Native.Debug.values) return elm.Native.Debug.values;

6+ if ('values' in Elm.Native.Debug)

7+ return elm.Native.Debug.values = Elm.Native.Debug.values;

6

8

7 var show = Elm.Native.Show.make(elm).show;

9 var show = Elm.Native.Show.make(elm).show;

10+ var replace = Elm.Native.Utils.make(elm).replace;

8

11

9− function log(tag,value) {

12+ function log(tag, value) {

10 var msg = tag + ': ' + show(value);

13 var msg = tag + ': ' + show(value);

11 var process = process || {};

14 var process = process || {};

12 if (process.stdout) {

15 if (process.stdout) {

@@ -17,8 +20,41 @@ Elm.Native.Debug.make = function(elm) {

17 return value;

20 return value;

18 }

21 }

19

22

20− return elm.Native.Debug.values = {

23+ function tracePath(debugId, form) {

21− log: F2(log)

24+ return replace([["debugTracePathId",debugId]], form);

25+ }

26+

27+ function WatchTracker() {

28+ this.frames = [{}];

29+ this.clear = function() {

30+ this.watches = {};

31+ };

32+ this.pushFrame = function() {

33+ var lastFrame = this.frames[this.frames.length - 1];

34+ this.frames.push(lastFrame);

35+ }

36+ this.notify = function(tag, value) {

37+ this.frames[this.frames.length - 1][tag] = value;

38+ };

39+ }

40+ var watchTracker = new WatchTracker();

41+

42+ function watch(tag, value) {

43+ watchTracker.notify(tag, value);

44+ return value;

45+ }

46+

47+ function watchSummary(tag, f, value) {

48+ watchTracker.notify(tag, f(value));

49+ return value;

50+ }

51+

52+ Elm.Native.Debug.values = {

53+ tracePath: F2(tracePath),

54+ log: F2(log),

55+ watch: F2(watch),

56+ watchSummary:F3(watchSummary),

57+ watchTracker: watchTracker

22 };

58 };

23−

59+ return elm.Native.Debug.values = Elm.Native.Debug.values;

24};

60};

libraries/Native/Graphics/Input.js+84−52

@@ -21,46 +21,67 @@ Elm.Native.Graphics.Input.make = function(elm) {

21 return { _:{}, signal:signal, handle:signal };

22 }

23

24− function renderDropDown(signal, values) {

24+ function renderDropDown(model) {

25− return function(_) {

25+ var drop = newNode('select');

26− var entries = List.toArray(values);

26+ drop.style.border = '0 solid';

27−

27+ drop.style.pointerEvents = 'auto';

28− var drop = newNode('select');

28+ drop.style.display = 'block';

29− drop.style.border = '0 solid';

29+

30− drop.style.pointerEvents = 'auto';

30+ drop.elm_signal = model.signal;

31− for (var i = 0; i < entries.length; ++i) {

31+ drop.elm_values = List.toArray(model.values);

32− var option = newNode('option');

32+ var values = drop.elm_values;

33− var name = entries[i]._0;

33+

34− option.value = name;

34+ for (var i = 0; i < values.length; ++i) {

35− option.innerHTML = name;

35+ var option = newNode('option');

36− drop.appendChild(option);

36+ var name = values[i]._0;

37− }

37+ option.value = name;

38− drop.addEventListener('change', function() {

38+ option.innerHTML = name;

39− elm.notify(signal.id, entries[drop.selectedIndex]._1);

39+ drop.appendChild(option);

40− });

40+ }

41−

41+ drop.addEventListener('change', function() {

42− var t = drop.cloneNode(true);

42+ elm.notify(drop.elm_signal.id, drop.elm_values[drop.selectedIndex]._1);

43− t.style.visibility = "hidden";

43+ });

44

45− elm.node.appendChild(t);

45+ return drop;

46− var style = window.getComputedStyle(t, null);

47− var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);

48− var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);

49− elm.node.removeChild(t);

50− return drop;

51− };

52 }

46 }

53

47

54 function updateDropDown(node, oldModel, newModel) {

48 function updateDropDown(node, oldModel, newModel) {

49+ node.elm_signal = newModel.signal;

50+ node.elm_values = List.toArray(newModel.values);

51+

52+ var values = node.elm_values;

53+ var kids = node.childNodes;

54+ var kidsLength = kids.length;

55+

56+ var i = 0;

57+ for (; i < kidsLength && i < values.length; ++i) {

58+ var option = kids[i];

59+ var name = values[i]._0;

60+ option.value = name;

61+ option.innerHTML = name;

62+ }

63+ for (; i < kidsLength; ++i) {

64+ node.removeChild(node.lastChild);

65+ }

66+ for (; i < values.length; ++i) {

67+ var option = newNode('option');

68+ var name = values[i]._0;

69+ option.value = name;

70+ option.innerHTML = name;

71+ node.appendChild(option);

72+ }

55 }

73 }

56

74

57 function dropDown(signal, values) {

75 function dropDown(signal, values) {

58 return A3(newElement, 100, 24, {

76 return A3(newElement, 100, 24, {

59 ctor: 'Custom',

77 ctor: 'Custom',

60 type: 'DropDown',

78 type: 'DropDown',

61− render: renderDropDown(signal,values),

79+ render: renderDropDown,

62 update: updateDropDown,

80 update: updateDropDown,

63− model: {}

81+ model: {

82+ signal: signal,

83+ values: values

84+ }

64 });

85 });

65 }

86 }

66

87

@@ -105,52 +126,63 @@ Elm.Native.Graphics.Input.make = function(elm) {

105 btn.elm_hover = Render.render(model.hover);

126 btn.elm_hover = Render.render(model.hover);

106 btn.elm_down = Render.render(model.down);

127 btn.elm_down = Render.render(model.down);

107

128

108− function replace(node) {

129+ btn.elm_up.style.display = 'block';

109− if (node !== btn.firstChild) {

130+ btn.elm_hover.style.display = 'none';

110− btn.replaceChild(node, btn.firstChild);

131+ btn.elm_down.style.display = 'none';

111− }

132+

133+ btn.appendChild(btn.elm_up);

134+ btn.appendChild(btn.elm_hover);

135+ btn.appendChild(btn.elm_down);

136+

137+ function swap(visibleNode, hiddenNode1, hiddenNode2) {

138+ visibleNode.style.display = 'block';

139+ hiddenNode1.style.display = 'none';

140+ hiddenNode2.style.display = 'none';

112 }

141 }

142+

113 var overCount = 0;

143 var overCount = 0;

114 function over(e) {

144 function over(e) {

115 if (overCount++ > 0) return;

145 if (overCount++ > 0) return;

116− replace(btn.elm_hover);

146+ swap(btn.elm_hover, btn.elm_down, btn.elm_up);

117 }

147 }

118 function out(e) {

148 function out(e) {

119 if (btn.contains(e.toElement || e.relatedTarget)) return;

149 if (btn.contains(e.toElement || e.relatedTarget)) return;

120 overCount = 0;

150 overCount = 0;

121− replace(btn.elm_up);

151+ swap(btn.elm_up, btn.elm_down, btn.elm_hover);

122 }

152 }

123 function up() {

153 function up() {

124− replace(btn.elm_hover);

154+ swap(btn.elm_hover, btn.elm_down, btn.elm_up);

125 elm.notify(btn.elm_signal.id, btn.elm_value);

155 elm.notify(btn.elm_signal.id, btn.elm_value);

126 }

156 }

127 function down() {

157 function down() {

128− replace(btn.elm_down);

158+ swap(btn.elm_down, btn.elm_hover, btn.elm_up);

129 }

159 }

160+

130 btn.addEventListener('mouseover', over);

161 btn.addEventListener('mouseover', over);

131 btn.addEventListener('mouseout' , out);

162 btn.addEventListener('mouseout' , out);

132 btn.addEventListener('mousedown', down);

163 btn.addEventListener('mousedown', down);

133 btn.addEventListener('mouseup' , up);

164 btn.addEventListener('mouseup' , up);

134

165

135− btn.appendChild(btn.elm_up);

136−

137 return btn;

166 return btn;

138 }

167 }

139

168

140 function updateCustomButton(node, oldModel, newModel) {

169 function updateCustomButton(node, oldModel, newModel) {

141− var signal = newModel.signal;

170+ node.elm_signal = newModel.signal;

142− node.elm_up.elm_signal = signal;

171+ node.elm_value = newModel.value;

143− node.elm_hover.elm_signal = signal;

172+

144− node.elm_down.elm_signal = signal;

173+ var kids = node.childNodes;

145−

174+ var styleUp = kids[0].style.display;

146− var value = newModel.value;

175+ var styleHover = kids[1].style.display;

147− node.elm_up.elm_value = value;

176+ var styleDown = kids[2].style.display;

148− node.elm_hover.elm_value = value;

177+

149− node.elm_down.elm_value = value;

178+ Render.update(kids[0], oldModel.up, newModel.up);

150−

179+ Render.update(kids[1], oldModel.hover, newModel.hover);

151− Render.update(node.elm_up, oldModel.up, newModel.up)

180+ Render.update(kids[2], oldModel.down, newModel.down);

152− Render.update(node.elm_hover, oldModel.hover, newModel.hover)

181+

153− Render.update(node.elm_down, oldModel.down, newModel.down)

182+ var kids = node.childNodes;

183+ kids[0].style.display = styleUp;

184+ kids[1].style.display = styleHover;

185+ kids[2].style.display = styleDown;

154 }

186 }

155

187

156 function max3(a,b,c) {

188 function max3(a,b,c) {

libraries/Native/List.js+52−4

@@ -199,6 +199,16 @@ Elm.Native.List.make = function(elm) {

199 return false;

200 }

201

202+ function zip(xs, ys) {

203+ var arr = [];

204+ while (xs.ctor !== '[]' && ys.ctor !== '[]') {

205+ arr.push(Utils.Tuple2(xs._0, ys._0));

206+ xs = xs._1;

207+ ys = ys._1;

208+ }

209+ return fromArray(arr);

210+ }

211+

202 function zipWith(f, xs, ys) {

212 function zipWith(f, xs, ys) {

203 var arr = [];

213 var arr = [];

204 while (xs.ctor !== '[]' && ys.ctor !== '[]') {

214 while (xs.ctor !== '[]' && ys.ctor !== '[]') {

@@ -209,12 +219,47 @@ Elm.Native.List.make = function(elm) {

209 return fromArray(arr);

219 return fromArray(arr);

210 }

220 }

211

221

212− function zip(xs, ys) {

222+ function zipWith3(f, xs, ys, zs) {

213 var arr = [];

223 var arr = [];

214− while (xs.ctor !== '[]' && ys.ctor !== '[]') {

224+ while (xs.ctor !== '[]' && ys.ctor !== '[]' && zs.ctor !== '[]') {

215− arr.push(Utils.Tuple2(xs._0, ys._0));

225+ arr.push(A3(f, xs._0, ys._0, zs._0));

226+ xs = xs._1;

227+ ys = ys._1;

228+ zs = zs._1;

229+ }

230+ return fromArray(arr);

231+ }

232+

233+ function zipWith4(f, ws, xs, ys, zs) {

234+ var arr = [];

235+ while ( ws.ctor !== '[]'

236+ && xs.ctor !== '[]'

237+ && ys.ctor !== '[]'

238+ && zs.ctor !== '[]')

239+ {

240+ arr.push(A4(f, ws._0, xs._0, ys._0, zs._0));

241+ ws = ws._1;

242+ xs = xs._1;

243+ ys = ys._1;

244+ zs = zs._1;

245+ }

246+ return fromArray(arr);

247+ }

248+

249+ function zipWith5(f, vs, ws, xs, ys, zs) {

250+ var arr = [];

251+ while ( vs.ctor !== '[]'

252+ && ws.ctor !== '[]'

253+ && xs.ctor !== '[]'

254+ && ys.ctor !== '[]'

255+ && zs.ctor !== '[]')

256+ {

257+ arr.push(A5(f, vs._0, ws._0, xs._0, ys._0, zs._0));

258+ vs = vs._1;

259+ ws = ws._1;

216 xs = xs._1;

260 xs = xs._1;

217 ys = ys._1;

261 ys = ys._1;

262+ zs = zs._1;

218 }

263 }

219 return fromArray(arr);

264 return fromArray(arr);

220 }

265 }

@@ -328,7 +373,10 @@ Elm.Native.List.make = function(elm) {

328

373

329 all:F2(all),

374 all:F2(all),

330 any:F2(any),

375 any:F2(any),

331− zipWith:F3(zipWith),

376+ zipWith :F3(zipWith ),

377+ zipWith3:F4(zipWith3),

378+ zipWith4:F5(zipWith4),

379+ zipWith5:F6(zipWith5),

332 zip:F2(zip),

380 zip:F2(zip),

333 sort:sort,

381 sort:sort,

334 sortBy:F2(sortBy),

382 sortBy:F2(sortBy),

libraries/Native/Show.js+29−14

@@ -15,15 +15,20 @@ Elm.Native.Show.make = function(elm) {

15 if (type === "function") {

16 var name = v.func ? v.func.name : v.name;

17 return '<function' + (name === '' ? '' : ': ') + name + '>';

18− } else if (type === "boolean") {

18+ }

19+ else if (type === "boolean") {

19 return v ? "True" : "False";

20 return v ? "True" : "False";

20− } else if (type === "number") {

21+ }

21− return v+"";

22+ else if (type === "number") {

22− } else if ((v instanceof String) && v.isChar) {

23+ return v + "";

24+ }

25+ else if ((v instanceof String) && v.isChar) {

23 return "'" + addSlashes(v) + "'";

26 return "'" + addSlashes(v) + "'";

24− } else if (type === "string") {

27+ }

28+ else if (type === "string") {

25 return '"' + addSlashes(v) + '"';

29 return '"' + addSlashes(v) + '"';

26− } else if (type === "object" && '_' in v && probablyPublic(v)) {

30+ }

31+ else if (type === "object" && '_' in v && probablyPublic(v)) {

27 var output = [];

32 var output = [];

28 for (var k in v._) {

33 for (var k in v._) {

29 for (var i = v._[k].length; i--; ) {

34 for (var i = v._[k].length; i--; ) {

@@ -34,9 +39,12 @@ Elm.Native.Show.make = function(elm) {

34 if (k === '_') continue;

39 if (k === '_') continue;

35 output.push(k + " = " + toString(v[k]));

40 output.push(k + " = " + toString(v[k]));

36 }

41 }

37− if (output.length === 0) return "{}";

42+ if (output.length === 0) {

43+ return "{}";

44+ }

38 return "{ " + output.join(", ") + " }";

45 return "{ " + output.join(", ") + " }";

39− } else if (type === "object" && 'ctor' in v) {

46+ }

47+ else if (type === "object" && 'ctor' in v) {

40 if (v.ctor.substring(0,6) === "_Tuple") {

48 if (v.ctor.substring(0,6) === "_Tuple") {

41 var output = [];

49 var output = [];

42 for (var k in v) {

50 for (var k in v) {

@@ -44,10 +52,12 @@ Elm.Native.Show.make = function(elm) {

44 output.push(toString(v[k]));

52 output.push(toString(v[k]));

45 }

53 }

46 return "(" + output.join(",") + ")";

54 return "(" + output.join(",") + ")";

47− } else if (v.ctor === "_Array") {

55+ }

56+ else if (v.ctor === "_Array") {

48 var list = Array.toList(v);

57 var list = Array.toList(v);

49 return "Array.fromList " + toString(list);

58 return "Array.fromList " + toString(list);

50− } else if (v.ctor === "::") {

59+ }

60+ else if (v.ctor === "::") {

51 var output = '[' + toString(v._0);

61 var output = '[' + toString(v._0);

52 v = v._1;

62 v = v._1;

53 while (v.ctor === "::") {

63 while (v.ctor === "::") {

@@ -55,9 +65,11 @@ Elm.Native.Show.make = function(elm) {

55 v = v._1;

65 v = v._1;

56 }

66 }

57 return output + ']';

67 return output + ']';

58− } else if (v.ctor === "[]") {

68+ }

69+ else if (v.ctor === "[]") {

59 return "[]";

70 return "[]";

60− } else if (v.ctor === "RBNode" || v.ctor === "RBEmpty") {

71+ }

72+ else if (v.ctor === "RBNode" || v.ctor === "RBEmpty") {

61 var cons = F3(function(k,v,acc){return NList.Cons(Tuple2(k,v),acc)});

73 var cons = F3(function(k,v,acc){return NList.Cons(Tuple2(k,v),acc)});

62 var list = A3(Dict.foldr, cons, NList.Nil, v);

74 var list = A3(Dict.foldr, cons, NList.Nil, v);

63 var name = "Dict";

75 var name = "Dict";

@@ -66,7 +78,8 @@ Elm.Native.Show.make = function(elm) {

66 list = A2(List.map, function(x){return x._0}, list);

78 list = A2(List.map, function(x){return x._0}, list);

67 }

79 }

68 return name + ".fromList " + toString(list);

80 return name + ".fromList " + toString(list);

69− } else {

81+ }

82+ else {

70 var output = "";

83 var output = "";

71 for (var i in v) {

84 for (var i in v) {

72 if (i === 'ctor') continue;

85 if (i === 'ctor') continue;

@@ -77,7 +90,9 @@ Elm.Native.Show.make = function(elm) {

77 return v.ctor + output;

90 return v.ctor + output;

78 }

91 }

79 }

92 }

80− if (type === 'object' && 'recv' in v) return '<signal>';

93+ if (type === 'object' && 'recv' in v) {

94+ return '<signal>';

95+ }

81 return "<internal structure>";

96 return "<internal structure>";

82 };

97 };

83

98

libraries/Native/Signal/Keyboard.js+142−105

@@ -1,117 +1,154 @@

1Elm.Native.Keyboard = {};

2Elm.Native.Keyboard.make = function(elm) {

3

4− elm.Native = elm.Native || {};

4+ elm.Native = elm.Native || {};

5− elm.Native.Keyboard = elm.Native.Keyboard || {};

5+ elm.Native.Keyboard = elm.Native.Keyboard || {};

6− if (elm.Native.Keyboard.values) return elm.Native.Keyboard.values;

6+ if (elm.Native.Keyboard.values) return elm.Native.Keyboard.values;

7−

7+

8− // Duplicated from Native.Signal

8+ // Duplicated from Native.Signal

9− function send(node, timestep, changed) {

9+ function send(node, timestep, changed) {

10− var kids = node.kids;

10+ var kids = node.kids;

11− for (var i = kids.length; i--; ) {

11+ for (var i = kids.length; i--; ) {

12− kids[i].recv(timestep, changed, node.id);

12+ kids[i].recv(timestep, changed, node.id);

13− }

14− }

15−

16− var Signal = Elm.Signal.make(elm);

17− var NList = Elm.Native.List.make(elm);

18− var Utils = Elm.Native.Utils.make(elm);

19−

20− var downEvents = Signal.constant(0);

21− var upEvents = Signal.constant(0);

22− var blurEvents = Signal.constant(0);

23−

24− elm.addListener([downEvents.id], document, 'keydown', function down(e) {

25− elm.notify(downEvents.id, e.keyCode);

26− });

27−

28− elm.addListener([upEvents.id], document, 'keyup', function up(e) {

29− elm.notify(upEvents.id, e.keyCode);

30− });

31−

32− elm.addListener([blurEvents.id], document, 'blur', function blur(e) {

33− elm.notify(blurEvents.id, NList.Nil);

34− });

35−

36− function KeyMerge(down, up, blur) {

37− var args = [down,up,blur];

38− this.id = Utils.guid();

39− // Ignore starting values here

40− this.value = NList.Nil

41− this.kids = [];

42−

43− var n = args.length;

44− var count = 0;

45− var isChanged = false;

46−

47− this.recv = function(timestep, changed, parentID) {

48− ++count;

49− if (changed) {

50− // We know this a change must only be one of the following cases

51− if (parentID === down.id && !(NList.member(down.value)(this.value))) {

52− isChanged = true;

53− this.value = NList.Cons(down.value, this.value);

54− }

55− if (parentID === up.id) {

56− isChanged = true;

57− var notEq = function(kc) { return kc !== up.value };

58− this.value = NList.filter(notEq)(this.value);

59− }

60− if (parentID === blur.id) {

61− isChanged = true;

62− this.value = NList.Nil;

63 }

13 }

64− }

14+ }

65− if (count == n) {

15+

66− send(this, timestep, isChanged);

16+ var Signal = Elm.Signal.make(elm);

67− isChanged = false;

17+ var NList = Elm.Native.List.make(elm);

68− count = 0;

18+ var Utils = Elm.Native.Utils.make(elm);

69− }

19+

70− };

20+ var downEvents = Signal.constant(null);

21+ var upEvents = Signal.constant(null);

22+ var blurEvents = Signal.constant(null);

23+

24+ elm.addListener([downEvents.id], document, 'keydown', function down(e) {

25+ elm.notify(downEvents.id, e);

26+ });

27+

28+ elm.addListener([upEvents.id], document, 'keyup', function up(e) {

29+ elm.notify(upEvents.id, e);

30+ });

31+

32+ elm.addListener([blurEvents.id], window, 'blur', function blur(e) {

33+ elm.notify(blurEvents.id, null);

34+ });

71

35

72− for (var i = n; i--; ) { args[i].kids.push(this); }

36+ function state(alt, meta, keyCodes) {

73−

37+ return {

74− }

38+ alt: alt,

75−

39+ meta: meta,

76− var keysDown = Signal.dropRepeats(new KeyMerge(downEvents,upEvents,blurEvents));

40+ keyCodes: keyCodes

77−

41+ };

78− function keySignal(f) {

42+ }

79− var signal = A2(Signal.lift, f, keysDown);

43+ var emptyState = state(false, false, NList.Nil);

80− // must set the default number of kids to make it possible to filter

44+

81− // these signals if they are not actually used.

45+ function KeyMerge(down, up, blur) {

82− keysDown.defaultNumberOfKids += 1;

46+ var args = [down,up,blur];

83− signal.defaultNumberOfKids = 1;

47+ this.id = Utils.guid();

84− var filtered = Signal.dropRepeats(signal)

48+ // Ignore starting values here

85− filtered.defaultNumberOfKids = 0;

49+ this.value = emptyState;

86− return filtered;

50+ this.kids = [];

87− }

51+

88−

52+ var n = args.length;

89− function dir(up, down, left, right) {

53+ var count = 0;

90− function f(ks) {

54+ var isChanged = false;

91− var x = 0, y = 0;

55+

92− while (ks.ctor === "::") {

56+ this.recv = function(timestep, changed, parentID) {

93− switch (ks._0) {

57+ ++count;

94− case left : --x; break;

58+ if (changed) {

95− case right: ++x; break;

59+ // We know this a change must only be one of the following cases

96− case up : ++y; break;

60+ if (parentID === down.id && !A2(NList.member, down.value.keyCode, this.value.keyCodes)) {

97− case down : --y; break;

61+ isChanged = true;

62+ var v = down.value;

63+ var newCodes = NList.Cons(v.keyCode, this.value.keyCodes);

64+ this.value = state(v.altKey, v.metaKey, newCodes);

65+ }

66+ else if (parentID === up.id) {

67+ isChanged = true;

68+ var v = up.value;

69+ var notEq = function(kc) { return kc !== v.keyCode };

70+ var newCodes = A2(NList.filter, notEq, this.value.keyCodes);

71+ this.value = state(v.altKey, v.metaKey, newCodes);

72+ }

73+ else if (parentID === blur.id) {

74+ isChanged = true;

75+ this.value = emptyState;

76+ }

77+ }

78+ if (count == n) {

79+ send(this, timestep, isChanged);

80+ isChanged = false;

81+ count = 0;

82+ }

83+ };

84+

85+ for (var i = n; i--; ) {

86+ args[i].kids.push(this);

87+ args[i].defaultNumberOfKids += 1;

98 }

88 }

99− ks = ks._1;

100− }

101− return { _:{}, x:x, y:y };

102 }

89 }

103− return keySignal(f);

104− }

105

90

106− function is(key) { return keySignal(NList.member(key)); }

91+ var keyMerge = new KeyMerge(downEvents,upEvents,blurEvents);

92+

93+ // select a part of a keyMerge and dropRepeats the result

94+ function keySignal(f) {

95+ var signal = A2(Signal.lift, f, keyMerge);

96+ // must set the default number of kids to make it possible to filter

97+ // these signals if they are not actually used.

98+ keyMerge.defaultNumberOfKids += 1;

99+ signal.defaultNumberOfKids = 1;

100+ var filtered = Signal.dropRepeats(signal);

101+ filtered.defaultNumberOfKids = 0;

102+ return filtered;

103+ }

107

104

108− var lastPressed = downEvents;

105+ // break keyMerge into parts

106+ var keysDown = keySignal(function getKeyCodes(v) {

107+ return v.keyCodes;

108+ });

109+ var alt = keySignal(function getKeyCodes(v) {

110+ return v.alt;

111+ });

112+ var meta = keySignal(function getKeyCodes(v) {

113+ return v.meta;

114+ });

115+

116+ function dir(up, down, left, right) {

117+ function toDirections(state) {

118+ var keyCodes = state.keyCodes;

119+ var x = 0, y = 0;

120+ while (keyCodes.ctor === "::") {

121+ switch (keyCodes._0) {

122+ case left : --x; break;

123+ case right: ++x; break;

124+ case up : ++y; break;

125+ case down : --y; break;

126+ }

127+ keyCodes = keyCodes._1;

128+ }

129+ return { _:{}, x:x, y:y };

130+ }

131+ return keySignal(toDirections);

132+ }

109

133

110− return elm.Native.Keyboard.values = {

134+ function is(key) {

111− isDown:is,

135+ return keySignal(function(v) {

112− directions:F4(dir),

136+ return A2( NList.member, key, v.keyCodes );

113− keysDown:keysDown,

137+ });

114− lastPressed:lastPressed

138+ }

115− };

139+

140+ var lastPressed = A2(Signal.lift, function(e) {

141+ return e ? e.keyCode : 0;

142+ }, downEvents);

143+ downEvents.defaultNumberOfKids += 1;

144+

145+ return elm.Native.Keyboard.values = {

146+ isDown:is,

147+ alt: alt,

148+ meta: meta,

149+ directions:F4(dir),

150+ keysDown:keysDown,

151+ lastPressed:lastPressed

152+ };

116

153

117};

154};

libraries/Native/Signal/Signal.js+2−1

@@ -128,7 +128,7 @@ Elm.Native.Signal.make = function(elm) {

128 }

129

130 function timestamp(a) {

131− function update() { return Utils.Tuple2(Date.now(), a.value); }

131+ function update() { return Utils.Tuple2(elm.timer.now(), a.value); }

132 return new LiftN(update, [a]);

133 }

134

@@ -199,6 +199,7 @@ Elm.Native.Signal.make = function(elm) {

199 function merges(ss) { return A2(foldr1, F2(merge), ss); }

200

201 return elm.Native.Signal.values = {

202+ input: function(v) { return new Input(v); },

202 constant : function(v) { return new Input(v); },

203 constant : function(v) { return new Input(v); },

203 lift : F2(lift ),

204 lift : F2(lift ),

204 lift2 : F3(lift2),

205 lift2 : F3(lift2),

libraries/Native/Signal/Time.js+14−9

@@ -12,11 +12,15 @@ Elm.Native.Time.make = function(elm) {

12

13 function fpsWhen(desiredFPS, isOn) {

14 var msPerFrame = 1000 / desiredFPS;

15− var prev = Date.now(), curr = prev, diff = 0, wasOn = true;

15+ var prev = elm.timer.now(), curr = prev, diff = 0, wasOn = true;

16− var ticker = Signal.constant(diff);

16+ var ticker = NS.input(diff);

17− function tick(zero) { return function() {

17+ function tick(zero) {

18− curr = Date.now();

18+ return function() {

19+ curr = elm.timer.now();

19 diff = zero ? 0 : curr - prev;

20 diff = zero ? 0 : curr - prev;

21+ if (prev > curr) {

22+ diff = 0;

23+ }

20 prev = curr;

24 prev = curr;

21 elm.notify(ticker.id, diff);

25 elm.notify(ticker.id, diff);

22 };

26 };

@@ -24,7 +28,7 @@ Elm.Native.Time.make = function(elm) {

24 var timeoutID = 0;

28 var timeoutID = 0;

25 function f(isOn, t) {

29 function f(isOn, t) {

26 if (isOn) {

30 if (isOn) {

27− timeoutID = setTimeout(tick(!wasOn && isOn), msPerFrame);

31+ timeoutID = elm.setTimeout(tick(!wasOn && isOn), msPerFrame);

28 } else if (wasOn) {

32 } else if (wasOn) {

29 clearTimeout(timeoutID);

33 clearTimeout(timeoutID);

30 }

34 }

@@ -35,10 +39,11 @@ Elm.Native.Time.make = function(elm) {

35 }

39 }

36

40

37 function every(t) {

41 function every(t) {

38− var clock = Signal.constant(Date.now());

42+ var clock = NS.input(elm.timer.now());

39− setInterval(function() {

43+ function tellTime() {

40− elm.notify(clock.id, Date.now());

44+ elm.notify(clock.id, elm.timer.now());

41− }, t);

45+ }

46+ setInterval(tellTime, t);

42 return clock;

47 return clock;

43 }

48 }

44

49

libraries/Native/Signal/Touch.js+3−3

@@ -61,11 +61,11 @@ Elm.Native.Touch.make = function(elm) {

61 dict.insert(e.identifier,

62 {x: point._0,

63 y: point._1,

64− t: Date.now()});

64+ t: elm.timer.now()});

65 }

66 function end(e) {

67 var t = dict.remove(e.identifier);

68− if (Date.now() - t.t < tapTime) {

68+ if (elm.timer.now() - t.t < tapTime) {

69 hasTap = true;

70 tap = {_:{}, x:t.x, y:t.y};

71 }

@@ -107,7 +107,7 @@ Elm.Native.Touch.make = function(elm) {

107 root.value.push(touch(e));

108 elm.notify(root.id, root.value);

109 });

110− elm.addListener([root.id], node, "mouseup", function up(e) {

110+ elm.addListener([root.id], document, "mouseup", function up(e) {

111 node.removeEventListener("mousemove", move);

112 e.identifier = mouseID;

113 end(e);

libraries/Native/Signal/WebSocket.js+1−1

@@ -9,7 +9,7 @@ Elm.Native.WebSocket.make = function(elm) {

9 var List = Elm.Native.List.make(elm);

10

11 function open(url, outgoing) {

12− var incoming = Signal.constant(List.Nil);

12+ var incoming = Signal.constant("");

13 var ws = new WebSocket(url);

14

15 var pending = [];

libraries/Native/Signal/Window.js+2−1

@@ -6,6 +6,7 @@ Elm.Native.Window.make = function(elm) {

6 if (elm.Native.Window.values) return elm.Native.Window.values;

7

8 var Signal = Elm.Signal.make(elm);

9+ var NS = Elm.Native.Signal.make(elm);

9 var Tuple2 = Elm.Native.Utils.make(elm).Tuple2;

10 var Tuple2 = Elm.Native.Utils.make(elm).Tuple2;

10

11

11 function getWidth() { return elm.node.clientWidth; }

12 function getWidth() { return elm.node.clientWidth; }

@@ -16,7 +17,7 @@ Elm.Native.Window.make = function(elm) {

16 return elm.node.clientHeight;

17 return elm.node.clientHeight;

17 }

18 }

18

19

19− var dimensions = Signal.constant(Tuple2(getWidth(), getHeight()));

20+ var dimensions = NS.input(Tuple2(getWidth(), getHeight()));

20 dimensions.defaultNumberOfKids = 2;

21 dimensions.defaultNumberOfKids = 2;

21

22

22 // Do not move width and height into Elm. By setting the default number of kids,

23 // Do not move width and height into Elm. By setting the default number of kids,

libraries/Native/Utils.js+35−23

@@ -123,38 +123,50 @@ Elm.Native.Utils.make = function(elm) {

123 var count = 0;

124 function guid(_) { return count++ }

125

126− function copy(r) {

126+ function copy(oldRecord) {

127− var o = {};

127+ var newRecord = {};

128− for (var i in r) { o[i] = r[i]; }

128+ for (var key in oldRecord) {

129− return o;

129+ var value = key === '_'

130+ ? copy(oldRecord._)

131+ : oldRecord[key]

132+ ;

133+ newRecord[key] = value;

134+ }

135+ return newRecord;

130 }

136 }

131

137

132− function remove(x,r) {

138+ function remove(key, oldRecord) {

133− var o = copy(r);

139+ var record = copy(oldRecord);

134− if (x in o._) {

140+ if (key in record._) {

135− o[x] = o._[x][0];

141+ record[key] = record._[key][0];

136− o._[x] = o._[x].slice(1);

142+ record._[key] = record._[key].slice(1);

137− if (o._[x].length === 0) { delete o._[x]; }

143+ if (record._[key].length === 0) {

144+ delete record._[key];

145+ }

138 } else {

146 } else {

139− delete o[x];

147+ delete record[key];

140 }

148 }

141− return o;

149+ return record;

142 }

150 }

143

151

144− function replace(kvs,r) {

152+ function replace(keyValuePairs, oldRecord) {

145− var o = copy(r);

153+ var record = copy(oldRecord);

146− for (var i = kvs.length; i--; ) {

154+ for (var i = keyValuePairs.length; i--; ) {

147− var kvsi = kvs[i];

155+ var pair = keyValuePairs[i];

148− o[kvsi[0]] = kvsi[1];

156+ record[pair[0]] = pair[1];

149 }

157 }

150− return o;

158+ return record;

151 }

159 }

152

160

153− function insert(x,v,r) {

161+ function insert(key, value, oldRecord) {

154− var o = copy(r);

162+ var newRecord = copy(oldRecord);

155− if (x in o) o._[x] = [o[x]].concat(x in o._ ? o._[x].slice(0) : []);

163+ if (key in newRecord) {

156− o[x] = v;

164+ var values = newRecord._[key];

157− return o;

165+ var copiedValues = values ? values.slice(0) : [];

166+ newRecord._[key] = [newRecord[key]].concat(copiedValues);

167+ }

168+ newRecord[key] = value;

169+ return newRecord;

158 }

170 }

159

171

160 function max(a,b) { return a > b ? a : b }

172 function max(a,b) { return a > b ? a : b }

libraries/Set.elm+9−7

@@ -1,11 +1,13 @@

1

2−module Set (empty,singleton,insert,remove

2+module Set

3− ,member

3+ ( Set

4− ,foldl,foldr,map

4+ , empty, singleton, insert, remove

5− ,filter,partition

5+ , member

6− ,union,intersect,diff

6+ , foldl, foldr, map

7− ,toList,fromList

7+ , filter, partition

8− ) where

8+ , union, intersect, diff

9+ , toList, fromList

10+ ) where

9

11

10{-| A set of unique values. The values can be any comparable type. This

12{-| A set of unique values. The values can be any comparable type. This

11includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or lists

13includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or lists

libraries/Signal.elm+1−1

@@ -30,7 +30,7 @@ the `Time` library.

30-}

31

32import Native.Signal

33−import List (foldr)

33+import List (foldr, (::))

34import Basics (fst, snd, not)

35

36data Signal a = Signal

libraries/String.elm+8−6

@@ -71,6 +71,7 @@ concat = Native.String.concat

71{-| Get the length of a string.

72

73 length "innumerable" == 11

74+ length "" == 0

74

75

75-}

76-}

76length : String -> Int

77length : String -> Int

@@ -123,6 +124,7 @@ split = Native.String.split

123

124

124{-| Put many strings together with a given separator.

125{-| Put many strings together with a given separator.

125

126

127+ join "a" ["H","w","ii","n"] == "Hawaiian"

126 join " " ["cat","dog","cow"] == "cat dog cow"

128 join " " ["cat","dog","cow"] == "cat dog cow"

127 join "/" ["home","evan","Desktop"] == "home/evan/Desktop"

129 join "/" ["home","evan","Desktop"] == "home/evan/Desktop"

128-}

130-}

@@ -204,7 +206,7 @@ trim = Native.String.trim

204trimLeft : String -> String

206trimLeft : String -> String

205trimLeft = Native.String.trimLeft

207trimLeft = Native.String.trimLeft

206

208

207−{-| Get rid of whitespace on the left of a string.

209+{-| Get rid of whitespace on the right of a string.

208

210

209 trimRight " hats \n" == " hats"

211 trimRight " hats \n" == " hats"

210-}

212-}

@@ -220,7 +222,7 @@ words = Native.String.words

220

222

221{-| Break a string into lines, splitting on newlines.

223{-| Break a string into lines, splitting on newlines.

222

224

223− lines "How are you?\nGood? == ["How are you?", "Good?"]

225+ lines "How are you?\nGood?" == ["How are you?", "Good?"]

224-}

226-}

225lines : String -> [String]

227lines : String -> [String]

226lines = Native.String.lines

228lines = Native.String.lines

@@ -253,7 +255,7 @@ any = Native.String.any

253all : (Char -> Bool) -> String -> Bool

255all : (Char -> Bool) -> String -> Bool

254all = Native.String.all

256all = Native.String.all

255

257

256−{-| See if a string contains another one.

258+{-| See if the second string contains the first one.

257

259

258 contains "the" "theory" == True

260 contains "the" "theory" == True

259 contains "hat" "theory" == False

261 contains "hat" "theory" == False

@@ -264,7 +266,7 @@ Use `Regex.contains` if you need something more flexible.

264contains : String -> String -> Bool

266contains : String -> String -> Bool

265contains = Native.String.contains

267contains = Native.String.contains

266

268

267−{-| See if a string starts with another one.

269+{-| See if the second string starts with the first one.

268

270

269 startsWith "the" "theory" == True

271 startsWith "the" "theory" == True

270 startsWith "ory" "theory" == False

272 startsWith "ory" "theory" == False

@@ -272,7 +274,7 @@ contains = Native.String.contains

272startsWith : String -> String -> Bool

274startsWith : String -> String -> Bool

273startsWith = Native.String.startsWith

275startsWith = Native.String.startsWith

274

276

275−{-| See if a string ends with another one.

277+{-| See if the second string ends with the first one.

276

278

277 endsWith "the" "theory" == False

279 endsWith "the" "theory" == False

278 endsWith "ory" "theory" == True

280 endsWith "ory" "theory" == True

@@ -280,7 +282,7 @@ startsWith = Native.String.startsWith

280endsWith : String -> String -> Bool

282endsWith : String -> String -> Bool

281endsWith = Native.String.endsWith

283endsWith = Native.String.endsWith

282

284

283−{-| Get all of the indexes for a substring.

285+{-| Get all of the indexes for a substring in another string.

284

286

285 indexes "i" "Mississippi" == [1,4,7,10]

287 indexes "i" "Mississippi" == [1,4,7,10]

286 indexes "ss" "Mississippi" == [2,5]

288 indexes "ss" "Mississippi" == [2,5]

libraries/Text.elm+2−2

@@ -34,7 +34,7 @@ import Basics (..)

34import String

35import Color (Color, black)

36import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)

37−import Maybe (Maybe, Nothing)

37+import Maybe (Maybe(Nothing))

38import Native.Show

39import Native.Text

40

@@ -212,7 +212,7 @@ markdown = Native.Text.markdown

212{-| Convert anything to its textual representation and make it displayable in

213the browser:

214

215− asText value = text (monospace (show value))

215+ asText value = leftAligned (monospace (toText (show value)))

216

217Excellent for debugging.

218-}

libraries/Transform2D.elm+5−1

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

1−module Transform2D where

1+module Transform2D ( Transform2D

2+ , identity, matrix, multiply

3+ , rotation, translation

4+ , scale, scaleX, scaleY

5+ ) where

2{-| A library for performing [2D matrix transformations][affine].

6{-| A library for performing [2D matrix transformations][affine].

3It is used primarily with the `groupTransform` function from `Graphics.Collage` and

7It is used primarily with the `groupTransform` function from `Graphics.Collage` and

4allows you to do things like rotation, scaling, translation, shearing, and reflection.

8allows you to do things like rotation, scaling, translation, shearing, and reflection.

libraries/WebSocket.elm−1

@@ -8,7 +8,6 @@ change to make it more flexible.

8-}

9

10import Signal (Signal)

11−import Basics (String)

12import Native.WebSocket

11import Native.WebSocket

13

12

14{-| Create a web-socket. The first argument is the URL of the desired

13{-| Create a web-socket. The first argument is the URL of the desired

libraries/elm_dependencies.json+3−3

@@ -1,9 +1,9 @@

1−{ "version": "0.12.2"

1+{ "version": "0.13"

2, "summary": "Elm's standard libraries"

3−, "description": "The full set of standard libraries for Elm. This library is pegged to the version number of the compiler, so if you are using Elm 0.12.1, you should be using version 0.12.1 of the standard libraries."

3+, "description": "The full set of standard libraries for Elm. This library is pegged to the version number of the compiler, so if you are using Elm 0.13, you should be using version 0.13 of the standard libraries."

4, "license": "BSD3"

5, "repository": "http://github.com/elm-lang/Elm.git"

6−, "elm-version": "0.12.2"

6+, "elm-version": "0.13"

7, "dependencies": {}

8, "exposed-modules":

9 [ "Array"

runtime/Debugger.jsnew file+604

@@ -0,0 +1,604 @@

1+(function() {

2+'use strict';

3+

4+if (typeof window != 'undefined' && !window.location.origin) {

5+ window.location.origin =

6+ window.location.protocol + "//" +

7+ window.location.hostname +

8+ (window.location.port ? (':' + window.location.port) : '');

9+}

10+

11+Elm.fullscreenDebugHooks = function(module, debuggerHistory /* =undefined */) {

12+ var exposedDebugger = {};

13+ function debuggerAttach(module, debuggerHistory) {

14+ return {

15+ make: function(runtime) {

16+ var wrappedModule = debugModule(module, runtime);

17+ exposedDebugger = debuggerInit(wrappedModule, runtime, debuggerHistory);

18+ return wrappedModule.debuggedModule;

19+ }

20+ }

21+ }

22+ var mainHandle = Elm.fullscreen(debuggerAttach(module, debuggerHistory));

23+ mainHandle.debugger = exposedDebugger;

24+ return mainHandle;

25+};

26+

27+var EVENTS_PER_SAVE = 100;

28+

29+function debugModule(module, runtime) {

30+ var programPaused = false;

31+ var recordedEvents = [];

32+ var asyncCallbacks = [];

33+ var snapshots = [];

34+ var watchTracker = Elm.Native.Debug.make(runtime).watchTracker;

35+ var pauseTime = 0;

36+ var eventsUntilSnapshot = EVENTS_PER_SAVE;

37+ runtime.debuggerStatus = runtime.debuggerStatus || {};

38+ runtime.debuggerStatus.eventCounter = runtime.debuggerStatus.eventCounter || 0;

39+

40+ // runtime is the prototype of wrappedRuntime

41+ // so we can access all runtime properties too

42+ var wrappedRuntime = Object.create(runtime);

43+ wrappedRuntime.notify = notifyWrapper;

44+ wrappedRuntime.setTimeout = setTimeoutWrapper;

45+

46+ // make a copy of the wrappedRuntime

47+ var assignedPropTracker = Object.create(wrappedRuntime);

48+ var debuggedModule = module.make(assignedPropTracker);

49+

50+ // make sure the signal graph is actually a signal & extract the visual model

51+ if ( !('recv' in debuggedModule.main) ) {

52+ debuggedModule.main = Elm.Signal.make(runtime).constant(debuggedModule.main);

53+ }

54+

55+ // The main module stores imported modules onto the runtime.

56+ // To ensure only one instance of each module is created,

57+ // we assign them back on the original runtime object.

58+ Object.keys(assignedPropTracker).forEach(function(key) {

59+ runtime[key] = assignedPropTracker[key];

60+ });

61+

62+ var signalGraphNodes = flattenSignalGraph(wrappedRuntime.inputs);

63+ var tracePath = tracePathInit(runtime, debuggedModule.main);

64+

65+ snapshots.push(snapshotSignalGraph(signalGraphNodes));

66+

67+ function notifyWrapper(id, v) {

68+ var timestep = runtime.timer.now();

69+

70+ if (programPaused) {

71+ // ignore async events generated while playing back

72+ // or user events while program is paused

73+ return false;

74+ }

75+ else {

76+ recordEvent(id, v, timestep);

77+ var changed = runtime.notify(id, v, timestep);

78+ snapshotOnCheckpoint();

79+ if (parent.window) {

80+ parent.window.postMessage("elmNotify", window.location.origin);

81+ }

82+ return changed;

83+ }

84+ };

85+

86+ function setTimeoutWrapper(func, delayMs) {

87+ if (programPaused) {

88+ // Don't push timers and such to the callback stack while we're paused.

89+ // It causes too many callbacks to be fired during unpausing.

90+ return 0;

91+ }

92+ var cbObj = { func:func, delayMs:delayMs, timerId:0, executed:false };

93+ var timerId = setTimeout(function() {

94+ cbObj.executed = true;

95+ func();

96+ }, delayMs);

97+ cbObj.timerId = timerId;

98+ asyncCallbacks.push(cbObj);

99+ return timerId;

100+ }

101+

102+ function recordEvent(id, v, timestep) {

103+ watchTracker.pushFrame();

104+ recordedEvents.push({ id:id, value:v, timestep:timestep });

105+ runtime.debuggerStatus.eventCounter += 1;

106+ }

107+

108+ function clearAsyncCallbacks() {

109+ asyncCallbacks.forEach(function(timer) {

110+ if (!timer.executed) {

111+ clearTimeout(timer.timerId);

112+ }

113+ });

114+ }

115+

116+ function clearRecordedEvents() {

117+ recordedEvents = [];

118+ runtime.debuggerStatus.eventCounter = 0;

119+ }

120+

121+ function getRecordedEventsLength() {

122+ return recordedEvents.length;

123+ }

124+

125+ function getRecordedEventAt(i) {

126+ return recordedEvents[i];

127+ }

128+

129+ function copyRecordedEvents() {

130+ return recordedEvents.slice();

131+ }

132+

133+ function loadRecordedEvents(events) {

134+ recordedEvents = events.slice();

135+ }

136+

137+ function clearSnapshots() {

138+ snapshots = [snapshotSignalGraph(signalGraphNodes)];

139+ }

140+

141+ function getSnapshotAt(i) {

142+ var snapshotEvent = Math.floor(i / EVENTS_PER_SAVE);

143+ assert(snapshotEvent < snapshots.length && snapshotEvent >= 0,

144+ "Out of bounds index: " + snapshotEvent);

145+ return snapshots[snapshotEvent];

146+ }

147+

148+ function snapshotOnCheckpoint() {

149+ if (eventsUntilSnapshot === 1) {

150+ snapshots.push(snapshotSignalGraph(signalGraphNodes));

151+ eventsUntilSnapshot = EVENTS_PER_SAVE;

152+ } else {

153+ eventsUntilSnapshot -= 1;

154+ }

155+ }

156+

157+ function setPaused() {

158+ programPaused = true;

159+ clearAsyncCallbacks();

160+ pauseTime = Date.now();

161+ tracePath.stopRecording();

162+ preventInputEvents();

163+ }

164+

165+ function setContinue(position) {

166+ var pauseDelay = Date.now() - pauseTime;

167+ runtime.timer.addDelay(pauseDelay);

168+ programPaused = false;

169+

170+ // we need to dump the events that are ahead of where we're continuing.

171+ var lastSnapshotPosition = Math.floor(position / EVENTS_PER_SAVE);

172+ eventsUntilSnapshot = EVENTS_PER_SAVE - (position % EVENTS_PER_SAVE);

173+ snapshots = snapshots.slice(0, lastSnapshotPosition + 1);

174+

175+ if (position < getRecordedEventsLength()) {

176+ var lastEventTime = recordedEvents[position].timestep;

177+ var scrubTime = runtime.timer.now() - lastEventTime;

178+ runtime.timer.addDelay(scrubTime);

179+ }

180+

181+ recordedEvents = recordedEvents.slice(0, position);

182+ tracePath.clearTracesAfter(position);

183+ runtime.debuggerStatus.eventCounter = position;

184+ executeCallbacks(asyncCallbacks);

185+ permitInputEvents();

186+

187+ tracePath.startRecording();

188+ }

189+

190+ function getPaused() {

191+ return programPaused;

192+ }

193+

194+ function preventInputEvents(){

195+ var events =

196+ [ "click", "mousemove", "mouseup", "mousedown", "mouseclick"

197+ , "keydown", "keypress", "keyup", "touchstart", "touchend"

198+ , "touchcancel", "touchleave", "touchmove", "pointermove"

199+ , "pointerdown", "pointerup", "pointerover", "pointerout"

200+ , "pointerenter", "pointerleave", "pointercancel"

201+ ];

202+

203+ var ignore = function(e) {

204+ var evt = e ? e : window.event;

205+ if (evt.stopPropagation) {

206+ evt.stopPropagation();

207+ }

208+ if (evt.cancelBubble !== null) {

209+ evt.cancelBubble = true;

210+ }

211+ if (evt.preventDefault) {

212+ evt.preventDefault();

213+ }

214+ return false;

215+ };

216+

217+ var ignoringDiv = document.getElementById("elmEventIgnorer");

218+ if (!ignoringDiv) {

219+ ignoringDiv = document.createElement("div");

220+ ignoringDiv.id = "elmEventIgnorer";

221+ ignoringDiv.style.position = "absolute";

222+ ignoringDiv.style.top = "0px";

223+ ignoringDiv.style.left = "0px";

224+ ignoringDiv.style.width = "100%";

225+ ignoringDiv.style.height = "100%";

226+

227+ for (var i = events.length; i-- ;) {

228+ ignoringDiv.addEventListener(events[i], ignore, true);

229+ }

230+ runtime.node.appendChild(ignoringDiv);

231+ }

232+ }

233+

234+ function permitInputEvents(){

235+ var ignoringDiv = document.getElementById("elmEventIgnorer");

236+ ignoringDiv.parentNode.removeChild(ignoringDiv);

237+ }

238+

239+ return {

240+ debuggedModule: debuggedModule,

241+ signalGraphNodes: signalGraphNodes,

242+ initialSnapshot: snapshotSignalGraph(signalGraphNodes),

243+ initialAsyncCallbacks: asyncCallbacks.slice(),

244+ // API functions

245+ clearAsyncCallbacks: clearAsyncCallbacks,

246+ clearRecordedEvents: clearRecordedEvents,

247+ getRecordedEventsLength: getRecordedEventsLength,

248+ getRecordedEventAt: getRecordedEventAt,

249+ copyRecordedEvents: copyRecordedEvents,

250+ loadRecordedEvents: loadRecordedEvents,

251+ clearSnapshots: clearSnapshots,

252+ getSnapshotAt: getSnapshotAt,

253+ snapshotOnCheckpoint: snapshotOnCheckpoint,

254+ getPaused: getPaused,

255+ setPaused: setPaused,

256+ setContinue: setContinue,

257+ tracePath: tracePath,

258+ watchTracker: watchTracker

259+ };

260+}

261+

262+// The debuggerHistory variable is passed in on swap. It represents

263+// the a state of the debugger for it to assume during init. It contains

264+// the paused state of the debugger, the recorded events, and the current

265+// event being processed.

266+function debuggerInit(debugModule, runtime, debuggerHistory /* =undefined */) {

267+ var currentEventIndex = 0;

268+

269+ function resetProgram(position) {

270+ var closestSnapshot = debugModule.getSnapshotAt(position);

271+ debugModule.clearAsyncCallbacks();

272+ restoreSnapshot(debugModule.signalGraphNodes, closestSnapshot);

273+ redrawGraphics();

274+ }

275+

276+ function restartProgram() {

277+ pauseProgram();

278+ resetProgram(0);

279+ debugModule.watchTracker.clear();

280+ debugModule.tracePath.clearTraces();

281+ debugModule.setContinue(0);

282+ debugModule.clearRecordedEvents();

283+ debugModule.clearSnapshots();

284+ executeCallbacks(debugModule.initialAsyncCallbacks);

285+ }

286+

287+ function pauseProgram() {

288+ debugModule.setPaused();

289+ currentEventIndex = debugModule.getRecordedEventsLength();

290+ }

291+

292+ function continueProgram() {

293+ if (debugModule.getPaused())

294+ {

295+ var closestSnapshotIndex =

296+ Math.floor(currentEventIndex / EVENTS_PER_SAVE) * EVENTS_PER_SAVE;

297+ resetProgram(currentEventIndex);

298+ var continueIndex = currentEventIndex;

299+ currentEventIndex = closestSnapshotIndex;

300+ stepTo(continueIndex);

301+ debugModule.setContinue(currentEventIndex);

302+ }

303+ }

304+

305+ function stepTo(index) {

306+ if (!debugModule.getPaused()) {

307+ debugModule.setPaused();

308+ resetProgram();

309+ }

310+

311+ if (index < 0 || index > getMaxSteps()) {

312+ throw "Index out of bounds: " + index;

313+ }

314+

315+ if (index < currentEventIndex) {

316+ var closestSnapshotIndex = Math.floor(index / EVENTS_PER_SAVE) * EVENTS_PER_SAVE;

317+ resetProgram(index);

318+ currentEventIndex = closestSnapshotIndex;

319+ }

320+

321+ while (currentEventIndex < index) {

322+ var nextEvent = debugModule.getRecordedEventAt(currentEventIndex);

323+ runtime.notify(nextEvent.id, nextEvent.value, nextEvent.timestep);

324+

325+ currentEventIndex += 1;

326+ }

327+ }

328+

329+ function getMaxSteps() {

330+ return debugModule.getRecordedEventsLength();

331+ }

332+

333+ function redrawGraphics() {

334+ var main = debugModule.debuggedModule.main

335+ for (var i = main.kids.length ; i-- ; ) {

336+ main.kids[i].recv(runtime.timer.now(), true, main.id);

337+ }

338+ }

339+

340+ function getSwapState() {

341+ var continueIndex = currentEventIndex;

342+ if (!debugModule.getPaused()) {

343+ continueIndex = getMaxSteps();

344+ }

345+ return {

346+ paused: debugModule.getPaused(),

347+ recordedEvents: debugModule.copyRecordedEvents(),

348+ currentEventIndex: continueIndex

349+ };

350+ }

351+

352+ function dispose() {

353+ var parentNode = runtime.node.parentNode;

354+ parentNode.removeChild(debugModule.tracePath.canvas);

355+ parentNode.removeChild(runtime.node);

356+ }

357+

358+ if (debuggerHistory) {

359+ // The problem is that we want to previous paused state. But

360+ // by the time JS reaches here, the old code has been swapped out

361+ // and the new modules are being generated. So we can ask the

362+ // debugging console what it thinks the pause state is and go

363+ // from there.

364+ var paused = debuggerHistory.paused;

365+ debugModule.setPaused();

366+ debugModule.loadRecordedEvents(debuggerHistory.recordedEvents);

367+ var index = getMaxSteps();

368+ runtime.debuggerStatus.eventCounter = 0;

369+ debugModule.tracePath.clearTraces();

370+

371+ // draw new trace path

372+ debugModule.tracePath.startRecording();

373+ while(currentEventIndex < index) {

374+ var nextEvent = debugModule.getRecordedEventAt(currentEventIndex);

375+ runtime.debuggerStatus.eventCounter += 1;

376+ runtime.notify(nextEvent.id, nextEvent.value, nextEvent.timestep);

377+ debugModule.snapshotOnCheckpoint();

378+ currentEventIndex += 1;

379+ }

380+ debugModule.tracePath.stopRecording();

381+

382+ stepTo(debuggerHistory.currentEventIndex);

383+ if (!paused) {

384+ debugModule.setContinue(debuggerHistory.currentEventIndex);

385+ }

386+ }

387+

388+ runtime.node.parentNode.appendChild(debugModule.tracePath.canvas);

389+

390+ var elmDebugger = {

391+ restart: restartProgram,

392+ pause: pauseProgram,

393+ kontinue: continueProgram,

394+ getMaxSteps: getMaxSteps,

395+ stepTo: stepTo,

396+ getPaused: debugModule.getPaused,

397+ getSwapState: getSwapState,

398+ dispose: dispose,

399+ allNodes: debugModule.signalGraphNodes,

400+ watchTracker: debugModule.watchTracker

401+ };

402+

403+ return elmDebugger;

404+}

405+

406+function Point(x, y) {

407+ this.x = x;

408+ this.y = y;

409+

410+ this.translate = function(x, y) {

411+ return new Point(this.x + x, this.y + y);

412+ }

413+

414+ this.equals = function(p) {

415+ return this.x == p.x && this.y == p.y;

416+ }

417+}

418+

419+function tracePathInit(runtime, signalGraphMain) {

420+ var List = Elm.List.make(runtime);

421+ var Signal = Elm.Signal.make(runtime);

422+ var tracePathNode = A2(Signal.lift, graphicsUpdate, signalGraphMain);

423+ var tracePathCanvas = createCanvas();

424+ var tracePositions = {};

425+ var recordingTraces = true;

426+

427+ function findPositions(currentScene) {

428+ var positions = {};

429+ function processElement(elem, offset) {

430+ if (elem.element.ctor == "Custom" && elem.element.type == "Collage")

431+ {

432+ List.map(F2(processForm)(offset))(elem.element.model.forms);

433+ }

434+ }

435+

436+ function processForm(offset, form) {

437+ if (form.form.ctor == "FElement")

438+ {

439+ processElement(form.form._0, offset.translate(form.x, -form.y));

440+ }

441+ if (form.form.ctor == "FGroup")

442+ {

443+ var newOffset = offset.translate(form.x, -form.y);

444+ List.map(F2(processForm)(newOffset))(form.form._1);

445+ }

446+ if (form.debugTracePathId)

447+ {

448+ positions[form.debugTracePathId] = new Point(form.x + offset.x, -form.y + offset.y);

449+ }

450+ }

451+

452+ processElement(currentScene, new Point(0, 0));

453+ return positions;

454+ }

455+

456+ function appendPositions(positions) {

457+ for (var id in positions) {

458+ var pos = positions[id];

459+ if (tracePositions.hasOwnProperty(id)) {

460+ tracePositions[id].push(pos);

461+ }

462+ else {

463+ tracePositions[id] = [pos];

464+ }

465+ if (tracePositions[id].length < runtime.debuggerStatus.eventCounter) {

466+ var padCount = runtime.debuggerStatus.eventCounter - tracePositions[id].length;

467+ var lastTracePosition = tracePositions[id][tracePositions[id].length - 1];

468+ for (var i = padCount; i--;) {

469+ tracePositions[id].push(lastTracePosition)

470+ }

471+ }

472+ assert(tracePositions[id].length === runtime.debuggerStatus.eventCounter,

473+ "We don't have a 1-1 mapping of trace positions to events");

474+ }

475+ }

476+

477+ function graphicsUpdate(currentScene) {

478+ if (!recordingTraces) {

479+ return;

480+ }

481+

482+ var ctx = tracePathCanvas.getContext('2d');

483+ ctx.clearRect(0, 0, tracePathCanvas.width, tracePathCanvas.height);

484+

485+ ctx.save();

486+ ctx.translate(ctx.canvas.width/2, ctx.canvas.height/2);

487+ appendPositions(findPositions(currentScene));

488+ for (var id in tracePositions)

489+ {

490+ ctx.beginPath();

491+ var points = tracePositions[id];

492+ for (var i=0; i < points.length; i++)

493+ {

494+ var p = points[i];

495+ if (i == 0) {

496+ ctx.moveTo(p.x, p.y);

497+ }

498+ else {

499+ ctx.lineTo(p.x, p.y);

500+ }

501+ }

502+ ctx.lineWidth = 1;

503+ ctx.strokeStyle = "rgba(50, 50, 50, 0.4)";

504+ ctx.stroke();

505+ }

506+

507+ ctx.restore();

508+ }

509+

510+ function clearTraces() {

511+ tracePositions = {};

512+ }

513+

514+ function stopRecording() {

515+ recordingTraces = false;

516+ }

517+

518+ function startRecording() {

519+ recordingTraces = true;

520+ }

521+

522+ function clearTracesAfter(position) {

523+ var newTraces = {};

524+ for (var id in tracePositions) {

525+ newTraces[id] = tracePositions[id].slice(0,position);

526+ }

527+ tracePositions = newTraces;

528+ }

529+

530+ return {

531+ graphicsUpdate: graphicsUpdate,

532+ canvas: tracePathCanvas,

533+ clearTraces: clearTraces,

534+ clearTracesAfter: clearTracesAfter,

535+ stopRecording: stopRecording,

536+ startRecording: startRecording

537+ }

538+}

539+

540+function executeCallbacks(callbacks) {

541+ callbacks.forEach(function(timer) {

542+ if (!timer.executed) {

543+ var func = timer.func;

544+ timer.executed = true;

545+ func();

546+ }

547+ });

548+}

549+

550+function createCanvas() {

551+ var c = document.createElement('canvas');

552+ c.width = window.innerWidth;

553+ c.height = window.innerHeight;

554+ c.style.position = "absolute";

555+ c.style.top = "0";

556+ c.style.left = "0";

557+ c.style.pointerEvents = "none";

558+ return c;

559+}

560+

561+function assert(bool, msg) {

562+ if (!bool) {

563+ throw "Assertion error: " + msg;

564+ }

565+}

566+

567+function snapshotSignalGraph(signalGraphNodes) {

568+ var nodeValues = [];

569+

570+ signalGraphNodes.forEach(function(node) {

571+ nodeValues.push({ value: node.value, id: node.id });

572+ });

573+

574+ return nodeValues;

575+};

576+

577+function restoreSnapshot(signalGraphNodes, snapshot) {

578+ assert(signalGraphNodes.length == snapshot.length,

579+ "saved program state has wrong length");

580+ for (var i=0; i < signalGraphNodes.length; i++) {

581+ var node = signalGraphNodes[i];

582+ var state = snapshot[i];

583+ assert(node.id == state.id, "the nodes moved position");

584+

585+ node.value = state.value;

586+ }

587+}

588+

589+function flattenSignalGraph(nodes) {

590+ var nodesById = {};

591+

592+ function addAllToDict(node) {

593+ nodesById[node.id] = node;

594+ node.kids.forEach(addAllToDict);

595+ }

596+ nodes.forEach(addAllToDict);

597+

598+ var allNodes = Object.keys(nodesById).sort().map(function(key) {

599+ return nodesById[key];

600+ });

601+ return allNodes;

602+};

603+

604+}());

runtime/Init.js+44−5

@@ -31,21 +31,47 @@ function init(display, container, module, ports, moduleToReplace) {

31 // defining state needed for an instance of the Elm RTS

32 var inputs = [];

33

34+ /* OFFSET

35+ * Elm's time traveling debugger lets you interrupt the smooth flow of time

36+ * by pausing and continuing program execution. To ensure the user sees a

37+ * program that moves smoothly through the pause/continue time gap,

38+ * we need to adjsut the value of Date.now().

39+ */

40+ var timer = function() {

41+ var inducedDelay = 0;

42+

43+ var now = function() {

44+ return Date.now() - inducedDelay;

45+ };

46+

47+ var addDelay = function(d) {

48+ inducedDelay += d;

49+ return inducedDelay;

50+ };

51+

52+ return { now : now

53+ , addDelay : addDelay

54+ }

55+ }();

56+

34 var updateInProgress = false;

57 var updateInProgress = false;

35 function notify(id, v) {

58 function notify(id, v) {

36 if (updateInProgress) {

59 if (updateInProgress) {

37 throw new Error(

60 throw new Error(

38 'The notify function has been called synchronously!\n' +

61 'The notify function has been called synchronously!\n' +

39 'This can lead to frames being dropped.\n' +

62 'This can lead to frames being dropped.\n' +

40− 'Definitely report this to <https://github.com/evancz/Elm/issues>\n');

63+ 'Definitely report this to <https://github.com/elm-lang/Elm/issues>\n');

41 }

64 }

42 updateInProgress = true;

65 updateInProgress = true;

43− var timestep = Date.now();

66+ var timestep = timer.now();

44 for (var i = inputs.length; i--; ) {

67 for (var i = inputs.length; i--; ) {

45 inputs[i].recv(timestep, id, v);

68 inputs[i].recv(timestep, id, v);

46 }

69 }

47 updateInProgress = false;

70 updateInProgress = false;

48 }

71 }

72+ function setTimeout(func, delay) {

73+ window.setTimeout(func, delay);

74+ }

49

75

50 var listeners = [];

76 var listeners = [];

51 function addListener(relevantInputs, domNode, eventName, func) {

77 function addListener(relevantInputs, domNode, eventName, func) {

@@ -67,11 +93,13 @@ function init(display, container, module, ports, moduleToReplace) {

67 // object. This permits many Elm programs to be embedded per document.

93 // object. This permits many Elm programs to be embedded per document.

68 var elm = {

94 var elm = {

69 notify:notify,

95 notify:notify,

96+ setTimeout:setTimeout,

70 node:container,

97 node:container,

71 display:display,

98 display:display,

72 id:ElmRuntime.guid(),

99 id:ElmRuntime.guid(),

73 addListener:addListener,

100 addListener:addListener,

74 inputs:inputs,

101 inputs:inputs,

102+ timer:timer,

75 ports: { incoming:ports, outgoing:{}, uses:portUses }

103 ports: { incoming:ports, outgoing:{}, uses:portUses }

76 };

104 };

77

105

@@ -84,6 +112,11 @@ function init(display, container, module, ports, moduleToReplace) {

84 return newElm;

112 return newElm;

85 }

113 }

86

114

115+ function dispose() {

116+ removeListeners(listeners);

117+ inputs = [];

118+ }

119+

87 var Module = {};

120 var Module = {};

88 var reportAnyErrors = function() {};

121 var reportAnyErrors = function() {};

89 try {

122 try {

@@ -110,7 +143,11 @@ function init(display, container, module, ports, moduleToReplace) {

110 }

143 }

111

144

112 reportAnyErrors();

145 reportAnyErrors();

113− return { swap:swap, ports:elm.ports.outgoing };

146+ return {

147+ swap:swap,

148+ ports:elm.ports.outgoing,

149+ dispose:dispose

150+ };

114};

151};

115

152

116function checkPorts(elm) {

153function checkPorts(elm) {

@@ -203,8 +240,9 @@ function addReceivers(ports) {

203}

240}

204

241

205function initGraphics(elm, Module) {

242function initGraphics(elm, Module) {

206− if (!('main' in Module))

243+ if (!('main' in Module)) {

207 throw new Error("'main' is missing! What do I display?!");

244 throw new Error("'main' is missing! What do I display?!");

245+ }

208

246

209 var signalGraph = Module.main;

247 var signalGraph = Module.main;

210

248

@@ -221,8 +259,9 @@ function initGraphics(elm, Module) {

221

259

222 // set up updates so that the DOM is adjusted as necessary.

260 // set up updates so that the DOM is adjusted as necessary.

223 var savedScene = currentScene;

261 var savedScene = currentScene;

262+ var previousDrawId = 0;

224 function domUpdate(newScene) {

263 function domUpdate(newScene) {

225− ElmRuntime.draw(function(_) {

264+ previousDrawId = ElmRuntime.draw(previousDrawId, function(_) {

226 Render.update(elm.node.firstChild, savedScene, newScene);

265 Render.update(elm.node.firstChild, savedScene, newScene);

227 if (elm.Native.Window) elm.Native.Window.values.resizeIfNeeded();

266 if (elm.Native.Window) elm.Native.Window.values.resizeIfNeeded();

228 savedScene = newScene;

267 savedScene = newScene;

runtime/Render/Collage.js+2−2

@@ -21,7 +21,7 @@ function trace(ctx, path) {

21}

22

23function line(ctx,style,path) {

24− style.dashing.ctor === 'Nil' ? trace(ctx, path) : customLineHelp(ctx, style, path);

24+ style.dashing.ctor === '[]' ? trace(ctx, path) : customLineHelp(ctx, style, path);

25 ctx.scale(1,-1);

26 ctx.stroke();

27}

@@ -301,7 +301,7 @@ function nodeStepper(w,h,div) {

301 : (Render.update(kid, kid.oldElement, elem), kids[i]);

302

303 node.style.position = 'absolute';

304− node.style.opacity = alpha * form.alpha;

304+ node.style.opacity = alpha * form.alpha * elem.props.opacity;

305 addTransform(node.style, makeTransform(w, h, form, matrices));

306 node.oldElement = elem;

307 ++i;

runtime/Render/Element.js+125−73

@@ -3,44 +3,52 @@ ElmRuntime.Render.Element = function() {

3'use strict';

4

5var Utils = ElmRuntime.use(ElmRuntime.Render.Utils);

6−var newElement = Utils.newElement, colorToCss = Utils.colorToCss,

6+var newElement = Utils.newElement;

7− addTransform = Utils.addTransform, removeTransform = Utils.removeTransform,

7+var colorToCss = Utils.colorToCss;

8− fromList = Utils.fromList, eq = Utils.eq;

8+var addTransform = Utils.addTransform;

9+var removeTransform = Utils.removeTransform;

10+var fromList = Utils.fromList;

11+var eq = Utils.eq;

9

12

10−function setProps(elem, e) {

13+function setProps(elem, node) {

11 var props = elem.props;

14 var props = elem.props;

15+

12 var element = elem.element;

16 var element = elem.element;

13 var width = props.width - (element.adjustWidth || 0);

17 var width = props.width - (element.adjustWidth || 0);

14 var height = props.height - (element.adjustHeight || 0);

18 var height = props.height - (element.adjustHeight || 0);

15− e.style.width = (width |0) + 'px';

19+ node.style.width = (width |0) + 'px';

16− e.style.height = (height|0) + 'px';

20+ node.style.height = (height|0) + 'px';

21+

17 if (props.opacity !== 1) {

22 if (props.opacity !== 1) {

18− e.style.opacity = props.opacity;

23+ node.style.opacity = props.opacity;

19 }

24 }

25+

20 if (props.color.ctor === 'Just') {

26 if (props.color.ctor === 'Just') {

21− e.style.backgroundColor = colorToCss(props.color._0);

27+ node.style.backgroundColor = colorToCss(props.color._0);

22 }

28 }

23− if (props.tag !== '') { e.id = props.tag; }

29+

24− if (props.href !== '') {

30+ if (props.tag !== '') {

25− var a = newElement('a');

31+ node.id = props.tag;

26− a.href = props.href;

27− a.style.width = '100%';

28− a.style.height = '100%';

29− a.style.top = 0;

30− a.style.left = 0;

31− a.style.display = 'block';

32− a.style.position = 'absolute';

33− e.style.position = 'relative';

34− a.style.pointerEvents = 'auto';

35− e.appendChild(a);

36 }

32 }

33+

37 if (props.hover.ctor !== '_Tuple0') {

34 if (props.hover.ctor !== '_Tuple0') {

38− addHover(e, props.hover);

35+ addHover(node, props.hover);

39 }

36 }

37+

40 if (props.click.ctor !== '_Tuple0') {

38 if (props.click.ctor !== '_Tuple0') {

41− addClick(e, props.click);

39+ addClick(node, props.click);

42 }

40 }

43− return e;

41+

42+ if (props.href !== '') {

43+ var anchor = newElement('a');

44+ anchor.href = props.href;

45+ anchor.style.display = 'block';

46+ anchor.style.pointerEvents = 'auto';

47+ anchor.appendChild(node);

48+ node = anchor;

49+ }

50+

51+ return node;

44}

52}

45

53

46function addClick(e, handler) {

54function addClick(e, handler) {

@@ -57,6 +65,8 @@ function addClick(e, handler) {

57function removeClick(e, handler) {

65function removeClick(e, handler) {

58 if (e.elm_click_trigger) {

66 if (e.elm_click_trigger) {

59 e.removeEventListener('click', e.elm_click_trigger);

67 e.removeEventListener('click', e.elm_click_trigger);

68+ e.elm_click_trigger = null;

69+ e.elm_click_handler = null;

60 }

70 }

61}

71}

62

72

@@ -83,11 +93,14 @@ function addHover(e, handler) {

83}

93}

84

94

85function removeHover(e) {

95function removeHover(e) {

96+ e.elm_hover_handler = null;

86 if (e.elm_hover_over) {

97 if (e.elm_hover_over) {

87 e.removeEventListener('mouseover', e.elm_hover_over);

98 e.removeEventListener('mouseover', e.elm_hover_over);

99+ e.elm_hover_over = null;

88 }

100 }

89 if (e.elm_hover_out) {

101 if (e.elm_hover_out) {

90 e.removeEventListener('mouseout', e.elm_hover_out);

102 e.removeEventListener('mouseout', e.elm_hover_out);

103+ e.elm_hover_out = null;

91 }

104 }

92}

105}

93

106

@@ -248,7 +261,9 @@ function rawHtml(elem) {

248 return div;

261 return div;

249}

262}

250

263

251−function render(elem) { return setProps(elem, makeElement(elem)); }

264+function render(elem) {

265+ return setProps(elem, makeElement(elem));

266+}

252function makeElement(e) {

267function makeElement(e) {

253 var elem = e.element;

268 var elem = e.element;

254 switch(elem.ctor) {

269 switch(elem.ctor) {

@@ -262,8 +277,12 @@ function makeElement(e) {

262}

277}

263

278

264function update(node, curr, next) {

279function update(node, curr, next) {

265− if (node.tagName === 'A') { node = node.firstChild; }

280+ if (node.tagName === 'A') {

266− if (curr.props.id === next.props.id) return updateProps(node, curr, next);

281+ node = node.firstChild;

282+ }

283+ if (curr.props.id === next.props.id) {

284+ return updateProps(node, curr, next);

285+ }

267 if (curr.element.ctor !== next.element.ctor) {

286 if (curr.element.ctor !== next.element.ctor) {

268 node.parentNode.replaceChild(render(next),node);

287 node.parentNode.replaceChild(render(next),node);

269 return true;

288 return true;

@@ -354,61 +373,94 @@ function update(node, curr, next) {

354}

373}

355

374

356function updateProps(node, curr, next) {

375function updateProps(node, curr, next) {

357− var props = next.props;

376+ var nextProps = next.props;

358− var currP = curr.props;

377+ var currProps = curr.props;

359− var e = node;

378+

360 var element = next.element;

379 var element = next.element;

361− var width = props.width - (element.adjustWidth || 0);

380+ var width = nextProps.width - (element.adjustWidth || 0);

362− var height = props.height - (element.adjustHeight || 0);

381+ var height = nextProps.height - (element.adjustHeight || 0);

363− if (width !== currP.width) {

382+ if (width !== currProps.width) {

364− e.style.width = (width|0) + 'px';

383+ node.style.width = (width|0) + 'px';

365− }

384+ }

366− if (height !== currP.height) {

385+ if (height !== currProps.height) {

367− e.style.height = (height|0) + 'px';

386+ node.style.height = (height|0) + 'px';

368− }

387+ }

369− if (props.opacity !== currP.opacity) {

388+

370− e.style.opacity = props.opacity;

389+ if (nextProps.opacity !== currProps.opacity) {

371− }

390+ node.style.opacity = nextProps.opacity;

372− var nextColor = (props.color.ctor === 'Just' ?

391+ }

373− colorToCss(props.color._0) : '');

392+

374− if (e.style.backgroundColor !== nextColor) {

393+ var nextColor = nextProps.color.ctor === 'Just'

375− e.style.backgroundColor = (nextColor === '' ? 'transparent' : nextColor);

394+ ? colorToCss(nextProps.color._0)

376− }

395+ : 'transparent';

377− if (props.tag !== currP.tag) { e.id = props.tag; }

396+ if (node.style.backgroundColor !== nextColor) {

378− if (props.href !== currP.href) {

397+ node.style.backgroundColor = nextColor;

379− if (currP.href === '') {

398+ }

380− var a = newElement('a');

399+

381− a.href = props.href;

400+ if (nextProps.tag !== currProps.tag) {

382− a.style.width = '100%';

401+ node.id = nextProps.tag;

383− a.style.height = '100%';

402+ }

384− a.style.top = 0;

403+

385− a.style.left = 0;

404+ if (nextProps.href !== currProps.href) {

386− a.style.display = 'block';

405+ if (currProps.href === '') {

387− a.style.position = 'absolute';

406+ // add a surrounding href

388− e.style.position = 'relative';

407+ var anchor = newElement('a');

389− a.style.pointerEvents = 'auto';

408+ anchor.href = nextProps.href;

390− e.appendChild(a);

409+ anchor.style.display = 'block';

410+ anchor.style.pointerEvents = 'auto';

411+

412+ node.parentNode.replaceChild(anchor, node);

413+ anchor.appendChild(node);

414+ } else if (nextProps.href === '') {

415+ // remove the surrounding href

416+ var anchor = node.parentNode;

417+ anchor.parentNode.replaceChild(node, anchor);

391 } else {

418 } else {

392− node.lastNode.href = props.href;

419+ // just update the link

420+ node.parentNode.href = nextProps.href;

393 }

421 }

394 }

422 }

395

423

424+ // update click and hover handlers

425+ var removed = false;

426+

396 // update hover handlers

427 // update hover handlers

397− if (props.hover.ctor === '_Tuple0') {

428+ if (currProps.hover.ctor === '_Tuple0') {

398− removeHover(e);

429+ if (nextProps.hover.ctor !== '_Tuple0') {

399− } else if (e.elm_hover_handler) {

430+ addHover(node, nextProps.hover);

400− e.elm_hover_handler = props.hover;

431+ }

401− } else {

432+ }

402− addHover(e, props.hover);

433+ else {

434+ if (nextProps.hover.ctor === '_Tuple0') {

435+ removed = true;

436+ removeHover(node);

437+ }

438+ else {

439+ node.elm_hover_handler = nextProps.hover;

440+ }

403 }

441 }

404

442

405 // update click handlers

443 // update click handlers

406− if (props.click.ctor === '_Tuple0') {

444+ if (currProps.click.ctor === '_Tuple0') {

407− removeClick(e);

445+ if (nextProps.click.ctor !== '_Tuple0') {

408− } else if (e.elm_click_handler) {

446+ addClick(node, nextProps.click);

409− e.elm_click_handler = props.click;

447+ }

410− } else {

448+ }

411− addClick(e, props.click);

449+ else {

450+ if (nextProps.click.ctor === '_Tuple0') {

451+ removed = true;

452+ removeClick(node);

453+ } else {

454+ node.elm_click_handler = nextProps.click;

455+ }

456+ }

457+

458+ // stop capturing clicks if

459+ if (removed

460+ && nextProps.hover.ctor === '_Tuple0'

461+ && nextProps.click.ctor === '_Tuple0')

462+ {

463+ node.style.pointerEvents = 'none';

412 }

464 }

413}

465}

414

466

runtime/Utils.js+14−6

@@ -32,7 +32,13 @@ ElmRuntime.filterDeadInputs = function(inputs) {

32 return temp;

33};

34

35−// define the draw function

35+// define function for drawing efficiently

36+//

37+// draw : RequestID -> (() -> ()) -> RequestID

38+//

39+// Takes a "RequestID" allowing you to cancel old requests if possible.

40+// Returns a "RequestID" so you can refer to past requests.

41+//

36var vendors = ['ms', 'moz', 'webkit', 'o'];

42var vendors = ['ms', 'moz', 'webkit', 'o'];

37var win = typeof window !== 'undefined' ? window : {};

43var win = typeof window !== 'undefined' ? window : {};

38for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {

44for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {

@@ -42,13 +48,15 @@ for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {

42}

48}

43

49

44if (win.requestAnimationFrame && win.cancelAnimationFrame) {

50if (win.requestAnimationFrame && win.cancelAnimationFrame) {

45− var previous = 0;

51+ ElmRuntime.draw = function(previousRequestID, callback) {

46− ElmRuntime.draw = function(callback) {

52+ win.cancelAnimationFrame(previousRequestID);

47− win.cancelAnimationFrame(previous);

53+ return win.requestAnimationFrame(callback);

48− previous = win.requestAnimationFrame(callback);

49 };

54 };

50} else {

55} else {

51− ElmRuntime.draw = function(callback) { callback(); };

56+ ElmRuntime.draw = function(previousRequestID, callback) {

57+ callback();

58+ return previousRequestID;

59+ };

52}

60}

53

61

54}());

62}());

tests/compiler/Tests/Compiler.hs+57−40

@@ -1,45 +1,62 @@

1−module Tests.Compiler (compilerTests)

1+{-# OPTIONS_GHC -W #-}

2− where

2+module Tests.Compiler (compilerTests) where

3+

4+import Data.Traversable (traverse)

5+

6+import System.Exit

7+import System.FilePath ((</>))

8+import System.FilePath.Find (find, (==?), extension)

9+import System.Process (readProcessWithExitCode)

3

10

4−import Data.Functor ((<$>))

5−import Data.Traversable (traverse)

6−import System.FilePath ((</>))

7−import System.FilePath.Find (find, (==?), extension)

8import Test.Framework

11import Test.Framework

9import Test.Framework.Providers.HUnit (testCase)

12import Test.Framework.Providers.HUnit (testCase)

10−import Test.HUnit (Assertion, assertFailure, assertBool)

13+import Test.HUnit (Assertion, assertFailure, assertBool)

11−import Text.Parsec (ParseError)

12−

13−import Elm.Internal.Utils as Elm

14

15compilerTests :: Test

16−compilerTests = buildTest $ do

16+compilerTests =

17− goods <- mkTests goodCompile =<< getElms "good"

17+ buildTest $ do

18− bads <- mkTests badCompile =<< getElms "bad"

18+ goods <- testIf isSuccess =<< getElms "good"

19− return $ testGroup "Compile Tests"

19+ bads <- testIf isFailure =<< getElms "bad"

20− [

20+ return $ testGroup "Compile Tests"

21− testGroup "Good Tests" goods

21+ [ testGroup "Good Tests" goods

22− , testGroup "Bad Tests" bads

22+ , testGroup "Bad Tests" bads

23− ]

23+ ]

24−

24+

25− where getElms :: FilePath -> IO [FilePath]

25+-- COLLECT FILES

26− getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)

26+

27−

27+getElms :: FilePath -> IO [FilePath]

28− mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]

28+getElms filePath =

29− mkTests h = traverse setupTest

29+ find (return True) (extension ==? ".elm") (testsDir </> filePath)

30− where setupTest f = testCase f . mkCompileTest h <$> readFile f

30+

31−

31+testsDir :: FilePath

32− testsDir = "tests" </> "test-files"

32+testsDir = "tests" </> "compiler" </> "test-files"

33−

33+

34−goodCompile :: Either String String -> Assertion

34+

35−goodCompile (Left err) = assertFailure err

35+-- RUN COMPILER

36−goodCompile (Right _) = assertBool "" True

36+

37−

37+testIf :: (ExitCode -> String -> Assertion) -> [FilePath] -> IO [Test]

38−badCompile :: Either String String -> Assertion

38+testIf handler filePaths =

39−badCompile (Left _) = assertBool "" True

39+ traverse setupTest filePaths

40−badCompile (Right _) = assertFailure "Compilation succeeded but should have failed"

40+ where

41−

41+ setupTest filePath = do

42−mkCompileTest :: ((Either String String) -> Assertion) -- ^ Handler

42+ let args = [ "--make", "--src-dir=" ++ testsDir, filePath ]

43− -> String -- ^ File Contents

43+ (exitCode, stdout, stderr) <- readProcessWithExitCode compiler args ""

44− -> Assertion

44+ return (testCase filePath (handler exitCode (stdout ++ stderr)))

45−mkCompileTest handle = handle . Elm.compile

45+

46+compiler :: FilePath

47+compiler = "dist" </> "build" </> "elm" </> "elm"

48+

49+

50+-- CHECK RESULTS

51+

52+isSuccess :: ExitCode -> String -> Assertion

53+isSuccess exitCode stderr =

54+ case exitCode of

55+ ExitSuccess -> assertBool "" True

56+ ExitFailure _ -> assertFailure stderr

57+

58+isFailure :: ExitCode -> String -> Assertion

59+isFailure exitCode _stderr =

60+ case exitCode of

61+ ExitSuccess -> assertFailure "Compilation succeeded but should have failed"

62+ ExitFailure _ -> assertBool "" True

tests/compiler/Tests/Property.hs+23−22

@@ -9,11 +9,12 @@ import Test.QuickCheck

9import Text.Parsec.Combinator (eof)

10import Text.PrettyPrint as P

11

12−import SourceSyntax.Literal as Lit

12+import AST.Literal as Lit

13−import qualified SourceSyntax.Pattern as P

13+import qualified AST.Pattern as P

14−import SourceSyntax.PrettyPrint (Pretty, pretty)

14+import qualified AST.Variable as V

15−import Parse.Helpers (IParser, iParse)

15+import AST.PrettyPrint (Pretty, pretty)

16−import Parse.Literal (literal)

16+import Parse.Helpers (IParser, iParse)

17+import Parse.Literal (literal)

17import qualified Parse.Pattern as Pat (expr)

18import qualified Parse.Pattern as Pat (expr)

18import qualified Parse.Type as Type (expr)

19import qualified Parse.Type as Type (expr)

19import Tests.Property.Arbitrary

20import Tests.Property.Arbitrary

@@ -21,8 +22,7 @@ import Tests.Property.Arbitrary

21propertyTests :: Test

22propertyTests :: Test

22propertyTests =

23propertyTests =

23 testGroup "Parse/Print Agreement Tests"

24 testGroup "Parse/Print Agreement Tests"

24− [

25+ [ testCase "Long Pattern test" $ assert (prop_parse_print Pat.expr longPat)

25− testCase "Long Pattern test" $ assert (prop_parse_print Pat.expr longPat)

26 , testProperty "Literal test" $ prop_parse_print literal

27 , testProperty "Pattern test" $ prop_parse_print Pat.expr

28 , testProperty "Type test" $ prop_parse_print Type.expr

@@ -31,21 +31,22 @@ propertyTests =

31 where

32 -- This test was autogenerated from the Pattern test and should be

33 -- left in all its ugly glory.

34− longPat = P.Data "I" [ P.Literal (Lit.Chr '+')

34+ longPat = P.Data (V.Raw "I")

35− , P.Record

35+ [ P.Literal (Lit.Chr '+')

36− [ "q7yclkcm7k_ikstrczv_"

36+ , P.Record

37− , "wQRv6gKsvvkjw4b5F"

37+ [ "q7yclkcm7k_ikstrczv_"

38− ,"c9'eFfhk9FTvsMnwF_D"

38+ , "wQRv6gKsvvkjw4b5F"

39− ,"yqxhEkHvRFwZ"

39+ ,"c9'eFfhk9FTvsMnwF_D"

40− ,"o"

40+ ,"yqxhEkHvRFwZ"

41− ,"nbUlCn3y3NnkVoxhW"

41+ ,"o"

42− ,"iJ0MNy3KZ_lrs"

42+ ,"nbUlCn3y3NnkVoxhW"

43− ,"ug"

43+ ,"iJ0MNy3KZ_lrs"

44− ,"sHHsX"

44+ ,"ug"

45− ,"mRKs9d"

45+ ,"sHHsX"

46− ,"o2KiCX5'ZRzHJfRi8" ]

46+ ,"mRKs9d"

47− , P.Var "su'BrrbPUK6I33Eq"

47+ ,"o2KiCX5'ZRzHJfRi8" ]

48− ]

48+ , P.Var "su'BrrbPUK6I33Eq"

49+ ]

49

50

50prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool

51prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool

51prop_parse_print p x =

52prop_parse_print p x =

tests/compiler/Tests/Property/Arbitrary.hs+21−12

@@ -8,9 +8,14 @@ import Test.QuickCheck.Gen

8import qualified Data.Set as Set

9import qualified Parse.Helpers (reserveds)

10

11−import qualified SourceSyntax.Literal as L

11+import qualified AST.Literal as L

12−import qualified SourceSyntax.Pattern as P

12+import qualified AST.Pattern as P

13−import qualified SourceSyntax.Type as T

13+import qualified AST.Type as T

14+import qualified AST.Variable as V

15+

16+instance Arbitrary V.Raw where

17+ arbitrary = V.Raw <$> capVar

18+ shrink (V.Raw v) = V.Raw <$> shrink v

14

19

15instance Arbitrary L.Literal where

20instance Arbitrary L.Literal where

16 arbitrary =

21 arbitrary =

@@ -41,10 +46,10 @@ genVector n generator = do

41 let m = n `div` (len + 1)

46 let m = n `div` (len + 1)

42 vectorOf len $ generator m

47 vectorOf len $ generator m

43

48

44−instance Arbitrary P.Pattern where

49+instance Arbitrary v => Arbitrary (P.Pattern v) where

45 arbitrary = sized pat

50 arbitrary = sized pat

46 where

51 where

47− pat :: Int -> Gen P.Pattern

52+ pat :: (Arbitrary v) => Int -> Gen (P.Pattern v)

48 pat n =

53 pat n =

49 oneof

54 oneof

50 [ pure P.Anything

55 [ pure P.Anything

@@ -52,7 +57,7 @@ instance Arbitrary P.Pattern where

52 , P.Record <$> (listOf1 lowVar)

57 , P.Record <$> (listOf1 lowVar)

53 , P.Literal <$> arbitrary

58 , P.Literal <$> arbitrary

54 , P.Alias <$> lowVar <*> pat (n-1)

59 , P.Alias <$> lowVar <*> pat (n-1)

55− , P.Data <$> capVar <*> genVector n pat

60+ , P.Data <$> arbitrary <*> genVector n pat

56 ]

61 ]

57

62

58 shrink pat =

63 shrink pat =

@@ -61,7 +66,7 @@ instance Arbitrary P.Pattern where

61 P.Var v -> P.Var <$> shrinkWHead v

66 P.Var v -> P.Var <$> shrinkWHead v

62 P.Literal l -> P.Literal <$> shrink l

67 P.Literal l -> P.Literal <$> shrink l

63 P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)

68 P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)

64− P.Data s ps -> ps ++ (P.Data <$> shrinkWHead s <*> shrink ps)

69+ P.Data s ps -> ps ++ (P.Data <$> shrink s <*> shrink ps)

65 P.Record fs ->

70 P.Record fs ->

66 P.Record <$> filter (all notNull) (filter notNull (shrink fs))

71 P.Record <$> filter (all notNull) (filter notNull (shrink fs))

67 where

72 where

@@ -71,29 +76,33 @@ shrinkWHead :: Arbitrary a => [a] -> [[a]]

71shrinkWHead [] = error "Should be nonempty"

76shrinkWHead [] = error "Should be nonempty"

72shrinkWHead (x:xs) = (x:) <$> shrink xs

77shrinkWHead (x:xs) = (x:) <$> shrink xs

73

78

74−instance Arbitrary T.Type where

79+instance Arbitrary v => Arbitrary (T.Type v) where

75 arbitrary = sized tipe

80 arbitrary = sized tipe

76 where

81 where

77− tipe :: Int -> Gen T.Type

82+ tipe :: Arbitrary v => Int -> Gen (T.Type v)

78 tipe n =

83 tipe n =

79 let depthTipe = tipe =<< choose (0,n)

84 let depthTipe = tipe =<< choose (0,n)

80 field = (,) <$> lowVar <*> depthTipe

85 field = (,) <$> lowVar <*> depthTipe

81 fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)

86 fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)

82 fields1 = (:) <$> field <*> fields

87 fields1 = (:) <$> field <*> fields

88+ depthTipes = (:) <$> depthTipe <*> genVector n tipe

83 in

89 in

84 oneof

90 oneof

85 [ T.Lambda <$> depthTipe <*> depthTipe

91 [ T.Lambda <$> depthTipe <*> depthTipe

86 , T.Var <$> lowVar

92 , T.Var <$> lowVar

87− , T.Data <$> capVar <*> genVector n tipe

93+ , T.Type <$> arbitrary

94+ , T.App <$> (T.Type <$> arbitrary) <*> depthTipes

88 , T.Record <$> fields <*> pure Nothing

95 , T.Record <$> fields <*> pure Nothing

89− , T.Record <$> fields1 <*> (Just <$> lowVar)

96+ , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar)

90 ]

97 ]

91

98

92 shrink tipe =

99 shrink tipe =

93 case tipe of

100 case tipe of

94 T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)

101 T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)

95 T.Var _ -> []

102 T.Var _ -> []

96− T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)

103+ T.Aliased v t -> t : (T.Aliased v <$> shrink t)

104+ T.Type v -> T.Type <$> shrink v

105+ T.App t ts -> t : ts ++ (T.App <$> shrink t <*> shrink ts)

97 T.Record fs t -> map snd fs ++ record

106 T.Record fs t -> map snd fs ++ record

98 where

107 where

99 record =

108 record =

tests/compiler/test-files/Imports.elmnew file+22

@@ -0,0 +1,22 @@

1+module Imports (Point, BooleanExpr(Not), true, false, adt, func) where

2+

3+type Point = { x : Float, y : Float }

4+

5+data BooleanExpr

6+ = T

7+ | F

8+ | Not BooleanExpr

9+ | And BooleanExpr BooleanExpr

10+ | Or BooleanExpr BooleanExpr

11+

12+true = T

13+

14+false = F

15+

16+adt : HiddenADT

17+adt = HiddenADT

18+

19+func : HiddenADT -> Int

20+func adt = 42

21+

22+data HiddenADT = HiddenADT

tests/compiler/test-files/bad/Imports/UseHiddenValues.elmnew file+4

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

1+

2+import Imports (BooleanExpr(..))

3+

4+bool = Or (Not T) F

tests/compiler/test-files/good/Box.elmdeleted−89

@@ -1,89 +0,0 @@

1−

2−module Box where

3−

4−import Math.Vector3 (..)

5−import Math.Matrix4 (..)

6−import Graphics.WebGL (Triangle, zipTriangle, Shader, Model, model, webgl)

7−import Window(dimensions)

8−

9−-- Create a cube in which each point has a color

10−

11−type ColorPoint = { color:Vec3, point:Vec3 }

12−

13−face : Color -> Vec3 -> Vec3 -> Vec3 -> Vec3 -> [Triangle ColorPoint]

14−face color a b c d =

15− let toV3 color =

16− let c = toRgb color

17− in v3 (toFloat c.red / 255) (toFloat c.green / 255) (toFloat c.blue / 255)

18− p = ColorPoint (toV3 color)

19− in

20− [ (p a, p b, p c), (p c, p d, p a) ]

21−

22−cube : [Triangle ColorPoint]

23−cube =

24− let rft = v3 1 1 1 -- right, front, top

25− lft = v3 -1 1 1 -- left, front, top

26− lbt = v3 -1 -1 1

27− rbt = v3 1 -1 1

28− rbb = v3 1 -1 -1

29− rfb = v3 1 1 -1

30− lfb = v3 -1 1 -1

31− lbb = v3 -1 -1 -1

32− in

33− concat [ face green rft rfb rbb rbt -- right

34− , face blue rft rfb lfb lft -- front

35− , face purple lft lfb lbb lbt -- left

36− , face orange rbt rbb lbb lbt -- back

37− ]

38−

39−-- Create the scene

40−

41−main : Signal Element

42−main = webgl (400,400) <~ lift scene angle

43−

44−angle : Signal Float

45−angle = foldp (\dt theta -> theta + dt / 5000) 0 (fps 25)

46−

47−scene : Float -> [Model]

48−scene angle =

49− [ model vertexShader fragmentShader cube (uniforms angle) ]

50−

51−uniforms : Float -> { rotation:Mat4, perspective:Mat4, camera:Mat4, shade:Float }

52−uniforms t =

53− { rotation = mul (makeRotate (3*t) (v3 0 1 0)) (makeRotate (2*t) (v3 1 0 0))

54− , perspective = makePerspective 45 1 0.01 100

55− , camera = makeLookAt (v3 0 0 5) (v3 0 0 0) (v3 0 1 0)

56− , shade = 0.8

57− }

58−

59−-- Shaders

60−

61−vertexShader : Shader { attr | point:Vec3, color:Vec3 }

62− { unif | rotation:Mat4, perspective:Mat4, camera:Mat4 }

63− { vcolor:Vec3 }

64−vertexShader = [glShader|

65−

66−attribute vec3 point;

67−attribute vec3 color;

68−uniform mat4 perspective;

69−uniform mat4 camera;

70−uniform mat4 rotation;

71−varying vec3 vcolor;

72−void main () {

73− gl_Position = perspective * camera * rotation * vec4(point, 1.0);

74− vcolor = color;

75−}

76−

77−|]

78−

79−fragmentShader : Shader {} { u | shade:Float } { vcolor:Vec3 }

80−fragmentShader = [glShader|

81−

82−precision mediump float;

83−uniform float shade;

84−varying vec3 vcolor;

85−void main () {

86− gl_FragColor = shade * vec4(vcolor, 1.0);

87−}

88−

89−|]

tests/compiler/test-files/good/Crate.elmdeleted−85

@@ -1,85 +0,0 @@

1−

2−module Crate where

3−

4−import Http (..)

5−import Math.Vector2 (Vec2)

6−import Math.Vector3 (..)

7−import Math.Matrix4 (..)

8−import Graphics.WebGL (..)

9−

10−-- Define the mesh for a crate

11−crate : [Triangle { pos:Vec3, coord:Vec3 }]

12−crate = concatMap rotatedFace [ (0,0), (90,0), (180,0), (270,0), (0,90), (0,-90) ]

13−

14−rotatedFace : (Float,Float) -> [Triangle { pos:Vec3, coord:Vec3 }]

15−rotatedFace (angleX,angleY) =

16− let x = makeRotate (degrees angleX) (v3 1 0 0)

17− y = makeRotate (degrees angleY) (v3 0 1 0)

18− t = x `mul` y `mul` makeTranslate (v3 0 0 1)

19− in

20− map (mapTriangle (\x -> {x | pos <- mulVec3 t x.pos })) face

21−

22−face : [Triangle { pos:Vec3, coord:Vec3 }]

23−face =

24− let topLeft = { pos = v3 -1 1 0, coord = v3 0 1 0 }

25− topRight = { pos = v3 1 1 0, coord = v3 1 1 0 }

26− bottomLeft = { pos = v3 -1 -1 0, coord = v3 0 0 0 }

27− bottomRight = { pos = v3 1 -1 0, coord = v3 1 0 0 }

28− in

29− [ (topLeft,topRight,bottomLeft), (bottomLeft,topRight,bottomRight) ]

30−

31−-- View

32−view : Float -> Mat4

33−view angle =

34− foldr1 mul [ perspective

35− , camera

36− , makeRotate (3*angle) (v3 0 1 0)

37− , makeRotate (2*angle) (v3 1 0 0)

38− ]

39−

40−perspective : Mat4

41−perspective = makePerspective 45 1 0.01 100

42−

43−camera : Mat4

44−camera = makeLookAt (v3 0 0 5) (v3 0 0 0) (v3 0 1 0)

45−

46−-- Putting it together

47−main : Signal Element

48−main = webgl (400,400) <~ lift2 scene (loadTex "woodCrate.jpg") (view <~ angle)

49−

50−angle : Signal Float

51−angle = foldp (\dt theta -> theta + dt / 10000) 0 (fps 25)

52−

53−scene : Response Texture -> Mat4 -> [Model]

54−scene response view =

55− case response of

56− Waiting -> []

57− Failure _ _ -> []

58− Success tex -> [model vertexShader fragmentShader crate { crate = tex, view = view }]

59−

60−-- Shaders

61−vertexShader : Shader { pos:Vec3, coord:Vec3 } { u | view:Mat4 } { vcoord:Vec2 }

62−vertexShader = [glShader|

63−

64−attribute vec3 pos;

65−attribute vec3 coord;

66−uniform mat4 view;

67−varying vec2 vcoord;

68−void main () {

69− gl_Position = view * vec4(pos, 1.0);

70− vcoord = coord.xy;

71−}

72−

73−|]

74−

75−fragmentShader : Shader {} { u | crate:Texture } { vcoord:Vec2 }

76−fragmentShader = [glShader|

77−

78−precision mediump float;

79−uniform sampler2D crate;

80−varying vec2 vcoord;

81−void main () {

82− gl_FragColor = texture2D(crate, vcoord);

83−}

84−

85−|]

tests/compiler/test-files/good/Imports/OverlappingImports.elmnew file+5

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

1+import Text

2+import Text (..)

3+import Text (leftAligned)

4+

5+main = leftAligned (toText "hello")

tests/compiler/test-files/good/Imports/UseHiddenTypes.elmnew file+4

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

1+

2+import Imports (adt, func)

3+

4+fortyTwo = func adt

tests/compiler/test-files/good/Imports/UseRecordConstructor.elmnew file+4

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

1+

2+import Imports (Point)

3+

4+point = Point 3 4

tests/compiler/test-files/good/Imports/UseTypeConstructor.elmnew file+4

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

1+

2+import Imports (BooleanExpr(..), true, false)

3+

4+bool = Not true

tests/compiler/test-files/good/PortsWithTypeAliases.elmnew file+8

@@ -0,0 +1,8 @@

1+

2+type Point2D = Point Float Float

3+

4+type Point a b = { x:a, y:b }

5+

6+port points : Signal Point2D

7+

8+port pairs : Signal (Point String String)

tests/compiler/test-files/good/woodCrate.JPGdeleted

Binary file not shown.

tests/libraries/LibraryTest.hs+20−14

@@ -19,31 +19,37 @@ main = do

19 unless ("jsdom" `isInfixOf` out) $ runCmd "npm" ["install","jsdom"]

20

21 -- setup actual library tests

22− setCurrentDirectory $ top </> "tests" </> "libraries"

22+ let localCompiler = joinPath [ "dist", "build", "elm", "elm" ]

23− let localCompiler = joinPath [ top, "dist", "build", "elm", "elm" ]

24 runCmd localCompiler [ "--make"

23 runCmd localCompiler [ "--make"

25 , "--only-js"

24 , "--only-js"

26− , "--src-dir=" ++ top </> "automaton"

25+ , "--src-dir=IO"

27− , "--src-dir=" ++ top </> "IO"

26+ , "--src-dir=Elm-Test"

28− , "--src-dir=" ++ top </> "Elm-Test"

27+ , "--src-dir=" ++ "tests" </> "libraries"

29− , "Test.elm"

28+ , testFile <.> "elm"

30 ]

29 ]

31

30

32 -- run tests

31 -- run tests

33− let ioScript s = top </> "IO" </> s

32+ let files = [ "IO" </> "share" </> "prescript.js"

34− files = [ ioScript "prescript.js"

35 , Elm.runtime

33 , Elm.runtime

36− , "build" </> "Test.js"

34+ , "build" </> testFile <.> "js"

37− , ioScript "handler.js"

35+ , "IO" </> "share" </> "handler.js"

38 ]

36 ]

37+ testRunner = "build" </> "TestRunner.js"

39 exe <- readProcess "cat" files ""

38 exe <- readProcess "cat" files ""

40− writeFile "exe.js" exe

39+ writeFile testRunner exe

41− exitWith =<< waitForProcess =<< (runCommand "node exe.js")

40+ exitCode <- rawSystem "node" [testRunner]

41+ removeDirectoryRecursive "cache"

42+ removeDirectoryRecursive "build"

43+ exitWith exitCode

44+ where

45+ testFile = "tests" </> "libraries" </> "Test"

42

46

43runCmd :: String -> [String] -> IO ()

47runCmd :: String -> [String] -> IO ()

44runCmd cmd args = do

48runCmd cmd args = do

45 putStrLn (cmd ++ " " ++ unwords args)

49 putStrLn (cmd ++ " " ++ unwords args)

46− (exitCode, _stdout, stderr) <- readProcessWithExitCode cmd args ""

50+ (exitCode, stdout, stderr) <- readProcessWithExitCode cmd args ""

51+ putStr stdout

52+ putStr stderr

47 case exitCode of

53 case exitCode of

48 ExitSuccess -> return ()

54 ExitSuccess -> return ()

49− ExitFailure _ -> error stderr

55+ ExitFailure _ -> exitWith exitCode

tests/libraries/Test.elm+8−6

@@ -4,12 +4,14 @@ import ElmTest.Assertion as A

4import ElmTest.Run as R

5import ElmTest.Runner.Console (runDisplay)

6import ElmTest.Test (..)

7−

8import IO.IO (..)

7import IO.IO (..)

9import IO.Runner (Request, Response)

8import IO.Runner (Request, Response)

10import IO.Runner as Run

9import IO.Runner as Run

11

10

12import Test.Array as Array

11import Test.Array as Array

12+import Test.Basics as Basics

13+import Test.Char as Char

14+import Test.CodeGen as CodeGen

13import Test.Dict as Dict

15import Test.Dict as Dict

14import Test.Equality as Equality

16import Test.Equality as Equality

15import Test.List as List

17import Test.List as List

@@ -20,6 +22,9 @@ import Test.Trampoline as Trampoline

20tests : Test

22tests : Test

21tests = suite "Elm Standard Library Tests"

23tests = suite "Elm Standard Library Tests"

22 [ Array.tests

24 [ Array.tests

25+ , Basics.tests

26+ , Char.tests

27+ , CodeGen.tests

23 , Dict.tests

28 , Dict.tests

24 , Equality.tests

29 , Equality.tests

25 , List.tests

30 , List.tests

@@ -31,10 +36,7 @@ tests = suite "Elm Standard Library Tests"

31console : IO ()

36console : IO ()

32console = runDisplay tests

37console = runDisplay tests

33

38

34−port requests : Signal [{ mPut : Maybe String

39+port requests : Signal Request

35− , mExit : Maybe Int

36− , mGet : Bool

37− }]

38port requests = Run.run responses console

40port requests = Run.run responses console

39

41

40−port responses : Signal (Maybe String)

42+port responses : Signal Response

tests/libraries/Test/Array.elm+19−4

@@ -7,14 +7,23 @@ import Native.Array

7import ElmTest.Assertion (..)

8import ElmTest.Test (..)

9

10+mergeSplit : Int -> Array.Array a -> Array.Array a

11+mergeSplit n arr =

12+ let left = Array.slice 0 n arr

13+ right = Array.slice n (Array.length arr) arr

14+ in Array.append left right

15+

16+holeArray : Array.Array Int

17+holeArray = foldl mergeSplit (Array.fromList [0..100]) [0..100]

18+

10tests : Test

19tests : Test

11tests =

20tests =

12 let creationTests = suite "Creation"

21 let creationTests = suite "Creation"

13 [ test "empty" <| assertEqual Array.empty (Array.fromList [])

22 [ test "empty" <| assertEqual Array.empty (Array.fromList [])

14− , test "initialize" <| assertEqual (Array.initialize 4 id) (Array.fromList [0,1,2,3])

23+ , test "initialize" <| assertEqual (Array.initialize 4 identity) (Array.fromList [0,1,2,3])

15 , test "initialize 2" <| assertEqual (Array.initialize 4 (\n -> n*n)) (Array.fromList [0,1,4,9])

24 , test "initialize 2" <| assertEqual (Array.initialize 4 (\n -> n*n)) (Array.fromList [0,1,4,9])

16 , test "initialize 3" <| assertEqual (Array.initialize 4 (always 0)) (Array.fromList [0,0,0,0])

25 , test "initialize 3" <| assertEqual (Array.initialize 4 (always 0)) (Array.fromList [0,0,0,0])

17− , test "initialize Empty" <| assertEqual (Array.initialize 0 id) Array.empty

26+ , test "initialize Empty" <| assertEqual (Array.initialize 0 identity) Array.empty

18 , test "initialize 4" <| assertEqual (Array.initialize 2 (always 0)) (Array.fromList [0,0])

27 , test "initialize 4" <| assertEqual (Array.initialize 2 (always 0)) (Array.fromList [0,0])

19 , test "repeat" <| assertEqual (Array.repeat 5 40) (Array.fromList [40,40,40,40,40])

28 , test "repeat" <| assertEqual (Array.repeat 5 40) (Array.fromList [40,40,40,40,40])

20 , test "repeat 2" <| assertEqual (Array.repeat 5 0) (Array.fromList [0,0,0,0,0])

29 , test "repeat 2" <| assertEqual (Array.repeat 5 0) (Array.fromList [0,0,0,0,0])

@@ -26,6 +35,9 @@ tests =

26 , test "length - Long" <| assertEqual 10000 (Array.length (Array.repeat 10000 0))

35 , test "length - Long" <| assertEqual 10000 (Array.length (Array.repeat 10000 0))

27 , test "push" <| assertEqual (Array.fromList [1,2,3]) (Array.push 3 (Array.fromList [1,2]))

36 , test "push" <| assertEqual (Array.fromList [1,2,3]) (Array.push 3 (Array.fromList [1,2]))

28 , test "append" <| assertEqual [42,42,81,81,81] (Array.toList (Array.append (Array.repeat 2 42) (Array.repeat 3 81)))

37 , test "append" <| assertEqual [42,42,81,81,81] (Array.toList (Array.append (Array.repeat 2 42) (Array.repeat 3 81)))

38+ , test "appendEmpty 1" <| assertEqual [1..33] (Array.toList (Array.append Array.empty (Array.fromList [1..33])))

39+ , test "appendEmpty 2" <| assertEqual [1..33] (Array.toList (Array.append (Array.fromList [1..33]) Array.empty))

40+ , test "appendAndSlice" <| assertEqual [0..100] (Array.toList holeArray)

29 ]

41 ]

30 getAndSetTests = suite "Get and Set"

42 getAndSetTests = suite "Get and Set"

31 [ test "get" <| assertEqual (Just 2) (Array.get 1 (Array.fromList [3,2,1]))

43 [ test "get" <| assertEqual (Just 2) (Array.get 1 (Array.fromList [3,2,1]))

@@ -43,15 +55,18 @@ tests =

43 , test "slice 2" <| assertEqual (Array.fromList [1,2,3]) (Array.slice 1 4 (Array.fromList [0,1,2,3,4]))

55 , test "slice 2" <| assertEqual (Array.fromList [1,2,3]) (Array.slice 1 4 (Array.fromList [0,1,2,3,4]))

44 , test "slice 3" <| assertEqual (Array.fromList [1,2,3]) (Array.slice 1 -1 (Array.fromList [0,1,2,3,4]))

56 , test "slice 3" <| assertEqual (Array.fromList [1,2,3]) (Array.slice 1 -1 (Array.fromList [0,1,2,3,4]))

45 , test "slice 4" <| assertEqual (Array.fromList [2]) (Array.slice -3 -2 (Array.fromList [0,1,2,3,4]))

57 , test "slice 4" <| assertEqual (Array.fromList [2]) (Array.slice -3 -2 (Array.fromList [0,1,2,3,4]))

58+ , test "slice 5" <| assertEqual 63 (Array.length <| Array.slice 65 (65 + 63) <| Array.fromList [1..200])

46 ]

59 ]

47 mappingAndFoldingTests = suite "Mapping and Folding"

60 mappingAndFoldingTests = suite "Mapping and Folding"

48 [ test "map" <| assertEqual (Array.fromList [1,2,3]) (Array.map sqrt (Array.fromList [1,4,9]))

61 [ test "map" <| assertEqual (Array.fromList [1,2,3]) (Array.map sqrt (Array.fromList [1,4,9]))

49 , test "indexedMap 1" <| assertEqual (Array.fromList [0,5,10]) (Array.indexedMap (*) (Array.fromList [5,5,5]))

62 , test "indexedMap 1" <| assertEqual (Array.fromList [0,5,10]) (Array.indexedMap (*) (Array.fromList [5,5,5]))

50 , test "indexedMap 2" <| assertEqual [0..99] (Array.toList (Array.indexedMap always (Array.repeat 100 0)))

63 , test "indexedMap 2" <| assertEqual [0..99] (Array.toList (Array.indexedMap always (Array.repeat 100 0)))

51− , test "foldl" <| assertEqual [3,2,1] (Array.foldl (::) [] (Array.fromList [1,2,3]))

64+ , test "foldl 1" <| assertEqual [3,2,1] (Array.foldl (::) [] (Array.fromList [1,2,3]))

65+ , test "foldl 2" <| assertEqual 33 (Array.foldl (+) 0 (Array.repeat 33 1))

52 , test "foldr 1" <| assertEqual 15 (Array.foldr (+) 0 (Array.repeat 3 5))

66 , test "foldr 1" <| assertEqual 15 (Array.foldr (+) 0 (Array.repeat 3 5))

53 , test "foldr 2" <| assertEqual [1,2,3] (Array.foldr (::) [] (Array.fromList [1,2,3]))

67 , test "foldr 2" <| assertEqual [1,2,3] (Array.foldr (::) [] (Array.fromList [1,2,3]))

54− , test "filter" <| assertEqual (Array.fromList [2,4,6]) (Array.filter (\x -> x `mod` 2 == 0) (Array.fromList [1..6]))

68+ , test "foldr 3" <| assertEqual 53 (Array.foldr (-) 54 (Array.fromList [10,11]))

69+ , test "filter" <| assertEqual (Array.fromList [2,4,6]) (Array.filter (\x -> x % 2 == 0) (Array.fromList [1..6]))

55 ]

70 ]

56 nativeTests = suite "Conversion to JS Arrays"

71 nativeTests = suite "Conversion to JS Arrays"

57 [ test "jsArrays" <| assertEqual (Array.fromList [1..1100]) (Native.Array.fromJSArray (Native.Array.toJSArray (Array.fromList [1..1100])))

72 [ test "jsArrays" <| assertEqual (Array.fromList [1..1100]) (Native.Array.fromJSArray (Native.Array.toJSArray (Array.fromList [1..1100])))

tests/libraries/Test/Basics.elmnew file+20

@@ -0,0 +1,20 @@

1+module Test.Basics (tests) where

2+

3+import ElmTest.Assertion (..)

4+import ElmTest.Test (..)

5+

6+tests : Test

7+tests =

8+ let comparison =

9+ suite "Comparison"

10+ [ test "max" <| assertEqual 42 (max 32 42)

11+ , test "min" <| assertEqual 42 (min 91 42)

12+ , test "clamp low" <| assertEqual 10 (clamp 10 20 5)

13+ , test "clamp mid" <| assertEqual 15 (clamp 10 20 15)

14+ , test "clamp high" <| assertEqual 20 (clamp 10 20 25)

15+ ]

16+

17+ in

18+ suite "Basics"

19+ [ comparison

20+ ]

tests/libraries/Test/Char.elmnew file+15

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

1+module Test.Char (tests) where

2+

3+import Char

4+

5+import ElmTest.Assertion (..)

6+import ElmTest.Test (..)

7+

8+tests : Test

9+tests =

10+ suite "Char"

11+ [ test "toUpper" <| assertEqual 'C' <| Char.toUpper 'c'

12+ , test "toLower" <| assertEqual 'c' <| Char.toLower 'C'

13+ , test "toLocaleUpper" <| assertEqual 'C' <| Char.toLocaleUpper 'c'

14+ , test "toLocaleLower" <| assertEqual 'c' <| Char.toLocaleLower 'C'

15+ ]

tests/libraries/Test/CodeGen.elmnew file+55

@@ -0,0 +1,55 @@

1+module Test.CodeGen (tests) where

2+

3+import ElmTest.Assertion (..)

4+import ElmTest.Test (..)

5+

6+import Maybe

7+import Maybe (..)

8+

9+casePrime m' =

10+ case m' of

11+ Just x -> x

12+ Nothing -> 0

13+

14+patternPrime =

15+ case Just 42 of

16+ Just x' -> x'

17+ Nothing -> 0

18+

19+letQualified =

20+ let (Maybe.Just x) = Just 42

21+ in x

22+

23+caseQualified =

24+ case Just 42 of

25+ Maybe.Just x -> x

26+ Nothing -> 0

27+

28+caseScope : String

29+caseScope =

30+ case "Not this one!" of

31+ string ->

32+ case "Hi" of

33+ string -> string

34+

35+tests : Test

36+tests =

37+ let primes =

38+ suite "Primes"

39+ [ test "case" <| assertEqual 42 (casePrime (Just 42))

40+ , test "pattern" <| assertEqual 42 patternPrime

41+ ]

42+ qualifiedPatterns =

43+ suite "Qualified Patterns"

44+ [ test "let" <| assertEqual 42 letQualified

45+ , test "case" <| assertEqual 42 caseQualified

46+ ]

47+ scope =

48+ suite "Scoping"

49+ [ test "case" <| assertEqual "Hi" caseScope ]

50+ in

51+ suite "CodeGen"

52+ [ primes

53+ , qualifiedPatterns

54+ , scope

55+ ]

tests/libraries/Test/Dict.elm+27−4

@@ -11,16 +11,39 @@ animals = Dict.fromList [ ("Tom", "cat"), ("Jerry", "mouse") ]

11

12tests : Test

13tests =

14− let getTests =

14+ let buildTests = suite "build Tests"

15− [ test "get 1" <| assertEqual (Just "cat") (Dict.get "Tom" animals)

15+ [ test "empty" <| assertEqual (Dict.fromList []) (Dict.empty)

16+ , test "singleton" <| assertEqual (Dict.fromList [("k","v")]) (Dict.singleton "k" "v")

17+ , test "insert" <| assertEqual (Dict.fromList [("k","v")]) (Dict.insert "k" "v" Dict.empty)

18+ , test "insert replace" <| assertEqual (Dict.fromList [("k","vv")]) (Dict.insert "k" "vv" (Dict.singleton "k" "v"))

19+ , test "update" <| assertEqual (Dict.fromList [("k","vv")]) (Dict.update "k" (\v->Just "vv") (Dict.singleton "k" "v"))

20+ , test "update Nothing" <| assertEqual Dict.empty (Dict.update "k" (\v->Nothing) (Dict.singleton "k" "v"))

21+ , test "remove" <| assertEqual Dict.empty (Dict.remove "k" (Dict.singleton "k" "v"))

22+ , test "remove not found" <| assertEqual (Dict.singleton "k" "v") (Dict.remove "kk" (Dict.singleton "k" "v"))

23+ ]

24+ queryTests = suite "query Tests"

25+ [ test "member 1" <| assertEqual True (Dict.member "Tom" animals)

26+ , test "member 2" <| assertEqual False (Dict.member "Spike" animals)

27+ , test "get 1" <| assertEqual (Just "cat") (Dict.get "Tom" animals)

16 , test "get 2" <| assertEqual Nothing (Dict.get "Spike" animals)

28 , test "get 2" <| assertEqual Nothing (Dict.get "Spike" animals)

17 , test "getOrElse 1" <| assertEqual "mouse" (Dict.getOrElse "dog" "Jerry" animals)

29 , test "getOrElse 1" <| assertEqual "mouse" (Dict.getOrElse "dog" "Jerry" animals)

18 , test "getOrElse 2" <| assertEqual "dog" (Dict.getOrElse "dog" "Spike" animals)

30 , test "getOrElse 2" <| assertEqual "dog" (Dict.getOrElse "dog" "Spike" animals)

19 , test "getOrFail" <| assertEqual "cat" (Dict.getOrFail "Tom" animals)

31 , test "getOrFail" <| assertEqual "cat" (Dict.getOrFail "Tom" animals)

20 ]

32 ]

21− filterTests =

33+ combineTests = suite "combine Tests"

34+ [ test "union" <| assertEqual animals (Dict.union (Dict.singleton "Jerry" "mouse") (Dict.singleton "Tom" "cat"))

35+ , test "union collison" <| assertEqual (Dict.singleton "Tom" "cat") (Dict.union (Dict.singleton "Tom" "cat") (Dict.singleton "Tom" "mouse"))

36+ , test "intersect" <| assertEqual (Dict.singleton "Tom" "cat") (Dict.intersect animals (Dict.singleton "Tom" "cat"))

37+ , test "diff" <| assertEqual (Dict.singleton "Jerry" "mouse") (Dict.diff animals (Dict.singleton "Tom" "cat"))

38+ ]

39+ transformTests = suite "transform Tests"

22 [ test "filter" <| assertEqual (Dict.singleton "Tom" "cat") (Dict.filter (\k v -> k == "Tom") animals)

40 [ test "filter" <| assertEqual (Dict.singleton "Tom" "cat") (Dict.filter (\k v -> k == "Tom") animals)

23 , test "partition" <| assertEqual (Dict.singleton "Tom" "cat", Dict.singleton "Jerry" "mouse") (Dict.partition (\k v -> k == "Tom") animals)

41 , test "partition" <| assertEqual (Dict.singleton "Tom" "cat", Dict.singleton "Jerry" "mouse") (Dict.partition (\k v -> k == "Tom") animals)

24 ]

42 ]

25 in

43 in

26− suite "Dict Tests" <| List.concat [ getTests, filterTests ]

44+ suite "Dict Tests"

45+ [ buildTests

46+ , queryTests

47+ , combineTests

48+ , transformTests

49+ ]

tests/libraries/Test/Equality.elm+7−6

@@ -3,21 +3,22 @@ module Test.Equality (tests) where

3import ElmTest.Assertion (..)

4import ElmTest.Test (..)

5

6−data Different = A String

6+data Different

7− | B [Int]

7+ = A String

8+ | B [Int]

8

9

9tests : Test

10tests : Test

10tests =

11tests =

11 let diffTests = suite "ADT equality"

12 let diffTests = suite "ADT equality"

12 [ test "As eq" <| assert (A "a" == A "a")

13 [ test "As eq" <| assert (A "a" == A "a")

13 , test "Bs eq" <| assert (B [1] == B [1])

14 , test "Bs eq" <| assert (B [1] == B [1])

14− , test "A left neq" <| assert . not <| (A "a" == B [1])

15+ , test "A left neq" <| assert (A "a" /= B [1])

15− , test "A left neq" <| assert . not <| (B [1] == A "a")

16+ , test "A left neq" <| assert (B [1] /= A "a")

16 ]

17 ]

17 recordTests = suite "Record equality"

18 recordTests = suite "Record equality"

18 [ test "empty same" <| assert ({} == {})

19 [ test "empty same" <| assert ({} == {})

19− , test "ctor same" <| assert ({ctor = Just 3} == {ctor = Just 3})

20+ , test "ctor same" <| assert ({ctor = Just 3} == {ctor = Just 3})

20− , test "ctor diff" . assert . not <| ({ctor = Just 3} == {ctor = Nothing})

21+ , test "ctor diff" <| assert ({ctor = Just 3} /= {ctor = Nothing})

21 ]

22 ]

22 in

23 in

23 suite "Equality Tests" [diffTests, recordTests]

24 suite "Equality Tests" [diffTests, recordTests]

tests/libraries/Test/List.elm+81−29

@@ -1,38 +1,90 @@

1module Test.List (tests) where

2

3import List

4+import String

4

5

5import ElmTest.Assertion (..)

6import ElmTest.Assertion (..)

6import ElmTest.Test (..)

7import ElmTest.Test (..)

7

8

9+largeNumber = 100000

10+trueList = repeat largeNumber True

11+falseList = repeat largeNumber False

12+

13+lessThanThree x = x < 3

14+isEven n = n % 2 == 0

15+

16+alice = { name="Alice", height=1.62 }

17+bob = { name="Bob" , height=1.85 }

18+chuck = { name="Chuck", height=1.76 }

19+

20+flippedComparison a b =

21+ case compare a b of

22+ LT -> GT

23+ EQ -> EQ

24+ GT -> LT

25+

8tests : Test

26tests : Test

9−tests =

27+tests =

10− let partitionTests =

28+ let partitionTests = suite "partition Tests"

11− let p1 = id

29+ [ test "simple partition" <| assertEqual ([True],[False]) (List.partition identity [False, True])

12− p2 x = x < 3

30+ , test "order check" <| assertEqual ([2,1], [5,6]) (List.partition lessThanThree [2,5,6,1])

13− isEven n = n `mod` 2 == 0

31+ , test "partition doc check 1" <| assertEqual ([0,1,2], [3,4,5]) (partition lessThanThree [0..5])

14− in suite "partition Tests" [ test "simple partition" <| assertEqual ([True],[False]) (List.partition p1 [False, True]),

32+ , test "partition doc check 2" <| assertEqual ([0,2,4], [1,3,5]) (partition isEven [0..5])

15− test "order check" <| assertEqual ([2,1], [5,6]) (List.partition p2 [2,5,6,1]),

33+ , test "partition stress test" <| assertEqual (trueList, falseList) (partition identity (falseList ++ trueList))

16− test "partition doc check 1" <| assertEqual ([0,1,2], [3,4,5]) (partition p2 [0..5]),

34+ ]

17− test "partition doc check 2" <| assertEqual ([0,2,4], [1,3,5]) (partition isEven [0..5]),

35+ unzipTests = suite "unzip Tests"

18− let n = 100000

36+ [ test "unzip doc check" <| assertEqual ([0,17,1337],[True,False,True]) (unzip [(0, True), (17, False), (1337, True)])

19− ts = repeat n True

37+ , test "unzip stress test" <| assertEqual (trueList, falseList) (unzip (zip trueList falseList))

20− fs = repeat n False

38+ ]

21− in test "partition stress test" <| assertEqual (ts, fs) (partition p1 (fs++ts))

39+ concatTests = suite "concat Tests"

22− ]

40+ [ test "concat doc check 1" <| assertEqual [1,2,3,4,5] (concat [[1,2],[3],[4,5]])

23− unzipTests = suite "unzip Tests" [

41+ , test "concat doc check 2" <| assertEqual "treehouse" (concat ["tree","house"])

24− test "unzip doc check" <| assertEqual ([0,17,1337],[True,False,True]) (unzip [(0, True), (17, False), (1337, True)]),

42+ ]

25− let n = 100000

43+ joinTests = suite "join Tests"

26− ts = repeat n True

44+ [ test "join doc check" <| assertEqual "Hawaiian" (join "a" ["H","w","ii","n"])

27− fs = repeat n False

45+ , test "join list check" <| assertEqual [1,0,2,0,3] (join [0] [[1],[2],[3]])

28− in test "unzip stress test" <| assertEqual (ts, fs) (unzip (zip ts fs))

46+ ]

29− ]

47+ intersperseTests = suite "intersperse Tests"

30− intersperseTests = suite "intersperse Tests" [

48+ [ test "intersperse doc check" <| assertEqual ["turtles","on","turtles","on","turtles"] (intersperse "on" ["turtles","turtles","turtles"])

31− test "intersperse doc check" <| assertEqual ["turtles","on","turtles","on","turtles"] (intersperse "on" ["turtles","turtles","turtles"]),

49+ , test "intersperse stress test" <| assertEqual (tail <| List.concat <| zipWith (\x y -> [x,y]) falseList trueList) (intersperse False trueList)

32− let n = 100000

50+ ]

33− ts = repeat n True

51+ zipTests = suite "zip Tests"

34− fs = repeat n False

52+ [ test "zip doc check 1" <| assertEqual [(1,6),(2,7)] (zip [1,2,3] [6,7])

35− in test "intersperse stress test" <| assertEqual (tail . List.concat <| zipWith (\x y -> [x,y]) fs ts)

53+ , test "zip doc check 2" <| assertEqual (zipWith (,) [1,2,3] [6,7]) (zip [1,2,3] [6,7])

36− (intersperse False ts)

54+ ]

55+ filterMapTests = suite "filterMap Tests"

56+ [ test "filterMap doc check" <| assertEqual [3,5] (filterMap String.toInt ["3","4.0","5","hats"])

57+ ]

58+ concatMapTests = suite "concatMap Tests"

59+ [ test "simple concatMap check" <| assertEqual [1,1,2,2] (concatMap (repeat 2) [1,2])

60+ ]

61+ indexedMapTests = suite "indexedMap Tests"

62+ [ test "indexedMap doc check" <| assertEqual [(0,"Tom"),(1,"Sue"),(2,"Bob")] (indexedMap (,) ["Tom", "Sue", "Bob"])

63+ ]

64+ sortTests = suite "sort Tests"

65+ [ test "sort doc check" <| assertEqual [1,3,5] (sort [3,1,5])

66+ , test "sort string check" <| assertEqual ["a","c","e"] (sort ["c","a","e"])

67+ ]

68+ sortByTests = suite "sortBy Tests"

69+ [ test "sortBy doc check" <| assertEqual ["cat","mouse"] (sortBy String.length ["mouse","cat"])

70+ , test "sortby derived property check 1" <| assertEqual [alice,bob,chuck] (sortBy .name [chuck,alice,bob])

71+ , test "sortby derived property check 2" <| assertEqual [alice,chuck,bob] (sortBy .height [chuck,alice,bob])

72+ ]

73+ sortWithTests = suite "sortWith Tests"

74+ [ test "sortWith doc check" <| assertEqual [5,4,3,2,1] (sortWith flippedComparison [1..5])

75+ ]

76+ in

77+ suite "List Tests"

78+ [ partitionTests

79+ , unzipTests

80+ , concatTests

81+ , joinTests

82+ , intersperseTests

83+ , zipTests

84+ , filterMapTests

85+ , concatMapTests

86+ , indexedMapTests

87+ , sortTests

88+ , sortByTests

89+ , sortWithTests

37 ]

90 ]

38− in suite "List Tests" [partitionTests, unzipTests, intersperseTests]

tests/libraries/Test/String.elm+20−20

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

1module Test.String (tests) where

2

3import List

4−import String (..)

4+import String

5

6import ElmTest.Assertion (..)

7import ElmTest.Test (..)

@@ -9,29 +9,29 @@ import ElmTest.Test (..)

9tests : Test

10tests =

11 let simpleTests = suite "Simple Stuff"

12− [ test "is empty" <| assert (isEmpty "")

12+ [ test "is empty" <| assert (String.isEmpty "")

13− , test "is not empty" <| assert (not (isEmpty ("the world")))

13+ , test "is not empty" <| assert (not (String.isEmpty ("the world")))

14− , test "length" <| assertEqual 11 (length "innumerable")

14+ , test "length" <| assertEqual 11 (String.length "innumerable")

15− , test "endsWith" (assert <| endsWith "ship" "spaceship")

15+ , test "endsWith" (assert <| String.endsWith "ship" "spaceship")

16− , test "reverse" <| assertEqual "desserts" (reverse "stressed")

16+ , test "reverse" <| assertEqual "desserts" (String.reverse "stressed")

17− , test "repeat" <| assertEqual "hahaha" (repeat 3 "ha")

17+ , test "repeat" <| assertEqual "hahaha" (String.repeat 3 "ha")

18 ]

19

20 combiningTests = suite "Combining Strings"

21− [ test "uncons non-empty" <| assertEqual (Just ('a',"bc")) (uncons "abc")

21+ [ test "uncons non-empty" <| assertEqual (Just ('a',"bc")) (String.uncons "abc")

22− , test "uncons empty" <| assertEqual Nothing (uncons "")

22+ , test "uncons empty" <| assertEqual Nothing (String.uncons "")

23− , test "append 1" <| assertEqual "butterfly" (append "butter" "fly")

23+ , test "append 1" <| assertEqual "butterfly" (String.append "butter" "fly")

24− , test "append 2" <| assertEqual "butter" (append "butter" "")

24+ , test "append 2" <| assertEqual "butter" (String.append "butter" "")

25− , test "append 3" <| assertEqual "butter" (append "" "butter")

25+ , test "append 3" <| assertEqual "butter" (String.append "" "butter")

26 , test "concat" <| assertEqual "nevertheless" (concat ["never","the","less"])

27− , test "split commas" <| assertEqual ["cat","dog","cow"] (split "," "cat,dog,cow")

27+ , test "split commas" <| assertEqual ["cat","dog","cow"] (String.split "," "cat,dog,cow")

28− , test "split slashes"<| assertEqual ["home","steve","Desktop", ""] (split "/" "home/steve/Desktop/")

28+ , test "split slashes"<| assertEqual ["home","steve","Desktop", ""] (String.split "/" "home/steve/Desktop/")

29− , test "join spaces" <| assertEqual "cat dog cow" (join " " ["cat","dog","cow"])

29+ , test "join spaces" <| assertEqual "cat dog cow" (String.join " " ["cat","dog","cow"])

30− , test "join slashes" <| assertEqual "home/steve/Desktop" (join "/" ["home","steve","Desktop"])

30+ , test "join slashes" <| assertEqual "home/steve/Desktop" (String.join "/" ["home","steve","Desktop"])

31− , test "slice 1" <| assertEqual "c" (slice 2 3 "abcd")

31+ , test "slice 1" <| assertEqual "c" (String.slice 2 3 "abcd")

32− , test "slice 2" <| assertEqual "abc" (slice 0 3 "abcd")

32+ , test "slice 2" <| assertEqual "abc" (String.slice 0 3 "abcd")

33− , test "slice 3" <| assertEqual "abc" (slice 0 -1 "abcd")

33+ , test "slice 3" <| assertEqual "abc" (String.slice 0 -1 "abcd")

34− , test "slice 4" <| assertEqual "cd" (slice -2 4 "abcd")

34+ , test "slice 4" <| assertEqual "cd" (String.slice -2 4 "abcd")

35 ]

36 in

37 suite "String" [ simpleTests, combiningTests ]