3925082 · elk · git.iko.soy

.gitignore+2

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

11dist

22cabal-dev

3+.cabal-sandbox/

4+cabal.sandbox.config

35*.o

46*.hi

57*.chi

.gitmodules−3

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

11[submodule "IO"]

22 path = IO

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

4−[submodule "automaton"]

5− path = automaton

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

74[submodule "Elm-Test"]

85 path = Elm-Test

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

CONTRIBUTING.md+30−23

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

11# Contributing to Elm

22

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

4−describes the basic standards for opening pull requests:

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

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

519

620## Branches

721

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

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

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

24+ should target this branch!

1125

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

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

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

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

1532

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

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

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

1936features.

2037

21−## Opening a pull request

22−

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

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

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

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

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

41+your changes maintain this compatibility.

2542

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).

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.

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

Elm-Test+1−1

Submodule changed.

Elm.cabal+142−134

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

11Name: Elm

2−Version: 0.12.2

2+Version: 0.13

33Synopsis: The Elm language module.

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

55 It is a statically/strongly typed, functional reactive

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

3737 Elm.Internal.Utils,

3838 Elm.Internal.Version

3939 Hs-Source-Dirs: compiler

40− other-modules: SourceSyntax.Annotation,

41− SourceSyntax.Declaration,

42− SourceSyntax.Expression,

43− SourceSyntax.Helpers,

44− SourceSyntax.Literal,

45− SourceSyntax.Module,

46− SourceSyntax.Pattern,

47− SourceSyntax.PrettyPrint,

48− SourceSyntax.Type,

49− SourceSyntax.Variable,

40+ other-modules: AST.Annotation,

41+ AST.Declaration,

42+ AST.Expression.General,

43+ AST.Expression.Source,

44+ AST.Expression.Valid,

45+ AST.Expression.Canonical,

46+ AST.Helpers,

47+ AST.Literal,

48+ AST.Module,

49+ AST.Pattern,

50+ AST.PrettyPrint,

51+ AST.Type,

52+ AST.Variable,

5053 Generate.JavaScript,

5154 Generate.JavaScript.Helpers,

5255 Generate.JavaScript.Ports,

56+ Generate.JavaScript.Variable,

5357 Generate.Markdown,

5458 Generate.Html,

5559 Generate.Cases,

5660 Transform.Canonicalize,

61+ Transform.Canonicalize.Environment,

62+ Transform.Canonicalize.Setup,

63+ Transform.Canonicalize.Type,

64+ Transform.Canonicalize.Variable,

5765 Transform.Check,

5866 Transform.Expression,

5967 Transform.Declaration,

6068 Transform.Definition,

61− Transform.SafeNames,

69+ Transform.Interface,

6270 Transform.SortDefinitions,

6371 Transform.Substitute,

6472 Metadata.Prelude,

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

7179 Parse.Parse,

7280 Parse.Pattern,

7381 Parse.Type,

74− Type.Alias,

75− Type.Constrain.Declaration,

7682 Type.Constrain.Expression,

7783 Type.Constrain.Literal,

7884 Type.Constrain.Pattern,

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

94100 Build.Utils,

95101 Paths_Elm

96102

97− Build-depends: aeson,

98− aeson-pretty,

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

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

99105 base >=4.2 && <5,

100− binary >= 0.7.0.0,

106+ binary >= 0.7.0.0 && < 0.8,

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

102− blaze-markup,

103− bytestring,

104− cmdargs,

105− containers >= 0.3,

106− directory,

107− filepath,

108− indents,

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

110− language-glsl,

111− mtl >= 2,

112− pandoc >= 1.10,

113− parsec >= 3.1.1,

114− pretty,

115− scientific,

116− text,

117− transformers >= 0.2,

118− union-find,

119− unordered-containers,

120− yaml

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

109+ bytestring >= 0.9 && < 0.11,

110+ cheapskate >= 0.1 && < 0.2,

111+ cmdargs >= 0.7 && < 0.11,

112+ containers >= 0.3 && < 0.6,

113+ directory >= 1.0 && < 2.0,

114+ filepath >= 1 && < 2.0,

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

116+ indents >= 0.3 && < 0.4,

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

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

119+ mtl >= 2 && < 3,

120+ parsec >= 3.1.1 && < 3.5,

121+ pretty >= 1.0 && < 2.0,

122+ text >= 1 && < 2,

123+ transformers >= 0.2 && < 0.5,

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

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

121126

122127Executable elm

123128 Main-is: Compiler.hs

124129 ghc-options: -threaded -O2

125130 Hs-Source-Dirs: compiler

126− other-modules: SourceSyntax.Annotation,

127− SourceSyntax.Declaration,

128− SourceSyntax.Expression,

129− SourceSyntax.Helpers,

130− SourceSyntax.Literal,

131− SourceSyntax.Module,

132− SourceSyntax.Pattern,

133− SourceSyntax.PrettyPrint,

134− SourceSyntax.Type,

135− SourceSyntax.Variable,

131+ other-modules: AST.Annotation,

132+ AST.Declaration,

133+ AST.Expression.General,

134+ AST.Expression.Source,

135+ AST.Expression.Valid,

136+ AST.Expression.Canonical,

137+ AST.Helpers,

138+ AST.Literal,

139+ AST.Module,

140+ AST.Pattern,

141+ AST.PrettyPrint,

142+ AST.Type,

143+ AST.Variable,

136144 Generate.JavaScript,

137145 Generate.JavaScript.Helpers,

138146 Generate.JavaScript.Ports,

147+ Generate.JavaScript.Variable,

139148 Generate.Markdown,

140149 Generate.Html,

141150 Generate.Cases,

142151 Transform.Canonicalize,

152+ Transform.Canonicalize.Environment,

153+ Transform.Canonicalize.Setup,

154+ Transform.Canonicalize.Type,

155+ Transform.Canonicalize.Variable,

143156 Transform.Check,

144157 Transform.Expression,

145158 Transform.Declaration,

146159 Transform.Definition,

147− Transform.SafeNames,

160+ Transform.Interface,

148161 Transform.SortDefinitions,

149162 Transform.Substitute,

150163 Metadata.Prelude,

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

157170 Parse.Parse,

158171 Parse.Pattern,

159172 Parse.Type,

160− Type.Alias,

161− Type.Constrain.Declaration,

162173 Type.Constrain.Expression,

163174 Type.Constrain.Literal,

164175 Type.Constrain.Pattern,

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

180191 Build.Utils,

181192 Paths_Elm

182193

183− Build-depends: aeson,

184− aeson-pretty,

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

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

185196 base >=4.2 && <5,

186− binary >= 0.7.0.0,

197+ binary >= 0.7.0.0 && < 0.8,

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

188− blaze-markup,

189− bytestring,

190− cmdargs,

191− containers >= 0.3,

192− directory,

193− filepath,

194− indents,

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

196− language-glsl,

197− mtl >= 2,

198− pandoc >= 1.10,

199− parsec >= 3.1.1,

200− scientific,

201− pretty,

202− text,

203− transformers >= 0.2,

204− union-find,

205− unordered-containers,

206− yaml

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

200+ bytestring >= 0.9 && < 0.11,

201+ cheapskate >= 0.1 && < 0.2,

202+ cmdargs >= 0.7 && < 0.11,

203+ containers >= 0.3 && < 0.6,

204+ directory >= 1.0 && < 2.0,

205+ filepath >= 1 && < 2.0,

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

207+ indents >= 0.3 && < 0.4,

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

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

210+ mtl >= 2 && < 3,

211+ parsec >= 3.1.1 && < 3.5,

212+ pretty >= 1.0 && < 2.0,

213+ text >= 1 && < 2,

214+ transformers >= 0.2 && < 0.5,

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

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

207217

208218Executable elm-doc

209219 Main-is: Docs.hs

210220 Hs-Source-Dirs: compiler

211− other-modules: SourceSyntax.Annotation,

212− SourceSyntax.Declaration,

213− SourceSyntax.Expression,

214− SourceSyntax.Helpers,

215− SourceSyntax.Literal,

216− SourceSyntax.Module,

217− SourceSyntax.Pattern,

218− SourceSyntax.PrettyPrint,

219− SourceSyntax.Type,

220− SourceSyntax.Variable,

221+ other-modules: AST.Annotation,

222+ AST.Declaration,

223+ AST.Expression.General,

224+ AST.Helpers,

225+ AST.Literal,

226+ AST.Module,

227+ AST.Pattern,

228+ AST.PrettyPrint,

229+ AST.Type,

230+ AST.Variable,

221231 Parse.Binop,

222232 Parse.Declaration,

223233 Parse.Expression,

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

227237 Parse.Pattern,

228238 Parse.Type

229239

230− Build-depends: aeson,

231− aeson-pretty,

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

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

232242 base >=4.2 && <5,

233− binary >= 0.7.0.0,

234− bytestring,

235− cmdargs,

236− containers >= 0.3,

237− directory,

238− filepath,

239− indents,

240− language-glsl,

241− mtl >= 2,

242− pandoc >= 1.10,

243− parsec >= 3.1.1,

244− pretty,

245− scientific,

246− text,

247− union-find,

248− yaml

243+ binary >= 0.7.0.0 && < 0.8,

244+ bytestring >= 0.9 && < 0.11,

245+ cmdargs >= 0.7 && < 0.11,

246+ containers >= 0.3 && < 0.6,

247+ directory >= 1.0 && < 2.0,

248+ filepath >= 1 && < 2.0,

249+ indents >= 0.3 && < 0.4,

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

251+ mtl >= 2 && < 3,

252+ parsec >= 3.1.1 && < 3.5,

253+ pretty >= 1.0 && < 2.0,

254+ text >= 1 && < 2,

255+ transformers >= 0.2 && < 0.5,

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

249257

250258Test-Suite compiler-tests

251259 Type: exitcode-stdio-1.0

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

254262 other-modules: Tests.Compiler

255263 Tests.Property

256264 Tests.Property.Arbitrary

257− SourceSyntax.Helpers

258− SourceSyntax.Literal

259− SourceSyntax.PrettyPrint

260− build-depends: test-framework,

261− test-framework-hunit,

262− test-framework-quickcheck2 >= 0.3,

263− HUnit,

265+ AST.Helpers

266+ AST.Literal

267+ AST.PrettyPrint

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

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

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

271+ HUnit >= 1.1 && < 2,

264272 QuickCheck >= 2 && < 3,

265− aeson,

266− aeson-pretty,

273+ aeson >= 0.7 && < 0.9,

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

267275 base >=4.2 && <5,

268− binary >= 0.7.0.0,

269− blaze-html,

270− blaze-markup,

271− bytestring,

272− cmdargs,

273− containers >= 0.3,

274− directory,

276+ binary >= 0.7.0.0 && < 0.8,

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

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

279+ bytestring >= 0.9 && < 0.11,

280+ cheapskate >= 0.1 && < 0.2,

281+ cmdargs >= 0.7 && < 0.11,

282+ containers >= 0.3 && < 0.6,

283+ directory >= 1.0 && < 2.0,

275284 Elm,

276− filemanip,

277− filepath,

278− indents,

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

280− language-glsl,

281− mtl >= 2,

282− pandoc >= 1.10,

283− parsec >= 3.1.1,

284− pretty,

285− scientific,

286− text,

287− transformers >= 0.2,

288− union-find,

289− unordered-containers,

290− yaml

285+ filemanip >= 0.3.5 && < 0.4,

286+ filepath >= 1 && < 2.0,

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

288+ indents >= 0.3 && < 0.4,

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

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

291+ mtl >= 2 && < 3,

292+ parsec >= 3.1.1 && < 3.5,

293+ pretty >= 1.0 && < 2.0,

294+ process,

295+ text >= 1 && < 2,

296+ transformers >= 0.2 && < 0.5,

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

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

291299

292300Test-Suite library-tests

293301 Type: exitcode-stdio-1.0

294302 Hs-Source-Dirs: tests/libraries

295303 Main-is: LibraryTest.hs

296− build-depends: base,

297− directory,

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

305+ directory >= 1.0 && < 2.0,

298306 Elm,

299− filepath,

300− process

307+ filepath >= 1 && < 2.0,

308+ process >= 1 && < 2.0

IO+1−1

Submodule changed.

Setup.hs+61−94

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

1+{-# OPTIONS_GHC -W #-}

12import Distribution.Simple

23import Distribution.Simple.LocalBuildInfo

34import Distribution.Simple.Setup

45import Distribution.PackageDescription

56

6−import System.Cmd

77import System.Directory

88import System.FilePath

99import System.IO

1010import System.Process

1111

12−import Control.Monad

1312import qualified Data.Binary as Binary

1413import qualified Data.ByteString.Lazy as BS

1514import qualified Data.List as List

1615

17−-- Part 1

18−-- ------

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.

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

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

32−

33−-- Assumptions

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

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

36−rtsDir :: LocalBuildInfo -> FilePath

37−rtsDir lbi = "data"

38−

39−tempDir :: LocalBuildInfo -> FilePath

40−tempDir lbi = "temp"

16+-- OVERVIEW

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

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

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

20+

21+assetsDir :: FilePath

22+assetsDir = "data"

23+

24+tempDir :: FilePath

25+tempDir = "temp"

4126

4227-- The runtime is called:

43−rts :: LocalBuildInfo -> FilePath

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

28+runtime :: FilePath

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

4530

4631-- The runtime is called:

47−docs :: LocalBuildInfo -> FilePath

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

32+docs :: FilePath

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

4934

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

51−interfaces :: LocalBuildInfo -> FilePath

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

36+interfaces :: FilePath

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

5338

5439elm :: LocalBuildInfo -> FilePath

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

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

6550main = defaultMainWithHooks simpleUserHooks { postBuild = myPostBuild }

6651

6752

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−

8653

8754-- Post Build

8855

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

90−myPostBuild as bfs pd lbi = do

57+myPostBuild args flags packageDescription lbi = do

9158 putStrLn "Custom build step: compiling standard libraries"

9259 (elmos, elmis) <- compileLibraries lbi

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

94− buildInterfaces lbi elmis

61+ buildInterfaces elmis

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

96− buildRuntime lbi elmos

63+ buildRuntime elmos

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

98− buildDocs lbi

99− removeDirectoryRecursive (tempDir lbi)

65+ buildDocs

66+ removeDirectoryRecursive tempDir

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

101− postBuild simpleUserHooks as bfs pd lbi

68+ postBuild simpleUserHooks args flags packageDescription lbi

10269

10370

10471compileLibraries lbi = do

105− let temp = tempDir lbi -- temp

106− rts = rtsDir lbi -- data

107− createDirectoryIfMissing True temp

108− createDirectoryIfMissing True rts

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

72+ createDirectoryIfMissing True tempDir

73+ createDirectoryIfMissing True assetsDir

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

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

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

112− rtd_c <- canonicalizePath rts -- data

77+ rtd_c <- canonicalizePath assetsDir -- data

11378

11479 let make file = do

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

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

117− -- to find docs.json

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

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

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

80+ let args =

81+ [ "--only-js"

82+ , "--make"

83+ , "--no-prelude"

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

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

86+ , file

87+ ]

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

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

122− exitCode <- waitForProcess handle

90+ _exitCode <- waitForProcess handle

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

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

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

93+ )

12594

12695 setCurrentDirectory "libraries"

12796 paths <- getFiles ".elm" "."

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

13099 setCurrentDirectory ".."

131100 return files

132101

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

134−buildInterfaces lbi elmis = do

135− createDirectoryIfMissing True (rtsDir lbi)

136− let ifaces = interfaces lbi

137− ifaceHandle <- openBinaryFile ifaces WriteMode

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

103+buildInterfaces elmis = do

104+ createDirectoryIfMissing True assetsDir

105+ ifaceHandle <- openBinaryFile interfaces WriteMode

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

139107 let append file = do

140108 handle <- openBinaryFile file ReadMode

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

144112 mapM_ append elmis

145113 hClose ifaceHandle

146114

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

148−buildRuntime lbi elmos = do

149− createDirectoryIfMissing True (rtsDir lbi)

150− let rts' = rts lbi

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

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

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

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

155− mapM_ (appendTo rts') elmos

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

157−

158−buildDocs :: LocalBuildInfo -> IO ()

159−buildDocs lbi = do

160− createDirectoryIfMissing True (rtsDir lbi)

161− let docs' = docs lbi

162− writeFile docs' "[\n"

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

116+buildRuntime elmos = do

117+ createDirectoryIfMissing True assetsDir

118+ writeFile runtime

119+ "'use strict';\n\

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

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

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

123+ mapM_ (appendTo runtime) elmos

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

125+

126+buildDocs :: IO ()

127+buildDocs = do

128+ createDirectoryIfMissing True assetsDir

129+ writeFile docs "[\n"

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

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

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

131+ let appends = map (appendTo docs) json

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

166133 sequence_ (addCommas appends)

167− appendFile docs' "\n]"

134+ appendFile docs "\n]"

168135

169136getFiles ext dir = do

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

automatondeleted−1

Submodule changed.

changelog.md+37−1

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

11

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+

238## 0.12.1

339

4−## Improvements:

40+#### Improvements:

541

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

743 * Json.Value can flow through ports

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

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

11{-# OPTIONS_GHC -W #-}

2−module SourceSyntax.Annotation where

2+module AST.Annotation where

33

44import qualified Text.Parsec.Pos as Parsec

55import qualified Text.PrettyPrint as P

6−import SourceSyntax.PrettyPrint

6+import AST.PrettyPrint

77

88data Annotated annotation expr = A annotation expr

99 deriving (Show)

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

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

11{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Declaration where

2+module AST.Declaration where

33

44import Data.Binary

5−import qualified SourceSyntax.Expression as Expr

6−import qualified SourceSyntax.Type as T

7−import SourceSyntax.PrettyPrint

5+import qualified AST.Expression.Source as Source

6+import qualified AST.Expression.Valid as Valid

7+import qualified AST.Expression.Canonical as Canonical

8+import qualified AST.Type as T

9+import qualified AST.Variable as Var

10+import AST.PrettyPrint

811import Text.PrettyPrint as P

912

10−data Declaration' port def

13+data Declaration' port def var

1114 = Definition def

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

13− | TypeAlias String [String] T.Type

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

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

1417 | Port port

1518 | Fixity Assoc Int String

1619 deriving (Show)

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

1821data Assoc = L | N | R

1922 deriving (Eq)

2023

21−data ParsePort

22− = PPAnnotation String T.Type

23− | PPDef String Expr.ParseExpr

24+data RawPort

25+ = PPAnnotation String T.RawType

26+ | PPDef String Source.Expr

2427 deriving (Show)

2528

26−data Port

27− = Out String Expr.Expr T.Type

28− | In String T.Type

29+data Port expr var

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

31+ | In String (T.Type var)

2932 deriving (Show)

3033

31−portName :: Port -> String

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+

40+portName :: Port expr var -> String

3241portName port =

3342 case port of

3443 Out name _ _ -> name

3544 In name _ -> name

3645

37−type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

38−type Declaration = Declaration' Port Expr.Def

39−

4046instance Show Assoc where

4147 show assoc =

4248 case assoc of

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

5460

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

5662

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

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

64+ Pretty (Declaration' port def var) where

5865 pretty decl =

5966 case decl of

6067 Definition def -> pretty def

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

8188 N -> P.empty

8289 R -> P.text "r"

8390

84−instance Pretty ParsePort where

91+instance Pretty RawPort where

8592 pretty port =

8693 case port of

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

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

8996

90−instance Pretty Port where

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

9198 pretty port =

9299 case port of

93100 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

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

77enrich the AST with more information.

88-}

9−module SourceSyntax.Expression where

9+module AST.Expression.General where

1010

11−import SourceSyntax.PrettyPrint

11+import AST.PrettyPrint

1212import Text.PrettyPrint as P

13−import qualified SourceSyntax.Helpers as Help

14−import qualified SourceSyntax.Annotation as Annotation

15−import qualified SourceSyntax.Pattern as Pattern

16−import qualified SourceSyntax.Type as SrcType

17−import qualified SourceSyntax.Literal as Literal

18−import qualified SourceSyntax.Variable as Variable

13+import AST.Type (Type)

14+

15+import qualified AST.Annotation as Annotation

16+import qualified AST.Helpers as Help

17+import qualified AST.Literal as Literal

18+import qualified AST.Pattern as Pattern

19+import qualified AST.Variable as Var

1920

2021---- GENERAL AST ----

2122

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

3435 with information about what module a variable came from.

3536

3637-}

37−type GeneralExpr annotation definition variable =

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

38+type Expr annotation definition variable =

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

3940

40−data GeneralExpr' ann def var

41+data Expr' ann def var

4142 = Literal Literal.Literal

4243 | Var var

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

44− | ExplicitList [GeneralExpr ann def var]

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

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

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

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

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

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

51− | Data String [GeneralExpr ann def var]

52− | Access (GeneralExpr ann def var) String

53− | Remove (GeneralExpr ann def var) String

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

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

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

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

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

45+ | ExplicitList [Expr ann def var]

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

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

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

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

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

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

52+ | Data String [Expr ann def var]

53+ | Access (Expr ann def var) String

54+ | Remove (Expr ann def var) String

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

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

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

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

5859 -- for type checking and code gen only

59− | PortIn String SrcType.Type

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

60+ | PortIn String (Type var)

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

6162 | GLShader String String Literal.GLShaderTipe

6263 deriving (Show)

6364

6465

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−

9166---- UTILITIES ----

9267

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

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

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

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)

9573

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

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

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

9876

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

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

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

10179delist _ = []

10280

10381saveEnvName :: String

10482saveEnvName = "_save_the_environment!!!"

10583

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

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

10785dummyLet defs =

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

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

10987

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

11189 pretty expr =

11290 case expr of

11391 Literal lit -> pretty lit

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

11896

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

12098

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

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

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

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

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

123102

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 ]

125104 where

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

105+ op' = Var.toString op

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

127107

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

129109 where

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

179159

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

181161

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

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

183163

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

185165

186166 PortOut _ _ signal -> pretty signal

187167

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]

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

207170 case expr of

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

209172 _ -> [annExpr]

210173

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)

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

213176 case expr of

214177 Lambda pattern body ->

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

217180

218181 _ -> ([], lexpr)

219182

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

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

222185 where

223186 needed =

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

228191 MultiIf _ -> True

229192 Let _ _ -> True

230193 Case _ _ -> True

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

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

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

11{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Helpers where

2+module AST.Helpers where

33

44import qualified Data.Char as Char

55

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

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

11{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Literal where

2+module AST.Literal where

33

4+import AST.PrettyPrint

45import Data.Map (Map)

5−import SourceSyntax.PrettyPrint

66import qualified Text.PrettyPrint as PP

77

88data 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

13

2−module SourceSyntax.PrettyPrint where

3−

4−import Text.PrettyPrint

5−import qualified SourceSyntax.Helpers as Help

4+import Control.Monad.Trans.Error

5+import Text.PrettyPrint as P

6+import qualified AST.Helpers as Help

67

78class Pretty a where

89 pretty :: a -> Doc

910

10−instance Pretty () where

11− pretty () = empty

11+instance Pretty Doc where

12+ pretty doc = doc

13+

14+instance Pretty String where

15+ pretty = P.text

1216

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

1418renderPretty e = render (pretty e)

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

2125

2226variable :: String -> Doc

2327variable x =

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

25− else text (reprime x)

26−

27−reprime :: String -> String

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

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

2929

3030eightyCharLines :: Int -> String -> String

3131eightyCharLines indent message = answer

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

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

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

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

1010import System.Directory

1111import System.FilePath as FP

1212

13−import qualified SourceSyntax.Module as Module

13+import qualified AST.Module as Module

1414import qualified Parse.Parse as Parse

1515import qualified Elm.Internal.Paths as Path

1616import qualified Elm.Internal.Name as N

compiler/Build/File.hs+15−17

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

2323import qualified Build.Utils as Utils

2424import qualified Generate.JavaScript as JS

2525import qualified Parse.Module as Parser

26−import qualified SourceSyntax.Module as M

27−import qualified Transform.Canonicalize as Canonical

26+import qualified AST.Module as Module

2827

2928-- Reader: Runtime flags, always accessible

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

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

3332type Build a = BuildT IO a

3433

3534-- Interfaces, remembering if something was recompiled

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

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

3736

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

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

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

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

4039evalBuild flags interfaces build =

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

4241 return (fmap snd ifaces, getLast moduleNames)

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

4544

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

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

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

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

4948build flags interfaces files =

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

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

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

5655 | null ports = return ()

5756 | otherwise = Print.failure msg

5857 where

59− ports = M.iPorts iface

58+ ports = Module.iPorts iface

6059 msg = concat

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

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

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

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

124123 case Interface.isValid filePath iface of

125124 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))

129126 update name interface False

130127

131128 Left err -> liftIO $ Print.failure err

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

142139 createDirectoryIfMissing True (Flag.cache_dir flags)

143140 createDirectoryIfMissing True (Flag.build_dir flags)

144141

145− metaModule <-

142+ canonicalModule <-

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

147144 Right modul -> return modul

148145 Left errors -> do Print.errors errors

149146 exitFailure

150147

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

152150

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

154− generateCache name newInters metaModule

151+ let newInters = Module.toInterface canonicalModule

152+ generateCache name newInters canonicalModule

155153 update name newInters True

156154

157155 where

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

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

165163 , "( " ++ filePath ++ " )" ]

166164

167− generateCache name interfs metaModule = do

165+ generateCache name interfs canonicalModule = do

168166 flags <- ask

169167 liftIO $ do

170168 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)

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

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

174172

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

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

176174update name inter wasUpdated =

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

178176 tell (Last . Just $ name)

compiler/Build/Flags.hs+27−11

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

99 , files :: [FilePath]

1010 , set_runtime :: Maybe FilePath

1111 , get_runtime :: Bool

12+ , bundle_runtime :: Bool

1213 , only_js :: Bool

1314 , print_types :: Bool

1415 , scripts :: [FilePath]

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

1819 , src_dir :: [FilePath]

1920 }

2021 deriving (Data,Typeable,Show,Eq)

21−

22+

23+flags :: Flags

2224flags = Flags

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

26+

2427 , make = False

25− &= help "automatically compile dependencies."

28+ &= help "automatically compile dependencies."

29+

2630 , only_js = False

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

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

32+

2833 , 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+

3036 , 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+

3239 , 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+

3442 , 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+

3648 , 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+

3851 , 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+

4054 , 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+

4257 , print_types = False

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

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

59+

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

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

4662 &= 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

77import qualified Build.Print as Print

88import qualified Elm.Internal.Version as Version

99import System.Directory (doesFileExist)

10−import SourceSyntax.Module

10+import AST.Module as Module

1111

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

1313load filePath =

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

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

2929 ]

3030

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

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

3232isValid filePath (name, interface) =

3333 let version = iVersion interface in

3434 if version == Version.elmVersion

compiler/Build/Print.hs+7−25

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

55

66import qualified Data.Map as Map

77import qualified Data.List as List

8−import qualified SourceSyntax.Type as T

9−import qualified SourceSyntax.Module as M

10−import qualified SourceSyntax.PrettyPrint as Pretty

11−import qualified Type.Alias as Alias

8+import qualified AST.Module as Module

9+import qualified AST.PrettyPrint as Pretty

1210import qualified Text.PrettyPrint as P

1311

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

15−metaTypes interfaces meta =

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 =

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

13+types ts =

2814 do putStrLn ""

29− mapM_ printType (Map.toList types')

15+ mapM_ printType (Map.toList ts)

3016 putStrLn ""

3117 where

32− rules = Alias.rules interfaces aliases imports

33−

3418 printType (n,t) = do

3519 print $ P.hsep [ Pretty.variable n

3620 , P.text ":"

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

21+ , Pretty.pretty t ]

3822

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

4024errors errs =

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

4226

4327failure :: String -> IO a

44−failure msg =

45− do hPutStrLn stderr msg

46− exitFailure

28+failure msg = hPutStrLn stderr msg >> exitFailure

compiler/Build/Source.hs+22−45

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

22module Build.Source (build) where

33

44import qualified Data.Map as Map

5−import System.FilePath as FP

65import Text.PrettyPrint (Doc)

76

8−import SourceSyntax.Declaration

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

7+import qualified AST.Module as Module

138import qualified Parse.Parse as Parse

149import qualified Metadata.Prelude as Prelude

1510import qualified Transform.Check as Check

16−import qualified Transform.SortDefinitions as SD

1711import qualified Type.Inference as TI

18−import qualified Type.Constrain.Declaration as TcDecl

1912import qualified Transform.Canonicalize as Canonical

2013

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

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

2215build noPrelude interfaces source =

23− do let add = Prelude.add noPrelude

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

25− . concatMap iFixities $ Map.elems interfaces

26−

27− Module names exs ims decls <- do

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

29− case Check.mistakes decls of

30− [] -> return modul

31− ms -> Left ms

32−

33− let exports'

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 $

42− MetadataModule

43− { names = names

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

57−

58− return $ metaModule { types = types }

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

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

18+

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

20+ validModule <- do

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

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

23+ [] -> return modul

24+ ms -> Left ms

25+

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

27+ canonicalModule <- Canonical.module' interfaces validModule

28+

29+ -- Run type inference on the program.

30+ types <- TI.infer interfaces canonicalModule

31+

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

55import System.Directory (doesFileExist)

66import System.Environment (getEnv)

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

8+import System.IO.Error (tryIOError)

89import qualified Build.Flags as Flag

910import qualified Build.Print as Print

1011import qualified Paths_Elm as This

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

3334 if exists

3435 then return path

3536 else do

36− env <- getEnv "ELM_HOME"

37− return (env </> name)

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

38+ case environment of

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+ ]

3858

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

4060run command = do

compiler/Compiler.hs+28−12

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

2525

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

2727compileArgs flags =

28− do when (Flag.get_runtime flags) $

29− do putStrLn Path.runtime

30− exitSuccess

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

29+ putStrLn Path.runtime

30+ exitSuccess

3131 case Flag.files flags of

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

33− fs -> mapM_ (build flags) fs

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

33+ fs -> mapM_ (build flags) fs

3434

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

3636build flags rootFile =

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

5050 (extension, code) <-

5151 if Flag.only_js flags

5252 then do putStr "Generating JavaScript ... "

53− return ("js", js)

53+ makeJs js

5454 else do putStr "Generating HTML ... "

55− return (makeHtml js moduleName)

55+ makeHtml js moduleName

5656

5757 let targetFile = Utils.buildPath flags rootFile extension

5858 createDirectoryIfMissing True (takeDirectory targetFile)

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

6565 src <- BS.readFile filePath

6666 return (BS.append src js)

6767

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

6974

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

71− where

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

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

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

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

86+ where

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

88+ html runtime =

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

compiler/Docs.hs+103−66

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

1+{-# OPTIONS_GHC -W #-}

12{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}

23module Main where

34

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

1112import Control.Arrow (second)

1213import Data.Aeson

1314import Data.Aeson.Encode.Pretty

15+import Data.Aeson.Types (Pair)

1416import qualified Data.List as List

1517import qualified Data.Map as Map

1618import qualified Data.ByteString.Lazy as BS

1719import qualified Data.Text as Text

1820

19−import qualified SourceSyntax.Helpers as Help

20−import qualified SourceSyntax.Type as T

21−import qualified SourceSyntax.Expression as E

22−import qualified SourceSyntax.Declaration as D

21+import qualified AST.Helpers as Help

22+import qualified AST.Type as T

23+import qualified AST.Declaration as D

24+import qualified AST.Expression.Source as Src

25+import qualified AST.Variable as Var

2326

2427import Text.Parsec hiding (newline,spaces)

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

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

6366

6467docs :: IParser Value

6568docs = do

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

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

6770 things <- document

68− return $ documentToJson name exports structure things

71+ return $ documentToJson name structure things

6972

7073docComment :: IParser String

7174docComment = do

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

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

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

7679

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

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

7881moduleDocs = do

7982 optional freshLine

8083 (names,exports) <- moduleDef

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

8386 structure <- docComment

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

8588

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

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

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

8891

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

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

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

9194 where

9295 uncommentable = do

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

103106 return (comment, def, src)

104107

105108

106−documentToJson name exports structure things =

107− object $ [ "name" .= name

108− , "document" .= structure

109− , "values" .= toList values

110− , "aliases" .= toList aliases

111− , "datatypes" .= toList adts

112− ]

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

110+documentToJson name structure things =

111+ object

112+ [ "name" .= name

113+ , "document" .= structure

114+ , "values" .= toList values

115+ , "aliases" .= toList aliases

116+ , "datatypes" .= toList adts

117+ ]

113118 where

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

119+ (values, aliases, adts) =

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

115121

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

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

123+ toList dict =

124+ map object (Map.elems dict)

117125

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

119− filterPublics dict =

120− case Map.null exportMap of

121− True -> dict

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

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

123127

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

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

130+ -> (Pairs, Pairs, Pairs)

124131collect infixes types aliases adts things =

125132 case things of

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

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

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

136143

137144 (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

138152 case decl of

139− D.Fixity assoc prec name ->

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

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

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

143− D.TypeAlias name vars tipe ->

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

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

153+ D.Definition def ->

154+ case def of

155+ Src.TypeAnnotation name tipe ->

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

157+

158+ Src.Definition _ _ ->

159+ collect infixes types aliases adts rest

160+

146161 D.Datatype name vars ctors ->

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

148− fields = ["typeVariables" .= vars

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

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

163+ fields = [ "typeVariables" .= vars

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

165+ ]

150166 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

155167

156−instance ToJSON T.Type where

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+

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

157180 toJSON tipe =

158− object $

159− case tipe of

160− T.Lambda _ _ ->

161− let tipes = T.collectLambdas tipe in

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

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

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

165− ]

166−

167− T.Var x ->

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

169− , "name" .= toJSON x

170− ]

171−

172− T.Data name ts ->

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

174− , "name" .= toJSON name

175− , "args" .= map toJSON ts

176− ]

177−

178− T.Record fields ext ->

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

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

181− , "extension" .= toJSON ext

182− ]

183−

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

181+ object (getFields tipe)

182+ where

183+ getFields tipe =

184+ case tipe of

185+ T.Lambda _ _ ->

186+ let tipes = T.collectLambdas tipe in

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

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

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

190+ ]

191+

192+ T.Var x ->

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

194+ , "name" .= toJSON x

195+ ]

196+

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

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

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

206+ , "args" .= map toJSON ts

207+ ]

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+

211+ T.Record fields ext ->

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

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

214+ , "extension" .= toJSON ext

215+ ]

216+

217+ T.Aliased _ t ->

218+ getFields t

219+

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

185221ctorToJson tipe (ctor, tipes) =

186222 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−

51Name: Elm

6−Version: 0.8.0.3

2+Version: 0.12

73Synopsis: The Elm language module.

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

95 It is a statically/strongly typed, functional reactive

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

1814

1915Author: Evan Czaplicki

2016Maintainer: info@elm-lang.org

2218

2319Category: Compiler, Language

2420

2521Build-type: Custom

2622

27−Extra-source-files: changelog.txt

28−Data-dir: dist/data

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

30−Cabal-version: >=1.8

23+Extra-source-files: changelog.md

24+Data-dir: data

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

26+Cabal-version: >=1.9

3127

3228source-repository head

3329 type: git

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

3531

3632Library

37− exposed-modules: Language.Elm,

38− Language.Elm.Quasi

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

34+ Elm.Internal.Documentation,

35+ Elm.Internal.Name,

36+ Elm.Internal.Paths,

37+ Elm.Internal.Utils,

38+ Elm.Internal.Version

3939 Hs-Source-Dirs: compiler

40− other-modules: Unique,

41− SourceSyntax.Helpers,

42− SourceSyntax.Location,

43− SourceSyntax.Literal,

44− SourceSyntax.Pattern,

45− SourceSyntax.Expression,

46− SourceSyntax.Declaration,

47− SourceSyntax.Module,

40+ other-modules: AST.Annotation,

41+ AST.Declaration,

42+ AST.Expression.General,

43+ AST.Expression.Source,

44+ AST.Expression.Valid,

45+ AST.Expression.Canonical,

46+ AST.Helpers,

47+ AST.Literal,

48+ AST.Module,

49+ AST.Pattern,

50+ AST.PrettyPrint,

51+ AST.Type,

52+ AST.Variable,

4853 Generate.JavaScript,

49− Generate.Noscript,

54+ Generate.JavaScript.Helpers,

55+ Generate.JavaScript.Ports,

56+ Generate.Markdown,

5057 Generate.Html,

5158 Generate.Cases,

59+ Transform.Canonicalize,

60+ Transform.Check,

61+ Transform.Expression,

62+ Transform.Declaration,

63+ Transform.Definition,

64+ Transform.SortDefinitions,

5265 Transform.Substitute,

53− Transform.Optimize,

54− Metadata.Libraries,

55− Metadata.LoadLibraries,

56− Initialize,

66+ Metadata.Prelude,

5767 Parse.Binop,

68+ Parse.Declaration,

5869 Parse.Expression,

59− Parse.Foreign,

6070 Parse.Helpers,

71+ Parse.Literal,

6172 Parse.Module,

62− Parse.Parser,

73+ Parse.Parse,

6374 Parse.Pattern,

6475 Parse.Type,

65− Types.Alias,

66− Types.Types,

67− Types.Constrain,

68− Types.Hints,

69− Types.Solver,

70− Types.Substitutions,

71− Types.Unify,

76+ Type.Alias,

77+ Type.Constrain.Expression,

78+ Type.Constrain.Literal,

79+ Type.Constrain.Pattern,

80+ Type.Environment,

81+ Type.ExtraChecks,

82+ Type.Fragment,

83+ Type.Inference,

84+ Type.PrettyPrint,

85+ Type.Solve,

86+ Type.State,

87+ Type.Type,

88+ Type.Unify,

89+ Build.Dependencies,

90+ Build.File,

91+ Build.Flags,

92+ Build.Interface,

93+ Build.Print,

94+ Build.Source,

95+ Build.Utils,

7296 Paths_Elm

7397

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,

75105 containers >= 0.3,

76− transformers >= 0.2,

106+ directory,

107+ filepath,

108+ indents,

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

110+ language-glsl,

77111 mtl >= 2,

78− deepseq,

112+ pandoc >= 1.10,

79113 parsec >= 3.1.1,

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

81− blaze-markup == 0.5.1.*,

114+ pretty,

82115 text,

83− shakespeare >= 1,

84− template-haskell,

85− pandoc >= 1.10,

86− bytestring,

87− uniplate,

88− hjsmin,

89− indents,

90− filepath,

91− json,

92− directory

116+ transformers >= 0.2,

117+ union-find,

118+ unordered-containers

93119

94120Executable elm

95121 Main-is: Compiler.hs

122+ ghc-options: -threaded -O2

96123 Hs-Source-Dirs: compiler

97− other-modules: Unique,

98− SourceSyntax.Helpers,

99− SourceSyntax.Location,

100− SourceSyntax.Literal,

101− SourceSyntax.Pattern,

102− SourceSyntax.Expression,

103− SourceSyntax.Declaration,

104− SourceSyntax.Module,

124+ other-modules: AST.Annotation,

125+ AST.Declaration,

126+ AST.Expression.General,

127+ AST.Expression.Source,

128+ AST.Expression.Valid,

129+ AST.Expression.Canonical,

130+ AST.Helpers,

131+ AST.Literal,

132+ AST.Module,

133+ AST.Pattern,

134+ AST.PrettyPrint,

135+ AST.Type,

136+ AST.Variable,

105137 Generate.JavaScript,

106− Generate.Noscript,

138+ Generate.JavaScript.Helpers,

139+ Generate.JavaScript.Ports,

140+ Generate.Markdown,

107141 Generate.Html,

108142 Generate.Cases,

143+ Transform.Canonicalize,

144+ Transform.Check,

145+ Transform.Expression,

146+ Transform.Declaration,

147+ Transform.Definition,

148+ Transform.SortDefinitions,

109149 Transform.Substitute,

110− Transform.Optimize,

111− Metadata.Libraries,

112− Metadata.LoadLibraries,

113− Initialize,

150+ Metadata.Prelude,

114151 Parse.Binop,

152+ Parse.Declaration,

115153 Parse.Expression,

116− Parse.Foreign,

117154 Parse.Helpers,

155+ Parse.Literal,

118156 Parse.Module,

119− Parse.Parser,

157+ Parse.Parse,

120158 Parse.Pattern,

121159 Parse.Type,

122− Types.Alias,

123− Types.Types,

124− Types.Constrain,

125− Types.Hints,

126− Types.Solver,

127− Types.Substitutions,

128− Types.Unify,

160+ Type.Alias,

161+ Type.Constrain.Expression,

162+ Type.Constrain.Literal,

163+ Type.Constrain.Pattern,

164+ Type.Environment,

165+ Type.ExtraChecks,

166+ Type.Fragment,

167+ Type.Inference,

168+ Type.PrettyPrint,

169+ Type.Solve,

170+ Type.State,

171+ Type.Type,

172+ Type.Unify,

173+ Build.Dependencies,

174+ Build.File,

175+ Build.Flags,

176+ Build.Interface,

177+ Build.Print,

178+ Build.Source,

179+ Build.Utils,

129180 Paths_Elm

130181

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,

132189 containers >= 0.3,

133− transformers >= 0.2,

190+ directory,

191+ filepath,

192+ indents,

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

194+ language-glsl,

134195 mtl >= 2,

135− deepseq,

136− parsec >= 3.1.1,

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

138− blaze-markup == 0.5.1.*,

139− cmdargs,

140196 pandoc >= 1.10,

141− bytestring,

142− uniplate,

143− hjsmin,

144− indents,

145− filepath,

146− json,

147− directory

197+ parsec >= 3.1.1,

198+ pretty,

199+ text,

200+ transformers >= 0.2,

201+ union-find,

202+ unordered-containers

148203

149204Executable elm-doc

150205 Main-is: Docs.hs

151206 Hs-Source-Dirs: compiler

152− other-modules: SourceSyntax.Helpers,

153− SourceSyntax.Location,

154− SourceSyntax.Literal,

155− SourceSyntax.Pattern,

156− SourceSyntax.Expression,

157− SourceSyntax.Declaration,

158− SourceSyntax.Module,

207+ other-modules: AST.Annotation,

208+ AST.Declaration,

209+ AST.Expression.General,

210+ AST.Helpers,

211+ AST.Literal,

212+ AST.Module,

213+ AST.Pattern,

214+ AST.PrettyPrint,

215+ AST.Type,

216+ AST.Variable,

217+ Parse.Binop,

218+ Parse.Declaration,

219+ Parse.Expression,

159220 Parse.Helpers,

160− Parse.Module

221+ Parse.Literal,

222+ Parse.Module,

223+ Parse.Pattern,

224+ Parse.Type

161225

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,

163232 containers >= 0.3,

164− transformers >= 0.2,

233+ directory,

234+ filepath,

235+ indents,

236+ language-glsl,

165237 mtl >= 2,

166− parsec >= 3.1.1,

167238 pandoc >= 1.10,

168− cmdargs,

169− filepath,

170− indents

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,

265+ cmdargs,

266+ containers >= 0.3,

267+ directory,

268+ Elm,

269+ filemanip,

270+ filepath,

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

55import qualified Data.List as List

66import qualified Generate.JavaScript as JS

77import qualified Build.Source as Source

8−import Parse.Module (getModuleName)

8+import qualified Parse.Module as Parser

9+import qualified AST.Module as M

910import Parse.Parse (dependencies)

10−import qualified SourceSyntax.Module as M

1111import qualified Text.PrettyPrint as P

1212import qualified Metadata.Prelude as Prelude

1313import System.IO.Unsafe

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

2626

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

2828moduleName :: String -> Maybe String

29−moduleName = getModuleName

29+moduleName = Parser.getModuleName

3030

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

3232-- source program.

compiler/Generate/Cases.hs+156−78

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

1+{-# OPTIONS_GHC -W #-}

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

23

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

45import Control.Arrow (first)

5−import Control.Monad.State

6+import Control.Monad.State (State)

7+import qualified Control.Monad.State as State

68import Data.List (groupBy,sortBy)

79import Data.Maybe (fromMaybe)

810

9−import SourceSyntax.Annotation

10−import SourceSyntax.Expression

11−import SourceSyntax.Literal

12−import qualified SourceSyntax.Pattern as P

13−import qualified SourceSyntax.Variable as V

14−import Transform.Substitute

11+import qualified AST.Annotation as A

12+import qualified AST.Expression.General as Expr

13+import qualified AST.Expression.Canonical as Canonical

14+import qualified AST.Literal as Literal

15+import qualified AST.Pattern as P

16+import qualified AST.Variable as Var

17+import Transform.Substitute (subst)

1518

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

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

1720toMatch patterns = do

1821 v <- newVar

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

2023

24+

2125newVar :: State Int String

22−newVar = do n <- get

23− modify (+1)

24− return $ "_v" ++ show n

26+newVar =

27+ do n <- State.get

28+ State.modify (+1)

29+ return $ "_v" ++ show n

30+

2531

2632data Match

2733 = Match String [Clause] Match

2834 | Break

2935 | Fail

30− | Other Expr

36+ | Other Canonical.Expr

3137 | Seq [Match]

3238 deriving Show

3339

40+

3441data Clause =

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

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

3643 deriving Show

3744

45+

46+type Case =

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

48+

49+

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

3951matchSubst pairs match =

4052 case match of

4153 Break -> Break

42− Fail -> Fail

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

44− Other (A a e) ->

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

54+

55+ Fail -> Fail

56+

57+ Seq ms ->

58+ Seq (map (matchSubst pairs) ms)

59+

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

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

62+

4663 Match n cs m ->

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

48− where

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

50− clauseSubst (Clause c vs m) =

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

65+ where

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

67+ clauseSubst (Clause c vs m) =

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

5269

70+

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

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

5373isCon (p:_, _) =

54− case p of

55− P.Data _ _ -> True

56− P.Literal _ -> True

57− _ -> False

74+ case p of

75+ P.Data _ _ -> True

76+ P.Literal _ -> True

77+ _ -> False

5878

79+

80+isVar :: ([P.Pattern var], expr) -> Bool

5981isVar p = not (isCon p)

6082

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

7283

73−dealias :: String -> ([P.Pattern],Expr) -> ([P.Pattern],Expr)

74−dealias v c@(p:ps, A a e) =

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"

109+dealias v c@(p:ps, A.A a e) =

75110 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)

77112 _ -> c

78113

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

80−matchVar (v:vs) cs def = match vs (map subVar cs) def

114+

115+matchVar :: [String] -> [Case] -> Match -> State Int Match

116+matchVar [] _ _ = noMatch "matchVar"

117+matchVar (v:vs) cs def =

118+ match vs (map subVar cs) def

81119 where

82− subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)

83− where

84− subOnePattern pattern e =

120+ subVar ([], _) = noMatch "matchVar.subVar"

121+ subVar (p:ps, (A.A a expr)) =

122+ (ps, A.A a $ subOnePattern p expr)

123+ where

124+ subOnePattern pattern expr =

85125 case pattern of

86− P.Var x -> subst x (rawVar v) e

87− P.Anything -> e

126+ P.Anything -> expr

127+

128+ P.Var x ->

129+ subst x (Expr.localVar v) expr

130+

88131 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

90133

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

92−matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

93− where

94− css = groupBy eq (sortBy cmp cs)

95−

96− cmp (p1:_,_) (p2:_,_) =

97− case (p1,p2) of

98− (P.Data n1 _, P.Data n2 _) -> compare n1 n2

99− _ -> compare p1 p2

100−

101− eq (p1:_,_) (p2:_,_) =

102− case (p1,p2) of

103− (P.Data n1 _, P.Data n2 _) -> n1 == n2

104− _ -> p1 == p2

105−

106− toClause cs =

107− case head cs of

108− (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break

109− (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break

110−

111−matchClause :: Either String Literal

112− -> [String]

113− -> [([P.Pattern],Expr)]

114− -> Match

134+ _ -> noMatch "matchVar.subVar"

135+

136+

137+matchCon :: [String] -> [Case] -> Match -> State Int Match

138+matchCon variables cases match =

139+ case variables of

140+ [] -> noMatch "matchCon"

141+

142+ var : _vars ->

143+ flip (Match var) match <$> mapM toClause caseGroups

144+ where

145+ caseGroups :: [[Case]]

146+ caseGroups =

147+ groupBy eq (sortBy cmp cases)

148+

149+ eq :: Case -> Case -> Bool

150+ eq (patterns1, _) (patterns2, _) =

151+ case (patterns1, patterns2) of

152+ (pattern1:_, pattern2:_) ->

153+ case (pattern1, pattern2) of

154+ (P.Data name1 _, P.Data name2 _) -> name1 == name2

155+ (_, _) -> pattern1 == pattern2

156+ (_, _) -> noMatch "matchCon.eq"

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

115180 -> State Int Clause

116−matchClause c (_:vs) cs def =

181+matchClause _ [] _ _ = noMatch "matchClause"

182+matchClause c (_:vs) cs mtch =

117183 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

119185 where

120−

186+ flatten ([], _) = noMatch "matchClause.flatten"

121187 flatten (p:ps, e) =

122188 case p of

123189 P.Data _ ps' -> (ps' ++ ps, e)

124190 P.Literal _ -> (ps, e)

191+ _ -> noMatch "matchClause.flatten"

125192

193+ getVars :: State Int [String]

126194 getVars =

127195 case head cs of

128− (P.Data _ ps : _, _) -> forM ps (const newVar)

196+ (P.Data _ ps : _, _) -> State.forM ps (const newVar)

129197 (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+

130207

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

132−matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

133− where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

208+noMatch :: String -> a

209+noMatch name =

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 =

1717 H.script ! A.type_ "text/javascript" $

1818 preEscapedToMarkup $ BS.unpack src

1919

20−generate :: FilePath -> String -> [JSSource] -> String -> String -> H.Html

21−generate libLoc title scripts moduleName noscript =

20+generate :: JSSource -> String -> [JSSource] -> String -> String -> H.Html

21+generate runtime title scripts moduleName noscript =

2222 H.docTypeHtml $ do

2323 H.head $ do

2424 H.meta ! A.charset "UTF-8"

2525 H.title . H.toHtml $ title

26− makeScript (Link libLoc)

26+ makeScript runtime

2727 mapM_ makeScript scripts

2828 H.body $ do

2929 H.script ! A.type_ "text/javascript" $

compiler/Generate/JavaScript.hs+173−129

@@ -10,59 +10,66 @@ import qualified Data.Set as Set

1010import Language.ECMAScript3.PrettyPrint

1111import Language.ECMAScript3.Syntax

1212

13−import Generate.JavaScript.Helpers

13+import Generate.JavaScript.Helpers as Help

1414import qualified Generate.Cases as Case

1515import qualified Generate.JavaScript.Ports as Port

16+import qualified Generate.JavaScript.Variable as Var

1617import qualified Generate.Markdown as MD

17−import SourceSyntax.Annotation

18−import SourceSyntax.Expression

19−import qualified SourceSyntax.Helpers as Help

20−import SourceSyntax.Literal

21−import SourceSyntax.Module

22−import qualified SourceSyntax.Pattern as P

23−import SourceSyntax.PrettyPrint (renderPretty)

24−import qualified SourceSyntax.Variable as V

25−import qualified Transform.SafeNames as MakeSafe

18+

19+import AST.Annotation

20+import AST.Module

21+import AST.Expression.General

22+import qualified AST.Expression.Canonical as Canonical

23+import qualified AST.Module as Module

24+import qualified AST.Helpers as Help

25+import AST.Literal

26+import qualified AST.Pattern as P

27+import qualified AST.Variable as Var

2628

2729varDecl :: String -> Expression () -> VarDecl ()

2830varDecl x expr =

2931 VarDecl () (var x) (Just expr)

3032

31−include :: String -> String -> VarDecl ()

32−include alias moduleName =

33− varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")

34−

35−internalImports :: String -> Statement ()

33+internalImports :: String -> [VarDecl ()]

3634internalImports name =

37− VarDeclStmt ()

38− [ varDecl "_N" (obj "Elm.Native")

39− , include "_U" "_N.Utils"

40− , include "_L" "_N.List"

41− , include "_A" "_N.Array"

42− , include "_E" "_N.Error"

43− , varDecl "$moduleName" (string name)

35+ [ varDecl "_N" (obj ["Elm","Native"])

36+ , include "_U" "Utils"

37+ , include "_L" "List"

38+ , include "_A" "Array"

39+ , include "_E" "Error"

40+ , varDecl Help.localModuleName (string name)

4441 ]

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]

4552

4653literal :: Literal -> Expression ()

4754literal lit =

4855 case lit of

49− Chr c -> obj "_U.chr" <| string [c]

56+ Chr c -> _Utils "chr" <| string [c]

5057 Str s -> string s

5158 IntNum n -> IntLit () n

5259 FloatNum n -> NumLit () n

5360 Boolean b -> BoolLit () b

5461

55−expression :: Expr -> State Int (Expression ())

62+expression :: Canonical.Expr -> State Int (Expression ())

5663expression (A region expr) =

5764 case expr of

58− Var (V.Raw x) -> return $ obj x

65+ Var var -> return $ Var.canonical var

5966

6067 Literal lit -> return $ literal lit

6168

6269 Range lo hi ->

6370 do lo' <- expression lo

6471 hi' <- expression hi

65− return $ obj "_L.range" `call` [lo',hi']

72+ return $ _List "range" `call` [lo',hi']

6673

6774 Access e x ->

6875 do e' <- expression e

@@ -70,19 +77,19 @@ expression (A region expr) =

7077

7178 Remove e x ->

7279 do e' <- expression e

73− return $ obj "_U.remove" `call` [string x, e']

80+ return $ _Utils "remove" `call` [string x, e']

7481

7582 Insert e x v ->

7683 do v' <- expression v

7784 e' <- expression e

78− return $ obj "_U.insert" `call` [string x, v', e']

85+ return $ _Utils "insert" `call` [string x, v', e']

7986

8087 Modify e fs ->

8188 do e' <- expression e

8289 fs' <- forM fs $ \(f,v) -> do

8390 v' <- expression v

8491 return $ ArrayLit () [string f, v']

85− return $ obj "_U.replace" `call` [ArrayLit () fs', e']

92+ return $ _Utils "replace" `call` [ArrayLit () fs', e']

8693

8794 Record fields ->

8895 do fields' <- forM fields $ \(f,e) -> do

@@ -106,10 +113,10 @@ expression (A region expr) =

106113 where

107114 depattern (args, body) pattern =

108115 case pattern of

109− P.Var x -> return (args ++ [x], body)

116+ P.Var x -> return (args ++ [ Var.varName x ], body)

110117 _ -> do arg <- Case.newVar

111118 return ( args ++ [arg]

112− , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))

119+ , A ann (Case (A ann (localVar arg)) [(pattern, body)]))

113120

114121 (patterns, innerBody) = collect [p] e

115122

@@ -140,22 +147,23 @@ expression (A region expr) =

140147 return $ function [] (stmts ++ [ ret exp ]) `call` []

141148

142149 MultiIf branches ->

143− do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

144− return $ case last branches of

145− (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'

146− (A _ (Literal (Boolean True)), _) -> safeIfs branches'

147− _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])

148− where

149− safeIfs branches = ifs (init branches) (snd (last branches))

150− ifs branches finally = foldr iff finally branches

151− iff (if', then') else' = CondExpr () if' then' else'

150+ do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

151+ return $ case last branches of

152+ (A _ (Var (Var.Canonical (Var.Module "Basics") "otherwise")), _) ->

153+ safeIfs branches'

154+ (A _ (Literal (Boolean True)), _) -> safeIfs branches'

155+ _ -> ifs branches' (throw "If" region)

156+ where

157+ safeIfs branches = ifs (init branches) (snd (last branches))

158+ ifs branches finally = foldr iff finally branches

159+ iff (if', then') else' = CondExpr () if' then' else'

152160

153161 Case e cases ->

154162 do (tempVar,initialMatch) <- Case.toMatch cases

155163 (revisedMatch, stmt) <-

156164 case e of

157− A _ (Var (V.Raw x)) ->

158− return (Case.matchSubst [(tempVar,x)] initialMatch, [])

165+ A _ (Var (Var.Canonical Var.Local x)) ->

166+ return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])

159167 _ ->

160168 do e' <- expression e

161169 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])

@@ -164,7 +172,7 @@ expression (A region expr) =

164172

165173 ExplicitList es ->

166174 do es' <- mapM expression es

167− return $ obj "_L.fromArray" <| ArrayLit () es'

175+ return $ _List "fromArray" <| ArrayLit () es'

168176

169177 Data name es ->

170178 do es' <- mapM expression es

@@ -175,7 +183,7 @@ expression (A region expr) =

175183

176184 Markdown uid doc es ->

177185 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')

179187 where

180188 pad = "<div style=\"height:0;width:0;\"> </div>"

181189 md = pad ++ MD.toHtml doc ++ pad

@@ -184,15 +192,16 @@ expression (A region expr) =

184192 return $ ObjectLit () [(PropString () "src", literal (Str src))]

185193

186194 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 ]

188197

189198 PortOut name tipe value ->

190199 do value' <- expression value

191− return $ obj "Native.Ports.portOut" `call`

200+ return $ Var.value "Native.Ports" "portOut" `call`

192201 [ string name, Port.outgoing tipe, value' ]

193202

194−definition :: Def -> State Int [Statement ()]

195−definition (Definition pattern expr@(A region _) _) = do

203+definition :: Canonical.Def -> State Int [Statement ()]

204+definition (Canonical.Definition pattern expr@(A region _) _) = do

196205 expr' <- expression expr

197206 let assign x = varDecl x expr'

198207 case pattern of

@@ -201,39 +210,39 @@ definition (Definition pattern expr@(A region _) _) = do

201210 let op = LBracket () (ref "_op") (string x) in

202211 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

203212 | otherwise ->

204− return [ VarDeclStmt () [ assign x ] ]

213+ return [ VarDeclStmt () [ assign (Var.varName x) ] ]

205214

206215 P.Record fields ->

207− let setField f = varDecl f (dotSep ["$",f]) in

216+ let setField f = varDecl f (obj ["$",f]) in

208217 return [ VarDeclStmt () (assign "$" : map setField fields) ]

209218

210− P.Data name patterns | vars /= Nothing ->

219+ P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

211220 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

212221 where

213222 vars = getVars patterns

214223 getVars patterns =

215224 case patterns of

216− P.Var x : rest -> (x:) `fmap` getVars rest

225+ P.Var x : rest -> (Var.varName x :) `fmap` getVars rest

217226 [] -> Just []

218227 _ -> Nothing

219228

220− decl x n = varDecl x (dotSep ["$","_" ++ show n])

229+ decl x n = varDecl x (obj ["$","_" ++ show n])

221230 setup vars

222231 | Help.isTuple name = assign "$" : vars

223232 | otherwise = assign "_raw" : safeAssign : vars

224233

225− safeAssign = varDecl "$" (CondExpr () if' (obj "_raw") exception)

226− if' = InfixExpr () OpStrictEq (obj "_raw.ctor") (string name)

227− exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]

234+ safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

235+ if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

236+ exception = Help.throw "Case" region

228237

229238 _ ->

230239 do defs' <- concat <$> mapM toDef vars

231240 return (VarDeclStmt () [assign "_"] : defs')

232241 where

233242 vars = P.boundVarList pattern

234− mkVar = A region . rawVar

243+ mkVar = A region . localVar

235244 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

237246

238247match :: Region -> Case.Match -> State Int [Statement ()]

239248match region mtch =

@@ -248,15 +257,15 @@ match region mtch =

248257 _ -> False

249258

250259 access name

251− | any isLiteral clauses = obj name

252− | otherwise = dotSep (split name ++ ["ctor"])

260+ | any isLiteral clauses = obj [name]

261+ | otherwise = obj (Help.splitDots name ++ ["ctor"])

253262

254263 format isChars e

255264 | or isChars = InfixExpr () OpAdd e (string "")

256265 | otherwise = e

257266

258267 Case.Fail ->

259− return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]

268+ return [ ExprStmt () (Help.throw "Case" region) ]

260269

261270 Case.Break -> return [BreakStmt () Nothing]

262271

@@ -283,98 +292,133 @@ clause region variable (Case.Clause value vars mtch) =

283292 _ -> (,) False $ case value of

284293 Right (Boolean b) -> BoolLit () b

285294 Right lit -> literal lit

286− Left name -> string $ case List.elemIndices '.' name of

287− [] -> name

288− is -> drop (last is + 1) name

295+ Left (Var.Canonical _ name) ->

296+ string name

289297

290−flattenLets :: [Def] -> Expr -> ([Def], Expr)

298+flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)

291299flattenLets defs lexpr@(A _ expr) =

292300 case expr of

293301 Let ds body -> flattenLets (defs ++ ds) body

294302 _ -> (defs, lexpr)

295303

296−generate :: MetadataModule -> String

297−generate unsafeModule =

298− show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++

299− [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]

304+generate :: CanonicalModule -> String

305+generate modul =

306+ show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

307+ [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]

300308 where

301− modul = MakeSafe.metadataModule unsafeModule

302− thisModule = dotSep ("_elm" : names modul ++ ["values"])

309+ names :: [String]

310+ names = Module.names modul

311+

312+ thisModule :: Expression ()

313+ thisModule = obj ("_elm" : names ++ ["values"])

314+

315+ programStmts :: [Statement ()]

303316 programStmts =

304317 concat

305− [ [ ExprStmt () $ string "use strict" ]

306− , setup (Just "_elm") (names modul ++ ["values"])

318+ [ [ ExprStmt () (string "use strict") ]

319+ , setup "_elm" (names ++ ["values"])

307320 , [ IfSingleStmt () thisModule (ret thisModule) ]

308− , [ internalImports (List.intercalate "." (names modul)) ]

309− , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul

310− , [ assign ["_op"] (ObjectLit () []) ]

311− , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0

321+ , [ VarDeclStmt () localVars ]

322+ , body

312323 , [ jsExports ]

313324 , [ ret thisModule ]

314325 ]

315326

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)

317352 where

318− exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul

353+ exs = map entry $ "_op" : concatMap extract (exports modul)

319354 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

320361

321362 assign path expr =

322363 case path of

323364 [x] -> VarDeclStmt () [ varDecl x expr ]

324365 _ -> ExprStmt () $

325− AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr

326−

327− jsImport modul = setup Nothing path ++ [ include ]

328− where

329− path = Help.splitDots modul

330− include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"

331−

332− setup namespace path = map create paths

333− where

334− create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))

335− paths = case namespace of

336− Nothing -> tail . init $ List.inits path

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)

366+ AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

367+

368+binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr

369+ -> State Int (Expression ())

370+binop region func@(Var.Canonical home op) e1 e2 =

371+ case (home, op) of

372+ (Var.Module "Basics", ">>") ->

373+ do es <- mapM expression (collectLeftAssoc [e2] e1)

374+ return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es

375+

376+ (Var.Module "Basics", "<<") ->

377+ do es <- mapM expression (e1 : collectRightAssoc [] e2)

344378 return $ ["$"] ==> foldr (<|) (ref "$") es

345− "Basics.<|" ->

379+

380+ (Var.Module "Basics", "<|") ->

346381 do e2' <- expression e2

347− es <- mapM expression (collect [] e1)

382+ es <- mapM expression (collectRightAssoc [] e1)

348383 return $ foldr (<|) e2' es

349− "List.++" ->

384+

385+ (Var.Module "List", "++") ->

350386 do e1' <- expression e1

351387 e2' <- expression e2

352− return $ obj "_L.append" `call` [e1', e2']

353− "::" -> expression (A region (Data "::" [e1,e2]))

354− _ ->

388+ return $ _List "append" `call` [e1', e2']

389+

390+ (Var.BuiltIn, "::") ->

391+ expression (A region (Data "::" [e1,e2]))

392+

393+ (Var.Module "Basics", _) ->

355394 do e1' <- expression e1

356395 e2' <- expression e2

357− return $ case Map.lookup op opDict of

396+ return $ case Map.lookup op basicOps of

358397 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+

360405 where

361− collect es e =

406+ collectRightAssoc es e =

362407 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

364410 _ -> es ++ [e]

365411

366− func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)

367− | otherwise = dotSep parts

368− where

369− parts = Help.splitDots op

370− operator = last parts

371−

372− opDict = Map.fromList (infixOps ++ specialOps)

412+ collectLeftAssoc es e =

413+ case e of

414+ A _ (Binop (Var.Canonical (Var.Module "Basics") ">>") e1 e2) ->

415+ collectLeftAssoc (e2 : es) e1

416+ _ -> e : es

373417

374− specialOp str func = [ (str, func), ("Basics." ++ str, func) ]

375− infixOp str op = specialOp str (InfixExpr () op)

418+ basicOps = Map.fromList (infixOps ++ specialOps)

376419

377− infixOps = concat

420+ infixOps =

421+ let infixOp str op = (str, InfixExpr () op) in

378422 [ infixOp "+" OpAdd

379423 , infixOp "-" OpSub

380424 , infixOp "*" OpMul

@@ -383,16 +427,16 @@ binop region op e1 e2 =

383427 , infixOp "||" OpLOr

384428 ]

385429

386− specialOps = concat

387− [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]

388− , specialOp "|>" $ flip (<|)

389− , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]

390− , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])

391− , specialOp "<" $ cmp OpLT 0

392− , specialOp ">" $ cmp OpGT 0

393− , specialOp "<=" $ cmp OpLT 1

394− , specialOp ">=" $ cmp OpGT (-1)

395− , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

430+ specialOps =

431+ [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

432+ , (,) "|>" $ flip (<|)

433+ , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]

434+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])

435+ , (,) "<" $ cmp OpLT 0

436+ , (,) ">" $ cmp OpGT 0

437+ , (,) "<=" $ cmp OpLT 1

438+ , (,) ">=" $ cmp OpGT (-1)

439+ , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

396440 ]

397441

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

11{-# OPTIONS_GHC -W #-}

22module Generate.JavaScript.Helpers where

33

4−import qualified SourceSyntax.Helpers as Help

4+import AST.Annotation (Region)

5+import qualified AST.PrettyPrint as PP

56import Language.ECMAScript3.Syntax

67

7−split :: String -> [String]

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]

8+-- Creating Variables

159

10+var :: String -> Id ()

1611var name = Id () name

12+

13+ref :: String -> Expression ()

1714ref name = VarRef () (var name)

15+

16+prop :: String -> Prop ()

1817prop name = PropId () (var name)

19−f <| x = CallExpr () f [x]

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 ()

18+

2419string = StringLit ()

2520

26−dotSep vars =

21+obj :: [String] -> Expression ()

22+obj vars =

2723 case vars of

2824 x:xs -> foldl (DotRef ()) (ref x) (map var xs)

2925 [] -> error "dotSep must be called on a non-empty list of variables"

3026

31−obj = dotSep . split

27+-- Specific Utilities

3228

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 ()

3356equal a b = InfixExpr () OpStrictEq a b

57+

58+instanceof :: String -> Expression () -> Expression ()

3459instanceof tipe x =

3560 InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))

61+

62+typeof :: String -> Expression () -> Expression ()

3663typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)

64+

65+member :: String -> Expression () -> Expression ()

3766member field x = InfixExpr () OpIn (string field) x

compiler/Generate/JavaScript/Ports.hs+105−74

@@ -2,8 +2,9 @@

22module Generate.JavaScript.Ports (incoming, outgoing) where

33

44import Generate.JavaScript.Helpers

5−import qualified SourceSyntax.Helpers as Help

6−import SourceSyntax.Type as T

5+import qualified Generate.JavaScript.Variable as V

6+import AST.Type as T

7+import qualified AST.Variable as Var

78import Language.ECMAScript3.Syntax

89

910data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]

@@ -14,64 +15,68 @@ check x jsType continue =

1415 CondExpr () (jsFold OpLOr checks x) continue throw

1516 where

1617 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

1819 msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")

19− checks = case jsType of

20− JSNumber -> [typeof "number"]

21− JSBoolean -> [typeof "boolean"]

22− JSString -> [typeof "string", instanceof "String"]

23− JSArray -> [(obj "_U.isJSArray" <|)]

24− JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]

25−

26−incoming :: Type -> Expression ()

20+ checks =

21+ case jsType of

22+ JSNumber -> [typeof "number"]

23+ JSBoolean -> [typeof "boolean"]

24+ JSString -> [typeof "string", instanceof "String"]

25+ JSArray -> [(obj ["_U","isJSArray"] <|)]

26+ JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]

27+

28+incoming :: CanonicalType -> Expression ()

2729incoming tipe =

2830 case tipe of

29− Data "Signal.Signal" [t] ->

30− obj "Native.Ports.incomingSignal" <| incoming t

31+ Aliased _ t -> incoming t

32+

33+ App (Type v) [t]

34+ | Var.isSignal v -> V.value "Native.Ports" "incomingSignal" <| incoming t

35+

3136 _ -> ["v"] ==> inc tipe (ref "v")

3237

33−inc :: Type -> Expression () -> Expression ()

38+inc :: CanonicalType -> Expression () -> Expression ()

3439inc tipe x =

3540 case tipe of

3641 Lambda _ _ -> error "functions should not be allowed through input ports"

3742 Var _ -> error "type variables should not be allowed through input ports"

38−

39− Data "Json.Value" [] ->

40− obj "Native.Json.fromJS" <| x

41−

42− Data ctor []

43− | ctor == "Int" -> from JSNumber

44− | ctor == "Float" -> from JSNumber

45− | ctor == "Bool" -> from JSBoolean

46− | ctor == "String" -> from JSString

43+ Aliased _ t ->

44+ inc t x

45+

46+ Type (Var.Canonical Var.BuiltIn name)

47+ | name == "Int" -> from JSNumber

48+ | name == "Float" -> from JSNumber

49+ | name == "Bool" -> from JSBoolean

50+ | name == "String" -> from JSString

4751 where

4852 from checks = check x checks x

4953

50− Data ctor [t]

51− | ctor == "Maybe.Maybe" ->

52− CondExpr () (equal x (NullLit ()))

53− (obj "Maybe.Nothing")

54− (obj "Maybe.Just" <| inc t x)

54+ Type name

55+ | Var.isJson name -> V.value "Native.Json" "fromJS" <| x

56+ | Var.isTuple name -> incomingTuple [] x

57+ | otherwise -> error "bad type got to incoming port generation code"

5558

56− | ctor == "_List" ->

57− check x JSArray (obj "_L.fromArray" <| array)

59+ App f args ->

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)

5867

59− | ctor == "Array.Array" ->

60− check x JSArray (obj "_A.fromJSArray" <| array)

68+ | Var.isList name ->

69+ check x JSArray (obj ["_L","fromArray"] <| array)

6170

62− where

63− array = DotRef () x (var "map") <| incoming t

71+ | Var.isArray name ->

72+ check x JSArray (obj ["_A","fromJSArray"] <| array)

73+ where

74+ array = DotRef () x (var "map") <| incoming t

6475

65− Data ctor ts

66− | Help.isTuple ctor -> check x JSArray tuple

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

76+ Type name : ts

77+ | Var.isTuple name -> incomingTuple ts x

7278

73− Data _ _ ->

74− error "bad ADT got to incoming port generation code"

79+ _ -> error "bad ADT got to incoming port generation code"

7580

7681 Record _ (Just _) ->

7782 error "bad record got to incoming port generation code"

@@ -83,15 +88,34 @@ inc tipe x =

8388 keys = map convert fields

8489 convert (f,t) = (prop f, inc t (DotRef () x (var f)))

8590

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 ()

86105outgoing tipe =

87106 case tipe of

88− Data "Signal.Signal" [t] ->

89− obj "Native.Ports.outgoingSignal" <| outgoing t

107+ Aliased _ t -> outgoing t

108+

109+ App (Type v) [t]

110+ | Var.isSignal v -> V.value "Native.Ports" "outgoingSignal" <| outgoing t

111+

90112 _ -> ["v"] ==> out tipe (ref "v")

91113

92−out :: Type -> Expression () -> Expression ()

114+out :: CanonicalType -> Expression () -> Expression ()

93115out tipe x =

94116 case tipe of

117+ Aliased _ t -> out t x

118+

95119 Lambda _ _

96120 | numArgs > 1 && numArgs < 10 ->

97121 func (ref ('A':show numArgs) `call` (x:values))

@@ -101,36 +125,43 @@ out tipe x =

101125 numArgs = length ts - 1

102126 args = map (\n -> '_' : show n) [0..]

103127 values = zipWith inc (init ts) (map ref args)

104− func body = function (take numArgs args)

105− [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]

106− , ret (out (last ts) (ref "_r"))

107− ]

128+ func body =

129+ function (take numArgs args)

130+ [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]

131+ , ret (out (last ts) (ref "_r"))

132+ ]

108133

109134 Var _ -> error "type variables should not be allowed through input ports"

110− Data ctor []

111− | ctor `elem` ["Int","Float","Bool","String"] -> x

112− | ctor == "Json.Value" ->

113− obj "Native.Json.toJS" <| x

114−

115− Data ctor [t]

116− | ctor == "Maybe.Maybe" ->

117− CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))

118− (NullLit ())

119− (out t (DotRef () x (var "_0")))

120−

121− | ctor == "_List" ->

122− DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t

123−

124− | ctor == "Array.Array" ->

125− DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t

126−

127− Data ctor ts

128− | Help.isTuple ctor ->

129− let convert n t = out t $ DotRef () x $ var ('_':show n)

130− in ArrayLit () $ zipWith convert [0..] ts

131−

132− Data _ _ ->

133− error "bad ADT got to outgoing port generation code"

135+

136+ Type (Var.Canonical Var.BuiltIn name)

137+ | name `elem` ["Int","Float","Bool","String"] -> x

138+

139+ Type name

140+ | Var.isJson name -> V.value "Native.Json" "toJS" <| x

141+ | Var.isTuple name -> ArrayLit () []

142+ | otherwise -> error "bad type got to outgoing port generation code"

143+

144+ App f args ->

145+ case f : args of

146+ Type name : [t]

147+ | Var.isMaybe name ->

148+ CondExpr ()

149+ (equal (DotRef () x (var "ctor")) (string "Nothing"))

150+ (NullLit ())

151+ (out t (DotRef () x (var "_0")))

152+

153+ | Var.isArray name ->

154+ DotRef () (obj ["_A","toJSArray"] <| x) (var "map") <| outgoing t

155+

156+ | Var.isList name ->

157+ DotRef () (obj ["_L","toArray"] <| x) (var "map") <| outgoing t

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"

134165

135166 Record _ (Just _) ->

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

11module Generate.Markdown where

22

3−import Text.Pandoc

3+import qualified Cheapskate as CS

4+import qualified Cheapskate.Html as CS

45import 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

514

615toHtml :: 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

822

9−readOptions =

10− def { readerExtensions = elmExtensions

11− , readerApplyMacros = False

12− }

23+options :: CS.Options

24+options =

25+ CS.Options

26+ { CS.sanitize = False

27+ , CS.allowRawHtml = True

28+ , CS.preserveHardBreaks = False

29+ , CS.debug = False

30+ }

1331

14−writeOptions =

15− def { writerExtensions = elmExtensions

16− , writerHighlight = True

17− }

32+highlightCode :: CS.Block -> CS.Block

33+highlightCode block =

34+ case block of

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

1841

19−elmExtensions :: Set.Set Extension

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− ]

42+ _ -> block

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

22module Metadata.Prelude (interfaces, add) where

33

44import qualified Data.Map as Map

5+import qualified Data.Set as Set

56import qualified Control.Exception as E

67import System.Exit

78import System.IO

8−import SourceSyntax.Module

9+import AST.Module as Module

10+import qualified AST.Variable as Var

911import qualified Build.Interface as Interface

1012import Build.Utils (getDataFile)

1113

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

1614

17− addModule (n, method) = case lookup n ims of

18− Nothing -> [(n, method)]

19− Just (As _) -> [(n, method)]

20− Just _ -> []

15+-- DEFINITION OF THE PRELUDE

2116

22−prelude :: [(String, ImportMethod)]

23−prelude = string ++ text ++ map (\n -> (n, Hiding [])) modules

17+type ImportDict =

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

2475 where

25− text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]

26− string = map ((,) "String") [ As "String", Importing ["show"] ]

27− modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Color"

28− , "Graphics.Element", "Graphics.Collage"

29− , "Native.Ports", "Native.Json"

30− ]

76+ mergeMethods :: Maybe ([String], Var.Listing Var.Value)

77+ -> Maybe ([String], Var.Listing Var.Value)

78+ mergeMethods entry =

79+ let (qualifiers, listing) =

80+ case entry of

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

3196

3297interfaces :: Bool -> IO Interfaces

3398interfaces noPrelude =

@@ -42,14 +107,14 @@ safeReadDocs name =

42107 hPutStrLn stderr $ unlines $

43108 [ "Error reading types for standard library from file " ++ name

44109 , " 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"

46111 , " Elm and your OS." ]

47112 exitFailure

48113

49114readDocs :: FilePath -> IO Interfaces

50115readDocs filePath = do

51116 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

53118 Left err -> do

54119 hPutStrLn stderr err

55120 exitFailure

compiler/Parse/Binop.hs+19−17

@@ -5,9 +5,11 @@ import Control.Applicative ((<$>))

55import qualified Data.List as List

66import qualified Data.Map as Map

77

8−import SourceSyntax.Annotation (merge)

9−import qualified SourceSyntax.Expression as E

10−import SourceSyntax.Declaration (Assoc(..))

8+import AST.Annotation (merge)

9+import AST.Declaration (Assoc(..))

10+import AST.Expression.General (Expr'(Binop))

11+import qualified AST.Expression.Source as Source

12+import qualified AST.Variable as Var

1113import Text.Parsec

1214import Parse.Helpers

1315

@@ -17,13 +19,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table

1719opAssoc :: OpTable -> String -> Assoc

1820opAssoc table op = snd $ Map.findWithDefault (9,L) op table

1921

20−hasLevel :: OpTable -> Int -> (String, E.ParseExpr) -> Bool

22+hasLevel :: OpTable -> Int -> (String, Source.Expr) -> Bool

2123hasLevel table n (op,_) = opLevel table op == n

2224

23−binops :: IParser E.ParseExpr

24− -> IParser E.ParseExpr

25+binops :: IParser Source.Expr

26+ -> IParser Source.Expr

2527 -> IParser String

26− -> IParser E.ParseExpr

28+ -> IParser Source.Expr

2729binops term last anyOp =

2830 do e <- term

2931 table <- getState

@@ -39,9 +41,9 @@ binops term last anyOp =

3941

4042split :: OpTable

4143 -> Int

42− -> E.ParseExpr

43− -> [(String, E.ParseExpr)]

44− -> IParser E.ParseExpr

44+ -> Source.Expr

45+ -> [(String, Source.Expr)]

46+ -> IParser Source.Expr

4547split _ _ e [] = return e

4648split table n e eops = do

4749 assoc <- getAssoc table n eops

@@ -50,26 +52,26 @@ split table n e eops = do

5052 case assoc of R -> joinR es ops

5153 _ -> joinL es ops

5254

53−splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]

54− -> [IParser E.ParseExpr]

55+splitLevel :: OpTable -> Int -> Source.Expr -> [(String, Source.Expr)]

56+ -> [IParser Source.Expr]

5557splitLevel table n e eops =

5658 case break (hasLevel table n) eops of

5759 (lops, (_op,e'):rops) ->

5860 split table (n+1) e lops : splitLevel table n e' rops

5961 (lops, []) -> [ split table (n+1) e lops ]

6062

61−joinL :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr

63+joinL :: [Source.Expr] -> [String] -> IParser Source.Expr

6264joinL [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

6466joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

6567

66−joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr

68+joinR :: [Source.Expr] -> [String] -> IParser Source.Expr

6769joinR [e] [] = return e

6870joinR (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))

7072joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

7173

72−getAssoc :: OpTable -> Int -> [(String,E.ParseExpr)] -> IParser Assoc

74+getAssoc :: OpTable -> Int -> [(String,Source.Expr)] -> IParser Assoc

7375getAssoc table n eops

7476 | all (==L) assocs = return L

7577 | all (==R) assocs = return R

compiler/Parse/Declaration.hs+7−8

@@ -7,16 +7,15 @@ import Text.Parsec hiding (newline,spaces)

77import Parse.Helpers

88import qualified Parse.Expression as Expr

99import qualified Parse.Type as Type

10−import qualified SourceSyntax.Declaration as D

10+import qualified AST.Declaration as D

1111

12−

13−declaration :: IParser D.ParseDeclaration

12+declaration :: IParser D.SourceDecl

1413declaration = alias <|> datatype <|> infixDecl <|> port <|> definition

1514

16−definition :: IParser D.ParseDeclaration

15+definition :: IParser D.SourceDecl

1716definition = D.Definition <$> Expr.def

1817

19−alias :: IParser D.ParseDeclaration

18+alias :: IParser D.SourceDecl

2019alias = do

2120 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

2221 forcedWS

@@ -26,7 +25,7 @@ alias = do

2625 tipe <- Type.expr

2726 return (D.TypeAlias name args tipe)

2827

29−datatype :: IParser D.ParseDeclaration

28+datatype :: IParser D.SourceDecl

3029datatype = do

3130 reserved "data" <?> "datatype definition (data T = A | B | ...)"

3231 forcedWS

@@ -37,7 +36,7 @@ datatype = do

3736 return $ D.Datatype name args tcs

3837

3938

40−infixDecl :: IParser D.ParseDeclaration

39+infixDecl :: IParser D.SourceDecl

4140infixDecl = do

4241 assoc <- choice [ reserved "infixl" >> return D.L

4342 , reserved "infix" >> return D.N

@@ -48,7 +47,7 @@ infixDecl = do

4847 D.Fixity assoc (read [n]) <$> anyOp

4948

5049

51−port :: IParser D.ParseDeclaration

50+port :: IParser D.SourceDecl

5251port =

5352 do try (reserved "port")

5453 whitespace

compiler/Parse/Expression.hs+38−35

@@ -6,45 +6,47 @@ import Text.Parsec hiding (newline,spaces)

66import Text.Parsec.Indent

77

88import Parse.Binop

9−import Parse.Helpers

9+import Parse.Helpers as Help

1010import Parse.Literal

1111import qualified Parse.Pattern as Pattern

1212import qualified Parse.Type as Type

1313

14−import SourceSyntax.Annotation as Annotation

15−import qualified SourceSyntax.Pattern as P

16−import qualified SourceSyntax.Literal as L

17−import SourceSyntax.Expression

14+import AST.Annotation as Annotation

15+import AST.Expression.General

16+import qualified AST.Expression.Source as Source

17+import qualified AST.Literal as L

18+import qualified AST.Pattern as P

19+import qualified AST.Variable as Var

1820

1921

2022-------- Basic Terms --------

2123

22−varTerm :: IParser ParseExpr'

24+varTerm :: IParser Source.Expr'

2325varTerm = toVar <$> var <?> "variable"

2426

25−toVar :: String -> ParseExpr'

27+toVar :: String -> Source.Expr'

2628toVar v = case v of "True" -> Literal (L.Boolean True)

2729 "False" -> Literal (L.Boolean False)

2830 _ -> rawVar v

2931

30−accessor :: IParser ParseExpr'

32+accessor :: IParser Source.Expr'

3133accessor = do

3234 (start, lbl, end) <- located (try (string "." >> rLabel))

3335 let loc e = Annotation.at start end e

3436 return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))

3537

36−negative :: IParser ParseExpr'

38+negative :: IParser Source.Expr'

3739negative = do

3840 (start, nTerm, end) <-

3941 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

4042 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)

4244

4345

4446-------- Complex Terms --------

4547

46−listTerm :: IParser ParseExpr'

47−listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> commaSep expr)

48+listTerm :: IParser Source.Expr'

49+listTerm = markdown' <|> shader' <|> braces (try range <|> ExplicitList <$> commaSep expr)

4850 where

4951 range = do

5052 lo <- expr

@@ -54,17 +56,18 @@ listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> co

5456 markdown' = do

5557 pos <- getPosition

5658 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

57− (rawText, exprs) <- markdown (interpolation uid)

59+ (rawText, exprs) <- Help.markdown (interpolation uid)

5860 return (Markdown uid (filter (/='\r') rawText) exprs)

5961

60− glShader' = do

62+ shader' = do

6163 pos <- getPosition

6264 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

63− (rawSrc, tipe) <- glShader

65+ (rawSrc, tipe) <- Help.shader

6466 return $ GLShader uid (filter (/='\r') rawSrc) tipe

6567

6668 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>"

6871

6972 interpolation uid exprs = do

7073 try (string "{{")

@@ -72,14 +75,14 @@ listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> co

7275 string "}}"

7376 return (span uid (length exprs), exprs ++ [e])

7477

75−parensTerm :: IParser ParseExpr

78+parensTerm :: IParser Source.Expr

7679parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

7780 where

7881 opFn = do

7982 (start, op, end) <- located anyOp

8083 let loc = Annotation.at start end

8184 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"))

8386

8487 tupleFn = do

8588 let comma = char ',' <?> "comma ','"

@@ -95,7 +98,7 @@ parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

9598 [e] -> e

9699 _ -> Annotation.at start end (tuple es)

97100

98−recordTerm :: IParser ParseExpr

101+recordTerm :: IParser Source.Expr

99102recordTerm = brackets $ choice [ misc, addLocation record ]

100103 where

101104 field = do

@@ -129,14 +132,14 @@ recordTerm = brackets $ choice [ misc, addLocation record ]

129132 Nothing -> try (insert record) <|> try (modify record)

130133

131134

132−term :: IParser ParseExpr

135+term :: IParser Source.Expr

133136term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

134137 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

135138 <?> "basic term (4, x, 'c', etc.)"

136139

137140-------- Applications --------

138141

139−appExpr :: IParser ParseExpr

142+appExpr :: IParser Source.Expr

140143appExpr = do

141144 t <- term

142145 ts <- constrainedSpacePrefix term $ \str ->

@@ -147,12 +150,12 @@ appExpr = do

147150

148151-------- Normal Expressions --------

149152

150−binaryExpr :: IParser ParseExpr

153+binaryExpr :: IParser Source.Expr

151154binaryExpr = binops appExpr lastExpr anyOp

152155 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

153156 <|> lambdaExpr

154157

155−ifExpr :: IParser ParseExpr'

158+ifExpr :: IParser Source.Expr'

156159ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

157160 where

158161 normal = do

@@ -168,7 +171,7 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

168171 b <- expr ; padded arrow

169172 (,) b <$> expr

170173

171−lambdaExpr :: IParser ParseExpr

174+lambdaExpr :: IParser Source.Expr

172175lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

173176 whitespace

174177 args <- spaceSep1 Pattern.term

@@ -176,17 +179,17 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

176179 body <- expr

177180 return (makeFunction args body)

178181

179−defSet :: IParser [ParseDef]

182+defSet :: IParser [Source.Def]

180183defSet = block (do d <- def ; whitespace ; return d)

181184

182−letExpr :: IParser ParseExpr'

185+letExpr :: IParser Source.Expr'

183186letExpr = do

184187 reserved "let" ; whitespace

185188 defs <- defSet

186189 padded (reserved "in")

187190 Let defs <$> expr

188191

189−caseExpr :: IParser ParseExpr'

192+caseExpr :: IParser Source.Expr'

190193caseExpr = do

191194 reserved "case"; e <- padded expr; reserved "of"; whitespace

192195 Case e <$> (with <|> without)

@@ -196,13 +199,13 @@ caseExpr = do

196199 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

197200 without = block (do c <- case_ ; whitespace ; return c)

198201

199−expr :: IParser ParseExpr

202+expr :: IParser Source.Expr

200203expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

201204 <|> lambdaExpr

202205 <|> binaryExpr

203206 <?> "an expression"

204207

205−defStart :: IParser [P.Pattern]

208+defStart :: IParser [P.RawPattern]

206209defStart =

207210 choice [ do p1 <- try Pattern.term

208211 infics p1 <|> func p1

@@ -222,24 +225,24 @@ defStart =

222225 return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]

223226 else [ P.Var (o:p), p1, p2 ]

224227

225−makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr

228+makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr

226229makeFunction args body@(A ann _) =

227230 foldr (\arg body' -> A ann $ Lambda arg body') body args

228231

229−definition :: IParser ParseDef

232+definition :: IParser Source.Def

230233definition = withPos $ do

231234 (name:args) <- defStart

232235 padded equals

233236 body <- expr

234− return . Def name $ makeFunction args body

237+ return . Source.Definition name $ makeFunction args body

235238

236−typeAnnotation :: IParser ParseDef

237−typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

239+typeAnnotation :: IParser Source.Def

240+typeAnnotation = Source.TypeAnnotation <$> try start <*> Type.expr

238241 where

239242 start = do

240243 v <- lowVar <|> parens symOp

241244 padded hasType

242245 return v

243246

244−def :: IParser ParseDef

247+def :: IParser Source.Def

245248def = typeAnnotation <|> definition

compiler/Parse/Helpers.hs+14−31

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

66import Control.Monad

77import Control.Monad.State

88import Data.Char (isUpper)

9−import qualified Data.Set as Set

109import qualified Data.Map as Map

1110import qualified Language.GLSL.Parser as GLP

1211import Language.GLSL.Syntax as GLS

@@ -14,13 +13,14 @@ import Text.Parsec hiding (newline,spaces,State)

1413import Text.Parsec.Indent

1514import qualified Text.Parsec.Token as T

1615

17−import SourceSyntax.Annotation as Annotation

18−import SourceSyntax.Declaration (Assoc)

19−import SourceSyntax.Expression

20−import SourceSyntax.Helpers as Help

21−import SourceSyntax.Literal as Literal

22−import SourceSyntax.PrettyPrint

23−import SourceSyntax.Variable as Variable

16+import AST.Annotation as Annotation

17+import AST.Declaration (Assoc)

18+import AST.Expression.General

19+import qualified AST.Expression.Source as Source

20+import AST.Helpers as Help

21+import AST.Literal as Literal

22+import AST.PrettyPrint

23+import qualified AST.Variable as Variable

2424

2525reserveds = [ "if", "then", "else"

2626 , "case", "of"

@@ -29,25 +29,8 @@ reserveds = [ "if", "then", "else"

2929 , "module", "where"

3030 , "import", "as", "hiding", "open"

3131 , "export", "foreign"

32− , "deriving", "port" ]

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− ]

32+ , "deriving", "port"

33+ ]

5134

5235expecting = flip (<?>)

5336

@@ -200,7 +183,7 @@ located p = do

200183 end <- getPosition

201184 return (start, e, end)

202185

203−accessible :: IParser ParseExpr -> IParser ParseExpr

186+accessible :: IParser Source.Expr -> IParser Source.Expr

204187accessible expr = do

205188 start <- getPosition

206189 ce@(A _ e) <- expr

@@ -324,9 +307,9 @@ markdown interpolation =

324307 closeMarkdown (markdownBuilder . (c:)) stuff

325308 ]

326309

327−glShader :: IParser (String, Literal.GLShaderTipe)

328−glShader =

329− do try (string "[glShader|")

310+shader :: IParser (String, Literal.GLShaderTipe)

311+shader =

312+ do try (string "[glsl|")

330313 rawSrc <- closeShader id

331314 case glSource rawSrc of

332315 Left err -> parserFail . show $ err

compiler/Parse/Literal.hs+1−1

@@ -4,7 +4,7 @@ module Parse.Literal (literal) where

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

55import Text.Parsec hiding (newline,spaces)

66import Parse.Helpers

7−import SourceSyntax.Literal

7+import AST.Literal

88

99literal :: IParser Literal

1010literal = num <|> (Str <$> str) <|> (Chr <$> chr) <?> "literal"

compiler/Parse/Module.hs+31−14

@@ -5,10 +5,8 @@ import Data.List (intercalate)

55import Text.Parsec hiding (newline,spaces)

66

77import Parse.Helpers

8−import SourceSyntax.Module (ImportMethod(..), Imports)

9−

10−varList :: IParser [String]

11−varList = commaSep1 (var <|> parens symOp)

8+import AST.Module (ImportMethod(..))

9+import AST.Variable (Listing(..), Value(..), openListing)

1210

1311getModuleName :: String -> Maybe String

1412getModuleName source =

@@ -21,18 +19,18 @@ getModuleName source =

2119 (names, _) <- moduleDef

2220 return (intercalate "." names)

2321

24−moduleDef :: IParser ([String], [String])

22+moduleDef :: IParser ([String], Listing Value)

2523moduleDef = do

2624 try (reserved "module")

2725 whitespace

2826 names <- dotSep1 capVar <?> "name of module"

2927 whitespace

30− exports <- option [] (parens varList)

28+ exports <- option (Listing [] True) (listing value)

3129 whitespace <?> "reserved word 'where'"

3230 reserved "where"

3331 return (names, exports)

3432

35−imports :: IParser Imports

33+imports :: IParser [(String, ImportMethod)]

3634imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))

3735

3836import' :: IParser (String, ImportMethod)

@@ -43,17 +41,36 @@ import' =

4341 (,) name <$> option (As name) method

4442 where

4543 method :: IParser ImportMethod

46− method = try $ do whitespace

47− as' <|> importing'

44+ method = as' <|> importing'

4845

4946 as' :: IParser ImportMethod

5047 as' = do

51− reserved "as"

48+ try (whitespace >> reserved "as")

5249 whitespace

5350 As <$> capVar <?> "alias for module"

5451

5552 importing' :: IParser ImportMethod

56− importing' =

57− parens (choice [ const (Hiding []) <$> string ".."

58− , Importing <$> varList

59− ] <?> "listing of imported values (x,y,z)")

53+ importing' = Open <$> listing value

54+

55+listing :: IParser a -> IParser (Listing a)

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

77import Text.Parsec hiding (newline,spaces)

88import qualified Text.PrettyPrint as P

99

10−import qualified SourceSyntax.Declaration as D

11−import qualified SourceSyntax.Module as M

10+import qualified AST.Declaration as D

11+import qualified AST.Module as M

12+import qualified AST.Variable as Var

1213import Parse.Helpers

1314import Parse.Declaration (infixDecl)

1415import Parse.Module

@@ -22,21 +23,24 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

2223decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

2324 (d:) <$> many freshDef

2425

25−program :: OpTable -> String -> Either [P.Doc] (M.Module D.Declaration)

26+program :: OpTable -> String -> Either [P.Doc] M.ValidModule

2627program table src =

27− do (M.Module names exs ims parseDecls) <- setupParserWithTable table programParser src

28− decls <- either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)

29− return $ M.Module names exs ims decls

28+ do (M.Module names filePath exs ims parseDecls) <-

29+ setupParserWithTable table programParser src

30+ decls <-

31+ either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)

32+ return $ M.Module names filePath exs ims decls

3033

31−programParser :: IParser (M.Module D.ParseDeclaration)

34+programParser :: IParser M.SourceModule

3235programParser =

3336 do optional freshLine

34− (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

37+ (names,exports) <-

38+ option (["Main"], Var.openListing) (moduleDef `followedBy` freshLine)

3539 is <- (do try (lookAhead $ reserved "import")

3640 imports `followedBy` freshLine) <|> return []

3741 declarations <- decls

3842 optional freshLine ; optional spaces ; eof

39− return $ M.Module names exports is declarations

43+ return $ M.Module names "" exports is declarations

4044

4145dependencies :: String -> Either [P.Doc] (String, [String])

4246dependencies =

compiler/Parse/Pattern.hs+13−12

@@ -8,54 +8,55 @@ import Text.Parsec hiding (newline,spaces,State)

88

99import Parse.Helpers

1010import Parse.Literal

11−import SourceSyntax.Literal

12−import qualified SourceSyntax.Pattern as P

11+import AST.Literal

12+import qualified AST.Pattern as P

13+import qualified AST.Variable as Var

1314

14−basic :: IParser P.Pattern

15+basic :: IParser P.RawPattern

1516basic = choice

1617 [ char '_' >> return P.Anything

1718 , do v <- var

1819 return $ case v of

1920 "True" -> P.Literal (Boolean True)

2021 "False" -> P.Literal (Boolean False)

21− c:_ | isUpper c -> P.Data v []

22+ c:_ | isUpper c -> P.Data (Var.Raw v) []

2223 _ -> P.Var v

2324 , P.Literal <$> literal

2425 ]

2526

26−asPattern :: P.Pattern -> IParser P.Pattern

27+asPattern :: P.RawPattern -> IParser P.RawPattern

2728asPattern pattern = do

2829 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))

2930 return $ case var of

3031 Just v -> P.Alias v pattern

3132 Nothing -> pattern

3233

33−record :: IParser P.Pattern

34+record :: IParser P.RawPattern

3435record = P.Record <$> brackets (commaSep1 lowVar)

3536

36−tuple :: IParser P.Pattern

37+tuple :: IParser P.RawPattern

3738tuple = do

3839 ps <- parens (commaSep expr)

3940 return $ case ps of

4041 [p] -> p

4142 _ -> P.tuple ps

4243

43−list :: IParser P.Pattern

44+list :: IParser P.RawPattern

4445list = P.list <$> braces (commaSep expr)

4546

46−term :: IParser P.Pattern

47+term :: IParser P.RawPattern

4748term =

4849 (choice [ record, tuple, list, basic ]) <?> "pattern"

4950

50−patternConstructor :: IParser P.Pattern

51+patternConstructor :: IParser P.RawPattern

5152patternConstructor = do

5253 v <- List.intercalate "." <$> dotSep1 capVar

5354 case v of

5455 "True" -> return $ P.Literal (Boolean True)

5556 "False" -> return $ P.Literal (Boolean False)

56− _ -> P.Data v <$> spacePrefix term

57+ _ -> P.Data (Var.Raw v) <$> spacePrefix term

5758

58−expr :: IParser P.Pattern

59+expr :: IParser P.RawPattern

5960expr = do

6061 patterns <- consSep1 (patternConstructor <|> term)

6162 asPattern (foldr1 P.cons patterns) <?> "pattern"

compiler/Parse/Type.hs+21−17

@@ -5,22 +5,23 @@ import Control.Applicative ((<$>),(<*>),(<*))

55import Data.List (intercalate)

66import Text.Parsec

77

8−import SourceSyntax.Type as T

8+import qualified AST.Type as T

9+import qualified AST.Variable as Var

910import Parse.Helpers

1011

11−tvar :: IParser T.Type

12+tvar :: IParser T.RawType

1213tvar = T.Var <$> lowVar <?> "type variable"

1314

14−list :: IParser T.Type

15−list = listOf <$> braces expr

15+list :: IParser T.RawType

16+list = T.listOf <$> braces expr

1617

17−tuple :: IParser T.Type

18+tuple :: IParser T.RawType

1819tuple = do ts <- parens (commaSep expr)

1920 return $ case ts of

2021 [t] -> t

21− _ -> tupleOf ts

22+ _ -> T.tupleOf ts

2223

23−record :: IParser T.Type

24+record :: IParser T.RawType

2425record =

2526 do char '{' ; whitespace

2627 rcrd <- extended <|> normal

@@ -33,7 +34,7 @@ record =

3334 extended = do

3435 ext <- try (lowVar <* (whitespace >> string "|"))

3536 whitespace

36− flip T.Record (Just ext) <$> commaSep1 field

37+ flip T.Record (Just (T.Var ext)) <$> commaSep1 field

3738

3839 field = do

3940 lbl <- rLabel

@@ -43,25 +44,28 @@ record =

4344capTypeVar :: IParser String

4445capTypeVar = intercalate "." <$> dotSep1 capVar

4546

46−constructor0 :: IParser T.Type

47+constructor0 :: IParser T.RawType

4748constructor0 =

4849 do name <- capTypeVar

49− return (T.Data name [])

50+ return (T.Type (Var.Raw name))

5051

51−term :: IParser T.Type

52+term :: IParser T.RawType

5253term = list <|> tuple <|> record <|> tvar <|> constructor0

5354

54−app :: IParser T.Type

55+app :: IParser T.RawType

5556app =

56− do name <- capTypeVar <|> try tupleCtor <?> "type constructor"

57+ do f <- constructor0 <|> try tupleCtor <?> "type constructor"

5758 args <- spacePrefix term

58− return (T.Data name args)

59+ return $ case args of

60+ [] -> f

61+ _ -> T.App f args

5962 where

6063 tupleCtor = do

6164 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))

6367

64−expr :: IParser T.Type

68+expr :: IParser T.RawType

6569expr =

6670 do t1 <- app <|> term

6771 arr <- optionMaybe $ try (whitespace >> arrow)

@@ -69,6 +73,6 @@ expr =

6973 Just _ -> T.Lambda t1 <$> (whitespace >> expr)

7074 Nothing -> return t1

7175

72−constructor :: IParser (String, [T.Type])

76+constructor :: IParser (String, [T.RawType])

7377constructor = (,) <$> (capTypeVar <?> "another type constructor")

7478 <*> 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 #-}

2−module Transform.Canonicalize (interface, metadataModule) where

1+{-# OPTIONS_GHC -W #-}

2+module Transform.Canonicalize (module') where

33

4−import Control.Arrow ((***))

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

6−import Control.Monad.Identity

7−import qualified Data.Either as Either

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

5+import Control.Monad.Error (runErrorT, throwError)

6+import Control.Monad.State (runState)

87import qualified Data.List as List

98import qualified Data.Map as Map

109import qualified Data.Set as Set

1110import qualified Data.Traversable as T

12−import SourceSyntax.Annotation as A

13−import SourceSyntax.Expression

14−import SourceSyntax.Module

15−import SourceSyntax.PrettyPrint (pretty)

16−import qualified SourceSyntax.Pattern as P

17−import qualified SourceSyntax.Type as Type

18−import qualified SourceSyntax.Variable as Var

11+

12+import AST.Expression.General (Expr'(..), dummyLet)

13+import qualified AST.Expression.Valid as Valid

14+import qualified AST.Expression.Canonical as Canonical

15+

16+import AST.Module (CanonicalBody(..))

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

1924import Text.PrettyPrint as P

2025

21−interface :: String -> ModuleInterface -> ModuleInterface

22−interface moduleName iface =

23− ModuleInterface

24− { iVersion = iVersion iface

25− , iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))

26− , iImports = iImports iface

27− , iAdts = map (both prefix renameCtors) (iAdts iface)

28− , iAliases = map (both prefix renameType') (iAliases iface)

29− , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

30− , iPorts = iPorts iface

31− }

26+import Transform.Canonicalize.Environment as Env

27+import qualified Transform.Canonicalize.Setup as Setup

28+import qualified Transform.Canonicalize.Type as Canonicalize

29+import qualified Transform.Canonicalize.Variable as Canonicalize

30+import qualified Transform.SortDefinitions as Transform

31+import qualified Transform.Declaration as Transform

32+

33+module' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule

34+module' interfaces modul =

35+ filterImports <$> modul'

3236 where

33− both f g (a,b,c) = (f a, b, g c)

34− prefix name = moduleName ++ "." ++ name

35−

36− pair name = (name, moduleName ++ "." ++ name)

37− canon (name,_,_) = pair name

38− canons = Map.fromList $ concat

39− [ map canon (iAdts iface), map canon (iAliases iface) ]

40−

41− renameCtors ctors =

42− map (prefix *** map renameType') ctors

43− renameType' =

44− runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

45−

46−renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type

47−renameType renamer tipe =

48− let rnm = renameType renamer in

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' }

37+ (modul', usedModules) =

38+ runState (runErrorT (moduleHelp interfaces modul)) Set.empty

39+

40+ filterImports m =

41+ let used (name,_) = Set.member name usedModules

42+ in m { Module.imports = filter used (Module.imports m) }

43+

44+moduleHelp :: Module.Interfaces -> Module.ValidModule

45+ -> Canonicalizer [Doc] Module.CanonicalModule

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

47+ do env <- Setup.environment interfaces modul

48+ canonicalDecls <- mapM (declaration env) decls

49+ exports' <- resolveExports locals exports

50+ return $ modul { Module.exports = exports'

51+ , Module.body = body canonicalDecls

52+ }

6953 where

70− two2 f (a,b) = (,) a <$> f b

71− three3 f (a,b,c) = (,,) a b <$> f c

72− renameType' =

73− Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)

74−

75− get1 (a,_,_) = a

76− canon (name, importMethod) =

77− let pair pre var = (pre ++ drop (length name + 1) var, var)

78− iface = ifaces Map.! name

79− allNames = concat [ Map.keys (iTypes iface)

80− , map get1 (iAliases iface)

81− , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]

82− in case importMethod of

83− As alias -> map (pair (alias ++ ".")) allNames

84− Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

85− where vs = Set.fromList vars

86− Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames

87− where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars

88−

89− two n = (n,n)

90− localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))

91− globalEnv =

92− map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++

93− map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]

94− realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)

95− initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)

96−

97−type Env = Map.Map String String

98−

99−extend :: Env -> P.Pattern -> Env

100−extend env pattern = Map.union (Map.fromList (zip xs xs)) env

101− where xs = P.boundVarList pattern

102−

103−replace :: String -> Env -> String -> Either String String

104−replace variable env v =

105− if List.isPrefixOf "Native." v then return v else

106− case Map.lookup v env of

107− Just v' -> return v'

108− Nothing -> Left $ "Could not find " ++ variable ++ " '" ++ v ++ "'." ++ msg

54+ locals :: [Var.Value]

55+ locals = concatMap declToValue decls

56+

57+ body :: [D.CanonicalDecl] -> Module.CanonicalBody

58+ body decls =

59+ Module.CanonicalBody

60+ { program =

61+ let expr = Transform.toExpr (Module.getName modul) decls

62+ in Transform.sortDefs (dummyLet expr)

63+ , types = Map.empty

64+ , datatypes =

65+ Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]

66+ , fixities =

67+ [ (assoc,level,op) | D.Fixity assoc level op <- decls ]

68+ , aliases =

69+ Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]

70+ , ports =

71+ [ D.portName port | D.Port port <- decls ]

72+ }

73+

74+resolveExports :: [Var.Value] -> Var.Listing Var.Value -> Canonicalizer [Doc] [Var.Value]

75+resolveExports fullList (Var.Listing partialList open) =

76+ if open

77+ then return fullList

78+ else do

79+ valueExports <- getValueExports

80+ aliasExports <- concat `fmap` mapM getAliasExport aliases

81+ adtExports <- mapM getAdtExport adts

82+ return $ valueExports ++ aliasExports ++ adtExports

83+ where

84+ (allValues, allAliases, allAdts) = splitValues fullList

85+

86+ (values, aliases, adts) = splitValues partialList

87+

88+ getValueExports =

89+ case Set.toList (Set.difference values' allValues') of

90+ [] -> return (map Var.Value values)

91+ xs -> notFound xs

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

109175 where

110− matches = filter (List.isInfixOf v) (Map.keys env)

111− msg = if null matches then "" else

112− "\nClose matches include: " ++ List.intercalate ", " matches

113−

114−-- TODO: Var.Raw -> Var.Canonical

115−rename :: Env -> Expr -> Either [Doc] Expr

116−rename env (A ann expr) =

117− let rnm = rename env

118− throw err = Left [ P.vcat [ P.text "Error" <+> pretty ann <> P.colon

119− , P.text err

120− ]

121− ]

122− format = Either.either throw return

123− renameType' environ = renameType (format . replace "variable" environ)

176+ canonicalize' (ctor,args) =

177+ (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args

178+

179+ D.TypeAlias name tvars expanded ->

180+ do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded

181+ return (D.TypeAlias name tvars expanded')

182+

183+ D.Port port -> do

184+ Env.uses "Native.Ports"

185+ Env.uses "Native.Json"

186+ D.Port <$> case port of

187+ D.In name t ->

188+ do t' <- canonicalize Canonicalize.tipe "port" name env t

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

124205 in

125− A ann <$>

206+ A.A ann <$>

126207 case expr of

127− Literal _ -> return expr

208+ Literal lit -> return (Literal lit)

128209

129− Range e1 e2 -> Range <$> rnm e1 <*> rnm e2

210+ Range e1 e2 -> Range <$> go e1 <*> go e2

130211

131− Access e x -> Access <$> rnm e <*> return x

212+ Access e x -> Access <$> go e <*> return x

132213

133− Remove e x -> flip Remove x <$> rnm e

214+ Remove e x -> flip Remove x <$> go e

134215

135− Insert e x v -> flip Insert x <$> rnm e <*> rnm v

216+ Insert e x v -> flip Insert x <$> go e <*> go v

136217

137218 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

139220

140− Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs

221+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fs

141222

142− Binop op e1 e2 ->

143− do op' <- format (replace "variable" env op)

144− Binop op' <$> rnm e1 <*> rnm e2

223+ Binop (Var.Raw op) e1 e2 ->

224+ do op' <- format (Canonicalize.variable env op)

225+ Binop op' <$> go e1 <*> go e2

145226

146− Lambda pattern e ->

147− let env' = extend env pattern in

148− Lambda <$> format (renamePattern env' pattern) <*> rename env' e

227+ Lambda p e ->

228+ let env' = update p env in

229+ Lambda <$> format (pattern env' p) <*> expression env' e

149230

150− App e1 e2 -> App <$> rnm e1 <*> rnm e2

231+ App e1 e2 -> App <$> go e1 <*> go e2

151232

152− MultiIf ps -> MultiIf <$> mapM grnm ps

153− where grnm (b,e) = (,) <$> rnm b <*> rnm e

233+ MultiIf ps -> MultiIf <$> mapM go' ps

234+ where go' (b,e) = (,) <$> go b <*> go e

154235

155− Let defs e -> Let <$> mapM rename' defs <*> rename env' e

236+ Let defs e -> Let <$> mapM rename' defs <*> expression env' e

156237 where

157− env' = foldl extend env $ map (\(Definition p _ _) -> p) defs

158− rename' (Definition p body mtipe) =

159− Definition <$> format (renamePattern env' p)

160− <*> rename env' body

161− <*> T.traverse (renameType' env') mtipe

238+ env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs

239+ rename' (Valid.Definition p body mtipe) =

240+ Canonical.Definition

241+ <$> format (pattern env' p)

242+ <*> expression env' body

243+ <*> T.traverse (tipe' env') mtipe

162244

163− -- TODO: Raw -> Canonical

164− Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)

245+ Var (Var.Raw x) -> Var <$> format (Canonicalize.variable env x)

165246

166− Data name es -> Data name <$> mapM rnm es

247+ Data name es -> Data name <$> mapM go es

167248

168− ExplicitList es -> ExplicitList <$> mapM rnm es

249+ ExplicitList es -> ExplicitList <$> mapM go es

169250

170− Case e cases -> Case <$> rnm e <*> mapM branch cases

251+ Case e cases -> Case <$> go e <*> mapM branch cases

171252 where

172− branch (pattern,b) = (,) <$> format (renamePattern env pattern)

173− <*> rename (extend env pattern) b

174−

175− Markdown uid md es -> Markdown uid md <$> mapM rnm es

176−

177− PortIn name st -> PortIn name <$> renameType' env st

178−

179− PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

180−

181− GLShader _ _ _ -> return expr

182−

183−renamePattern :: Env -> P.Pattern -> Either String P.Pattern

184−renamePattern env pattern =

185− case pattern of

186− P.Var _ -> return pattern

187− P.Literal _ -> return pattern

188− P.Record _ -> return pattern

189− P.Anything -> return pattern

190− P.Alias x p -> P.Alias x <$> renamePattern env p

191− P.Data name ps -> P.Data <$> replace "pattern" env name

192− <*> mapM (renamePattern env) ps

253+ branch (p,b) = (,) <$> format (pattern env p)

254+ <*> expression (update p env) b

255+

256+ Markdown uid md es ->

257+ do Env.uses "Text"

258+ Markdown uid md <$> mapM go es

259+

260+ PortIn name st -> PortIn name <$> tipe' env st

261+

262+ PortOut name st signal -> PortOut name <$> tipe' env st <*> go signal

263+

264+ GLShader uid src tipe -> return (GLShader uid src tipe)

265+

266+pattern :: Environment -> P.RawPattern -> Canonicalizer String P.CanonicalPattern

267+pattern env ptrn =

268+ case ptrn of

269+ P.Var x -> return $ P.Var x

270+ P.Literal lit -> return $ P.Literal lit

271+ P.Record fs -> return $ P.Record fs

272+ P.Anything -> return P.Anything

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

66import qualified Data.Maybe as Maybe

77import qualified Data.Set as Set

88

9−import qualified SourceSyntax.Expression as E

10−import qualified SourceSyntax.Declaration as D

11−import qualified SourceSyntax.Pattern as Pattern

12−import qualified SourceSyntax.Type as T

9+import qualified AST.Expression.Valid as Valid

10+import qualified AST.Declaration as D

11+import qualified AST.Pattern as Pattern

12+import qualified AST.Type as T

13+import qualified AST.Variable as Var

1314import qualified Transform.Expression as Expr

1415

15−import SourceSyntax.PrettyPrint

16+import AST.PrettyPrint

1617import Text.PrettyPrint as P

1718

1819

19−mistakes :: [D.Declaration] -> [Doc]

20+mistakes :: [D.ValidDecl] -> [Doc]

2021mistakes decls =

2122 concat [ infiniteTypeAliases decls

2223 , illFormedTypes decls

@@ -30,7 +31,7 @@ dupErr :: String -> String -> String

3031dupErr err x =

3132 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."

3233

33−duplicates :: [D.Declaration] -> [String]

34+duplicates :: [D.ValidDecl] -> [String]

3435duplicates decls =

3536 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++

3637 case mapM exprDups (portExprs ++ defExprs) of

@@ -41,7 +42,7 @@ duplicates decls =

4142 msg = dupErr "definition of"

4243

4344 (defPatterns, defExprs) =

44− unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]

45+ unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]

4546

4647 (portNames, portExprs) =

4748 Arrow.second concat $ unzip $

@@ -50,17 +51,17 @@ duplicates decls =

5051 D.Out name expr _ -> (name, [expr])

5152 D.In name _ -> (name, [])

5253

53− exprDups :: E.Expr -> Either String E.Expr

54+ exprDups :: Valid.Expr -> Either String Valid.Expr

5455 exprDups expr = Expr.crawlLet defsDups expr

5556

56− defsDups :: [E.Def] -> Either String [E.Def]

57+ defsDups :: [Valid.Def] -> Either String [Valid.Def]

5758 defsDups defs =

58− let varsIn (E.Definition pattern _ _) = Pattern.boundVarList pattern in

59+ let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in

5960 case dups $ concatMap varsIn defs of

6061 [] -> Right defs

6162 name:_ -> Left name

6263

63−duplicateConstructors :: [D.Declaration] -> [String]

64+duplicateConstructors :: [D.ValidDecl] -> [String]

6465duplicateConstructors decls =

6566 map (dupErr "definition of type constructor") (dups typeCtors) ++

6667 map (dupErr "definition of data constructor") (dups dataCtors)

@@ -68,7 +69,7 @@ duplicateConstructors decls =

6869 typeCtors = [ name | D.Datatype name _ _ <- decls ]

6970 dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]

7071

71−illFormedTypes :: [D.Declaration] -> [Doc]

72+illFormedTypes :: [D.ValidDecl] -> [Doc]

7273illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

7374 where

7475 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]

@@ -78,9 +79,11 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

7879 case tipe of

7980 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

8081 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))

8284 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

8487

8588 undeclared tvars tipes = Set.difference used declared

8689 where

@@ -113,20 +116,23 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

113116 quote tvar = "'" ++ tvar ++ "'"

114117

115118

116−infiniteTypeAliases :: [D.Declaration] -> [Doc]

119+infiniteTypeAliases :: [D.ValidDecl] -> [Doc]

117120infiniteTypeAliases decls =

118121 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls

119122 , infiniteType name tipe ]

120123 where

124+ infiniteType :: String -> T.Type Var.Raw -> Bool

121125 infiniteType name tipe =

122126 let infinite = infiniteType name in

123127 case tipe of

124128 T.Lambda a b -> infinite a || infinite b

125129 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)

127132 T.Record fields _ -> any (infinite . snd) fields

133+ T.Aliased _ t -> infinite t

128134

129− indented :: D.Declaration -> Doc

135+ indented :: D.ValidDecl -> Doc

130136 indented decl = P.text "\n " <> pretty decl <> P.text "\n"

131137

132138 report name args tipe =

compiler/Transform/Declaration.hs+89−24

@@ -1,16 +1,23 @@

11{-# OPTIONS_GHC -Wall #-}

2−module Transform.Declaration where

2+module Transform.Declaration (combineAnnotations, toExpr) where

33

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

5−import qualified SourceSyntax.Pattern as P

6−import SourceSyntax.Expression as E

7−import SourceSyntax.Declaration as D

5+

6+import qualified AST.Annotation as A

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

815

916import qualified Transform.Expression as Expr

1017import qualified Transform.Definition as Def

1118

1219

13−combineAnnotations :: [ParseDeclaration] -> Either String [Declaration]

20+combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]

1421combineAnnotations = go

1522 where

1623 msg x = "Syntax Error: The type annotation for '" ++ x ++

@@ -23,41 +30,99 @@ combineAnnotations = go

2330 -- simple cases, pass them through with no changes

2431 [] -> return []

2532

26− Datatype name tvars ctors : rest ->

27− (:) (Datatype name tvars ctors) <$> go rest

33+ D.Datatype name tvars ctors : rest ->

34+ (:) (D.Datatype name tvars ctors) <$> go rest

2835

29− TypeAlias name tvars alias : rest ->

30− (:) (TypeAlias name tvars alias) <$> go rest

36+ D.TypeAlias name tvars alias : rest ->

37+ (:) (D.TypeAlias name tvars alias) <$> go rest

3138

32− Fixity assoc prec op : rest ->

33− (:) (Fixity assoc prec op) <$> go rest

39+ D.Fixity assoc prec op : rest ->

40+ (:) (D.Fixity assoc prec op) <$> go rest

3441

3542 -- combine definitions

3643 D.Definition def : defRest ->

3744 case def of

38− Def pat expr ->

45+ Source.Definition pat expr ->

3946 do expr' <- exprCombineAnnotations expr

40− let def' = E.Definition pat expr' Nothing

47+ let def' = Valid.Definition pat expr' Nothing

4148 (:) (D.Definition def') <$> go defRest

4249

43− TypeAnnotation name tipe ->

50+ Source.TypeAnnotation name tipe ->

4451 case defRest of

45− D.Definition (Def pat@(P.Var name') expr) : rest | name == name' ->

46− do expr' <- exprCombineAnnotations expr

47− let def' = E.Definition pat expr' (Just tipe)

48− (:) (D.Definition def') <$> go rest

52+ D.Definition (Source.Definition pat@(P.Var name') expr) : rest

53+ | name == name' ->

54+ do expr' <- exprCombineAnnotations expr

55+ let def' = Valid.Definition pat expr' (Just tipe)

56+ (:) (D.Definition def') <$> go rest

4957

5058 _ -> Left (msg name)

5159

5260 -- combine ports

53− Port port : portRest ->

61+ D.Port port : portRest ->

5462 case port of

55− PPDef name _ -> Left (msg name)

56− PPAnnotation name tipe ->

63+ D.PPDef name _ -> Left (msg name)

64+ D.PPAnnotation name tipe ->

5765 case portRest of

58− Port (PPDef name' expr) : rest | name == name' ->

66+ D.Port (D.PPDef name' expr) : rest | name == name' ->

5967 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..]

61122

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)

63126

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

22module Transform.Definition where

33

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

5−import qualified SourceSyntax.Pattern as P

6−import SourceSyntax.Expression

5+import qualified AST.Pattern as P

6+import qualified AST.Expression.Source as Source

7+import qualified AST.Expression.Valid as Valid

78import qualified Transform.Expression as Expr

89

9−combineAnnotations :: [ParseDef] -> Either String [Def]

10+combineAnnotations :: [Source.Def] -> Either String [Valid.Def]

1011combineAnnotations = go

1112 where

1213 msg x = "Syntax Error: The type annotation for '" ++ x ++

@@ -16,16 +17,19 @@ combineAnnotations = go

1617

1718 go defs =

1819 case defs of

19− TypeAnnotation name tipe : Def pat@(P.Var name') expr : rest | name == name' ->

20− do expr' <- exprCombineAnnotations expr

21− let def = Definition pat expr' (Just tipe)

22− (:) def <$> go rest

20+ Source.TypeAnnotation name tipe : rest ->

21+ case rest of

22+ Source.Definition pat@(P.Var name') expr : rest'

23+ | name == name' ->

24+ do expr' <- exprCombineAnnotations expr

25+ let def = Valid.Definition pat expr' (Just tipe)

26+ (:) def <$> go rest'

2327

24− TypeAnnotation name _ : _ -> Left (msg name)

28+ _ -> Left (msg name)

2529

26− Def pat expr : rest ->

30+ Source.Definition pat expr : rest ->

2731 do expr' <- exprCombineAnnotations expr

28− let def = Definition pat expr' Nothing

32+ let def = Valid.Definition pat expr' Nothing

2933 (:) def <$> go rest

3034

3135 [] -> return []

compiler/Transform/Expression.hs+15−14

@@ -2,31 +2,32 @@

22module Transform.Expression (crawlLet, checkPorts) where

33

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

5−import SourceSyntax.Annotation ( Annotated(A) )

6−import SourceSyntax.Expression

7−import SourceSyntax.Type (Type)

5+import AST.Annotation ( Annotated(A) )

6+import AST.Expression.General

7+import qualified AST.Expression.Canonical as Canonical

8+import AST.Type (Type, CanonicalType)

89

910crawlLet :: ([def] -> Either a [def'])

10− -> GeneralExpr ann def var

11− -> Either a (GeneralExpr ann def' var)

11+ -> Expr ann def var

12+ -> Either a (Expr ann def' var)

1213crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())

1314

14−checkPorts :: (String -> Type -> Either a ())

15− -> (String -> Type -> Either a ())

16− -> Expr

17− -> Either a Expr

15+checkPorts :: (String -> CanonicalType -> Either a ())

16+ -> (String -> CanonicalType -> Either a ())

17+ -> Canonical.Expr

18+ -> Either a Canonical.Expr

1819checkPorts inCheck outCheck expr =

1920 crawl inCheck outCheck (mapM checkDef) expr

2021 where

21− checkDef def@(Definition _ body _) =

22+ checkDef def@(Canonical.Definition _ body _) =

2223 do _ <- checkPorts inCheck outCheck body

2324 return def

2425

25−crawl :: (String -> Type -> Either a ())

26− -> (String -> Type -> Either a ())

26+crawl :: (String -> Type var -> Either a ())

27+ -> (String -> Type var -> Either a ())

2728 -> ([def] -> Either a [def'])

28− -> GeneralExpr ann def var

29− -> Either a (GeneralExpr ann def' var)

29+ -> Expr ann def var

30+ -> Either a (Expr ann def' var)

3031crawl portInCheck portOutCheck defsTransform = go

3132 where

3233 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

77import qualified Data.Map as Map

88import qualified Data.Maybe as Maybe

99import 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

1410

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]

1618ctors pattern =

1719 case pattern of

1820 P.Var _ -> []

1921 P.Alias _ p -> ctors p

20− P.Data ctor ps -> ctor : concatMap ctors ps

2122 P.Record _ -> []

2223 P.Anything -> []

2324 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

2432

2533free :: String -> State (Set.Set String) ()

2634free x = modify (Set.insert x)

2735

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+

2843bound :: Set.Set String -> State (Set.Set String) ()

2944bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

3045

31−sortDefs :: Expr -> Expr

46+sortDefs :: Canonical.Expr -> Canonical.Expr

3247sortDefs expr = evalState (reorder expr) Set.empty

3348

34−reorder :: Expr -> State (Set.Set String) Expr

49+reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr

3550reorder (A ann expr) =

3651 A ann <$>

3752 case expr of

3853 -- Be careful adding and restricting freeVars

39− Var (V.Raw x) -> free x >> return expr

54+ Var var -> freeIfLocal var >> return expr

4055

4156 Lambda p e ->

4257 uncurry Lambda <$> bindingReorder (p,e)

4358

4459 Binop op e1 e2 ->

45− do free op

60+ do freeIfLocal op

4661 Binop op <$> reorder e1 <*> reorder e2

4762

4863 Case e cases ->

@@ -102,7 +117,7 @@ reorder (A ann expr) =

102117 let defss = map Graph.flattenSCC sccs

103118

104119 -- remove let-bound variables from the context

105− forM_ defs $ \(Definition pattern _ _) -> do

120+ forM_ defs $ \(Canonical.Definition pattern _ _) -> do

106121 bound (P.boundVars pattern)

107122 mapM free (ctors pattern)

108123

@@ -110,7 +125,8 @@ reorder (A ann expr) =

110125

111126 return let'

112127

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)

114130bindingReorder (pattern,expr) =

115131 do expr' <- reorder expr

116132 bound (P.boundVars pattern)

@@ -118,8 +134,8 @@ bindingReorder (pattern,expr) =

118134 return (pattern, expr')

119135

120136

121−reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])

122−reorderAndGetDependencies (Definition pattern expr mType) =

137+reorderAndGetDependencies :: Canonical.Def -> State (Set.Set String) (Canonical.Def, [String])

138+reorderAndGetDependencies (Canonical.Definition pattern expr mType) =

123139 do globalFrees <- get

124140 -- work in a fresh environment

125141 put Set.empty

@@ -127,28 +143,28 @@ reorderAndGetDependencies (Definition pattern expr mType) =

127143 localFrees <- get

128144 -- merge with global frees

129145 modify (Set.union globalFrees)

130− return (Definition pattern expr' mType, Set.toList localFrees)

146+ return (Canonical.Definition pattern expr' mType, Set.toList localFrees)

131147

132148

133149-- 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])]

135151buildDefDict defs =

136152 do pdefsDeps <- mapM reorderAndGetDependencies defs

137153 return $ realDeps (addKey pdefsDeps)

138154

139155 where

140− addKey :: [(Def, [String])] -> [(Def, Int, [String])]

156+ addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]

141157 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

142158

143− variableToKey :: (Def, Int, [String]) -> [(String, Int)]

144− variableToKey (Definition pattern _ _, key, _) =

159+ variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]

160+ variableToKey (Canonical.Definition pattern _ _, key, _) =

145161 [ (var, key) | var <- Set.toList (P.boundVars pattern) ]

146162

147− variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int

163+ variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int

148164 variableToKeyMap pdefsDeps =

149165 Map.fromList (concatMap variableToKey pdefsDeps)

150166

151− realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]

167+ realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]

152168 realDeps pdefsDeps = map convert pdefsDeps

153169 where

154170 varDict = variableToKeyMap pdefsDeps

compiler/Transform/Substitute.hs+78−32

@@ -4,42 +4,88 @@ module Transform.Substitute (subst) where

44import Control.Arrow (second, (***))

55import qualified Data.Set as Set

66

7−import SourceSyntax.Annotation

8−import SourceSyntax.Expression

9−import qualified SourceSyntax.Pattern as Pattern

10−import qualified SourceSyntax.Variable as V

7+import AST.Annotation

8+import AST.Expression.General (Expr'(..))

9+import qualified AST.Expression.Canonical as Canonical

10+import qualified AST.Pattern as Pattern

11+import qualified AST.Variable as V

1112

12−subst :: String -> Expr' -> Expr' -> Expr'

13−subst old new expr =

13+

14+subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'

15+subst old new expression =

1416 let f (A a e) = A a (subst old new e) in

15− case expr of

16− Range e1 e2 -> Range (f e1) (f e2)

17− ExplicitList es -> ExplicitList (map f es)

18− Binop op e1 e2 -> Binop op (f e1) (f e2)

19− Lambda p e

20− | Set.member old (Pattern.boundVars p) -> expr

21− | otherwise -> Lambda p (f e)

22− App e1 e2 -> App (f e1) (f e2)

23− MultiIf ps -> MultiIf (map (f *** f) ps)

17+ case expression of

18+ Range e1 e2 ->

19+ Range (f e1) (f e2)

20+

21+ ExplicitList exprs ->

22+ ExplicitList (map f exprs)

23+

24+ Binop op e1 e2 ->

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)

2436

2537 Let defs body

26− | anyShadow -> expr

38+ | anyShadow -> expression

2739 | otherwise -> Let (map substDef defs) (f body)

2840 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+

3044 anyShadow =

31− any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]

32−

33− Var (V.Raw x) -> if x == old then new else expr

34− Case e cases -> Case (f e) $ map (second f) cases

35− Data name es -> Data name (map f es)

36− Access e x -> Access (f e) x

37− Remove e x -> Remove (f e) x

38− Insert e x v -> Insert (f e) x (f v)

39− Modify r fs -> Modify (f r) (map (second f) fs)

40− Record fs -> Record (map (second f) fs)

41− Literal _ -> expr

42− Markdown uid md es -> Markdown uid md (map f es)

43− GLShader _ _ _ -> expr

44− PortIn name st -> PortIn name st

45− PortOut name st signal -> PortOut name st (f signal)

45+ any (Set.member old . Pattern.boundVars)

46+ [ pattern | Canonical.Definition pattern _ _ <- defs ]

47+

48+ Var (V.Canonical home x) ->

49+ case home of

50+ V.Module _ -> expression

51+ V.BuiltIn -> expression

52+ V.Local -> if x == old then new else expression

53+

54+ Case e cases ->

55+ Case (f e) (map substCase cases)

56+ where

57+ substCase (pattern, expr) =

58+ if Set.member old (Pattern.boundVars pattern)

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

88import qualified Data.Map as Map

99import qualified Text.PrettyPrint as PP

1010

11−import SourceSyntax.Literal as Lit

12−import SourceSyntax.Annotation as Ann

13−import SourceSyntax.Expression

14−import qualified SourceSyntax.Pattern as P

15−import qualified SourceSyntax.Type as ST

16−import qualified SourceSyntax.Variable as V

11+import AST.Literal as Lit

12+import AST.Annotation as Ann

13+import AST.Expression.General

14+import qualified AST.Expression.Canonical as Canonical

15+import qualified AST.Pattern as P

16+import qualified AST.Type as ST

17+import qualified AST.Variable as V

1718import Type.Type hiding (Descriptor(..))

1819import Type.Fragment

1920import qualified Type.Environment as Env

2021import qualified Type.Constrain.Literal as Literal

2122import qualified Type.Constrain.Pattern as Pattern

2223

23−constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint

24+constrain :: Env.Environment -> Canonical.Expr -> Type

25+ -> ErrorT [PP.Doc] IO TypeConstraint

2426constrain env (A region expr) tipe =

2527 let list t = Env.get env Env.types "_List" <| t

2628 and = A region . CAnd

@@ -45,12 +47,14 @@ constrain env (A region expr) tipe =

4547 else record (Map.map (\t -> [glTipe t]) decls) baseRec

4648 attribute = makeRec Lit.attribute attr

4749 uniform = makeRec Lit.uniform unif

48− varying = makeRec Lit.varying (TermN EmptyRecord1)

50+ varying = makeRec Lit.varying (termN EmptyRecord1)

4951 in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)

5052

51− Var (V.Raw name)

53+ Var var

5254 | name == saveEnvName -> return (A region CSaveEnv)

5355 | otherwise -> return (name <? tipe)

56+ where

57+ name = V.toString var

5458

5559 Range lo hi ->

5660 existsNumber $ \n -> do

@@ -68,7 +72,7 @@ constrain env (A region expr) tipe =

6872 exists $ \t2 -> do

6973 c1 <- constrain env e1 t1

7074 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) ]

7276

7377 Lambda p e ->

7478 exists $ \t1 ->

@@ -102,8 +106,8 @@ constrain env (A region expr) tipe =

102106 and . (:) ce <$> mapM branch branches

103107

104108 Data name exprs ->

105− do vars <- forM exprs $ \_ -> liftIO (var Flexible)

106− let pairs = zip exprs (map VarN vars)

109+ do vars <- forM exprs $ \_ -> liftIO (variable Flexible)

110+ let pairs = zip exprs (map varN vars)

107111 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

108112 return $ ex vars (cs /\ name <? ctipe)

109113 where

@@ -129,28 +133,28 @@ constrain env (A region expr) tipe =

129133

130134 Modify e fields ->

131135 exists $ \t -> do

132− oldVars <- forM fields $ \_ -> liftIO (var Flexible)

133− let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))

136+ oldVars <- forM fields $ \_ -> liftIO (variable Flexible)

137+ let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

134138 cOld <- ex oldVars <$> constrain env e (record oldFields t)

135139

136− newVars <- forM fields $ \_ -> liftIO (var Flexible)

137− let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))

140+ newVars <- forM fields $ \_ -> liftIO (variable Flexible)

141+ let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

138142 let cNew = tipe === record newFields t

139143

140− cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)

144+ cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)

141145

142146 return $ cOld /\ ex newVars (and (cNew : cs))

143147

144148 Record fields ->

145− do vars <- forM fields $ \_ -> liftIO (var Flexible)

146− cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)

147− let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))

148− recordType = record fields' (TermN EmptyRecord1)

149+ do vars <- forM fields $ \_ -> liftIO (variable Flexible)

150+ cs <- zipWithM (constrain env) (map snd fields) (map varN vars)

151+ let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

152+ recordType = record fields' (termN EmptyRecord1)

149153 return . ex vars . and $ tipe === recordType : cs

150154

151155 Markdown _ _ es ->

152− do vars <- forM es $ \_ -> liftIO (var Flexible)

153− let tvars = map VarN vars

156+ do vars <- forM es $ \_ -> liftIO (variable Flexible)

157+ let tvars = map varN vars

154158 cs <- zipWithM (constrain env) es tvars

155159 return . ex vars $ and ("Text.markdown" <? tipe : cs)

156160

@@ -169,16 +173,16 @@ constrain env (A region expr) tipe =

169173 PortOut _ _ signal ->

170174 constrain env signal tipe

171175

172−constrainDef env info (Definition pattern expr maybeTipe) =

176+constrainDef env info (Canonical.Definition pattern expr maybeTipe) =

173177 let qs = [] -- should come from the def, but I'm not sure what would live there...

174178 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

175179 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.

177181 -- Currently, qs is always [].

178182 case (pattern, maybeTipe) of

179183 (P.Var name, Just tipe) -> do

180− flexiVars <- forM qs (\_ -> liftIO $ var Flexible)

181− let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars

184+ flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)

185+ let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars

182186 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

183187 (vars, typ) <- Env.instantiateType env tipe Map.empty

184188 let scheme = Scheme { rigidQuantifiers = [],

@@ -194,9 +198,9 @@ constrainDef env info (Definition pattern expr maybeTipe) =

194198 , fl rigidVars c /\ c1 )

195199

196200 (P.Var name, Nothing) -> do

197− v <- liftIO $ var Flexible

198− let tipe = VarN v

199− inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars

201+ v <- liftIO $ variable Flexible

202+ let tipe = varN v

203+ inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars

200204 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

201205 c <- constrain env' expr tipe

202206 return ( schemes

@@ -206,18 +210,18 @@ constrainDef env info (Definition pattern expr maybeTipe) =

206210 , c /\ c2

207211 , c1 )

208212

209− _ -> error (show pattern)

213+ _ -> error ("problem in constrainDef with " ++ show pattern)

210214

211−expandPattern :: Def -> [Def]

212−expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =

215+expandPattern :: Canonical.Def -> [Canonical.Def]

216+expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =

213217 case pattern of

214218 P.Var _ -> [def]

215− _ -> Definition (P.Var x) lexpr maybeType : map toDef vars

219+ _ -> Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars

216220 where

217221 vars = P.boundVarList pattern

218222 x = "$" ++ concat vars

219− mkVar = A r . rawVar

220− toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

223+ mkVar = A r . localVar

224+ toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

221225

222226try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

223227try region computation = do

compiler/Type/Constrain/Literal.hs+3−3

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

11{-# OPTIONS_GHC -W #-}

22module Type.Constrain.Literal where

33

4−import SourceSyntax.Annotation

5−import SourceSyntax.Literal

4+import AST.Annotation

5+import AST.Literal

66import Type.Type

77import Type.Environment as Env

88

@@ -15,7 +15,7 @@ constrain env region literal tipe =

1515

1616 litType =

1717 case literal of

18− IntNum _ -> VarN `fmap` var (Is Number)

18+ IntNum _ -> varN `fmap` variable (Is Number)

1919 FloatNum _ -> prim "Float"

2020 Chr _ -> prim "Char"

2121 Str _ -> prim "String"

compiler/Type/Constrain/Pattern.hs+18−15

@@ -9,20 +9,21 @@ import Control.Monad.Error

99import qualified Data.Map as Map

1010import qualified Text.PrettyPrint as PP

1111

12−import qualified SourceSyntax.Annotation as A

13−import qualified SourceSyntax.Pattern as P

14−import SourceSyntax.PrettyPrint (pretty)

12+import qualified AST.Annotation as A

13+import qualified AST.Pattern as P

14+import qualified AST.Variable as V

15+import AST.PrettyPrint (pretty)

1516import Type.Type

1617import Type.Fragment

1718import Type.Environment as Env

1819import qualified Type.Constrain.Literal as Literal

1920

2021

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

2224constrain env pattern tipe =

2325 let region = A.None (pretty pattern)

2426 t1 === t2 = A.A region (CEqual t1 t2)

25− x <? t = A.A region (CInstance x t)

2627 in

2728 case pattern of

2829 P.Anything -> return emptyFragment

@@ -32,23 +33,25 @@ constrain env pattern tipe =

3233 return $ emptyFragment { typeConstraint = c }

3334

3435 P.Var name -> do

35− v <- liftIO $ var Flexible

36+ v <- liftIO $ variable Flexible

3637 return $ Fragment {

37− typeEnv = Map.singleton name (VarN v),

38+ typeEnv = Map.singleton name (varN v),

3839 vars = [v],

39− typeConstraint = VarN v === tipe

40+ typeConstraint = varN v === tipe

4041 }

4142

4243 P.Alias name p -> do

44+ v <- liftIO $ variable Flexible

4345 fragment <- constrain env p tipe

44− return $ fragment {

45− typeEnv = Map.insert name tipe (typeEnv fragment),

46− typeConstraint = name <? tipe /\ typeConstraint fragment

46+ return $ fragment

47+ { typeEnv = Map.insert name (varN v) (typeEnv fragment)

48+ , vars = v : vars fragment

49+ , typeConstraint = varN v === tipe /\ typeConstraint fragment

4750 }

4851

4952 P.Data name patterns -> do

50− (kind, cvars, args, result) <- liftIO $ freshDataScheme env name

51− let msg = concat [ "Constructor '", name, "' expects ", show kind

53+ (kind, cvars, args, result) <- liftIO $ freshDataScheme env (V.toString name)

54+ let msg = concat [ "Constructor '", V.toString name, "' expects ", show kind

5255 , " argument", if kind == 1 then "" else "s"

5356 , " but was given ", show (length patterns), "." ]

5457 err span = PP.vcat [ PP.text $ "Type error " ++ show span

@@ -63,8 +66,8 @@ constrain env pattern tipe =

6366 }

6467

6568 P.Record fields -> do

66− pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields

67− let tenv = Map.fromList (map (second VarN) pairs)

69+ pairs <- liftIO $ mapM (\name -> (,) name <$> variable Flexible) fields

70+ let tenv = Map.fromList (map (second varN) pairs)

6871 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

6972 return $ Fragment {

7073 typeEnv = tenv,

compiler/Type/Environment.hs+84−86

@@ -4,7 +4,6 @@ module Type.Environment where

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

55import Control.Exception (try, SomeException)

66import Control.Monad

7−import Control.Monad.Trans.Error (ErrorList(..))

87import Control.Monad.Error (ErrorT, throwError, liftIO)

98import qualified Control.Monad.State as State

109import qualified Data.Traversable as Traverse

@@ -12,55 +11,59 @@ import qualified Data.Map as Map

1211import Data.List (isPrefixOf)

1312import qualified Text.PrettyPrint as PP

1413

15−import qualified SourceSyntax.Type as Src

16−import SourceSyntax.Module (ADT, Alias)

14+import qualified AST.Type as T

15+import qualified AST.Variable as V

16+import AST.Module (CanonicalAdt, AdtInfo)

1717import Type.Type

1818

1919type TypeDict = Map.Map String Type

2020type VarDict = Map.Map String Variable

2121

22−data Environment = Environment {

23− constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),

24− aliases :: Map.Map String ([String], Src.Type),

25− types :: TypeDict,

26− value :: TypeDict

27−}

22+data Environment = Environment

23+ { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))

24+ , types :: TypeDict

25+ , value :: TypeDict

26+ }

2827

29−initialEnvironment :: [ADT] -> [Alias] -> IO Environment

30−initialEnvironment datatypes aliases = do

28+initialEnvironment :: [CanonicalAdt] -> IO Environment

29+initialEnvironment datatypes = do

3130 types <- makeTypes datatypes

32− let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases

33− env = Environment {

34− constructor = Map.empty,

35− value = Map.empty,

36− types = types,

37− aliases = aliases' }

38−

31+ let env = Environment

32+ { constructor = Map.empty

33+ , value = Map.empty

34+ , types = types

35+ }

3936 return $ env { constructor = makeConstructors env datatypes }

4037

41−makeTypes :: [ADT] -> IO TypeDict

42−makeTypes datatypes =

43− Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

38+makeTypes :: [CanonicalAdt] -> IO TypeDict

39+makeTypes datatypes =

40+ do adts <- mapM makeImported datatypes

41+ bs <- mapM makeBuiltin builtins

42+ return (Map.fromList (adts ++ bs))

4443 where

45− nameAndKind (name, tvars, _) = (name, length tvars)

46−

47− makeCtor (name, _) = do

48− ctor <- VarN <$> namedVar Constant name

49− return (name, ctor)

44+ makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)

45+ makeImported (var, _) = do

46+ tvar <- namedVar Constant var

47+ return (V.toString var, varN tvar)

5048

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')

5253

53− kind n names = map (\name -> (name, n)) names

54−

55− builtins :: [(String,Int)]

54+ builtins :: [(String, Int)]

5655 builtins = concat [ map tuple [0..9]

5756 , kind 1 ["_List"]

5857 , kind 0 ["Int","Float","Char","String","Bool"]

5958 ]

59+ where

60+ tuple n = ("_Tuple" ++ show n, n)

61+ kind n names = map (\name -> (name, n)) names

62+

6063

6164

6265makeConstructors :: Environment

63− -> [ADT]

66+ -> [CanonicalAdt]

6467 -> Map.Map String (IO (Int, [Variable], [Type], Type))

6568makeConstructors env datatypes = Map.fromList builtins

6669 where

@@ -68,8 +71,8 @@ makeConstructors env datatypes = Map.fromList builtins

6871

6972 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

7073 inst numTVars tipe = do

71− vars <- forM [1..numTVars] $ \_ -> var Flexible

72− let (args, result) = tipe (map VarN vars)

74+ vars <- forM [1..numTVars] $ \_ -> variable Flexible

75+ let (args, result) = tipe (map (varN) vars)

7376 return (length args, vars, args, result)

7477

7578 tupleCtor n =

@@ -83,88 +86,83 @@ makeConstructors env datatypes = Map.fromList builtins

8386 ++ concatMap (ctorToType env) datatypes

8487

8588

86−ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

87−ctorToType env (name, tvars, ctors) =

88− zip (map fst ctors) (map inst ctors)

89+ctorToType :: Environment

90+ -> (V.Canonical, AdtInfo V.Canonical)

91+ -> [(String, IO (Int, [Variable], [Type], Type))]

92+ctorToType env (name, (tvars, ctors)) =

93+ zip (map (V.toString . fst) ctors) (map inst ctors)

8994 where

90− inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

95+ inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)

9196 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

9398 return (length args, Map.elems dict, args, tipe)

9499

95100

96− go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)

101+ go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)

97102 go (_, args) = do

98103 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))

100105 return (types, returnType)

101106

102107

103108get :: 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)

105110 where

106− err = error $ "\nCould not find type constructor '" ++ key ++ "' while checking types."

111+ msg = "Could not find type constructor '" ++ key ++ "' while checking types."

107112

108113

109114freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

110115freshDataScheme env name = get env constructor name

111116

112−instance ErrorList PP.Doc where

113− listMsg str = [PP.text str]

114−

115−instantiateType :: Environment -> Src.Type -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)

117+instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)

116118instantiateType env sourceType dict =

117− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) (dict, Map.empty))

118− case result :: Either SomeException (Type, (VarDict, TypeDict)) of

119+ do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)

120+ case result :: Either SomeException (Type, VarDict) of

119121 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)

121123

122−instantiator :: Environment -> Src.Type

123− -> State.StateT (VarDict, TypeDict) IO Type

124+instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type

124125instantiator env sourceType = go sourceType

125126 where

126− go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type

127+ go :: T.CanonicalType -> State.StateT VarDict IO Type

127128 go sourceType =

128129 case sourceType of

129− Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2

130−

131− Src.Var x -> do

132− (dict, aliases) <- State.get

133− case (Map.lookup x dict, Map.lookup x aliases) of

134− (_, Just t) -> return t

135− (Just v, _) -> return (VarN v)

136− _ ->

137− do var <- State.liftIO $ namedVar flex x

138− State.put (Map.insert x var dict, aliases)

139− return (VarN var)

130+ T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2

131+

132+ T.Var x -> do

133+ dict <- State.get

134+ case Map.lookup x dict of

135+ Just v -> return (varN v)

136+ Nothing ->

137+ do v <- State.liftIO $ namedVar flex (V.local x)

138+ State.put (Map.insert x v dict)

139+ return (varN v)

140140 where

141141 flex | "number" `isPrefixOf` x = Is Number

142142 | "comparable" `isPrefixOf` x = Is Comparable

143143 | "appendable" `isPrefixOf` x = Is Appendable

144144 | otherwise = Flexible

145145

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

147160 ts' <- mapM go ts

148− case (Map.lookup name (types env), Map.lookup name (aliases env)) of

149− (Just t, _) -> return $ foldl (<|) t ts'

150− (_, Just (tvars, t)) ->

151− let tvarLen = length tvars

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)

161+ return $ foldl (<|) t' ts'

162+

163+ T.Record fields ext -> do

164+ fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)

167165 ext' <- case ext of

168− Nothing -> return $ TermN EmptyRecord1

169− Just x -> go (Src.Var x)

170− return $ TermN (Record1 fields' ext')

166+ Nothing -> return $ termN EmptyRecord1

167+ Just x -> go x

168+ return $ termN (Record1 fields' ext')

compiler/Type/ExtraChecks.hs+53−43

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

1−{-# OPTIONS_GHC -W #-}

1+{-# OPTIONS_GHC -Wall #-}

22

33{-| This module contains checks to be run *after* type inference has completed

44successfully. 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

77module Type.ExtraChecks (mainType, occurs, portTypes) where

88

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

10+import Control.Monad.Error

1011import Control.Monad.State

1112import qualified Data.Map as Map

1213import qualified Data.Traversable as Traverse

1314import qualified Data.UnionFind.IO as UF

1415import Text.PrettyPrint as P

1516

16−import qualified SourceSyntax.Annotation as A

17−import qualified SourceSyntax.Expression as E

18−import qualified SourceSyntax.Helpers as Help

19−import qualified SourceSyntax.PrettyPrint as SPP

20−import qualified SourceSyntax.Type as ST

17+import qualified AST.Annotation as A

18+import qualified AST.Expression.Canonical as Canonical

19+import qualified AST.PrettyPrint as PP

20+import qualified AST.Type as ST

21+import qualified AST.Variable as V

2122import qualified Transform.Expression as Expr

2223import qualified Type.Type as TT

2324import qualified Type.State as TS

24−import qualified Type.Alias as Alias

2525

26+throw :: [Doc] -> Either [Doc] a

2627throw err = Left [ P.vcat err ]

2728

28−mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))

29−mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env

29+mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)

30+mainType environment =

31+ do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment

32+ mainCheck environment'

3033 where

31− mainCheck :: Alias.Rules -> Map.Map String ST.Type -> Either [P.Doc] (Map.Map String ST.Type)

32− mainCheck rules env =

34+ mainCheck :: (Monad m) => Map.Map String ST.CanonicalType

35+ -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)

36+ mainCheck env =

3337 case Map.lookup "main" env of

34− Nothing -> Right env

35− Just mainType

36− | tipe `elem` acceptable -> Right env

37− | otherwise -> throw err

38+ Nothing -> return env

39+ Just typeOfMain

40+ | tipe `elem` acceptable -> return env

41+ | otherwise -> throwError err

3842 where

3943 acceptable = [ "Graphics.Element.Element"

4044 , "Signal.Signal Graphics.Element.Element" ]

4145

42− tipe = SPP.renderPretty $ Alias.canonicalRealias (fst rules) mainType

46+ tipe = PP.renderPretty typeOfMain

4347 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

4448 , P.text "Instead 'main' has type:\n"

45− , P.nest 4 . SPP.pretty $ Alias.realias rules mainType

49+ , P.nest 4 (PP.pretty typeOfMain)

4650 , P.text " " ]

4751

4852data Direction = In | Out

4953

50−portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()

51−portTypes rules expr =

52− const () <$> Expr.checkPorts (check In) (check Out) expr

54+portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()

55+portTypes expr =

56+ case Expr.checkPorts (check In) (check Out) expr of

57+ Left err -> throwError err

58+ Right _ -> return ()

5359 where

5460 check = isValid True False False

5561 isValid isTopLevel seenFunc seenSignal direction name tipe =

5662 case tipe of

57− ST.Data ctor ts

58− | validConstructor -> mapM_ valid ts

59− | ctor == "Signal.Signal" -> handleSignal ts

60− | otherwise -> err' True "an unsupported type"

61− where

62− primitives =

63− ["Int","Float","String","Bool","Maybe.Maybe","_List","Array.Array","Json.Value"]

64− validConstructor =

65− ctor `elem` primitives || Help.isTuple ctor

63+ ST.Aliased _ t -> valid t

64+

65+ ST.Type v

66+ | V.isJson v -> return ()

67+ | V.isPrimitive v -> return ()

68+ | V.isTuple v -> return ()

69+ | otherwise -> err "an unsupported type"

70+

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"

6683

6784 ST.Var _ -> err "free type variables"

6885

@@ -84,30 +101,24 @@ portTypes rules expr =

84101 isValid' = isValid False

85102 valid = isValid' seenFunc seenSignal direction name

86103

87− handleSignal ts

104+ handleSignal t

88105 | seenFunc = err "functions that involve signals"

89106 | seenSignal = err "signals-of-signals"

90− | isTopLevel = mapM_ (isValid' seenFunc True direction name) ts

107+ | isTopLevel = isValid' seenFunc True direction name t

91108 | otherwise = err "a signal within a data stucture"

92109

93110 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }

94111 txt = P.text . concat

95112

96− err = err' False

97− err' couldBeAlias kind =

113+ err kind =

98114 throw $

99115 [ txt [ "Type Error: the value ", dir "coming in" "sent out"

100116 , " through port '", name, "' is invalid." ]

101117 , 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"

103119 , 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," ]

105121 , 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)." ]

111122 ]

112123

113124occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()

@@ -119,17 +130,16 @@ occurs (name, variable) =

119130 desc <- liftIO $ UF.descriptor var

120131 case TT.structure desc of

121132 Nothing ->

122− modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

133+ modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }

123134 Just _ ->

124135 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })

125136 var' <- liftIO $ UF.fresh desc

126137 TS.addError (A.None (P.text name)) (Just msg) var var'

127138 where

128139 msg = "Infinite types are not allowed"

129− fallback _ = return $ P.text msg

130140

131141 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]

132− infiniteVars seen var =

142+ infiniteVars seen var =

133143 let go = infiniteVars (var:seen) in

134144 if var `elem` seen

135145 then return [var]

compiler/Type/Fragment.hs+2−2

@@ -4,8 +4,8 @@ import qualified Data.List as List

44import qualified Data.Map as Map

55

66import Type.Type

7−import SourceSyntax.Pattern

8−import SourceSyntax.Annotation (noneNoDocs)

7+import AST.Pattern

8+import AST.Annotation (noneNoDocs)

99

1010data Fragment = Fragment

1111 { typeEnv :: Map.Map String Type

compiler/Type/Inference.hs+74−38

@@ -8,50 +8,86 @@ import qualified Type.Environment as Env

88import qualified Type.Constrain.Expression as TcExpr

99import qualified Type.Solve as Solve

1010

11−import SourceSyntax.Module as Module

12−import SourceSyntax.Annotation (noneNoDocs)

13−import SourceSyntax.Type (Type)

11+import qualified AST.Annotation as A

12+import AST.Module as Module

13+import AST.Type (CanonicalType)

14+import qualified AST.Variable as Var

1415import Text.PrettyPrint

1516import qualified Type.State as TS

1617import qualified Type.ExtraChecks as Check

18+import Control.Arrow (first, second)

1719import Control.Monad.State (execStateT, forM)

18−import Control.Monad.Error (runErrorT, liftIO)

19−import qualified Type.Alias as Alias

20+import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)

2021

2122import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

2223 -- the IO monad. I don't think that'd be worthwhile.

2324

2425

25−infer :: Interfaces -> MetadataModule -> Either [Doc] (Map.Map String Type)

26−infer interfaces modul = unsafePerformIO $ do

27− env <- Env.initialEnvironment

28− (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

29− (aliases modul ++ concatMap iAliases (Map.elems interfaces))

30− ctors <- forM (Map.keys (Env.constructor env)) $ \name ->

31− do (_, vars, args, result) <- Env.freshDataScheme env name

32− return (name, (vars, foldr (T.==>) result args))

33−

34− attemptConstraint <- runErrorT $ do

35− importedVars <-

36− forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->

37− (,) name `fmap` Env.instantiateType env tipe Map.empty

38−

39− let allTypes = ctors ++ importedVars

40− vars = concatMap (fst . snd) allTypes

41− header = Map.map snd (Map.fromList allTypes)

42− environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]

43−

44− fvar <- liftIO $ T.var T.Flexible

45− c <- TcExpr.constrain env (program modul) (T.VarN fvar)

46− return (header, environ c)

47−

48− case attemptConstraint of

49− Left err -> return $ Left err

50− Right (header, constraint) -> do

51− state <- execStateT (Solve.solve constraint) TS.initialState

52− let rules = Alias.rules interfaces (aliases modul) (imports modul)

53− case TS.sErrors state of

54− errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

55− [] -> case Check.portTypes rules (program modul) of

56− Right () -> Check.mainType rules (Map.difference (TS.sSavedEnv state) header)

57− Left err -> return (Left err)

26+infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)

27+infer interfaces modul = unsafePerformIO $ runErrorT $ do

28+ (header, constraint) <- genConstraints interfaces modul

29+

30+ state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState

31+

32+ () <- case TS.sErrors state of

33+ errors@(_:_) -> throwError errors

34+ [] -> return ()

35+

36+ () <- Check.portTypes (program (body modul))

37+

38+ let header' = Map.delete "::" header

39+ types = Map.difference (TS.sSavedEnv state) header'

40+

41+ Check.mainType types

42+

43+

44+genConstraints :: Interfaces -> CanonicalModule

45+ -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)

46+genConstraints interfaces modul = do

47+ env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)

48+

49+ ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do

50+ (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name

51+ return (name, (vars, foldr (T.==>) result args))

52+

53+ importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)

54+

55+ let allTypes = concat (ctors : importedVars)

56+ vars = concatMap (fst . snd) allTypes

57+ header = Map.map snd (Map.fromList allTypes)

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

22module Type.PrettyPrint where

33

44import Text.PrettyPrint

5−import qualified SourceSyntax.PrettyPrint as Src

5+import qualified AST.PrettyPrint as Src

66

77data ParensWhen = Fn | App | Never

88

99class PrettyType a where

1010 pretty :: ParensWhen -> a -> Doc

1111

12+commaSep :: [Doc] -> Doc

1213commaSep docs = sep (punctuate comma docs)

1314

15+parensIf :: Bool -> Doc -> Doc

1416parensIf 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

1111import Type.Unify

1212import qualified Type.ExtraChecks as Check

1313import qualified Type.State as TS

14−import qualified SourceSyntax.Annotation as A

14+import qualified AST.Annotation as A

1515

1616

1717-- | Every variable has rank less than or equal to the maxRank of the pool.

@@ -21,9 +21,9 @@ generalize youngPool = do

2121 youngMark <- TS.uniqueMark

2222 let youngRank = TS.maxRank youngPool

2323 insert dict var = do

24− desc <- liftIO $ UF.descriptor var

24+ descriptor <- liftIO $ UF.descriptor var

2525 liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })

26− return $ Map.insertWith (++) (rank desc) [var] dict

26+ return $ Map.insertWith (++) (rank descriptor) [var] dict

2727

2828 -- Sort the youngPool variables by rank.

2929 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)

@@ -32,7 +32,8 @@ generalize youngPool = do

3232 -- start at low ranks so that we only have to pass

3333 -- over the information once.

3434 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

3637

3738 -- For variables that have rank lowerer than youngRank, register them in

3839 -- the old pool if they are not redundant.

@@ -64,35 +65,38 @@ generalize youngPool = do

6465-- adjust the ranks of variables such that ranks never increase as you

6566-- move deeper into a variable.

6667adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int

67−adjustRank youngMark visitedMark groupRank variable =

68− let adjust = adjustRank youngMark visitedMark groupRank in

69− do desc <- liftIO $ UF.descriptor variable

68+adjustRank youngMark visitedMark groupRank var =

69+ do descriptor <- liftIO $ UF.descriptor var

7070 case () of

71− () | mark desc == youngMark ->

71+ () | mark descriptor == youngMark ->

7272 do -- Set the variable as marked first because it may be cyclic.

73− liftIO $ UF.modifyDescriptor variable $ \desc -> desc { mark = visitedMark }

74− rank' <- case structure desc of

75− Nothing -> return groupRank

76− Just term ->

77− case term of

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' }

73+ liftIO $ UF.modifyDescriptor var $ \desc ->

74+ desc { mark = visitedMark }

75+ rank' <- maybe (return groupRank) adjustTerm (structure descriptor)

76+ liftIO $ UF.modifyDescriptor var $ \desc ->

77+ desc { rank = rank' }

8778 return rank'

8879

89− | mark desc /= visitedMark ->

90− do let rank' = min groupRank (rank desc)

91− liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })

80+ | mark descriptor /= visitedMark ->

81+ do let rank' = min groupRank (rank descriptor)

82+ liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' })

9283 return rank'

9384

94− | otherwise -> return (rank desc)

85+ | otherwise -> return (rank descriptor)

86+

87+ where

88+ adjust = adjustRank youngMark visitedMark groupRank

9589

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

96100

97101

98102solve :: TypeConstraint -> StateT TS.SolverState IO ()

@@ -129,7 +133,7 @@ solve (A.A region constraint) =

129133 case Map.lookup name env of

130134 Just tipe -> TS.makeInstance tipe

131135 Nothing

132− | List.isPrefixOf "Native." name -> liftIO (var Flexible)

136+ | List.isPrefixOf "Native." name -> liftIO (variable Flexible)

133137 | otherwise ->

134138 error ("Could not find '" ++ name ++ "' when solving type constraints.")

135139

compiler/Type/State.hs+40−35

@@ -1,16 +1,15 @@

11{-# OPTIONS_GHC -W #-}

22module Type.State where

33

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

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

55import Control.Monad.State

66import qualified Data.Map as Map

77import qualified Data.Traversable as Traversable

88import qualified Data.UnionFind.IO as UF

99

10−import qualified SourceSyntax.Annotation as A

11−import SourceSyntax.PrettyPrint

10+import qualified AST.Annotation as A

11+import AST.PrettyPrint

1212import Text.PrettyPrint as P

13−import qualified Type.Alias as Alias

1413import Type.Type

1514

1615-- Pool

@@ -18,10 +17,10 @@ import Type.Type

1817-- The rank of each variable is less than or equal to the pool's "maxRank"

1918-- The young pool exists to make it possible to identify these vars in constant time.

2019

21−data Pool = Pool {

22− maxRank :: Int,

23− inhabitants :: [Variable]

24−} deriving Show

20+data Pool = Pool

21+ { maxRank :: Int

22+ , inhabitants :: [Variable]

23+ } deriving Show

2524

2625emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }

2726

@@ -33,7 +32,7 @@ data SolverState = SS {

3332 sSavedEnv :: Env,

3433 sPool :: Pool,

3534 sMark :: Int,

36− sErrors :: [Alias.Rules -> IO P.Doc]

35+ sErrors :: [P.Doc]

3736}

3837

3938initialState = SS {

@@ -47,13 +46,15 @@ initialState = SS {

4746modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }

4847modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

4948

49+addError :: A.Region -> Maybe String -> UF.Point Descriptor -> UF.Point Descriptor

50+ -> StateT SolverState IO ()

5051addError 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 }

5254 where

53− makeError rules = do

54− let prettiest = pretty . Alias.realias rules

55− t1' <- prettiest <$> toSrcType t1

56− t2' <- prettiest <$> toSrcType t2

55+ makeError = do

56+ t1' <- pretty <$> toSrcType t1

57+ t2' <- pretty <$> toSrcType t2

5758 return . P.vcat $

5859 [ P.text "Type error" <+> pretty region <> P.colon

5960 , maybe P.empty P.text hint

@@ -103,17 +104,20 @@ introduce variable = do

103104flatten :: Type -> StateT SolverState IO Variable

104105flatten term =

105106 case term of

106− VarN v -> return v

107− TermN t -> do

107+ VarN maybeAlias v -> do

108+ liftIO $ UF.modifyDescriptor v $ \desc -> desc { alias = maybeAlias <|> alias desc }

109+ return v

110+ TermN maybeAlias t -> do

108111 flatStructure <- traverseTerm flatten t

109112 pool <- getPool

110− var <- liftIO . UF.fresh $ Descriptor {

111− structure = Just flatStructure,

112− rank = maxRank pool,

113− flex = Flexible,

114− name = Nothing,

115− copy = Nothing,

116− mark = noMark

113+ var <- liftIO . UF.fresh $ Descriptor

114+ { structure = Just flatStructure

115+ , rank = maxRank pool

116+ , flex = Flexible

117+ , name = Nothing

118+ , copy = Nothing

119+ , mark = noMark

120+ , alias = maybeAlias

117121 }

118122 register var

119123

@@ -139,18 +143,19 @@ makeCopy alreadyCopied variable = do

139143

140144 | otherwise -> do

141145 pool <- getPool

142− newVar <- liftIO $ UF.fresh $ Descriptor {

143− structure = Nothing,

144− rank = maxRank pool,

145− mark = noMark,

146− flex = case flex desc of

147− Is s -> Is s

148− _ -> Flexible,

149− copy = Nothing,

150− name = case flex desc of

151− Rigid -> Nothing

152− _ -> name desc

153− }

146+ newVar <- liftIO $ UF.fresh $ Descriptor

147+ { structure = Nothing

148+ , rank = maxRank pool

149+ , mark = noMark

150+ , flex = case flex desc of

151+ Is s -> Is s

152+ _ -> Flexible

153+ , copy = Nothing

154+ , name = case flex desc of

155+ Rigid -> Nothing

156+ _ -> name desc

157+ , alias = Nothing

158+ }

154159 register newVar

155160

156161 -- 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 #-}

12module Type.Type where

23

34import qualified Data.Char as Char

@@ -8,12 +9,13 @@ import Type.PrettyPrint

89import Text.PrettyPrint as P

910import System.IO.Unsafe

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

11−import Control.Monad.State

12−import Control.Monad.Error

12+import Control.Monad.State (StateT, get, put, execStateT, runStateT)

13+import Control.Monad.Error (ErrorT, Error, liftIO)

1314import Data.Traversable (traverse)

14−import SourceSyntax.Annotation

15−import SourceSyntax.Helpers (isTuple)

16−import qualified SourceSyntax.Type as Src

15+import AST.Annotation

16+import qualified AST.PrettyPrint as PP

17+import qualified AST.Type as T

18+import qualified AST.Variable as Var

1719

1820data Term1 a

1921 = App1 a a

@@ -24,18 +26,24 @@ data Term1 a

2426 deriving Show

2527

2628data TermN a

27− = VarN a

28− | TermN (Term1 (TermN a))

29+ = VarN (Maybe Var.Canonical) a

30+ | TermN (Maybe Var.Canonical) (Term1 (TermN a))

2931 deriving Show

3032

33+varN :: a -> TermN a

34+varN = VarN Nothing

35+

36+termN :: (Term1 (TermN a)) -> TermN a

37+termN = TermN Nothing

38+

3139record :: 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)

3341

3442type Type = TermN Variable

3543type Variable = UF.Point Descriptor

3644

3745type SchemeName = String

38−type TypeName = String

46+type TypeName = Var.Canonical

3947

4048type Constraint a b = Located (BasicConstraint a b)

4149data BasicConstraint a b

@@ -57,6 +65,7 @@ data Scheme a b = Scheme {

5765type TypeConstraint = Constraint Type Variable

5866type TypeScheme = Scheme Type Variable

5967

68+monoscheme :: Map.Map String a -> Scheme a b

6069monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

6170

6271infixl 8 /\

@@ -70,23 +79,31 @@ a@(A _ c1) /\ b@(A _ c2) =

7079

7180infixr 9 ==>

7281(==>) :: Type -> Type -> Type

73−a ==> b = TermN (Fun1 a b)

74−

75−f <| a = TermN (App1 f a)

76−

77−data Descriptor = Descriptor {

78− structure :: Maybe (Term1 Variable),

79− rank :: Int,

80− flex :: Flex,

81− name :: Maybe TypeName,

82− copy :: Maybe Variable,

83− mark :: Int

84−} deriving Show

85−

82+a ==> b = termN (Fun1 a b)

83+

84+(<|) :: TermN a -> TermN a -> TermN a

85+f <| a = termN (App1 f a)

86+

87+data Descriptor = Descriptor

88+ { structure :: Maybe (Term1 Variable)

89+ , rank :: Int

90+ , flex :: Flex

91+ , name :: Maybe TypeName

92+ , copy :: Maybe Variable

93+ , mark :: Int

94+ , alias :: Maybe Var.Canonical

95+ } deriving Show

96+

97+noRank :: Int

8698noRank = -1

87−outermostRank = 0 :: Int

8899

100+outermostRank :: Int

101+outermostRank = 0

102+

103+noMark :: Int

89104noMark = 0

105+

106+initialMark :: Int

90107initialMark = 1

91108

92109data Flex = Rigid | Flexible | Constant | Is SuperType

@@ -95,34 +112,26 @@ data Flex = Rigid | Flexible | Constant | Is SuperType

95112data SuperType = Number | Comparable | Appendable

96113 deriving (Show, Eq)

97114

98−namedVar :: Flex -> String -> IO Variable

99−namedVar flex name = UF.fresh $ Descriptor {

100− structure = Nothing,

101− rank = noRank,

102− flex = flex,

103− name = Just name,

104− copy = Nothing,

105− mark = noMark

115+namedVar :: Flex -> Var.Canonical -> IO Variable

116+namedVar flex name = UF.fresh $ Descriptor

117+ { structure = Nothing

118+ , rank = noRank

119+ , flex = flex

120+ , name = Just name

121+ , copy = Nothing

122+ , mark = noMark

123+ , alias = Nothing

106124 }

107125

108−var :: Flex -> IO Variable

109−var flex = UF.fresh $ Descriptor {

110− structure = Nothing,

111− rank = noRank,

112− flex = flex,

113− name = Nothing,

114− copy = Nothing,

115− mark = noMark

116− }

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+variable :: Flex -> IO Variable

127+variable flex = UF.fresh $ Descriptor

128+ { structure = Nothing

129+ , rank = noRank

130+ , flex = flex

131+ , name = Nothing

132+ , copy = Nothing

133+ , mark = noMark

134+ , alias = Nothing

126135 }

127136

128137

@@ -138,13 +147,13 @@ fl rqs constraint@(A ann _) =

138147

139148exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

140149exists f = do

141− v <- liftIO $ var Flexible

142− ex [v] <$> f (VarN v)

150+ v <- liftIO $ variable Flexible

151+ ex [v] <$> f (varN v)

143152

144153existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

145154existsNumber f = do

146− v <- liftIO $ var (Is Number)

147− ex [v] <$> f (VarN v)

155+ v <- liftIO $ variable (Is Number)

156+ ex [v] <$> f (varN v)

148157

149158

150159instance Show a => Show (UF.Point a) where

@@ -187,23 +196,32 @@ instance PrettyType a => PrettyType (Term1 a) where

187196 prettyExt = prty ext

188197 extend | P.render prettyExt == "{}" = P.empty

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

191200 prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)

192201

193202

194203instance PrettyType a => PrettyType (TermN a) where

195204 pretty when term =

196205 case term of

197− VarN x -> pretty when x

198− TermN t1 -> pretty when t1

199−

206+ VarN alias x -> either alias (pretty when x)

207+ TermN alias t1 -> either alias (pretty when t1)

208+ where

209+ either maybeAlias doc =

210+ case maybeAlias of

211+ Just alias -> PP.pretty alias

212+ Nothing -> doc

200213

201214instance PrettyType Descriptor where

202− pretty when desc =

203− case (structure desc, name desc) of

204− (Just term, _) -> pretty when term

205− (_, Just name) -> if not (isTuple name) then P.text (reprime name) else

206− P.parens . P.text $ replicate (read (drop 6 name) - 1) ','

215+ pretty when desc = do

216+ case (alias desc, structure desc, name desc) of

217+ (Just name, _, _) -> PP.pretty name

218+ (_, Just term, _) -> pretty when term

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+

207225 _ -> P.text "?"

208226

209227

@@ -269,7 +287,7 @@ addNames value = do

269287 (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)

270288 let vars = map head . List.group $ List.sort rawVars

271289 suffix s = map (++s) (map (:[]) ['a'..'z'])

272− allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]

290+ allVars = concatMap suffix $ ["","'","_"] ++ map show [ (0 :: Int) .. ]

273291 okayVars = filter (`notElem` vars) allVars

274292 runStateT (crawl rename value) (okayVars, 0, 0, 0)

275293 return value

@@ -277,23 +295,20 @@ addNames value = do

277295 getNames desc state@(vars, a, b, c) =

278296 let name' = name desc in

279297 case name' of

280− Just var -> (name', (var:vars, a, b, c))

281− Nothing -> (name', state)

298+ Just (Var.Canonical _ var) -> (name', (var:vars, a, b, c))

299+ _ -> (name', state)

282300

283301 rename desc state@(vars, a, b, c) =

284302 case name desc of

285303 Just var -> (Just var, state)

286304 Nothing ->

287305 case flex desc of

288− Is Number -> (Just $ "number" ++ replicate a '\'', (vars, a+1, b, c))

289− Is Comparable -> (Just $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

290− Is Appendable -> (Just $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

291− other -> (Just $ head vars, (tail vars, a, b, c))

292− where mark = case other of

293− Flexible -> ""

294− Rigid -> "!"

295− Constant -> "#"

296−

306+ Is Number -> (local $ "number" ++ replicate a '\'', (vars, a+1, b, c))

307+ Is Comparable -> (local $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

308+ Is Appendable -> (local $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

309+ _ -> (local $ head vars, (tail vars, a, b, c))

310+ where

311+ local v = Just (Var.local v)

297312

298313type CrawlState = ([String], Int, Int, Int)

299314

@@ -329,8 +344,8 @@ instance (Crawl t, Crawl v) => Crawl (Scheme t v) where

329344instance Crawl t => Crawl (TermN t) where

330345 crawl nextState tipe =

331346 case tipe of

332− VarN x -> VarN <$> crawl nextState x

333− TermN term -> TermN <$> crawl nextState term

347+ VarN a x -> VarN a <$> crawl nextState x

348+ TermN a term -> TermN a <$> crawl nextState term

334349

335350instance Crawl t => Crawl (Term1 t) where

336351 crawl nextState term =

@@ -359,50 +374,71 @@ instance Crawl Descriptor where

359374 return $ desc { name = name', structure = structure' }

360375

361376

362−toSrcType :: Variable -> IO Src.Type

363−toSrcType variable = do

364− desc <- UF.descriptor =<< addNames variable

365− case structure desc of

366− Just term ->

377+toSrcType :: Variable -> IO T.CanonicalType

378+toSrcType var =

379+ go =<< addNames var

380+ where

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 =

367398 case term of

368399 App1 a b -> do

369− Src.Data name ts <- toSrcType a

370− b' <- toSrcType b

371− return (Src.Data name (ts ++ [b']))

372− Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b

373− Var1 a -> toSrcType a

374− EmptyRecord1 -> return $ Src.Record [] Nothing

400+ a' <- go a

401+ b' <- go b

402+ case a' of

403+ T.App f args -> return $ T.App f (args ++ [b'])

404+ _ -> return $ T.App a' [b']

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+

375412 Record1 tfields extension -> do

376− fields' <- traverse (mapM toSrcType) tfields

413+ fields' <- traverse (mapM go) tfields

377414 let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

378− ext' <- toSrcType extension

415+ ext' <- dealias <$> go extension

379416 return $ case ext' of

380− Src.Record fs ext -> Src.Record (fs ++ fields) ext

381− Src.Var x -> Src.Record fields (Just x)

417+ T.Record fs ext -> T.Record (fs ++ fields) ext

418+ T.Var _ -> T.Record fields (Just ext')

382419 _ -> error "Used toSrcType on a type that is not well-formed"

383− Nothing ->

384− case name desc of

385− Just x@(c:_) | Char.isLower c -> return (Src.Var x)

386− | otherwise -> return (Src.Data x [])

387− _ -> error $ concat

388− [ "Problem converting the following type "

389− , "from a type-checker type to a source-syntax type:"

390− , P.render (pretty Never variable) ]

420+

421+ dealias :: T.CanonicalType -> T.CanonicalType

422+ dealias t =

423+ case t of

424+ T.Aliased _ t' -> t'

425+ _ -> t

426+

391427

392428data AppStructure = List Variable | Tuple [Variable] | Other

393429

394430collectApps :: Variable -> IO AppStructure

395−collectApps variable = go [] variable

431+collectApps var = go [] var

396432 where

397− go vars variable = do

398− desc <- UF.descriptor variable

433+ go vars var = do

434+ desc <- UF.descriptor var

399435 case (structure desc, vars) of

400436 (Nothing, [v]) -> case name desc of

401− Just "_List" -> return (List v)

402− _ -> return Other

437+ Just n | Var.isList n -> return (List v)

438+ _ -> return Other

403439 (Nothing, vs) -> case name desc of

404− Just ctor | isTuple ctor -> return (Tuple vs)

405− _ -> return Other

440+ Just n | Var.isTuple n -> return (Tuple vs)

441+ _ -> return Other

406442 (Just term, _) -> case term of

407443 App1 a b -> go (vars ++ [b]) a

408444 _ -> return Other

compiler/Type/Unify.hs+81−52

@@ -1,11 +1,14 @@

11{-# OPTIONS_GHC -W #-}

22module Type.Unify (unify) where

33

4+import Control.Applicative ((<|>))

45import Control.Monad.State

6+import qualified Data.List as List

57import qualified Data.Map as Map

68import qualified Data.Maybe as Maybe

79import 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

912import qualified Type.State as TS

1013import Type.Type

1114import Type.PrettyPrint

@@ -23,64 +26,55 @@ actuallyUnify region variable1 variable2 = do

2326 desc2 <- liftIO $ UF.descriptor variable2

2427 let unify' = unify region

2528

26− name' :: Maybe String

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)

29+ (name', flex', rank', alias') = combinedDescriptors desc1 desc2

5130

5231 merge1 :: StateT TS.SolverState IO ()

5332 merge1 = liftIO $ do

5433 if rank desc1 < rank desc2 then UF.union variable2 variable1

5534 else UF.union variable1 variable2

5635 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+ }

5841

5942 merge2 :: StateT TS.SolverState IO ()

6043 merge2 = liftIO $ do

6144 if rank desc1 < rank desc2 then UF.union variable2 variable1

6245 else UF.union variable1 variable2

6346 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+ }

6552

6653 merge = if rank desc1 < rank desc2 then merge1 else merge2

6754

6855 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable

6956 fresh structure = do

70− var <- liftIO . UF.fresh $ Descriptor {

71− structure = structure, rank = rank', flex = flex',

72− name = name', copy = Nothing, mark = noMark

73− }

74− TS.register var

75−

76− flexAndUnify var = do

77− liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }

57+ v <- liftIO . UF.fresh $ Descriptor

58+ { structure = structure

59+ , rank = rank'

60+ , flex = flex'

61+ , name = name'

62+ , copy = Nothing

63+ , mark = noMark

64+ , alias = alias'

65+ }

66+ TS.register v

67+

68+ flexAndUnify v = do

69+ liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }

7870 unify' variable1 variable2

7971

80− unifyNumber svar name

81− | name `elem` ["Int","Float","number"] = flexAndUnify svar

82− | otherwise = TS.addError region (Just hint) variable1 variable2

83− where hint = "A number must be an Int or Float."

72+ unifyNumber svar (Var.Canonical home name) =

73+ case home of

74+ Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar

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

8478

8579 comparableError maybe =

8680 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

@@ -90,22 +84,24 @@ actuallyUnify region variable1 variable2 = do

9084 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

9185 where msg = "An appendable must be of type String, List, or Text."

9286

93− unifyComparable var name

94− | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var

95− | otherwise = comparableError Nothing

87+ unifyComparable v (Var.Canonical home name) =

88+ case home of

89+ Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v

90+ Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v

91+ _ -> comparableError Nothing

9692

9793 unifyComparableStructure varSuper varFlex =

9894 do struct <- liftIO $ collectApps varFlex

9995 case struct of

10096 Other -> comparableError Nothing

10197 List v -> do flexAndUnify varSuper

102− unify' v =<< liftIO (var $ Is Comparable)

98+ unify' v =<< liftIO (variable $ Is Comparable)

10399 Tuple vs

104100 | length vs > 6 ->

105101 comparableError $ Just "Cannot compare a tuple with more than 6 elements."

106102 | otherwise ->

107103 do flexAndUnify varSuper

108− cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)

104+ cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

109105 zipWithM_ unify' vs cmpVars

110106

111107 unifyAppendable varSuper varFlex =

@@ -114,10 +110,10 @@ actuallyUnify region variable1 variable2 = do

114110 List _ -> flexAndUnify varSuper

115111 _ -> appendableError Nothing

116112

117− rigidError variable = TS.addError region (Just hint) variable1 variable2

113+ rigidError var = TS.addError region (Just hint) variable1 variable2

118114 where

119− var = "'" ++ render (pretty Never variable) ++ "'"

120− hint = "Cannot unify rigid type variable " ++ var ++

115+ var' = "'" ++ render (pretty Never var) ++ "'"

116+ hint = "Cannot unify rigid type variable " ++ var' ++

121117 ".\nThe problem probably relates to a type annotation. Note that rigid type\n\

122118 \variables are not shared between a top-level and let-bound type annotations."

123119

@@ -136,10 +132,10 @@ actuallyUnify region variable1 variable2 = do

136132 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2

137133 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1

138134

139− (Is Appendable, _, _, Just ctor)

140− | ctor `elem` ["Text.Text","String"] -> flexAndUnify variable1

141− (_, Is Appendable, Just ctor, _)

142− | ctor `elem` ["Text.Text","String"] -> flexAndUnify variable2

135+ (Is Appendable, _, _, Just name)

136+ | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1

137+ (_, Is Appendable, Just name, _)

138+ | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2

143139 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2

144140 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1

145141

@@ -202,3 +198,36 @@ actuallyUnify region variable1 variable2 = do

202198

203199 _ -> TS.addError region Nothing variable1 variable2

204200

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?

2222@docs not, (&&), (||), xor, otherwise

2323

2424# Mathematics

25−@docs (+), (-), (*), (/), (^), div, rem, mod, abs, sqrt, clamp, logBase, e

25+@docs (+), (-), (*), (/), (^), (//), rem, (%), negate, abs, sqrt, clamp, logBase, e

2626

2727# Trigonometry

2828@docs pi, cos, sin, tan, acos, asin, atan, atan2

@@ -46,7 +46,7 @@ which happen to be radians.

4646@docs fst, snd

4747

4848# Higher-Order Helpers

49−@docs id, (<|), (|>), (.), always, flip, curry, uncurry

49+@docs identity, always, (<|), (|>), (<<), (>>), flip, curry, uncurry

5050

5151-}

5252

@@ -58,25 +58,25 @@ radians t = t

5858

5959{-| Convert degrees to standard Elm angles (radians). -}

6060degrees : Float -> Float

61−degrees d = d * Native.Basics.pi / 180

61+degrees = Native.Basics.degrees

6262

6363{-| Convert turns to standard Elm angles (radians).

6464One turn is equal to 360°.

6565-}

6666turns : Float -> Float

67−turns r = 2 * Native.Basics.pi * r

67+turns = Native.Basics.turns

6868

6969{-| Start with polar coordinates (r,θ)

7070and get out cartesian coordinates (x,y).

7171-}

7272fromPolar : (Float,Float) -> (Float,Float)

73−fromPolar (r,t) = (r * Native.Basics.cos t, r * Native.Basics.sin t)

73+fromPolar = Native.Basics.fromPolar

7474

7575{-| Start with cartesian coordinates (x,y)

7676and get out polar coordinates (r,θ).

7777-}

7878toPolar : (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

8080

8181(+) : number -> number -> number

8282(+) = Native.Basics.add

@@ -97,21 +97,29 @@ infixl 7 *

9797infixl 7 /

9898infixl 8 ^

9999

100−infixl 7 `div`

101−infixl 7 `mod`

100+infixl 7 //

101+infixl 7 %

102102infixl 7 `rem`

103103

104104{-| Integer division, remainder is discarded. -}

105−div : Int -> Int -> Int

106−div = Native.Basics.div

105+(//) : Int -> Int -> Int

106+(//) = Native.Basics.div

107107

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+-}

109113rem : Int -> Int -> Int

110114rem = Native.Basics.rem

111115

112−{-| Perform modular arithmetic: ``7 `mod` 2 == 1`` -}

113−mod : Int -> Int -> Int

114−mod = Native.Basics.mod

116+{-| Perform [modular arithmetic](http://en.wikipedia.org/wiki/Modular_arithmetic):

117+

118+ 7 % 2 == 1

119+ -1 % 4 == 3

120+-}

121+(%) : Int -> Int -> Int

122+(%) = Native.Basics.mod

115123

116124{-| Exponentiation: `3^2 == 9` -}

117125(^) : number -> number -> number

@@ -150,15 +158,19 @@ atan2 : Float -> Float -> Float

150158atan2 = Native.Basics.atan2

151159

152160{-| Take the square root of a number. -}

153−sqrt : number -> number

161+sqrt : Float -> Float

154162sqrt = Native.Basics.sqrt

155163

164+{-| Negate any number: `negate 42 == -42` -}

165+negate : number -> number

166+negate = Native.Basics.negate

167+

156168{-| Take the absolute value of a number. -}

157169abs : number -> number

158170abs = Native.Basics.abs

159171

160172{-| Calculate the logarithm of a number with a given base: `logBase 10 100 == 2` -}

161−logBase : number -> number -> number

173+logBase : Float -> Float -> Float

162174logBase = Native.Basics.logBase

163175

164176{-| Clamps a number within a given range. With the expression

@@ -301,9 +313,32 @@ isInfinite = Native.Basics.isInfinite

301313

302314-- Function Helpers

303315

304−{-| Function composition: `(f . g == (\\x -> f (g x)))` -}

305−(.) : (b -> c) -> (a -> b) -> (a -> c)

306−(.) f g x = f (g x)

316+{-| Function composition, passing results along in the suggested direction. For

317+example, the following code checks if the square root of a number is odd:

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)

307342

308343{-| Forward function application `x |> f == f x`. This function is useful

309344for avoiding parenthesis and writing code in a more natural way.

@@ -332,13 +367,16 @@ This can also be written as:

332367(<|) : (a -> b) -> a -> b

333368f <| x = f x

334369

335−infixr 9 .

370+infixr 9 <<

371+infixl 9 >>

336372infixr 0 <|

337373infixl 0 |>

338374

339−{-| Given a value, returns exactly the same value. -}

340−id : a -> a

341−id x = x

375+{-| Given a value, returns exactly the same value. This is called

376+[the identity function](http://en.wikipedia.org/wiki/Identity_function).

377+-}

378+identity : a -> a

379+identity x = x

342380

343381{-| Creates a [constant function](http://en.wikipedia.org/wiki/Constant_function),

344382a 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.

6060-}

6161hsla : Float -> Float -> Float -> Float -> Color

6262hsla 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

6464

6565{-| Create [HSL colors](http://en.wikipedia.org/wiki/HSL_and_HSV). This gives

6666you access to colors more like a color wheel, where all hues are aranged in a

@@ -97,7 +97,7 @@ complement color =

9797 RGBA r g b a -> let (h,s,l) = rgbToHsl r g b

9898 in hsla (h + degrees 180) s l a

9999

100−{-| Extract the the components of a color in the HSL format.

100+{-| Extract the components of a color in the HSL format.

101101-}

102102toHsl : Color -> { hue:Float, saturation:Float, lightness:Float, alpha:Float }

103103toHsl color =

@@ -107,7 +107,7 @@ toHsl color =

107107 let (h,s,l) = rgbToHsl r g b

108108 in { hue=h, saturation=s, lightness=l, alpha=a }

109109

110−{-| Extract the the components of a color in the RGB format.

110+{-| Extract the components of a color in the RGB format.

111111-}

112112toRgb : Color -> { red:Int, green:Int, blue:Int, alpha:Float }

113113toRgb color =

@@ -124,7 +124,7 @@ toRgb color =

124124fmod : Float -> Int -> Float

125125fmod f n =

126126 let integer = floor f

127− in toFloat (integer `mod` n) + f - toFloat integer

127+ in toFloat (integer % n) + f - toFloat integer

128128

129129rgbToHsl : Int -> Int -> Int -> (Float,Float,Float)

130130rgbToHsl red green blue =

libraries/Debug.elm+71−2

@@ -2,10 +2,16 @@ module Debug where

22{-| This library is for investigating bugs or performance problems. It should

33*not* be used in production code.

44

5−@docs log

5+# Console Debugging

6+@docs log, crash

7+

8+# Time-Travel Debugging

9+@docs watch, watchSummary, trace

610-}

711

12+import Graphics.Collage (Form)

813import Native.Debug

14+import Native.Error

915

1016{-| Log a tagged value on the developer console, and then return the value.

1117

@@ -16,4 +22,67 @@ Notice that `log` is not a pure function! It should *only* be used for

1622investigating bugs or performance problems.

1723-}

1824log : 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

2− ,get,getOrElse,getOrFail

3− ,remove,member

4− ,filter

5− ,partition

6− ,foldl,foldr,map

7− ,union,intersect,diff

8− ,keys,values

9− ,toList,fromList

10− ) where

1+module Dict

2+ ( Dict

3+ , empty, singleton, insert, update

4+ , get, getOrElse, getOrFail

5+ , remove, member

6+ , filter

7+ , partition

8+ , foldl, foldr, map

9+ , union, intersect, diff

10+ , keys, values

11+ , toList, fromList

12+ ) where

1113

1214{-| A dictionary mapping unique keys to values. The keys can be any comparable

1315type. This includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or

@@ -37,36 +39,42 @@ import Basics (..)

3739import Maybe (..)

3840import Native.Error

3941import List

42+import List ((::))

4043import Native.Utils

4144

45+type Fakeout = (Int, Int)

46+

47+type Another = (Int, Int)

48+

4249-- BBlack and NBlack should only be used during the deletion

4350-- algorithm. Any other occurrence is a bug and should fail an assert.

44−data NColor = Red

45− | Black

46− -- ^ Double Black, counts as 2 blacks for the invariant

47− | BBlack

48− -- ^ Negative Black, counts as -1 blacks for the invariant

49− | NBlack

51+data NColor

52+ = Red

53+ | Black

54+ | BBlack -- Double Black, counts as 2 blacks for the invariant

55+ | NBlack -- Negative Black, counts as -1 blacks for the invariant

5056

5157

5258showNColor : NColor -> String

53−showNColor c = case c of

54− Red -> "Red"

55− Black -> "Black"

56− BBlack -> "BBlack"

57− NBlack -> "NBlack"

59+showNColor c =

60+ case c of

61+ Red -> "Red"

62+ Black -> "Black"

63+ BBlack -> "BBlack"

64+ NBlack -> "NBlack"

5865

59−data LeafColor = LBlack

60− -- ^ Double Black, counts as 2

61− | LBBlack

66+data LeafColor

67+ = LBlack

68+ | LBBlack -- Double Black, counts as 2

6269

6370showLColor : LeafColor -> String

6471showLColor c = case c of

6572 LBlack -> "LBlack"

6673 LBBlack -> "LBBlack"

6774

68−data Dict k v = RBNode NColor k v (Dict k v) (Dict k v)

69− | RBEmpty LeafColor

75+data Dict k v

76+ = RBNode NColor k v (Dict k v) (Dict k v)

77+ | RBEmpty LeafColor

7078

7179{-| Create an empty dictionary. -}

7280empty : Dict comparable v

@@ -248,7 +256,7 @@ reportRemBug msg c lgot rgot =

248256 lgot,

249257 " ",

250258 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"

252260 ]

253261

254262-- Remove the top node from the tree, may leave behind BBlacks

libraries/Either.elm+2−1

@@ -14,8 +14,9 @@ module Either where

1414-}

1515

1616import List

17+import List ((::))

1718

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

1920either an `Int` or a `String`.

2021

2122This 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.

3232

3333import Basics (..)

3434import List

35−import Either (Either, Left, Right)

36−import Transform2D (Transform2D, identity)

35+import Either (Either(Left, Right))

36+import Transform2D (Transform2D)

37+import Transform2D as T

3738import Native.Graphics.Collage

3839import Graphics.Element (Element)

3940import Color (Color, black, Gradient)

@@ -153,7 +154,7 @@ toForm e = form (FElement e)

153154as a single unit, making it possible to build small, modular components.

154155-}

155156group : [Form] -> Form

156−group fs = form (FGroup identity fs)

157+group fs = form (FGroup T.identity fs)

157158

158159{-| Flatten many forms into a single `Form` and then apply a matrix

159160transformation.

libraries/Graphics/Element.elm+1−1

@@ -41,7 +41,7 @@ import Basics (..)

4141import Native.Utils

4242import List as List

4343import Color (..)

44−import Maybe (Maybe, Just, Nothing)

44+import Maybe ( Maybe(..) )

4545

4646type Properties = {

4747 id : Int,

libraries/Graphics/Input/Field.elm+4−4

@@ -33,8 +33,8 @@ edges all have width 1:

3333uniformly : Int -> Dimensions

3434uniformly n = Dimensions n n n n

3535

36−{-| For setting dimensions of a fields padding or border. The left, right, top,

37−and bottom may all have different sizes. The following example creates

36+{-| For setting dimensions of a field's padding or outline. The left, right,

37+top, and bottom may all have different sizes. The following example creates

3838dimensions such that the left and right are twice as wide as the top and bottom:

3939

4040 myDimensions : Int -> Dimensions

@@ -69,8 +69,8 @@ noHighlight : Highlight

6969noHighlight = Highlight Color.blue 0

7070

7171{-| 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

73−outline that shows up when the field has focus. `outline` describes the line

72+itself using [`Text.Style`](/Text#Style). `highlight` describes the glowing blue

73+highlight that shows up when the field has focus. `outline` describes the line

7474surrounding the text field, and `padding` adds whitespace between the `outline`

7575and the text.

7676

libraries/Keyboard.elm+15−8

@@ -8,7 +8,10 @@ module Keyboard where

88@docs arrows, wasd, directions

99

1010# 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

1215

1316# General Keypresses

1417@docs isDown, keysDown, lastPressed

@@ -50,19 +53,23 @@ wasd = directions 87 83 65 68

5053isDown : KeyCode -> Signal Bool

5154isDown = Native.Keyboard.isDown

5255

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+

5467shift : Signal Bool

5568shift = isDown 16

5669

57−{-| Whether the control key is pressed. -}

58−ctrl : Signal Bool

59−ctrl = isDown 17

60−

61−{-| Whether the space key is pressed. -}

6270space : Signal Bool

6371space = isDown 32

6472

65−{-| Whether the enter key is pressed. -}

6673enter : Signal Bool

6774enter = isDown 13

6875

libraries/List.elm+59−11

@@ -10,22 +10,35 @@ list must have the same type.

1010@docs head, tail, last, filter, take, drop

1111

1212# Putting Lists Together

13−@docs concat, concatMap, join, intersperse, zip, zipWith, repeat

13+@docs concat, join, intersperse, zip, zipWith, repeat

1414

1515# Taking Lists Apart

1616@docs partition, unzip

1717

1818# Folds

19−@docs foldr, foldl, foldr1, foldl1, scanl, scanl1

19+@docs foldr, foldl

20+

21+# Special Maps

22+@docs filterMap, concatMap, indexedMap

2023

2124# Special Folds

22−@docs sum, product, maximum, minimum, all, any, and, or

25+@docs sum, product, maximum, minimum, all, any, foldr1, foldl1, scanl, scanl1

2326

2427# Sorting

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

2638-}

2739

2840import Basics (..)

41+import Maybe ( Maybe(Just,Nothing) )

2942import Native.List

3043

3144{-| Add an element to the front of a list `(1 :: [2,3] == [1,2,3])` -}

@@ -72,6 +85,15 @@ isEmpty xs =

7285map : (a -> b) -> [a] -> [b]

7386map = Native.List.map

7487

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+

7597{-| Reduce a list from the left: `(foldl (::) [] [1,2,3] == [3,2,1])` -}

7698foldl : (a -> b -> b) -> b -> [a] -> b

7799foldl = Native.List.foldl

@@ -108,6 +130,22 @@ scanl1 = Native.List.scanl1

108130filter : (a -> Bool) -> [a] -> [a]

109131filter = Native.List.filter

110132

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+

111149{-| Determine the length of a list: `(length [1,2,3] == 3)` -}

112150length : [a] -> Int

113151length = Native.List.length

@@ -124,14 +162,6 @@ all = Native.List.all

124162any : (a -> Bool) -> [a] -> Bool

125163any = Native.List.any

126164

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−

135165{-| Concatenate a list of appendable things:

136166

137167 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.

186216zip : [a] -> [b] -> [(a,b)]

187217zip = Native.List.zip

188218

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+

189228{-| Combine two lists, combining them with the given function.

190229If one list is longer, the extra elements are dropped.

191230

@@ -194,6 +233,15 @@ If one list is longer, the extra elements are dropped.

194233zipWith : (a -> b -> c) -> [a] -> [b] -> [c]

195234zipWith = Native.List.zipWith

196235

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+

197245{-| Decompose a list of tuples.

198246

199247 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

22

33{-| Represents an optional value. Maybe it is there, maybe it is not.

44

@@ -8,13 +8,10 @@ module Maybe where

88# Taking Maybes apart

99@docs maybe, isJust, isNothing

1010

11−# Maybes and Lists

12−@docs justs

11+# Map

12+@docs map

1313-}

1414

15−import Basics (not, (.))

16−import List (foldr)

17−

1815{-| The Maybe datatype. Useful when a computation may or may not

1916result in a value (e.g. logarithm is defined only for positive

2017numbers).

@@ -27,14 +24,12 @@ function to the associated value.

2724

2825 isPositive : Maybe Int -> Bool

2926 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

3327-}

3428maybe : b -> (a -> b) -> Maybe a -> b

35−maybe b f m = case m of

36− Just v -> f v

37− Nothing -> b

29+maybe b f m =

30+ case m of

31+ Just v -> f v

32+ Nothing -> b

3833

3934{-| Check if a maybe happens to be a `Just`.

4035

@@ -52,14 +47,15 @@ isJust = maybe False (\_ -> True)

5247 isNothing Nothing == True

5348-}

5449isNothing : Maybe a -> Bool

55−isNothing = not . isJust

56−

57−cons : Maybe a -> [a] -> [a]

58−cons mx xs = maybe xs (\x -> x :: xs) mx

50+isNothing = maybe True (\_ -> False)

5951

60−{-| Filters out Nothings and extracts the remaining values.

52+{-| Transform the contents of a `Maybe` with a given function:

6153

62− justs [Just 0, Nothing, Just 5, Just 7] == [0,5,7]

54+ map sqrt (Just 9) == Just 3

55+ map sqrt Nothing == Nothing

6356-}

64−justs : [Maybe a] -> [a]

65−justs = foldr cons []

57+map : (a -> b) -> Maybe a -> Maybe b

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) {

3535 function unsafeGet(i, array) {

3636 for (var x = array.height; x > 0; x--) {

3737 var slot = i >> (x * 5);

38+ while (array.lengths[slot] <= i) {

39+ slot++;

40+ }

3841 if (slot > 0) {

39− while (array.lengths[slot - 1] > i) { slot--; }

4042 i -= array.lengths[slot - 1];

4143 }

4244 array = array.table[slot];

@@ -255,15 +257,27 @@ Elm.Native.Array.make = function(elm) {

255257 }

256258

257259 function foldl(f, b, a) {

258− for (var i = 0; i < a.table.length; i++) {

259− b = A2(f, a.height == 0 ? a.table[i] : foldl(f, b, a.table[i]), b);

260+ if (a.height == 0) {

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+ }

260268 }

261269 return b;

262270 }

263271

264272 function foldr(f, b, a) {

265− for (var i = a.table.length; i--; ) {

266− b = A2(f, a.height == 0 ? a.table[i] : foldr(f, b, a.table[i]), b);

273+ if (a.height == 0) {

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+ }

267281 }

268282 return b;

269283 }

@@ -299,10 +313,12 @@ Elm.Native.Array.make = function(elm) {

299313

300314 // Create new node.

301315 var newA = { ctor:"_Array", height:a.height

302− , table:a.table.slice(0, right + 1)

303− , lengths:a.lengths.slice(0, right + 1) };

304− newA.table[right] = sliced;

305− newA.lengths[right] = length(sliced) + (right > 0 ? newA.lengths[right - 1] : 0);

316+ , table:a.table.slice(0, right)

317+ , lengths:a.lengths.slice(0, right) };

318+ if (sliced.table.length > 0) {

319+ newA.table[right] = sliced;

320+ newA.lengths[right] = length(sliced) + (right > 0 ? newA.lengths[right - 1] : 0);

321+ }

306322 return newA;

307323 }

308324

@@ -331,7 +347,7 @@ Elm.Native.Array.make = function(elm) {

331347 var newA = { ctor:"_Array", height:a.height

332348 , table:a.table.slice(left, a.table.length + 1)

333349 , lengths:new Array(a.table.length - left) };

334− newA.table[left] = sliced;

350+ newA.table[0] = sliced;

335351 var len = 0;

336352 for (var i = 0; i < newA.table.length; i++) {

337353 len += length(newA.table[i]);

@@ -342,68 +358,116 @@ Elm.Native.Array.make = function(elm) {

342358 }

343359

344360 // 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.

347361 function append(a,b) {

348− if (b.height > a.height) { return append(parentise(a, b.height), b); }

349− if (a.height > b.height) { return append(a, parentise(b, a.height)); }

350− if (a.height == 0) { return append(parentise(a, 1), parentise(b, 1)); }

362+ if (a.table.length === 0) {

363+ return b;

364+ }

365+ if (b.table.length === 0) {

366+ return a;

367+ }

351368

352369 var c = append_(a, b);

353− if (c[1].table.length > 0) {

354− return siblise(c[0], c[1]);

355− } else {

370+

371+ // Check if both nodes can be crunshed together.

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+

356390 return c[0];

357391 }

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]);

358399 }

359400

360− // Returns an array of two nodes. The second node _may_ be empty. This case

361− // needs to be handled by the function, that called append_. May be only

362− // called for trees with an minimal height of 1.

401+ // Returns an array of two nodes; right and left. One node _may_ be empty.

363402 function append_(a, b) {

364− if (a.height == 1) {

365− // Check if balancing is needed and return based on that.

366− var toRemove = calcToRemove(a, b);

367− if (toRemove <= E) {

368− return [a,b];

369− }

370−

371− return shuffle(a, b, toRemove);

403+ if (a.height === 0 && b.height === 0) {

404+ return [a, b];

372405 }

373406

374− var appended = append_(botRight(a), botLeft(b));

375− a = nodeCopy(a), b = nodeCopy(b);

407+ if (a.height !== 1 || b.height !== 1) {

408+ if (a.height === b.height) {

409+ a = nodeCopy(a);

410+ b = nodeCopy(b);

411+ var appended = append_(botRight(a), botLeft(b));

376412

377− // Adjust the bottom right side of the new tree.

378− a.table[a.table.length - 1] = appended[0];

379− a.lengths[a.lengths.length - 1] = length(appended[0])

380− a.lengths[a.lengths.length - 1] += a.lengths.length > 1 ? a.lengths[a.lengths.length - 2] : 0;

413+ insertRight(a, appended[1]);

414+ insertLeft(b, appended[0]);

415+ } else if (a.height > b.height) {

416+ a = nodeCopy(a);

417+ var appended = append_(botRight(a), b);

381418

382− // Adjust the bottom left side of the new tree.

383− if (appended[1].table.length > 0) {

384− b.table[0] = appended[1];

385− b.lengths[0] = length(appended[1]);

386− for (var i = 1, len = length(b.table[0]); i < b.lengths.length; i++) {

387− len += length(b.table[i]);

388− b.lengths[i] = len;

389− }

390− } else {

391− b.table.shift();

392− for (var i = 1; i < b.lengths.length; i++) {

393− b.lengths[i] = b.lengths[i] - b.lengths[0];

419+ insertRight(a, appended[0]);

420+ b = parentise(appended[1], appended[1].height + 1);

421+ } else {

422+ b = nodeCopy(b);

423+ var appended = append_(a, botLeft(b));

424+

425+ var left = appended[0].table.length === 0 ? 0 : 1;

426+ var right = left === 0 ? 1 : 0;

427+ insertLeft(b, appended[left]);

428+ a = parentise(appended[right], appended[right].height + 1);

394429 }

395− b.lengths.shift();

396430 }

397431

398432 // Check if balancing is needed and return based on that.

399− var toRemove = calcToRemove(a, b);

400− if (toRemove <= E || b.table.length == 0) {

433+ if (a.table.length === 0 || b.table.length === 0) {

401434 return [a,b];

402435 }

403436

437+ var toRemove = calcToRemove(a, b);

438+ if (toRemove <= E) {

439+ return [a,b];

440+ }

404441 return shuffle(a, b, toRemove);

405442 }

406443

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+

407471 // Returns the extra search steps for E. Refer to the paper.

408472 function calcToRemove(a, b) {

409473 var subLengths = 0;

@@ -544,7 +608,9 @@ Elm.Native.Array.make = function(elm) {

544608 // find the exact slot via forward searching in "lengths". Returns the index.

545609 function getSlot(i, a) {

546610 var slot = i >> (5 * a.height);

547− while (a.lengths[slot - 1] > i) { slot--; }

611+ while (a.lengths[slot] <= i) {

612+ slot++;

613+ }

548614 return slot;

549615 }

550616

libraries/Native/Basics.js+94−45

@@ -8,54 +8,103 @@ Elm.Native.Basics.make = function(elm) {

88 var JS = Elm.Native.JavaScript.make(elm);

99 var Utils = Elm.Native.Utils.make(elm);

1010

11− function div(a,b) { return (a/b)|0; }

12− function rem(a,b) { return a % b; }

11+ function div(a, b) {

12+ return (a/b)|0;

13+ }

14+ function rem(a, b) {

15+ return a % b;

16+ }

1317 var mod = Utils.mod;

14− function abs(x) { return x < 0 ? -x : x; }

15− function logBase(base,n) { return Math.log(n) / Math.log(base); }

16− function min(a,b) { return Utils.cmp(a,b) < 0 ? a : b; }

17− function max(a,b) { return Utils.cmp(a,b) > 0 ? a : b; }

18− function clamp(lo,hi,n) {

19− return Utils.cmp(n,lo) < 0 ? lo : Utils.cmp(n,hi) > 0 ? hi : n; }

20− function xor(a,b) { return a !== b; }

21− function not(b) { return !b; }

22− function isInfinite(n) { return n === Infinity || n === -Infinity }

23−

24− function truncate(n) { return n|0; }

18+ function logBase(base, n) {

19+ return Math.log(n) / Math.log(base);

20+ }

21+ function negate(n) {

22+ return -n;

23+ }

24+ function abs(n) {

25+ return n < 0 ? -n : n;

26+ }

27+

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+ }

2568

2669 var basics = {

27− div:F2(div),

28− rem:F2(rem),

29− mod:mod,

30−

31− pi:Math.PI,

32− e:Math.E,

33− cos:Math.cos,

34− sin:Math.sin,

35− tan:Math.tan,

36− acos:Math.acos,

37− asin:Math.asin,

38− atan:Math.atan,

39− atan2:F2(Math.atan2),

40−

41− sqrt:Math.sqrt,

42− abs:abs,

43− logBase:F2(logBase),

44− min:F2(min),

45− max:F2(max),

46− clamp:F3(clamp),

47− compare:Utils.compare,

48−

49− xor:F2(xor),

50− not:not,

51−

52− truncate:truncate,

53− ceiling:Math.ceil,

54− floor:Math.floor,

55− round:Math.round,

56− toFloat:function(x) { return x; },

57− isNaN:isNaN,

58− isInfinite:isInfinite

70+ div: F2(div),

71+ rem: F2(rem),

72+ mod: mod,

73+

74+ pi: Math.PI,

75+ e: Math.E,

76+ cos: Math.cos,

77+ sin: Math.sin,

78+ tan: Math.tan,

79+ acos: Math.acos,

80+ asin: Math.asin,

81+ atan: Math.atan,

82+ atan2: F2(Math.atan2),

83+

84+ degrees: degrees,

85+ turns: turns,

86+ fromPolar: fromPolar,

87+ toPolar: toPolar,

88+

89+ sqrt: Math.sqrt,

90+ logBase: F2(logBase),

91+ negate: negate,

92+ abs: abs,

93+ min: F2(min),

94+ max: F2(max),

95+ clamp: F3(clamp),

96+ compare: Utils.compare,

97+

98+ xor: F2(xor),

99+ not: not,

100+

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

59108 };

60109

61110 return elm.Native.Basics.values = basics;

libraries/Native/Char.js+6−4

@@ -4,6 +4,8 @@ Elm.Native.Char.make = function(elm) {

44 elm.Native.Char = elm.Native.Char || {};

55 if (elm.Native.Char.values) return elm.Native.Char.values;

66

7+ var Utils = Elm.Native.Utils.make(elm);

8+

79 function isBetween(lo,hi) { return function(chr) {

810 var c = chr.charCodeAt(0);

911 return lo <= c && c <= hi;

@@ -16,10 +18,10 @@ Elm.Native.Char.make = function(elm) {

1618 return elm.Native.Char.values = {

1719 fromCode : function(c) { return String.fromCharCode(c); },

1820 toCode : function(c) { return c.toUpperCase().charCodeAt(0); },

19− toUpper : function(c) { return c.toUpperCase(); },

20− toLower : function(c) { return c.toLowerCase(); },

21− toLocaleUpper : function(c) { return c.toLocaleUpperCase(); },

22− toLocaleLower : function(c) { return c.toLocaleLowerCase(); },

21+ toUpper : function(c) { return Utils.chr(c.toUpperCase()); },

22+ toLower : function(c) { return Utils.chr(c.toLowerCase()); },

23+ toLocaleUpper : function(c) { return Utils.chr(c.toLocaleUpperCase()); },

24+ toLocaleLower : function(c) { return Utils.chr(c.toLocaleLowerCase()); },

2325 isLower : isBetween('a'.charCodeAt(0),'z'.charCodeAt(0)),

2426 isUpper : isBetween('A'.charCodeAt(0),'Z'.charCodeAt(0)),

2527 isDigit : isDigit,

libraries/Native/Debug.js+40−4

@@ -3,10 +3,13 @@ Elm.Native.Debug.make = function(elm) {

33 elm.Native = elm.Native || {};

44 elm.Native.Debug = elm.Native.Debug || {};

55 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;

68

79 var show = Elm.Native.Show.make(elm).show;

10+ var replace = Elm.Native.Utils.make(elm).replace;

811

9− function log(tag,value) {

12+ function log(tag, value) {

1013 var msg = tag + ': ' + show(value);

1114 var process = process || {};

1215 if (process.stdout) {

@@ -17,8 +20,41 @@ Elm.Native.Debug.make = function(elm) {

1720 return value;

1821 }

1922

20− return elm.Native.Debug.values = {

21− log: F2(log)

23+ function tracePath(debugId, form) {

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

2258 };

23−

59+ return elm.Native.Debug.values = Elm.Native.Debug.values;

2460};

libraries/Native/Graphics/Input.js+84−52

@@ -21,46 +21,67 @@ Elm.Native.Graphics.Input.make = function(elm) {

2121 return { _:{}, signal:signal, handle:signal };

2222 }

2323

24− function renderDropDown(signal, values) {

25− return function(_) {

26− var entries = List.toArray(values);

27−

28− var drop = newNode('select');

29− drop.style.border = '0 solid';

30− drop.style.pointerEvents = 'auto';

31− for (var i = 0; i < entries.length; ++i) {

32− var option = newNode('option');

33− var name = entries[i]._0;

34− option.value = name;

35− option.innerHTML = name;

36− drop.appendChild(option);

37− }

38− drop.addEventListener('change', function() {

39− elm.notify(signal.id, entries[drop.selectedIndex]._1);

40− });

41−

42− var t = drop.cloneNode(true);

43− t.style.visibility = "hidden";

24+ function renderDropDown(model) {

25+ var drop = newNode('select');

26+ drop.style.border = '0 solid';

27+ drop.style.pointerEvents = 'auto';

28+ drop.style.display = 'block';

29+

30+ drop.elm_signal = model.signal;

31+ drop.elm_values = List.toArray(model.values);

32+ var values = drop.elm_values;

33+

34+ for (var i = 0; i < values.length; ++i) {

35+ var option = newNode('option');

36+ var name = values[i]._0;

37+ option.value = name;

38+ option.innerHTML = name;

39+ drop.appendChild(option);

40+ }

41+ drop.addEventListener('change', function() {

42+ elm.notify(drop.elm_signal.id, drop.elm_values[drop.selectedIndex]._1);

43+ });

4444

45− elm.node.appendChild(t);

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− };

45+ return drop;

5246 }

5347

5448 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+ }

5573 }

5674

5775 function dropDown(signal, values) {

5876 return A3(newElement, 100, 24, {

5977 ctor: 'Custom',

6078 type: 'DropDown',

61− render: renderDropDown(signal,values),

79+ render: renderDropDown,

6280 update: updateDropDown,

63− model: {}

81+ model: {

82+ signal: signal,

83+ values: values

84+ }

6485 });

6586 }

6687

@@ -105,52 +126,63 @@ Elm.Native.Graphics.Input.make = function(elm) {

105126 btn.elm_hover = Render.render(model.hover);

106127 btn.elm_down = Render.render(model.down);

107128

108− function replace(node) {

109− if (node !== btn.firstChild) {

110− btn.replaceChild(node, btn.firstChild);

111− }

129+ btn.elm_up.style.display = 'block';

130+ btn.elm_hover.style.display = 'none';

131+ btn.elm_down.style.display = 'none';

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';

112141 }

142+

113143 var overCount = 0;

114144 function over(e) {

115145 if (overCount++ > 0) return;

116− replace(btn.elm_hover);

146+ swap(btn.elm_hover, btn.elm_down, btn.elm_up);

117147 }

118148 function out(e) {

119149 if (btn.contains(e.toElement || e.relatedTarget)) return;

120150 overCount = 0;

121− replace(btn.elm_up);

151+ swap(btn.elm_up, btn.elm_down, btn.elm_hover);

122152 }

123153 function up() {

124− replace(btn.elm_hover);

154+ swap(btn.elm_hover, btn.elm_down, btn.elm_up);

125155 elm.notify(btn.elm_signal.id, btn.elm_value);

126156 }

127157 function down() {

128− replace(btn.elm_down);

158+ swap(btn.elm_down, btn.elm_hover, btn.elm_up);

129159 }

160+

130161 btn.addEventListener('mouseover', over);

131162 btn.addEventListener('mouseout' , out);

132163 btn.addEventListener('mousedown', down);

133164 btn.addEventListener('mouseup' , up);

134165

135− btn.appendChild(btn.elm_up);

136−

137166 return btn;

138167 }

139168

140169 function updateCustomButton(node, oldModel, newModel) {

141− var signal = newModel.signal;

142− node.elm_up.elm_signal = signal;

143− node.elm_hover.elm_signal = signal;

144− node.elm_down.elm_signal = signal;

145−

146− var value = newModel.value;

147− node.elm_up.elm_value = value;

148− node.elm_hover.elm_value = value;

149− node.elm_down.elm_value = value;

150−

151− Render.update(node.elm_up, oldModel.up, newModel.up)

152− Render.update(node.elm_hover, oldModel.hover, newModel.hover)

153− Render.update(node.elm_down, oldModel.down, newModel.down)

170+ node.elm_signal = newModel.signal;

171+ node.elm_value = newModel.value;

172+

173+ var kids = node.childNodes;

174+ var styleUp = kids[0].style.display;

175+ var styleHover = kids[1].style.display;

176+ var styleDown = kids[2].style.display;

177+

178+ Render.update(kids[0], oldModel.up, newModel.up);

179+ Render.update(kids[1], oldModel.hover, newModel.hover);

180+ Render.update(kids[2], oldModel.down, newModel.down);

181+

182+ var kids = node.childNodes;

183+ kids[0].style.display = styleUp;

184+ kids[1].style.display = styleHover;

185+ kids[2].style.display = styleDown;

154186 }

155187

156188 function max3(a,b,c) {

libraries/Native/List.js+52−4

@@ -199,6 +199,16 @@ Elm.Native.List.make = function(elm) {

199199 return false;

200200 }

201201

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+

202212 function zipWith(f, xs, ys) {

203213 var arr = [];

204214 while (xs.ctor !== '[]' && ys.ctor !== '[]') {

@@ -209,12 +219,47 @@ Elm.Native.List.make = function(elm) {

209219 return fromArray(arr);

210220 }

211221

212− function zip(xs, ys) {

222+ function zipWith3(f, xs, ys, zs) {

213223 var arr = [];

214− while (xs.ctor !== '[]' && ys.ctor !== '[]') {

215− arr.push(Utils.Tuple2(xs._0, ys._0));

224+ while (xs.ctor !== '[]' && ys.ctor !== '[]' && zs.ctor !== '[]') {

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;

216260 xs = xs._1;

217261 ys = ys._1;

262+ zs = zs._1;

218263 }

219264 return fromArray(arr);

220265 }

@@ -328,7 +373,10 @@ Elm.Native.List.make = function(elm) {

328373

329374 all:F2(all),

330375 any:F2(any),

331− zipWith:F3(zipWith),

376+ zipWith :F3(zipWith ),

377+ zipWith3:F4(zipWith3),

378+ zipWith4:F5(zipWith4),

379+ zipWith5:F6(zipWith5),

332380 zip:F2(zip),

333381 sort:sort,

334382 sortBy:F2(sortBy),

libraries/Native/Show.js+29−14

@@ -15,15 +15,20 @@ Elm.Native.Show.make = function(elm) {

1515 if (type === "function") {

1616 var name = v.func ? v.func.name : v.name;

1717 return '<function' + (name === '' ? '' : ': ') + name + '>';

18− } else if (type === "boolean") {

18+ }

19+ else if (type === "boolean") {

1920 return v ? "True" : "False";

20− } else if (type === "number") {

21− return v+"";

22− } else if ((v instanceof String) && v.isChar) {

21+ }

22+ else if (type === "number") {

23+ return v + "";

24+ }

25+ else if ((v instanceof String) && v.isChar) {

2326 return "'" + addSlashes(v) + "'";

24− } else if (type === "string") {

27+ }

28+ else if (type === "string") {

2529 return '"' + addSlashes(v) + '"';

26− } else if (type === "object" && '_' in v && probablyPublic(v)) {

30+ }

31+ else if (type === "object" && '_' in v && probablyPublic(v)) {

2732 var output = [];

2833 for (var k in v._) {

2934 for (var i = v._[k].length; i--; ) {

@@ -34,9 +39,12 @@ Elm.Native.Show.make = function(elm) {

3439 if (k === '_') continue;

3540 output.push(k + " = " + toString(v[k]));

3641 }

37− if (output.length === 0) return "{}";

42+ if (output.length === 0) {

43+ return "{}";

44+ }

3845 return "{ " + output.join(", ") + " }";

39− } else if (type === "object" && 'ctor' in v) {

46+ }

47+ else if (type === "object" && 'ctor' in v) {

4048 if (v.ctor.substring(0,6) === "_Tuple") {

4149 var output = [];

4250 for (var k in v) {

@@ -44,10 +52,12 @@ Elm.Native.Show.make = function(elm) {

4452 output.push(toString(v[k]));

4553 }

4654 return "(" + output.join(",") + ")";

47− } else if (v.ctor === "_Array") {

55+ }

56+ else if (v.ctor === "_Array") {

4857 var list = Array.toList(v);

4958 return "Array.fromList " + toString(list);

50− } else if (v.ctor === "::") {

59+ }

60+ else if (v.ctor === "::") {

5161 var output = '[' + toString(v._0);

5262 v = v._1;

5363 while (v.ctor === "::") {

@@ -55,9 +65,11 @@ Elm.Native.Show.make = function(elm) {

5565 v = v._1;

5666 }

5767 return output + ']';

58− } else if (v.ctor === "[]") {

68+ }

69+ else if (v.ctor === "[]") {

5970 return "[]";

60− } else if (v.ctor === "RBNode" || v.ctor === "RBEmpty") {

71+ }

72+ else if (v.ctor === "RBNode" || v.ctor === "RBEmpty") {

6173 var cons = F3(function(k,v,acc){return NList.Cons(Tuple2(k,v),acc)});

6274 var list = A3(Dict.foldr, cons, NList.Nil, v);

6375 var name = "Dict";

@@ -66,7 +78,8 @@ Elm.Native.Show.make = function(elm) {

6678 list = A2(List.map, function(x){return x._0}, list);

6779 }

6880 return name + ".fromList " + toString(list);

69− } else {

81+ }

82+ else {

7083 var output = "";

7184 for (var i in v) {

7285 if (i === 'ctor') continue;

@@ -77,7 +90,9 @@ Elm.Native.Show.make = function(elm) {

7790 return v.ctor + output;

7891 }

7992 }

80− if (type === 'object' && 'recv' in v) return '<signal>';

93+ if (type === 'object' && 'recv' in v) {

94+ return '<signal>';

95+ }

8196 return "<internal structure>";

8297 };

8398

libraries/Native/Signal/Keyboard.js+142−105

@@ -1,117 +1,154 @@

11Elm.Native.Keyboard = {};

22Elm.Native.Keyboard.make = function(elm) {

33

4− elm.Native = elm.Native || {};

5− elm.Native.Keyboard = elm.Native.Keyboard || {};

6− if (elm.Native.Keyboard.values) return elm.Native.Keyboard.values;

7−

8− // Duplicated from Native.Signal

9− function send(node, timestep, changed) {

10− var kids = node.kids;

11− for (var i = kids.length; i--; ) {

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;

4+ elm.Native = elm.Native || {};

5+ elm.Native.Keyboard = elm.Native.Keyboard || {};

6+ if (elm.Native.Keyboard.values) return elm.Native.Keyboard.values;

7+

8+ // Duplicated from Native.Signal

9+ function send(node, timestep, changed) {

10+ var kids = node.kids;

11+ for (var i = kids.length; i--; ) {

12+ kids[i].recv(timestep, changed, node.id);

6313 }

64− }

65− if (count == n) {

66− send(this, timestep, isChanged);

67− isChanged = false;

68− count = 0;

69− }

70− };

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(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+ });

7135

72− for (var i = n; i--; ) { args[i].kids.push(this); }

73−

74− }

75−

76− var keysDown = Signal.dropRepeats(new KeyMerge(downEvents,upEvents,blurEvents));

77−

78− function keySignal(f) {

79− var signal = A2(Signal.lift, f, keysDown);

80− // must set the default number of kids to make it possible to filter

81− // these signals if they are not actually used.

82− keysDown.defaultNumberOfKids += 1;

83− signal.defaultNumberOfKids = 1;

84− var filtered = Signal.dropRepeats(signal)

85− filtered.defaultNumberOfKids = 0;

86− return filtered;

87− }

88−

89− function dir(up, down, left, right) {

90− function f(ks) {

91− var x = 0, y = 0;

92− while (ks.ctor === "::") {

93− switch (ks._0) {

94− case left : --x; break;

95− case right: ++x; break;

96− case up : ++y; break;

97− case down : --y; break;

36+ function state(alt, meta, keyCodes) {

37+ return {

38+ alt: alt,

39+ meta: meta,

40+ keyCodes: keyCodes

41+ };

42+ }

43+ var emptyState = state(false, false, NList.Nil);

44+

45+ function KeyMerge(down, up, blur) {

46+ var args = [down,up,blur];

47+ this.id = Utils.guid();

48+ // Ignore starting values here

49+ this.value = emptyState;

50+ this.kids = [];

51+

52+ var n = args.length;

53+ var count = 0;

54+ var isChanged = false;

55+

56+ this.recv = function(timestep, changed, parentID) {

57+ ++count;

58+ if (changed) {

59+ // We know this a change must only be one of the following cases

60+ if (parentID === down.id && !A2(NList.member, down.value.keyCode, this.value.keyCodes)) {

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;

9888 }

99− ks = ks._1;

100− }

101− return { _:{}, x:x, y:y };

10289 }

103− return keySignal(f);

104− }

10590

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+ }

107104

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+ }

109133

110− return elm.Native.Keyboard.values = {

111− isDown:is,

112− directions:F4(dir),

113− keysDown:keysDown,

114− lastPressed:lastPressed

115− };

134+ function is(key) {

135+ return keySignal(function(v) {

136+ return A2( NList.member, key, v.keyCodes );

137+ });

138+ }

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+ };

116153

117154};

libraries/Native/Signal/Signal.js+2−1

@@ -128,7 +128,7 @@ Elm.Native.Signal.make = function(elm) {

128128 }

129129

130130 function timestamp(a) {

131− function update() { return Utils.Tuple2(Date.now(), a.value); }

131+ function update() { return Utils.Tuple2(elm.timer.now(), a.value); }

132132 return new LiftN(update, [a]);

133133 }

134134

@@ -199,6 +199,7 @@ Elm.Native.Signal.make = function(elm) {

199199 function merges(ss) { return A2(foldr1, F2(merge), ss); }

200200

201201 return elm.Native.Signal.values = {

202+ input: function(v) { return new Input(v); },

202203 constant : function(v) { return new Input(v); },

203204 lift : F2(lift ),

204205 lift2 : F3(lift2),

libraries/Native/Signal/Time.js+14−9

@@ -12,11 +12,15 @@ Elm.Native.Time.make = function(elm) {

1212

1313 function fpsWhen(desiredFPS, isOn) {

1414 var msPerFrame = 1000 / desiredFPS;

15− var prev = Date.now(), curr = prev, diff = 0, wasOn = true;

16− var ticker = Signal.constant(diff);

17− function tick(zero) { return function() {

18− curr = Date.now();

15+ var prev = elm.timer.now(), curr = prev, diff = 0, wasOn = true;

16+ var ticker = NS.input(diff);

17+ function tick(zero) {

18+ return function() {

19+ curr = elm.timer.now();

1920 diff = zero ? 0 : curr - prev;

21+ if (prev > curr) {

22+ diff = 0;

23+ }

2024 prev = curr;

2125 elm.notify(ticker.id, diff);

2226 };

@@ -24,7 +28,7 @@ Elm.Native.Time.make = function(elm) {

2428 var timeoutID = 0;

2529 function f(isOn, t) {

2630 if (isOn) {

27− timeoutID = setTimeout(tick(!wasOn && isOn), msPerFrame);

31+ timeoutID = elm.setTimeout(tick(!wasOn && isOn), msPerFrame);

2832 } else if (wasOn) {

2933 clearTimeout(timeoutID);

3034 }

@@ -35,10 +39,11 @@ Elm.Native.Time.make = function(elm) {

3539 }

3640

3741 function every(t) {

38− var clock = Signal.constant(Date.now());

39− setInterval(function() {

40− elm.notify(clock.id, Date.now());

41− }, t);

42+ var clock = NS.input(elm.timer.now());

43+ function tellTime() {

44+ elm.notify(clock.id, elm.timer.now());

45+ }

46+ setInterval(tellTime, t);

4247 return clock;

4348 }

4449

libraries/Native/Signal/Touch.js+3−3

@@ -61,11 +61,11 @@ Elm.Native.Touch.make = function(elm) {

6161 dict.insert(e.identifier,

6262 {x: point._0,

6363 y: point._1,

64− t: Date.now()});

64+ t: elm.timer.now()});

6565 }

6666 function end(e) {

6767 var t = dict.remove(e.identifier);

68− if (Date.now() - t.t < tapTime) {

68+ if (elm.timer.now() - t.t < tapTime) {

6969 hasTap = true;

7070 tap = {_:{}, x:t.x, y:t.y};

7171 }

@@ -107,7 +107,7 @@ Elm.Native.Touch.make = function(elm) {

107107 root.value.push(touch(e));

108108 elm.notify(root.id, root.value);

109109 });

110− elm.addListener([root.id], node, "mouseup", function up(e) {

110+ elm.addListener([root.id], document, "mouseup", function up(e) {

111111 node.removeEventListener("mousemove", move);

112112 e.identifier = mouseID;

113113 end(e);

libraries/Native/Signal/WebSocket.js+1−1

@@ -9,7 +9,7 @@ Elm.Native.WebSocket.make = function(elm) {

99 var List = Elm.Native.List.make(elm);

1010

1111 function open(url, outgoing) {

12− var incoming = Signal.constant(List.Nil);

12+ var incoming = Signal.constant("");

1313 var ws = new WebSocket(url);

1414

1515 var pending = [];

libraries/Native/Signal/Window.js+2−1

@@ -6,6 +6,7 @@ Elm.Native.Window.make = function(elm) {

66 if (elm.Native.Window.values) return elm.Native.Window.values;

77

88 var Signal = Elm.Signal.make(elm);

9+ var NS = Elm.Native.Signal.make(elm);

910 var Tuple2 = Elm.Native.Utils.make(elm).Tuple2;

1011

1112 function getWidth() { return elm.node.clientWidth; }

@@ -16,7 +17,7 @@ Elm.Native.Window.make = function(elm) {

1617 return elm.node.clientHeight;

1718 }

1819

19− var dimensions = Signal.constant(Tuple2(getWidth(), getHeight()));

20+ var dimensions = NS.input(Tuple2(getWidth(), getHeight()));

2021 dimensions.defaultNumberOfKids = 2;

2122

2223 // 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) {

123123 var count = 0;

124124 function guid(_) { return count++ }

125125

126− function copy(r) {

127− var o = {};

128− for (var i in r) { o[i] = r[i]; }

129− return o;

126+ function copy(oldRecord) {

127+ var newRecord = {};

128+ for (var key in oldRecord) {

129+ var value = key === '_'

130+ ? copy(oldRecord._)

131+ : oldRecord[key]

132+ ;

133+ newRecord[key] = value;

134+ }

135+ return newRecord;

130136 }

131137

132− function remove(x,r) {

133− var o = copy(r);

134− if (x in o._) {

135− o[x] = o._[x][0];

136− o._[x] = o._[x].slice(1);

137− if (o._[x].length === 0) { delete o._[x]; }

138+ function remove(key, oldRecord) {

139+ var record = copy(oldRecord);

140+ if (key in record._) {

141+ record[key] = record._[key][0];

142+ record._[key] = record._[key].slice(1);

143+ if (record._[key].length === 0) {

144+ delete record._[key];

145+ }

138146 } else {

139− delete o[x];

147+ delete record[key];

140148 }

141− return o;

149+ return record;

142150 }

143151

144− function replace(kvs,r) {

145− var o = copy(r);

146− for (var i = kvs.length; i--; ) {

147− var kvsi = kvs[i];

148− o[kvsi[0]] = kvsi[1];

152+ function replace(keyValuePairs, oldRecord) {

153+ var record = copy(oldRecord);

154+ for (var i = keyValuePairs.length; i--; ) {

155+ var pair = keyValuePairs[i];

156+ record[pair[0]] = pair[1];

149157 }

150− return o;

158+ return record;

151159 }

152160

153− function insert(x,v,r) {

154− var o = copy(r);

155− if (x in o) o._[x] = [o[x]].concat(x in o._ ? o._[x].slice(0) : []);

156− o[x] = v;

157− return o;

161+ function insert(key, value, oldRecord) {

162+ var newRecord = copy(oldRecord);

163+ if (key in newRecord) {

164+ var values = newRecord._[key];

165+ var copiedValues = values ? values.slice(0) : [];

166+ newRecord._[key] = [newRecord[key]].concat(copiedValues);

167+ }

168+ newRecord[key] = value;

169+ return newRecord;

158170 }

159171

160172 function max(a,b) { return a > b ? a : b }

libraries/Set.elm+9−7

@@ -1,11 +1,13 @@

11

2−module Set (empty,singleton,insert,remove

3− ,member

4− ,foldl,foldr,map

5− ,filter,partition

6− ,union,intersect,diff

7− ,toList,fromList

8− ) where

2+module Set

3+ ( Set

4+ , empty, singleton, insert, remove

5+ , member

6+ , foldl, foldr, map

7+ , filter, partition

8+ , union, intersect, diff

9+ , toList, fromList

10+ ) where

911

1012{-| A set of unique values. The values can be any comparable type. This

1113includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or lists

libraries/Signal.elm+1−1

@@ -30,7 +30,7 @@ the `Time` library.

3030-}

3131

3232import Native.Signal

33−import List (foldr)

33+import List (foldr, (::))

3434import Basics (fst, snd, not)

3535

3636data Signal a = Signal

libraries/String.elm+8−6

@@ -71,6 +71,7 @@ concat = Native.String.concat

7171{-| Get the length of a string.

7272

7373 length "innumerable" == 11

74+ length "" == 0

7475

7576-}

7677length : String -> Int

@@ -123,6 +124,7 @@ split = Native.String.split

123124

124125{-| Put many strings together with a given separator.

125126

127+ join "a" ["H","w","ii","n"] == "Hawaiian"

126128 join " " ["cat","dog","cow"] == "cat dog cow"

127129 join "/" ["home","evan","Desktop"] == "home/evan/Desktop"

128130-}

@@ -204,7 +206,7 @@ trim = Native.String.trim

204206trimLeft : String -> String

205207trimLeft = Native.String.trimLeft

206208

207−{-| Get rid of whitespace on the left of a string.

209+{-| Get rid of whitespace on the right of a string.

208210

209211 trimRight " hats \n" == " hats"

210212-}

@@ -220,7 +222,7 @@ words = Native.String.words

220222

221223{-| Break a string into lines, splitting on newlines.

222224

223− lines "How are you?\nGood? == ["How are you?", "Good?"]

225+ lines "How are you?\nGood?" == ["How are you?", "Good?"]

224226-}

225227lines : String -> [String]

226228lines = Native.String.lines

@@ -253,7 +255,7 @@ any = Native.String.any

253255all : (Char -> Bool) -> String -> Bool

254256all = Native.String.all

255257

256−{-| See if a string contains another one.

258+{-| See if the second string contains the first one.

257259

258260 contains "the" "theory" == True

259261 contains "hat" "theory" == False

@@ -264,7 +266,7 @@ Use `Regex.contains` if you need something more flexible.

264266contains : String -> String -> Bool

265267contains = Native.String.contains

266268

267−{-| See if a string starts with another one.

269+{-| See if the second string starts with the first one.

268270

269271 startsWith "the" "theory" == True

270272 startsWith "ory" "theory" == False

@@ -272,7 +274,7 @@ contains = Native.String.contains

272274startsWith : String -> String -> Bool

273275startsWith = Native.String.startsWith

274276

275−{-| See if a string ends with another one.

277+{-| See if the second string ends with the first one.

276278

277279 endsWith "the" "theory" == False

278280 endsWith "ory" "theory" == True

@@ -280,7 +282,7 @@ startsWith = Native.String.startsWith

280282endsWith : String -> String -> Bool

281283endsWith = Native.String.endsWith

282284

283−{-| Get all of the indexes for a substring.

285+{-| Get all of the indexes for a substring in another string.

284286

285287 indexes "i" "Mississippi" == [1,4,7,10]

286288 indexes "ss" "Mississippi" == [2,5]

libraries/Text.elm+2−2

@@ -34,7 +34,7 @@ import Basics (..)

3434import String

3535import Color (Color, black)

3636import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)

37−import Maybe (Maybe, Nothing)

37+import Maybe (Maybe(Nothing))

3838import Native.Show

3939import Native.Text

4040

@@ -212,7 +212,7 @@ markdown = Native.Text.markdown

212212{-| Convert anything to its textual representation and make it displayable in

213213the browser:

214214

215− asText value = text (monospace (show value))

215+ asText value = leftAligned (monospace (toText (show value)))

216216

217217Excellent for debugging.

218218-}

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

26{-| A library for performing [2D matrix transformations][affine].

37It is used primarily with the `groupTransform` function from `Graphics.Collage` and

48allows 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.

88-}

99

1010import Signal (Signal)

11−import Basics (String)

1211import Native.WebSocket

1312

1413{-| 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"

22, "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."

44, "license": "BSD3"

55, "repository": "http://github.com/elm-lang/Elm.git"

6−, "elm-version": "0.12.2"

6+, "elm-version": "0.13"

77, "dependencies": {}

88, "exposed-modules":

99 [ "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) {

3131 // defining state needed for an instance of the Elm RTS

3232 var inputs = [];

3333

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+

3457 var updateInProgress = false;

3558 function notify(id, v) {

3659 if (updateInProgress) {

3760 throw new Error(

3861 'The notify function has been called synchronously!\n' +

3962 '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');

4164 }

4265 updateInProgress = true;

43− var timestep = Date.now();

66+ var timestep = timer.now();

4467 for (var i = inputs.length; i--; ) {

4568 inputs[i].recv(timestep, id, v);

4669 }

4770 updateInProgress = false;

4871 }

72+ function setTimeout(func, delay) {

73+ window.setTimeout(func, delay);

74+ }

4975

5076 var listeners = [];

5177 function addListener(relevantInputs, domNode, eventName, func) {

@@ -67,11 +93,13 @@ function init(display, container, module, ports, moduleToReplace) {

6793 // object. This permits many Elm programs to be embedded per document.

6894 var elm = {

6995 notify:notify,

96+ setTimeout:setTimeout,

7097 node:container,

7198 display:display,

7299 id:ElmRuntime.guid(),

73100 addListener:addListener,

74101 inputs:inputs,

102+ timer:timer,

75103 ports: { incoming:ports, outgoing:{}, uses:portUses }

76104 };

77105

@@ -84,6 +112,11 @@ function init(display, container, module, ports, moduleToReplace) {

84112 return newElm;

85113 }

86114

115+ function dispose() {

116+ removeListeners(listeners);

117+ inputs = [];

118+ }

119+

87120 var Module = {};

88121 var reportAnyErrors = function() {};

89122 try {

@@ -110,7 +143,11 @@ function init(display, container, module, ports, moduleToReplace) {

110143 }

111144

112145 reportAnyErrors();

113− return { swap:swap, ports:elm.ports.outgoing };

146+ return {

147+ swap:swap,

148+ ports:elm.ports.outgoing,

149+ dispose:dispose

150+ };

114151};

115152

116153function checkPorts(elm) {

@@ -203,8 +240,9 @@ function addReceivers(ports) {

203240}

204241

205242function initGraphics(elm, Module) {

206− if (!('main' in Module))

243+ if (!('main' in Module)) {

207244 throw new Error("'main' is missing! What do I display?!");

245+ }

208246

209247 var signalGraph = Module.main;

210248

@@ -221,8 +259,9 @@ function initGraphics(elm, Module) {

221259

222260 // set up updates so that the DOM is adjusted as necessary.

223261 var savedScene = currentScene;

262+ var previousDrawId = 0;

224263 function domUpdate(newScene) {

225− ElmRuntime.draw(function(_) {

264+ previousDrawId = ElmRuntime.draw(previousDrawId, function(_) {

226265 Render.update(elm.node.firstChild, savedScene, newScene);

227266 if (elm.Native.Window) elm.Native.Window.values.resizeIfNeeded();

228267 savedScene = newScene;

runtime/Render/Collage.js+2−2

@@ -21,7 +21,7 @@ function trace(ctx, path) {

2121}

2222

2323function 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);

2525 ctx.scale(1,-1);

2626 ctx.stroke();

2727}

@@ -301,7 +301,7 @@ function nodeStepper(w,h,div) {

301301 : (Render.update(kid, kid.oldElement, elem), kids[i]);

302302

303303 node.style.position = 'absolute';

304− node.style.opacity = alpha * form.alpha;

304+ node.style.opacity = alpha * form.alpha * elem.props.opacity;

305305 addTransform(node.style, makeTransform(w, h, form, matrices));

306306 node.oldElement = elem;

307307 ++i;

runtime/Render/Element.js+125−73

@@ -3,44 +3,52 @@ ElmRuntime.Render.Element = function() {

33'use strict';

44

55var Utils = ElmRuntime.use(ElmRuntime.Render.Utils);

6−var newElement = Utils.newElement, colorToCss = Utils.colorToCss,

7− addTransform = Utils.addTransform, removeTransform = Utils.removeTransform,

8− fromList = Utils.fromList, eq = Utils.eq;

6+var newElement = Utils.newElement;

7+var colorToCss = Utils.colorToCss;

8+var addTransform = Utils.addTransform;

9+var removeTransform = Utils.removeTransform;

10+var fromList = Utils.fromList;

11+var eq = Utils.eq;

912

10−function setProps(elem, e) {

13+function setProps(elem, node) {

1114 var props = elem.props;

15+

1216 var element = elem.element;

1317 var width = props.width - (element.adjustWidth || 0);

1418 var height = props.height - (element.adjustHeight || 0);

15− e.style.width = (width |0) + 'px';

16− e.style.height = (height|0) + 'px';

19+ node.style.width = (width |0) + 'px';

20+ node.style.height = (height|0) + 'px';

21+

1722 if (props.opacity !== 1) {

18− e.style.opacity = props.opacity;

23+ node.style.opacity = props.opacity;

1924 }

25+

2026 if (props.color.ctor === 'Just') {

21− e.style.backgroundColor = colorToCss(props.color._0);

27+ node.style.backgroundColor = colorToCss(props.color._0);

2228 }

23− if (props.tag !== '') { e.id = props.tag; }

24− if (props.href !== '') {

25− var a = newElement('a');

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);

29+

30+ if (props.tag !== '') {

31+ node.id = props.tag;

3632 }

33+

3734 if (props.hover.ctor !== '_Tuple0') {

38− addHover(e, props.hover);

35+ addHover(node, props.hover);

3936 }

37+

4038 if (props.click.ctor !== '_Tuple0') {

41− addClick(e, props.click);

39+ addClick(node, props.click);

4240 }

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;

4452}

4553

4654function addClick(e, handler) {

@@ -57,6 +65,8 @@ function addClick(e, handler) {

5765function removeClick(e, handler) {

5866 if (e.elm_click_trigger) {

5967 e.removeEventListener('click', e.elm_click_trigger);

68+ e.elm_click_trigger = null;

69+ e.elm_click_handler = null;

6070 }

6171}

6272

@@ -83,11 +93,14 @@ function addHover(e, handler) {

8393}

8494

8595function removeHover(e) {

96+ e.elm_hover_handler = null;

8697 if (e.elm_hover_over) {

8798 e.removeEventListener('mouseover', e.elm_hover_over);

99+ e.elm_hover_over = null;

88100 }

89101 if (e.elm_hover_out) {

90102 e.removeEventListener('mouseout', e.elm_hover_out);

103+ e.elm_hover_out = null;

91104 }

92105}

93106

@@ -248,7 +261,9 @@ function rawHtml(elem) {

248261 return div;

249262}

250263

251−function render(elem) { return setProps(elem, makeElement(elem)); }

264+function render(elem) {

265+ return setProps(elem, makeElement(elem));

266+}

252267function makeElement(e) {

253268 var elem = e.element;

254269 switch(elem.ctor) {

@@ -262,8 +277,12 @@ function makeElement(e) {

262277}

263278

264279function update(node, curr, next) {

265− if (node.tagName === 'A') { node = node.firstChild; }

266− if (curr.props.id === next.props.id) return updateProps(node, curr, next);

280+ if (node.tagName === 'A') {

281+ node = node.firstChild;

282+ }

283+ if (curr.props.id === next.props.id) {

284+ return updateProps(node, curr, next);

285+ }

267286 if (curr.element.ctor !== next.element.ctor) {

268287 node.parentNode.replaceChild(render(next),node);

269288 return true;

@@ -354,61 +373,94 @@ function update(node, curr, next) {

354373}

355374

356375function updateProps(node, curr, next) {

357− var props = next.props;

358− var currP = curr.props;

359− var e = node;

376+ var nextProps = next.props;

377+ var currProps = curr.props;

378+

360379 var element = next.element;

361− var width = props.width - (element.adjustWidth || 0);

362− var height = props.height - (element.adjustHeight || 0);

363− if (width !== currP.width) {

364− e.style.width = (width|0) + 'px';

365− }

366− if (height !== currP.height) {

367− e.style.height = (height|0) + 'px';

368− }

369− if (props.opacity !== currP.opacity) {

370− e.style.opacity = props.opacity;

371− }

372− var nextColor = (props.color.ctor === 'Just' ?

373− colorToCss(props.color._0) : '');

374− if (e.style.backgroundColor !== nextColor) {

375− e.style.backgroundColor = (nextColor === '' ? 'transparent' : nextColor);

376− }

377− if (props.tag !== currP.tag) { e.id = props.tag; }

378− if (props.href !== currP.href) {

379− if (currP.href === '') {

380− var a = newElement('a');

381− a.href = props.href;

382− a.style.width = '100%';

383− a.style.height = '100%';

384− a.style.top = 0;

385− a.style.left = 0;

386− a.style.display = 'block';

387− a.style.position = 'absolute';

388− e.style.position = 'relative';

389− a.style.pointerEvents = 'auto';

390− e.appendChild(a);

380+ var width = nextProps.width - (element.adjustWidth || 0);

381+ var height = nextProps.height - (element.adjustHeight || 0);

382+ if (width !== currProps.width) {

383+ node.style.width = (width|0) + 'px';

384+ }

385+ if (height !== currProps.height) {

386+ node.style.height = (height|0) + 'px';

387+ }

388+

389+ if (nextProps.opacity !== currProps.opacity) {

390+ node.style.opacity = nextProps.opacity;

391+ }

392+

393+ var nextColor = nextProps.color.ctor === 'Just'

394+ ? colorToCss(nextProps.color._0)

395+ : 'transparent';

396+ if (node.style.backgroundColor !== nextColor) {

397+ node.style.backgroundColor = nextColor;

398+ }

399+

400+ if (nextProps.tag !== currProps.tag) {

401+ node.id = nextProps.tag;

402+ }

403+

404+ if (nextProps.href !== currProps.href) {

405+ if (currProps.href === '') {

406+ // add a surrounding href

407+ var anchor = newElement('a');

408+ anchor.href = nextProps.href;

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);

391418 } else {

392− node.lastNode.href = props.href;

419+ // just update the link

420+ node.parentNode.href = nextProps.href;

393421 }

394422 }

395423

424+ // update click and hover handlers

425+ var removed = false;

426+

396427 // update hover handlers

397− if (props.hover.ctor === '_Tuple0') {

398− removeHover(e);

399− } else if (e.elm_hover_handler) {

400− e.elm_hover_handler = props.hover;

401− } else {

402− addHover(e, props.hover);

428+ if (currProps.hover.ctor === '_Tuple0') {

429+ if (nextProps.hover.ctor !== '_Tuple0') {

430+ addHover(node, nextProps.hover);

431+ }

432+ }

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+ }

403441 }

404442

405443 // update click handlers

406− if (props.click.ctor === '_Tuple0') {

407− removeClick(e);

408− } else if (e.elm_click_handler) {

409− e.elm_click_handler = props.click;

410− } else {

411− addClick(e, props.click);

444+ if (currProps.click.ctor === '_Tuple0') {

445+ if (nextProps.click.ctor !== '_Tuple0') {

446+ addClick(node, nextProps.click);

447+ }

448+ }

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';

412464 }

413465}

414466

runtime/Utils.js+14−6

@@ -32,7 +32,13 @@ ElmRuntime.filterDeadInputs = function(inputs) {

3232 return temp;

3333};

3434

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+//

3642var vendors = ['ms', 'moz', 'webkit', 'o'];

3743var win = typeof window !== 'undefined' ? window : {};

3844for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {

@@ -42,13 +48,15 @@ for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {

4248}

4349

4450if (win.requestAnimationFrame && win.cancelAnimationFrame) {

45− var previous = 0;

46− ElmRuntime.draw = function(callback) {

47− win.cancelAnimationFrame(previous);

48− previous = win.requestAnimationFrame(callback);

51+ ElmRuntime.draw = function(previousRequestID, callback) {

52+ win.cancelAnimationFrame(previousRequestID);

53+ return win.requestAnimationFrame(callback);

4954 };

5055} else {

51− ElmRuntime.draw = function(callback) { callback(); };

56+ ElmRuntime.draw = function(previousRequestID, callback) {

57+ callback();

58+ return previousRequestID;

59+ };

5260}

5361

5462}());

tests/compiler/Tests/Compiler.hs+57−40

@@ -1,45 +1,62 @@

1−module Tests.Compiler (compilerTests)

2− where

1+{-# OPTIONS_GHC -W #-}

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)

310

4−import Data.Functor ((<$>))

5−import Data.Traversable (traverse)

6−import System.FilePath ((</>))

7−import System.FilePath.Find (find, (==?), extension)

811import Test.Framework

912import Test.Framework.Providers.HUnit (testCase)

10−import Test.HUnit (Assertion, assertFailure, assertBool)

11−import Text.Parsec (ParseError)

12−

13−import Elm.Internal.Utils as Elm

13+import Test.HUnit (Assertion, assertFailure, assertBool)

1414

1515compilerTests :: Test

16−compilerTests = buildTest $ do

17− goods <- mkTests goodCompile =<< getElms "good"

18− bads <- mkTests badCompile =<< getElms "bad"

19− return $ testGroup "Compile Tests"

20− [

21− testGroup "Good Tests" goods

22− , testGroup "Bad Tests" bads

23− ]

24−

25− where getElms :: FilePath -> IO [FilePath]

26− getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)

27−

28− mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]

29− mkTests h = traverse setupTest

30− where setupTest f = testCase f . mkCompileTest h <$> readFile f

31−

32− testsDir = "tests" </> "test-files"

33−

34−goodCompile :: Either String String -> Assertion

35−goodCompile (Left err) = assertFailure err

36−goodCompile (Right _) = assertBool "" True

37−

38−badCompile :: Either String String -> Assertion

39−badCompile (Left _) = assertBool "" True

40−badCompile (Right _) = assertFailure "Compilation succeeded but should have failed"

41−

42−mkCompileTest :: ((Either String String) -> Assertion) -- ^ Handler

43− -> String -- ^ File Contents

44− -> Assertion

45−mkCompileTest handle = handle . Elm.compile

16+compilerTests =

17+ buildTest $ do

18+ goods <- testIf isSuccess =<< getElms "good"

19+ bads <- testIf isFailure =<< getElms "bad"

20+ return $ testGroup "Compile Tests"

21+ [ testGroup "Good Tests" goods

22+ , testGroup "Bad Tests" bads

23+ ]

24+

25+-- COLLECT FILES

26+

27+getElms :: FilePath -> IO [FilePath]

28+getElms filePath =

29+ find (return True) (extension ==? ".elm") (testsDir </> filePath)

30+

31+testsDir :: FilePath

32+testsDir = "tests" </> "compiler" </> "test-files"

33+

34+

35+-- RUN COMPILER

36+

37+testIf :: (ExitCode -> String -> Assertion) -> [FilePath] -> IO [Test]

38+testIf handler filePaths =

39+ traverse setupTest filePaths

40+ where

41+ setupTest filePath = do

42+ let args = [ "--make", "--src-dir=" ++ testsDir, filePath ]

43+ (exitCode, stdout, stderr) <- readProcessWithExitCode compiler args ""

44+ return (testCase filePath (handler exitCode (stdout ++ stderr)))

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

99import Text.Parsec.Combinator (eof)

1010import Text.PrettyPrint as P

1111

12−import SourceSyntax.Literal as Lit

13−import qualified SourceSyntax.Pattern as P

14−import SourceSyntax.PrettyPrint (Pretty, pretty)

15−import Parse.Helpers (IParser, iParse)

16−import Parse.Literal (literal)

12+import AST.Literal as Lit

13+import qualified AST.Pattern as P

14+import qualified AST.Variable as V

15+import AST.PrettyPrint (Pretty, pretty)

16+import Parse.Helpers (IParser, iParse)

17+import Parse.Literal (literal)

1718import qualified Parse.Pattern as Pat (expr)

1819import qualified Parse.Type as Type (expr)

1920import Tests.Property.Arbitrary

@@ -21,8 +22,7 @@ import Tests.Property.Arbitrary

2122propertyTests :: Test

2223propertyTests =

2324 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)

2626 , testProperty "Literal test" $ prop_parse_print literal

2727 , testProperty "Pattern test" $ prop_parse_print Pat.expr

2828 , testProperty "Type test" $ prop_parse_print Type.expr

@@ -31,21 +31,22 @@ propertyTests =

3131 where

3232 -- This test was autogenerated from the Pattern test and should be

3333 -- left in all its ugly glory.

34− longPat = P.Data "I" [ P.Literal (Lit.Chr '+')

35− , P.Record

36− [ "q7yclkcm7k_ikstrczv_"

37− , "wQRv6gKsvvkjw4b5F"

38− ,"c9'eFfhk9FTvsMnwF_D"

39− ,"yqxhEkHvRFwZ"

40− ,"o"

41− ,"nbUlCn3y3NnkVoxhW"

42− ,"iJ0MNy3KZ_lrs"

43− ,"ug"

44− ,"sHHsX"

45− ,"mRKs9d"

46− ,"o2KiCX5'ZRzHJfRi8" ]

47− , P.Var "su'BrrbPUK6I33Eq"

48− ]

34+ longPat = P.Data (V.Raw "I")

35+ [ P.Literal (Lit.Chr '+')

36+ , P.Record

37+ [ "q7yclkcm7k_ikstrczv_"

38+ , "wQRv6gKsvvkjw4b5F"

39+ ,"c9'eFfhk9FTvsMnwF_D"

40+ ,"yqxhEkHvRFwZ"

41+ ,"o"

42+ ,"nbUlCn3y3NnkVoxhW"

43+ ,"iJ0MNy3KZ_lrs"

44+ ,"ug"

45+ ,"sHHsX"

46+ ,"mRKs9d"

47+ ,"o2KiCX5'ZRzHJfRi8" ]

48+ , P.Var "su'BrrbPUK6I33Eq"

49+ ]

4950

5051prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool

5152prop_parse_print p x =

tests/compiler/Tests/Property/Arbitrary.hs+21−12

@@ -8,9 +8,14 @@ import Test.QuickCheck.Gen

88import qualified Data.Set as Set

99import qualified Parse.Helpers (reserveds)

1010

11−import qualified SourceSyntax.Literal as L

12−import qualified SourceSyntax.Pattern as P

13−import qualified SourceSyntax.Type as T

11+import qualified AST.Literal as L

12+import qualified AST.Pattern as P

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

1419

1520instance Arbitrary L.Literal where

1621 arbitrary =

@@ -41,10 +46,10 @@ genVector n generator = do

4146 let m = n `div` (len + 1)

4247 vectorOf len $ generator m

4348

44−instance Arbitrary P.Pattern where

49+instance Arbitrary v => Arbitrary (P.Pattern v) where

4550 arbitrary = sized pat

4651 where

47− pat :: Int -> Gen P.Pattern

52+ pat :: (Arbitrary v) => Int -> Gen (P.Pattern v)

4853 pat n =

4954 oneof

5055 [ pure P.Anything

@@ -52,7 +57,7 @@ instance Arbitrary P.Pattern where

5257 , P.Record <$> (listOf1 lowVar)

5358 , P.Literal <$> arbitrary

5459 , P.Alias <$> lowVar <*> pat (n-1)

55− , P.Data <$> capVar <*> genVector n pat

60+ , P.Data <$> arbitrary <*> genVector n pat

5661 ]

5762

5863 shrink pat =

@@ -61,7 +66,7 @@ instance Arbitrary P.Pattern where

6166 P.Var v -> P.Var <$> shrinkWHead v

6267 P.Literal l -> P.Literal <$> shrink l

6368 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)

6570 P.Record fs ->

6671 P.Record <$> filter (all notNull) (filter notNull (shrink fs))

6772 where

@@ -71,29 +76,33 @@ shrinkWHead :: Arbitrary a => [a] -> [[a]]

7176shrinkWHead [] = error "Should be nonempty"

7277shrinkWHead (x:xs) = (x:) <$> shrink xs

7378

74−instance Arbitrary T.Type where

79+instance Arbitrary v => Arbitrary (T.Type v) where

7580 arbitrary = sized tipe

7681 where

77− tipe :: Int -> Gen T.Type

82+ tipe :: Arbitrary v => Int -> Gen (T.Type v)

7883 tipe n =

7984 let depthTipe = tipe =<< choose (0,n)

8085 field = (,) <$> lowVar <*> depthTipe

8186 fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)

8287 fields1 = (:) <$> field <*> fields

88+ depthTipes = (:) <$> depthTipe <*> genVector n tipe

8389 in

8490 oneof

8591 [ T.Lambda <$> depthTipe <*> depthTipe

8692 , T.Var <$> lowVar

87− , T.Data <$> capVar <*> genVector n tipe

93+ , T.Type <$> arbitrary

94+ , T.App <$> (T.Type <$> arbitrary) <*> depthTipes

8895 , T.Record <$> fields <*> pure Nothing

89− , T.Record <$> fields1 <*> (Just <$> lowVar)

96+ , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar)

9097 ]

9198

9299 shrink tipe =

93100 case tipe of

94101 T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)

95102 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)

97106 T.Record fs t -> map snd fs ++ record

98107 where

99108 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

1919 unless ("jsdom" `isInfixOf` out) $ runCmd "npm" ["install","jsdom"]

2020

2121 -- setup actual library tests

22− setCurrentDirectory $ top </> "tests" </> "libraries"

23− let localCompiler = joinPath [ top, "dist", "build", "elm", "elm" ]

22+ let localCompiler = joinPath [ "dist", "build", "elm", "elm" ]

2423 runCmd localCompiler [ "--make"

2524 , "--only-js"

26− , "--src-dir=" ++ top </> "automaton"

27− , "--src-dir=" ++ top </> "IO"

28− , "--src-dir=" ++ top </> "Elm-Test"

29− , "Test.elm"

25+ , "--src-dir=IO"

26+ , "--src-dir=Elm-Test"

27+ , "--src-dir=" ++ "tests" </> "libraries"

28+ , testFile <.> "elm"

3029 ]

3130

3231 -- run tests

33− let ioScript s = top </> "IO" </> s

34− files = [ ioScript "prescript.js"

32+ let files = [ "IO" </> "share" </> "prescript.js"

3533 , Elm.runtime

36− , "build" </> "Test.js"

37− , ioScript "handler.js"

34+ , "build" </> testFile <.> "js"

35+ , "IO" </> "share" </> "handler.js"

3836 ]

37+ testRunner = "build" </> "TestRunner.js"

3938 exe <- readProcess "cat" files ""

40− writeFile "exe.js" exe

41− exitWith =<< waitForProcess =<< (runCommand "node exe.js")

39+ writeFile testRunner exe

40+ exitCode <- rawSystem "node" [testRunner]

41+ removeDirectoryRecursive "cache"

42+ removeDirectoryRecursive "build"

43+ exitWith exitCode

44+ where

45+ testFile = "tests" </> "libraries" </> "Test"

4246

4347runCmd :: String -> [String] -> IO ()

4448runCmd cmd args = do

4549 putStrLn (cmd ++ " " ++ unwords args)

46− (exitCode, _stdout, stderr) <- readProcessWithExitCode cmd args ""

50+ (exitCode, stdout, stderr) <- readProcessWithExitCode cmd args ""

51+ putStr stdout

52+ putStr stderr

4753 case exitCode of

4854 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

44import ElmTest.Run as R

55import ElmTest.Runner.Console (runDisplay)

66import ElmTest.Test (..)

7−

87import IO.IO (..)

98import IO.Runner (Request, Response)

109import IO.Runner as Run

1110

1211import Test.Array as Array

12+import Test.Basics as Basics

13+import Test.Char as Char

14+import Test.CodeGen as CodeGen

1315import Test.Dict as Dict

1416import Test.Equality as Equality

1517import Test.List as List

@@ -20,6 +22,9 @@ import Test.Trampoline as Trampoline

2022tests : Test

2123tests = suite "Elm Standard Library Tests"

2224 [ Array.tests

25+ , Basics.tests

26+ , Char.tests

27+ , CodeGen.tests

2328 , Dict.tests

2429 , Equality.tests

2530 , List.tests

@@ -31,10 +36,7 @@ tests = suite "Elm Standard Library Tests"

3136console : IO ()

3237console = runDisplay tests

3338

34−port requests : Signal [{ mPut : Maybe String

35− , mExit : Maybe Int

36− , mGet : Bool

37− }]

39+port requests : Signal Request

3840port requests = Run.run responses console

3941

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

77import ElmTest.Assertion (..)

88import ElmTest.Test (..)

99

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+

1019tests : Test

1120tests =

1221 let creationTests = suite "Creation"

1322 [ 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])

1524 , test "initialize 2" <| assertEqual (Array.initialize 4 (\n -> n*n)) (Array.fromList [0,1,4,9])

1625 , 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

1827 , test "initialize 4" <| assertEqual (Array.initialize 2 (always 0)) (Array.fromList [0,0])

1928 , test "repeat" <| assertEqual (Array.repeat 5 40) (Array.fromList [40,40,40,40,40])

2029 , test "repeat 2" <| assertEqual (Array.repeat 5 0) (Array.fromList [0,0,0,0,0])

@@ -26,6 +35,9 @@ tests =

2635 , test "length - Long" <| assertEqual 10000 (Array.length (Array.repeat 10000 0))

2736 , test "push" <| assertEqual (Array.fromList [1,2,3]) (Array.push 3 (Array.fromList [1,2]))

2837 , 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)

2941 ]

3042 getAndSetTests = suite "Get and Set"

3143 [ test "get" <| assertEqual (Just 2) (Array.get 1 (Array.fromList [3,2,1]))

@@ -43,15 +55,18 @@ tests =

4355 , test "slice 2" <| assertEqual (Array.fromList [1,2,3]) (Array.slice 1 4 (Array.fromList [0,1,2,3,4]))

4456 , test "slice 3" <| assertEqual (Array.fromList [1,2,3]) (Array.slice 1 -1 (Array.fromList [0,1,2,3,4]))

4557 , 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])

4659 ]

4760 mappingAndFoldingTests = suite "Mapping and Folding"

4861 [ test "map" <| assertEqual (Array.fromList [1,2,3]) (Array.map sqrt (Array.fromList [1,4,9]))

4962 , test "indexedMap 1" <| assertEqual (Array.fromList [0,5,10]) (Array.indexedMap (*) (Array.fromList [5,5,5]))

5063 , 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))

5266 , test "foldr 1" <| assertEqual 15 (Array.foldr (+) 0 (Array.repeat 3 5))

5367 , 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]))

5570 ]

5671 nativeTests = suite "Conversion to JS Arrays"

5772 [ 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") ]

1111

1212tests : Test

1313tests =

14− let getTests =

15− [ test "get 1" <| assertEqual (Just "cat") (Dict.get "Tom" animals)

14+ let buildTests = suite "build Tests"

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)

1628 , test "get 2" <| assertEqual Nothing (Dict.get "Spike" animals)

1729 , test "getOrElse 1" <| assertEqual "mouse" (Dict.getOrElse "dog" "Jerry" animals)

1830 , test "getOrElse 2" <| assertEqual "dog" (Dict.getOrElse "dog" "Spike" animals)

1931 , test "getOrFail" <| assertEqual "cat" (Dict.getOrFail "Tom" animals)

2032 ]

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"

2240 [ test "filter" <| assertEqual (Dict.singleton "Tom" "cat") (Dict.filter (\k v -> k == "Tom") animals)

2341 , test "partition" <| assertEqual (Dict.singleton "Tom" "cat", Dict.singleton "Jerry" "mouse") (Dict.partition (\k v -> k == "Tom") animals)

2442 ]

2543 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

33import ElmTest.Assertion (..)

44import ElmTest.Test (..)

55

6−data Different = A String

7− | B [Int]

6+data Different

7+ = A String

8+ | B [Int]

89

910tests : Test

1011tests =

1112 let diffTests = suite "ADT equality"

1213 [ test "As eq" <| assert (A "a" == A "a")

1314 , 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 . not <| (B [1] == A "a")

15+ , test "A left neq" <| assert (A "a" /= B [1])

16+ , test "A left neq" <| assert (B [1] /= A "a")

1617 ]

1718 recordTests = suite "Record equality"

1819 [ test "empty same" <| assert ({} == {})

19− , test "ctor same" <| assert ({ctor = Just 3} == {ctor = Just 3})

20− , test "ctor diff" . assert . not <| ({ctor = Just 3} == {ctor = Nothing})

20+ , test "ctor same" <| assert ({ctor = Just 3} == {ctor = Just 3})

21+ , test "ctor diff" <| assert ({ctor = Just 3} /= {ctor = Nothing})

2122 ]

2223 in

2324 suite "Equality Tests" [diffTests, recordTests]

tests/libraries/Test/List.elm+81−29

@@ -1,38 +1,90 @@

11module Test.List (tests) where

22

33import List

4+import String

45

56import ElmTest.Assertion (..)

67import ElmTest.Test (..)

78

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+

826tests : Test

9−tests =

10− let partitionTests =

11− let p1 = id

12− p2 x = x < 3

13− isEven n = n `mod` 2 == 0

14− in suite "partition Tests" [ test "simple partition" <| assertEqual ([True],[False]) (List.partition p1 [False, True]),

15− test "order check" <| assertEqual ([2,1], [5,6]) (List.partition p2 [2,5,6,1]),

16− test "partition doc check 1" <| assertEqual ([0,1,2], [3,4,5]) (partition p2 [0..5]),

17− test "partition doc check 2" <| assertEqual ([0,2,4], [1,3,5]) (partition isEven [0..5]),

18− let n = 100000

19− ts = repeat n True

20− fs = repeat n False

21− in test "partition stress test" <| assertEqual (ts, fs) (partition p1 (fs++ts))

22− ]

23− unzipTests = suite "unzip Tests" [

24− test "unzip doc check" <| assertEqual ([0,17,1337],[True,False,True]) (unzip [(0, True), (17, False), (1337, True)]),

25− let n = 100000

26− ts = repeat n True

27− fs = repeat n False

28− in test "unzip stress test" <| assertEqual (ts, fs) (unzip (zip ts fs))

29− ]

30− intersperseTests = suite "intersperse Tests" [

31− test "intersperse doc check" <| assertEqual ["turtles","on","turtles","on","turtles"] (intersperse "on" ["turtles","turtles","turtles"]),

32− let n = 100000

33− ts = repeat n True

34− fs = repeat n False

35− in test "intersperse stress test" <| assertEqual (tail . List.concat <| zipWith (\x y -> [x,y]) fs ts)

36− (intersperse False ts)

27+tests =

28+ let partitionTests = suite "partition Tests"

29+ [ test "simple partition" <| assertEqual ([True],[False]) (List.partition identity [False, True])

30+ , test "order check" <| assertEqual ([2,1], [5,6]) (List.partition lessThanThree [2,5,6,1])

31+ , test "partition doc check 1" <| assertEqual ([0,1,2], [3,4,5]) (partition lessThanThree [0..5])

32+ , test "partition doc check 2" <| assertEqual ([0,2,4], [1,3,5]) (partition isEven [0..5])

33+ , test "partition stress test" <| assertEqual (trueList, falseList) (partition identity (falseList ++ trueList))

34+ ]

35+ unzipTests = suite "unzip Tests"

36+ [ test "unzip doc check" <| assertEqual ([0,17,1337],[True,False,True]) (unzip [(0, True), (17, False), (1337, True)])

37+ , test "unzip stress test" <| assertEqual (trueList, falseList) (unzip (zip trueList falseList))

38+ ]

39+ concatTests = suite "concat Tests"

40+ [ test "concat doc check 1" <| assertEqual [1,2,3,4,5] (concat [[1,2],[3],[4,5]])

41+ , test "concat doc check 2" <| assertEqual "treehouse" (concat ["tree","house"])

42+ ]

43+ joinTests = suite "join Tests"

44+ [ test "join doc check" <| assertEqual "Hawaiian" (join "a" ["H","w","ii","n"])

45+ , test "join list check" <| assertEqual [1,0,2,0,3] (join [0] [[1],[2],[3]])

46+ ]

47+ intersperseTests = suite "intersperse Tests"

48+ [ 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)

50+ ]

51+ zipTests = suite "zip Tests"

52+ [ test "zip doc check 1" <| assertEqual [(1,6),(2,7)] (zip [1,2,3] [6,7])

53+ , test "zip doc check 2" <| assertEqual (zipWith (,) [1,2,3] [6,7]) (zip [1,2,3] [6,7])

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

3790 ]

38− in suite "List Tests" [partitionTests, unzipTests, intersperseTests]

tests/libraries/Test/String.elm+20−20

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

11module Test.String (tests) where

22

33import List

4−import String (..)

4+import String

55

66import ElmTest.Assertion (..)

77import ElmTest.Test (..)

@@ -9,29 +9,29 @@ import ElmTest.Test (..)

99tests : Test

1010tests =

1111 let simpleTests = suite "Simple Stuff"

12− [ test "is empty" <| assert (isEmpty "")

13− , test "is not empty" <| assert (not (isEmpty ("the world")))

14− , test "length" <| assertEqual 11 (length "innumerable")

15− , test "endsWith" (assert <| endsWith "ship" "spaceship")

16− , test "reverse" <| assertEqual "desserts" (reverse "stressed")

17− , test "repeat" <| assertEqual "hahaha" (repeat 3 "ha")

12+ [ test "is empty" <| assert (String.isEmpty "")

13+ , test "is not empty" <| assert (not (String.isEmpty ("the world")))

14+ , test "length" <| assertEqual 11 (String.length "innumerable")

15+ , test "endsWith" (assert <| String.endsWith "ship" "spaceship")

16+ , test "reverse" <| assertEqual "desserts" (String.reverse "stressed")

17+ , test "repeat" <| assertEqual "hahaha" (String.repeat 3 "ha")

1818 ]

1919

2020 combiningTests = suite "Combining Strings"

21− [ test "uncons non-empty" <| assertEqual (Just ('a',"bc")) (uncons "abc")

22− , test "uncons empty" <| assertEqual Nothing (uncons "")

23− , test "append 1" <| assertEqual "butterfly" (append "butter" "fly")

24− , test "append 2" <| assertEqual "butter" (append "butter" "")

25− , test "append 3" <| assertEqual "butter" (append "" "butter")

21+ [ test "uncons non-empty" <| assertEqual (Just ('a',"bc")) (String.uncons "abc")

22+ , test "uncons empty" <| assertEqual Nothing (String.uncons "")

23+ , test "append 1" <| assertEqual "butterfly" (String.append "butter" "fly")

24+ , test "append 2" <| assertEqual "butter" (String.append "butter" "")

25+ , test "append 3" <| assertEqual "butter" (String.append "" "butter")

2626 , test "concat" <| assertEqual "nevertheless" (concat ["never","the","less"])

27− , test "split commas" <| assertEqual ["cat","dog","cow"] (split "," "cat,dog,cow")

28− , test "split slashes"<| assertEqual ["home","steve","Desktop", ""] (split "/" "home/steve/Desktop/")

29− , test "join spaces" <| assertEqual "cat dog cow" (join " " ["cat","dog","cow"])

30− , test "join slashes" <| assertEqual "home/steve/Desktop" (join "/" ["home","steve","Desktop"])

31− , test "slice 1" <| assertEqual "c" (slice 2 3 "abcd")

32− , test "slice 2" <| assertEqual "abc" (slice 0 3 "abcd")

33− , test "slice 3" <| assertEqual "abc" (slice 0 -1 "abcd")

34− , test "slice 4" <| assertEqual "cd" (slice -2 4 "abcd")

27+ , test "split commas" <| assertEqual ["cat","dog","cow"] (String.split "," "cat,dog,cow")

28+ , test "split slashes"<| assertEqual ["home","steve","Desktop", ""] (String.split "/" "home/steve/Desktop/")

29+ , test "join spaces" <| assertEqual "cat dog cow" (String.join " " ["cat","dog","cow"])

30+ , test "join slashes" <| assertEqual "home/steve/Desktop" (String.join "/" ["home","steve","Desktop"])

31+ , test "slice 1" <| assertEqual "c" (String.slice 2 3 "abcd")

32+ , test "slice 2" <| assertEqual "abc" (String.slice 0 3 "abcd")

33+ , test "slice 3" <| assertEqual "abc" (String.slice 0 -1 "abcd")

34+ , test "slice 4" <| assertEqual "cd" (String.slice -2 4 "abcd")

3535 ]

3636 in

3737 suite "String" [ simpleTests, combiningTests ]