51dfa67 · elk · git.iko.soy

.gitignore+3−7

@@ -5,11 +5,7 @@ cabal-dev

55*.chi

66*.chs.h

77*.aes

8+*.elmi

9+*.elmo

10+*/ElmFiles/*

811.DS_Store

9−/Examples/elm-js/ChangeTitle/ChangeTitle.html

10−/Examples/elm-js/ConsoleLog/Log.html

11−/Examples/elm-js/Redirect/Redirect.html

12−/Examples/elm-js/Form/Form.html

13−/Examples/elm-js/FrameRate/FrameRate.html

14−/Examples/elm-js/Maps/Map.html

15−elm/elm-runtime.js

Elm.cabal+118−102

@@ -22,134 +22,150 @@ Build-type: Custom

2222

2323Extra-source-files: changelog.txt

2424Data-dir: dist/data

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

26−Cabal-version: >=1.8

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

26+Cabal-version: >=1.9

2727

2828source-repository head

2929 type: git

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

3131

3232Library

33− exposed-modules: Language.Elm,

34− Language.Elm.Quasi

35− Hs-Source-Dirs: compiler, compiler/Gen, compiler/Model, compiler/Transform

36− other-modules: Ast,

37− Located,

38− CompileToJS,

39− Cases,

40− Substitute,

41− ExtractNoscript,

42− GenerateHtml,

43− Guid,

44− Libraries,

45− LoadLibraries,

46− Optimize,

33+ exposed-modules: Language.Elm

34+ Hs-Source-Dirs: compiler

35+ other-modules: Unique,

36+ SourceSyntax.Declaration,

37+ SourceSyntax.Expression,

38+ SourceSyntax.Everything,

39+ SourceSyntax.Helpers,

40+ SourceSyntax.Literal,

41+ SourceSyntax.Location,

42+ SourceSyntax.Module,

43+ SourceSyntax.Pattern,

44+ SourceSyntax.PrettyPrint,

45+ SourceSyntax.Type,

46+ Generate.JavaScript,

47+ Generate.Noscript,

48+ Generate.Html,

49+ Generate.Cases,

50+ Transform.Canonicalize,

51+ Transform.Check,

52+ Transform.SortDefinitions,

53+ Transform.Substitute,

54+ Transform.Optimize,

55+ Metadata.Prelude,

4756 Initialize,

48− Rename,

49− Parse.Binops,

50− Parse.Expr,

51− Parse.Foreign,

52− Parse.Library,

53− Parse.Modules,

54− Parse.Parser,

55− Parse.Patterns,

56− Parse.Types,

57− Types.Alias,

58− Types.Types,

59− Types.Constrain,

60− Types.Hints,

61− Types.Solver,

62− Types.Substitutions,

63− Types.Unify,

57+ Parse.Binop,

58+ Parse.Declaration,

59+ Parse.Expression,

60+ Parse.Helpers,

61+ Parse.Literal,

62+ Parse.Module,

63+ Parse.Parse,

64+ Parse.Pattern,

65+ Parse.Type,

66+ Type.Constrain.Declaration,

67+ Type.Constrain.Expression,

68+ Type.Constrain.Literal,

69+ Type.Constrain.Pattern,

70+ Type.Environment,

71+ Type.Fragment,

72+ Type.Inference,

73+ Type.PrettyPrint,

74+ Type.Solve,

75+ Type.State,

76+ Type.Type,

77+ Type.Unify,

6478 Paths_Elm

6579

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

67− containers >= 0.3,

68− uniplate >= 1.6,

69− transformers >= 0.2,

70− mtl >= 2,

71− deepseq,

72− parsec >= 3.1.1,

81+ binary,

7382 blaze-html == 0.5.* || == 0.6.*,

7483 blaze-markup == 0.5.1.*,

75− text,

76− shakespeare >= 1,

77− template-haskell,

78− pandoc >= 1.10,

7984 bytestring,

85+ cmdargs,

86+ containers >= 0.3,

87+ directory,

88+ filepath,

8089 hjsmin,

8190 indents,

82− filepath,

83− json,

84− directory

91+ mtl >= 2,

92+ pandoc >= 1.10,

93+ parsec >= 3.1.1,

94+ pretty,

95+ transformers >= 0.2,

96+ union-find,

97+ uniplate

8598

8699Executable elm

87100 Main-is: Compiler.hs

88− Hs-Source-Dirs: compiler, compiler/Gen, compiler/Model, compiler/Transform

89− extensions: CPP

90− cpp-options: -DELM_COMPILEDATADIR="dist/data"

91− other-modules: Ast,

92− Located,

93− CompileToJS,

94− Cases,

95− Substitute,

96− ExtractNoscript,

97− GenerateHtml,

98− Guid,

99− Libraries,

100− LoadLibraries,

101− Optimize,

101+ ghc-options: -threaded -O2

102+ Hs-Source-Dirs: compiler

103+ other-modules: Unique,

104+ SourceSyntax.Declaration,

105+ SourceSyntax.Expression,

106+ SourceSyntax.Everything,

107+ SourceSyntax.Helpers,

108+ SourceSyntax.Literal,

109+ SourceSyntax.Location,

110+ SourceSyntax.Module,

111+ SourceSyntax.Pattern,

112+ SourceSyntax.PrettyPrint,

113+ SourceSyntax.Type,

114+ Generate.JavaScript,

115+ Generate.Noscript,

116+ Generate.Html,

117+ Generate.Cases,

118+ Transform.Canonicalize,

119+ Transform.Check,

120+ Transform.SortDefinitions,

121+ Transform.Substitute,

122+ Transform.Optimize,

123+ Metadata.Prelude,

102124 Initialize,

103− Rename,

104− Parse.Binops,

105− Parse.Expr,

106− Parse.Foreign,

107− Parse.Library,

108− Parse.Modules,

109− Parse.Parser,

110− Parse.Patterns,

111− Parse.Types,

112− Types.Alias,

113− Types.Types,

114− Types.Constrain,

115− Types.Hints,

116− Types.Solver,

117− Types.Substitutions,

118− Types.Unify,

125+ Parse.Binop,

126+ Parse.Declaration,

127+ Parse.Expression,

128+ Parse.Helpers,

129+ Parse.Literal,

130+ Parse.Module,

131+ Parse.Parse,

132+ Parse.Pattern,

133+ Parse.Type,

134+ Type.Constrain.Declaration,

135+ Type.Constrain.Expression,

136+ Type.Constrain.Literal,

137+ Type.Constrain.Pattern,

138+ Type.Environment,

139+ Type.Fragment,

140+ Type.Inference,

141+ Type.PrettyPrint,

142+ Type.Solve,

143+ Type.State,

144+ Type.Type,

145+ Type.Unify,

119146 Paths_Elm

120147

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

122− containers >= 0.3,

123− uniplate >= 1.6,

124− transformers >= 0.2,

125− mtl >= 2,

126− deepseq,

127− parsec >= 3.1.1,

149+ binary,

128150 blaze-html == 0.5.* || == 0.6.*,

129151 blaze-markup == 0.5.1.*,

130− cmdargs,

131− pandoc >= 1.10,

132152 bytestring,

153+ cmdargs,

154+ containers >= 0.3,

155+ directory,

156+ filepath,

133157 hjsmin,

134158 indents,

135− filepath,

136− json,

137− directory

138−

139−Executable elm-doc

140− Main-is: Docs.hs

141− Hs-Source-Dirs: compiler, compiler/Model, compiler/Transform

142− other-modules: Ast,

143− Located,

144− Parse.Library,

145− Parse.Modules,

146− Rename

147−

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

149− containers >= 0.3,

150− transformers >= 0.2,

151159 mtl >= 2,

152− parsec >= 3.1.1,

153160 pandoc >= 1.10,

154− cmdargs,

155− indents

161+ parsec >= 3.1.1,

162+ pretty,

163+ transformers >= 0.2,

164+ union-find,

165+ uniplate

166+

167+Test-Suite test-elm

168+ Type: exitcode-stdio-1.0

169+ Hs-Source-Dirs: tests

170+ Main-is: Everything.hs

171+ build-depends: base

Setup.hs+75−75

@@ -10,12 +10,13 @@ import System.IO

1010import System.Process

1111

1212import Control.Monad

13+import qualified Data.Binary as Binary

1314

1415-- Part 1

1516-- ------

1617-- Add a build callout

17−-- We need to build elm-doc and run it because that generates the file "docs.json" needs by Libraries.hs

18−-- which is part of the elm library and executable

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

19+-- needs by Libraries.hs which is part of the elm library and executable

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

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

2122-- (b) elm (library) depends on docs.json

@@ -29,47 +30,34 @@ import Control.Monad

2930

3031-- Assumptions

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

32−rtsDir lbi = (buildDir lbi) </> ".." </> "data" -- git won't look in dist + cabal will clean it

33−jsDir lbi = (buildDir lbi) </> ".." </> "js"

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

34+rtsDir :: LocalBuildInfo -> FilePath

35+rtsDir lbi = buildDir lbi </> ".." </> "data"

3436

35−-- The runtime is called:

36−rts lbi = (rtsDir lbi) </> "elm-runtime.js"

37−

38−-- The json file is called:

37+tempDir :: LocalBuildInfo -> FilePath

38+tempDir lbi = buildDir lbi </> ".." </> "temp"

3939

40−-- The elm-docs executable is called:

41−elmDoc = "elm-doc"

42−elm_doc lbi = (buildDir lbi) </> elmDoc </> elmDoc

40+-- The runtime is called:

41+rts :: LocalBuildInfo -> FilePath

42+rts lbi = rtsDir lbi </> "elm-runtime.js"

4343

44−types lbi = (rtsDir lbi) </> "docs.json"

44+-- The interfaces for the Standard Libraries live in:

45+interfaces :: LocalBuildInfo -> FilePath

46+interfaces lbi = rtsDir lbi </> "interfaces.data"

4547

4648-- buildDir with LocalBuildInfo points to "dist/build" (usually)

47−elm lbi = (buildDir lbi) </> "elm" </> "elm"

49+elm lbi = buildDir lbi </> "elm" </> "elm"

4850

4951-- Care! This appears to be based on an unstable API

5052-- See: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html#2

5153

5254

5355main :: IO ()

54−main = defaultMainWithHooks simpleUserHooks { {-- buildHook = myBuild, --} postBuild = myPostBuildWithTypes }

56+main = defaultMainWithHooks simpleUserHooks { postBuild = myPostBuild }

5557

5658

5759-- Build

5860

59−-- Not currently used. buildTypes is in 'myPostBuildWithTypes'

60−-- If using this again, change postBuild to 'myPostBuild'

61−-- Purpose is to make sure docs.json was built before elm exec was (as elm exec depended on it)

62−-- This is no longer true and the code below seems to affect cabal's build dependencies

63−myBuild :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()

64−myBuild pd lbi uh bf = do

65− putStrLn $ "Custom build step started: compile " ++ elmDoc

66− withExe pd (\x -> putStrLn (exeName x))

67− buildHook simpleUserHooks (filterExe elmDoc pd) (filterLBI elmDoc lbi) uh bf

68− putStrLn "Custom build step started: build docs.json"

69− buildTypes lbi -- see note(1) below

70− putStrLn "Custom build step started: compile everything"

71− buildHook simpleUserHooks pd lbi uh bf

72−

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

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

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

@@ -77,42 +65,83 @@ myBuild pd lbi uh bf = do

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

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

7967

80−-- In the PackageDescription, the list of stuff to build is held in library (in a Maybe)

81−-- and the executables list. We want a PackageDescription that only mentions the executable 'name'

68+-- In the PackageDescription, the list of stuff to build is held in library

69+-- (in a Maybe) and the executables list. We want a PackageDescription that

70+-- only mentions the executable 'name'

71+filterExe :: String -> PackageDescription -> PackageDescription

8272filterExe name pd = pd {

8373 library = Nothing,

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

8575 }

8676

87−-- It's not enough to fix the PackageDescription, we also have to fix the LocalBuildInfo.

88−-- This includes the component build order (data ComponentName) which is horribly internal.

77+-- It's not enough to fix the PackageDescription, we also have to fix the

78+-- LocalBuildInfo. This includes the component build order (data ComponentName)

79+-- which is horribly internal.

80+filterLBI :: String -> LocalBuildInfo -> LocalBuildInfo

8981filterLBI name lbi = lbi {

9082 libraryConfig = Nothing,

9183 compBuildOrder = [CExeName name],

9284 executableConfigs = filter (\a -> (fst a == name)) (executableConfigs lbi)

9385 }

9486

95−buildTypes lbi = do

96− createDirectoryIfMissing False (rtsDir lbi) -- dist should already exist

97− files <- getFiles ".elm" "libraries"

98− system (elm_doc lbi ++ " " ++ unwords files ++ " > " ++ (types lbi))

99− putStrLn $ "Custom build step completed: " ++ elmDoc

100−

10187

10288-- Post Build

10389

104−myPostBuildWithTypes :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()

105−myPostBuildWithTypes as bfs pd lbi = do

106− putStrLn "Custom build step started: build docs.json"

107− buildTypes lbi -- see note(1) below

108− myPostBuild as bfs pd lbi

109−

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

11191myPostBuild as bfs pd lbi = do

112− putStrLn "Custom post build step started: build elm-runtime.js"

113− buildRuntime lbi

92+ putStrLn "Custom build step: compiling standard libraries"

93+ (elmos, elmis) <- compileLibraries lbi

94+ putStrLn "Custom build step: build interfaces.data"

95+ buildInterfaces lbi elmis

96+ putStrLn "Custom build step: build elm-runtime.js"

97+ buildRuntime lbi elmos

98+ removeDirectoryRecursive ("dist" </> "temp")

11499 postBuild simpleUserHooks as bfs pd lbi

115100

101+

102+compileLibraries lbi = do

103+ let temp = tempDir lbi -- dist/temp

104+ rts = rtsDir lbi -- dist/data

105+ createDirectoryIfMissing True temp

106+ createDirectoryIfMissing True rts

107+ out_c <- canonicalizePath temp -- dist/temp (root folder)

108+ elm_c <- canonicalizePath (elm lbi) -- dist/build/elm/elm

109+ rtd_c <- canonicalizePath rts -- dist/data (for docs.json)

110+

111+ let make file = do

112+ -- replace 'system' call with 'runProcess' which handles args better

113+ -- and allows env variable "Elm_datadir" which is used by LoadLibraries

114+ -- to find docs.json

115+ let args = ["--only-js","--make","--no-prelude","--output-directory="++out_c,file]

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

117+ handle <- runProcess elm_c args Nothing arg Nothing Nothing Nothing

118+ exitCode <- waitForProcess handle

119+ return ( out_c </> replaceExtension file "elmo"

120+ , out_c </> replaceExtension file "elmi")

121+

122+ setCurrentDirectory "libraries"

123+ print =<< getCurrentDirectory

124+ files <- getFiles ".elm" "."

125+ files <- unzip `fmap` mapM make files

126+ setCurrentDirectory ".."

127+ return files

128+

129+buildInterfaces :: LocalBuildInfo -> [FilePath] -> IO ()

130+buildInterfaces lbi elmis = do

131+ createDirectoryIfMissing True (rtsDir lbi)

132+ let ifaces = interfaces lbi

133+ Binary.encodeFile ifaces (length elmis)

134+ mapM_ (\elmi -> readFile elmi >>= appendFile ifaces) elmis

135+

136+buildRuntime :: LocalBuildInfo -> [FilePath] -> IO ()

137+buildRuntime lbi elmos = do

138+ createDirectoryIfMissing True (rtsDir lbi)

139+ writeFile (rts lbi) "Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\

140+ \Elm.Graphics = {}; ElmRuntime = {}; ElmRuntime.Render = {};\n"

141+ mapM_ (appendJS lbi) =<< getFiles ".js" "libraries"

142+ mapM_ (appendJS lbi) elmos

143+ mapM_ (appendJS lbi) =<< getFiles ".js" "runtime"

144+

116145getFiles ext dir = do

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

118147 let files = filter (\f -> takeExtension f == ext) contents

@@ -125,32 +154,3 @@ appendJS lbi file = do

125154 str <- readFile file

126155 length str `seq` return ()

127156 appendFile (rts lbi) str

128−

129−appendElm lbi file = do

130− jsFile <- runElm lbi file

131− appendJS lbi jsFile

132−

133−-- replace 'system' call with 'runProcess' which handles args better and allows env variable

134−-- "Elm_datadir" which is used by LoadLibraries to find docs.json

135−runElm :: LocalBuildInfo -> String -> IO FilePath

136−runElm lbi file = do

137− rts_c <- canonicalizePath (rts lbi) -- dist/data/elm-runtime.js

138− let js = jsDir lbi -- dist/js

139− let j = dropFileName (js </> file) -- dist/js/libraries/

140− createDirectoryIfMissing True j -- must do before any canonicalization

141− out_c <- canonicalizePath js -- dist/js (root folder)

142− elm_c <- canonicalizePath (elm lbi) -- dist/build/elm/elm

143− rtd_c <- canonicalizePath (rtsDir lbi) -- dist/data (for docs.json)

144− handle <- runProcess elm_c ["--only-js", "--no-prelude", "--output-directory="++out_c, file]

145− Nothing (Just [("Elm_datadir", rtd_c)]) Nothing Nothing Nothing

146− exitCode <- waitForProcess handle

147− return $ j </> replaceExtension (takeFileName file) ".js"

148−

149−

150−buildRuntime lbi = do

151− createDirectoryIfMissing False (rtsDir lbi) -- dist should already exist

152− writeFile (rts lbi) "Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\

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

154− mapM_ (appendJS lbi) =<< getFiles ".js" "libraries"

155− mapM_ (appendElm lbi) =<< getFiles ".elm" "libraries"

156− mapM_ (appendJS lbi) =<< getFiles ".js" "runtime"

changelog.txt+40

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

11

2+Release 0.8.1

3+=============

4+

5+Website:

6+* Hot-swapping

7+* Much faster page load with pre-compile Elm files (Max New)

8+

9+Syntax:

10+* Pattern matching on literals

11+* Pattern aliases with `as` (Andrew)

12+* Unary negation

13+* Triple-quoted multi-line strings

14+* Custom infix precedence and associativity

15+* Type annotations in let expressions (Andrew)

16+* Record Constructors

17+* Record type aliases can be closed on the zeroth column

18+* (,,) syntax in types

19+* "(+) = " is permitted

20+* Unparenthesized if, let, case, and lambda in last

21+ term of a binary expression

22+

23+Libraries:

24+* Detect hovering over any Element

25+* Opacity on arbitrary forms in collages

26+* Switch Text.height to use px instead of em

27+

28+Error Messages:

29+* Cross-module type errors

30+* Pretty printing of expressions and types

31+* Type-variables look more natural (a,b,c instead of t1,t2,t3)

32+

33+Build Improvements:

34+* Module-level compilation, only re-compile if necessary

35+* Import type aliases between modules

36+

37+

38+

39+forgot to fill this in again...

40+

41+

242Release 0.7.2

343=============

444

compiler/Compiler.hs+86−43

@@ -1,34 +1,42 @@

11{-# LANGUAGE DeriveDataTypeable #-}

22module Main where

33

4−import Control.Monad (foldM, when)

4+import Control.Monad

55import qualified Data.Map as Map

6−import Data.Either (lefts, rights)

7−import Data.List (intersect, intercalate, lookup)

8−import Data.Maybe (fromMaybe)

6+import qualified Data.List as List

7+import qualified Data.Binary as Binary

98import Data.Version (showVersion)

10−import System.Console.CmdArgs

9+import System.Console.CmdArgs hiding (program)

1110import System.Directory

1211import System.Exit

1312import System.FilePath

13+import GHC.Conc

14+

1415import qualified Text.Blaze.Html.Renderer.Pretty as Pretty

1516import qualified Text.Blaze.Html.Renderer.String as Normal

16−

1717import qualified Text.Jasmine as JS

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

1919

20−import Ast

21−import Initialize (buildFromSource, getSortedModuleNames)

22−import CompileToJS (jsModule)

23−import GenerateHtml (createHtml, JSStyle(..), JSSource(..))

24−import qualified Libraries as Libraries

20+import qualified Metadata.Prelude as Prelude

21+import qualified Transform.Canonicalize as Canonical

22+import SourceSyntax.Module

23+import Initialize (buildFromSource, getSortedDependencies)

24+import Generate.JavaScript (jsModule)

25+import Generate.Html (createHtml, JSStyle(..), JSSource(..))

2526import Paths_Elm

2627

28+import SourceSyntax.PrettyPrint (pretty, variable)

29+import Text.PrettyPrint as P

30+import qualified Type.Type as Type

31+import qualified Data.Traversable as Traverse

32+

2733data Flags =

2834 Flags { make :: Bool

2935 , files :: [FilePath]

3036 , runtime :: Maybe FilePath

3137 , only_js :: Bool

38+ , print_types :: Bool

39+ , print_program :: Bool

3240 , scripts :: [FilePath]

3341 , no_prelude :: Bool

3442 , minify :: Bool

@@ -44,6 +52,10 @@ flags = Flags

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

4553 , only_js = False

4654 &= help "Compile only to JavaScript."

55+ , print_types = False

56+ &= help "Print out infered types of top-level definitions."

57+ , print_program = False

58+ &= help "Print out an internal representation of a program."

4759 , scripts = [] &= typFile

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

4961 , no_prelude = False

@@ -56,7 +68,8 @@ flags = Flags

5668 &= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki")

5769

5870main :: IO ()

59−main = compileArgs =<< cmdArgs flags

71+main = do setNumCapabilities =<< getNumProcessors

72+ compileArgs =<< cmdArgs flags

6073

6174compileArgs :: Flags -> IO ()

6275compileArgs flags =

@@ -65,49 +78,77 @@ compileArgs flags =

6578 fs -> mapM_ (build flags) fs

6679

6780

68−type Interface = String

69−

7081file :: Flags -> FilePath -> String -> FilePath

7182file flags filePath ext = output_directory flags </> replaceExtension filePath ext

7283

7384elmo :: Flags -> FilePath -> FilePath

7485elmo flags filePath = file flags filePath "elmo"

7586

87+elmi :: Flags -> FilePath -> FilePath

88+elmi flags filePath = file flags filePath "elmi"

7689

77−buildFile :: Flags -> Int -> Int -> FilePath -> IO Interface

78−buildFile flags moduleNum numModules filePath =

79− do compiled <- alreadyCompiled

80− if compiled then readFile (elmo flags filePath) else compile

8190

91+buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO ModuleInterface

92+buildFile flags moduleNum numModules interfaces filePath =

93+ do compiled <- alreadyCompiled

94+ if not compiled then compile

95+ else getInterface `fmap` Binary.decodeFile (elmi flags filePath)

8296 where

97+ getInterface :: (String, ModuleInterface) -> ModuleInterface

98+ getInterface = snd

99+

83100 alreadyCompiled :: IO Bool

84101 alreadyCompiled = do

85− exists <- doesFileExist (elmo flags filePath)

86− if not exists then return False

87− else do tsrc <- getModificationTime filePath

88− tint <- getModificationTime (elmo flags filePath)

89− return (tsrc < tint)

102+ existsi <- doesFileExist (elmi flags filePath)

103+ existso <- doesFileExist (elmo flags filePath)

104+ if not existsi || not existso

105+ then return False

106+ else do tsrc <- getModificationTime filePath

107+ tint <- getModificationTime (elmo flags filePath)

108+ return (tsrc < tint)

90109

91110 number :: String

92111 number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"

93112

94113 name :: String

95− name = intercalate "." (splitDirectories (dropExtensions filePath))

114+ name = List.intercalate "." (splitDirectories (dropExtensions filePath))

96115

97− compile :: IO Interface

116+ compile :: IO ModuleInterface

98117 compile = do

99− putStrLn (number ++ " Compiling " ++ name)

118+ putStrLn $ concat [ number, " Compiling ", name

119+ , replicate (max 1 (20 - length name)) ' '

120+ , "( " ++ filePath ++ " )" ]

100121 source <- readFile filePath

101− (interface,obj) <-

102− if takeExtension filePath == ".js" then return ("",source) else

103− case buildFromSource (no_prelude flags) source of

104− Left err -> putStrLn err >> exitFailure

105− Right modul -> do exs <- exportInfo modul

106− return (exs, jsModule modul)

107122 createDirectoryIfMissing True (output_directory flags)

108− writeFile (elmo flags filePath) obj

109− return obj

110−

123+ metaModule <-

124+ case buildFromSource (no_prelude flags) interfaces source of

125+ Left errors -> do

126+ mapM print (List.intersperse (P.text " ") errors)

127+ exitFailure

128+ Right modul -> do

129+ case print_program flags of

130+ False -> return ()

131+ True -> print . pretty $ program modul

132+ return modul

133+

134+ if print_types flags then printTypes metaModule else return ()

135+ tipes <- Traverse.traverse Type.toSrcType (types metaModule)

136+ let interface = Canonical.interface name $ ModuleInterface {

137+ iTypes = tipes,

138+ iAdts = datatypes metaModule,

139+ iAliases = aliases metaModule

140+ }

141+ createDirectoryIfMissing True . dropFileName $ elmi flags filePath

142+ Binary.encodeFile (elmi flags filePath) (name,interface)

143+ writeFile (elmo flags filePath) (jsModule metaModule)

144+ return interface

145+

146+printTypes metaModule = do

147+ putStrLn ""

148+ forM_ (Map.toList $ types metaModule) $ \(n,t) -> do

149+ pt <- Type.extraPretty t

150+ print $ variable n <+> P.text ":" <+> pt

151+ putStrLn ""

111152

112153getRuntime :: Flags -> IO FilePath

113154getRuntime flags =

@@ -117,8 +158,10 @@ getRuntime flags =

117158

118159build :: Flags -> FilePath -> IO ()

119160build flags rootFile = do

120− files <- if make flags then getSortedModuleNames rootFile else return [rootFile]

121− buildFiles flags (length files) Map.empty files

161+ let noPrelude = no_prelude flags

162+ files <- if make flags then getSortedDependencies noPrelude rootFile else return [rootFile]

163+ let ifaces = if noPrelude then Map.empty else Prelude.interfaces

164+ interfaces <- buildFiles flags (length files) ifaces files

122165 js <- foldM appendToOutput "" files

123166 case only_js flags of

124167 True -> do

@@ -128,7 +171,7 @@ build flags rootFile = do

128171 False -> do

129172 putStr "Generating HTML ... "

130173 runtime <- getRuntime flags

131− let html = genHtml $ createHtml runtime rootFile (sources js) ""

174+ let html = genHtml $ createHtml runtime (takeBaseName rootFile) (sources js) ""

132175 writeFile (file flags rootFile "html") html

133176 putStrLn "Done"

134177

@@ -144,11 +187,11 @@ build flags rootFile = do

144187 [ Source (if minify flags then Minified else Readable) js ]

145188

146189

147−buildFiles :: Flags -> Int -> Map.Map String Interface -> [FilePath] -> IO ()

148−buildFiles _ _ _ [] = return ()

190+buildFiles :: Flags -> Int -> Interfaces -> [FilePath] -> IO Interfaces

191+buildFiles _ _ interfaces [] = return interfaces

149192buildFiles flags numModules interfaces (filePath:rest) = do

150− interface <- buildFile flags (numModules - length rest) numModules filePath

151− let moduleName = intercalate "." (splitDirectories (dropExtensions filePath))

193+ interface <- buildFile flags (numModules - length rest) numModules interfaces filePath

194+ let moduleName = List.intercalate "." . splitDirectories $ dropExtensions filePath

152195 interfaces' = Map.insert moduleName interface interfaces

153196 buildFiles flags numModules interfaces' rest

154197

@@ -156,4 +199,4 @@ buildFiles flags numModules interfaces (filePath:rest) = do

156199exportInfo :: Module -> IO String

157200exportInfo (Module names exs ims stmts) =

158201 do print exs

159− return (show exs)

202+ return (show exs)

compiler/Docs.hs+8−9

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

11

22module Main where

33

4−import Ast

4+import SourceSyntax.Declaration (Declaration(Datatype))

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

66import Data.List (intercalate)

7−import Data.Maybe (catMaybes)

8−import Types.Types ((==>), Type ( ADT, VarT ) )

9−import Parse.Types (datatype)

10−import Parse.Library

11−import Parse.Modules (moduleDef)

7+import Parse.Type

8+import Parse.Helpers

9+import Parse.Module (moduleDef)

1210import Text.Parsec hiding (newline,spaces)

1311import System.Environment

1412import System.Exit

1513

16−

1714main = do

1815 srcs <- mapM readFile =<< getArgs

1916 case mapM docParse srcs of

@@ -64,11 +61,13 @@ annotation exports =

6461

6562 typeDef = lookAhead ((string "data" <|> string "type") >> whitespace >> capVar)

6663

67− adt = do

64+ adt = do undefined

65+{-- TODO: reimplement this

6866 (Datatype name tvs constructors) <- datatype

6967 let toType (cName, typeArgs) =

70− (cName, show $ foldr (==>) (ADT name $ map VarT tvs) typeArgs, "")

68+ (cName, show $ foldr (==>) (kADT name $ map kVarT tvs) typeArgs, "")

7169 return $ map toType constructors

70+--}

7271

7372setupParser p source =

7473 case iParse p "" source of

compiler/Dummy.cabalnew file+170

@@ -0,0 +1,170 @@

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+

5+Name: Elm

6+Version: 0.8.0.3

7+Synopsis: The Elm language module.

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

9+ It is a statically/strongly typed, functional reactive

10+ language to HTML, CSS, and JS. This package provides a

11+ library for Elm compilation in Haskell and a compiler

12+ executable.

13+

14+Homepage: http://elm-lang.org

15+

16+License: BSD3

17+License-file: LICENSE

18+

19+Author: Evan Czaplicki

20+Maintainer: info@elm-lang.org

22+

23+Category: Compiler, Language

24+

25+Build-type: Custom

26+

27+Extra-source-files: changelog.txt

28+Data-dir: dist/data

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

30+Cabal-version: >=1.8

31+

32+source-repository head

33+ type: git

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

35+

36+Library

37+ exposed-modules: Language.Elm,

38+ Language.Elm.Quasi

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

48+ Generate.JavaScript,

49+ Generate.Noscript,

50+ Generate.Html,

51+ Generate.Cases,

52+ Transform.Substitute,

53+ Transform.Optimize,

54+ Metadata.Libraries,

55+ Metadata.LoadLibraries,

56+ Initialize,

57+ Parse.Binop,

58+ Parse.Expression,

59+ Parse.Foreign,

60+ Parse.Helpers,

61+ Parse.Module,

62+ Parse.Parser,

63+ Parse.Pattern,

64+ Parse.Type,

65+ Types.Alias,

66+ Types.Types,

67+ Types.Constrain,

68+ Types.Hints,

69+ Types.Solver,

70+ Types.Substitutions,

71+ Types.Unify,

72+ Paths_Elm

73+

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

75+ containers >= 0.3,

76+ transformers >= 0.2,

77+ mtl >= 2,

78+ deepseq,

79+ parsec >= 3.1.1,

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

81+ blaze-markup == 0.5.1.*,

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

93+

94+Executable elm

95+ Main-is: Compiler.hs

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

105+ Generate.JavaScript,

106+ Generate.Noscript,

107+ Generate.Html,

108+ Generate.Cases,

109+ Transform.Substitute,

110+ Transform.Optimize,

111+ Metadata.Libraries,

112+ Metadata.LoadLibraries,

113+ Initialize,

114+ Parse.Binop,

115+ Parse.Expression,

116+ Parse.Foreign,

117+ Parse.Helpers,

118+ Parse.Module,

119+ Parse.Parser,

120+ Parse.Pattern,

121+ Parse.Type,

122+ Types.Alias,

123+ Types.Types,

124+ Types.Constrain,

125+ Types.Hints,

126+ Types.Solver,

127+ Types.Substitutions,

128+ Types.Unify,

129+ Paths_Elm

130+

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

132+ containers >= 0.3,

133+ transformers >= 0.2,

134+ mtl >= 2,

135+ deepseq,

136+ parsec >= 3.1.1,

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

138+ blaze-markup == 0.5.1.*,

139+ cmdargs,

140+ pandoc >= 1.10,

141+ bytestring,

142+ uniplate,

143+ hjsmin,

144+ indents,

145+ filepath,

146+ json,

147+ directory

148+

149+Executable elm-doc

150+ Main-is: Docs.hs

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

159+ Parse.Helpers,

160+ Parse.Module

161+

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

163+ containers >= 0.3,

164+ transformers >= 0.2,

165+ mtl >= 2,

166+ parsec >= 3.1.1,

167+ pandoc >= 1.10,

168+ cmdargs,

169+ filepath,

170+ indents

compiler/Gen/Cases.hsdeleted−87

@@ -1,87 +0,0 @@

1−

2−module Cases (caseToMatch, Match (..), Clause (..), matchSubst) where

3−

4−import Control.Arrow (first)

5−import Control.Monad (liftM,foldM)

6−import Data.List (groupBy,sortBy,lookup)

7−import Data.Maybe (fromMaybe)

8−

9−import Ast

10−import Located

11−import Guid

12−import Substitute

13−

14−caseToMatch patterns = do

15− v <- newVar

16− match [v] (map (first (:[])) patterns) Fail

17−

18−newVar = do n <- guid

19− return $ "case" ++ show n

20−

21−data Match = Match String [Clause] Match

22− | Break

23− | Fail

24− | Other CExpr

25− | Seq [Match]

26− deriving Show

27−

28−data Clause = Clause String [String] Match

29− deriving Show

30−

31−matchSubst :: [(String,String)] -> Match -> Match

32−matchSubst _ Break = Break

33−matchSubst _ Fail = Fail

34−matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)

35−matchSubst pairs (Other (L t s e)) =

36− Other . L t s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs

37−matchSubst pairs (Match n cs m) =

38− Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

39− where varSubst v = fromMaybe v (lookup v pairs)

40− clauseSubst (Clause c vs m) =

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

42−

43−isCon (PData _ _ : _, _) = True

44−isCon _ = False

45−

46−isVar p = not (isCon p)

47−

48−match :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

49−match [] [] def = return def

50−match [] [([],e)] Fail = return $ Other e

51−match [] [([],e)] Break = return $ Other e

52−match [] cs def = return $ Seq (map (Other . snd) cs ++ [def])

53−match vs cs def

54− | all isVar cs = matchVar vs cs def

55− | all isCon cs = matchCon vs cs def

56− | otherwise = matchMix vs cs def

57−

58−matchVar :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

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

60− where

61− subVar (p:ps, ce@(L t s e)) =

62− let loc = L t s in

63− (ps, case p of

64− PVar x -> L t s $ subst x (Var v) e

65− PAnything -> ce

66− PRecord fs ->

67− loc $ foldr (\x -> subst x (Access (loc (Var v)) x)) e fs

68− )

69−

70−matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

71−matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css

72− where css = groupBy (withName (==)) $ sortBy (withName compare) cs

73− withName f (PData n1 _:_,_) (PData n2 _:_,_) = f n1 n2

74− toClause cs = let (PData name _ : _ , _) = head cs in

75− matchClause name (v:vs) cs Break

76−

77−matchClause :: String -> [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Clause

78−matchClause c (v:vs) cs def =

79− do vs' <- getVars

80− Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def

81− where flatten (PData _ ps' : ps, e) = (ps' ++ ps, e)

82− getVars = let (PData _ ps : _, _) = head cs in

83− mapM (\_ -> newVar) ps

84−

85−matchMix :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

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

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

compiler/Gen/CompileToJS.hsdeleted−341

@@ -1,341 +0,0 @@

1−module CompileToJS (showErr, jsModule) where

2−

3−import Control.Arrow (first,second)

4−import Control.Monad (liftM,(<=<),join,ap)

5−import Data.Char (isAlpha,isDigit)

6−import Data.List (intercalate,sortBy,inits,foldl')

7−import qualified Data.Map as Map

8−import Data.Either (partitionEithers)

9−import qualified Text.Pandoc as Pan

10−import Data.Maybe (maybeToList)

11−

12−import Ast

13−import Located

14−import Rename (derename)

15−import Cases

16−import Guid

17−import Rename (deprime)

18−import Types.Types ( Type(RecordT) )

19−

20−showErr :: String -> String

21−showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)

22− where msg = show . concatMap (++"<br>") . lines $ err

23− body = "var T = Elm.Text(elm);\n\

24− \return { main : T.text(T.monospace(" ++ msg ++ ")) };"

25−

26−indent = concatMap f

27− where f '\n' = "\n "

28− f c = [c]

29−

30−internalImports =

31− [ ("N" , "Elm.Native"),

32− ("_N", "N.Utils(elm)"),

33− ("_L", "N.List(elm)"),

34− ("_E", "N.Error(elm)"),

35− ("_str", "N.JavaScript(elm).toString")

36− ]

37−

38−parens s = "(" ++ s ++ ")"

39−brackets s = "{" ++ s ++ "}"

40−jsObj = brackets . intercalate ", "

41−jsList ss = "["++ intercalate "," ss ++"]"

42−jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"

43−assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"

44−ret e = "\nreturn "++ e ++";"

45−iff a b c = a ++ "?" ++ b ++ ":" ++ c

46−quoted s = "'" ++ concatMap f s ++ "'"

47− where f '\n' = "\\n"

48− f '\'' = "\\'"

49− f '\t' = "\\t"

50− f '\"' = "\\\""

51− f '\\' = "\\\\"

52− f c = [c]

53−

54−globalAssign n e = "\n" ++ assign' n e ++ ";"

55−assign' n e = n ++ " = " ++ e

56−

57−jsModule (Module names exports imports stmts) =

58− setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)

59− where

60− modNames = if null names then ["Main"] else names

61− modName = intercalate "." modNames

62− includes = concatMap jsImport imports

63− body = stmtsToJS stmts

64− defs = assign "$op" "{}"

65− program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++

66− setup ("elm":"Native":modNames) ++

67− assign "_" ("elm.Native." ++ modName ++ "||{}") ++

68− getExports exports stmts ++ setup ("elm":modNames) ++

69− ret (assign' ("elm." ++ modName) "_") ++ "\n"

70− setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .

71− map (intercalate ".") . drop 2 . inits $ init modNames

72− usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)

73−

74−getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)

75− where exNames n = either derename id n `elem` names

76− exports | null names = concatMap get stmts

77− | otherwise = filter exNames (concatMap get stmts)

78−

79− (fns,ops) = partitionEithers exports

80−

81− opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"

82− fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn

83−

84− op = ("_.$op = "++) . jsObj $ map opPair ops

85−

86− get' (FnDef x _ _) = Just (Left x)

87− get' (OpDef op _ _ _) = Just (Right op)

88− get' (TypeAnnotation _ _) = Nothing

89− get s = case s of Definition d -> maybeToList (get' d)

90− Datatype _ _ tcs -> map (Left . fst) tcs

91− ImportEvent _ _ x _ -> [ Left x ]

92− ExportEvent _ _ _ -> []

93− TypeAlias _ _ _ -> []

94−

95−

96−jsImport (modul, how) =

97− case how of

98− As name -> assign name ("Elm." ++ modul ++ parens "elm")

99− Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++

100− "; for(var k in _){if(k in hiding)continue;" ++

101− "eval('var '+k+'=_[\"'+k+'\"]')}"

102− Importing vs -> include ++ named

103− where

104− imprt v = assign' v ("_." ++ v)

105− def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))

106− named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"

107− where

108− include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul

109− setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])

110− where

111− defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)

112− subnames = map (intercalate ".") . tail . inits . init . split

113− split names = case go [] names of

114− (name, []) -> [name]

115− (name, ns) -> name : split ns

116− go name str = case str of

117− '.':rest -> (reverse name, rest)

118− c:rest -> go (c:name) rest

119− [] -> (reverse name, [])

120−

121−

122−

123−stmtsToJS :: [Statement] -> String

124−stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)

125− return (concat program)

126− where

127− cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)

128− valueOf s = case s of

129− Datatype _ _ _ -> 1

130− ImportEvent _ _ _ _ -> 2

131− Definition (FnDef f [] _) ->

132− if derename f == "main" then 5 else 4

133− Definition (TypeAnnotation _ _) -> 0

134− Definition _ -> 3

135− ExportEvent _ _ _ -> 6

136− TypeAlias _ _ _ -> 0

137−

138−class ToJS a where

139− toJS :: a -> GuidCounter String

140−

141−instance ToJS Def where

142− toJS (FnDef x [] e) = assign x `liftM` toJS' e

143− toJS (FnDef f as e) = (assign f . wrapper . func) `liftM` toJS' e

144− where

145− func body = jsFunc (intercalate ", " as) (ret body)

146− wrapper e | length as == 1 = e

147− | otherwise = 'F' : show (length as) ++ parens e

148− toJS (OpDef op a1 a2 e) =

149− do body <- toJS' e

150− let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))

151− return (globalAssign ("$op['" ++ op ++ "']") func)

152− toJS (TypeAnnotation _ _) = return ""

153−

154−

155−instance ToJS Statement where

156− toJS stmt =

157− case stmt of

158− Definition d -> toJS d

159− Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs

160− where toDef (name,args) =

161− let vars = map (('a':) . show) [1..length args] in

162− Definition . FnDef name vars . notLocated $

163− Data (derename name) (map (notLocated . Var) vars)

164− ImportEvent js base elm _ ->

165− do v <- toJS' base

166− return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"

167− , "\ndocument.addEventListener('", js

168− , "_' + elm.id, function(e) { elm.notify(", elm

169− , ".id, e.value); });" ]

170− ExportEvent js elm _ ->

171− return $ concat [ "\nlift(function(v) { "

172− , "var e = document.createEvent('Event');"

173− , "e.initEvent('", js, "_' + elm.id, true, true);"

174− , "e.value = v;"

175− , "document.dispatchEvent(e); return v; })(", elm, ");" ]

176− TypeAlias n _ t -> return ""

177−

178−toJS' :: CExpr -> GuidCounter String

179−toJS' (L txt span expr) =

180− case expr of

181− MultiIf ps -> multiIfToJS span ps

182− Case e cases -> caseToJS span e cases

183− _ -> toJS expr

184−

185−remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"

186−addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"

187−setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"

188− where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"

189−access x e = e ++ "." ++ x

190−makeRecord kvs = record `liftM` collect kvs

191− where

192− combine r (k,v) = Map.insertWith (++) k v r

193− collect = liftM (foldl' combine Map.empty) . mapM prep

194− prep (k, as, e@(L t s _)) =

195− do v <- toJS' (foldr (\x e -> L t s $ Lambda x e) e as)

196− return (k,[v])

197− fields fs =

198− brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))

199− hidden = fields . map (second jsList) .

200− filter (not . null . snd) . Map.toList . Map.map tail

201− record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs

202−

203−

204−instance ToJS Expr where

205− toJS expr =

206− case expr of

207− Var x -> return $ x

208− Chr c -> return $ quoted [c]

209− Str s -> return $ "_str" ++ parens (quoted s)

210− IntNum n -> return $ show n

211− FloatNum n -> return $ show n

212− Boolean b -> return $ if b then "true" else "false"

213− Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi

214− Access e x -> access x `liftM` toJS' e

215− Remove e x -> remove x `liftM` toJS' e

216− Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e

217− Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)

218− setField fs' `liftM` toJS' e

219− Record fs -> makeRecord fs

220− Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2

221−

222− If eb et ef ->

223− parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)

224−

225− Lambda v e -> liftM (jsFunc v . ret) (toJS' e)

226−

227− App e1 e2 -> jsApp e1 e2

228− Let defs e -> jsLet defs e

229− Data name es ->

230− do fs <- mapM toJS' es

231− return $ case name of

232− "Nil" -> jsNil

233− "Cons" -> jsCons (head fs) ((head . tail) fs)

234− _ -> jsObj $ ("ctor:" ++ show name) : fields

235− where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs

236−

237− Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"

238− where pad = "<div style=\"height:0;width:0;\"> </div>"

239− md = formatMarkdown $ Pan.writeHtmlString Pan.def doc

240−

241−jsApp e1 e2 =

242− do f <- toJS' func

243− as <- mapM toJS' args

244− return $ case as of

245− [a] -> f ++ parens a

246− _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))

247− where

248− (func, args) = go [e2] e1

249− go args e =

250− case e of

251− (L _ _ (App e1 e2)) -> go (e2 : args) e1

252− _ -> (e, args)

253−

254−formatMarkdown = concatMap f

255− where f '\'' = "\\'"

256− f '\n' = "\\n"

257− f '"' = "\""

258− f c = [c]

259−

260−multiIfToJS span ps =

261− case last ps of

262− (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)

263− _ -> format ("_E.If" ++ parens (quoted (show span))) ps

264− where

265− format base ps =

266− foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps

267− f (b,e) = do b' <- toJS' b

268− e' <- toJS' e

269− return (b' ++ " ? " ++ e')

270−

271−jsLet defs e' = do ds <- jsDefs defs

272− e <- toJS' e'

273− return $ jsFunc "" (concat ds ++ ret e) ++ "()"

274− where

275− jsDefs defs = mapM toJS (sortBy f defs)

276− f a b = compare (valueOf a) (valueOf b)

277− valueOf (FnDef _ [] _) = 2

278− valueOf (FnDef _ _ _) = 1

279− valueOf (OpDef _ _ _ _) = 1

280− valueOf (TypeAnnotation _ _) = 0

281−

282−caseToJS span e ps = do

283− match <- caseToMatch ps

284− e' <- toJS' e

285− let (match',stmt) = case (match,e) of

286− (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")

287− (Match name _ _, _) -> (match, assign name e')

288− _ -> (match, "")

289− matches <- matchToJS span match'

290− return $ "function(){ " ++ stmt ++ matches ++ " }()"

291−

292−matchToJS span match =

293− case match of

294− Match name clauses def ->

295− do cases <- concat `liftM` mapM (clauseToJS span name) clauses

296− finally <- matchToJS span def

297− return $ concat [ "\nswitch (", name, ".ctor) {",

298− indent cases, "\n}", finally ]

299− Fail -> return ("_E.Case" ++ parens (quoted (show span)))

300− Break -> return "break;"

301− Other e -> ret `liftM` toJS' e

302− Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)

303− where

304− dropEnd acc [] = acc

305− dropEnd acc (m:ms) =

306− case m of

307− Other _ -> acc ++ [m]

308− _ -> dropEnd (acc ++ [m]) ms

309−

310−clauseToJS span var (Clause name vars e) = do

311− let vars' = map (\n -> var ++ "._" ++ show n) [0..]

312− s <- matchToJS span $ matchSubst (zip vars vars') e

313− return $ concat [ "\ncase ", quoted name, ":", indent s ]

314−

315−jsNil = "_L.Nil"

316−jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"

317−jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)

318−jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)

319−

320−binop (o:p) e1 e2

321− | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2

322− | otherwise =

323− let ops = ["+","-","*","/","&&","||"] in

324− case o:p of

325− "::" -> jsCons e1 e2

326− "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)

327− "<|" -> e1 ++ parens e2

328− "|>" -> e2 ++ parens e1

329− "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")

330− "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"

331− "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"

332− "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"

333− "<" -> jsCompare e1 e2 "==='LT'"

334− ">" -> jsCompare e1 e2 "==='GT'"

335− "<=" -> jsCompare e1 e2 "!=='GT'"

336− ">=" -> jsCompare e1 e2 "!=='LT'"

337− "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"

338− "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"

339− _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)

340− | otherwise -> concat [ "$op['", o:p, "']"

341− , parens e1, parens e2 ]

compiler/Gen/ExtractNoscript.hsdeleted−59

@@ -1,59 +0,0 @@

1−module ExtractNoscript (extractNoscript) where

2−

3−import Ast

4−import Located

5−import qualified Text.Pandoc as Pan

6−

7−extractNoscript :: Module -> String

8−extractNoscript modul = concat (extract modul)

9−

10−class Extract a where

11− extract :: a -> [String]

12−

13−instance Extract Module where

14− extract (Module _ _ _ stmts) =

15− map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)

16−

17−instance Extract Statement where

18− extract (Definition d) = extract d

19− extract _ = []

20−

21−instance Extract Def where

22− extract (FnDef _ _ e) = extract e

23− extract (OpDef _ _ _ e) = extract e

24− extract _ = []

25−

26−instance Extract e => Extract (Located e) where

27− extract (L _ _ e) = extract e

28−

29−instance Extract Expr where

30− extract expr =

31− let f = extract in

32− case expr of

33− Str s -> [s]

34− Binop op e1 e2 -> case (op, f e1, f e2) of

35− ("++", [s1], [s2]) -> [s1 ++ s2]

36− (_ , ss1 , ss2 ) -> ss1 ++ ss2

37− Lambda v e -> f e

38− App (L _ _ (App (L _ _ (Var "link")) src)) txt -> linkExtract src txt

39− App (L _ _ (App (L _ _ (Var "Text.link")) src)) txt -> linkExtract src txt

40− App (L _ _ (Var "header")) e -> tag "h1" e

41− App (L _ _ (Var "bold")) e -> tag "b" e

42− App (L _ _ (Var "italic")) e -> tag "i" e

43− App (L _ _ (Var "monospace")) e -> tag "code" e

44− App e1 e2 -> f e1 ++ f e2

45− If eb et ef -> f et ++ f ef

46− Let defs e -> concatMap extract defs ++ f e

47− Var _ -> []

48− Case e cases -> concatMap (f . snd) cases

49− Data _ es -> concatMap f es

50− Markdown doc -> [ Pan.writeHtmlString Pan.def doc ]

51− _ -> []

52−

53−linkExtract src txt =

54− case (extract src, extract txt) of

55− ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]

56− ( ss1, ss2) -> ss1 ++ ss2

57−

58−

59−tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)

compiler/Generate/Cases.hsnew file+128

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

1+module Generate.Cases (caseToMatch, Match (..), Clause (..), matchSubst) where

2+

3+import Control.Arrow (first)

4+import Control.Monad (liftM,foldM)

5+import Data.List (groupBy,sortBy,lookup)

6+import Data.Maybe (fromMaybe)

7+

8+import Unique

9+import SourceSyntax.Location

10+import SourceSyntax.Literal

11+import SourceSyntax.Pattern

12+import SourceSyntax.Expression

13+import Transform.Substitute

14+

15+caseToMatch patterns = do

16+ v <- newVar

17+ (,) v `liftM` match [v] (map (first (:[])) patterns) Fail

18+

19+newVar = do n <- guid

20+ return $ "case" ++ show n

21+

22+data Match t v

23+ = Match String [Clause t v] (Match t v)

24+ | Break

25+ | Fail

26+ | Other (LExpr t v)

27+ | Seq [Match t v]

28+ deriving Show

29+

30+data Clause t v =

31+ Clause (Either String Literal) [String] (Match t v)

32+ deriving Show

33+

34+matchSubst :: [(String,String)] -> Match t v -> Match t v

35+matchSubst _ Break = Break

36+matchSubst _ Fail = Fail

37+matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)

38+matchSubst pairs (Other (L s e)) =

39+ Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs

40+matchSubst pairs (Match n cs m) =

41+ Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

42+ where varSubst v = fromMaybe v (lookup v pairs)

43+ clauseSubst (Clause c vs m) =

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

45+

46+isCon (p:ps, e) =

47+ case p of

48+ PData _ _ -> True

49+ PLiteral _ -> True

50+ _ -> False

51+

52+isVar p = not (isCon p)

53+

54+match :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Match t v)

55+match [] [] def = return def

56+match [] [([],e)] Fail = return $ Other e

57+match [] [([],e)] Break = return $ Other e

58+match [] cs def = return $ Seq (map (Other . snd) cs ++ [def])

59+match vs@(v:_) cs def

60+ | all isVar cs' = matchVar vs cs' def

61+ | all isCon cs' = matchCon vs cs' def

62+ | otherwise = matchMix vs cs' def

63+ where

64+ cs' = map (dealias v) cs

65+

66+dealias v c@(p:ps, L s e) =

67+ case p of

68+ PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)

69+ _ -> c

70+

71+matchVar :: [String] -> [([Pattern],LExpr t v)] -> Match t v

72+ -> Unique (Match t v)

73+matchVar (v:vs) cs def = match vs (map subVar cs) def

74+ where

75+ subVar (p:ps, ce@(L s e)) = (ps, L s $ subOnePattern p e)

76+ where

77+ subOnePattern pattern e =

78+ case pattern of

79+ PVar x -> subst x (Var v) e

80+ PAnything -> e

81+ PRecord fs ->

82+ foldr (\x -> subst x (Access (L s (Var v)) x)) e fs

83+

84+matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v

85+ -> Unique (Match t v)

86+matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css

87+ where

88+ css = groupBy eq (sortBy cmp cs)

89+

90+ cmp (p1:_,_) (p2:_,_) =

91+ case (p1,p2) of

92+ (PData n1 _, PData n2 _) -> compare n1 n2

93+ _ -> compare p1 p2

94+

95+ eq (p1:_,_) (p2:_,_) =

96+ case (p1,p2) of

97+ (PData n1 _, PData n2 _) -> n1 == n2

98+ _ -> p1 == p2

99+

100+ toClause cs =

101+ case head cs of

102+ (PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break

103+ (PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break

104+

105+matchClause :: Either String Literal

106+ -> [String]

107+ -> [([Pattern],LExpr t v)]

108+ -> Match t v

109+ -> Unique (Clause t v)

110+matchClause c (v:vs) cs def =

111+ do vs' <- getVars

112+ Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def

113+ where

114+

115+ flatten (p:ps, e) =

116+ case p of

117+ PData _ ps' -> (ps' ++ ps, e)

118+ PLiteral _ -> (ps, e)

119+

120+ getVars =

121+ case head cs of

122+ (PData _ ps : _, _) -> mapM (\_ -> newVar) ps

123+ (PLiteral _ : _, _) -> return []

124+

125+matchMix :: [String] -> [([Pattern],LExpr t v)] -> Match t v

126+ -> Unique (Match t v)

127+matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

128+ where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

compiler/Gen/GenerateHtml.hs → compiler/Generate/Html.hsrenamed+10−13

@@ -1,13 +1,12 @@

11{-# LANGUAGE OverloadedStrings #-}

2−module GenerateHtml (generateHtml,

3− createHtml,

4− JSStyle (..),

5− JSSource (..)

6− ) where

2+module Generate.Html

3+ (generateHtml,

4+ createHtml,

5+ JSStyle (..),

6+ JSSource (..)

7+ ) where

78

8−import Data.List (intercalate)

99import Text.Blaze (preEscapedToMarkup)

10−import Text.Blaze.Html (Html)

1110import qualified Text.Blaze.Html5 as H

1211import Text.Blaze.Html5 ((!))

1312import qualified Text.Blaze.Html5.Attributes as A

@@ -15,11 +14,9 @@ import qualified Text.Blaze.Html5.Attributes as A

1514import Text.Jasmine (minify)

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

1716

18−import Ast

1917import Initialize (buildFromSource)

20−import CompileToJS

21−import ExtractNoscript

22−import Libraries as Libraries

18+import Generate.JavaScript

19+import Generate.Noscript

2320

2421data JSStyle = Minified | Readable

2522data JSSource = Link String | Source JSStyle String

@@ -42,7 +39,7 @@ makeScript source =

4239generateHtml :: String -- ^ Location of elm-runtime.js as expected by the browser

4340 -> String -- ^ The page title

4441 -> String -- ^ The elm source code.

45− -> Html

42+ -> H.Html

4643generateHtml libLoc title source = H.span "broken for now"

4744{--

4845 case buildFromSource True source of

@@ -62,7 +59,7 @@ modulesToHtml libLoc title scripts nscrpt modules =

6259 where Module names _ _ _ = last modules

6360--}

6461

65−createHtml :: FilePath -> String -> [JSSource] -> String -> Html

62+createHtml :: FilePath -> String -> [JSSource] -> String -> H.Html

6663createHtml libLoc title scripts noscript =

6764 H.docTypeHtml $ do

6865 H.head $ do

compiler/Generate/JavaScript.hsnew file+368

@@ -0,0 +1,368 @@

1+module Generate.JavaScript (showErr, jsModule) where

2+

3+import Control.Arrow (first,second)

4+import Control.Monad (liftM,(<=<),join,ap)

5+import Data.Char (isAlpha,isDigit)

6+import qualified Data.List as List

7+import qualified Data.Map as Map

8+import qualified Data.Set as Set

9+import Data.Either (partitionEithers)

10+import qualified Text.Pandoc as Pan

11+

12+import Unique

13+import Generate.Cases

14+import SourceSyntax.Everything

15+import SourceSyntax.Location

16+import qualified Transform.SortDefinitions as SD

17+

18+deprime :: String -> String

19+deprime = map (\c -> if c == '\'' then '$' else c)

20+

21+showErr :: String -> String

22+showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)

23+ where msg = show . concatMap (++"<br>") . lines $ err

24+ body = "var T = Elm.Text(elm);\n\

25+ \return { main : T.text(T.monospace(" ++ msg ++ ")) };"

26+

27+indent = concatMap f

28+ where f '\n' = "\n "

29+ f c = [c]

30+

31+internalImports name =

32+ [ ("N" , "Elm.Native"),

33+ ("_N", "N.Utils(elm)"),

34+ ("_L", "N.List(elm)"),

35+ ("_E", "N.Error(elm)"),

36+ ("_J", "N.JavaScript(elm)"),

37+ ("_str", "_J.toString"),

38+ ("$moduleName", quoted name)

39+ ]

40+

41+parens s = "(" ++ s ++ ")"

42+brackets s = "{" ++ s ++ "}"

43+commaSep = List.intercalate ", "

44+dotSep = List.intercalate "."

45+jsObj = brackets . commaSep

46+jsList ss = "["++ List.intercalate "," ss ++"]"

47+jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"

48+assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"

49+ret e = "\nreturn "++ e ++";"

50+quoted s = "'" ++ concatMap f s ++ "'"

51+ where f '\n' = "\\n"

52+ f '\'' = "\\'"

53+ f '\t' = "\\t"

54+ f '\"' = "\\\""

55+ f '\\' = "\\\\"

56+ f c = [c]

57+

58+globalAssign n e = "\n" ++ assign' n e ++ ";"

59+assign' n e = n ++ " = " ++ e

60+

61+jsModule :: MetadataModule t v -> String

62+jsModule modul =

63+ run $ do

64+ body <- toJS . fst . SD.flattenLets [] $ program modul

65+ foreignImport <- mapM importEvent (foreignImports modul)

66+ return $ concat [ setup ("Elm": names modul)

67+ , globalAssign ("Elm." ++ modName)

68+ (jsFunc "elm" $ makeProgram body foreignImport) ]

69+ where

70+ modName = dotSep (names modul)

71+ makeProgram body foreignImport =

72+ concat [ "\nvar " ++ usefulFuncs ++ ";"

73+ , concatMap jsImport (imports modul)

74+ , concat foreignImport

75+ , assign "_op" "{}"

76+ , body

77+ , concatMap exportEvent $ foreignExports modul

78+ , jsExports

79+ ]

80+ setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .

81+ map dotSep . drop 2 . List.inits $ init names

82+ usefulFuncs = commaSep (map (uncurry assign') (internalImports modName))

83+

84+ jsExports = setup ("elm" : names modul) ++

85+ ret (assign' ("elm." ++ modName) (brackets exs))

86+ where

87+ exs = indent . commaSep . concatMap (pair . deprime) $ "_op" : exports modul

88+ pair x | isOp x = []

89+ | otherwise = ["\n" ++ x ++ " : " ++ x]

90+

91+

92+ importEvent (js,base,elm,_) =

93+ do v <- toJS' base

94+ return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"

95+ , "\ndocument.addEventListener('", js

96+ , "_' + elm.id, function(e) { elm.notify(", elm

97+ , ".id, e.value); });" ]

98+

99+ exportEvent (js,elm,_) =

100+ concat [ "\nA2( Signal.lift, function(v) { "

101+ , "var e = document.createEvent('Event');"

102+ , "e.initEvent('", js, "_' + elm.id, true, true);"

103+ , "e.value = v;"

104+ , "document.dispatchEvent(e); return v; }, ", elm, ");" ]

105+

106+jsImport (modul, method) =

107+ concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values

108+ where

109+ starters = "\nvar " : repeat "\n"

110+ values = map (\name -> name ++ " || {}") (init subnames) ++

111+ ["Elm." ++ modul ++ parens "elm"]

112+ subnames = map dotSep . tail . List.inits $ split modul

113+

114+ split names = case go [] names of

115+ (name, []) -> [name]

116+ (name, ns) -> name : split ns

117+ go name str = case str of

118+ '.':rest -> (reverse name, rest)

119+ c:rest -> go (c:name) rest

120+ [] -> (reverse name, [])

121+

122+

123+class ToJS a where

124+ toJS :: a -> Unique String

125+

126+

127+instance ToJS (Def t v) where

128+

129+ -- TODO: Make this handle patterns besides plain variables

130+ toJS (Def (PVar x) e)

131+ | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e

132+ | otherwise = assign (deprime x) `liftM` toJS' e

133+

134+ toJS (Def pattern e@(L s _)) =

135+ do n <- guid

136+ let x = "_" ++ show n

137+ var = L s . Var

138+ toDef y' = let y = deprime y' in

139+ Def (PVar y) (L s $ Case (var x) [(pattern, var y)])

140+ stmt <- assign x `liftM` toJS' e

141+ vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern

142+ return (stmt ++ vars)

143+

144+ toJS (TypeAnnotation _ _) = return ""

145+

146+

147+instance ToJS a => ToJS [a] where

148+ toJS xs = concat `liftM` mapM toJS xs

149+

150+toJS' :: LExpr t v -> Unique String

151+toJS' (L span expr) =

152+ case expr of

153+ MultiIf ps -> multiIfToJS span ps

154+ Case e cases -> caseToJS span e cases

155+ _ -> toJS expr

156+

157+remove x e = "_N.remove('" ++ deprime x ++ "', " ++ e ++ ")"

158+addField x v e = "_N.insert('" ++ deprime x ++ "', " ++ v ++ ", " ++ e ++ ")"

159+setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"

160+ where f (x,v) = "['" ++ deprime x ++ "'," ++ v ++ "]"

161+access x e = e ++ "." ++ deprime x

162+makeRecord kvs = record `liftM` collect kvs

163+ where

164+ combine r (k,v) = Map.insertWith (++) k v r

165+ collect = liftM (List.foldl' combine Map.empty) . mapM prep

166+ prep (k, e) =

167+ do v <- toJS' e

168+ return (deprime k, [v])

169+ fields fs =

170+ brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))

171+ hidden = fields . map (second jsList) .

172+ filter (not . null . snd) . Map.toList . Map.map tail

173+ record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs

174+

175+

176+instance ToJS Literal where

177+ toJS lit =

178+ case lit of

179+ Chr c -> return $ quoted [c]

180+ Str s -> return $ "_str" ++ parens (quoted s)

181+ IntNum n -> return $ show n

182+ FloatNum n -> return $ show n

183+ Boolean b -> return $ if b then "true" else "false"

184+

185+

186+instance ToJS (Expr t v) where

187+ toJS expr =

188+ case expr of

189+ Var x -> return (deprime x)

190+ Literal lit -> toJS lit

191+ Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi

192+ Access e x -> access x `liftM` toJS' e

193+ Remove e x -> remove x `liftM` toJS' e

194+ Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e

195+ Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)

196+ setField fs' `liftM` toJS' e

197+ Record fs -> makeRecord fs

198+ Binop op e1 e2 -> binop op e1 e2

199+

200+ Lambda p e@(L s _) -> liftM (fastFunc . ret) (toJS' body)

201+ where

202+ fastFunc body

203+ | length args < 2 || length args > 9 = foldr jsFunc body args

204+ | otherwise = "F" ++ show (length args) ++ parens (jsFunc (commaSep args) body)

205+ (args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])

206+

207+ depattern (pattern,n) (args, body) =

208+ case pattern of

209+ PVar x -> (deprime x : args, body)

210+ _ -> let arg = "arg" ++ show n

211+ in (arg:args, L s (Case (L s (Var arg)) [(pattern, body)]))

212+

213+ (patterns, innerBody) = collect [p] e

214+

215+ collect patterns lexpr@(L _ expr) =

216+ case expr of

217+ Lambda p e -> collect (p:patterns) e

218+ _ -> (patterns, lexpr)

219+

220+ App e1 e2 -> jsApp e1 e2

221+ Let defs e -> jsLet $ SD.flattenLets defs e

222+

223+ ExplicitList es ->

224+ do es' <- mapM toJS' es

225+ return $ "_J.toList" ++ parens (jsList es')

226+

227+ Data name es ->

228+ do fs <- mapM toJS' es

229+ return $ case name of

230+ "[]" -> jsNil

231+ "::" -> jsCons (head fs) ((head . tail) fs)

232+ _ -> jsObj $ ("ctor:" ++ show name) : fields

233+ where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs

234+

235+ Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"

236+ where pad = "<div style=\"height:0;width:0;\"> </div>"

237+ md = formatMarkdown $ Pan.writeHtmlString Pan.def doc

238+

239+jsApp e1 e2 =

240+ do f <- toJS' func

241+ as <- mapM toJS' args

242+ return $ case as of

243+ [a] -> f ++ parens a

244+ _ -> "A" ++ show (length as) ++ parens (commaSep (f:as))

245+ where

246+ (func, args) = go [e2] e1

247+ go args e =

248+ case e of

249+ (L _ (App e1 e2)) -> go (e2 : args) e1

250+ _ -> (e, args)

251+

252+formatMarkdown = concatMap f

253+ where f '\'' = "\\'"

254+ f '\n' = "\\n"

255+ f '"' = "\""

256+ f c = [c]

257+

258+multiIfToJS span ps =

259+ case last ps of

260+ (L _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)

261+ _ -> format ("_E.If" ++ parens ("$moduleName," ++ quoted (show span))) ps

262+ where

263+ format base ps =

264+ foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps

265+ f (b,e) = do b' <- toJS' b

266+ e' <- toJS' e

267+ return (b' ++ " ? " ++ e')

268+

269+jsLet (defs,e') = do ds <- mapM toJS defs

270+ e <- toJS' e'

271+ return $ jsFunc "" (concat ds ++ ret e) ++ "()"

272+

273+caseToJS span e ps = do

274+ (tempVar,match) <- caseToMatch ps

275+ e' <- toJS' e

276+ let (match',stmt) = case e of

277+ L _ (Var x) -> (matchSubst [(tempVar,deprime x)] match, "")

278+ _ -> (match, assign tempVar e')

279+ matches <- matchToJS span match'

280+ return $ jsFunc "" (stmt ++ matches) ++ "()"

281+

282+matchToJS span match =

283+ case match of

284+ Match name clauses def ->

285+ do cases <- concat `liftM` mapM (clauseToJS span name) clauses

286+ finally <- matchToJS span def

287+ let isLiteral p = case p of

288+ Clause (Right _) _ _ -> True

289+ _ -> False

290+ access = if any isLiteral clauses then "" else ".ctor"

291+ return $ concat [ "\nswitch (", name, access, ") {"

292+ , indent cases, "\n}", finally ]

293+ Fail -> return ("_E.Case" ++ parens ("$moduleName," ++ quoted (show span)))

294+ Break -> return "break;"

295+ Other e -> ret `liftM` toJS' e

296+ Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)

297+ where

298+ dropEnd acc [] = acc

299+ dropEnd acc (m:ms) =

300+ case m of

301+ Other _ -> acc ++ [m]

302+ _ -> dropEnd (acc ++ [m]) ms

303+

304+clauseToJS span var (Clause value vars e) = do

305+ let vars' = map (\n -> var ++ "._" ++ show n) [0..]

306+ s <- matchToJS span $ matchSubst (zip vars vars') e

307+ return $ concat [ "\ncase ", case value of

308+ Right (Boolean True) -> "true"

309+ Right (Boolean False) -> "false"

310+ Right lit -> show lit

311+ Left name -> quoted $ case List.elemIndices '.' name of

312+ [] -> name

313+ is -> drop (last is + 1) name

314+ , ":", indent s ]

315+

316+jsNil = "_L.Nil"

317+jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"

318+jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)

319+jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)

320+

321+

322+binop op e1 e2

323+ | op == "Basics.." =

324+ do ss <- mapM toJS' (e1 : collect [] e2)

325+ return . jsFunc "$" . ret $ apply "$" ss

326+ | op == "Basics.<|" =

327+ do arg <- toJS' e2

328+ funcs <- mapM toJS' (collect [] e1)

329+ return (apply arg funcs)

330+ | otherwise =

331+ binopNormal op `liftM` toJS' e1 `ap` toJS' e2

332+ where

333+ apply = foldr (\f arg-> f ++ parens arg)

334+

335+ collect es e =

336+ case e of

337+ L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2

338+ _ -> es ++ [e]

339+

340+binopNormal op s1 s2 =

341+ case Map.lookup op opDict of

342+ Just e -> e

343+ Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, s1, s2 ])

344+ where

345+ func | isOp op' = "_op['" ++ op' ++ "']"

346+ | otherwise = op'

347+ (prefix, op') = case List.elemIndices '.' op of

348+ [] -> ("", op)

349+ xs -> splitAt (last xs + 1) op

350+

351+ opDict = Map.fromList $ basics ++

352+ [ ("::", jsCons s1 s2)

353+ , ("List.++", "_L.append" ++ parens (s1 ++ "," ++ s2)) ]

354+

355+ ops = pow : map (\op -> (op, parens (s1 ++ op ++ s2))) ["+","-","*","/","&&","||"]

356+ where pow = ("^" , "Math.pow(" ++ s1 ++ "," ++ s2 ++ ")")

357+

358+ basics = ops ++ map (\(op,e) -> ("Basics." ++ op, e))

359+ (ops ++ [ ("<|", s1 ++ parens s2)

360+ , ("|>", s2 ++ parens s1)

361+ , ("==", "_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")

362+ , ("/=", "!_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")

363+ , ("<" , jsCompare s1 s2 "<0")

364+ , (">" , jsCompare s1 s2 ">0")

365+ , ("<=", jsCompare s1 s2 "<1")

366+ , (">=", jsCompare s1 s2 ">-1")

367+ , ("div", parens (s1 ++ "/" ++ s2 ++ "|0"))

368+ ])

compiler/Generate/Noscript.hsnew file+65

@@ -0,0 +1,65 @@

1+module Generate.Noscript (noscript) where

2+

3+import Data.List (isInfixOf)

4+import SourceSyntax.Everything

5+import qualified Text.Pandoc as Pan

6+

7+noscript :: Module t v -> String

8+noscript modul = concat (extract modul)

9+

10+class Extract a where

11+ extract :: a -> [String]

12+

13+instance Extract (Module t v) where

14+ extract (Module _ _ _ stmts) =

15+ map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)

16+

17+instance Extract (Declaration t v) where

18+ extract (Definition d) = extract d

19+ extract _ = []

20+

21+instance Extract (Def t v) where

22+ extract (Def _ e) = extract e

23+ extract _ = []

24+

25+instance Extract e => Extract (Located e) where

26+ extract (L _ e) = extract e

27+

28+instance Extract (Expr t v) where

29+ extract expr =

30+ let f = extract in

31+ case expr of

32+ Literal (Str s) -> [s]

33+ Binop op e1 e2 -> case (op, f e1, f e2) of

34+ ("++", [s1], [s2]) -> [s1 ++ s2]

35+ (_ , ss1 , ss2 ) -> ss1 ++ ss2

36+ Lambda v e -> f e

37+ App (L _ (App (L _ (App (L _ (Var func)) w)) h)) src

38+ | "image" `isInfixOf` func -> extractImage src

39+ App (L _ (App (L _ (Var func)) src)) txt

40+ | "link" `isInfixOf` func -> extractLink src txt

41+ App (L _ (Var func)) e

42+ | "header" `isInfixOf` func -> tag "h1" e

43+ | "bold" `isInfixOf` func -> tag "b" e

44+ | "italic" `isInfixOf` func -> tag "i" e

45+ | "monospace" `isInfixOf` func -> tag "code" e

46+ App e1 e2 -> f e1 ++ f e2

47+ Let defs e -> concatMap extract defs ++ f e

48+ Var _ -> []

49+ Case e cases -> concatMap (f . snd) cases

50+ Data _ es -> concatMap f es

51+ MultiIf es -> concatMap (f . snd) es

52+ Markdown doc -> [ Pan.writeHtmlString Pan.def doc ]

53+ _ -> []

54+

55+extractLink src txt =

56+ case (extract src, extract txt) of

57+ ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]

58+ ( ss1, ss2) -> ss1 ++ ss2

59+

60+extractImage src =

61+ case extract src of

62+ [s] -> ["<img src=\"" ++ s ++ "\">"]

63+ ss -> ss

64+

65+tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)

compiler/Initialize.hs+87−64

@@ -1,80 +1,103 @@

1−module Initialize (buildFromSource, getSortedModuleNames) where

1+module Initialize (buildFromSource, getSortedDependencies) where

22

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

4−import Control.Monad.Error

5−import Data.List (lookup,nub)

3+import Data.Data

4+import Control.Monad.State

5+import qualified Data.Graph as Graph

6+import qualified Data.List as List

67import qualified Data.Map as Map

7−

8−import Ast

9−import Data.Either (lefts,rights)

10−import Data.List (intercalate,partition)

11−import Parse.Parser (parseProgram, parseDependencies)

12−import Rename

13−import qualified Libraries as Libs

14−import Types.Types ((-:))

15−import Types.Hints (hints)

16−import Types.Unify (unify)

17−import Types.Alias (dealias, mistakes)

18−import Optimize

8+import qualified Data.Set as Set

199import System.Exit

20−import System.FilePath

10+import System.FilePath as FP

11+import Text.PrettyPrint (Doc)

12+

13+import SourceSyntax.Everything

14+import SourceSyntax.Type

15+import qualified Parse.Parse as Parse

16+import qualified Metadata.Prelude as Prelude

17+import qualified Transform.Check as Check

18+import qualified Transform.SortDefinitions as SD

19+import qualified Type.Inference as TI

20+import qualified Type.Constrain.Declaration as TcDecl

21+import qualified Transform.Canonicalize as Canonical

22+

23+buildFromSource :: Bool -> Interfaces -> String -> Either [Doc] (MetadataModule () ())

24+buildFromSource noPrelude interfaces source =

25+ do let add = if noPrelude then id else Prelude.add

26+ modul@(Module _ _ _ decls') <- add `fmap` Parse.program source

27+

28+ -- check for structural errors

29+ Module names exs ims decls <-

30+ case Check.mistakes decls' of

31+ [] -> return modul

32+ ms -> Left ms

2133

22−checkMistakes :: Module -> Either String Module

23−checkMistakes modul@(Module name ex im stmts) =

24− case mistakes stmts of

25− m:ms -> Left (unlines (m:ms))

26− [] -> return modul

34+ let exports'

35+ | null exs =

36+ let get = Set.toList . SD.boundVars in

37+ concat [ get pattern | Definition (Def pattern _) <- decls ] ++

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

39+ | otherwise = exs

2740

28−checkTypes :: Module -> Either String Module

29−checkTypes modul =

30− do subs <- unify hints modul

31− subs `seq` return (optimize (renameModule modul))

41+ metaModule <- Canonical.metadataModule interfaces $ MetadataModule {

42+ names = names,

43+ path = FP.joinPath names,

44+ exports = exports',

45+ imports = ims,

46+ -- reorder AST into strongly connected components

47+ program = SD.sortDefs . dummyLet $ TcDecl.toExpr decls,

48+ types = Map.empty,

49+ datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],

50+ fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],

51+ aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],

52+ foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],

53+ foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]

54+ }

3255

33−check :: Module -> Either String Module

34−check = checkMistakes >=> checkTypes

56+ types <- TI.infer interfaces metaModule

3557

36−buildFromSource :: Bool -> String -> Either String Module

37−buildFromSource noPrelude src =

38− let add = if noPrelude then id else Libs.addPrelude in

39− (check . add) =<< (parseProgram src)

58+ return $ metaModule { types = types }

4059

41−getSortedModuleNames :: FilePath -> IO [String]

42−getSortedModuleNames root =

43− sortDeps =<< readDeps [] root

4460

45−type Deps = (String, [String])

61+getSortedDependencies :: Bool -> FilePath -> IO [String]

62+getSortedDependencies noPrelude root =

63+ sortDeps =<< readDeps noPrelude root

64+

65+type Deps = (FilePath, String, [String])

4666

4767sortDeps :: [Deps] -> IO [String]

48−sortDeps deps = go [] (nub deps)

49− where

50− msg = "A cyclical or missing module dependency or was detected in: "

51−

52− go :: [String] -> [Deps] -> IO [String]

53− go sorted [] = return (map toFilePath sorted)

54− go sorted unsorted =

55− case partition (all (`elem` sorted) . snd) unsorted of

56− ([],m:ms) -> do putStrLn (msg ++ intercalate ", " (map fst (m:ms)) ++ show sorted ++ show unsorted)

57− exitFailure

58− (srtd,unsrtd) -> go (sorted ++ map fst srtd) unsrtd

59−

60−readDeps :: [FilePath] -> FilePath -> IO [Deps]

61−readDeps seen root = do

62− txt <- readFile root

63− case parseDependencies txt of

64− Left err ->

65− let msg = "Error resolving dependencies in " ++ root ++ ":\n" in

66− putStrLn (msg ++ err) >> exitFailure

67− Right (name,deps) ->

68− do rest <- mapM (readDeps seen' . toFilePath) newDeps

69− return ((name, realDeps) : concat rest)

70− where

71− realDeps = filter (`notElem` builtIns) deps

72− newDeps = filter (\d -> d `notElem` seen && not (isNative d)) realDeps

73− seen' = root : seen ++ newDeps

74− builtIns = Map.keys Libs.libraries

68+sortDeps depends =

69+ if null mistakes

70+ then return (concat sccs)

71+ else print msg >> mapM print mistakes >> exitFailure

72+ where

73+ sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends

74+

75+ mistakes = filter (\scc -> length scc > 1) sccs

76+ msg = "A cyclical module dependency or was detected in: "

77+

78+readDeps :: Bool -> FilePath -> IO [Deps]

79+readDeps noPrelude root = evalStateT (go root) Set.empty

80+ where

81+ builtIns = if noPrelude then Set.empty

82+ else Set.fromList (Map.keys Prelude.interfaces)

83+

84+ go :: FilePath -> StateT (Set.Set String) IO [Deps]

85+ go root = do

86+ txt <- liftIO $ readFile root

87+ case Parse.dependencies txt of

88+ Left err -> liftIO (putStrLn msg >> print err >> exitFailure)

89+ where msg = "Error resolving dependencies in " ++ root ++ ":"

90+

91+ Right (name,deps) ->

92+ do seen <- get

93+ let realDeps = Set.difference (Set.fromList deps) builtIns

94+ newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen

95+ put (Set.insert name (Set.union newDeps seen))

96+ rest <- mapM (go . toFilePath) (Set.toList newDeps)

97+ return ((makeRelative "." root, name, Set.toList realDeps) : concat rest)

7598

7699

77−isNative name = takeWhile (/='.') name == "Native"

100+isNative name = List.isPrefixOf "Native." name

78101

79102toFilePath :: String -> FilePath

80103toFilePath name = map swapDots name ++ ext

compiler/Language/Elm.hs+22−21

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

11{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

22{- | This module exports the functions necessary for compiling Elm code into the

3− respective HTML, JS and CSS code.

4−

5− The type class @'ElmSource'@ requires an instance for all types that the Elm

6− compiler understands. The provided instances for String, Text and QuasiQuoted

7− Elm source code should be sufficient.

3+ respective HTML, CSS, and JS code.

84

95 The documentation for the Elm language is available at

106 <http://elm-lang.org/Documentation.elm>, and many interactive examples are

@@ -15,33 +11,39 @@

1511-}

1612module Language.Elm (compile, toHtml, moduleName, runtime, docs) where

1713

18−import Data.List (intercalate)

14+import qualified Data.List as List

15+import qualified Data.Map as Map

1916import Data.Version (showVersion)

20−import CompileToJS (showErr, jsModule)

21−import GenerateHtml (generateHtml)

17+import Generate.JavaScript (showErr, jsModule)

18+import Generate.Html (generateHtml)

2219import Initialize (buildFromSource)

23−import Parse.Library

24−import Parse.Modules (moduleDef)

20+import Parse.Helpers

21+import Parse.Module (moduleDef)

22+import SourceSyntax.Module

2523import Text.Blaze.Html (Html)

2624import Text.Parsec (option,optional)

25+import qualified Text.PrettyPrint as P

26+import qualified Metadata.Prelude as Prelude

2727import Paths_Elm

2828

29−-- |This function compiles Elm code to JavaScript.

30−compile :: String -> String

31−compile source = either showErr jsModule modul

32− where

33− modul = buildFromSource True source

29+-- |This function compiles Elm code to JavaScript. It will return either

30+-- an error message or the compiled JS code.

31+compile :: String -> Either String String

32+compile source =

33+ case buildFromSource False Prelude.interfaces source of

34+ Left docs -> Left . unlines . List.intersperse "" $ map P.render docs

35+ Right modul -> Right $ jsModule (modul :: MetadataModule () ())

3436

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

36−moduleName :: String -> String

38+moduleName :: String -> Maybe String

3739moduleName source = case iParse getModuleName "" source of

38− Right name -> name

39− Left _ -> "Main"

40+ Right name -> Just name

41+ Left _ -> Nothing

4042 where

4143 getModuleName = do

4244 optional freshLine

43− (names, _) <- option (["Main"],[]) moduleDef

44− return (intercalate "." names)

45+ (names, _) <- moduleDef

46+ return (List.intercalate "." names)

4547

4648-- |This function compiles Elm code into a full HTML page.

4749toHtml :: String -- ^ Location of elm-min.js as expected by the browser

@@ -57,4 +59,3 @@ runtime = getDataFileName "elm-runtime.js"

5759-- |The absolute path to Elm's core library documentation.

5860docs :: IO FilePath

5961docs = getDataFileName "docs.json"

60−

compiler/Language/Elm/DevTools.hsnew file+46

@@ -0,0 +1,46 @@

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/Language/Elm/Quasi.hsdeleted−96

@@ -1,96 +0,0 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE CPP #-}

5−{-# OPTIONS_GHC -fno-warn-missing-fields #-}

6−

7−-- | This module contains Shakespearean (see "Text.Shakespeare") templates

8−-- for Elm. It introduces type-safe compile-time variable and URL

9−-- interpolation. A typeclass @'ToElm'@ is provided for interpolated

10−-- variables.

11−--

12−-- Further reading on Shakespearean templates:

13−-- <http://www.yesodweb.com/book/templates>

14−--

15−-- Further reading on Elm: <http://elm-lang.org>

16−module Language.Elm.Quasi

17− ( -- * Functions

18− -- ** Template-Reading Functions

19− -- |These QuasiQuoters return functions of the type @(t -> 'Elm')@

20− -- where @t@ is the URL rendering function if type-safe URLs are used.

21− --

22− -- A usage example for both type-safe (Yesod) and standard path segment

23− -- (Happstack) URLs is provided in the Examples folder in the Git

24− -- repository.

25− elm

26− , elmFile

27− , elmFileReload

28−

29− -- * Datatypes

30− , Elm (..)

31−

32− -- * Typeclass for interpolated variables

33− , ToElm (..)

34−

35− -- ** Rendering Functions

36− , renderElm

37−

38− ) where

39−

40−import Language.Haskell.TH.Quote (QuasiQuoter (..))

41−import Language.Haskell.TH.Syntax

42−import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText)

43−import Data.Monoid

44−import qualified Data.Text as TS

45−import qualified Data.Text.Lazy as TL

46−import Text.Shakespeare

47−

48−-- | Render Elm to lazy Text.

49−renderElm :: Elm -> TL.Text

50−renderElm (Elm b) = toLazyText b

51−

52−-- | Newtype wrapper of 'Builder'.

53−newtype Elm = Elm { unElm :: Builder }

54− deriving Monoid

55−

56−-- | A typeclass for types that can be interpolated in Elm templates.

57−class ToElm a where

58− toElm :: a -> Builder

59−instance ToElm [Char] where toElm = fromLazyText . TL.pack

60−instance ToElm TS.Text where toElm = fromText

61−instance ToElm TL.Text where toElm = fromLazyText

62−

63−elmSettings :: Q ShakespeareSettings

64−elmSettings = do

65− toJExp <- [|toElm|]

66− wrapExp <- [|Elm|]

67− unWrapExp <- [|unElm|]

68− return $ defaultShakespeareSettings { toBuilder = toJExp

69− , wrap = wrapExp

70− , unwrap = unWrapExp

71− }

72−

73−-- |QuasiQuoter for embedding Elm code inside of Haskell code.

74−--

75−-- Usage:

76−-- @[elm|main = plaintext \"Some elm code\"|]@

77−elm :: QuasiQuoter

78−elm = QuasiQuoter { quoteExp = \s -> do

79− rs <- elmSettings

80− quoteExp (shakespeare rs) s

81− }

82−

83−-- |A Template Haskell function for embedding Elm code from external

84−-- .elm files.

85−--

86−-- Usage:

87−-- @$(elmFile \"elm_source/index.elm\")@

88−elmFile :: FilePath -> Q Exp

89−elmFile fp = do

90− rs <- elmSettings

91− shakespeareFile rs fp

92−

93−elmFileReload :: FilePath -> Q Exp

94−elmFileReload fp = do

95− rs <- elmSettings

96− shakespeareFileReload rs fp

compiler/Metadata/Prelude.hsnew file+51

@@ -0,0 +1,51 @@

1+module Metadata.Prelude (interfaces, add) where

2+

3+import qualified Data.Map as Map

4+import qualified Control.Exception as E

5+import qualified Paths_Elm as Path

6+import System.Directory

7+import System.Exit

8+import System.FilePath

9+import System.IO.Unsafe (unsafePerformIO)

10+import SourceSyntax.Module

11+import qualified Data.Binary as Binary

12+

13+

14+add :: Module t v -> Module t v

15+add (Module name exs ims stmts) = Module name exs (customIms ++ ims) stmts

16+ where

17+ customIms = concatMap addModule prelude

18+

19+ addModule (n, method) = case lookup n ims of

20+ Nothing -> [(n, method)]

21+ Just (As m) -> [(n, method)]

22+ Just _ -> []

23+

24+prelude :: [(String, ImportMethod)]

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

26+ where

27+ text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]

28+ modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"

29+ , "Graphics.Element", "Color", "Graphics.Collage" ]

30+

31+{-# NOINLINE interfaces #-}

32+interfaces :: Interfaces

33+interfaces =

34+ unsafePerformIO (safeReadDocs =<< Path.getDataFileName "interfaces.data")

35+

36+safeReadDocs :: FilePath -> IO Interfaces

37+safeReadDocs name =

38+ E.catch (readDocs name) $ \err -> do

39+ let _ = err :: IOError

40+ putStrLn $ unlines [ "Error reading types for standard library!"

41+ , " The file should be at " ++ name

42+ , " If you are using a stable version of Elm,"

43+ , " please report an issue at github.com/evancz/Elm"

44+ , " and specify your versions of Elm and your OS" ]

45+ exitFailure

46+

47+readDocs :: FilePath -> IO Interfaces

48+readDocs name = do

49+ exists <- doesFileExist name

50+ if exists then Map.fromList `fmap` Binary.decodeFile name

51+ else ioError . userError $ "File Not Found"

compiler/Model/Ast.hsdeleted−156

@@ -1,156 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−module Ast where

3−

4−import Located

5−import Data.Char (isDigit, isSymbol)

6−import Data.List (intercalate)

7−import Types.Types

8−import qualified Text.Pandoc as Pandoc

9−import Data.Data

10−

11−data Module = Module [String] Exports Imports [Statement]

12− deriving Show

13−

14−type Exports = [String]

15−

16−type Imports = [(String, ImportMethod)]

17−data ImportMethod = As String | Importing [String] | Hiding [String]

18− deriving (Eq, Ord, Show, Data, Typeable)

19−

20−

21−data Pattern = PData String [Pattern]

22− | PRecord [String]

23− | PVar String

24− | PAnything

25− deriving (Eq, Data, Typeable)

26−

27−type CExpr = Located Expr

28−data Expr = IntNum Int

29− | FloatNum Float

30− | Chr Char

31− | Str String

32− | Boolean Bool

33− | Range CExpr CExpr

34− | Access CExpr String

35− | Remove CExpr String

36− | Insert CExpr String CExpr

37− | Modify CExpr [(String,CExpr)]

38− | Record [(String,[String],CExpr)]

39− | Binop String CExpr CExpr

40− | Lambda String CExpr

41− | App CExpr CExpr

42− | If CExpr CExpr CExpr

43− | MultiIf [(CExpr,CExpr)]

44− | Let [Def] CExpr

45− | Var String

46− | Case CExpr [(Pattern,CExpr)]

47− | Data String [CExpr]

48− | Markdown Pandoc.Pandoc

49− deriving (Eq, Data, Typeable)

50−

51−data Def = FnDef String [String] CExpr

52− | OpDef String String String CExpr

53− | TypeAnnotation String Type

54− deriving (Eq, Data, Typeable)

55−

56−data Statement = Definition Def

57− | Datatype String [X] [(String,[Type])]

58− | TypeAlias String [X] Type

59− | ImportEvent String CExpr String Type

60− | ExportEvent String String Type

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

62−

63−cons h t = epos h t (Data "Cons" [h,t])

64−nil = L (Just "[]") NoSpan (Data "Nil" [])

65−list = foldr cons nil

66−tuple es = Data ("Tuple" ++ show (length es)) es

67−

68−delist (L _ _ (Data "Cons" [h,t])) = h : delist t

69−delist _ = []

70−

71−

72−pcons h t = PData "Cons" [h,t]

73−pnil = PData "Nil" []

74−plist = foldr pcons pnil

75−ptuple es = PData ("Tuple" ++ show (length es)) es

76−

77−brkt s = "{ " ++ s ++ " }"

78−parensIf b s = if b then parens s else s

79−isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"

80−

81−instance Show Pattern where

82− show p =

83− case p of

84− PRecord fs -> brkt (intercalate ", " fs)

85− PVar x -> x

86− PAnything -> "_"

87− PData "Cons" [hd@(PData "Cons" _),tl] ->

88− parens (show hd) ++ " :: " ++ show tl

89− PData "Cons" [hd,tl] -> show hd ++ " : " ++ show tl

90− PData "Nil" [] -> "[]"

91− PData name ps ->

92− if take 5 name == "Tuple" && all isDigit (drop 5 name) then

93− parens . intercalate ", " $ map show ps

94− else parensIf (not (null ps)) $ unwords (name : map show ps)

95−

96−instance Show Expr where

97− show e =

98− let show' (L _ _ e) = parensIf (needsParens e) (show e) in

99− case e of

100− IntNum n -> show n

101− FloatNum n -> show n

102− Chr c -> show c

103− Str s -> show s

104− Boolean b -> show b

105− Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"

106− Access e x -> show' e ++ "." ++ x

107− Remove e x -> brkt (show e ++ " - " ++ x)

108− Insert (L _ _ (Remove e y)) x v ->

109− brkt (show e ++ " - " ++ y ++ " | " ++ x ++ " = " ++ show v)

110− Insert e x v -> brkt (show e ++ " | " ++ x ++ " = " ++ show v)

111− Modify e fs -> brkt (show e ++" | "++ intercalate ", " (map field fs))

112− where field (x,e) = x ++ " <- " ++ show e

113− Record r -> brkt (intercalate ", " (map fields r))

114− where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e

115− Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2

116− Lambda x e -> let (xs,e') = getLambdas (notLocated $ Lambda x e) in

117− concat [ "\\", intercalate " " xs, " -> ", show e' ]

118− App e1 e2 -> show' e1 ++ " " ++ show' e2

119− If e1 e2 e3 -> concat [ "if ", show e1, " then ", show e2, " else ", show e3 ]

120− MultiIf (p:ps) -> concat [ "if | ", iff p, sep (map iff ps) ]

121− where iff (b,e) = show b ++ " -> " ++ show e

122− sep = concatMap ("\n | " ++)

123− Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e

124− Var (c:cs) -> if isOp c then parens (c:cs) else c:cs

125− Case e pats -> "case "++ show e ++" of " ++ brkt (intercalate " ; " pats')

126− where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats

127− Data name es

128− | name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $

129− delist (notLocated $ Data "Cons" es)

130− | name == "Nil" -> "[]"

131− | otherwise -> name ++ " " ++ intercalate " " (map show' es)

132− Markdown _ -> "[markdown| ... |]"

133−

134−

135−instance Show Def where

136− show e =

137− case e of

138− FnDef v [] e -> v ++ " = " ++ show e

139− FnDef f args e -> f ++ concatMap (' ':) args ++ " = " ++ show e

140− OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e

141− TypeAnnotation n t -> n ++ " : " ++ show t

142−

143−getLambdas (L _ _ (Lambda x e)) = (x:xs,e')

144− where (xs,e') = getLambdas e

145−getLambdas e = ([],e)

146−

147−needsParens e =

148− case e of

149− Binop _ _ _ -> True

150− Lambda _ _ -> True

151− App _ _ -> True

152− If _ _ _ -> True

153− Let _ _ -> True

154− Case _ _ -> True

155− Data name (x:xs) -> name /= "Cons"

156− _ -> False

compiler/Model/Guid.hsdeleted−19

@@ -1,19 +0,0 @@

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−module Guid (guid, set, run, runAt, GuidCounter) where

3−

4−import Control.Monad.State (evalState, State, get, put)

5−

6−-- Wrapper around State monad.

7−newtype GuidCounter a = GC { runGC :: State Int a }

8− deriving (Monad)

9−

10−-- Get the next GUID, incrementing the counter.

11−guid :: GuidCounter Int

12−guid = GC $ do n <- get

13− put (n + 1)

14− return n

15−

16−set n = GC (put n)

17−

18−run = runAt 0

19−runAt n x = evalState (runGC x) n

compiler/Model/Libraries.hsdeleted−59

@@ -1,59 +0,0 @@

1−module Libraries (libraries, addPrelude) where

2−

3−import Ast

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

5−import qualified Data.Map as Map

6−import Data.List (inits)

7−import Text.JSON

8−import LoadLibraries as Libs

9−

10−addPrelude :: Module -> Module

11−addPrelude (Module name exs ims stmts) = Module name exs (customIms ++ ims) stmts

12− where customIms = concatMap addModule prelude

13−

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

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

16− Just (As m) -> [(n, method)]

17− Just _ -> []

18−

19−prelude = text : map (\n -> (n, Hiding [])) modules

20− where

21− text = ("Text", Hiding ["link", "color", "height"])

22− modules = [ "Prelude", "Signal", "List", "Maybe", "Time"

23− , "Graphics.Element", "Color", "Graphics.Collage" ]

24−

25−libraries :: Map.Map String (Map.Map String String)

26−libraries =

27− case getLibs of

28− Error err -> error err

29− Ok libs -> Map.unionWith Map.union libs nilAndTuples

30− where nilAndTuples = Map.singleton "Prelude" (Map.fromList pairs)

31− pairs =

32− [ ("Cons", "a -> [a] -> [a]")

33− , ("Nil", "[a]")

34− ] ++ map makeTuple (inits ['a'..'i'])

35−

36− makeTuple cs =

37− let name = "Tuple" ++ show (length cs)

38− in (name, concatMap (\c -> c : " -> ") cs ++

39− name ++ concatMap (\c -> [' ',c]) cs)

40−

41−getLibs :: Result (Map.Map String (Map.Map String String))

42−getLibs = do

43− obj <- decodeStrict Libs.docs :: Result (JSObject JSValue)

44− modules <- valFromObj "modules" obj :: Result [JSObject JSValue]

45− Map.fromList `fmap` mapM getValues modules

46−

47−

48−get :: String -> JSObject JSValue -> Result String

49−get = valFromObj

50−

51−getValue :: JSObject JSValue -> Result (String,String)

52−getValue obj = (,) <$> get "name" obj <*> get "type" obj

53−

54−getValues :: JSObject JSValue -> Result (String, Map.Map String String)

55−getValues obj = do

56− name <- get "name" obj

57− vs <- valFromObj "values" obj

58− vals <- mapM getValue vs

59− return (name, Map.fromList vals)

compiler/Model/LoadLibraries.hsdeleted−34

@@ -1,34 +0,0 @@

1−module LoadLibraries (docs) where

2−

3−import Control.DeepSeq (force)

4−import qualified Control.Exception as E

5−import Paths_Elm

6−import System.Directory

7−import System.FilePath

8−import System.IO.Unsafe (unsafePerformIO)

9−

10−-- See stackoverflow discussion for trade-off between using unsafeIO or TemplateHaskell:

11−-- http://stackoverflow.com/questions/12716215/load-pure-global-variable-from-file

12−

13−-- Given the awkwardness of including a compile-time generated file

14−-- vs loading static data, then the unsafeIO seems better.

15−

16−{-# NOINLINE docs #-}

17−docs :: String

18−docs = force $ unsafePerformIO (safeReadDocs =<< getDataFileName "docs.json")

19−

20−safeReadDocs :: FilePath -> IO String

21−safeReadDocs name = E.catch (readDocs name) (emitError name)

22−

23−readDocs :: FilePath -> IO String

24−readDocs name = do

25− exists <- doesFileExist name

26− if exists then readFile name

27− else ioError . userError $ "File Not Found"

28−

29−

30−emitError :: FilePath -> IOError -> IO String

31−emitError name err = do

32− putStrLn $ "Error! Types for standard library not loaded properly!\n File should be here:" ++ name ++ "\n The file is created and copied by command: cabal install"

33− putStrLn (show err)

34− return "{\"modules\":[]}"

compiler/Model/Located.hsdeleted−43

@@ -1,43 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−module Located where

3−

4−import Text.Parsec.Pos

5−import Data.Data

6−

7−data SrcPos = Pos Int Int

8− deriving (Eq, Ord, Data, Typeable)

9−

10−data SrcSpan = Span SrcPos SrcPos | NoSpan

11− deriving (Eq, Ord, Data, Typeable)

12−

13−data Located e = L (Maybe String) SrcSpan e deriving (Eq,Ord, Data, Typeable)

14−

15−

16−instance Show SrcPos where

17− show (Pos r c) = "Line " ++ show r ++ ", Column " ++ show c

18−

19−instance Show SrcSpan where

20− show span =

21− case span of

22− Span start end -> show start

23− NoSpan -> ""

24−

25−instance Show e => Show (Located e) where

26− show (L _ _ e) = show e

27−

28−

29−

30−notLocated = L Nothing NoSpan

31−

32−pos start end = L Nothing

33− (Span (Pos (sourceLine start) (sourceColumn start))

34− (Pos (sourceLine end ) (sourceColumn end )))

35−

36−epos (L _ s1 _) (L _ s2 _) = L Nothing span

37− where span = case (s1,s2) of

38− (Span start _, Span _ end) -> Span start end

39− (_, NoSpan) -> s1

40− (NoSpan, _) -> s2

41−

42−addLoc x (L Nothing span e) = L (Just (show x)) span e

43−addLoc x (L txt span e) = L txt span e

compiler/Parse/Binops.hs → compiler/Parse/Binop.hsrenamed+34−25

@@ -1,18 +1,15 @@

1−module Parse.Binops (binops, infixStmt, OpTable) where

1+module Parse.Binop (binops, infixStmt, OpTable) where

22

3−import Ast

4−import Control.Monad (liftM,guard)

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

54import Control.Monad.Error

6−import Data.List (foldl',splitAt,elemIndices

7− ,group,groupBy,sortBy,find,intercalate)

5+import Data.List (intercalate)

86import qualified Data.Map as Map

9−import Data.Maybe (mapMaybe)

107

11−import Located (epos)

8+import SourceSyntax.Location (merge)

9+import SourceSyntax.Expression (LExpr, Expr(Binop))

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

1211import Text.Parsec

13−import Parse.Library

14−

15−data Assoc = L | N | R deriving (Eq,Show)

12+import Parse.Helpers

1613

1714type OpTable = [(Int, Assoc, String)]

1815

@@ -39,20 +36,31 @@ opAssoc :: OpTable -> String -> Assoc

3936opAssoc table op = Map.findWithDefault R op dict

4037 where dict = Map.fromList (map (\(_,assoc,op) -> (op,assoc)) table)

4138

42−hasLevel :: OpTable -> Int -> (String,CExpr) -> Bool

39+hasLevel :: OpTable -> Int -> (String, LExpr t v) -> Bool

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

4441

45−binops :: OpTable -> IParser CExpr -> IParser String -> IParser CExpr

46−binops table term anyOp =

42+binops :: OpTable

43+ -> IParser (LExpr t v)

44+ -> IParser (LExpr t v)

45+ -> IParser String

46+ -> IParser (LExpr t v)

47+binops table term last anyOp =

4748 do e <- term

48− split (table ++ preludeTable) 0 e =<< many nextOp

49+ split (table ++ preludeTable) 0 e =<< nextOps

4950 where

50− nextOp = commitIf (whitespace >> anyOp) $ do

51− whitespace ; op <- anyOp

52− whitespace ; e <- term

53− return (op,e)

51+ nextOps = choice [ commitIf (whitespace >> anyOp) $ do

52+ whitespace ; op <- anyOp ; whitespace

53+ expr <- Left <$> try term <|> Right <$> last

54+ case expr of

55+ Left t -> (:) (op,t) <$> nextOps

56+ Right e -> return [(op,e)]

57+ , return [] ]

5458

55−split :: OpTable -> Int -> CExpr -> [(String, CExpr)] -> IParser CExpr

59+split :: OpTable

60+ -> Int

61+ -> LExpr t v

62+ -> [(String, LExpr t v)]

63+ -> IParser (LExpr t v)

5664split _ _ e [] = return e

5765split table n e eops = do

5866 assoc <- getAssoc table n eops

@@ -61,25 +69,26 @@ split table n e eops = do

6169 case assoc of R -> joinR es ops

6270 _ -> joinL es ops

6371

64−splitLevel :: OpTable -> Int -> CExpr -> [(String, CExpr)] -> [IParser CExpr]

72+splitLevel :: OpTable -> Int -> LExpr t v -> [(String, LExpr t v)]

73+ -> [IParser (LExpr t v)]

6574splitLevel table n e eops =

6675 case break (hasLevel table n) eops of

6776 (lops, (op,e'):rops) ->

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

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

7079

71−joinL :: [CExpr] -> [String] -> IParser CExpr

80+joinL :: [LExpr t v] -> [String] -> IParser (LExpr t v)

7281joinL [e] [] = return e

73−joinL (a:b:es) (op:ops) = joinL (epos a b (Binop op a b) : es) ops

82+joinL (a:b:es) (op:ops) = joinL (merge a b (Binop op a b) : es) ops

7483joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."

7584

76−joinR :: [CExpr] -> [String] -> IParser CExpr

85+joinR :: [LExpr t v] -> [String] -> IParser (LExpr t v)

7786joinR [e] [] = return e

7887joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

79− return (epos a e (Binop op a e))

88+ return (merge a e (Binop op a e))

8089joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."

8190

82−getAssoc :: OpTable -> Int -> [(String,CExpr)] -> IParser Assoc

91+getAssoc :: OpTable -> Int -> [(String,LExpr t v)] -> IParser Assoc

8392getAssoc table n eops

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

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

compiler/Parse/Declaration.hsnew file+134

@@ -0,0 +1,134 @@

1+

2+module Parse.Declaration where

3+

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

5+import qualified Data.List as List

6+import Text.Parsec hiding (newline,spaces)

7+import Text.Parsec.Indent

8+import qualified Text.Pandoc as Pan

9+

10+import Parse.Helpers

11+import qualified Parse.Expression as Expr

12+import qualified SourceSyntax.Type as T

13+import qualified Parse.Type as Type

14+import SourceSyntax.Declaration (Declaration(..), Assoc(..))

15+

16+import Unique

17+

18+declaration :: IParser (Declaration t v)

19+declaration = alias <|> datatype <|> infixDecl <|> foreignDef <|> definition

20+

21+definition :: IParser (Declaration t v)

22+definition = Definition <$> Expr.def

23+

24+alias :: IParser (Declaration t v)

25+alias = do

26+ reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

27+ forcedWS

28+ alias <- capVar

29+ args <- spacePrefix lowVar

30+ whitespace ; string "=" ; whitespace

31+ tipe <- Type.expr

32+ return (TypeAlias alias args tipe)

33+

34+datatype :: IParser (Declaration t v)

35+datatype = do

36+ reserved "data" <?> "datatype definition (data T = A | B | ...)"

37+ forcedWS

38+ name <- capVar <?> "name of data-type"

39+ args <- spacePrefix lowVar

40+ whitespace ; string "=" ; whitespace

41+ tcs <- pipeSep1 Type.constructor

42+ return $ Datatype name args tcs

43+

44+

45+infixDecl :: IParser (Declaration t v)

46+infixDecl = do

47+ assoc <- choice [ reserved "infixl" >> return L

48+ , reserved "infix" >> return N

49+ , reserved "infixr" >> return R ]

50+ whitespace

51+ n <- digit

52+ forcedWS

53+ Fixity assoc (read [n]) <$> anyOp

54+

55+

56+foreignDef :: IParser (Declaration t v)

57+foreignDef = do

58+ try (reserved "foreign")

59+ whitespace

60+ importEvent <|> exportEvent

61+

62+exportEvent :: IParser (Declaration t v)

63+exportEvent = do

64+ try (reserved "export") >> whitespace >> reserved "jsevent" >> whitespace

65+ eventName <- jsVar

66+ whitespace

67+ elmVar <- lowVar

68+ whitespace ; hasType ; whitespace

69+ tipe <- Type.expr

70+ case tipe of

71+ T.Data "Signal" [t] ->

72+ case isExportable t of

73+ Nothing -> return (ExportEvent eventName elmVar tipe)

74+ Just err -> error err

75+ _ -> error "When importing foreign events, the imported value must have type Signal."

76+

77+importEvent :: IParser (Declaration t v)

78+importEvent = do

79+ try (reserved "import") >> whitespace >> reserved "jsevent" >> whitespace

80+ eventName <- jsVar

81+ whitespace

82+ baseValue <- Expr.term <?> "Base case for imported signal (signals cannot be undefined)"

83+ whitespace

84+ elmVar <- lowVar <?> "Name of imported signal"

85+ whitespace ; hasType ; whitespace

86+ tipe <- Type.expr

87+ case tipe of

88+ T.Data "Signal" [t] ->

89+ case isExportable t of

90+ Nothing -> return (ImportEvent eventName baseValue elmVar tipe)

91+ Just err -> error err

92+ _ -> error "When importing foreign events, the imported value must have type Signal."

93+

94+jsVar :: IParser String

95+jsVar = betwixt '"' '"' $ do

96+ v <- (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')

97+ if v `notElem` jsReserveds then return v else

98+ error $ "'" ++ v ++

99+ "' is not a good name for a importing or exporting JS values."

100+

101+jsReserveds :: [String]

102+jsReserveds =

103+ [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"

104+ , "arguments", "int", "byte", "char", "goto", "long", "final", "float"

105+ , "short", "double", "native", "throws", "boolean", "abstract", "volatile"

106+ , "transient", "synchronized", "function", "break", "case", "catch"

107+ , "continue", "debugger", "default", "delete", "do", "else", "finally"

108+ , "for", "function", "if", "in", "instanceof", "new", "return", "switch"

109+ , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"

110+ , "const", "enum", "export", "extends", "import", "super", "implements"

111+ , "interface", "let", "package", "private", "protected", "public"

112+ , "static", "yield"

113+ ]

114+

115+isExportable tipe =

116+ case tipe of

117+ T.Lambda _ _ ->

118+ Just $ "Elm's JavaScript event interface does not yet handle functions. " ++

119+ "Only simple values can be imported and exported in this release."

120+

121+ T.Data "JSArray" [t] -> isExportable t

122+

123+ T.Data name []

124+ | any (`List.isSuffixOf` name) jsTypes -> Nothing

125+ | otherwise -> Just $ "'" ++ name ++ "' is not an exportable type." ++ msg

126+

127+ T.Data name _ ->

128+ Just $ "'" ++ name ++ "' is not an exportable type " ++

129+ "constructor. Only 'JSArray' is an exportable container."

130+

131+ T.Var _ -> Just $ "Cannot export type variables." ++ msg

132+ where

133+ msg = " The following types are exportable: " ++ List.intercalate ", " jsTypes

134+ jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]

compiler/Parse/Expr.hsdeleted−220

@@ -1,220 +0,0 @@

1−module Parse.Expr (def,term) where

2−

3−import Ast

4−import Located

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

6−import Control.Monad

7−import Data.Char (isSymbol, isDigit)

8−import Data.List (foldl')

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

10−import Text.Parsec.Indent

11−import qualified Text.Pandoc as Pan

12−

13−import Parse.Library

14−import Parse.Patterns

15−import Parse.Binops

16−import Parse.Types

17−

18−import Guid

19−import Types.Types (Type (VarT), Scheme (Forall))

20−

21−import System.IO.Unsafe

22−

23−

24−-------- Basic Terms --------

25−

26−numTerm :: IParser Expr

27−numTerm = toExpr <$> (preNum <?> "number")

28− where toExpr n | '.' `elem` n = FloatNum (read n)

29− | otherwise = IntNum (read n)

30− preNum = (++) <$> many1 digit <*> option "" postNum

31− postNum = do try $ lookAhead (string "." >> digit)

32− string "."

33− ('.':) <$> many1 digit

34−

35−strTerm :: IParser Expr

36−strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $

37− backslashed <|> satisfy (/='"')

38−

39−varTerm :: IParser Expr

40−varTerm = toVar <$> var <?> "variable"

41−

42−toVar v = case v of "True" -> Boolean True

43− "False" -> Boolean False

44− _ -> Var v

45−

46−chrTerm :: IParser Expr

47−chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))

48− <?> "character"

49−

50−accessor :: IParser Expr

51−accessor = do

52− start <- getPosition

53− lbl <- try (string "." >> rLabel)

54− end <- getPosition

55− let loc e = addLoc ("." ++ lbl) (pos start end e)

56− return (Lambda "_" (loc $ Access (loc $ Var "_") lbl))

57−

58−

59−-------- Complex Terms --------

60−

61−listTerm :: IParser Expr

62−listTerm =

63− (do { try $ string "[markdown|"

64− ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")

65− ; return . Markdown $ Pan.readMarkdown Pan.def md })

66− <|> (braces $ choice

67− [ try $ do { lo <- expr; whitespace; string ".." ; whitespace

68− ; Range lo <$> expr }

69− , do (L _ _ e) <- list <$> commaSep expr

70− return e

71− ])

72−

73−parensTerm :: IParser CExpr

74−parensTerm = parens $ choice

75− [ do start <- getPosition

76− op <- try anyOp

77− end <- getPosition

78− let loc = pos start end

79− return . loc . Lambda "x" . loc . Lambda "y" . loc $

80− Binop op (loc $ Var "x") (loc $ Var "y")

81− , do start <- getPosition

82− let comma = char ',' <?> "comma ','"

83− commas <- comma >> many (whitespace >> comma)

84− end <- getPosition

85− let vars = map (('v':) . show) [ 0 .. length commas + 1 ]

86− loc = pos start end

87− return $ foldr (\x e -> loc $ Lambda x e)

88− (loc . tuple $ map (loc . Var) vars) vars

89− , do start <- getPosition

90− es <- commaSep expr

91− end <- getPosition

92− return $ case es of [e] -> e

93− _ -> pos start end (tuple es)

94− ]

95−

96−recordTerm :: IParser CExpr

97−recordTerm = brackets $ choice [ misc, addLocation record ]

98− where field = do

99− fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix patternTerm

100− whitespace

101− e <- string "=" >> whitespace >> expr

102− n <- sourceLine <$> getPosition

103− runAt (1000 * n) $ flattenPatterns fDefs e

104− extract [ FnDef f args exp ] = return (f,args,exp)

105− extract _ = fail "Improperly formed record field."

106− record = Record <$> (mapM extract =<< commaSep field)

107− change = do

108− lbl <- rLabel

109− whitespace >> string "<-" >> whitespace

110− (,) lbl <$> expr

111− remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)

112− insert r = addLocation $ do

113− string "|" >> whitespace

114− Insert r <$> rLabel <*>

115− (whitespace >> string "=" >> whitespace >> expr)

116− modify r = addLocation

117− (string "|" >> whitespace >> Modify r <$> commaSep1 change)

118− misc = try $ do

119− record <- addLocation (Var <$> rLabel)

120− whitespace

121− opt <- optionMaybe (remove record)

122− whitespace

123− case opt of

124− Just e -> try (insert e) <|> return e

125− Nothing -> try (insert record) <|> try (modify record)

126−

127−

128−term :: IParser CExpr

129−term = addLocation (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])

130− <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

131− <?> "basic term (4, x, 'c', etc.)"

132−

133−-------- Applications --------

134−

135−appExpr :: IParser CExpr

136−appExpr = do

137− tlist <- spaceSep1 term

138− return $ case tlist of

139− t:[] -> t

140− t:ts -> foldl' (\f x -> epos f x $ App f x) t ts

141−

142−-------- Normal Expressions --------

143−

144−binaryExpr :: IParser CExpr

145−binaryExpr = binops [] appExpr anyOp

146−

147−ifExpr :: IParser Expr

148−ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

149− where normal = do e1 <- expr ; whitespace

150− reserved "then" ; whitespace ; e2 <- expr

151− whitespace <?> "an 'else' branch"

152− reserved "else" <?> "an 'else' branch" ; whitespace

153− If e1 e2 <$> expr

154− multiIf = (MultiIf <$> spaceSep1 iff)

155− where iff = do string "|" ; whitespace

156− b <- expr ; whitespace ; string "->" ; whitespace

157− (,) b <$> expr

158−

159−lambdaExpr :: IParser CExpr

160−lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

161− whitespace

162− pats <- spaceSep1 patternTerm

163− whitespace ; arrow ; whitespace

164− e <- expr

165− return . run $ makeLambda pats e

166−

167−defSet :: IParser [Def]

168−defSet = concat <$> block (do d <- anyDef ; whitespace ; return d)

169−

170−letExpr :: IParser Expr

171−letExpr = do

172− reserved "let" ; whitespace

173− defs <- defSet

174− whitespace ; reserved "in" ; whitespace

175− Let defs <$> expr

176−

177−caseExpr :: IParser Expr

178−caseExpr = do

179− reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace

180− Case e <$> (with <|> without)

181− where case_ = do p <- patternExpr; whitespace; arrow; whitespace

182− (,) p <$> expr

183− with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

184− without = block (do c <- case_ ; whitespace ; return c)

185−

186−expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

187− <|> lambdaExpr

188− <|> binaryExpr

189− <?> "an expression"

190−

191−funcDef = try (do p1 <- try patternTerm ; infics p1 <|> func p1)

192− <|> ((:[]) <$> patternExpr)

193− <?> "the definition of a variable (x = ...)"

194− where func p@(PVar v) = (p:) <$> spacePrefix patternTerm

195− func p = do try (lookAhead (whitespace >> string "="))

196− return [p]

197− infics p1 = do

198− o:p <- try (whitespace >> anyOp)

199− p2 <- (whitespace >> patternTerm)

200− return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]

201− else [ PVar (o:p), p1, p2 ]

202−

203−assignExpr :: IParser [Def]

204−assignExpr = withPos $ do

205− fDefs <- funcDef

206− whitespace

207− e <- string "=" >> whitespace >> expr

208− n <- sourceLine <$> getPosition

209− runAt (1000 * n) $ flattenPatterns fDefs e

210−

211−anyDef =

212− ((\d -> [d]) <$> typeAnnotation) <|>

213− assignExpr

214−

215−def = map Definition <$> anyDef

216−

217−parseDef str =

218− case iParse def "" str of

219− Right result -> Right result

220− Left err -> Left $ "Parse error at " ++ show err

compiler/Parse/Expression.hsnew file+242

@@ -0,0 +1,242 @@

1+module Parse.Expression (def,term) where

2+

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

4+import Data.List (foldl')

5+import Text.Parsec hiding (newline,spaces)

6+import Text.Parsec.Indent

7+import qualified Text.Pandoc as Pan

8+

9+import Parse.Helpers

10+import qualified Parse.Pattern as Pattern

11+import qualified Parse.Type as Type

12+import Parse.Binop

13+import Parse.Literal

14+

15+import SourceSyntax.Location as Location

16+import SourceSyntax.Pattern hiding (tuple,list)

17+import qualified SourceSyntax.Literal as Literal

18+import SourceSyntax.Expression

19+import SourceSyntax.Declaration (Declaration(Definition))

20+

21+import Unique

22+

23+

24+-------- Basic Terms --------

25+

26+varTerm :: IParser (Expr t v)

27+varTerm = toVar <$> var <?> "variable"

28+

29+toVar :: String -> Expr t v

30+toVar v = case v of "True" -> Literal (Literal.Boolean True)

31+ "False" -> Literal (Literal.Boolean False)

32+ _ -> Var v

33+

34+accessor :: IParser (Expr t v)

35+accessor = do

36+ start <- getPosition

37+ lbl <- try (string "." >> rLabel)

38+ end <- getPosition

39+ let loc e = Location.at start end e

40+ return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))

41+

42+negative :: IParser (Expr t v)

43+negative = do

44+ start <- getPosition

45+ nTerm <- try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term

46+ end <- getPosition

47+ let loc e = Location.at start end e

48+ return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)

49+

50+

51+-------- Complex Terms --------

52+

53+listTerm :: IParser (Expr t v)

54+listTerm =

55+ (do { try $ string "[markdown|"

56+ ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")

57+ ; return . Markdown $ Pan.readMarkdown Pan.def md })

58+ <|> (braces $ choice

59+ [ try $ do { lo <- expr; whitespace; string ".." ; whitespace

60+ ; Range lo <$> expr }

61+ , ExplicitList <$> commaSep expr

62+ ])

63+

64+parensTerm :: IParser (LExpr t v)

65+parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

66+ where

67+ opFn = do

68+ start <- getPosition

69+ op <- anyOp

70+ end <- getPosition

71+ let loc = Location.at start end

72+ return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $

73+ Binop op (loc $ Var "x") (loc $ Var "y")

74+

75+ tupleFn = do

76+ start <- getPosition

77+ let comma = char ',' <?> "comma ','"

78+ commas <- comma >> many (whitespace >> comma)

79+ end <- getPosition

80+ let vars = map (('v':) . show) [ 0 .. length commas + 1 ]

81+ loc = Location.at start end

82+ return $ foldr (\x e -> loc $ Lambda x e)

83+ (loc . tuple $ map (loc . Var) vars) (map PVar vars)

84+

85+ parened = do

86+ start <- getPosition

87+ es <- commaSep expr

88+ end <- getPosition

89+ return $ case es of [e] -> e

90+ _ -> Location.at start end (tuple es)

91+

92+recordTerm :: IParser (LExpr t v)

93+recordTerm = brackets $ choice [ misc, addLocation record ]

94+ where field = do

95+ label <- rLabel

96+ patterns <- spacePrefix Pattern.term

97+ whitespace >> string "=" >> whitespace

98+ body <- expr

99+ return (label, makeFunction patterns body)

100+

101+ record = Record <$> commaSep field

102+

103+ change = do

104+ lbl <- rLabel

105+ whitespace >> string "<-" >> whitespace

106+ (,) lbl <$> expr

107+

108+ remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)

109+

110+ insert r = addLocation $ do

111+ string "|" >> whitespace

112+ Insert r <$> rLabel <*>

113+ (whitespace >> string "=" >> whitespace >> expr)

114+

115+ modify r = addLocation

116+ (string "|" >> whitespace >> Modify r <$> commaSep1 change)

117+

118+ misc = try $ do

119+ record <- addLocation (Var <$> rLabel)

120+ whitespace

121+ opt <- optionMaybe (remove record)

122+ whitespace

123+ case opt of

124+ Just e -> try (insert e) <|> return e

125+ Nothing -> try (insert record) <|> try (modify record)

126+

127+

128+term :: IParser (LExpr t v)

129+term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

130+ <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

131+ <?> "basic term (4, x, 'c', etc.)"

132+

133+-------- Applications --------

134+

135+appExpr :: IParser (LExpr t v)

136+appExpr = do

137+ t <- term

138+ ts <- constrainedSpacePrefix term $ \str ->

139+ if null str then notFollowedBy (char '-') else return ()

140+ return $ case ts of

141+ [] -> t

142+ _ -> foldl' (\f x -> Location.merge f x $ App f x) t ts

143+

144+-------- Normal Expressions --------

145+

146+binaryExpr :: IParser (LExpr t v)

147+binaryExpr = binops [] appExpr lastExpr anyOp

148+ where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

149+ <|> lambdaExpr

150+

151+ifExpr :: IParser (Expr t v)

152+ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

153+ where

154+ normal = do

155+ bool <- expr

156+ whitespace ; reserved "then" ; whitespace

157+ thenBranch <- expr

158+ whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace

159+ elseBranch <- expr

160+ return $ MultiIf [(bool, thenBranch),

161+ (Location.sameAs elseBranch (Var "otherwise"), elseBranch)]

162+ multiIf = MultiIf <$> spaceSep1 iff

163+ where iff = do string "|" ; whitespace

164+ b <- expr ; whitespace ; string "->" ; whitespace

165+ (,) b <$> expr

166+

167+lambdaExpr :: IParser (LExpr t v)

168+lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

169+ whitespace

170+ args <- spaceSep1 Pattern.term

171+ whitespace ; arrow ; whitespace

172+ body <- expr

173+ return (makeFunction args body)

174+

175+defSet :: IParser [Def t v]

176+defSet = block (do d <- def ; whitespace ; return d)

177+

178+letExpr :: IParser (Expr t v)

179+letExpr = do

180+ reserved "let" ; whitespace

181+ defs <- defSet

182+ whitespace ; reserved "in" ; whitespace

183+ Let defs <$> expr

184+

185+caseExpr :: IParser (Expr t v)

186+caseExpr = do

187+ reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace

188+ Case e <$> (with <|> without)

189+ where case_ = do p <- Pattern.expr; whitespace; arrow; whitespace

190+ (,) p <$> expr

191+ with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

192+ without = block (do c <- case_ ; whitespace ; return c)

193+

194+expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

195+ <|> lambdaExpr

196+ <|> binaryExpr

197+ <?> "an expression"

198+

199+funcDef =

200+ choice [ do p1 <- try Pattern.term

201+ infics p1 <|> func p1

202+ , func =<< (PVar <$> parens symOp)

203+ , (:[]) <$> Pattern.expr

204+ ] <?> "the definition of a variable (x = ...)"

205+ where

206+ func pattern =

207+ case pattern of

208+ PVar v -> (pattern:) <$> spacePrefix Pattern.term

209+ _ -> do try (lookAhead (whitespace >> string "="))

210+ return [pattern]

211+

212+ infics p1 = do

213+ o:p <- try (whitespace >> anyOp)

214+ p2 <- (whitespace >> Pattern.term)

215+ return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]

216+ else [ PVar (o:p), p1, p2 ]

217+

218+makeFunction :: [Pattern] -> LExpr t v -> LExpr t v

219+makeFunction args body@(L s _) =

220+ foldr (\arg body' -> L s $ Lambda arg body') body args

221+

222+assignExpr :: IParser (Def t v)

223+assignExpr = withPos $ do

224+ (name:args) <- funcDef

225+ whitespace >> string "=" >> whitespace

226+ body <- expr

227+ return . Def name $ makeFunction args body

228+

229+typeAnnotation :: IParser (Def t v)

230+typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

231+ where

232+ start = do v <- lowVar <|> parens symOp

233+ whitespace ; hasType ; whitespace

234+ return v

235+

236+def :: IParser (Def t v)

237+def = typeAnnotation <|> assignExpr

238+

239+attempt f parser str =

240+ case iParse parser "" str of

241+ Right result -> f result

242+ Left err -> error $ "Parse error at " ++ show err

compiler/Parse/Foreign.hsdeleted−60

@@ -1,60 +0,0 @@

1−

2−module Parse.Foreign (foreignDef) where

3−

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

5−import Data.Either (partitionEithers)

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

7−

8−import Ast

9−import Parse.Library

10−import Parse.Expr (term)

11−import Parse.Types

12−import Types.Types (signalOf)

13−

14−foreignDef = do try (reserved "foreign") ; whitespace

15− importEvent <|> exportEvent

16−

17−exportEvent = do

18− try (reserved "export") >> whitespace >> reserved "jsevent" >> whitespace

19− js <- jsVar ; whitespace

20− elm <- lowVar ; whitespace

21− hasType ; whitespace

22− tipe <- typeExpr

23− case tipe of

24− ADTPT "Signal" [pt] ->

25− either error (return . ExportEvent js elm . signalOf) (toForeignType pt)

26− _ -> error "When exporting events, the exported value must be a Signal."

27−

28−importEvent = do

29− try (reserved "import") >> whitespace >> reserved "jsevent" >> whitespace

30− js <- jsVar ; whitespace

31− base <- term <?> "Base case for imported signal (signals cannot be undefined)"

32− whitespace

33− elm <- lowVar <?> "Name of imported signal"

34− whitespace ; hasType ; whitespace

35− tipe <- typeExpr

36− case tipe of

37− ADTPT "Signal" [pt] ->

38− either error (return . ImportEvent js base elm . signalOf) (toForeignType pt)

39− _ -> error "When importing events, the imported value must be a Signal."

40−

41−

42−jsVar :: (Monad m) => ParsecT [Char] u m String

43−jsVar = betwixt '"' '"' $ do

44− v <- (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')

45− if v `notElem` jsReserveds then return v else

46− error $ "'" ++ v ++

47− "' is not a good name for a importing or exporting JS values."

48−

49−jsReserveds =

50− [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"

51− , "arguments", "int", "byte", "char", "goto", "long", "final", "float"

52− , "short", "double", "native", "throws", "boolean", "abstract", "volatile"

53− , "transient", "synchronized", "function", "break", "case", "catch"

54− , "continue", "debugger", "default", "delete", "do", "else", "finally"

55− , "for", "function", "if", "in", "instanceof", "new", "return", "switch"

56− , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"

57− , "const", "enum", "export", "extends", "import", "super", "implements"

58− , "interface", "let", "package", "private", "protected", "public"

59− , "static", "yield"

60− ]

compiler/Parse/Library.hs → compiler/Parse/Helpers.hsrenamed+45−25

@@ -1,13 +1,12 @@

1+module Parse.Helpers where

12

2−module Parse.Library where

3−

4−import Ast

5−import Located

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

74import Control.Monad

85import Control.Monad.State

96import Data.Char (isUpper)

10−import Rename (deprime)

7+import SourceSyntax.Helpers as Help

8+import SourceSyntax.Location as Location

9+import SourceSyntax.Expression

1110import Text.Parsec hiding (newline,spaces,State)

1211import Text.Parsec.Indent

1312

@@ -39,8 +38,13 @@ lowVar = makeVar (lower <?> "lower case variable")

3938capVar :: IParser String

4039capVar = makeVar (upper <?> "upper case variable")

4140

41+qualifiedVar :: IParser String

42+qualifiedVar = do

43+ vars <- many ((++) <$> capVar <*> string ".")

44+ (++) (concat vars) <$> lowVar

45+

4246rLabel :: IParser String

43−rLabel = deprime <$> lowVar

47+rLabel = lowVar

4448

4549innerVarChar :: IParser Char

4650innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""

@@ -56,10 +60,10 @@ reserved word =

5660 <?> "reserved word '" ++ word ++ "'"

5761

5862anyOp :: IParser String

59−anyOp = betwixt '`' '`' var <|> symOp <?> "infix operator (e.g. +, *, ||)"

63+anyOp = betwixt '`' '`' qualifiedVar <|> symOp <?> "infix operator (e.g. +, *, ||)"

6064

6165symOp :: IParser String

62−symOp = do op <- many1 (satisfy isOp)

66+symOp = do op <- many1 (satisfy Help.isSymbol)

6367 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])

6468 case op of

6569 "." -> notFollowedBy lower >> return op

@@ -103,7 +107,14 @@ dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)

103107spaceSep1 :: IParser a -> IParser [a]

104108spaceSep1 p = (:) <$> p <*> spacePrefix p

105109

106−spacePrefix p = many (try (whitespace >> indented >> p))

110+spacePrefix p = constrainedSpacePrefix p (\_ -> return ())

111+

112+constrainedSpacePrefix p constraint =

113+ many . try $ do

114+ n <- whitespace

115+ constraint n

116+ indented

117+ p

107118

108119followedBy a b = do x <- a ; b ; return x

109120

@@ -124,17 +135,17 @@ parens = surround '(' ')' "paren"

124135brackets :: IParser a -> IParser a

125136brackets = surround '{' '}' "bracket"

126137

127−addLocation :: IParser Expr -> IParser CExpr

138+addLocation :: IParser (Expr t v) -> IParser (LExpr t v)

128139addLocation expr = do

129140 start <- getPosition

130141 e <- expr

131142 end <- getPosition

132− return (pos start end e)

143+ return (Location.at start end e)

133144

134−accessible :: IParser CExpr -> IParser CExpr

145+accessible :: IParser (LExpr t v) -> IParser (LExpr t v)

135146accessible expr = do

136147 start <- getPosition

137− ce@(L s t e) <- expr

148+ ce@(L _ e) <- expr

138149 let rest f = do

139150 let dot = char '.' >> notFollowedBy (char '.')

140151 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")

@@ -143,41 +154,50 @@ accessible expr = do

143154 Just _ -> accessible $ do

144155 v <- var <?> "field access (e.g. List.map)"

145156 end <- getPosition

146− return (pos start end (f v))

157+ return (Location.at start end (f v))

147158 case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))

148159 | otherwise -> rest (Access ce)

149160 _ -> rest (Access ce)

150161

151162

152163spaces :: IParser String

153−spaces = many1 ((multiComment <|> string " " <?> "") >> return ' ') <?> "spaces"

164+spaces = concat <$> many1 (multiComment <|> string " ") <?> "spaces"

165+

166+forcedWS :: IParser String

167+forcedWS = choice [ try $ (++) <$> spaces <*> (concat <$> many nl_space)

168+ , try $ concat <$> many1 nl_space ]

169+ where nl_space = try ((++) <$> (concat <$> many1 newline) <*> spaces)

154170

155−forcedWS :: IParser [String]

156−forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)

157− where nl_space = try $ many1 newline >> spaces

171+-- Just eats whitespace until the next meaningful character.

172+dumbWhitespace :: IParser String

173+dumbWhitespace = concat <$> many (spaces <|> newline)

158174

159−whitespace :: IParser ()

160−whitespace = optional forcedWS <?> ""

175+whitespace :: IParser String

176+whitespace = option "" forcedWS <?> "whitespace"

161177

162178freshLine :: IParser [[String]]

163179freshLine = try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""

164180 where space_nl = try $ spaces >> many1 newline

165181

166182newline :: IParser String

167−newline = simpleNewline <|> lineComment <?> ""

183+newline = simpleNewline <|> lineComment <?> "newline"

168184

169185simpleNewline :: IParser String

170186simpleNewline = try (string "\r\n") <|> string "\n"

171187

172188lineComment :: IParser String

173−lineComment = do try (string "--")

174− manyTill anyChar $ simpleNewline <|> (eof >> return "\n")

189+lineComment = do

190+ try (string "--")

191+ comment <- manyTill anyChar $ simpleNewline <|> (eof >> return "\n")

192+ return ("--" ++ comment)

175193

176194multiComment :: IParser String

177195multiComment = do { try (string "{-"); closeComment }

178196

179197closeComment :: IParser String

180−closeComment = manyTill anyChar . choice $

198+closeComment = do

199+ comment <- manyTill anyChar . choice $

181200 [ try (string "-}") <?> "close comment"

182201 , do { try $ string "{-"; closeComment; closeComment }

183− ]

202+ ]

203+ return ("{-" ++ comment ++ "-}")

compiler/Parse/Literal.hsnew file+31

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

1+module Parse.Literal (literal) where

2+

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

4+import Control.Monad

5+import Text.Parsec hiding (newline,spaces)

6+import Text.Parsec.Indent

7+

8+import Parse.Helpers

9+import SourceSyntax.Literal

10+

11+literal = num <|> str <|> chr

12+

13+num :: IParser Literal

14+num = fmap toLit (preNum <?> "number")

15+ where toLit n | '.' `elem` n = FloatNum (read n)

16+ | otherwise = IntNum (read n)

17+ preNum = (++) <$> many1 digit <*> option "" postNum

18+ postNum = do try $ lookAhead (string "." >> digit)

19+ string "."

20+ ('.':) <$> many1 digit

21+

22+str :: IParser Literal

23+str = choice [ let quote = try (string "\"\"\"")

24+ in quote >> Str <$> manyTill (backslashed <|> anyChar) quote

25+ , liftM Str . expecting "string" . betwixt '"' '"' . many $

26+ backslashed <|> satisfy (/='"')

27+ ]

28+

29+chr :: IParser Literal

30+chr = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))

31+ <?> "character"

compiler/Parse/Module.hsnew file+44

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

1+

2+module Parse.Module (moduleDef, imports) where

3+

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

5+import Data.List (intercalate)

6+import Text.Parsec hiding (newline,spaces)

7+

8+import Parse.Helpers

9+import SourceSyntax.Module (Module(..), ImportMethod(..), Imports)

10+

11+varList :: IParser [String]

12+varList = parens $ commaSep1 (var <|> parens symOp)

13+

14+moduleDef :: IParser ([String], [String])

15+moduleDef = do

16+ try (reserved "module")

17+ whitespace

18+ names <- dotSep1 capVar <?> "name of module"

19+ whitespace

20+ exports <- option [] varList

21+ whitespace <?> "reserved word 'where'"

22+ reserved "where"

23+ return (names, exports)

24+

25+imports :: IParser Imports

26+imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))

27+

28+import' :: IParser (String, ImportMethod)

29+import' =

30+ do reserved "import"

31+ whitespace

32+ open <- optionMaybe (reserved "open")

33+ whitespace

34+ name <- intercalate "." <$> dotSep1 capVar

35+ case open of

36+ Just _ -> return (name, Hiding [])

37+ Nothing -> let how = try (whitespace >> (as' <|> importing'))

38+ in (,) name <$> option (As name) how

39+ where

40+ as' :: IParser ImportMethod

41+ as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"

42+

43+ importing' :: IParser ImportMethod

44+ importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"

compiler/Parse/Modules.hsdeleted−46

@@ -1,46 +0,0 @@

1−

2−module Parse.Modules (moduleDef, imports) where

3−

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

5−import Data.List (intercalate)

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

7−

8−import Ast

9−import Parse.Library

10−

11−varList :: IParser [String]

12−varList = parens $ commaSep1 (var <|> parens symOp)

13−

14−moduleDef :: IParser ([String], [String])

15−moduleDef = do

16− try (reserved "module")

17− whitespace

18− names <- dotSep1 capVar <?> "name of module"

19− whitespace

20− exports <- option [] varList

21− whitespace <?> "reserved word 'where'"

22− reserved "where"

23− return (names, exports)

24−

25−imports :: IParser Imports

26−imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))

27−

28−

29−import' :: IParser (String, ImportMethod)

30−import' = do

31− reserved "import"

32− whitespace

33− open <- optionMaybe (reserved "open")

34− whitespace

35− name <- intercalate "." <$> dotSep1 capVar

36− case open of

37− Just _ -> return (name, Hiding [])

38− Nothing -> let how = try (whitespace >> (as' <|> importing'))

39− in (,) name <$> option (Importing []) how

40−

41−

42−as' :: IParser ImportMethod

43−as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"

44−

45−importing' :: IParser ImportMethod

46−importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"

compiler/Parse/Parse.hsnew file+47

@@ -0,0 +1,47 @@

1+module Parse.Parse (program, dependencies) where

2+

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

4+import Control.Monad

5+import Data.Char (isSymbol, isDigit)

6+import Data.List (foldl',intercalate)

7+import Text.Parsec hiding (newline,spaces)

8+import qualified Text.PrettyPrint as P

9+

10+import qualified SourceSyntax.Module as S

11+import Parse.Helpers

12+import Parse.Binop (infixStmt, OpTable)

13+import Parse.Expression

14+import Parse.Type

15+import Parse.Module

16+import qualified Parse.Declaration as Decl

17+

18+freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

19+ freshLine

20+ Decl.declaration <?> "another datatype or variable definition"

21+

22+decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

23+ (d:) <$> many freshDef

24+

25+program :: String -> Either [P.Doc] (S.Module t v)

26+program = setupParser $ do

27+ optional freshLine

28+ (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

29+ is <- (do try (lookAhead $ reserved "import")

30+ imports `followedBy` freshLine) <|> return []

31+ declarations <- decls

32+ optional freshLine ; optional spaces ; eof

33+ return $ S.Module names exports is declarations

34+

35+dependencies :: String -> Either [P.Doc] (String, [String])

36+dependencies =

37+ let getName = intercalate "." . fst in

38+ setupParser $ do

39+ optional freshLine

40+ (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)

41+ <*> option [] (map fst <$> imports `followedBy` freshLine)

42+

43+setupParser :: IParser a -> String -> Either [P.Doc] a

44+setupParser p source =

45+ case iParse p "" source of

46+ Right result -> Right result

47+ Left err -> Left [ P.text $ "Parse error at " ++ show err ]

compiler/Parse/Parser.hsdeleted−59

@@ -1,59 +0,0 @@

1−module Parse.Parser (parseProgram, parseDependencies, parseInfix) where

2−

3−import Ast

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

5−import Control.Monad

6−import Data.Char (isSymbol, isDigit)

7−import Data.List (foldl',intercalate)

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

9−

10−import Parse.Library

11−import Parse.Binops (infixStmt, OpTable)

12−import Parse.Expr

13−import Parse.Types

14−import Parse.Modules

15−import Parse.Foreign

16−

17−

18−statement = choice (typeAlias:defs) <|> def <?> "datatype or variable definition"

19− where defs = map ((:[]) <$>) [ foreignDef, datatype ]

20−

21−freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

22− freshLine

23− statement <?> "another datatype or variable definition"

24−

25−defs1 = do d <- statement <?> "at least one datatype or variable definition"

26− concat <$> (d:) <$> many freshDef

27−

28−program = do

29− optional freshLine

30− (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

31− is <- (do try (lookAhead $ reserved "import")

32− imports `followedBy` freshLine) <|> return []

33− statements <- defs1

34− optional freshLine ; optional spaces ; eof

35− return $ Module names exports is statements

36−

37−parseProgram = setupParser program

38−

39−parseDependencies :: String -> Either String (String, [String])

40−parseDependencies =

41− setupParser $ do

42− optional skip

43− (,) <$> option "Main" moduleName <*> option [] imprts

44− where

45− skip = try (manyTill anyChar (try (string "/**")))

46− imprts = fmap (map fst) imports `followedBy` freshLine

47− getName = intercalate "." . fst

48− moduleName = do optional freshLine

49− getName <$> moduleDef `followedBy` freshLine

50−

51−parseInfix :: String -> Either String OpTable

52−parseInfix = setupParser . many $ do

53− manyTill (whitespace <|> (anyChar >> return ())) freshLine

54− infixStmt

55−

56−setupParser p source =

57− case iParse p "" source of

58− Right result -> Right result

59− Left err -> Left $ "Parse error at " ++ show err

compiler/Parse/Pattern.hsnew file+134

@@ -0,0 +1,134 @@

1+

2+module Parse.Pattern (term, expr) where

3+

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

5+import Control.Monad

6+import Control.Monad.State

7+import Data.Char (isUpper)

8+import Data.List (intercalate)

9+import Unique

10+import Text.Parsec hiding (newline,spaces,State)

11+import Text.Parsec.Indent

12+

13+import Parse.Helpers

14+import Parse.Literal

15+import qualified SourceSyntax.Pattern as Pattern

16+import SourceSyntax.Everything hiding (tuple)

17+

18+

19+basic :: IParser Pattern

20+basic = choice

21+ [ char '_' >> return PAnything

22+ , do v <- var

23+ return $ case v of

24+ "True" -> PLiteral (Boolean True)

25+ "False" -> PLiteral (Boolean False)

26+ c : _ -> if isUpper c then PData v [] else PVar v

27+ , do lit <- literal

28+ return $ case lit of

29+ Str s -> foldr combine (PData "[]" []) s

30+ where combine h t = PData "::" [PLiteral (Chr h),t]

31+ _ -> PLiteral lit

32+ ]

33+

34+asPattern :: Pattern -> IParser Pattern

35+asPattern pattern = do

36+ var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))

37+ return $ case var of

38+ Just v -> PAlias v pattern

39+ Nothing -> pattern

40+

41+record :: IParser Pattern

42+record = PRecord <$> brackets (commaSep1 lowVar)

43+

44+tuple :: IParser Pattern

45+tuple = do ps <- parens (commaSep expr)

46+ return $ case ps of { [p] -> p; _ -> Pattern.tuple ps }

47+

48+list :: IParser Pattern

49+list = Pattern.list <$> braces (commaSep expr)

50+

51+term :: IParser Pattern

52+term =

53+ (choice [ record, tuple, list, basic ]) <?> "pattern"

54+

55+patternConstructor :: IParser Pattern

56+patternConstructor = do

57+ v <- intercalate "." <$> dotSep1 capVar

58+ case v of

59+ "True" -> return $ PLiteral (Boolean True)

60+ "False" -> return $ PLiteral (Boolean False)

61+ _ -> PData v <$> spacePrefix term

62+

63+expr :: IParser Pattern

64+expr = do

65+ patterns <- consSep1 (patternConstructor <|> term)

66+ asPattern (foldr1 Pattern.cons patterns) <?> "pattern"

67+

68+{--

69+extract :: Pattern -> LExpr t v -> Unique (String, LExpr t v)

70+extract pattern body@(L t s _) =

71+ let loc = L t s in

72+ let fn x e = (x,e) in

73+ case pattern of

74+ PAnything -> return $ fn "_" body

75+ PVar x -> return $ fn x body

76+ PAlias x PAnything -> return $ fn x body

77+ PAlias x p -> do

78+ (x', body') <- extract p body

79+ return $ fn x (loc $ Let [FnDef x' [] (loc $ Var x)] body')

80+ PData name ps -> do

81+ x <- guid

82+ let a = '_' : show x

83+ return . fn a . loc $ Case (loc (Var a)) [(pattern, body)]

84+ PRecord fs -> do

85+ x <- guid

86+ let a = '_' : show x

87+ toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)

88+ return . fn a . loc $ Let (map toDef fs) body

89+

90+extracts :: [Pattern] -> LExpr t v -> Unique ([String], LExpr t v)

91+extracts ps body = go [] (reverse ps) body

92+ where go args [] body = return (args, body)

93+ go args (p:ps) body = do (x,e) <- extract p body

94+ go (x:args) ps e

95+

96+flatten :: [Pattern] -> LExpr t v -> Unique (IParser [Def t v])

97+flatten patterns exp@(L t s _) =

98+ let loc = L t s in

99+ case patterns of

100+ PVar f : args -> do

101+ (as,e) <- extracts args exp

102+ return . return $

103+ if isOp (head f) then let [a,b] = as in [ OpDef f a b e ]

104+ else [ FnDef f as e ]

105+

106+ [p] -> return `liftM` matchSingle p exp p

107+

108+ _ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++

109+ ") cannot be used on the left-hand side of an assign statement."

110+

111+matchSingle :: Pattern -> LExpr t v -> Pattern -> Unique [Def t v]

112+matchSingle pat exp@(L t s _) p =

113+ let loc = L t s in

114+ case p of

115+ PData _ ps -> do

116+ x <- guid

117+ let v = '_' : show x

118+ dss <- mapM (matchSingle pat . loc $ Var v) ps

119+ return (FnDef v [] exp : concat dss)

120+

121+ PVar x ->

122+ return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]

123+

124+ PAlias x p' -> do

125+ subPat <- matchSingle p' (loc $ Var x) p'

126+ return $ (FnDef x [] (loc $ Case exp [(pat, loc $ Var x)])):subPat

127+

128+ PRecord fs -> do

129+ a <- (\x -> '_' : show x) `liftM` guid

130+ let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)

131+ return (FnDef a [] exp : map toDef fs)

132+

133+ PAnything -> return []

134+--}

compiler/Parse/Patterns.hsdeleted−105

@@ -1,105 +0,0 @@

1−

2−module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where

3−

4−import Ast

5−import Located

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

7−import Control.Monad

8−import Control.Monad.State

9−import Data.Char (isUpper)

10−import Guid

11−import Text.Parsec hiding (newline,spaces,State)

12−import Text.Parsec.Indent

13−import Parse.Library

14−

15−patternBasic :: IParser Pattern

16−patternBasic =

17− choice [ char '_' >> return PAnything

18− , do x@(c:_) <- var

19− return $ if isUpper c then PData x [] else PVar x

20− ]

21−

22−patternRecord :: IParser Pattern

23−patternRecord = PRecord <$> brackets (commaSep1 lowVar)

24−

25−patternTuple :: IParser Pattern

26−patternTuple = do ps <- parens (commaSep patternExpr)

27− return $ case ps of { [p] -> p; _ -> ptuple ps }

28−

29−patternList :: IParser Pattern

30−patternList = plist <$> braces (commaSep patternExpr)

31−

32−patternTerm :: IParser Pattern

33−patternTerm = choice [ patternRecord, patternTuple, patternList, patternBasic ]

34− <?> "pattern"

35−

36−patternConstructor :: IParser Pattern

37−patternConstructor = PData <$> capVar <*> spacePrefix patternTerm

38−

39−patternExpr :: IParser Pattern

40−patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"

41−

42−makeLambda :: [Pattern] -> CExpr -> GuidCounter CExpr

43−makeLambda pats body = go (reverse pats) body

44− where go [] body = return body

45− go (p:ps) body@(L t s _) = do

46− (x,e) <- extract p body

47− go ps (L t s $ Lambda x e)

48−

49−extract :: Pattern -> CExpr -> GuidCounter (String, CExpr)

50−extract pattern body@(L t s _) =

51− let loc = L t s in

52− let fn x e = (x,e) in

53− case pattern of

54− PAnything -> return $ fn "_" body

55− PVar x -> return $ fn x body

56− PData name ps -> do

57− x <- guid

58− let a = '_' : show x

59− return . fn a . loc $ Case (loc (Var a)) [(pattern, body)]

60− PRecord fs -> do

61− x <- guid

62− let a = '_' : show x

63− toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)

64− return . fn a . loc $ Let (map toDef fs) body

65−

66−extracts :: [Pattern] -> CExpr -> GuidCounter ([String], CExpr)

67−extracts ps body = go [] (reverse ps) body

68− where go args [] body = return (args, body)

69− go args (p:ps) body = do (x,e) <- extract p body

70− go (x:args) ps e

71−

72−flattenPatterns :: [Pattern] -> CExpr -> GuidCounter (IParser [Def])

73−flattenPatterns patterns exp@(L t s _) =

74− let loc = L t s in

75− case patterns of

76− PVar f : args -> do

77− (as,e) <- extracts args exp

78− return . return $

79− if isOp (head f) then let [a,b] = as in [ OpDef f a b e ]

80− else [ FnDef f as e ]

81−

82− [p] -> return `liftM` matchSingle p exp p

83−

84− _ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++

85− ") cannot be used on the left-hand side of an assign statement."

86−

87−matchSingle :: Pattern -> CExpr -> Pattern -> GuidCounter [Def]

88−matchSingle pat exp@(L t s _) p =

89− let loc = L t s in

90− case p of

91− PData _ ps -> do

92− x <- guid

93− let v = '_' : show x

94− dss <- mapM (matchSingle pat . loc $ Var v) ps

95− return (FnDef v [] exp : concat dss)

96−

97− PVar x ->

98− return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]

99−

100− PRecord fs -> do

101− a <- (\x -> '_' : show x) `liftM` guid

102− let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)

103− return (FnDef a [] exp : map toDef fs)

104−

105− PAnything -> return []

compiler/Parse/Type.hsnew file+81

@@ -0,0 +1,81 @@

1+module Parse.Type where

2+

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

4+import Control.Monad (liftM,mapM)

5+import Data.Char (isLower)

6+import Data.List (lookup,intercalate)

7+import Text.Parsec

8+import Text.Parsec.Indent

9+

10+import SourceSyntax.Type as T

11+import Parse.Helpers

12+import Unique

13+

14+tvar :: IParser T.Type

15+tvar = T.Var <$> lowVar <?> "type variable"

16+

17+list :: IParser T.Type

18+list = listOf <$> braces expr

19+

20+tuple :: IParser T.Type

21+tuple = do ts <- parens (commaSep expr)

22+ return $ case ts of

23+ [t] -> t

24+ _ -> tupleOf ts

25+

26+record :: IParser T.Type

27+record =

28+ do char '{' ; whitespace

29+ ext <- extend

30+ fs <- fields

31+ dumbWhitespace ; char '}'

32+ return (T.Record fs ext)

33+ where

34+ extend = option T.EmptyRecord . try $ do

35+ t <- tvar

36+ whitespace >> string "|" >> whitespace

37+ return t

38+ fields = commaSep $ do

39+ lbl <- rLabel

40+ whitespace >> hasType >> whitespace

41+ (,) lbl <$> expr

42+

43+capTypeVar = intercalate "." <$> dotSep1 capVar

44+

45+constructor0 :: IParser T.Type

46+constructor0 =

47+ do name <- capTypeVar

48+ return (T.Data name [])

49+

50+term :: IParser T.Type

51+term = list <|> tuple <|> record <|> tvar <|> constructor0

52+

53+app :: IParser T.Type

54+app =

55+ do name <- capTypeVar <|> try tupleCtor <?> "type constructor"

56+ args <- spacePrefix term

57+ return (T.Data name args)

58+ where

59+ tupleCtor = do

60+ n <- length <$> parens (many (char ','))

61+ return $ "_Tuple" ++ show (if n == 0 then 0 else n+1)

62+

63+expr :: IParser T.Type

64+expr =

65+ do t1 <- app <|> term

66+ whitespace

67+ arr <- optionMaybe arrow

68+ whitespace

69+ case arr of

70+ Just _ -> T.Lambda t1 <$> expr

71+ Nothing -> return t1

72+

73+constructor :: IParser (String, [T.Type])

74+constructor = (,) <$> (capTypeVar <?> "another type constructor")

75+ <*> spacePrefix term

76+

77+readType :: String -> Type

78+readType str =

79+ case iParse expr "" str of

80+ Left err -> error (show err)

81+ Right tipe -> tipe

compiler/Parse/Types.hsdeleted−170

@@ -1,170 +0,0 @@

1−module Parse.Types where

2−

3−import Ast

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

5−import Control.Monad (liftM,mapM)

6−import Data.Char (isUpper,isLower)

7−import Data.Maybe (fromMaybe)

8−import Data.List (lookup,intercalate)

9−import Text.Parsec

10−import Text.Parsec.Indent

11−

12−import Located

13−import Parse.Library

14−import Types.Types hiding (parens,string)

15−import Guid

16−

17−data ParseType = VarPT String

18− | LambdaPT ParseType ParseType

19− | ADTPT String [ParseType]

20− | RecordPT (Maybe ParseType) [(String,ParseType)]

21− deriving (Show)

22−

23−listPT t = ADTPT "List" [t]

24−tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts

25−

26−typeVar :: IParser ParseType

27−typeVar = VarPT <$> lowVar <?> "type variable"

28−

29−typeList :: IParser ParseType

30−typeList = listPT <$> braces typeExpr

31−

32−typeTuple :: IParser ParseType

33−typeTuple = do ts <- parens (commaSep typeExpr)

34− return $ case ts of { [t] -> t ; _ -> tuplePT ts }

35−

36−typeRecord :: IParser ParseType

37−typeRecord = brackets (RecordPT <$> extend <*> fields)

38− where extend = optionMaybe . try $ do

39− t <- typeVar

40− whitespace >> string "|" >> whitespace

41− return t

42− fields = commaSep $ do

43− lbl <- rLabel

44− whitespace >> hasType >> whitespace

45− (,) lbl <$> typeExpr

46−

47−typeUnambiguous :: IParser ParseType

48−typeUnambiguous = typeList <|> typeTuple <|> typeRecord

49−

50−typeSimple :: IParser ParseType

51−typeSimple = VarPT <$> var

52−

53−typeApp :: IParser ParseType

54−typeApp = do name <- capVar <?> "type constructor"

55− args <- spacePrefix (typeUnambiguous <|> typeSimple)

56− return $ case args of

57− [] -> VarPT name

58− _ -> ADTPT name args

59−

60−typeExpr :: IParser ParseType

61−typeExpr = do

62− t1 <- typeVar <|> typeApp <|> typeUnambiguous

63− whitespace ; arr <- optionMaybe arrow ; whitespace

64− case arr of

65− Just _ -> LambdaPT t1 <$> typeExpr

66− Nothing -> return t1

67−

68−typeConstructor :: IParser (String, [ParseType])

69−typeConstructor = (,) <$> (capVar <?> "another type constructor")

70− <*> spacePrefix (typeSimple <|> typeUnambiguous)

71−

72−typeAlias :: IParser [Statement]

73−typeAlias = do

74− start <- getPosition

75− reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

76− forcedWS

77− alias <- capVar

78− args <- spacePrefix lowVar

79− whitespace ; string "=" ; whitespace

80− let n = length args

81− tipe <- typeExpr

82− end <- getPosition

83− case toTypeWith alias (zip args [1..n]) tipe of

84− Left msg -> fail msg

85− Right t -> return (TypeAlias alias [1..n] t : ctor)

86− where ctor = case tipe of

87− RecordPT _ kvs -> [toConstructor start end alias kvs]

88− _ -> []

89−

90−toConstructor start end alias kvs =

91− Definition (FnDef alias args (loc (Record rec)))

92− where

93− loc = pos start end

94− args = map fst kvs

95− rec = map (\a -> (a, [], loc (Var a))) args

96−

97−

98−typeAnnotation :: IParser Def

99−typeAnnotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)

100− where start = do v <- lowVar <|> parens symOp

101− whitespace ; hasType ; whitespace ; return v

102−

103−datatype :: IParser Statement

104−datatype = do

105− reserved "data" <?> "datatype definition (data T = A | B | ...)"

106− forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar

107− whitespace ; string "=" ; whitespace

108− tcs <- pipeSep1 typeConstructor

109− case toDatatype name args tcs of

110− Right dt -> return dt

111− Left msg -> fail msg

112−

113−beta = liftM VarT guid

114−

115−toType :: ParseType -> Type

116−toType pt =

117− let frees :: ParseType -> [String]

118− frees pt = case pt of

119− LambdaPT a b -> frees a ++ frees b

120− ADTPT _ ts -> concatMap frees ts

121− RecordPT t fs -> maybe [] frees t ++ concatMap (frees . snd) fs

122− VarPT (c:cs) | isLower c -> [c:cs]

123− | otherwise -> []

124− in case toTypeWith "" (zip (frees pt) [1..]) pt of

125− Right t -> t

126− Left _ -> VarT 0

127−

128−toTypeWith :: String -> [(String,X)] -> ParseType -> Either String Type

129−toTypeWith name tvarDict pt =

130− let msg x = "Type variable '" ++ x ++ "' is unbound in type '" ++ name ++ "'."

131− toT = toTypeWith name tvarDict

132− in case pt of

133− LambdaPT t1 t2 -> (==>) <$> toT t1 <*> toT t2

134− ADTPT name args -> ADT name <$> mapM toT args

135− RecordPT t fs -> do fs' <- mapM (\(x,pt) -> (,) x <$> toT pt) fs

136− ext <- maybe (return EmptyRecord) toT t

137− return (RecordT (recordT fs') ext)

138− VarPT x@(c:_)

139− | not (isLower c) -> return $ ADT x []

140− | otherwise -> VarT <$> case lookup x tvarDict of

141− Just v -> Right v

142− Nothing -> Left (msg x)

143−

144−

145−toDatatype name args tcs = Datatype name [1..n] <$> mapM toC tcs

146− where n = length args

147− toType = toTypeWith name (zip args [1..n])

148− toC (name,pt) = (,) name <$> mapM toType pt

149−

150−

151−toForeignType (LambdaPT t1 t2) =

152− fail $ "Elm's JavaScript event interface does not yet handle functions. " ++

153− "Only simple values can be imported and exported in this release."

154−

155−toForeignType (ADTPT "JSArray" args) =

156− ADT "JSArray" <$> mapM toForeignType args

157−

158−toForeignType (ADTPT name _) =

159− Left $ "'" ++ name ++ "' is not an exportable type " ++

160− "constructor. Only 'JSArray' is exportable."

161−

162−toForeignType (VarPT x@(c:_))

163− | x `elem` jsTypes = Right (ADT x [])

164− | isLower c =

165− Left $ "All exported types must be concrete types." ++ msg

166− | otherwise =

167− Left $ "'" ++ x ++ "' is not an exportable type." ++ msg

168− where

169− msg = " The following types are exportable: " ++ intercalate ", " jsTypes

170− jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]

compiler/Paths_El.hsnew file+15

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

1+-- This is a dummy file, but it should not be removed.

2+-- It makes it possible to build the compiler in GHCi, so you

3+-- can do some testing from within emacs (or whatever inferior

4+-- editor you use instead).

5+

6+module Paths_Elm where

7+

8+import Data.Version

9+import System.FilePath

10+

11+getDataFileName :: FilePath -> IO FilePath

12+getDataFileName path = return ("dist" </> "data" </> path)

13+

14+version :: Version

15+version = Version [0,8,0,3] []

compiler/SourceSyntax/Declaration.hsnew file+18

@@ -0,0 +1,18 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+module SourceSyntax.Declaration where

3+

4+import Data.Data

5+import qualified SourceSyntax.Expression as Expr

6+import SourceSyntax.Type

7+

8+data Declaration tipe var

9+ = Definition (Expr.Def tipe var)

10+ | Datatype String [String] [(String,[Type])]

11+ | TypeAlias String [String] Type

12+ | ImportEvent String (Expr.LExpr tipe var) String Type

13+ | ExportEvent String String Type

14+ | Fixity Assoc Int String

15+ deriving (Eq, Show)

16+

17+data Assoc = L | N | R

18+ deriving (Eq, Show)

compiler/SourceSyntax/Everything.hsnew file+17

@@ -0,0 +1,17 @@

1+module SourceSyntax.Everything

2+ (module SourceSyntax.Helpers,

3+ module SourceSyntax.Location,

4+ module SourceSyntax.Literal,

5+ module SourceSyntax.Pattern,

6+ module SourceSyntax.Expression,

7+ module SourceSyntax.Declaration,

8+ module SourceSyntax.Module

9+ ) where

10+

11+import SourceSyntax.Helpers

12+import SourceSyntax.Location

13+import SourceSyntax.Literal

14+import SourceSyntax.Pattern hiding (tuple, list, cons, nil, prettyParens)

15+import SourceSyntax.Expression

16+import SourceSyntax.Declaration hiding (Assoc(..))

17+import SourceSyntax.Module

compiler/SourceSyntax/Expression.hsnew file+130

@@ -0,0 +1,130 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+module SourceSyntax.Expression where

3+

4+import Data.Data

5+import Data.List (intercalate)

6+import qualified Text.Pandoc as Pandoc

7+import SourceSyntax.PrettyPrint

8+import Text.PrettyPrint as P

9+import qualified SourceSyntax.Helpers as Help

10+import qualified SourceSyntax.Location as Location

11+import qualified SourceSyntax.Pattern as Pattern

12+import qualified SourceSyntax.Type as Type

13+import qualified SourceSyntax.Literal as Literal

14+

15+type LExpr tipe var = Location.Located (Expr tipe var)

16+data Expr t v

17+ = Literal Literal.Literal

18+ | Var String

19+ | Range (LExpr t v) (LExpr t v)

20+ | ExplicitList [LExpr t v]

21+ | Binop String (LExpr t v) (LExpr t v)

22+ | Lambda Pattern.Pattern (LExpr t v)

23+ | App (LExpr t v) (LExpr t v)

24+ | MultiIf [(LExpr t v,LExpr t v)]

25+ | Let [Def t v] (LExpr t v)

26+ | Case (LExpr t v) [(Pattern.Pattern, LExpr t v)]

27+ | Data String [LExpr t v]

28+ | Access (LExpr t v) String

29+ | Remove (LExpr t v) String

30+ | Insert (LExpr t v) String (LExpr t v)

31+ | Modify (LExpr t v) [(String, LExpr t v)]

32+ | Record [(String, LExpr t v)]

33+ | Markdown Pandoc.Pandoc

34+ deriving (Eq, Show, Data, Typeable)

35+

36+data Def tipe var

37+ = Def Pattern.Pattern (LExpr tipe var)

38+ | TypeAnnotation String Type.Type

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

40+

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

42+

43+delist (Location.L _ (Data "::" [h,t])) = h : delist t

44+delist _ = []

45+

46+saveEnvName = "_save_the_environment!!!"

47+

48+dummyLet defs =

49+ Location.none $ Let defs (Location.none $ Var saveEnvName)

50+

51+instance Pretty (Expr t v) where

52+ pretty expr =

53+ case expr of

54+ Literal lit -> pretty lit

55+ Var x -> variable x

56+ Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)

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

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

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

60+ Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)

61+ in P.text "\\" <> P.sep ps <+> P.text "->" <+> pretty body

62+ App _ _ -> P.hang func 2 (P.sep args)

63+ where func:args = map prettyParens (collectApps (Location.none expr))

64+ MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)

65+ where

66+ iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)

67+ Let defs e ->

68+ P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))

69+ , P.text "in" <+> pretty e ]

70+ Case e pats ->

71+ P.hang pexpr 2 (P.vcat (map pretty' pats))

72+ where

73+ pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]

74+ pretty' (p,e) = pretty p <+> P.text "->" <+> pretty e

75+ Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl

76+ Data "[]" [] -> P.text "[]"

77+ Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))

78+ Access e x -> prettyParens e <> P.text "." <> P.text x

79+ Remove e x -> P.braces (pretty e <+> P.text "-" <+> P.text x)

80+ Insert (Location.L _ (Remove e y)) x v ->

81+ P.braces (pretty e <+> P.text "-" <+> P.text y <+> P.text "|" <+> P.text x <+> P.text "=" <+> pretty v)

82+ Insert e x v ->

83+ P.braces (pretty e <+> P.text "|" <+> P.text x <+> P.text "=" <+> pretty v)

84+

85+ Modify e fs ->

86+ P.braces $ P.hang (pretty e <+> P.text "|")

87+ 4

88+ (commaSep $ map field fs)

89+ where

90+ field (x,e) = P.text x <+> P.text "<-" <+> pretty e

91+

92+ Record fs ->

93+ P.braces $ P.nest 2 (commaSep $ map field fs)

94+ where

95+ field (x,e) = P.text x <+> P.text "=" <+> pretty e

96+

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

98+

99+instance Pretty (Def t v) where

100+ pretty def =

101+ case def of

102+ TypeAnnotation name tipe ->

103+ variable name <+> P.text ":" <+> pretty tipe

104+ Def pattern expr ->

105+ pretty pattern <+> P.text "=" <+> pretty expr

106+

107+collectApps lexpr@(Location.L _ expr) =

108+ case expr of

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

110+ _ -> [lexpr]

111+

112+collectLambdas lexpr@(Location.L _ expr) =

113+ case expr of

114+ Lambda pattern body ->

115+ let (ps, body') = collectLambdas body

116+ in (pretty pattern : ps, body')

117+ _ -> ([], lexpr)

118+

119+prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

120+ where

121+ needed =

122+ case expr of

123+ Binop _ _ _ -> True

124+ Lambda _ _ -> True

125+ App _ _ -> True

126+ MultiIf _ -> True

127+ Let _ _ -> True

128+ Case _ _ -> True

129+ Data name (x:xs) -> name /= "::"

130+ _ -> False

compiler/SourceSyntax/Helpers.hsnew file+18

@@ -0,0 +1,18 @@

1+

2+module SourceSyntax.Helpers where

3+

4+import qualified Data.Char as Char

5+

6+brkt :: String -> String

7+brkt s = "{ " ++ s ++ " }"

8+

9+isTuple :: String -> Bool

10+isTuple name =

11+ take 6 name == "_Tuple" && all Char.isDigit (drop 6 name)

12+

13+isOp :: String -> Bool

14+isOp = all isSymbol

15+

16+isSymbol :: Char -> Bool

17+isSymbol c =

18+ Char.isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"

compiler/SourceSyntax/Literal.hsnew file+22

@@ -0,0 +1,22 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+module SourceSyntax.Literal where

3+

4+import Data.Data

5+import SourceSyntax.PrettyPrint

6+import qualified Text.PrettyPrint as PP

7+

8+data Literal = IntNum Int

9+ | FloatNum Float

10+ | Chr Char

11+ | Str String

12+ | Boolean Bool

13+ deriving (Eq, Ord, Data, Typeable, Show)

14+

15+instance Pretty Literal where

16+ pretty literal =

17+ case literal of

18+ IntNum n -> PP.int n

19+ FloatNum n -> PP.float n

20+ Chr c -> PP.quotes (PP.char c)

21+ Str s -> PP.text (show s)

22+ Boolean bool -> PP.text (show bool)

compiler/SourceSyntax/Location.hsnew file+60

@@ -0,0 +1,60 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+module SourceSyntax.Location where

3+

4+import Data.Data

5+import Text.PrettyPrint

6+import SourceSyntax.PrettyPrint

7+import qualified Text.Parsec.Pos as Parsec

8+

9+data SrcPos = Pos { line :: Int, column :: Int }

10+ deriving (Eq, Ord, Data, Typeable)

11+

12+data SrcSpan = Span SrcPos SrcPos String | NoSpan String

13+ deriving (Eq, Ord, Data, Typeable)

14+

15+data Located e = L SrcSpan e

16+ deriving (Eq, Ord, Data, Typeable)

17+

18+none e = L (NoSpan (render $ pretty e)) e

19+noneNoDocs = L (NoSpan "")

20+

21+at start end e = L (Span (Pos (Parsec.sourceLine start) (Parsec.sourceColumn start))

22+ (Pos (Parsec.sourceLine end ) (Parsec.sourceColumn end ))

23+ (render $ pretty e)) e

24+

25+merge (L s1 _) (L s2 _) e = L (span (render $ pretty e)) e

26+ where span = case (s1,s2) of

27+ (Span start _ _, Span _ end _) -> Span start end

28+ (Span start end _, _) -> Span start end

29+ (_, Span start end _) -> Span start end

30+ (_, _) -> NoSpan

31+

32+mergeOldDocs (L s1 _) (L s2 _) e = L span e

33+ where span = case (s1,s2) of

34+ (Span start _ d1, Span _ end d2) -> Span start end (d1 ++ "\n\n" ++ d2)

35+ (Span _ _ _, _) -> s1

36+ (_, Span _ _ _) -> s2

37+ (_, _) -> NoSpan ""

38+

39+sameAs (L s _) = L s

40+

41+

42+instance Show SrcPos where

43+ show (Pos r c) = show r ++ "," ++ show c

44+

45+instance Show SrcSpan where

46+ show span =

47+ case span of

48+ NoSpan _ -> ""

49+ Span start end _ ->

50+ case line start == line end of

51+ False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)

52+ True -> "line " ++ show (line end) ++ ", column " ++

53+ show (column start) ++ " to " ++ show (column end)

54+

55+instance Show e => Show (Located e) where

56+ show (L s e) = "L (" ++ show s ++ ") (" ++ show e ++ ")"

57+

58+instance Pretty a => Pretty (Located a) where

59+ pretty (L _ e) = pretty e

60+

compiler/SourceSyntax/Module.hsnew file+52

@@ -0,0 +1,52 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+module SourceSyntax.Module where

3+

4+import Data.Data

5+import Data.Binary

6+import Data.List (intercalate)

7+import qualified Data.Map as Map

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

9+import Control.Arrow (second)

10+

11+import SourceSyntax.Expression (LExpr)

12+import SourceSyntax.Declaration

13+import SourceSyntax.Type

14+import System.FilePath (joinPath)

15+import qualified Type.Type as Type

16+

17+data Module tipe var =

18+ Module [String] Exports Imports [Declaration tipe var]

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, Data, Typeable)

26+

27+data MetadataModule t v = MetadataModule {

28+ names :: [String],

29+ path :: FilePath,

30+ exports :: [String],

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

32+ program :: LExpr t v,

33+ types :: Map.Map String Type.Variable,

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

35+ aliases :: [(String, [String], Type)],

36+ datatypes :: [ (String, [String], [(String,[Type])]) ],

37+ foreignImports :: [(String, LExpr t v, String, Type)],

38+ foreignExports :: [(String, String, Type)]

39+}

40+

41+type Interfaces = Map.Map String ModuleInterface

42+type ADT = (String, [String], [(String,[Type])])

43+

44+data ModuleInterface = ModuleInterface {

45+ iTypes :: Map.Map String Type,

46+ iAdts :: [ADT],

47+ iAliases :: [(String, [String], Type)]

48+} deriving Show

49+

50+instance Binary ModuleInterface where

51+ put modul = put (iTypes modul) >> put (iAdts modul) >> put (iAliases modul)

52+ get = ModuleInterface <$> get <*> get <*> get

compiler/SourceSyntax/Pattern.hsnew file+48

@@ -0,0 +1,48 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+module SourceSyntax.Pattern where

3+

4+import Data.List (intercalate)

5+import Data.Data

6+import SourceSyntax.Helpers as Help

7+import SourceSyntax.PrettyPrint

8+import Text.PrettyPrint as PP

9+import SourceSyntax.Literal as Literal

10+

11+data Pattern = PData String [Pattern]

12+ | PRecord [String]

13+ | PAlias String Pattern

14+ | PVar String

15+ | PAnything

16+ | PLiteral Literal.Literal

17+ deriving (Eq, Ord, Data, Typeable, Show)

18+

19+cons h t = PData "::" [h,t]

20+nil = PData "[]" []

21+list = foldr cons nil

22+tuple es = PData ("_Tuple" ++ show (length es)) es

23+

24+

25+instance Pretty Pattern where

26+ pretty pattern =

27+ case pattern of

28+ PVar x -> variable x

29+ PLiteral lit -> pretty lit

30+ PRecord fs -> PP.braces (commaCat $ map PP.text fs)

31+ PAlias x p -> prettyParens p <+> PP.text "as" <+> PP.text x

32+ PAnything -> PP.text "_"

33+ PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl

34+ where isCons = case hd of

35+ PData "::" _ -> True

36+ _ -> False

37+ PData name ps ->

38+ if isTuple name then

39+ PP.parens . commaCat $ map pretty ps

40+ else sep (PP.text name : map prettyParens ps)

41+

42+prettyParens pattern = parensIf needsThem (pretty pattern)

43+ where

44+ needsThem =

45+ case pattern of

46+ PData name (_:_) | not (isTuple name) -> True

47+ PAlias _ _ -> True

48+ _ -> False

compiler/SourceSyntax/PrettyPrint.hsnew file+18

@@ -0,0 +1,18 @@

1+

2+module SourceSyntax.PrettyPrint where

3+

4+import Text.PrettyPrint

5+import qualified SourceSyntax.Helpers as Help

6+

7+class Pretty a where

8+ pretty :: a -> Doc

9+

10+instance Pretty () where

11+ pretty () = empty

12+

13+commaCat docs = cat (punctuate comma docs)

14+commaSep docs = sep (punctuate comma docs)

15+

16+parensIf bool doc = if bool then parens doc else doc

17+

18+variable x = parensIf (Help.isOp x) (text x)

compiler/SourceSyntax/Type.hsnew file+85

@@ -0,0 +1,85 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+module SourceSyntax.Type where

3+

4+import Data.Binary

5+import Data.Data

6+import qualified Data.Map as Map

7+import qualified SourceSyntax.Helpers as Help

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

9+import SourceSyntax.PrettyPrint

10+import Text.PrettyPrint as P

11+

12+data Type = Lambda Type Type

13+ | Var String

14+ | Data String [Type]

15+ | EmptyRecord

16+ | Record [(String,Type)] Type

17+ deriving (Eq, Show, Data, Typeable)

18+

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

20+fieldMap fields =

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

22+

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

24+recordOf fields = Record fields EmptyRecord

25+

26+listOf :: Type -> Type

27+listOf t = Data "_List" [t]

28+

29+tupleOf :: [Type] -> Type

30+tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts

31+

32+

33+instance Pretty Type where

34+ pretty tipe =

35+ case tipe of

36+ Lambda t1 t2 -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

37+ where t:ts = collectLambdas tipe

38+ Var x -> P.text x

39+ Data "_List" [t] -> P.brackets (pretty t)

40+ Data name tipes

41+ | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes

42+ | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)

43+ EmptyRecord -> P.braces P.empty

44+ Record fields ext -> P.braces $ P.hang (pretty ext <+> P.text "|") 4 prettyFields

45+ where

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

47+ prettyFields = commaSep . map prettyField $ fields

48+

49+collectLambdas tipe =

50+ case tipe of

51+ Lambda arg@(Lambda _ _) body -> P.parens (pretty arg) : collectLambdas body

52+ Lambda arg body -> pretty arg : collectLambdas body

53+ _ -> [pretty tipe]

54+

55+prettyParens tipe = parensIf needed (pretty tipe)

56+ where

57+ needed =

58+ case tipe of

59+ Lambda _ _ -> True

60+ Data _ [] -> False

61+ Data _ _ -> True

62+ _ -> False

63+

64+instance Binary Type where

65+ put tipe =

66+ case tipe of

67+ Lambda t1 t2 ->

68+ putWord8 0 >> put t1 >> put t2

69+ Var x ->

70+ putWord8 1 >> put x

71+ Data ctor tipes ->

72+ putWord8 2 >> put ctor >> put tipes

73+ EmptyRecord ->

74+ putWord8 3

75+ Record fs ext ->

76+ putWord8 4 >> put fs >> put ext

77+

78+ get = do

79+ n <- getWord8

80+ case n of

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

82+ 1 -> Var <$> get

83+ 2 -> Data <$> get <*> get

84+ 3 -> return EmptyRecord

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

compiler/SourceSyntax/Variable.hsnew file+2

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

1+module SourceSyntax.Variable where

2+

compiler/Transform/Canonicalize.hsnew file+177

@@ -0,0 +1,177 @@

1+module Transform.Canonicalize (interface, metadataModule) where

2+

3+import Control.Arrow ((***))

4+import Control.Monad.Identity

5+import qualified Data.Map as Map

6+import qualified Data.Set as Set

7+import qualified Data.List as List

8+import qualified Data.Either as Either

9+import SourceSyntax.Module

10+import SourceSyntax.Expression

11+import SourceSyntax.Location as Loc

12+import SourceSyntax.Pattern

13+import SourceSyntax.Helpers (isOp)

14+import qualified SourceSyntax.Type as Type

15+import qualified Transform.SortDefinitions as SD

16+import Text.PrettyPrint as P

17+

18+

19+interface :: String -> ModuleInterface -> ModuleInterface

20+interface moduleName iface =

21+ ModuleInterface {

22+ iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface)),

23+ iAdts = map (both prefix renameCtors) (iAdts iface),

24+ iAliases = map (both prefix renameType') (iAliases iface)

25+ }

26+ where

27+ both f g (a,b,c) = (f a, b, g c)

28+ prefix name = moduleName ++ "." ++ name

29+

30+ pair name = (name, moduleName ++ "." ++ name)

31+ canon (name,_,_) = pair name

32+ canons = Map.fromList $ concat

33+ [ map canon (iAdts iface), map canon (iAliases iface) ]

34+

35+ renameCtors ctors =

36+ map (prefix *** map renameType') ctors

37+ renameType' =

38+ runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

39+

40+renameType :: (Monad m) => (String -> m String) -> Type.Type -> m Type.Type

41+renameType rename tipe =

42+ let rnm = renameType rename in

43+ case tipe of

44+ Type.Lambda a b -> Type.Lambda `liftM` rnm a `ap` rnm b

45+ Type.Var x -> return tipe

46+ Type.Data name ts -> Type.Data `liftM` rename name `ap` mapM rnm ts

47+ Type.EmptyRecord -> return tipe

48+ Type.Record fields ext -> Type.Record `liftM` mapM rnm' fields `ap` rnm ext

49+ where rnm' (f,t) = (,) f `liftM` rnm t

50+

51+metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)

52+metadataModule ifaces modul =

53+ do _ <- case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

54+ [] -> Right ()

55+ missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

56+ program' <- rename initialEnv (program modul)

57+ aliases' <- mapM (third renameType') (aliases modul)

58+ datatypes' <- mapM (third (mapM (second (mapM renameType')))) (datatypes modul)

59+ return $ modul { program = program', aliases = aliases', datatypes = datatypes' }

60+ where

61+ second f (a,b) = (,) a `fmap` f b

62+ third f (a,b,c) = (,,) a b `fmap` f c

63+ renameType' =

64+ Either.either (\err -> Left [P.text err]) return . renameType (replace initialEnv)

65+

66+ get1 (a,_,_) = a

67+ canon (name, importMethod) =

68+ let pair pre var = (pre ++ drop (length name + 1) var, var)

69+ iface = ifaces Map.! name

70+ allNames = concat [ Map.keys (iTypes iface)

71+ , map get1 (iAliases iface)

72+ , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]

73+ in case importMethod of

74+ As alias -> map (pair (alias ++ ".")) allNames

75+ Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

76+ where vs = Set.fromList vars

77+ Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames

78+ where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars

79+

80+ pair n = (n,n)

81+ localEnv = map pair (map get1 (aliases modul) ++ map get1 (datatypes modul))

82+ globalEnv = map pair $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool"] ++

83+ map (\n -> "_Tuple" ++ show n) [0..9]

84+ realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)

85+ initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)

86+

87+

88+type Env = Map.Map String String

89+

90+extend :: Env -> Pattern -> Env

91+extend env pattern = Map.union (Map.fromList (zip xs xs)) env

92+ where xs = Set.toList (SD.boundVars pattern)

93+

94+

95+replace :: Env -> String -> Either String String

96+replace env v =

97+ if List.isPrefixOf "Native." v then return v else

98+ case Map.lookup v env of

99+ Just v' -> return v'

100+ Nothing -> Left $ "Could not find variable '" ++ v ++ "'." ++ msg

101+ where

102+ matches = filter (List.isInfixOf v) (Map.keys env)

103+ msg = if null matches then "" else

104+ "\nClose matches include: " ++ List.intercalate ", " matches

105+

106+rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)

107+rename env lexpr@(L s expr) =

108+ let rnm = rename env

109+ throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]

110+ format = Either.either throw return

111+ in

112+ L s `liftM`

113+ case expr of

114+ Literal lit -> return expr

115+

116+ Range e1 e2 -> Range `liftM` rnm e1 `ap` rnm e2

117+

118+ Access e x -> Access `liftM` rnm e `ap` return x

119+

120+ Remove e x -> flip Remove x `liftM` rnm e

121+

122+ Insert e x v -> flip Insert x `liftM` rnm e `ap` rnm v

123+

124+ Modify e fs ->

125+ Modify `liftM` rnm e `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs

126+

127+ Record fs -> Record `liftM` mapM frnm fs

128+ where

129+ frnm (f,e) = (,) f `liftM` rename env e

130+

131+ Binop op e1 e2 ->

132+ do op' <- format (replace env op)

133+ Binop op' `liftM` rnm e1 `ap` rnm e2

134+

135+ Lambda pattern e ->

136+ let env' = extend env pattern in

137+ Lambda pattern `liftM` rename env' e

138+

139+ App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2

140+

141+ MultiIf ps -> MultiIf `liftM` mapM grnm ps

142+ where grnm (b,e) = (,) `liftM` rnm b `ap` rnm e

143+

144+ Let defs e -> Let `liftM` mapM rename' defs `ap` rename env' e

145+ where

146+ env' = foldl extend env [ pattern | Def pattern _ <- defs ]

147+ rename' def =

148+ case def of

149+ Def p exp ->

150+ Def `liftM` format (renamePattern env' p) `ap` rename env' exp

151+ TypeAnnotation name tipe ->

152+ TypeAnnotation name `liftM` renameType (format . replace env') tipe

153+

154+ Var x -> Var `liftM` format (replace env x)

155+

156+ Data name es -> Data name `liftM` mapM rnm es

157+

158+ ExplicitList es -> ExplicitList `liftM` mapM rnm es

159+

160+ Case e cases -> Case `liftM` rnm e `ap` mapM branch cases

161+ where

162+ branch (pattern,e) = (,) `liftM` format (renamePattern env pattern)

163+ `ap` rename (extend env pattern) e

164+

165+ Markdown _ -> return expr

166+

167+

168+renamePattern :: Env -> Pattern -> Either String Pattern

169+renamePattern env pattern =

170+ case pattern of

171+ PVar _ -> return pattern

172+ PLiteral _ -> return pattern

173+ PRecord _ -> return pattern

174+ PAnything -> return pattern

175+ PAlias x p -> PAlias x `liftM` renamePattern env p

176+ PData name ps -> PData `liftM` replace env name

177+ `ap` mapM (renamePattern env) ps

compiler/Transform/Check.hsnew file+63

@@ -0,0 +1,63 @@

1+module Transform.Check (mistakes) where

2+

3+import Transform.SortDefinitions (boundVars)

4+import SourceSyntax.Everything

5+import qualified SourceSyntax.Type as T

6+import Data.List as List

7+import qualified Data.Map as Map

8+import qualified Data.Set as Set

9+import Data.Data

10+import Data.Generics.Uniplate.Data

11+import Text.PrettyPrint as P

12+

13+

14+mistakes :: (Data t, Data v) => [Declaration t v] -> [Doc]

15+mistakes decls =

16+ map P.text $ concatMap findErrors (getLets decls)

17+ where

18+ findErrors defs = duplicates defs ++ badOrder defs

19+

20+

21+getLets :: (Data t, Data v) => [Declaration t v] -> [[Def t v]]

22+getLets decls = defs : concatMap getSubLets defs

23+ where

24+ defs = concatMap (\d -> case d of Definition d -> [d] ; _ -> []) decls

25+

26+ getSubLets def =

27+ case def of

28+ Def pattern expr -> [ defs | Let defs _ <- universeBi expr ]

29+ TypeAnnotation _ _ -> []

30+

31+

32+duplicates :: [Def t v] -> [String]

33+duplicates defs =

34+ map defMsg (dups definitions) ++ map annMsg (dups annotations)

35+ where

36+ annotations = List.sort [ name | TypeAnnotation name _ <- defs ]

37+ definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]

38+

39+ dups = map head . filter ((>1) . length) . List.group

40+

41+ msg = "Syntax Error: There can only be one "

42+ defMsg x = msg ++ " definition of '" ++ x ++ "'."

43+ annMsg x = msg ++ " type annotation for '" ++ x ++ "'."

44+

45+

46+badOrder :: [Def t v] -> [String]

47+badOrder defs = go defs

48+ where

49+ msg x = "Syntax Error: The type annotation for '" ++ x ++

50+ "' must be directly above its definition."

51+

52+ go defs =

53+ case defs of

54+ TypeAnnotation name _ : Def (PVar name') _ : rest

55+ | name == name' -> go rest

56+

57+ TypeAnnotation name _ : rest -> [msg name] ++ go rest

58+

59+ _ : rest -> go rest

60+

61+ _ -> []

62+

63+

compiler/Transform/Optimize.hs+83−87

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

1−module Optimize (optimize) where

1+module Transform.Optimize (optimize) where

22

3−import Ast

4−import Located

5−import Control.Arrow (second)

3+import SourceSyntax.Everything

4+import Control.Arrow (second, (***))

65import Data.Char (isAlpha)

7−import Substitute

86

97optimize (Module name ims exs stmts) =

108 Module name ims exs (map optimizeStmt stmts)

@@ -15,122 +13,120 @@ optimizeStmt stmt = if stmt == stmt' then stmt' else optimizeStmt stmt'

1513class Simplify a where

1614 simp :: a -> a

1715

18−instance Simplify Statement where

16+instance Simplify (Declaration t v) where

1917 simp (Definition def) = Definition (simp def)

2018 simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t

2119 simp stmt = stmt

2220

23−instance Simplify Def where

24− simp (FnDef func args e) = FnDef func args (simp e)

25− simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)

21+instance Simplify (Def t v) where

22+ simp (Def name e) = Def name (simp e)

2623 simp x = x

2724

2825instance Simplify e => Simplify (Located e) where

29− simp (L t s e) = L t s (simp e)

26+ simp (L s e) = L s (simp e)

3027

31−instance Simplify Expr where

28+instance Simplify (Expr t v) where

3229 simp expr =

3330 let f = simp in

3431 case expr of

3532 Range e1 e2 -> Range (f e1) (f e2)

36− Binop op e1 e2 -> simp_binop op (f e1) (f e2)

33+ Binop op e1 e2 -> binop op (f e1) (f e2)

3734 Lambda x e -> Lambda x (f e)

38− Record fs -> Record (map (\(f,as,e) -> (f, as, simp e)) fs)

39− App (L t s (Lambda x e1)) e2 ->

40− if isValue e2' then subst x e2' e1' else App (L t s (Lambda x ce1')) ce2'

41− where ce1'@(L _ _ e1') = f e1

42− ce2'@(L _ _ e2') = f e2

35+ Record fs -> Record (map (second simp) fs)

4336 App e1 e2 -> App (f e1) (f e2)

44− If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)

4537 Let defs e -> Let (map simp defs) (f e)

4638 Data name es -> Data name (map f es)

39+ MultiIf es -> MultiIf . clipBranches $ map (f *** f) es

4740 Case e cases -> Case (f e) (map (second f) cases)

4841 _ -> expr

4942

50−simp_if (L _ _ (Boolean b)) (L _ _ e2) (L _ _ e3) = if b then e2 else e3

51−simp_if a b c = If a b c

43+

44+clipBranches [] = []

45+clipBranches (e:es) =

46+ case e of

47+ (L _ (Literal (Boolean True)), _) -> [e]

48+ _ -> e : clipBranches es

49+

5250

5351isValue e =

54− case e of { IntNum _ -> True

55− ; FloatNum _ -> True

56− ; Chr _ -> True

57− ; Str _ -> True

58− ; Boolean _ -> True

59− ; Var _ -> True

60− ; Data _ _ -> True

61− ; _ -> False }

62−

63−simp_binop = binop

64−

65−binop op ce1@(L t1 s1 e1) ce2@(L t2 s2 e2) =

66− let c1 = L t1 s1 in

67− let c2 = L t2 s2 in

52+ case e of

53+ Literal _ -> True

54+ Var _ -> True

55+ Data _ _ -> True

56+ _ -> False

57+

58+

59+binop op ce1@(L s1 e1) ce2@(L s2 e2) =

60+ let c1 = L s1

61+ c2 = L s2

62+ int = Literal . IntNum

63+ str = Literal . Str

64+ bool = Literal . Boolean

65+ in

6866 case (op, e1, e2) of

69− (_, IntNum n, IntNum m) -> case op of

70− { "+" -> IntNum $ (+) n m

71− ; "-" -> IntNum $ (-) n m

72− ; "*" -> IntNum $ (*) n m

73− ; "^" -> IntNum $ n ^ m

74− ; "div" -> IntNum $ div n m

75− ; "mod" -> IntNum $ mod n m

76− ; "<" -> Boolean $ n < m

77− ; ">" -> Boolean $ n < m

78− ; "<=" -> Boolean $ n <= m

79− ; ">=" -> Boolean $ n >= m

80− ; "==" -> Boolean $ n == m

81− ; "/=" -> Boolean $ n /= m

82− ; _ -> Binop op ce1 ce2 }

83−

67+ (_, Literal (IntNum n), Literal (IntNum m)) ->

68+ case op of

69+ { "+" -> int $ (+) n m

70+ ; "-" -> int $ (-) n m

71+ ; "*" -> int $ (*) n m

72+ ; "^" -> int $ n ^ m

73+ ; "div" -> int $ div n m

74+ ; "mod" -> int $ mod n m

75+ ; "rem" -> int $ rem n m

76+ ; "<" -> bool $ n < m

77+ ; ">" -> bool $ n > m

78+ ; "<=" -> bool $ n <= m

79+ ; ">=" -> bool $ n >= m

80+ ; "==" -> bool $ n == m

81+ ; "/=" -> bool $ n /= m

82+ ; _ -> Binop op ce1 ce2 }

83+ {--

8484 -- flip order to move lone integers to the left

8585 ("+", _, IntNum n) -> binop "+" ce2 ce1

8686 ("*", _, IntNum n) -> binop "*" ce2 ce1

8787

8888 ("+", IntNum 0, _) -> e2

89− ("+", IntNum n, Binop "+" (L _ _ (IntNum m)) ce) ->

89+ ("+", IntNum n, Binop "+" (L _ (IntNum m)) ce) ->

9090 binop "+" (c1 $ IntNum (n+m)) ce

91− ("+", Binop "+" (L _ _ (IntNum n)) ce1'

92− , Binop "+" (L _ _ (IntNum m)) ce2') ->

93− binop "+" (notLocated $ IntNum (n+m)) (notLocated $ Binop "+" ce1' ce2')

91+ ("+", Binop "+" (L _ (IntNum n)) ce1'

92+ , Binop "+" (L _ (IntNum m)) ce2') ->

93+ binop "+" (none $ IntNum (n+m)) (none $ Binop "+" ce1' ce2')

9494

9595 ("*", IntNum 0, _) -> e1

9696 ("*", IntNum 1, _) -> e2

97− ("*", IntNum n, Binop "*" (L _ _ (IntNum m)) ce) ->

98− binop "*" (notLocated $ IntNum (n*m)) ce

99− ("*", Binop "*" (L _ _ (IntNum n)) ce1'

100− , Binop "*" (L _ _ (IntNum m)) ce2') ->

101− binop "*" (notLocated $ IntNum (n*m)) (notLocated $ Binop "*" ce1' ce2')

97+ ("*", IntNum n, Binop "*" (L _ (IntNum m)) ce) ->

98+ binop "*" (none $ IntNum (n*m)) ce

99+ ("*", Binop "*" (L _ (IntNum n)) ce1'

100+ , Binop "*" (L _ (IntNum m)) ce2') ->

101+ binop "*" (none $ IntNum (n*m)) (none $ Binop "*" ce1' ce2')

102102

103103 ("-", _, IntNum 0) -> e1

104104 ("/", _, IntNum 1) -> e1

105105 ("div", _, IntNum 1) -> e1

106−

107− (_, Boolean n, Boolean m) -> case op of "&&" -> Boolean $ n && m

108− "||" -> Boolean $ n || m

109− _ -> Binop op ce1 ce2

110−

111− ("&&", Boolean True, _) -> e2

112− ("&&", Boolean False, _) -> Boolean False

113− ("||", Boolean True, _) -> Boolean True

114− ("||", Boolean False, _) -> e2

115−

116− ("::", _, _) -> let (L _ _ e) = cons ce1 ce2 in e

117−

118− ("++", Str s1, Str s2) -> Str $ s1 ++ s2

119− ("++", Str s1, Binop "++" (L _ _ (Str s2)) ce) ->

120− Binop "++" (c1 $ Str $ s1 ++ s2) ce

121− ("++", Binop "++" e (L _ _ (Str s1)), Str s2) ->

122− Binop "++" e (c1 $ Str $ s1 ++ s2)

123−

124− ("++", Data "Nil" [], _) -> e2

125− ("++", _, Data "Nil" []) -> e1

126− ("++", Data "Cons" [h,t], _) -> Data "Cons" [h, notLocated $ binop "++" t ce2]

127−

128− ("|>", _, _) -> App ce2 ce1

129− ("<|", _, _) -> App ce1 ce2

130− (".", _, _) ->

131− Lambda "x" (notLocated $

132− App ce1 (notLocated $ App ce2 (notLocated $ Var "x")))

106+--}

107+ (_, Literal (Boolean n), Literal (Boolean m)) ->

108+ case op of

109+ "&&" -> bool $ n && m

110+ "||" -> bool $ n || m

111+ _ -> Binop op ce1 ce2

112+

113+ ("&&", Literal (Boolean True), _) -> e2

114+ ("&&", Literal (Boolean False), _) -> bool False

115+ ("||", Literal (Boolean True), _) -> bool True

116+ ("||", Literal (Boolean False), _) -> e2

117+

118+ ("::", _, _) -> Data "::" [ce1, ce2]

119+

120+ ("++", Literal (Str s1), Literal (Str s2)) -> str $ s1 ++ s2

121+ ("++", Literal (Str s1), Binop "++" (L _ (Literal (Str s2))) ce) ->

122+ Binop "++" (c1 . str $ s1 ++ s2) ce

123+ ("++", Binop "++" e (L _ (Literal (Str s1))), Literal (Str s2)) ->

124+ Binop "++" e (c1 . str $ s1 ++ s2)

125+

126+ ("++", Data "[]" [], _) -> e2

127+ ("++", _, Data "[]" []) -> e1

128+ ("++", Data "::" [h,t], _) -> Data "::" [h, none $ binop "++" t ce2]

133129

134130 _ | isAlpha (head op) || '_' == head op ->

135− App (notLocated $ App (notLocated $ Var op) ce1) ce2

136− | otherwise -> Binop op ce1 ce2

131+ App (none $ App (none $ Var op) ce1) ce2

132+ | otherwise -> Binop op ce1 ce2

compiler/Transform/Rename.hsdeleted−150

@@ -1,150 +0,0 @@

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−module Rename (renameModule, derename, deprime) where

3−

4−import Ast

5−import Located

6−import Control.Arrow (first)

7−import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)

8−import Control.Monad.State (evalState, State, get, put)

9−import Data.Char (isLower,isDigit)

10−import Guid

11−

12−derename var

13− | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var

14− | otherwise = var

15−

16−renameModule :: Module -> Module

17−renameModule modul = run (rename deprime modul)

18−

19−class Rename a where

20− rename :: (String -> String) -> a -> GuidCounter a

21−

22−instance Rename Module where

23− rename env (Module name ex im stmts) = do stmts' <- renameStmts env stmts

24− return (Module name ex im stmts')

25−

26−instance Rename Def where

27− rename env (OpDef op a1 a2 e) =

28− do env' <- extends env [a1,a2]

29− OpDef op (env' a1) (env' a2) `liftM` rename env' e

30− rename env (FnDef f args e) =

31− do env' <- extends env args

32− FnDef (env f) (map env' args) `liftM` rename env' e

33− rename env (TypeAnnotation n t) = return (TypeAnnotation (env n) t)

34−

35−

36−instance Rename Statement where

37− rename env stmt =

38− case stmt of

39− Definition def -> Definition `liftM` rename env def

40− Datatype name args tcs ->

41− return $ Datatype name args $ map (first env) tcs

42− TypeAlias n xs t -> return (TypeAlias n xs t)

43− ImportEvent js base elm tipe ->

44− do base' <- rename env base

45− return $ ImportEvent js base' (env elm) tipe

46− ExportEvent js elm tipe ->

47− return $ ExportEvent js (env elm) tipe

48−

49−renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts

50− mapM (rename env') stmts

51− where getNames stmt = case stmt of

52− Definition (FnDef n _ _) -> [n]

53− Datatype _ _ tcs -> map fst tcs

54− ImportEvent _ _ n _ -> [n]

55− _ -> []

56−

57−instance Rename a => Rename (Located a) where

58− rename env (L t s e) = L t s `liftM` rename env e

59−

60−instance Rename Expr where

61− rename env expr =

62− let rnm = rename env in

63− case expr of

64−

65− Range e1 e2 -> Range `liftM` rnm e1

66− `ap` rnm e2

67−

68− Access e x -> Access `liftM` rnm e

69− `ap` return x

70−

71− Remove e x -> flip Remove x `liftM` rnm e

72−

73− Insert e x v -> flip Insert x `liftM` rnm e

74− `ap` rnm v

75−

76− Modify e fs -> Modify `liftM` rnm e

77− `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs

78−

79− Record fs -> Record `liftM` mapM frnm fs

80− where frnm (f,as,e) = do env' <- extends env as

81− e' <- rename env' e

82− return (f, map env' as, e')

83−

84− Binop op@(h:_) e1 e2 ->

85− let rop = if isLower h || '_' == h

86− then env op

87− else op

88− in Binop rop `liftM` rnm e1

89− `ap` rnm e2

90−

91− Lambda x e -> do

92− (rx, env') <- extend env x

93− Lambda rx `liftM` rename env' e

94−

95− App e1 e2 -> App `liftM` rnm e1

96− `ap` rnm e2

97−

98− If e1 e2 e3 -> If `liftM` rnm e1

99− `ap` rnm e2

100− `ap` rnm e3

101−

102− MultiIf ps -> MultiIf `liftM` mapM grnm ps

103− where grnm (b,e) = (,) `liftM` rnm b

104− `ap` rnm e

105−

106− Let defs e -> renameLet env defs e

107−

108− Var x -> return . Var $ env x

109−

110− Data name es -> Data name `liftM` mapM rnm es

111−

112− Case e cases -> Case `liftM` rnm e

113− `ap` mapM (patternRename env) cases

114−

115− _ -> return expr

116−

117−deprime = map (\c -> if c == '\'' then '$' else c)

118−

119−extend :: (String -> String) -> String -> GuidCounter (String, String -> String)

120−extend env x = do

121− n <- guid

122− let rx = deprime x ++ "_" ++ show n

123− return (rx, \y -> if y == x then rx else env y)

124−

125−extends :: (String -> String) -> [String] -> GuidCounter (String -> String)

126−extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs

127−

128−patternExtend :: Pattern -> (String -> String) -> GuidCounter (Pattern, String -> String)

129−patternExtend pattern env =

130− case pattern of

131− PAnything -> return (PAnything, env)

132− PVar x -> first PVar `liftM` extend env x

133− PData name ps ->

134− first (PData name . reverse) `liftM` foldM f ([], env) ps

135− where f (rps,env') p = do (rp,env'') <- patternExtend p env'

136− return (rp:rps, env'')

137− PRecord fs ->

138− return (pattern, foldr (\f e n -> if n == f then f else env n) env fs)

139−

140−patternRename :: (String -> String) -> (Pattern, CExpr) -> GuidCounter (Pattern, CExpr)

141−patternRename env (p,e) = do

142− (rp,env') <- patternExtend p env

143− re <- rename env' e

144− return (rp,re)

145−

146−renameLet env defs e = do env' <- extends env $ concatMap getNames defs

147− defs' <- mapM (rename env') defs

148− Let defs' `liftM` rename env' e

149− where getNames (FnDef n _ _) = [n]

150− getNames _ = []

compiler/Transform/Replace.hs+6−3

@@ -20,6 +20,7 @@ replace y v expr =

2020 Let defs e -> if y `elem` vs then Let defs e else Let (zip vs (map f es)) (f e)

2121 where (vs,es) = unzip defs

2222 Var x -> if x == y then v else Var x

23+ ExplicitList es -> ExplicitList (map f es)

2324 Data name es -> Data name (map f es)

2425 Case e cases -> Case (f e) $ map (caseReplace y v) cases

2526 _ -> expr

@@ -32,8 +33,10 @@ patternVars :: Pattern -> Set String

3233patternVars pattern =

3334 case pattern of

3435 PData _ ps -> unions (map patternVars ps)

35− PVar x -> singleton x

36− PAnything -> empty

36+ PVar x -> singleton x

37+ PAsVar x p -> insert x (patternVars p)

38+ PAnything -> empty

39+ PLiteral _ -> empty

3740

3841depth :: Expr -> Integer

3942depth = depth' 0

@@ -51,7 +54,7 @@ depth' d expr =

5154 Fold e1 e2 e3 -> maximum [f e1, f e2, f e3]

5255 Async e -> f e

5356 Let defs e -> let (_,es) = unzip defs in maximum $ f e : map f es

54− Data "Cons" es -> maximum $ map (depth' d) es

57+ Data "::" es -> maximum $ map (depth' d) es

5558 Data name es -> maximum $ 1 : map f es

5659 Case e cases -> maximum $ f e : map (f . snd) cases

5760 _ -> d

compiler/Transform/SortDefinitions.hsnew file+198

@@ -0,0 +1,198 @@

1+

2+module Transform.SortDefinitions (sortDefs, boundVars, flattenLets) where

3+

4+import Control.Monad.State

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

6+import qualified Data.Set as Set

7+import qualified Data.Map as Map

8+import qualified SourceSyntax.Type as ST

9+import SourceSyntax.Everything

10+import qualified Data.Graph as Graph

11+import qualified Data.Map as Map

12+import qualified Data.Maybe as Maybe

13+

14+boundVars :: Pattern -> Set.Set String

15+boundVars pattern =

16+ case pattern of

17+ PVar x -> Set.singleton x

18+ PAlias x p -> Set.insert x (boundVars p)

19+ PData _ ps -> Set.unions (map boundVars ps)

20+ PRecord fields -> Set.fromList fields

21+ PAnything -> Set.empty

22+ PLiteral _ -> Set.empty

23+

24+ctors :: Pattern -> [String]

25+ctors pattern =

26+ case pattern of

27+ PVar x -> []

28+ PAlias x p -> ctors p

29+ PData ctor ps -> ctor : concatMap ctors ps

30+ PRecord fields -> []

31+ PAnything -> []

32+ PLiteral _ -> []

33+

34+free :: String -> State (Set.Set String) ()

35+free x = modify (Set.insert x)

36+

37+bound :: Set.Set String -> State (Set.Set String) ()

38+bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

39+

40+sortDefs :: LExpr t v -> LExpr t v

41+sortDefs expr = evalState (reorder expr) Set.empty

42+

43+flattenLets defs lexpr@(L _ expr) =

44+ case expr of

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

46+ _ -> (defs, lexpr)

47+

48+

49+reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)

50+reorder lexpr@(L s expr) =

51+ L s `liftM`

52+ case expr of

53+ -- Be careful adding and restricting freeVars

54+ Var x -> free x >> return expr

55+

56+ Lambda p e ->

57+ uncurry Lambda `liftM` bindingReorder (p,e)

58+

59+ Binop op e1 e2 ->

60+ do free op

61+ Binop op `liftM` reorder e1 `ap` reorder e2

62+

63+ Case e cases ->

64+ Case `liftM` reorder e `ap` mapM bindingReorder cases

65+

66+ Data name es ->

67+ do free name

68+ Data name `liftM` mapM reorder es

69+

70+ -- Just pipe the reorder though

71+ Literal _ -> return expr

72+

73+ Range e1 e2 ->

74+ Range `liftM` reorder e1 `ap` reorder e2

75+

76+ ExplicitList es ->

77+ ExplicitList `liftM` mapM reorder es

78+

79+ App e1 e2 ->

80+ App `liftM` reorder e1 `ap` reorder e2

81+

82+ MultiIf branches ->

83+ MultiIf `liftM` mapM reorderPair branches

84+

85+ Access e lbl ->

86+ Access `liftM` reorder e `ap` return lbl

87+

88+ Remove e lbl ->

89+ Remove `liftM` reorder e `ap` return lbl

90+

91+ Insert e lbl v ->

92+ Insert `liftM` reorder e `ap` return lbl `ap` reorder v

93+

94+ Modify e fields ->

95+ Modify `liftM` reorder e `ap` mapM reorderField fields

96+

97+ Record fields ->

98+ Record `liftM` mapM reorderField fields

99+

100+ Markdown _ -> return expr

101+

102+ -- Actually do some reordering

103+ Let defs body ->

104+ do body' <- reorder body

105+

106+ -- Sort defs into strongly connected components.This

107+ -- allows the programmer to write definitions in whatever

108+ -- order they please, we can still define things in order

109+ -- and generalize polymorphic functions when appropriate.

110+ sccs <- Graph.stronglyConnComp <$> buildDefDict defs

111+ let defss = map Graph.flattenSCC sccs

112+

113+ -- remove let-bound variables from the context

114+ let getPatterns def =

115+ case def of

116+ Def pattern _ -> pattern

117+ TypeAnnotation name _ -> PVar name

118+ forM (map getPatterns defs) $ \pattern -> do

119+ bound (boundVars pattern)

120+ mapM free (ctors pattern)

121+

122+ let addDefs ds bod = L s (Let (concatMap toDefs ds) bod)

123+ where

124+ toDefs (pattern, expr, Nothing) = [ Def pattern expr ]

125+ toDefs (PVar name, expr, Just tipe) =

126+ [ TypeAnnotation name tipe, Def (PVar name) expr ]

127+

128+ L _ let' = foldr addDefs body' defss

129+

130+ return let'

131+

132+

133+reorderField (label, expr) =

134+ (,) label `liftM` reorder expr

135+

136+reorderPair (e1,e2) =

137+ (,) `liftM` reorder e1 `ap` reorder e2

138+

139+bindingReorder :: (Pattern, LExpr t v) -> State (Set.Set String) (Pattern, LExpr t v)

140+bindingReorder (pattern,expr) =

141+ do expr' <- reorder expr

142+ bound (boundVars pattern)

143+ mapM free (ctors pattern)

144+ return (pattern, expr')

145+

146+

147+type PDef t v = (Pattern, LExpr t v, Maybe ST.Type)

148+

149+reorderAndGetDependencies :: PDef t v -> State (Set.Set String) (PDef t v, [String])

150+reorderAndGetDependencies (pattern, expr, mType) =

151+ do globalFrees <- get

152+ -- work in a fresh environment

153+ put Set.empty

154+ expr' <- reorder expr

155+ localFrees <- get

156+ -- merge with global frees

157+ modify (Set.union globalFrees)

158+ return ((pattern, expr', mType), Set.toList localFrees)

159+

160+

161+-- This also reorders the all of the sub-expressions in the Def list.

162+buildDefDict :: [Def t v] -> State (Set.Set String) [(PDef t v, Int, [Int])]

163+buildDefDict defs =

164+ do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)

165+ return $ realDeps (addKey pdefsDeps)

166+

167+ where

168+ getPDefs :: [Def t v] -> [PDef t v]

169+ getPDefs defs = map (\(p,(e,t)) -> (p,e,t)) $

170+ Map.toList $ go defs Map.empty Map.empty

171+ where

172+ go [] ds ts =

173+ Map.unions [ Map.difference ds ts

174+ , Map.intersectionWith (\(e,_) t -> (e,Just t)) ds ts ]

175+

176+ go (def:defs) ds ts =

177+ case def of

178+ Def p e -> go defs (Map.insert p (e, Nothing) ds) ts

179+ TypeAnnotation name tipe -> go defs ds (Map.insert (PVar name) tipe ts)

180+

181+ addKey :: [(PDef t v, [String])] -> [(PDef t v, Int, [String])]

182+ addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

183+

184+ variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]

185+ variableToKey ((pattern, _, _), key, _) =

186+ [ (var, key) | var <- Set.toList (boundVars pattern) ]

187+

188+ variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int

189+ variableToKeyMap pdefsDeps =

190+ Map.fromList (concatMap variableToKey pdefsDeps)

191+

192+ realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]

193+ realDeps pdefsDeps = map convert pdefsDeps

194+ where

195+ varDict = variableToKeyMap pdefsDeps

196+ convert (pdef, key, deps) =

197+ (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)

198+

compiler/Transform/Substitute.hs+18−17

@@ -1,29 +1,30 @@

1−module Substitute (subst) where

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Substitute (subst) where

23

3−import Ast

4−import Located

4+import SourceSyntax.Expression

5+import SourceSyntax.Location

56import Control.Arrow (second, (***))

67

7−subst :: String -> Expr -> Expr -> Expr

8+subst :: String -> Expr t v -> Expr t v -> Expr t v

89subst old new expr =

9− let f (L t s e) = L t s (subst old new e) in

10+ let f (L s e) = L s (subst old new e) in

1011 case expr of

1112 Range e1 e2 -> Range (f e1) (f e2)

12− Access e x -> Access (f e) x

13− Remove e x -> Remove (f e) x

14− Insert e x v -> Insert (f e) x (f v)

15− Modify r fs -> Modify (f r) (map (second f) fs)

16− Record fs -> Record (map (\(lbl,as,e) -> (lbl,as,f e)) fs)

13+ ExplicitList es -> ExplicitList (map f es)

1714 Binop op e1 e2 -> Binop op (f e1) (f e2)

18− Lambda x e -> if x == old then expr else Lambda x (f e)

15+ Lambda p e -> Lambda p (f e)

1916 App e1 e2 -> App (f e1) (f e2)

20− If e1 e2 e3 -> If (f e1) (f e2) (f e3)

2117 MultiIf ps -> MultiIf (map (f *** f) ps)

22− Let defs e -> Let (map substDef defs) (f e)

23− where substDef (FnDef name vs e) = FnDef name vs (f e)

24− substDef (OpDef op a1 a2 e) = OpDef op a1 a2 (f e)

25− substDef x = x

18+ Let defs body -> Let (map substDef defs) (f body)

19+ where substDef (Def name e) = Def name (f e)

20+ substDef anno@(TypeAnnotation _ _) = anno

2621 Var x -> if x == old then new else expr

2722 Case e cases -> Case (f e) $ map (second f) cases

2823 Data name es -> Data name (map f es)

29− _ -> expr

24+ Access e x -> Access (f e) x

25+ Remove e x -> Remove (f e) x

26+ Insert e x v -> Insert (f e) x (f v)

27+ Modify r fs -> Modify (f r) (map (second f) fs)

28+ Record fs -> Record (map (second f) fs)

29+ Literal _ -> expr

30+ Markdown _ -> expr

compiler/Type/Constrain/Declaration.hsnew file+68

@@ -0,0 +1,68 @@

1+module Type.Constrain.Declaration where

2+

3+import Control.Monad

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

5+

6+import qualified Data.Map as Map

7+

8+import qualified Type.Constrain.Expression as TcExpr

9+import qualified Type.Environment as Env

10+

11+import SourceSyntax.Declaration

12+import qualified SourceSyntax.Everything as Src

13+import qualified SourceSyntax.Type as Type

14+

15+toExpr :: [Declaration t v] -> [Src.Def t v]

16+toExpr = concatMap toDefs

17+

18+toDefs :: Declaration t v -> [Src.Def t v]

19+toDefs decl =

20+ case decl of

21+ Definition def -> [def]

22+

23+ Datatype name tvars constructors -> concatMap toDefs constructors

24+ where

25+ toDefs (ctor, tipes) =

26+ let vars = take (length tipes) arguments

27+ tbody = Type.Data name $ map Type.Var tvars

28+ body = Src.none . Src.Data ctor $ map (Src.none . Src.Var) vars

29+ in [ Src.TypeAnnotation ctor $ foldr Type.Lambda tbody tipes

30+ , Src.Def (Src.PVar ctor) $ buildFunction body vars

31+ ]

32+

33+ TypeAlias name tvars tipe@(Type.Record fields ext) ->

34+ [ Src.TypeAnnotation name $ foldr Type.Lambda tipe args

35+ , Src.Def (Src.PVar name) $ buildFunction record vars ]

36+ where

37+ args = case ext of

38+ Type.EmptyRecord -> map snd fields

39+ _ -> map snd fields ++ [ext]

40+

41+ var = Src.none . Src.Var

42+ vars = take (length args) arguments

43+

44+ efields = zip (map fst fields) (map var vars)

45+ record = case ext of

46+ Type.EmptyRecord -> Src.none $ Src.Record efields

47+ _ -> foldl (\r (f,v) -> Src.none $ Src.Insert r f v) (var $ last vars) efields

48+

49+ -- Type aliases must be added to an extended equality dictionary,

50+ -- but they do not require any basic constraints.

51+ TypeAlias _ _ _ -> []

52+

53+ ImportEvent _ expr@(Src.L s _) name tipe ->

54+ [ Src.TypeAnnotation name tipe

55+ , Src.Def (Src.PVar name) (Src.L s $ Src.App (Src.L s $ Src.Var "constant") expr) ]

56+

57+ ExportEvent _ name tipe ->

58+ [ Src.TypeAnnotation name tipe ]

59+

60+ -- no constraints are needed for fixity declarations

61+ Fixity _ _ _ -> []

62+

63+

64+arguments :: [String]

65+arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show n) [1..]

66+

67+buildFunction body@(Src.L s _) vars =

68+ foldr (\p e -> Src.L s (Src.Lambda p e)) body (map Src.PVar vars)

compiler/Type/Constrain/Expression.hsnew file+215

@@ -0,0 +1,215 @@

1+module Type.Constrain.Expression where

2+

3+import qualified Data.List as List

4+import qualified Data.Map as Map

5+import qualified Data.Set as Set

6+import Control.Arrow (second)

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

8+import qualified Control.Monad as Monad

9+import Control.Monad.State

10+import Data.Traversable (traverse)

11+

12+import SourceSyntax.Location as Loc

13+import SourceSyntax.Pattern (Pattern(PVar))

14+import SourceSyntax.Expression

15+import qualified SourceSyntax.Type as SrcT

16+import Type.Type hiding (Descriptor(..))

17+import Type.Fragment

18+import qualified Type.Environment as Env

19+import qualified Type.Constrain.Literal as Literal

20+import qualified Type.Constrain.Pattern as Pattern

21+import qualified Transform.SortDefinitions as SD

22+

23+

24+constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint

25+constrain env (L span expr) tipe =

26+ let list t = Env.get env Env.types "_List" <| t

27+ and = L span . CAnd

28+ true = L span CTrue

29+ t1 === t2 = L span (CEqual t1 t2)

30+ x <? t = L span (CInstance x t)

31+ clet schemes c = L span (CLet schemes c)

32+ in

33+ case expr of

34+ Literal lit -> Literal.constrain env span lit tipe

35+

36+ Var name -> return (name <? tipe)

37+

38+ Range lo hi ->

39+ exists $ \x -> do

40+ clo <- constrain env lo x

41+ chi <- constrain env hi x

42+ return $ and [clo, chi, list x === tipe]

43+

44+ ExplicitList exprs ->

45+ exists $ \x -> do

46+ cs <- mapM (\e -> constrain env e x) exprs

47+ return . and $ list x === tipe : cs

48+

49+ Binop op e1 e2 ->

50+ exists $ \t1 ->

51+ exists $ \t2 -> do

52+ c1 <- constrain env e1 t1

53+ c2 <- constrain env e2 t2

54+ return $ and [ c1, c2, op <? (t1 ==> t2 ==> tipe) ]

55+

56+ Lambda p e ->

57+ exists $ \t1 ->

58+ exists $ \t2 -> do

59+ fragment <- Pattern.constrain env p t1

60+ c2 <- constrain env e t2

61+ let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]

62+ (typeConstraint fragment /\ c2 ))

63+ return $ c /\ tipe === (t1 ==> t2)

64+

65+ App e1 e2 ->

66+ exists $ \t -> do

67+ c1 <- constrain env e1 (t ==> tipe)

68+ c2 <- constrain env e2 t

69+ return $ c1 /\ c2

70+

71+ MultiIf branches -> and <$> mapM constrain' branches

72+ where

73+ bool = Env.get env Env.types "Bool"

74+ constrain' (b,e) = do

75+ cb <- constrain env b bool

76+ ce <- constrain env e tipe

77+ return (cb /\ ce)

78+

79+ Case exp branches ->

80+ exists $ \t -> do

81+ ce <- constrain env exp t

82+ let branch (p,e) = do

83+ fragment <- Pattern.constrain env p t

84+ clet [toScheme fragment] <$> constrain env e tipe

85+ and . (:) ce <$> mapM branch branches

86+

87+ Data name exprs ->

88+ do pairs <- mapM pair exprs

89+ (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

90+ return (cs /\ name <? ctipe)

91+ where

92+ pair e = do v <- var Flexible -- needs an ex

93+ return (e, VarN v)

94+

95+ step (t,c) (e,x) = do

96+ c' <- constrain env e x

97+ return (x ==> t, c /\ c')

98+

99+ Access e label ->

100+ exists $ \t ->

101+ constrain env e (record (Map.singleton label [tipe]) t)

102+

103+ Remove e label ->

104+ exists $ \t ->

105+ constrain env e (record (Map.singleton label [t]) tipe)

106+

107+ Insert e label value ->

108+ exists $ \tVal ->

109+ exists $ \tRec -> do

110+ cVal <- constrain env value tVal

111+ cRec <- constrain env e tRec

112+ let c = tipe === record (Map.singleton label [tVal]) tRec

113+ return (and [cVal, cRec, c])

114+

115+ Modify e fields ->

116+ exists $ \t -> do

117+ oldVars <- forM fields $ \_ -> var Flexible

118+ let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))

119+ cOld <- ex oldVars <$> constrain env e (record oldFields t)

120+

121+ newVars <- forM fields $ \_ -> var Flexible

122+ let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))

123+ let cNew = tipe === record newFields t

124+

125+ cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)

126+

127+ return $ cOld /\ ex newVars (and (cNew : cs))

128+

129+ Record fields ->

130+ do vars <- forM fields $ \_ -> var Flexible

131+ cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)

132+ let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))

133+ recordType = record fields' (TermN EmptyRecord1)

134+ return . ex vars . and $ tipe === recordType : cs

135+

136+ Markdown _ ->

137+ return ("Graphics.Element.markdown" <? tipe)

138+

139+ Let defs body ->

140+ do c <- case body of

141+ L _ (Var name) | name == saveEnvName -> return (L span CSaveEnv)

142+ _ -> constrain env body tipe

143+ (schemes, rqs, fqs, header, c2, c1) <-

144+ Monad.foldM (constrainDef env)

145+ ([], [], [], Map.empty, true, true)

146+ (collapseDefs defs)

147+ return $ clet schemes

148+ (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

149+ (c1 /\ c))

150+

151+constrainDef env info (pattern, expr, maybeTipe) =

152+ let qs = [] -- should come from the def, but I'm not sure what would live there...

153+ (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

154+ in

155+ case (pattern, maybeTipe) of

156+ (PVar name, Just tipe) ->

157+ do flexiVars <- mapM (\_ -> var Flexible) qs

158+ let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars

159+ env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

160+ (vars, typ) <- Env.instantiateType env tipe Map.empty

161+ let scheme = Scheme { rigidQuantifiers = [],

162+ flexibleQuantifiers = flexiVars ++ vars,

163+ constraint = Loc.noneNoDocs CTrue,

164+ header = Map.singleton name typ }

165+ c <- constrain env' expr typ

166+ return ( scheme : schemes

167+ , rigidQuantifiers

168+ , flexibleQuantifiers

169+ , headers

170+ , c2

171+ , fl rigidQuantifiers c /\ c1 )

172+

173+ (PVar name, Nothing) ->

174+ do v <- var Flexible

175+ rigidVars <- mapM (\_ -> var Rigid) qs -- Some mistake may be happening here.

176+ -- Currently, qs is always the empty list.

177+ let tipe = VarN v

178+ inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars

179+ env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

180+ c <- constrain env' expr tipe

181+ return ( schemes

182+ , rigidVars ++ rigidQuantifiers

183+ , v : flexibleQuantifiers

184+ , Map.insert name tipe headers

185+ , c /\ c2

186+ , c1 )

187+

188+

189+expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)

190+ -> [(Pattern, LExpr t v, Maybe SrcT.Type)]

191+expandPattern triple@(pattern, lexpr@(L s _), maybeType) =

192+ case pattern of

193+ PVar _ -> [triple]

194+ _ -> (PVar x, lexpr, maybeType) : map toDef vars

195+ where

196+ vars = Set.toList $ SD.boundVars pattern

197+ x = concat vars

198+ var = L s . Var

199+ toDef y = (PVar y, L s $ Case (var x) [(pattern, var y)], Nothing)

200+

201+collapseDefs :: [Def t v] -> [(Pattern, LExpr t v, Maybe SrcT.Type)]

202+collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty

203+ where

204+ go output defs typs [] =

205+ output ++ concatMap Map.elems [

206+ Map.intersectionWithKey (\k v t -> (PVar k, v, Just t)) defs typs,

207+ Map.mapWithKey (\k v -> (PVar k, v, Nothing)) (Map.difference defs typs) ]

208+ go output defs typs (d:ds) =

209+ case d of

210+ Def (PVar name) body ->

211+ go output (Map.insert name body defs) typs ds

212+ Def pattern body ->

213+ go ((pattern, body, Nothing) : output) defs typs ds

214+ TypeAnnotation name typ ->

215+ go output defs (Map.insert name typ typs) ds

compiler/Type/Constrain/Literal.hsnew file+21

@@ -0,0 +1,21 @@

1+module Type.Constrain.Literal where

2+

3+import SourceSyntax.Literal

4+import SourceSyntax.Location

5+import Type.Type

6+import Type.Environment as Env

7+

8+constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint

9+constrain env span literal tipe =

10+ do tipe' <- litType

11+ return . L span $ CEqual tipe tipe'

12+ where

13+ prim name = Env.get env Env.types name

14+

15+ litType =

16+ case literal of

17+ IntNum _ -> VarN `fmap` var (Is Number)

18+ FloatNum _ -> return (prim "Float")

19+ Chr _ -> return (prim "Char")

20+ Str _ -> return (TermN (App1 (prim "_List") (prim "Char")))

21+ Boolean _ -> return (prim "Bool")

compiler/Type/Constrain/Pattern.hsnew file+68

@@ -0,0 +1,68 @@

1+module Type.Constrain.Pattern where

2+

3+import Control.Arrow (second)

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

5+import qualified Control.Monad as Monad

6+import qualified Data.List as List

7+import qualified Data.Maybe as Maybe

8+import qualified Data.Map as Map

9+

10+import SourceSyntax.Pattern

11+import SourceSyntax.PrettyPrint

12+import Text.PrettyPrint (render)

13+import qualified SourceSyntax.Location as Loc

14+import Type.Type

15+import Type.Fragment

16+import Type.Environment as Env

17+import qualified Type.Constrain.Literal as Literal

18+

19+

20+constrain :: Environment -> Pattern -> Type -> IO Fragment

21+constrain env pattern tipe =

22+ let span = Loc.NoSpan (render $ pretty pattern)

23+ t1 === t2 = Loc.L span (CEqual t1 t2)

24+ x <? t = Loc.L span (CInstance x t)

25+ in

26+ case pattern of

27+ PAnything -> return emptyFragment

28+

29+ PLiteral lit -> do

30+ c <- Literal.constrain env span lit tipe

31+ return $ emptyFragment { typeConstraint = c }

32+

33+ PVar name -> do

34+ v <- var Flexible

35+ return $ Fragment {

36+ typeEnv = Map.singleton name (VarN v),

37+ vars = [v],

38+ typeConstraint = VarN v === tipe

39+ }

40+

41+ PAlias name p -> do

42+ fragment <- constrain env p tipe

43+ return $ fragment {

44+ typeEnv = Map.insert name tipe (typeEnv fragment),

45+ typeConstraint = name <? tipe /\ typeConstraint fragment

46+ }

47+

48+ PData name patterns -> do

49+ (kind, cvars, args, result) <- freshDataScheme env name

50+ let msg = concat [ "Constructor '", name, "' expects ", show kind

51+ , " argument", if kind == 1 then "" else "s"

52+ , " but was given ", show (length patterns), "." ]

53+ if length patterns /= kind then error msg else do

54+ fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)

55+ return $ fragment {

56+ typeConstraint = typeConstraint fragment /\ tipe === result,

57+ vars = cvars ++ vars fragment

58+ }

59+

60+ PRecord fields -> do

61+ pairs <- mapM (\name -> (,) name <$> var Flexible) fields

62+ let tenv = Map.fromList (map (second VarN) pairs)

63+ c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

64+ return $ Fragment {

65+ typeEnv = tenv,

66+ vars = map snd pairs,

67+ typeConstraint = c

68+ }

compiler/Type/Environment.hsnew file+161

@@ -0,0 +1,161 @@

1+module Type.Environment where

2+

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

4+import Control.Monad

5+import qualified Control.Monad.State as State

6+import qualified Data.Traversable as Traverse

7+import qualified Data.Map as Map

8+import Data.List (isPrefixOf)

9+import qualified Data.UnionFind.IO as UF

10+

11+import qualified SourceSyntax.Type as Src

12+import SourceSyntax.Module (ADT)

13+import Type.Type

14+

15+type TypeDict = Map.Map String Type

16+type VarDict = Map.Map String Variable

17+

18+data Environment = Environment {

19+ constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),

20+ aliases :: Map.Map String ([String], Src.Type),

21+ types :: TypeDict,

22+ value :: TypeDict

23+}

24+

25+initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment

26+initialEnvironment datatypes aliases = do

27+ types <- makeTypes datatypes

28+ let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases

29+ env = Environment {

30+ constructor = Map.empty,

31+ value = Map.empty,

32+ types = types,

33+ aliases = aliases' }

34+

35+ return $ env { constructor = makeConstructors env datatypes }

36+

37+makeTypes :: [ADT] -> IO TypeDict

38+makeTypes datatypes =

39+ Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

40+ where

41+ nameAndKind (name, tvars, _) = (name, length tvars)

42+

43+ makeCtor (name, kind) = do

44+ ctor <- VarN <$> namedVar Constant name

45+ return (name, ctor)

46+

47+ tuple n = ("_Tuple" ++ show n, n)

48+

49+ kind n names = map (\name -> (name, n)) names

50+

51+ builtins :: [(String,Int)]

52+ builtins = concat [ map tuple [0..9]

53+ , kind 1 ["_List"]

54+ , kind 0 ["Int","Float","Char","Bool"]

55+ ]

56+

57+

58+makeConstructors :: Environment

59+ -> [ADT]

60+ -> Map.Map String (IO (Int, [Variable], [Type], Type))

61+makeConstructors env datatypes = Map.fromList builtins

62+ where

63+ list t = (types env Map.! "_List") <| t

64+

65+ inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

66+ inst numTVars tipe = do

67+ vars <- forM [1..numTVars] $ \_ -> var Flexible

68+ let (args, result) = tipe (map VarN vars)

69+ return (length args, vars, args, result)

70+

71+ tupleCtor n =

72+ let name = "_Tuple" ++ show n

73+ in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))

74+

75+ builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]

76+ builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))

77+ , ("::", inst 1 $ \ [t] -> ([t, list t], list t))

78+ ] ++ map tupleCtor [0..9]

79+ ++ concatMap (ctorToType env) datatypes

80+

81+

82+ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

83+ctorToType env (name, tvars, ctors) =

84+ zip (map fst ctors) (map inst ctors)

85+ where

86+ inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

87+ inst ctor = do

88+ ((args, tipe), (dict,_)) <- State.runStateT (go ctor) (Map.empty, Map.empty)

89+ return (length args, Map.elems dict, args, tipe)

90+

91+

92+ go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)

93+ go (ctor, args) = do

94+ types <- mapM (instantiator env) args

95+ returnType <- instantiator env (Src.Data name (map Src.Var tvars))

96+ return (types, returnType)

97+

98+

99+get :: Environment -> (Environment -> Map.Map String a) -> String -> a

100+get env subDict key = Map.findWithDefault err key (subDict env)

101+ where

102+ err = error $ "Could not find type constructor '" ++ key ++ "' while checking types."

103+

104+

105+freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

106+freshDataScheme env name = get env constructor name

107+

108+instantiateType ::

109+ Environment -> Src.Type -> VarDict -> IO ([Variable], Type)

110+instantiateType env sourceType dict =

111+ do (tipe, (dict',_)) <- State.runStateT (instantiator env sourceType) (dict, Map.empty)

112+ return (Map.elems dict', tipe)

113+

114+instantiator :: Environment -> Src.Type

115+ -> State.StateT (VarDict, TypeDict) IO Type

116+instantiator env sourceType = go sourceType

117+ where

118+ go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type

119+ go sourceType =

120+ case sourceType of

121+ Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2

122+

123+ Src.Var x -> do

124+ (dict, aliases) <- State.get

125+ case Map.lookup x dict of

126+ Just var -> return (VarN var)

127+ Nothing ->

128+ case Map.lookup x aliases of

129+ Just t -> return t

130+ Nothing ->

131+ do var <- State.liftIO $ namedVar flex x

132+ State.put (Map.insert x var dict, aliases)

133+ return (VarN var)

134+ where

135+ flex | "number" `isPrefixOf` x = Is Number

136+ | "comparable" `isPrefixOf` x = Is Comparable

137+ | "appendable" `isPrefixOf` x = Is Appendable

138+ | otherwise = Flexible

139+

140+ Src.Data "String" [] ->

141+ return (get env types "_List" <| get env types "Char")

142+

143+ Src.Data name ts -> do

144+ ts' <- mapM go ts

145+ case Map.lookup name (types env) of

146+ Just t -> return $ foldl (<|) t ts'

147+ Nothing ->

148+ case Map.lookup name (aliases env) of

149+ Nothing -> error $ "Could not find type constructor '" ++ name ++ "' while checking types."

150+ Just (tvars, t) ->

151+ let msg = "Type alias '" ++ name ++ "' expects " ++ show (length tvars) ++

152+ " but was given " ++ show (length ts')

153+ in if length ts' /= length tvars then error msg else

154+ do (dict, aliases) <- State.get

155+ State.put (dict, Map.union aliases . Map.fromList $ zip tvars ts')

156+ go t

157+

158+ Src.EmptyRecord -> return (TermN EmptyRecord1)

159+

160+ Src.Record fields ext ->

161+ TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)

compiler/Type/Fragment.hsnew file+28

@@ -0,0 +1,28 @@

1+module Type.Fragment where

2+

3+import qualified Data.List as List

4+import qualified Data.Map as Map

5+

6+import Type.Type

7+import SourceSyntax.Pattern

8+import SourceSyntax.Location (noneNoDocs)

9+

10+data Fragment = Fragment {

11+ typeEnv :: Map.Map String Type,

12+ vars :: [Variable],

13+ typeConstraint :: TypeConstraint

14+} deriving Show

15+

16+emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)

17+

18+joinFragment f1 f2 = Fragment {

19+ typeEnv = Map.union (typeEnv f1) (typeEnv f2),

20+ vars = vars f1 ++ vars f2,

21+ typeConstraint = typeConstraint f1 /\ typeConstraint f2

22+}

23+

24+joinFragments = List.foldl' (flip joinFragment) emptyFragment

25+

26+

27+toScheme fragment =

28+ Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)

compiler/Type/Inference.hsnew file+51

@@ -0,0 +1,51 @@

1+module Type.Inference where

2+

3+import qualified Data.Map as Map

4+

5+import qualified Type.Type as T

6+import qualified Type.Environment as Env

7+import qualified Type.Constrain.Expression as TcExpr

8+import qualified Type.Constrain.Declaration as TcDecl

9+import qualified Type.Solve as Solve

10+

11+import SourceSyntax.Module as Module

12+import qualified SourceSyntax.Expression as Expr

13+import SourceSyntax.Location (Located, noneNoDocs)

14+import SourceSyntax.PrettyPrint

15+import Text.PrettyPrint

16+import qualified Type.State as TS

17+import Control.Monad.State

18+import Control.Arrow (second)

19+import Transform.SortDefinitions as Sort

20+

21+import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

22+ -- the IO monad. I don't think that'd be worthwhile.

23+

24+

25+infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)

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

35+ forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->

36+ (,) name `fmap` Env.instantiateType env tipe Map.empty

37+

38+ let allTypes = ctors ++ importedVars

39+ vars = concatMap (fst . snd) allTypes

40+ header = Map.map snd (Map.fromList allTypes)

41+ environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]

42+

43+ fvar <- T.var T.Flexible

44+ constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)

45+

46+ state <- execStateT (Solve.solve constraint) TS.initialState

47+ let errors = TS.sErrors state

48+ if null errors

49+ then return $ Right (Map.difference (TS.sSavedEnv state) header)

50+ else Left `fmap` sequence (reverse errors)

51+

compiler/Type/PrettyPrint.hsnew file+13

@@ -0,0 +1,13 @@

1+

2+module Type.PrettyPrint where

3+

4+import Text.PrettyPrint

5+

6+data ParensWhen = Fn | App | Never

7+

8+class PrettyType a where

9+ pretty :: ParensWhen -> a -> Doc

10+

11+commaSep docs = sep (punctuate comma docs)

12+

13+parensIf bool doc = if bool then parens doc else doc

compiler/Type/Solve.hsnew file+186

@@ -0,0 +1,186 @@

1+module Type.Solve (solve) where

2+

3+import Control.Monad

4+import Control.Monad.State

5+import qualified Data.UnionFind.IO as UF

6+import qualified Data.Map as Map

7+import qualified Data.Traversable as Traversable

8+import qualified Data.Maybe as Maybe

9+import qualified Data.List as List

10+import Type.Type

11+import Type.Unify

12+import qualified Type.Environment as Env

13+import qualified Type.State as TS

14+import qualified Text.PrettyPrint as P

15+import SourceSyntax.Location (Located(L), SrcSpan)

16+

17+

18+-- | Every variable has rank less than or equal to the maxRank of the pool.

19+-- This sorts variables into the young and old pools accordingly.

20+generalize :: TS.Pool -> StateT TS.SolverState IO ()

21+generalize youngPool = do

22+ youngMark <- TS.uniqueMark

23+ let youngRank = TS.maxRank youngPool

24+ insert dict var = do

25+ desc <- liftIO $ UF.descriptor var

26+ liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })

27+ return $ Map.insertWith (++) (rank desc) [var] dict

28+

29+ -- Sort the youngPool variables by rank.

30+ rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)

31+

32+ -- get the ranks right for each entry.

33+ -- start at low ranks so that we only have to pass

34+ -- over the information once.

35+ visitedMark <- TS.uniqueMark

36+ mapM (\(poolRank, vars) -> mapM (adjustRank youngMark visitedMark poolRank) vars) (Map.toList rankDict)

37+

38+ -- For variables that have rank lowerer than youngRank, register them in

39+ -- the old pool if they are not redundant.

40+ let registerIfNotRedundant var = do

41+ isRedundant <- liftIO $ UF.redundant var

42+ if isRedundant then return var else TS.register var

43+

44+ let rankDict' = Map.delete youngRank rankDict

45+ Traversable.traverse (mapM registerIfNotRedundant) rankDict'

46+

47+ -- For variables with rank youngRank

48+ -- If rank < youngRank: register in oldPool

49+ -- otherwise generalize

50+ let registerIfLowerRank var = do

51+ isRedundant <- liftIO $ UF.redundant var

52+ if isRedundant then return () else do

53+ desc <- liftIO $ UF.descriptor var

54+ if rank desc < youngRank

55+ then TS.register var >> return ()

56+ else let flex' = if flex desc == Flexible then Rigid else flex desc

57+ in liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })

58+

59+ mapM registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)

60+

61+ return ()

62+

63+

64+-- adjust the ranks of variables such that ranks never increase as you

65+-- move deeper into a variable.

66+adjustRank :: 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

70+ case () of

71+ () | mark desc == youngMark ->

72+ do rank' <- case structure desc of

73+ Nothing -> return groupRank

74+ Just term ->

75+ case term of

76+ App1 a b -> max `liftM` adjust a `ap` adjust b

77+ Fun1 a b -> max `liftM` adjust a `ap` adjust b

78+ Var1 x -> adjust x

79+ EmptyRecord1 -> return outermostRank

80+ Record1 fields extension ->

81+ do ranks <- mapM adjust (concat (Map.elems fields))

82+ rnk <- adjust extension

83+ return . maximum $ rnk : ranks

84+ liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })

85+ return rank'

86+

87+ | mark desc /= visitedMark ->

88+ do let rank' = min groupRank (rank desc)

89+ liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })

90+ return rank'

91+

92+ | otherwise -> return (rank desc)

93+

94+

95+

96+solve :: TypeConstraint -> StateT TS.SolverState IO ()

97+solve (L span constraint) =

98+ case constraint of

99+ CTrue -> return ()

100+

101+ CSaveEnv -> TS.saveLocalEnv

102+

103+ CEqual term1 term2 -> do

104+ t1 <- TS.flatten term1

105+ t2 <- TS.flatten term2

106+ unify span t1 t2

107+

108+ CAnd cs -> mapM_ solve cs

109+

110+ CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do

111+ oldEnv <- TS.getEnv

112+ mapM TS.introduce fqs

113+ solve constraint'

114+ TS.modifyEnv (\_ -> oldEnv)

115+

116+ CLet schemes constraint' -> do

117+ oldEnv <- TS.getEnv

118+ headers <- mapM (solveScheme span) schemes

119+ TS.modifyEnv $ \env -> Map.unions (headers ++ [env])

120+ solve constraint'

121+ TS.modifyEnv (\_ -> oldEnv)

122+

123+ CInstance name term -> do

124+ env <- TS.getEnv

125+ freshCopy <-

126+ case Map.lookup name env of

127+ Just tipe -> TS.makeInstance tipe

128+ Nothing

129+ | List.isPrefixOf "Native." name -> liftIO (var Flexible)

130+ | otherwise ->

131+ error ("Could not find '" ++ name ++ "' when solving type constraints.")

132+

133+ t <- TS.flatten term

134+ unify span freshCopy t

135+

136+solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)

137+solveScheme span scheme =

138+ case scheme of

139+ Scheme [] [] constraint header -> do

140+ solve constraint

141+ Traversable.traverse TS.flatten header

142+

143+ Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do

144+ let quantifiers = rigidQuantifiers ++ flexibleQuantifiers

145+ oldPool <- TS.getPool

146+

147+ -- fill in a new pool when working on this scheme's constraints

148+ freshPool <- TS.nextRankPool

149+ TS.switchToPool freshPool

150+ mapM TS.introduce quantifiers

151+ header' <- Traversable.traverse TS.flatten header

152+ solve constraint

153+

154+ allDistinct span rigidQuantifiers

155+ youngPool <- TS.getPool

156+ TS.switchToPool oldPool

157+ generalize youngPool

158+ mapM (isGeneric span) rigidQuantifiers

159+ return header'

160+

161+

162+-- Checks that all of the given variables belong to distinct equivalence classes.

163+-- Also checks that their structure is Nothing, so they represent a variable, not

164+-- a more complex term.

165+allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()

166+allDistinct span vars = do

167+ seen <- TS.uniqueMark

168+ let check var = do

169+ desc <- liftIO $ UF.descriptor var

170+ case structure desc of

171+ Just _ ->

172+ TS.addError span "Cannot generalize something that is not a type variable" var var

173+ Nothing -> do

174+ if mark desc == seen

175+ then TS.addError span "Duplicate variable during generalization" var var

176+ else return ()

177+ liftIO $ UF.setDescriptor var (desc { mark = seen })

178+ mapM_ check vars

179+

180+-- Check that a variable has rank == noRank, meaning that it can be generalized.

181+isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()

182+isGeneric span var = do

183+ desc <- liftIO $ UF.descriptor var

184+ if rank desc == noRank

185+ then return ()

186+ else TS.addError span "Cannot generalize. Variable must have not have a rank." var var

compiler/Type/State.hsnew file+201

@@ -0,0 +1,201 @@

1+module Type.State where

2+

3+import Type.Type

4+import qualified Data.Map as Map

5+import qualified Data.List as List

6+import qualified Type.Environment as Env

7+import qualified Data.UnionFind.IO as UF

8+import Control.Monad.State

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

10+import qualified Data.Traversable as Traversable

11+import Text.PrettyPrint as P

12+import SourceSyntax.PrettyPrint

13+import SourceSyntax.Location

14+

15+-- Pool

16+-- Holds a bunch of variables

17+-- The rank of each variable is less than or equal to the pool's "maxRank"

18+-- The young pool exists to make it possible to identify these vars in constant time.

19+

20+data Pool = Pool {

21+ maxRank :: Int,

22+ inhabitants :: [Variable]

23+} deriving Show

24+

25+emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }

26+

27+-- Keeps track of the environment, type variable pool, and a list of errors

28+data SolverState = SS {

29+ sEnv :: Map.Map String Variable,

30+ sSavedEnv :: Map.Map String Variable,

31+ sPool :: Pool,

32+ sMark :: Int,

33+ sErrors :: [IO P.Doc]

34+}

35+

36+initialState = SS {

37+ sEnv = Map.empty,

38+ sSavedEnv = Map.empty,

39+ sPool = emptyPool,

40+ sMark = noMark + 1, -- The mark must never be equal to noMark!

41+ sErrors = []

42+}

43+

44+modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }

45+modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

46+

47+addError span message t1 t2 =

48+ modify $ \state -> state { sErrors = err : sErrors state }

49+ where

50+ err = makeError <$> extraPretty t1 <*> extraPretty t2

51+

52+ location = case span of

53+ NoSpan msg -> ""

54+ Span p1 p2 msg ->

55+ if line p1 == line p2 then " on line " ++ show (line p1)

56+ else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)

57+

58+ display msg = if null msg then "\n"

59+ else "\n" ++ unlines (map (" "++) $ lines msg)

60+

61+ src = case span of

62+ NoSpan msg -> display msg

63+ Span _ _ msg -> display msg

64+

65+ makeError pt1 pt2 =

66+ P.vcat [ P.text $ "Type error" ++ location ++ ":"

67+ , if null message then empty else P.vcat . map P.text $ lines message

68+ , P.text src

69+ , P.text " Expected Type:" <+> pt1

70+ , P.text " Actual Type:" <+> pt2 <> P.text "\n"

71+ ]

72+

73+switchToPool pool = modifyPool (\_ -> pool)

74+

75+getPool :: StateT SolverState IO Pool

76+getPool = sPool <$> get

77+

78+getEnv :: StateT SolverState IO (Map.Map String Variable)

79+getEnv = sEnv <$> get

80+

81+saveLocalEnv :: StateT SolverState IO ()

82+saveLocalEnv = do

83+ env <- sEnv <$> get

84+ modify $ \state -> state { sSavedEnv = env }

85+

86+uniqueMark :: StateT SolverState IO Int

87+uniqueMark = do

88+ state <- get

89+ let mark = sMark state

90+ put $ state { sMark = mark + 1 }

91+ return mark

92+

93+nextRankPool :: StateT SolverState IO Pool

94+nextRankPool = do

95+ pool <- getPool

96+ return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }

97+

98+register :: Variable -> StateT SolverState IO Variable

99+register variable = do

100+ modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }

101+ return variable

102+

103+introduce :: Variable -> StateT SolverState IO Variable

104+introduce variable = do

105+ pool <- getPool

106+ liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })

107+ register variable

108+

109+flatten :: Type -> StateT SolverState IO Variable

110+flatten term =

111+ case term of

112+ VarN v -> return v

113+ TermN t -> do

114+ flatStructure <- traverseTerm flatten t

115+ pool <- getPool

116+ var <- liftIO . UF.fresh $ Descriptor {

117+ structure = Just flatStructure,

118+ rank = maxRank pool,

119+ flex = Flexible,

120+ name = Nothing,

121+ copy = Nothing,

122+ mark = noMark

123+ }

124+ register var

125+

126+makeInstance :: Variable -> StateT SolverState IO Variable

127+makeInstance var = do

128+ alreadyCopied <- uniqueMark

129+ freshVar <- makeCopy alreadyCopied var

130+ restore alreadyCopied var

131+ return freshVar

132+

133+makeCopy :: Int -> Variable -> StateT SolverState IO Variable

134+makeCopy alreadyCopied variable = do

135+ desc <- liftIO $ UF.descriptor variable

136+ case () of

137+ () | mark desc == alreadyCopied ->

138+ case copy desc of

139+ Just v -> return v

140+ Nothing -> error "This should be impossible."

141+

142+ | rank desc /= noRank || flex desc == Constant ->

143+ return variable

144+

145+ | otherwise -> do

146+ pool <- getPool

147+ newVar <- liftIO $ UF.fresh $ Descriptor {

148+ structure = Nothing,

149+ rank = maxRank pool,

150+ mark = noMark,

151+ flex = case flex desc of

152+ Is s -> Is s

153+ _ -> Flexible,

154+ copy = Nothing,

155+ name = case flex desc of

156+ Rigid -> Nothing

157+ _ -> name desc

158+ }

159+ register newVar

160+

161+ -- Link the original variable to the new variable. This lets us

162+ -- avoid making multiple copies of the variable we are instantiating.

163+ --

164+ -- Need to do this before recursively copying the structure of

165+ -- the variable to avoid looping on cyclic terms.

166+ liftIO $ UF.modifyDescriptor variable $ \desc ->

167+ desc { mark = alreadyCopied, copy = Just newVar }

168+

169+ -- Now we recursively copy the structure of the variable.

170+ -- We have already marked the variable as copied, so we

171+ -- will not repeat this work or crawl this variable again.

172+ case structure desc of

173+ Nothing -> return newVar

174+ Just term -> do

175+ newTerm <- traverseTerm (makeCopy alreadyCopied) term

176+ liftIO $ UF.modifyDescriptor newVar $ \desc ->

177+ desc { structure = Just newTerm }

178+ return newVar

179+

180+restore :: Int -> Variable -> StateT SolverState IO Variable

181+restore alreadyCopied variable = do

182+ desc <- liftIO $ UF.descriptor variable

183+ if mark desc /= alreadyCopied

184+ then return variable

185+ else do

186+ restoredStructure <-

187+ Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)

188+ liftIO $ UF.modifyDescriptor variable $ \desc ->

189+ desc { mark = noMark, rank = noRank, structure = restoredStructure }

190+ return variable

191+

192+traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)

193+traverseTerm f term =

194+ case term of

195+ App1 a b -> App1 <$> f a <*> f b

196+ Fun1 a b -> Fun1 <$> f a <*> f b

197+ Var1 x -> Var1 <$> f x

198+ EmptyRecord1 -> return EmptyRecord1

199+ Record1 fields ext ->

200+ Record1 <$> Traversable.traverse (mapM f) fields <*> f ext

201+

compiler/Type/Type.hsnew file+391

@@ -0,0 +1,391 @@

1+module Type.Type where

2+

3+import qualified Data.Char as Char

4+import qualified Data.List as List

5+import qualified Data.Map as Map

6+import qualified Data.UnionFind.IO as UF

7+import Type.PrettyPrint

8+import Text.PrettyPrint as P

9+import System.IO.Unsafe

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

11+import Control.Monad.State

12+import Data.Traversable (traverse)

13+import SourceSyntax.Location

14+import SourceSyntax.Helpers (isTuple)

15+import qualified SourceSyntax.Type as Src

16+

17+data Term1 a

18+ = App1 a a

19+ | Fun1 a a

20+ | Var1 a

21+ | EmptyRecord1

22+ | Record1 (Map.Map String [a]) a

23+ deriving Show

24+

25+data TermN a

26+ = VarN a

27+ | TermN (Term1 (TermN a))

28+ deriving Show

29+

30+record :: Map.Map String [TermN a] -> TermN a -> TermN a

31+record fs rec = TermN (Record1 fs rec)

32+

33+type Type = TermN Variable

34+type Variable = UF.Point Descriptor

35+

36+type SchemeName = String

37+type TypeName = String

38+

39+type Constraint a b = Located (BasicConstraint a b)

40+data BasicConstraint a b

41+ = CTrue

42+ | CSaveEnv

43+ | CEqual a a

44+ | CAnd [Constraint a b]

45+ | CLet [Scheme a b] (Constraint a b)

46+ | CInstance SchemeName a

47+ deriving Show

48+

49+data Scheme a b = Scheme {

50+ rigidQuantifiers :: [b],

51+ flexibleQuantifiers :: [b],

52+ constraint :: Constraint a b,

53+ header :: Map.Map String a

54+} deriving Show

55+

56+type TypeConstraint = Constraint Type Variable

57+type TypeScheme = Scheme Type Variable

58+

59+monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

60+

61+infixl 8 /\

62+

63+(/\) :: Constraint a b -> Constraint a b -> Constraint a b

64+a@(L s1 c1) /\ b@(L s2 c2) =

65+ case (c1, c2) of

66+ (CTrue, _) -> b

67+ (_, CTrue) -> a

68+ _ -> mergeOldDocs a b (CAnd [a,b])

69+

70+infixr 9 ==>

71+(==>) :: Type -> Type -> Type

72+a ==> b = TermN (Fun1 a b)

73+

74+f <| a = TermN (App1 f a)

75+

76+data Descriptor = Descriptor {

77+ structure :: Maybe (Term1 Variable),

78+ rank :: Int,

79+ flex :: Flex,

80+ name :: Maybe TypeName,

81+ copy :: Maybe Variable,

82+ mark :: Int

83+} deriving Show

84+

85+noRank = -1

86+outermostRank = 0 :: Int

87+

88+noMark = 0

89+initialMark = 1

90+

91+data Flex = Rigid | Flexible | Constant | Is SuperType

92+ deriving (Show, Eq)

93+

94+data SuperType = Number | Comparable | Appendable

95+ deriving (Show, Eq)

96+

97+namedVar flex name = UF.fresh $ Descriptor {

98+ structure = Nothing,

99+ rank = noRank,

100+ flex = flex,

101+ name = Just name,

102+ copy = Nothing,

103+ mark = noMark

104+ }

105+

106+var flex = UF.fresh $ Descriptor {

107+ structure = Nothing,

108+ rank = noRank,

109+ flex = flex,

110+ name = Nothing,

111+ copy = Nothing,

112+ mark = noMark

113+ }

114+

115+structuredVar structure = UF.fresh $ Descriptor {

116+ structure = Just structure,

117+ rank = noRank,

118+ flex = Flexible,

119+ name = Nothing,

120+ copy = Nothing,

121+ mark = noMark

122+ }

123+

124+

125+-- ex qs constraint == exists qs. constraint

126+ex :: [Variable] -> TypeConstraint -> TypeConstraint

127+ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s CTrue)

128+

129+-- fl qs constraint == forall qs. constraint

130+fl :: [Variable] -> TypeConstraint -> TypeConstraint

131+fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)

132+

133+exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint

134+exists f = do

135+ v <- var Flexible

136+ ex [v] <$> f (VarN v)

137+

138+

139+instance Show a => Show (UF.Point a) where

140+ show point = unsafePerformIO $ fmap show (UF.descriptor point)

141+

142+

143+instance PrettyType a => PrettyType (UF.Point a) where

144+ pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)

145+

146+

147+instance PrettyType a => PrettyType (Located a) where

148+ pretty when (L _ e) = pretty when e

149+

150+

151+instance PrettyType a => PrettyType (Term1 a) where

152+ pretty when term =

153+ let prty = pretty Never in

154+ case term of

155+ App1 f x | P.render px == "_List" -> P.brackets (pretty Never x)

156+ | otherwise -> parensIf needed (px <+> pretty App x)

157+ where

158+ px = prty f

159+ needed = case when of

160+ App -> True

161+ _ -> False

162+

163+ Fun1 arg body ->

164+ parensIf needed (pretty Fn arg <+> P.text "->" <+> prty body)

165+ where

166+ needed = case when of

167+ Never -> False

168+ _ -> True

169+

170+ Var1 x -> prty x

171+

172+ EmptyRecord1 -> P.braces P.empty

173+

174+ Record1 fields ext -> P.braces (extend <+> commaSep prettyFields)

175+ where

176+ prettyExt = prty ext

177+ extend | P.render prettyExt == "{}" = P.empty

178+ | otherwise = prettyExt <+> P.text "|"

179+ mkPretty f t = P.text f <+> P.text ":" <+> prty t

180+ prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)

181+

182+

183+instance PrettyType a => PrettyType (TermN a) where

184+ pretty when term =

185+ case term of

186+ VarN x -> pretty when x

187+ TermN t1 -> pretty when t1

188+

189+

190+instance PrettyType Descriptor where

191+ pretty when desc =

192+ case (structure desc, name desc) of

193+ (Just term, _) -> pretty when term

194+ (_, Just name) -> if not (isTuple name) then P.text name else

195+ P.parens . P.text $ replicate (read (drop 6 name) - 1) ','

196+ _ -> P.text "?"

197+

198+

199+instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where

200+ pretty _ constraint =

201+ let prty = pretty Never in

202+ case constraint of

203+ CTrue -> P.text "True"

204+ CSaveEnv -> P.text "SaveTheEnvironment!!!"

205+ CEqual a b -> prty a <+> P.text "=" <+> prty b

206+ CAnd [] -> P.text "True"

207+

208+ CAnd cs ->

209+ P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)

210+

211+ CLet [Scheme [] fqs constraint header] (L _ CTrue) | Map.null header ->

212+ P.sep [ binder, pretty Never c ]

213+ where

214+ mergeExists vs (L _ c) =

215+ case c of

216+ CLet [Scheme [] fqs' c' _] (L _ CTrue) -> mergeExists (vs ++ fqs') c'

217+ _ -> (vs, c)

218+

219+ (fqs', c) = mergeExists fqs constraint

220+

221+ binder = if null fqs' then P.empty else

222+ P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."

223+

224+ CLet schemes constraint ->

225+ P.fsep [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)

226+ , P.text "in", pretty Never constraint ]

227+

228+ CInstance name tipe ->

229+ P.text name <+> P.text "<" <+> prty tipe

230+

231+instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where

232+ pretty _ (Scheme rqs fqs (L _ constraint) headers) =

233+ P.sep [ forall, cs, headers' ]

234+ where

235+ prty = pretty Never

236+

237+ forall = if null rqs && null fqs then P.empty else

238+ P.text "\x2200" <+> frees <+> rigids

239+

240+ frees = P.hsep $ map prty fqs

241+ rigids = if null rqs then P.empty else P.braces . P.hsep $ map prty rqs

242+

243+ cs = case constraint of

244+ CTrue -> P.empty

245+ CAnd [] -> P.empty

246+ _ -> P.brackets (pretty Never constraint)

247+

248+ headers' = if Map.size headers > 0 then dict else P.empty

249+ dict = P.parens . commaSep . map prettyPair $ Map.toList headers

250+ prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t

251+

252+

253+extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc

254+extraPretty t = pretty Never <$> addNames t

255+

256+addNames :: (Crawl t) => t -> IO t

257+addNames value = do

258+ (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)

259+ let vars = map head . List.group $ List.sort rawVars

260+ suffix s = map (++s) (map (:[]) ['a'..'z'])

261+ allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]

262+ okayVars = filter (`notElem` vars) allVars

263+ runStateT (crawl rename value) (okayVars, 0, 0, 0)

264+ return value

265+ where

266+ getNames desc state@(vars, a, b, c) =

267+ let name' = name desc in

268+ case name' of

269+ Just var -> (name', (var:vars, a, b, c))

270+ Nothing -> (name', state)

271+

272+ rename desc state@(vars, a, b, c) =

273+ case name desc of

274+ Just var -> (Just var, state)

275+ Nothing ->

276+ case flex desc of

277+ Is Number -> (Just $ "number" ++ replicate a '\'', (vars, a+1, b, c))

278+ Is Comparable -> (Just $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

279+ Is Appendable -> (Just $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

280+ _ -> (Just $ head vars, (tail vars, a, b, c))

281+

282+

283+type CrawlState = ([String], Int, Int, Int)

284+

285+-- Code for traversing all the type data-structures and giving

286+-- names to the variables embedded deep in there.

287+class Crawl t where

288+ crawl :: (Descriptor -> CrawlState -> (Maybe TypeName, CrawlState))

289+ -> t

290+ -> StateT CrawlState IO t

291+

292+instance Crawl a => Crawl (Located a) where

293+ crawl nextState (L s e) = L s <$> crawl nextState e

294+

295+instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where

296+ crawl nextState constraint =

297+ let rnm = crawl nextState in

298+ case constraint of

299+ CTrue -> return CTrue

300+ CSaveEnv -> return CSaveEnv

301+ CEqual a b -> CEqual <$> rnm a <*> rnm b

302+ CAnd cs -> CAnd <$> crawl nextState cs

303+ CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c

304+ CInstance name tipe -> CInstance name <$> rnm tipe

305+

306+instance Crawl a => Crawl [a] where

307+ crawl nextState list = mapM (crawl nextState) list

308+

309+instance (Crawl t, Crawl v) => Crawl (Scheme t v) where

310+ crawl nextState (Scheme rqs fqs c headers) =

311+ let rnm = crawl nextState in

312+ Scheme <$> rnm rqs <*> rnm fqs <*> crawl nextState c <*> return headers

313+

314+instance Crawl t => Crawl (TermN t) where

315+ crawl nextState tipe =

316+ case tipe of

317+ VarN x -> VarN <$> crawl nextState x

318+ TermN term -> TermN <$> crawl nextState term

319+

320+instance Crawl t => Crawl (Term1 t) where

321+ crawl nextState term =

322+ let rnm = crawl nextState in

323+ case term of

324+ App1 a b -> App1 <$> rnm a <*> rnm b

325+ Fun1 a b -> Fun1 <$> rnm a <*> rnm b

326+ Var1 a -> Var1 <$> rnm a

327+ EmptyRecord1 -> return EmptyRecord1

328+ Record1 fields ext ->

329+ Record1 <$> traverse (mapM rnm) fields <*> rnm ext

330+

331+instance Crawl a => Crawl (UF.Point a) where

332+ crawl nextState point = do

333+ desc <- liftIO $ UF.descriptor point

334+ desc' <- crawl nextState desc

335+ liftIO $ UF.setDescriptor point desc'

336+ return point

337+

338+instance Crawl Descriptor where

339+ crawl nextState desc = do

340+ state <- get

341+ let (name', state') = nextState desc state

342+ structure' <- traverse (crawl nextState) (structure desc)

343+ put state'

344+ return $ desc { name = name', structure = structure' }

345+

346+

347+toSrcType :: Variable -> IO Src.Type

348+toSrcType variable = do

349+ desc <- UF.descriptor =<< addNames variable

350+ case structure desc of

351+ Just term ->

352+ case term of

353+ App1 a b -> do

354+ Src.Data name ts <- toSrcType a

355+ b' <- toSrcType b

356+ return (Src.Data name (ts ++ [b']))

357+ Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b

358+ Var1 a -> toSrcType a

359+ EmptyRecord1 -> return Src.EmptyRecord

360+ Record1 fs ext -> do

361+ fs' <- traverse (mapM toSrcType) fs

362+ let fs'' = concat [ map ((,) name) ts | (name,ts) <- Map.toList fs' ]

363+ Src.Record fs'' <$> toSrcType ext

364+ Nothing ->

365+ case name desc of

366+ Just x@(c:cs) | Char.isLower c -> return (Src.Var x)

367+ | otherwise -> return (Src.Data x [])

368+ Nothing ->

369+ error $ concat

370+ [ "Problem converting the following type "

371+ , "from a type-checker type to a source-syntax type:"

372+ , P.render (pretty Never variable) ]

373+

374+

375+data AppStructure = List Variable | Tuple [Variable] | Other

376+

377+collectApps :: Variable -> IO AppStructure

378+collectApps variable = go [] variable

379+ where

380+ go vars variable = do

381+ desc <- UF.descriptor variable

382+ case (structure desc, vars) of

383+ (Nothing, [v] ) -> case name desc of

384+ Just "_List" -> return (List v)

385+ _ -> return Other

386+ (Nothing, vs ) -> case name desc of

387+ Just ctor | isTuple ctor -> return (Tuple vs)

388+ _ -> return Other

389+ (Just term, vs) -> case term of

390+ App1 a b -> go (vars ++ [b]) a

391+ _ -> return Other

compiler/Type/Unify.hsnew file+185

@@ -0,0 +1,185 @@

1+module Type.Unify (unify) where

2+

3+import Type.Type

4+import qualified Data.UnionFind.IO as UF

5+import qualified Data.Map as Map

6+import qualified Type.State as TS

7+import Control.Arrow (first,second)

8+import Control.Monad.State

9+import SourceSyntax.Location

10+

11+unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()

12+unify span variable1 variable2 = do

13+ equivalent <- liftIO $ UF.equivalent variable1 variable2

14+ if equivalent then return ()

15+ else actuallyUnify span variable1 variable2

16+

17+actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()

18+actuallyUnify span variable1 variable2 = do

19+ desc1 <- liftIO $ UF.descriptor variable1

20+ desc2 <- liftIO $ UF.descriptor variable2

21+ let unify' = unify span

22+

23+ name' :: Maybe String

24+ name' = case (name desc1, name desc2) of

25+ (Just name1, Just name2) ->

26+ case (flex desc1, flex desc2) of

27+ (_, Flexible) -> Just name1

28+ (Flexible, _) -> Just name2

29+ (Is Number, Is _) -> Just name1

30+ (Is _, Is Number) -> Just name2

31+ (Is _, Is _) -> Just name1

32+ (_, _) -> Nothing

33+ (Just name1, _) -> Just name1

34+ (_, Just name2) -> Just name2

35+ _ -> Nothing

36+

37+ flex' :: Flex

38+ flex' = case (flex desc1, flex desc2) of

39+ (f, Flexible) -> f

40+ (Flexible, f) -> f

41+ (Is Number, Is _) -> Is Number

42+ (Is _, Is Number) -> Is Number

43+ (Is super, Is _) -> Is super

44+ (_, _) -> Flexible

45+

46+ rank' :: Int

47+ rank' = min (rank desc1) (rank desc2)

48+

49+ merge1 :: StateT TS.SolverState IO ()

50+ merge1 = liftIO $ do

51+ if rank desc1 < rank desc2 then UF.union variable2 variable1

52+ else UF.union variable1 variable2

53+ UF.modifyDescriptor variable1 $ \desc ->

54+ desc { structure = structure desc1, flex = flex', name = name' }

55+

56+ merge2 :: StateT TS.SolverState IO ()

57+ merge2 = liftIO $ do

58+ if rank desc1 < rank desc2 then UF.union variable2 variable1

59+ else UF.union variable1 variable2

60+ UF.modifyDescriptor variable2 $ \desc ->

61+ desc { structure = structure desc2, flex = flex', name = name' }

62+

63+ merge = if rank desc1 < rank desc2 then merge1 else merge2

64+

65+ fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable

66+ fresh structure = do

67+ var <- liftIO . UF.fresh $ Descriptor {

68+ structure = structure, rank = rank', flex = flex',

69+ name = name', copy = Nothing, mark = noMark

70+ }

71+ TS.register var

72+

73+ flexAndUnify var = do

74+ liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }

75+ unify' variable1 variable2

76+

77+ unifyNumber svar name

78+ | name `elem` ["Int","Float"] = flexAndUnify svar

79+ | otherwise = TS.addError span "Expecting a number (Int or Float)" variable1 variable2

80+

81+ comparableError str = TS.addError span (str ++ msg) variable1 variable2

82+ where msg = "Expecting something comparable such as an\n" ++

83+ "Int, Float, Char, or a list or tuple of comparables."

84+

85+ unifyComparable var name

86+ | name `elem` ["Int","Float","Char"] = flexAndUnify var

87+ | otherwise = comparableError ""

88+

89+ unifyComparableStructure varSuper varFlex =

90+ do struct <- liftIO $ collectApps varFlex

91+ case struct of

92+ Other -> comparableError ""

93+ List v -> do flexAndUnify varSuper

94+ unify' v =<< liftIO (var $ Is Comparable)

95+ Tuple vs

96+ | length vs > 6 ->

97+ comparableError "Cannot compare a tuple with more than 6 elements.\n"

98+ | otherwise ->

99+ do flexAndUnify varSuper

100+ cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)

101+ zipWithM_ unify' vs cmpVars

102+

103+ unifyAppendable varSuper varFlex =

104+ do struct <- liftIO $ collectApps varFlex

105+ case struct of

106+ List _ -> flexAndUnify varSuper

107+ _ -> comparableError ""

108+

109+ superUnify =

110+ case (flex desc1, flex desc2, name desc1, name desc2) of

111+ (Is super1, Is super2, _, _)

112+ | super1 == super2 -> merge

113+ (Is Number, Is Comparable, _, _) -> merge1

114+ (Is Comparable, Is Number, _, _) -> merge2

115+

116+ (Is Number, _, _, Just name) -> unifyNumber variable1 name

117+ (_, Is Number, Just name, _) -> unifyNumber variable2 name

118+

119+ (Is Comparable, _, _, Just name) -> unifyComparable variable1 name

120+ (_, Is Comparable, Just name, _) -> unifyComparable variable2 name

121+ (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2

122+ (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1

123+

124+ (Is Appendable, _, _, Just "Text.Text") -> flexAndUnify variable1

125+ (_, Is Appendable, Just "Text.Text", _) -> flexAndUnify variable2

126+ (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2

127+ (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1

128+

129+ _ -> TS.addError span "" variable1 variable2

130+

131+ case (structure desc1, structure desc2) of

132+ (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge

133+ (Nothing, _) | flex desc1 == Flexible -> merge2

134+ (_, Nothing) | flex desc2 == Flexible -> merge1

135+

136+ (Just (Var1 v), _) -> unify' v variable2

137+ (_, Just (Var1 v)) -> unify' v variable1

138+

139+ (Nothing, _) -> superUnify

140+ (_, Nothing) -> superUnify

141+

142+ (Just type1, Just type2) ->

143+ case (type1,type2) of

144+ (App1 term1 term2, App1 term1' term2') ->

145+ do merge

146+ unify' term1 term1'

147+ unify' term2 term2'

148+ (Fun1 term1 term2, Fun1 term1' term2') ->

149+ do merge

150+ unify' term1 term1'

151+ unify' term2 term2'

152+

153+ (EmptyRecord1, EmptyRecord1) ->

154+ return ()

155+

156+ (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2

157+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1

158+

159+ (Record1 fields1 ext1, Record1 fields2 ext2) ->

160+ do sequence . concat . Map.elems $ Map.intersectionWith (zipWith unify') fields1 fields2

161+ let mkRecord fs ext = liftIO . structuredVar $ Record1 fs ext

162+ case (Map.null fields1', Map.null fields2') of

163+ (True , True ) -> unify' ext1 ext2

164+ (True , False) -> do

165+ record2' <- mkRecord fields2' ext2

166+ unify' ext1 record2'

167+ (False, True ) -> do

168+ record1' <- mkRecord fields1' ext1

169+ unify' record1' ext2

170+ (False, False) -> do

171+ record1' <- mkRecord fields1' =<< liftIO (var Flexible)

172+ record2' <- mkRecord fields2' =<< liftIO (var Flexible)

173+ unify' record1' ext2

174+ unify' ext1 record2'

175+ where

176+ fields1' = unmerged fields1 fields2

177+ fields2' = unmerged fields2 fields1

178+

179+ unmerged a b = Map.filter (not . null) $ Map.union (Map.intersectionWith eat a b) a

180+

181+ eat (x:xs) (y:ys) = eat xs ys

182+ eat xs ys = xs

183+

184+ _ -> TS.addError span "" variable1 variable2

185+

compiler/Types/Alias.hsdeleted−138

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

1−{-# LANGUAGE PatternGuards #-}

2−module Types.Alias (dealias, get, mistakes) where

3−

4−import Ast

5−import Located

6−import Control.Arrow (second)

7−import Data.List (group,sort)

8−import Data.Maybe (mapMaybe)

9−import qualified Data.Map as Map

10−import qualified Data.Set as Set

11−import Types.Substitutions (subst)

12−import Types.Types

13−import Data.Generics.Uniplate.Data

14−

15−builtins :: [(String,([X],Type))]

16−builtins =

17− let touch = ("t0", time) : map (flip (,) int) ["x","y","x0","y0","id"]

18− state = [("string", string), ("selectionStart", int), ("selectionEnd", int)]

19− line = [("color", tipe "Color"), ("width", float),

20− ("cap", tipe "LineCap"), ("join", tipe "LineJoin"),

21− ("miterLimit", float), ("dashing", listOf int),

22− ("dashOffset", int)]

23− makeRecord fields =

24− RecordT (Map.fromList $ map (second (:[])) fields) EmptyRecord

25− in [ ("String", ([], listOf char)),

26− ("Time", ([], float)),

27− ("KeyCode", ([], int)),

28− ("Touch", ([], makeRecord touch)),

29− ("FieldState", ([], makeRecord state)),

30− ("LineStyle", ([], makeRecord line))

31− ]

32−

33−get :: [Statement] -> Map.Map String ([X],Type)

34−get stmts = Map.fromList (builtins ++ concatMap getAlias stmts)

35− where getAlias stmt = case stmt of

36− TypeAlias alias xs t -> [(alias, (xs,t))]

37− _ -> []

38−

39−dealias :: Map.Map String ([X],Type) -> Type -> Type

40−dealias aliases t =

41− let f = dealias aliases in

42− case t of

43− ADT name ts -> case Map.lookup name aliases of

44− Just (xs,t) -> f (subst (zip xs ts) t)

45− Nothing -> ADT name (map f ts)

46− LambdaT t u -> LambdaT (f t) (f u)

47− RecordT r t -> RecordT (Map.map (map f) r) (f t)

48− _ -> t

49−

50−mistakes :: [Statement] -> [String]

51−mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts

52−

53−badKinds :: [Statement] -> [String]

54−badKinds stmts = [msg tname | t <- universeBi stmts, tname <- badT t]

55− where

56− msg x = "Type Error: Type alias '" ++ x ++

57− "' was given the wrong number of arguments."

58−

59− badT :: Type -> [String]

60− badT (ADT name ts)

61− | Just (xs, _) <- Map.lookup name (get stmts),

62− length xs /= length ts = [name]

63− badT _ = []

64−

65−annotation :: Def -> Maybe String

66−annotation s =

67− case s of

68− TypeAnnotation name _ -> Just name

69− _ -> Nothing

70−

71−definition :: Def -> Maybe String

72−definition s =

73− case s of

74− FnDef name _ _ -> Just name

75− OpDef name _ _ _ -> Just name

76− _ -> Nothing

77−

78−checkTopLevelAndLets :: [Statement] -> (String -> [Def] -> [a]) -> [a]

79−checkTopLevelAndLets stmts fcheck =

80− fcheck "at top-level" topLevelDefs ++

81− concatMap (fcheck "in let binding") allLetDefs

82− where

83− topLevelDefs = mapMaybe maybeDef stmts

84− maybeDef (Definition d) = Just d

85− maybeDef _ = Nothing

86− allLetDefs = [defList | Let defList _ <- universeBi stmts]

87−

88−dups :: [Statement] -> [String]

89−dups stmts = checkTopLevelAndLets stmts $ \ctxt defs ->

90− let

91− dup :: (Def -> Maybe String) -> [String]

92− dup f = map head . filter ((>1) . length) . group . sort $ mapMaybe f defs

93−

94− msg = "Syntax Error: There can only be one "

95− defMsg x = msg ++ "definition of '" ++ x ++ "' " ++ ctxt ++ "."

96− annMsg x = msg ++ "type annotation for '" ++ x ++ "'" ++ ctxt ++ "."

97− in

98− map defMsg (dup definition) ++ map annMsg (dup annotation)

99−

100−badOrder :: [Statement] -> [String]

101−badOrder stmts = checkTopLevelAndLets stmts $ \ctxt defs ->

102− let

103− msg x = "Syntax Error: The type annotation for '" ++ x ++

104− "' must be directly above its definition in " ++ ctxt ++ "."

105− as = sort $ mapMaybe annotation defs

106− ds = sort $ mapMaybe definition defs

107−

108− expectedPairs :: [String] -> [String] -> [String]

109− expectedPairs as ds =

110− case (as,ds) of

111− (x:xs, y:ys) -> case compare x y of

112− LT -> expectedPairs xs (y:ys)

113− EQ -> x : expectedPairs xs ys

114− GT -> expectedPairs (x:xs) ys

115− ( _ , _ ) -> []

116−

117− actualPairs :: [Def] -> [String]

118− actualPairs stmts =

119− case stmts of

120− TypeAnnotation n _ : rest@(d : _) ->

121− (if Just n == definition d

122− then [n]

123− else []

124− ) ++ actualPairs rest

125− t:s:rest -> actualPairs (s:rest)

126− _ -> []

127−

128− missings :: [String] -> [String] -> [String]

129− missings expected actual =

130− case (expected, actual) of

131− (e:es, a:as) -> case compare e a of

132− LT -> e : missings es (a:as)

133− EQ -> missings es as

134− GT -> a : missings (e:es) as

135− ( [] , _ ) -> actual

136− ( _ , [] ) -> expected

137− in

138− map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs defs)

compiler/Types/Constrain.hsdeleted−332

@@ -1,332 +0,0 @@

1−

2−module Types.Constrain (constrain) where

3−

4−import Control.Arrow (second)

5−import Control.Monad (liftM,mapM,zipWithM,foldM)

6−import Control.Monad.State (evalState)

7−import Data.Char (isDigit)

8−import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf)

9−import qualified Data.Map as Map

10−import qualified Data.Set as Set

11−

12−import Ast

13−import Located

14−import Guid

15−

16−import Types.Types

17−import qualified Types.Substitutions as Subs

18−

19−import System.IO.Unsafe

20−

21−beta = VarT `liftM` guid

22−unionA = Map.unionWith (++)

23−unionsA = Map.unionsWith (++)

24−

25−getAliases :: [(String,ImportMethod)] -> [(String,Scheme)] -> [(String,Scheme)]

26−getAliases imports hints = concatMap aliasesFrom imports

27− where

28− -- Get the names of values that are now in scope after a particular

29− -- import statement.

30− aliasesFrom :: (String,ImportMethod) -> [(String,Scheme)]

31− aliasesFrom (name,method) =

32− let values = concatMap (getValue name) hints

33− prefixed name = map (\(n,t) -> (name ++ "." ++ n, t)) values

34− in case method of

35− As alias -> prefixed alias

36− Hiding vs -> prefixed name ++ filter (\(n,t) -> n `notElem` vs) values

37− Importing vs -> prefixed name ++ filter (\(n,t) -> n `elem` vs) values

38−

39− -- Take a module name and a type annotation. Return the unprefxed

40− -- type annotation: getValue "List" ("List.map",t) == [("map",t)]

41− getValue :: String -> (String,Scheme) -> [(String,Scheme)]

42− getValue inModule (name,tipe) =

43− case inModule `isPrefixOf` name of

44− True -> [ (drop (length inModule + 1) name, tipe) ]

45− False -> []

46−

47−findAmbiguous hints assumptions continue =

48− let potentialDups = map head . filter (\g -> length g > 1) . group . sort $

49− filter (elem '.') hints

50− dups = filter (\k -> Map.member k assumptions) potentialDups

51− in case dups of

52− n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++

53− "' could refer to " ++

54− intercalate ", " (filter (isSuffixOf n) hints)

55− _ -> continue

56−

57−mergeSchemes :: [Map.Map String Scheme]

58− -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)

59−mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs

60− return (Map.unions ass, Set.unions css, Map.unions sss)

61− where

62− kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)

63− split (k,vs) =

64− let ps = zipWith (\s v -> (s++k,v)) (map (flip replicate '_') [0..]) vs

65− eq t u = L (Just $ msg ++ k) NoSpan (VarT t :=: VarT u)

66− msg = "the definition of "

67− in do xs <- mapM (\_ -> guid) vs

68− return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)

69− , case xs of

70− t:ts -> Set.fromList $ zipWith eq (t:ts) ts

71− [] -> Set.empty

72− , Map.fromList ps )

73−

74−constrain typeHints (Module _ _ imports stmts) = do

75− (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts

76− aliasHints <- getAliases imports `liftM` typeHints

77− (as', cs', schemes) <- mergeSchemes schemess

78− let constraints = Set.unions (cs':css)

79− as = unionsA (as':ass)

80− allHints = Map.union schemes (Map.fromList aliasHints)

81− insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as

82− assumptions <- foldM insert as (Map.keys schemes)

83− findAmbiguous (map fst aliasHints) assumptions $ do

84− let f k s vs = map (\v -> L (Just k) NoSpan $ v :<<: s) vs

85− cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions

86− escapees = Map.keys $ Map.difference assumptions allHints

87− msg = "Warning! Type-checker could not find variables:\n" ++ intercalate ", " escapees

88− return $ case escapees of

89− [] -> Right (Set.toList constraints ++ cs)

90− _ -> unsafePerformIO (putStrLn msg) `seq` Right (Set.toList constraints ++ cs)

91− --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)

92−

93−type TVarMap = Map.Map String [X]

94−type ConstraintSet = Set.Set (Located Constraint)

95−

96−loc e span = L (Just $ show e) span

97−

98−gen :: CExpr -> GuidCounter (TVarMap, ConstraintSet, Type)

99−gen (L _ span expr) =

100− let loc' = L (Just $ show expr) span in

101− case expr of

102− Var x ->

103− do b <- guid

104− return (Map.singleton x [b], Set.empty, VarT b)

105−

106− App e1 e2 ->

107− do (a1,c1,t1) <- gen e1

108− (a2,c2,t2) <- gen e2

109− b <- beta

110− return ( unionA a1 a2

111− , Set.unions [c1,c2

112− ,Set.singleton . loc' $ t1 :=: (LambdaT t2 b)]

113− , b )

114−

115− Lambda x e ->

116− do (a,c,t) <- gen e

117− b <- beta

118− v <- guid

119− return ( Map.delete x a

120− , Set.union c . Set.fromList .

121− map (\x -> loc' $ VarT x :=: b) $

122− Map.findWithDefault [v] x a

123− , LambdaT b t )

124−

125− Let defs e ->

126− do (as,cs,t) <- gen e

127− (ass, schemes) <- liftM unzip (mapM defScheme defs)

128− let assumptions = unionsA (as:ass)

129− getName d = case d of FnDef f _ _ -> f

130− OpDef op _ _ _ -> op

131− TypeAnnotation n _ -> n

132− names = map getName defs

133− genCs name s = do

134− v <- guid

135− let vs = Map.findWithDefault [v] name assumptions

136− return $ map (\x -> loc name span $ x :<<: s) vs

137− cs' <- zipWithM genCs names schemes

138− return ( foldr Map.delete assumptions names

139− , Set.union (Set.fromList . concat $ cs') cs

140− , t )

141−

142− Case e cases ->

143− do (as,cs,t) <- gen e

144− (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases

145− return ( unionsA $ as:ass

146− , let cases' = map snd cases

147− locs = zipWith epos cases' (tail cases')

148− csts = zipWith (:=:) ts (tail ts)

149− cs' = Set.fromList (zipWith ($) locs csts)

150− in Set.unions $ cs' : cs : css

151− , head ts)

152−

153− If e1 e2 e3 ->

154− do (a1,c1,t1) <- gen e1

155− (a2,c2,t2) <- gen e2

156− (a3,c3,t3) <- gen e3

157− return ( unionsA [a1,a2,a3]

158− , let c4 = Set.fromList [ loc e1 span (t1 :=: bool)

159− , loc' (t2 :=: t3) ]

160− in Set.unions [c1,c2,c3,c4]

161− , t2 )

162−

163− Data name es ->

164− gen $ foldl' (\f x -> epos f x $ App f x) (loc' $ Var name) es

165−

166− Binop op e1 e2 ->

167− gen $ loc' (App (loc' $ App (loc' $ Var op) e1) e2)

168−

169− Access e label ->

170− do (as,cs,rtype) <- gen e

171− t <- beta

172− rtype' <- beta

173− let fs = Map.singleton label [t]

174− c = (loc' (RecordT fs rtype' :=: rtype))

175− return (as, Set.insert c cs, t)

176−

177− Remove e x ->

178− do (as,cs,rtype) <- gen e

179− t <- beta

180− rtype' <- beta

181− let c = (loc' (RecordT (Map.singleton x [t]) rtype' :=: rtype))

182− return (as, Set.insert c cs, rtype')

183−

184− Insert e x v ->

185− do (eas,ecs,etype) <- gen e

186− (vas,vcs,vtype) <- gen v

187− return ( unionA eas vas

188− , Set.union ecs vcs

189− , RecordT (Map.singleton x [vtype]) etype )

190−

191− Modify record fields ->

192− do (ras,rcs,rtype) <- gen record

193− (ass,css,newTs) <- unzip3 `liftM` mapM gen (map snd fields)

194− oldTs <- mapM (\_ -> beta) fields

195− rtype' <- beta

196− let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'

197− c = Set.singleton (loc' (rtype :=: rT oldTs))

198− return ( unionsA (ras:ass), Set.unions (c : rcs : css), rT newTs )

199−

200− Record fields ->

201− let insert label tipe = Map.insertWith (++) label [tipe]

202− getScheme (f,args,e) = do

203− (as, _, (label, Forall _ cs tipe)) <- defGenHelp f args e

204− return (as, cs, insert label tipe)

205− in do (ass, css, fs) <- unzip3 `liftM` mapM getScheme fields

206− return ( unionsA ass

207− , Set.fromList (concat css)

208− , RecordT (foldr ($) Map.empty fs) EmptyRecord )

209−

210− Range e1@(L w1 s1 _) e2@(L w2 s2 _) ->

211− do (a1,c1,t1) <- gen e1

212− (a2,c2,t2) <- gen e2

213− return ( unionsA [a1,a2]

214− , Set.unions [ c1, c2, Set.fromList [ L w1 s1 (t1 :=: int)

215− , L w1 s2 (t2 :=: int) ] ]

216− , listOf int )

217−

218− MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps

219− let cs = Set.fromList (map (loc' . (t :=:)) ts)

220− return (unionsA ass, Set.unions (cs:css), t)

221− where genPair (b@(L t s _),e) = do

222− (a1,c1,t1) <- gen b

223− (a2,c2,t2) <- gen e

224− return ( unionsA [a1,a2]

225− , Set.unions [ c1, c2

226− , Set.singleton (L t s (t1 :=: bool)) ]

227− , t2 )

228−

229− IntNum _ -> do t <- beta

230− return (Map.empty, Set.singleton (loc' $ t :<: number), t)

231−

232− FloatNum _ -> primitive float

233− Chr _ -> primitive char

234− Str _ -> primitive string

235− Boolean _ -> primitive bool

236− Markdown _ -> primitive element

237−

238−

239−primitive :: Type -> GuidCounter (TVarMap, ConstraintSet, Type)

240−primitive t = return (Map.empty, Set.empty, t)

241−

242−caseGen :: Type

243− -> (Pattern, CExpr)

244− -> GuidCounter (TVarMap, ConstraintSet, Type)

245−caseGen tipe (p, ce@(L _ span e)) = do

246− (as ,cs ,t) <- gen ce

247− (as',cs',_) <- patternGen (loc p span) tipe as p

248− return ( as', Set.union cs cs', t )

249−

250−patternGen :: (Constraint -> Located Constraint)

251− -> Type -- Type of e in `case e of ...`

252− -> TVarMap

253− -> Pattern

254− -> GuidCounter (TVarMap, ConstraintSet, Type)

255−patternGen loc tipe as pattern =

256− case pattern of

257− PAnything -> do b <- beta ; return ( as, Set.empty, b )

258− PVar v -> do

259− b <- beta

260− let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)

261− return ( Map.delete v as, Set.fromList (loc (b :=: tipe) : cs), b )

262− PData name ps -> do

263− constr <- guid

264− output <- beta

265− let step (as,cs,tipe) p = do b <- beta

266− (as',cs',t) <- patternGen loc b as p

267− return (as', Set.union cs cs', t ==> tipe)

268− (as',cs, t) <- foldM step (as,Set.empty,tipe) (reverse ps)

269− return ( Map.insert name [constr] as'

270− , Set.insert (loc (VarT constr :=: t)) cs

271− , output )

272− PRecord fs ->

273− do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs

274− b <- beta

275− let t = RecordT (Map.fromList $ map (second (:[])) pairs) b

276− mkCs (name,tipe) = map (loc . (tipe :=:) . VarT)

277− (Map.findWithDefault [] name as)

278− return ( foldr Map.delete as fs

279− , Set.fromList (loc (t :=: tipe) : concatMap mkCs pairs)

280− , t )

281−

282−

283−defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme)

284−defScheme def = do (as,cs,hint) <- defGen def

285− return ( as, snd hint )

286−

287−defGen def = case def of

288− FnDef f args e -> defGenHelp f args e

289− OpDef op a1 a2 e -> defGenHelp op [a1,a2] e

290− TypeAnnotation name tipe -> do

291− schm <- Subs.generalize [] =<< Subs.superize name tipe

292− return (Map.empty, Set.empty, (name, schm))

293−

294−defGenHelp name args e = do

295− argDict <- mapM (\a -> liftM ((,) a) guid) args

296− (as,cs,t) <- gen e

297− let as' = foldr Map.delete as args

298− tipe = foldr (==>) t $ map (VarT . snd) argDict

299− genCs (arg,x) = do

300− v <- guid

301− let as' = Map.findWithDefault [v] arg as

302− return $ map (\y -> loc arg NoSpan $ VarT x :=: VarT y) as'

303− cs' <- concat `liftM` mapM genCs argDict

304− scheme <- Subs.generalize (concat $ Map.elems as') $

305− Forall (map snd argDict) (cs' ++ Set.toList cs) tipe

306− return ( as', Set.empty, (name, scheme) )

307−

308−

309−stmtGen :: Statement

310− -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)

311−stmtGen stmt =

312− case stmt of

313− Definition def -> do (as,cs,hint) <- defGen def

314− return ( as, cs, uncurry Map.singleton hint )

315−

316− Datatype name xs tcs ->

317− let toScheme ts = Forall xs [] (foldr (==>) (ADT name $ map VarT xs) ts)

318− in return (Map.empty, Set.empty, Map.fromList (map (second toScheme) tcs))

319−

320− ExportEvent js elm tipe ->

321− do x <- guid

322− return ( Map.singleton elm [x]

323− , Set.singleton . loc elm NoSpan $ VarT x :=: tipe

324− , Map.empty )

325−

326− ImportEvent js e@(L txt span base) elm tipe ->

327− do (as,cs,t) <- gen e

328− return ( as

329− , Set.insert (L txt span (signalOf t :=: tipe)) cs

330− , Map.singleton elm (Forall [] [] tipe) )

331−

332− TypeAlias _ _ _ -> return (Map.empty, Set.empty, Map.empty)

compiler/Types/Hints.hsdeleted−32

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

1−module Types.Hints (hints) where

2−

3−import Control.Arrow (first)

4−import Control.Monad (liftM)

5−import Data.Maybe (catMaybes)

6−import qualified Data.Map as Map

7−import Guid

8−import qualified Libraries as Libs

9−import Parse.Library (iParse)

10−import Parse.Types

11−import qualified Types.Substitutions as Subs

12−import Types.Types

13−

14−hints :: GuidCounter [(String, Scheme)]

15−hints = liftM catMaybes (mapM toScheme values)

16− where

17− values :: [(String, String)]

18− values = addPrefixes (Map.toList (Map.map Map.toList Libs.libraries))

19−

20− addPrefixes :: [(String,[(String, String)])] -> [(String, String)]

21− addPrefixes = concatMap (\(m,vs) -> map (first (\n -> m ++ "." ++ n)) vs)

22−

23− toScheme :: (String, String) -> GuidCounter (Maybe (String, Scheme))

24− toScheme (name, 't':'y':'p':'e':' ':_) = return Nothing

25− toScheme (name, 'd':'a':'t':'a':' ':_) = return Nothing

26− toScheme (name, tipeString) =

27− let err = "compiler error parsing type of " ++ name ++ ":\n" ++ tipeString

28− in case iParse (fmap toType typeExpr) err tipeString of

29− Left err -> error (show err)

30− Right tipe -> do

31− scheme <- Subs.generalize [] =<< Subs.superize name tipe

32− return (Just (name, scheme))

compiler/Types/Solver.hsdeleted−210

@@ -1,210 +0,0 @@

1−

2−module Types.Solver (solver) where

3−

4−import Located

5−import Control.Arrow (second)

6−import Control.Monad (liftM)

7−import Data.Either (lefts,rights)

8−import Data.List (foldl')

9−import Data.Maybe (isJust)

10−import qualified Data.Set as Set

11−import qualified Data.Map as Map

12−import Guid

13−import Types.Types

14−import Types.Substitutions

15−import Types.Alias (dealias)

16−

17−isSolved ss (L _ _ (t1 :=: t2)) = t1 == t2

18−isSolved ss (L _ _ (x :<<: _)) = isJust (lookup x ss)

19−isSolved ss c = False

20−

21−type Aliases = Map.Map String ([X],Type)

22−

23−crush :: Aliases -> Scheme -> GuidCounter (Either String Scheme)

24−crush aliases (Forall xs cs t) =

25− do subs <- solver aliases Map.empty cs

26− return $ do ss' <- subs

27− let ss = Map.toList ss'

28− cs' = filter (not . isSolved ss) (subst ss cs)

29− return $ Forall xs cs' (subst ss t)

30−

31−schemeSubHelp txt span x s t1 rltn t2 = do

32− (t1',cs1) <- sub t1

33− (t2',cs2) <- sub t2

34− return (L txt span (rltn t1' t2') : cs1 ++ cs2)

35− where sub t | not (occurs x t) = return (t, [])

36− | otherwise = do (st, cs) <- concretize s

37− return (subst [(x,st)] t, cs)

38−

39−schemeSub aliases x s c =

40− do s' <- crush aliases s

41− case s' of

42− Right s'' -> Right `liftM` schemeSub' x s'' c

43− Left err -> return $ Left err

44−

45−schemeSub' x s c@(L txt span constraint) =

46− case constraint of

47− (t1 :=: t2) -> schemeSubHelp txt span x s t1 (:=:) t2

48− (t1 :<: t2) -> schemeSubHelp txt span x s t1 (:<:) t2

49− (y :<<: Forall cxs ccs ctipe)

50− | not (occurs x c) -> return [c]

51− | otherwise ->

52− do Forall xs cs tipe <- rescheme s

53− let ss = [(x,tipe)]

54− constraints = subst ss (cs ++ ccs)

55− c' = y :<<: Forall (cxs ++ xs) constraints (subst ss ctipe)

56− return [ L txt span c' ]

57−

58−recordConstraints eq fs t fs' t' =

59− liftM concat . sequence $

60− [ constrain fs fs'

61− , liftM concat . mapM (\(k,ts) -> zipper [] k ts []) . Map.toList $

62− Map.difference fs fs'

63− , liftM concat . mapM (\(k,ts) -> zipper [] k [] ts) . Map.toList $

64− Map.difference fs' fs

65− ]

66− where constrain :: Map.Map String [Type] -> Map.Map String [Type]

67− -> GuidCounter [Located Constraint]

68− constrain as bs = liftM concat . sequence . Map.elems $

69− Map.intersectionWithKey (zipper []) as bs

70− zipper :: [Located Constraint] -> String -> [Type] -> [Type]

71− -> GuidCounter [Located Constraint]

72− zipper cs k xs ys =

73− case (xs,ys) of

74− (a:as, b:bs) -> zipper (eq a b : cs) k as bs

75− ([],[]) -> return cs

76− (as,[]) -> do x <- guid

77− let tipe = RecordT (Map.singleton k as) (VarT x)

78− return (cs ++ [eq t' tipe])

79− ([],bs) -> do x <- guid

80− let tipe = RecordT (Map.singleton k bs) (VarT x)

81− return (cs ++ [eq t tipe])

82−

83−solver :: Aliases

84− -> Map.Map X Type

85− -> [Located Constraint]

86− -> GuidCounter (Either String (Map.Map X Type))

87−solver _ subs [] = return $ Right subs

88−solver aliases subs (L txt span c : cs) =

89− let loc = L txt span

90− eq t1 t2 = loc (t1 :=: t2)

91− solv = solver aliases subs

92− uniError' = uniError (\t1 t2 -> solv (eq t1 t2 : cs)) aliases txt span

93− in case c of

94− -- Destruct Type-constructors

95− t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2) ->

96− if n1 == n2 then solv (zipWith eq ts1 ts2 ++ cs)

97− else uniError' t1 t2

98−

99− LambdaT t1 t2 :=: LambdaT t1' t2' ->

100− solv ([ eq t1 t1', eq t2 t2' ] ++ cs)

101−

102− RecordT fs t :=: RecordT fs' t' ->

103− do cs' <- recordConstraints eq fs t fs' t'

104− solv (cs' ++ cs)

105−

106− -- Type-equality

107− VarT x :=: VarT y

108− | x == y -> solv cs

109− | otherwise ->

110− case (Map.lookup x subs, Map.lookup y subs) of

111− (Just (Super xts), Just (Super yts)) ->

112− let ts = Set.intersection xts yts

113− setXY t = Map.insert x t . Map.insert y t

114− in case Set.toList ts of

115− [] -> unionError txt span xts yts

116− [t] -> let cs1 = subst [(x,t),(y,t)] cs in

117− cs1 `seq` solver aliases (setXY t subs) cs1

118− _ -> solver aliases (setXY (Super ts) subs) cs

119− (Just (Super xts), _) ->

120− let cs2 = subst [(y,VarT x)] cs in

121− solver aliases (Map.insert y (VarT x) subs) cs2

122− (_, _) ->

123− let cs3 = subst [(x,VarT y)] cs in

124− solver aliases (Map.insert x (VarT y) subs) cs3

125−

126− VarT x :=: t -> do

127− if x `occurs` t then occursError txt span (VarT x) t else

128− (case Map.lookup x subs of

129− Nothing ->

130− let cs4 = subst [(x,t)] cs

131− subs' = Map.map (subst [(x,t)]) $ Map.insert x t subs

132− in solver aliases subs' cs4

133− Just (Super ts) ->

134− let ts' = Set.intersection ts (Set.singleton t) in

135− case Set.toList ts' of

136− [] -> solv (loc (t :<: Super ts) : cs)

137− [t'] -> let cs5 = subst [(x,t)] cs in

138− solver aliases (Map.insert x t' subs) cs5

139− _ -> solver aliases (Map.insert x (Super ts') subs) cs

140− Just t' -> solv (loc (t' :=: t) : cs)

141− )

142−

143− t :=: VarT x -> solv ((loc (VarT x :=: t)) : cs)

144−

145− t1 :=: t2 | t1 == t2 -> solv cs

146− | otherwise -> uniError' t1 t2

147−

148− -- subtypes

149− VarT x :<: Super ts ->

150− case Map.lookup x subs of

151− Nothing -> solver aliases (Map.insert x (Super ts) subs) cs

152− Just (Super ts') ->

153− case Set.toList $ Set.intersection ts ts' of

154− [] -> unionError txt span ts ts'

155− [t] -> solver aliases (Map.insert x t subs) (subst [(x,t)] cs)

156− ts'' -> solver aliases subs' cs

157− where subs' = Map.insert x (Super $ Set.fromList ts'') subs

158−

159− ADT "List" [t] :<: Super ts

160− | any f (Set.toList ts) -> solv cs

161− | otherwise -> subtypeError txt span (ADT "List" [t]) (Super ts)

162− where f (ADT "List" [VarT _]) = True

163− f (ADT "List" [t']) = dealias aliases t == t'

164− f _ = False

165−

166− t :<: Super ts

167− | Set.member t ts -> solv cs

168− | Set.member (dealias aliases t) ts -> solv cs

169− | otherwise -> subtypeError txt span t (Super ts)

170−

171− x :<<: s

172− | any (occurs x) cs ->

173− do css <- mapM (schemeSub aliases x s) cs

174− case lefts css of

175− err : _ -> return $ Left err

176− [] -> solv (concat (rights css))

177− | otherwise ->

178− do (t,cs7) <- concretize s

179− solv (cs ++ loc (VarT x :=: t) : cs7)

180−

181−showMsg msg = case msg of

182− Just str -> "\nIn context: " ++ str

183− Nothing -> ""

184−

185−occursError msg span t1 t2 =

186− return . Left $ concat

187− [ "Type error (" ++ show span ++ "):\n"

188− , "Occurs check: cannot construct the infinite type:\n"

189− , show t1, " = ", show t2, showMsg msg ]

190−

191−uniError solveWith aliases msg span t1 t2 =

192− let t1' = dealias aliases t1

193− t2' = dealias aliases t2

194− in if t1 /= t1' || t2 /= t2'

195− then solveWith t1' t2'

196− else return . Left $ concat

197− [ "Type error (" ++ show span ++ "):\n"

198− , show t1, " is not equal to ", show t2, showMsg msg ]

199−

200−unionError msg span ts ts' =

201− return . Left $ concat

202− [ "Type error (" ++ show span ++ "):\n"

203− , "There are no types in both "

204− , show (Super ts), " and ", show (Super ts'), showMsg msg ]

205−

206−subtypeError msg span t s =

207− return . Left $ concat

208− [ "Type error (" ++ show span ++ "):\n"

209− , show t, " is not a ", show s, showMsg msg ]

210−

compiler/Types/Substitutions.hsdeleted−136

@@ -1,136 +0,0 @@

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−module Types.Substitutions (subst,

3− occurs,

4− freeVars,

5− concretize,

6− rescheme,

7− generalize,

8− superize) where

9−

10−import Ast

11−import Located

12−import Control.Monad (liftM, liftM2)

13−import Control.Monad.State (runState, State, get, put)

14−import Data.List (nub)

15−import qualified Data.Set as Set

16−import qualified Data.Map as Map

17−import Guid

18−import Types.Types

19−

20−class Subst a where

21− subst :: [(X,Type)] -> a -> a

22−

23−instance Subst Type where

24− subst ss t =

25− case t of

26− VarT x -> case lookup x ss of

27− Nothing -> VarT x

28− Just (Super _) -> VarT x

29− Just t -> t

30− LambdaT t1 t2 -> LambdaT (subst ss t1) (subst ss t2)

31− ADT name ts -> ADT name (subst ss ts)

32− RecordT fs t -> RecordT (Map.map (subst ss) fs) (subst ss t)

33− EmptyRecord -> EmptyRecord

34− Super ts -> Super ts

35−

36−instance Subst Scheme where

37− subst ss (Forall vs cs t) = Forall vs (subst ss cs) (subst ss t)

38−

39−instance Subst Constraint where

40− subst ss (t1 :=: t2) = subst ss t1 :=: subst ss t2

41− subst ss (t :<: super) = subst ss t :<: super

42− subst ss (x :<<: poly) = x :<<: subst ss poly

43−

44−instance Subst a => Subst (Located a) where

45− subst ss (L str span c) = L str span (subst ss c)

46−

47−instance Subst a => Subst [a] where

48− subst ss as = map (subst ss) as

49−

50−

51−class FreeVars a where

52− freeVars :: a -> [X]

53−

54−instance FreeVars Type where

55− freeVars t =

56− case t of

57− VarT v -> [v]

58− LambdaT t1 t2 -> freeVars t1 ++ freeVars t2

59− ADT _ ts -> concatMap freeVars ts

60− RecordT fs t -> freeVars (concat $ Map.elems fs) ++ freeVars t

61− EmptyRecord -> []

62− Super _ -> []

63−

64−instance FreeVars Constraint where

65− freeVars (t1 :=: t2) = freeVars t1 ++ freeVars t2

66− freeVars (t1 :<: t2) = freeVars t1 ++ freeVars t2

67− freeVars (x :<<: Forall xs cs t) = filter (`notElem` xs) frees

68− where frees = concatMap freeVars cs ++ freeVars t

69−

70−instance FreeVars a => FreeVars (Located a) where

71− freeVars (L _ _ c) = freeVars c

72−

73−instance FreeVars a => FreeVars [a] where

74− freeVars = concatMap freeVars

75−

76−occurs x t = x `elem` freeVars t

77−

78−concretize :: Scheme -> GuidCounter (Type, [Located Constraint])

79−concretize (Forall xs cs t) = do

80− ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs

81− return (subst ss t, subst ss cs)

82−

83−rescheme :: Scheme -> GuidCounter Scheme

84−rescheme (Forall xs cs t) = do

85− xs' <- mapM (const guid) xs

86− let ss = zip xs (map VarT xs')

87− return $ Forall xs' (subst ss cs) (subst ss t)

88−

89−generalize :: [X] -> Scheme -> GuidCounter Scheme

90−generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)

91− where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs

92− frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)

93−

94−newtype Superize a = S { runSuper :: State ([X], [X], [X]) a }

95− deriving (Monad)

96−

97−superize :: String -> Type -> GuidCounter Scheme

98−superize name tipe =

99− do constraints <- liftM concat $

100− sequence [ mapM (<: nmbr) (nub ns)

101− , mapM (<: apnd) (nub as)

102− , mapM (<: comp) (nub cs) ]

103− return (Forall (concat [ns,as,cs]) constraints tipe')

104− where

105− (tipe', (ns,as,cs)) = runState (runSuper (go tipe)) ([],[],[])

106− t <: super = do x <- guid

107− return $ L (Just name) NoSpan (VarT t :<: super x)

108−

109− nmbr t = number

110− apnd t = appendable t

111− comp t = comparable t

112−

113− go :: Type -> Superize Type

114− go t =

115− case t of

116− EmptyRecord -> return t

117− Super _ -> return t

118− VarT _ -> return t

119− LambdaT t1 t2 -> liftM2 LambdaT (go t1) (go t2)

120− ADT "Number" [VarT t] -> addNumber t

121− ADT "Appendable" [VarT t] -> addAppendable t

122− ADT "Comparable" [VarT t] -> addComparable t

123− ADT name ts -> liftM (ADT name) (mapM go ts)

124− RecordT fs t -> liftM2 RecordT fs' (go t)

125− where pairs = Map.toList fs

126− fs' = do ps <- mapM (\(f,t) -> liftM ((,) f) (mapM go t)) pairs

127− return (Map.fromList ps)

128−

129− add :: (X -> ([X],[X],[X]) -> ([X],[X],[X])) -> X -> Superize Type

130− add f v = S $ do (ns, as, cs) <- get

131− put $ f v (ns, as, cs)

132− return (VarT v)

133−

134− addNumber = add (\n (ns,as,cs) -> (n:ns,as,cs))

135− addAppendable = add (\a (ns,as,cs) -> (ns,a:as,cs))

136− addComparable = add (\c (ns,as,cs) -> (ns,as,c:cs))

compiler/Types/Types.hsdeleted−95

@@ -1,95 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−module Types.Types where

3−

4−import Located

5−import Data.Char (isDigit)

6−import Data.List (intercalate,isPrefixOf)

7−import qualified Data.Set as Set

8−import qualified Data.Map as Map

9−import Data.Data

10−

11−type X = Int

12−

13−data Type = LambdaT Type Type

14− | VarT X

15− | ADT String [Type]

16− | EmptyRecord

17− | RecordT (Map.Map String [Type]) Type

18− | Super (Set.Set Type)

19− deriving (Eq, Ord, Data, Typeable)

20−

21−data Scheme = Forall [X] [Located Constraint] Type deriving (Eq, Ord, Show, Data, Typeable)

22−

23−data Constraint = Type :=: Type

24− | Type :<: Type

25− | X :<<: Scheme

26− deriving (Eq, Ord, Show, Data, Typeable)

27−

28−recordT :: [(String,Type)] -> Map.Map String [Type]

29−recordT fields =

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

31−

32−recordOf :: [(String,Type)] -> Type

33−recordOf fields = RecordT (recordT fields) EmptyRecord

34−

35−tipe t = ADT t []

36−

37−int = tipe "Int"

38−float = tipe "Float"

39−time = tipe "Time"

40−date = tipe "Date"

41−

42−char = tipe "Char"

43−bool = tipe "Bool"

44−text = tipe "Text"

45−order = tipe "Order"

46−string = tipe "String"

47−

48−number = Super $ Set.fromList [ int, float, time ]

49−appendable t = Super $ Set.fromList [ string, text, listOf (VarT t) ]

50−comparable t = Super $ Set.fromList [ int, float, char, string, time, date ]

51−

52−element = tipe "Element"

53−

54−listOf t = ADT "List" [t]

55−signalOf t = ADT "Signal" [t]

56−tupleOf ts = ADT ("Tuple" ++ show (length ts)) ts

57−maybeOf t = ADT "Maybe" [t]

58−eitherOf a b = ADT "Either" [a,b]

59−pairOf t = tupleOf [t,t]

60−point = pairOf int

61−

62−infixr ==>

63−t1 ==> t2 = LambdaT t1 t2

64−

65−infix 8 -:

66−name -: tipe = (,) name $ Forall [] [] tipe

67−

68−parens = ("("++) . (++")")

69−

70−instance Show Type where

71− show t =

72− let addParens (c:cs) =

73− if notElem ' ' cs || c == '(' then c:cs else parens (c:cs)

74− in case t of

75− LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2

76− LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2

77− VarT x -> 't' : show x

78− ADT "List" [ADT "Char" []] -> "String"

79− ADT "List" [tipe] -> "[" ++ show tipe ++ "]"

80− ADT name cs ->

81− if isTupleString name

82− then parens . intercalate "," $ map show cs

83− else name ++ concatMap ((' ':) . addParens . show) cs

84− Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"

85− EmptyRecord -> "{}"

86− RecordT fs t ->

87− start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"

88− where field n s = n ++ " : " ++ show s

89− fields (n,ss) = map (field n) ss

90− start = case t of

91− EmptyRecord -> "{ "

92− _ -> "{ " ++ show t ++ " | "

93−

94−

95−isTupleString str = "Tuple" `isPrefixOf` str && all isDigit (drop 5 str)

compiler/Types/Unify.hsdeleted−16

@@ -1,16 +0,0 @@

1−

2−module Types.Unify (unify) where

3−

4−import Control.Monad (liftM)

5−import qualified Data.Map as Map

6−

7−import Ast

8−import Guid

9−import qualified Types.Constrain as Constrain

10−import qualified Types.Solver as Solver

11−import qualified Types.Alias as Alias

12−

13−unify hints modul@(Module _ _ _ stmts) = run $ do

14− constraints <- Constrain.constrain hints modul

15− either (return . Left) (Solver.solver (Alias.get stmts) Map.empty) constraints

16−

compiler/Unique.hsnew file+19

@@ -0,0 +1,19 @@

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+module Unique (guid, set, run, runAt, Unique) where

3+

4+import Control.Monad.State (evalState, State, get, put)

5+

6+-- Wrapper around State monad.

7+newtype Unique a = U { runU :: State Int a }

8+ deriving (Monad)

9+

10+-- Get the next GUID, incrementing the counter.

11+guid :: Unique Int

12+guid = U $ do n <- get

13+ put (n + 1)

14+ return n

15+

16+set n = U (put n)

17+

18+run = runAt 0

19+runAt n x = evalState (runU x) n

libraries/Automaton.elm+7−4

@@ -4,7 +4,10 @@

44-- it can be used.

55module Automaton where

66

7−import Signal (lift,foldp)

7+import open Basics

8+import Signal (lift,foldp,Signal)

9+import open List

10+import Maybe (Just, Nothing)

811

912data Automaton a b = Step (a -> (Automaton a b, b))

1013

@@ -13,7 +16,7 @@ data Automaton a b = Step (a -> (Automaton a b, b))

1316run : Automaton a b -> b -> Signal a -> Signal b

1417run auto base inputs =

1518 let step a (Step f, _) = f a

16− in lift (\(x,y) -> y) <| foldp step (auto,base) inputs

19+ in lift (\(x,y) -> y) (foldp step (auto,base) inputs)

1720

1821-- Step an automaton forward once with a given input.

1922step : a -> Automaton a b -> (Automaton a b, b)

@@ -33,7 +36,7 @@ g <<< f = f >>> g

3336-- Combine a list of automatons into a single automaton that produces a list.

3437combine : [Automaton a b] -> Automaton a [b]

3538combine autos =

36− Step (\a -> let (autos', bs) = unzip <| map (step a) autos

39+ Step (\a -> let (autos', bs) = unzip (map (step a) autos)

3740 in (combine autos', bs))

3841

3942-- Create an automaton with no memory. It just applies the given function to

@@ -69,7 +72,7 @@ empty = ([],[])

6972enqueue x (en,de) = (x::en, de)

7073dequeue q = case q of

7174 ([],[]) -> Nothing

72− (en,[]) -> enqueue ([], reverse en)

75+ (en,[]) -> dequeue ([], reverse en)

7376 (en,hd::tl) -> Just (hd, (en,tl))

7477

7578-- Computes the running average of the last `n` inputs.

libraries/Basics.elmnew file+254

@@ -0,0 +1,254 @@

1+

2+module Basics where

3+

4+import Native.Basics

5+

6+type String = [Char]

7+

8+-- Convert radians to standard Elm angles (radians).

9+radians : Float -> Float

10+radians t = t

11+

12+-- Convert degrees to standard Elm angles (radians).

13+degrees : Float -> Float

14+degrees d = d * Native.Basics.pi / 180

15+

16+-- Convert turns to standard Elm angles (radians).

17+-- One turn is equal to 360°.

18+turns : Float -> Float

19+turns r = 2 * Native.Basics.pi * r

20+

21+-- Start with polar coordinates (r,θ)

22+-- and get out cartesian coordinates (x,y).

23+fromPolar : (Float,Float) -> (Float,Float)

24+fromPolar (r,t) = (r * Native.Basics.cos t, r * Native.Basics.sin t)

25+

26+-- Start with cartesian coordinates (x,y)

27+-- and get out polar coordinates (r,θ).

28+toPolar : (Float,Float) -> (Float,Float)

29+toPolar (x,y) = (Native.Basics.sqrt (x^2 + y^2), Native.Basics.atan2 y x)

30+

31+(+) : number -> number -> number

32+(+) = Native.Basics.add

33+

34+(-) : number -> number -> number

35+(-) = Native.Basics.sub

36+

37+(*) : number -> number -> number

38+(*) = Native.Basics.mul

39+

40+-- Floating point division.

41+(/) : Float -> Float -> Float

42+(/) = Native.Basics.floatDiv

43+

44+-- Integer division, remainder is discarded.

45+div : Int -> Int -> Int

46+div = Native.Basics.div

47+

48+-- Finds the remainder after dividing one number by another: ``4 `rem` 3 == 1``

49+rem : Int -> Int -> Int

50+rem = Native.Basics.rem

51+

52+-- Perform modular arithmetic: ``7 `mod` 2 == 1``

53+mod : Int -> Int -> Int

54+mod = Native.Basics.mod

55+

56+-- Exponentiation: `3^2 == 9`

57+(^) : number -> number -> number

58+(^) = Native.Basics.exp

59+

60+cos : Float -> Float

61+cos = Native.Basics.cos

62+

63+sin : Float -> Float

64+sin = Native.Basics.sin

65+

66+tan : Float -> Float

67+tan = Native.Basics.tan

68+

69+acos : Float -> Float

70+acos = Native.Basics.acos

71+

72+asin : Float -> Float

73+asin = Native.Basics.asin

74+

75+-- You probably do not want to use this. Because it takes `(y/x)` as the argument

76+-- there is no way to know where the negative signs come from so the resulting

77+-- angle is always between π/2 and -π/2 (in quadrants I and IV).

78+atan : Float -> Float

79+atan = Native.Basics.atan

80+

81+-- This helps you find the angle of a cartesian coordinate.

82+-- You will almost certainly want to use this instead of `atan`.

83+-- So `atan2 y x` computes *atan(y/x)* but also keeps track of which

84+-- quadrant the angle should really be in. The result will be between

85+-- π and -π, giving you the full range of angles.

86+atan2 : Float -> Float -> Float

87+atan2 = Native.Basics.atan2

88+

89+-- Take the square root of a number.

90+sqrt : number -> number

91+sqrt = Native.Basics.sqrt

92+

93+-- Take the absolute value of a number.

94+abs : number -> number

95+abs = Native.Basics.abs

96+

97+-- Calculate the logarithm of a number with a given base: `logBase 10 100 == 2`

98+logBase : number -> number -> number

99+logBase = Native.Basics.logBase

100+

101+-- Given two comparables, returns the smaller one.

102+min : comparable -> comparable -> comparable

103+min = Native.Basics.min

104+

105+-- Given two comparables, returns the larger one.

106+max : comparable -> comparable -> comparable

107+max = Native.Basics.max

108+

109+-- Clamps a number within a given range. With the expression `clamp 100 200 x`

110+-- the results are as follows:

111+--

112+-- * `100 if x < 100`

113+-- * ` x if 100 <= x < 200`

114+-- * `200 if 200 <= x`

115+clamp : number -> number -> number -> number

116+clamp = Native.Basics.clamp

117+

118+-- An approximation of pi.

119+pi : Float

120+pi = Native.Basics.pi

121+

122+-- An approximation of e.

123+e : Float

124+e = Native.Basics.e

125+

126+-- Compare any two values for structural equality. Functions cannot be compared.

127+(==) : a -> a -> Bool

128+(==) = Native.Basics.eq

129+

130+(/=) : a -> a -> Bool

131+(/=) = Native.Basics.neq

132+

133+(<) : comparable -> comparable -> Bool

134+(<) = Native.Basics.lt

135+

136+(>) : comparable -> comparable -> Bool

137+(>) = Native.Basics.gt

138+

139+(<=) : comparable -> comparable -> Bool

140+(<=) = Native.Basics.le

141+

142+(>=) : comparable -> comparable -> Bool

143+(>=) = Native.Basics.ge

144+

145+-- Compare any two comparable values. Comparable values include `String`, `Char`,

146+-- `Int`, `Float`, `Time`, or a list or tuple containing comparable values.

147+-- These are also the only values that work as `Dict` keys or `Set` members.

148+compare : comparable -> comparable -> Order

149+compare = Native.Basics.compare

150+

151+-- Represents the relative ordering of two things.

152+-- The relations are less than, equal to, and greater than.

153+data Order = LT | EQ | GT

154+

155+-- The and operator. True if both inputs are True.

156+(&&) : Bool -> Bool -> Bool

157+(&&) = Native.Basics.and

158+

159+-- The or operator. True if one or both inputs are True.

160+(||) : Bool -> Bool -> Bool

161+(||) = Native.Basics.or

162+

163+-- The exclusive-or operator. True if exactly one input is True.

164+xor : Bool -> Bool -> Bool

165+xor = Native.Basics.xor

166+

167+-- Negate a boolean value: `(not True == False)` and `(not False == True)`

168+not : Bool -> Bool

169+not = Native.Basics.not

170+

171+-- Equal to true. Useful as the last case of a multi-way-if.

172+otherwise : Bool

173+otherwise = True

174+

175+

176+-- Conversions

177+

178+-- Round a number to the nearest integer.

179+round : Float -> Int

180+round = Native.Basics.round

181+

182+-- Truncate a decimal number, rounding towards zero.

183+truncate : Float -> Int

184+truncate = Native.Basics.truncate

185+

186+-- Floor function, rounding down.

187+floor : Float -> Int

188+floor = Native.Basics.floor

189+

190+-- Ceiling function, rounding up.

191+ceiling : Float -> Int

192+ceiling = Native.Basics.ceiling

193+

194+-- Convert an integer into a float.

195+toFloat : Int -> Float

196+toFloat = Native.Basics.toFloat

197+

198+

199+-- Function Helpers

200+

201+-- Function composition: `(f . g == (\\x -> f (g x)))`

202+(.) : (b -> c) -> (a -> b) -> (a -> c)

203+(.) f g x = f (g x)

204+

205+-- Forward function application `x |> f == f x`. This function is useful

206+-- for avoiding parenthesis and writing code in a more natural way.

207+-- Consider the following code to create a pentagon:

208+--

209+-- scale 2 (move (10,10) (filled blue (ngon 5 30)))

210+--

211+-- This can also be written as:

212+--

213+-- ngon 5 30 |> filled blue

214+-- |> move (10,10)

215+-- |> scale 2

216+(|>) : a -> (a -> b) -> b

217+x |> f = f x

218+

219+-- Function application `f <| x == f x`. This function is useful for avoiding

220+-- parenthesis. Consider the following code to create a text element:

221+--

222+-- text (monospace (toText "code"))

223+--

224+-- This can also be written as:

225+--

226+-- text . monospace <| toText "code"

227+(<|) : (a -> b) -> a -> b

228+f <| x = f x

229+

230+-- Given a value, returns exactly the same value.

231+id : a -> a

232+id x = x

233+

234+-- Given a 2-tuple, returns the first value.

235+fst : (a,b) -> a

236+fst = Native.Basics.fst

237+

238+-- Given a 2-tuple, returns the second value.

239+snd : (a,b) -> b

240+snd = Native.Basics.snd

241+

242+-- Flips the order of the first two arguments to a function.

243+flip : (a -> b -> c) -> (b -> a -> c)

244+flip f b a = f a b

245+

246+-- Change how arguments are passed to a function. This splits paired arguments

247+-- into two separate arguments.

248+curry : ((a,b) -> c) -> a -> b -> c

249+curry = Native.Basics.curry

250+

251+-- Change how arguments are passed to a function. This combines two arguments

252+-- into a sigle pair.

253+uncurry : (a -> b -> c) -> (a,b) -> c

254+uncurry = Native.Basics.uncurry

libraries/Char.elm+14−2

@@ -1,38 +1,50 @@

11

22module Char where

33

4−import Native.Char as N

4+import Native.Char

55

66-- True for upper case letters.

77isUpper : Char -> Bool

8+isUpper = Native.Char.isUpper

89

910-- True for lower case letters.

1011isLower : Char -> Bool

12+isLower = Native.Char.isLower

1113

1214-- True for ASCII digits (`0..9`).

1315isDigit : Char -> Bool

16+isDigit = Native.Char.isDigit

1417

1518-- True for ASCII octal digits (`0..7`).

1619isOctDigit : Char -> Bool

20+isOctDigit = Native.Char.isOctDigit

1721

1822-- True for ASCII hexadecimal digits (`0..9a..fA..F`).

1923isHexDigit : Char -> Bool

24+isHexDigit = Native.Char.isHexDigit

2025

2126-- Convert to upper case.

2227toUpper : Char -> Char

28+toUpper = Native.Char.toUpper

2329

2430-- Convert to lower case.

2531toLower : Char -> Char

32+toLower = Native.Char.toLower

2633

2734-- Convert to upper case, according to any locale-specific case mappings.

2835toLocaleUpper : Char -> Char

36+toLocaleUpper = Native.Char.toLocaleUpper

2937

3038-- Convert to lower case, according to any locale-specific case mappings.

3139toLocaleLower : Char -> Char

40+toLocaleLower = Native.Char.toLocaleLower

41+

42+type KeyCode = Int

3243

3344-- Convert to unicode.

3445toCode : Char -> KeyCode

46+toCode = Native.Char.toCode

3547

3648-- Convert from unicode.

3749fromCode : KeyCode -> Char

38−

50+fromCode = Native.Char.fromCode

libraries/Color.elm+7−2

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

11

22module Color where

33

4+import Native.Color

5+

46data Color = Color Int Int Int Float

57

68-- Create RGB colors with an alpha component for transparency.

@@ -56,16 +58,19 @@ forestGreen = Color 34 139 34 1

5658-- Produce a “complementary color”.

5759-- The two colors will accent each other.

5860complement : Color -> Color

61+complement = Native.Color.complement

5962

6063-- Create [HSV colors](http://en.wikipedia.org/wiki/HSL_and_HSV)

6164-- with an alpha component for transparency.

6265hsva : Float -> Float -> Float -> Float -> Color

66+hsva = Native.Color.hsva

6367

6468-- Create [HSV colors](http://en.wikipedia.org/wiki/HSL_and_HSV).

6569-- This is very convenient for creating colors that cycle and shift.

6670--

6771-- hsv (degrees 240) 1 1 == blue

6872hsv : Float -> Float -> Float -> Color

73+hsv = Native.Color.hsv

6974

7075data Gradient

7176 = Linear (Float,Float) (Float,Float) [(Float,Color)]

@@ -75,7 +80,7 @@ data Gradient

7580-- of “color stops” that indicate how to interpolate between

7681-- the start and end points. See [this example](/edit/examples/Elements/LinearGradient.elm) for

7782-- a more visual explanation.

78−linear : (Number a, Number a) -> (Number a, Number a) -> [(Float,Color)] -> Gradient

83+linear : (number, number) -> (number, number) -> [(Float,Color)] -> Gradient

7984linear = Linear

8085

8186-- Create a radial gradient. First takes a start point and inner radius.

@@ -83,5 +88,5 @@ linear = Linear

8388-- of “color stops” that indicate how to interpolate between

8489-- the inner and outer circles. See [this example](/edit/examples/Elements/RadialGradient.elm) for

8590-- a more visual explanation.

86−radial : (Number a,Number a) -> Number a -> (Number a,Number a) -> Number a -> [(Float,Color)] -> Gradient

91+radial : (number,number) -> number -> (number,number) -> number -> [(Float,Color)] -> Gradient

8792radial = Radial

libraries/Date.elm+19−4

@@ -4,6 +4,13 @@

44-- locale formatting or something.

55module Date where

66

7+import Basics (String)

8+import Native.Date

9+import Time (Time)

10+import Maybe (Maybe)

11+

12+data Date = Date

13+

714-- Represents the days of the week.

815data Day = Mon | Tue | Wed | Thu | Fri | Sat | Sun

916

@@ -14,37 +21,45 @@ data Month = Jan | Feb | Mar | Apr

1421

1522-- Attempt to read a date from a string.

1623read : String -> Maybe Date

24+read = Native.Date.read

1725

1826-- Convert a date into a time since midnight (UTC) of 1 January 1990 (i.e.

1927-- [UNIX time](http://en.wikipedia.org/wiki/Unix_time)). Given the date 23 June

2028-- 1990 at 11:45AM this returns the corresponding time.

2129toTime : Date -> Time

30+toTime = Native.Date.toTime

2231

2332-- Extract the year of a given date. Given the date 23 June 1990 at 11:45AM

2433-- this returns the integer `1990`.

25−year : Date -> Int

34+year : Date -> Int

35+year = Native.Date.year

2636

2737-- Extract the month of a given date. Given the date 23 June 1990 at 11:45AM

2838-- this returns the Month `Jun` as defined below.

2939month : Date -> Month

30−

40+month = Native.Date.month

3141

3242-- Extract the day of a given date. Given the date 23 June 1990 at 11:45AM

3343-- this returns the integer `23`.

34−day : Date -> Int

44+day : Date -> Int

45+day = Native.Date.day

3546

3647-- Extract the day of the week for a given date. Given the date 23 June

3748-- 1990 at 11:45AM this returns the Day `Thu` as defined below.

3849dayOfWeek : Date -> Day

50+dayOfWeek = Native.Date.dayOfWeek

3951

4052-- Extract the hour of a given date. Given the date 23 June 1990 at 11:45AM

4153-- this returns the integer `11`.

42−hour : Date -> Int

54+hour : Date -> Int

55+hour = Native.Date.hour

4356

4457-- Extract the minute of a given date. Given the date 23 June 1990 at 11:45AM

4558-- this returns the integer `45`.

4659minute : Date -> Int

60+minute = Native.Date.minute

4761

4862-- Extract the second of a given date. Given the date 23 June 1990 at 11:45AM

4963-- this returns the integer `0`.

5064second : Date -> Int

65+second = Native.Date.second

libraries/Dict.elm+41−40

@@ -8,17 +8,18 @@ module Dict (empty,singleton,insert

88 ,toList,fromList

99 ) where

1010

11−import Maybe as Maybe

12−import Native.Error as Error

11+import open Basics

12+import open Maybe

13+import Native.Error

1314import List as List

14−import Native.Utils (compare)

15+import Native.Utils

1516

1617data NColor = Red | Black

1718

1819data Dict k v = RBNode NColor k v (Dict k v) (Dict k v) | RBEmpty

1920

2021-- Create an empty dictionary.

21−empty : Dict (Comparable k) v

22+empty : Dict comparable v

2223empty = RBEmpty

2324

2425{-- Helpers for checking invariants

@@ -104,36 +105,36 @@ min t =

104105 case t of

105106 RBNode _ k v RBEmpty _ -> (k,v)

106107 RBNode _ _ _ l _ -> min l

107− RBEmpty -> Error.raise "(min Empty) is not defined"

108+ RBEmpty -> Native.Error.raise "(min Empty) is not defined"

108109

109110{--

110111max t =

111112 case t of

112113 { RBNode _ k v _ RBEmpty -> (k,v)

113114 ; RBNode _ _ _ _ r -> max r

114− ; RBEmpty -> Error.raise "(max Empty) is not defined"

115+ ; RBEmpty -> Native.Error.raise "(max Empty) is not defined"

115116 }

116117--}

117118

118119-- Lookup the value associated with a key.

119−lookup : Comparable k -> Dict (Comparable k) v -> Maybe v

120+lookup : comparable -> Dict comparable v -> Maybe v

120121lookup k t =

121122 case t of

122− RBEmpty -> Maybe.Nothing

123+ RBEmpty -> Nothing

123124 RBNode _ k' v l r ->

124− case compare k k' of

125+ case Native.Utils.compare k k' of

125126 LT -> lookup k l

126− EQ -> Maybe.Just v

127+ EQ -> Just v

127128 GT -> lookup k r

128129

129130-- Find the value associated with a key. If the key is not found,

130131-- return the default value.

131−findWithDefault : v -> Comparable k -> Dict (Comparable k) v -> v

132+findWithDefault : v -> comparable -> Dict comparable v -> v

132133findWithDefault base k t =

133134 case t of

134135 RBEmpty -> base

135136 RBNode _ k' v l r ->

136− case compare k k' of

137+ case Native.Utils.compare k k' of

137138 LT -> findWithDefault base k l

138139 EQ -> v

139140 GT -> findWithDefault base k r

@@ -142,9 +143,9 @@ findWithDefault base k t =

142143-- Find the value associated with a key. If the key is not found, there will be a runtime error.

143144find k t =

144145 case t of

145− { RBEmpty -> Error.raise "Key was not found in dictionary!"

146+ { RBEmpty -> Native.Error.raise "Key was not found in dictionary!"

146147 ; RBNode _ k' v l r ->

147− case compare k k' of

148+ case Native.Utils.compare k k' of

148149 { LT -> find k l

149150 ; EQ -> v

150151 ; GT -> find k r }

@@ -152,15 +153,15 @@ find k t =

152153--}

153154

154155-- Determine if a key is in a dictionary.

155−member : Comparable k -> Dict (Comparable k) v -> Bool

156+member : comparable -> Dict comparable v -> Bool

156157-- Does t contain k?

157−member k t = Maybe.isJust <| lookup k t

158+member k t = isJust <| lookup k t

158159

159160rotateLeft : Dict k v -> Dict k v

160161rotateLeft t =

161162 case t of

162163 RBNode cy ky vy a (RBNode cz kz vz b c) -> RBNode cy kz vz (RBNode Red ky vy a b) c

163− _ -> Error.raise "rotateLeft of a node without enough children"

164+ _ -> Native.Error.raise "rotateLeft of a node without enough children"

164165

165166-- rotateRight -- the reverse, and

166167-- makes Y have Z's color, and makes Z Red.

@@ -168,7 +169,7 @@ rotateRight : Dict k v -> Dict k v

168169rotateRight t =

169170 case t of

170171 RBNode cz kz vz (RBNode cy ky vy a b) c -> RBNode cz ky vy a (RBNode Red kz vz b c)

171− _ -> Error.raise "rotateRight of a node without enough children"

172+ _ -> Native.Error.raise "rotateRight of a node without enough children"

172173

173174rotateLeftIfNeeded : Dict k v -> Dict k v

174175rotateLeftIfNeeded t =

@@ -191,7 +192,7 @@ color_flip t =

191192 RBNode (otherColor c1) bk bv

192193 (RBNode (otherColor c2) ak av la ra)

193194 (RBNode (otherColor c3) ck cv lc rc)

194− _ -> Error.raise "color_flip called on a Empty or Node with a Empty child"

195+ _ -> Native.Error.raise "color_flip called on a Empty or Node with a Empty child"

195196

196197color_flipIfNeeded : Dict k v -> Dict k v

197198color_flipIfNeeded t =

@@ -209,13 +210,13 @@ ensureBlackRoot t =

209210

210211-- Insert a key-value pair into a dictionary. Replaces value when there is

211212-- a collision.

212−insert : Comparable k -> v -> Dict (Comparable k) v -> Dict (Comparable k) v

213+insert : comparable -> v -> Dict comparable v -> Dict comparable v

213214insert k v t = -- Invariant: t is a valid left-leaning rb tree

214215 let ins t =

215216 case t of

216217 RBEmpty -> RBNode Red k v RBEmpty RBEmpty

217218 RBNode c k' v' l r ->

218− let h = case compare k k' of

219+ let h = case Native.Utils.compare k k' of

219220 LT -> RBNode c k' v' (ins l) r

220221 EQ -> RBNode c k' v l r -- replace

221222 GT -> RBNode c k' v' l (ins r)

@@ -223,15 +224,15 @@ insert k v t = -- Invariant: t is a valid left-leaning rb tree

223224 in ensureBlackRoot (ins t)

224225{--

225226 if not (invariants_hold t) then

226− Error.raise "invariants broken before insert"

227+ Native.Error.raise "invariants broken before insert"

227228 else (let new_t = ensureBlackRoot (ins t) in

228229 if not (invariants_hold new_t) then

229− Error.raise "invariants broken after insert"

230+ Native.Error.raise "invariants broken after insert"

230231 else new_t)

231232--}

232233

233234-- Create a dictionary with one key-value pair.

234−singleton : Comparable k -> v -> Dict (Comparable k) v

235+singleton : comparable -> v -> Dict comparable v

235236singleton k v = insert k v RBEmpty

236237

237238isRed : Dict k v -> Bool

@@ -313,21 +314,21 @@ deleteMax t =

313314

314315-- Remove a key-value pair from a dictionary. If the key is not found,

315316-- no changes are made.

316−remove : Comparable k -> Dict (Comparable k) v -> Dict (Comparable k) v

317+remove : comparable -> Dict comparable v -> Dict comparable v

317318remove k t =

318319 let eq_and_noRightNode t =

319320 case t of { RBNode _ k' _ _ RBEmpty -> k == k' ; _ -> False }

320321 eq t = case t of { RBNode _ k' _ _ _ -> k == k' ; _ -> False }

321322 delLT t = case moveRedLeftIfNeeded t of

322323 RBNode c k' v l r -> fixUp (RBNode c k' v (del l) r)

323− RBEmpty -> Error.raise "delLT on Empty"

324+ RBEmpty -> Native.Error.raise "delLT on Empty"

324325 delEQ t = case t of -- Replace with successor

325326 RBNode c _ _ l r -> let (k',v') = min r in

326327 fixUp (RBNode c k' v' l (deleteMin r))

327− RBEmpty -> Error.raise "delEQ called on a Empty"

328+ RBEmpty -> Native.Error.raise "delEQ called on a Empty"

328329 delGT t = case t of

329330 RBNode c k' v l r -> fixUp (RBNode c k' v l (del r))

330− RBEmpty -> Error.raise "delGT called on a Empty"

331+ RBEmpty -> Native.Error.raise "delGT called on a Empty"

331332 del t = case t of

332333 RBEmpty -> RBEmpty

333334 RBNode _ k' _ _ _ ->

@@ -339,14 +340,14 @@ remove k t =

339340 in if member k t then ensureBlackRoot (del t) else t

340341{--

341342 if not (invariants_hold t) then

342− Error.raise "invariants broken before remove"

343+ Native.Error.raise "invariants broken before remove"

343344 else (let t' = ensureBlackRoot (del t) in

344345 if invariants_hold t' then t' else

345− Error.raise "invariants broken after remove")

346+ Native.Error.raise "invariants broken after remove")

346347--}

347348

348349-- Apply a function to all values in a dictionary.

349−map : (a -> b) -> Dict (Comparable k) a -> Dict (Comparable k) b

350+map : (a -> b) -> Dict comparable a -> Dict comparable b

350351map f t =

351352 case t of

352353 RBEmpty -> RBEmpty

@@ -354,7 +355,7 @@ map f t =

354355

355356-- Fold over the key-value pairs in a dictionary, in order from lowest

356357-- key to highest key.

357−foldl : (Comparable k -> v -> b -> b) -> b -> Dict (Comparable k) v -> b

358+foldl : (comparable -> v -> b -> b) -> b -> Dict comparable v -> b

358359foldl f acc t =

359360 case t of

360361 RBEmpty -> acc

@@ -362,7 +363,7 @@ foldl f acc t =

362363

363364-- Fold over the key-value pairs in a dictionary, in order from highest

364365-- key to lowest key.

365−foldr : (Comparable k -> v -> b -> b) -> b -> Dict (Comparable k) v -> b

366+foldr : (comparable -> v -> b -> b) -> b -> Dict comparable v -> b

366367foldr f acc t =

367368 case t of

368369 RBEmpty -> acc

@@ -370,33 +371,33 @@ foldr f acc t =

370371

371372-- Combine two dictionaries. If there is a collision, preference is given

372373-- to the first dictionary.

373−union : Dict (Comparable k) v -> Dict (Comparable k) v -> Dict (Comparable k) v

374+union : Dict comparable v -> Dict comparable v -> Dict comparable v

374375union t1 t2 = foldl insert t2 t1

375376

376377-- Keep a key-value pair when its key appears in the second dictionary.

377378-- Preference is given to values in the first dictionary.

378−intersect : Dict (Comparable k) v -> Dict (Comparable k) v -> Dict (Comparable k) v

379+intersect : Dict comparable v -> Dict comparable v -> Dict comparable v

379380intersect t1 t2 =

380381 let combine k v t = if k `member` t2 then insert k v t else t

381382 in foldl combine empty t1

382383

383384-- Keep a key-value pair when its key does not appear in the second dictionary.

384385-- Preference is given to the first dictionary.

385−diff : Dict (Comparable k) v -> Dict (Comparable k) v -> Dict (Comparable k) v

386+diff : Dict comparable v -> Dict comparable v -> Dict comparable v

386387diff t1 t2 = foldl (\k v t -> remove k t) t1 t2

387388

388389-- Get all of the keys in a dictionary.

389−keys : Dict (Comparable k) v -> [Comparable k]

390+keys : Dict comparable v -> [comparable]

390391keys t = foldr (\k v acc -> k :: acc) [] t

391392

392393-- Get all of the values in a dictionary.

393−values : Dict (Comparable k) v -> [v]

394+values : Dict comparable v -> [v]

394395values t = foldr (\k v acc -> v :: acc) [] t

395396

396397-- Convert a dictionary into an association list of key-value pairs.

397−toList : Dict (Comparable k) v -> [(Comparable k,v)]

398+toList : Dict comparable v -> [(comparable,v)]

398399toList t = foldr (\k v acc -> (k,v) :: acc) [] t

399400

400401-- Convert an association list into a dictionary.

401−fromList : [(Comparable k,v)] -> Dict (Comparable k) v

402+fromList : [(comparable,v)] -> Dict comparable v

402403fromList assocs = List.foldl (\(k,v) d -> insert k v d) empty assocs

libraries/Graphics/Collage.elm+35−26

@@ -1,26 +1,29 @@

11

22module Graphics.Collage where

33

4+import open Basics

45import List

5−import Native.Utils (toFloat)

6−import Either

7−import Native.Matrix2D as Matrix

8−import Native.Graphics.Collage as N

9−import Graphics.Element

10−import Color

6+import Either (Either, Left, Right)

7+import Matrix2D (Matrix2D, identity)

8+import Native.Graphics.Collage

9+import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)

10+import Color (Color, black, Gradient)

11+import Maybe (Maybe)

12+import JavaScript (JSString)

1113

1214type Form = {

1315 theta : Float,

1416 scale : Float,

1517 x : Float,

1618 y : Float,

19+ alpha : Float,

1720 form : BasicForm

1821 }

1922

2023data FillStyle

2124 = Solid Color

2225 | Texture String

23− | Gradient Gradient

26+ | Grad Gradient

2427

2528-- The shape of the ends of a line.

2629data LineCap = Flat | Round | Padded

@@ -48,7 +51,7 @@ type LineStyle = {

4851-- { defaultLine | width <- 10 }

4952defaultLine : LineStyle

5053defaultLine = {

51− color = Color.black,

54+ color = black,

5255 width = 1,

5356 cap = Flat,

5457 join = Sharp 10,

@@ -75,9 +78,10 @@ data BasicForm

7578 | FElement Element

7679 | FGroup Matrix2D [Form]

7780

78−form f = { theta = 0, scale = 1, x = 0, y = 0, form = f }

81+form : BasicForm -> Form

82+form f = { theta=0, scale=1, x=0, y=0, alpha=1, form=f }

7983

80−fill style shape = form (FShape (Either.Right style) shape)

84+fill style shape = form (FShape (Right style) shape)

8185

8286-- Create a filled in shape.

8387filled : Color -> Shape -> Form

@@ -90,11 +94,11 @@ textured src shape = fill (Texture src) shape

9094

9195-- Fill a shape with a [gradient](/docs/Color.elm#linear).

9296gradient : Gradient -> Shape -> Form

93−gradient grad shape = fill (Gradient grad) shape

97+gradient grad shape = fill (Grad grad) shape

9498

9599-- Outline a shape with a given line style.

96100outlined : LineStyle -> Shape -> Form

97−outlined style shape = form (FShape (Either.Left style) shape)

101+outlined style shape = form (FShape (Left style) shape)

98102

99103-- Trace a path with a given line style.

100104traced : LineStyle -> Path -> Form

@@ -114,7 +118,7 @@ toForm e = form (FElement e)

114118-- Flatten many forms into a single `Form`. This lets you move and rotate them

115119-- as a single unit, making it possible to build small, modular components.

116120group : [Form] -> Form

117−group fs = form (FGroup Matrix.identity fs)

121+group fs = form (FGroup identity fs)

118122

119123-- Flatten many forms into a single `Form` and then apply a matrix

120124-- transformation.

@@ -147,19 +151,24 @@ moveX x f = { f | x <- f.x + x }

147151moveY : Float -> Form -> Form

148152moveY y f = { f | y <- f.y + y }

149153

154+-- Set the alpha of a `Form`. The default is 1, and 0 is totally transparent.

155+alpha : Float -> Form -> Form

156+alpha a f = { f | alpha <- a }

157+

150158-- A collage is a collection of 2D forms. There are no strict positioning

151159-- relationships between forms, so you are free to do all kinds of 2D graphics.

152160collage : Int -> Int -> [Form] -> Element

161+collage = Native.Graphics.Collage.collage

153162

154163

155164type Path = [(Float,Float)]

156165

157166-- Create a path that follows a sequence of points.

158−path : [(Number a,Number a)] -> Path

167+path : [(Float,Float)] -> Path

159168path ps = ps

160169

161170-- Create a path along a given line segment.

162−segment : (Number a,Number a) -> (Number a,Number a) -> Path

171+segment : (Float,Float) -> (Float,Float) -> Path

163172segment p1 p2 = [p1,p2]

164173

165174type Shape = [(Float,Float)]

@@ -167,31 +176,31 @@ type Shape = [(Float,Float)]

167176-- Create an arbitrary polygon by specifying its corners in order.

168177-- `polygon` will automatically close all shapes, so the given list

169178-- of points does not need to start and end with the same position.

170−polygon : [(Number a,Number a)] -> Shape

179+polygon : [(Float,Float)] -> Shape

171180polygon points = points

172181

173182-- A rectangle with a given width and height.

174−rect : Number a -> Number a -> Shape

183+rect : Float -> Float -> Shape

175184rect w h = let hw = w/2

176185 hh = h/2

177186 in [ (0-hw,0-hh), (0-hw,hh), (hw,hh), (hw,0-hh) ]

178187

179188-- A square with a given edge length.

180−square : Number a -> Shape

189+square : Float -> Shape

181190square n = rect n n

182191

183192-- An oval with a given width and height.

184−oval : Number a -> Number a -> Shape

193+oval : Float -> Float -> Shape

185194oval w h =

186195 let n = 50

187− t = 2 * Math.PI / n

196+ t = 2 * pi / n

188197 hw = w/2

189198 hh = h/2

190− f i = (hw * Math.cos (t*i), hh * Math.sin (t*i))

199+ f i = (hw * cos (t*i), hh * sin (t*i))

191200 in List.map f [0..n-1]

192201

193202-- A circle with a given radius.

194−circle : Number a -> Shape

203+circle : Float -> Shape

195204circle r = oval (2*r) (2*r)

196205

197206-- A regular polygon with N sides. The first argument specifies the number

@@ -199,9 +208,9 @@ circle r = oval (2*r) (2*r)

199208-- 30 you would say:

200209--

201210-- ngon 5 30

202−ngon : Int -> Number a -> Shape

211+ngon : Int -> Float -> Shape

203212ngon n r =

204213 let m = toFloat n

205− t = 2 * Math.PI / m

206− f i = ( r * Math.cos (t*i), r * Math.sin (t*i) )

207− in List.map f [0..n-1]

214+ t = 2 * pi / m

215+ f i = ( r * cos (t*i), r * sin (t*i) )

216+ in List.map f [0..m-1]

libraries/Graphics/Element.elm+32−33

@@ -1,22 +1,13 @@

11

2−module Graphics.Element (widthOf, heightOf, sizeOf,

3− width, height, size, opacity, color, tag, link,

4− image, fittedImage, croppedImage, tiledImage,

5− flow, up, down, left, right, inward, outward,

6− above, below, beside, layers,

7− container, absolute, relative,

8− middle, topLeft, topRight, bottomLeft, bottomRight,

9− midLeft, midRight, midTop, midBottom, middleAt,

10− topLeftAt, topRightAt, bottomLeftAt, bottomRightAt,

11− midLeftAt, midRightAt, midTopAt, midBottomAt,

12− spacer, newElement

13− ) where

14−

15−import Native.Utils (guid, max, htmlHeight)

2+module Graphics.Element where

3+

4+import open Basics

5+import Native.Utils

166import JavaScript as JS

7+import JavaScript (JSString)

178import List as List

18−import Color

19−import Maybe (Just, Nothing)

9+import open Color

10+import Maybe (Maybe, Just, Nothing)

2011

2112type Properties = {

2213 id : Int,

@@ -25,7 +16,8 @@ type Properties = {

2516 opacity : Float,

2617 color : Maybe Color,

2718 href : JSString,

28− tag : JSString

19+ tag : JSString,

20+ hover : ()

2921 }

3022

3123type Element = { props : Properties, element : ElementPrim }

@@ -44,20 +36,22 @@ sizeOf e = (e.props.width, e.props.height)

4436

4537-- Create an `Element` with a given width.

4638width : Int -> Element -> Element

47−width nw e = let p = e.props

48− props = case e.element of

49− Image _ w h _ -> {p| height <- h/w*nw }

50− RawHtml html -> {p| height <- let (w,h) = htmlHeight nw html in h}

51− _ -> p

52− in { element=e.element, props={props| width <- nw} }

39+width nw e =

40+ let p = e.props

41+ props = case e.element of

42+ Image _ w h _ -> {p| height <- round (toFloat h / toFloat w * toFloat nw) }

43+ RawHtml html -> {p| height <- snd (Native.Utils.htmlHeight nw html)}

44+ _ -> p

45+ in { element=e.element, props={ props | width <- nw } }

5346

5447-- Create an `Element` with a given height.

5548height : Int -> Element -> Element

56−height nh e = let p = e.props

57− props = case e.element of

58− Image _ w h _ -> {p| width <- w/h*nh }

59− _ -> p

60− in { element=e.element, props={p| height <- nh} }

49+height nh e =

50+ let p = e.props

51+ props = case e.element of

52+ Image _ w h _ -> {p| width <- round (toFloat w / toFloat h * toFloat nh) }

53+ _ -> p

54+ in { element=e.element, props={ p | height <- nh} }

6155

6256-- Create an `Element` with a new width and height.

6357size : Int -> Int -> Element -> Element

@@ -70,24 +64,26 @@ opacity o e = let p = e.props in { element=e.element, props={p| opacity <- o} }

7064

7165-- Create an `Element` with a given background color.

7266color : Color -> Element -> Element

73−color c e = let p = e.props in

74− { element=e.element, props={p| color <- Just c} }

67+color c e = let p = e.props in

68+ { element = e.element

69+ , props = { p | color <- Just c}

70+ }

7571

7672-- Create an `Element` with a tag. This lets you link directly to it.

7773-- The element `(tag "all-about-badgers" thirdParagraph)` can be reached

7874-- with a link lik this: `/facts-about-animals.elm#all-about-badgers`

7975tag : String -> Element -> Element

8076tag name e = let p = e.props in

81− { element=e.element, props={p| tag <- JS.fromString name} }

77+ { element=e.element, props={p | tag <- JS.fromString name} }

8278

8379-- Create an `Element` that is a hyper-link.

8480link : String -> Element -> Element

8581link href e = let p = e.props in

86− { element=e.element, props={p| href <- JS.fromString href} }

82+ { element=e.element, props={p | href <- JS.fromString href} }

8783

8884emptyStr = JS.fromString ""

8985newElement w h e =

90− { props = Properties (guid ()) w h 1 Nothing emptyStr emptyStr, element = e }

86+ { props = Properties (Native.Utils.guid ()) w h 1 Nothing emptyStr emptyStr (), element = e }

9187

9288data ElementPrim

9389 = Image ImageStyle Int Int JSString

@@ -121,6 +117,9 @@ tiledImage : Int -> Int -> String -> Element

121117tiledImage w h src =

122118 newElement w h (Image Tiled w h (JS.fromString src))

123119

120+markdown : Element

121+markdown = Native.Utils.undefined

122+

124123data Three = P | Z | N

125124data Pos = Absolute Int | Relative Float

126125type Position = { horizontal : Three, vertical : Three, x : Pos, y : Pos }

libraries/Graphics/Input.elm+29−10

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

11

22module Graphics.Input where

33

4−import Signal (lift,dropRepeats)

5−import Native.Graphics.Input as N

4+import Basics (String)

5+import Signal (Signal,lift,dropRepeats)

6+import Native.Graphics.Input

67import List

8+import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)

9+import Color (Color)

10+import Maybe (Maybe)

11+import JavaScript (JSString)

712

813id x = x

914

@@ -17,12 +22,13 @@ id x = x

1722-- The `a` value is sent to `events` whenever the button is pressed.

1823buttons : a -> { events : Signal a,

1924 button : a -> String -> Element }

25+buttons = Native.Graphics.Input.buttons

2026

2127-- Create a button with a given label. The result is an `Element` and

2228-- a signal of units. This signal triggers whenever the button is pressed.

2329button : String -> (Element, Signal ())

2430button txt =

25− let pool = N.buttons ()

31+ let pool = buttons ()

2632 in (pool.button () txt, pool.events)

2733

2834-- Create a group of custom buttons.

@@ -36,13 +42,14 @@ button txt =

3642-- The `a` value is sent to `events` whenever the button is pressed.

3743customButtons : a -> { events : Signal a,

3844 customButton : a -> Element -> Element -> Element -> Element }

45+customButtons = Native.Graphics.Input.customButtons

3946

4047-- Create a button with custom states for up, hovering, and down

4148-- (given in that order). The result is an `Element` and

4249-- a signal of units. This signal triggers whenever the button is pressed.

4350customButton : Element -> Element -> Element -> (Element, Signal ())

4451customButton up hover down =

45− let pool = N.customButtons ()

52+ let pool = customButtons ()

4653 in (pool.customButton () up hover down, pool.events)

4754

4855-- Create a group of checkboxes.

@@ -57,6 +64,7 @@ customButton up hover down =

5764-- lets you add an ID to distinguish between checkboxes.

5865checkboxes : a -> { events : Signal a,

5966 checkbox : (Bool -> a) -> Bool -> Element }

67+checkboxes = Native.Graphics.Input.checkboxes

6068

6169-- Create a checkbox with a given start state. Unlike `button`, this result

6270-- is a *signal* of elements. That is because a checkbox has state that

@@ -64,8 +72,17 @@ checkboxes : a -> { events : Signal a,

6472-- The boolean signal represents the current state of the checkbox.

6573checkbox : Bool -> (Signal Element, Signal Bool)

6674checkbox b =

67− let cbs = N.checkboxes b

68− in (lift (cbs.box id) cbs.events, cbs.events)

75+ let cbs = checkboxes b

76+ in (lift (cbs.checkbox id) cbs.events, cbs.events)

77+

78+hoverables : a -> { events : Signal a,

79+ hoverable : (Bool -> a) -> Element -> Element }

80+hoverables = Native.Graphics.Input.hoverables

81+

82+hoverable : Element -> (Element, Signal Bool)

83+hoverable elem =

84+ let pool = hoverables False

85+ in (pool.hoverable id elem, pool.events)

6986

7087-- Represents the current state of a text field. The `string` represents the

7188-- characters filling the text field. The `selectionStart` and `selectionEnd`

@@ -90,6 +107,7 @@ type FieldState = { string:String, selectionStart:Int, selectionEnd:Int }

90107-- lets you add an ID to distinguish between input fields.

91108fields : a -> { events : Signal a,

92109 field : (FieldState -> a) -> String -> FieldState -> Element }

110+fields = Native.Graphics.Input.fields

93111

94112-- The empty field state:

95113--

@@ -102,7 +120,7 @@ emptyFieldState = { string="", selectionStart=0, selectionEnd=0 }

102120-- content of the field.

103121field : String -> (Signal Element, Signal String)

104122field placeHolder =

105− let tfs = N.fields emptyFieldState

123+ let tfs = fields emptyFieldState

106124 changes = dropRepeats tfs.events

107125 in (lift (tfs.field id placeHolder) changes,

108126 dropRepeats (lift .string changes))

@@ -110,7 +128,7 @@ field placeHolder =

110128-- Same as `field` but the UI element blocks out each characters.

111129password : String -> (Signal Element, Signal String)

112130password placeHolder =

113− let tfs = N.passwords emptyFieldState

131+ let tfs = Native.Graphics.Input.passwords emptyFieldState

114132 changes = dropRepeats tfs.events

115133 in (lift (tfs.field id placeHolder) changes,

116134 dropRepeats (lift .string changes))

@@ -120,7 +138,7 @@ password placeHolder =

120138-- get a custom keyboard with an `@` and `.com` button.

121139email : String -> (Signal Element, Signal String)

122140email placeHolder =

123− let tfs = N.emails emptyFieldState

141+ let tfs = Native.Graphics.Input.emails emptyFieldState

124142 changes = dropRepeats tfs.events

125143 in (lift (tfs.field id placeHolder) changes,

126144 dropRepeats (lift .string changes))

@@ -130,9 +148,10 @@ email placeHolder =

130148-- value. This lets you avoid manually mapping the string onto

131149-- functions and values.

132150dropDown : [(String,a)] -> (Signal Element, Signal a)

151+dropDown = Native.Graphics.Input.dropDown

133152

134153-- Create a drop-down menu for selecting strings. The resulting

135154-- signal of strings represents the string that is currently selected.

136155stringDropDown : [String] -> (Signal Element, Signal String)

137156stringDropDown strs =

138− N.dropDown (List.map (\s -> (s,s)) strs)

157+ dropDown (List.map (\s -> (s,s)) strs)

libraries/Http.elm+4−2

@@ -4,8 +4,9 @@

44

55module Http where

66

7−import Native.Http (send)

8−import Signal (lift)

7+import open Basics

8+import open Signal

9+import Native.Http

910

1011-- The datatype for responses. Success contains only the returned message.

1112-- Failures contain both an error code and an error message.

@@ -35,6 +36,7 @@ post url body = Request "POST" url body []

3536-- Performs an HTTP request with the given requests. Produces a signal

3637-- that carries the responses.

3738send : Signal (Request a) -> Signal (Response String)

39+send = Native.Http.send

3840

3941-- Performs an HTTP GET request with the given urls. Produces a signal

4042-- that carries the responses.

libraries/JavaScript.elm+31−1

@@ -1,26 +1,56 @@

11

22module JavaScript where

33

4+import Native.JavaScript

5+import open Basics

6+

7+data JSNumber = JSNumber

8+data JSBool = JSBool

9+data JSString = JSString

10+data JSArray a = JSArray a

11+data JSDomNode = JSDomNode

12+data JSObject = JSObject

413

514-- Requires that the input array be uniform (all members have the same type)

615toList : JSArray a -> [a]

16+toList = Native.JavaScript.toList

17+

718toInt : JSNumber -> Int

19+toInt = Native.JavaScript.toInt

20+

821toFloat : JSNumber -> Float

22+toFloat = Native.JavaScript.toFloat

23+

924toBool : JSBool -> Bool

25+toBool = Native.JavaScript.toBool

26+

1027toString : JSString -> String

28+toString = Native.JavaScript.toString

1129

1230

1331-- Produces a uniform JavaScript array with all members of the same type.

1432fromList : [a] -> JSArray a

33+fromList = Native.JavaScript.fromList

34+

1535fromInt : Int -> JSNumber

36+fromInt = Native.JavaScript.fromInt

37+

1638fromFloat : Float -> JSNumber

39+fromFloat = Native.JavaScript.fromFloat

40+

1741fromBool : Bool -> JSBool

18−fromString : String -> JSString

42+fromBool = Native.JavaScript.fromBool

1943

44+fromString : String -> JSString

45+fromString = Native.JavaScript.fromString

2046

47+{--

2148-- Turn an `Element` into a plain old DOM node.

2249fromElement : Element -> JSDomNode

50+fromElement = Native.JavaScript.fromElement

2351

2452-- Turn a DOM node into an `Element`. You can resize the node

2553-- using the normal `width` and `height` functions.

2654toElement : Int -> Int -> JSDomNode -> Element

55+toElement = Native.JavaScript.toElement

56+--}

libraries/JavaScript/Experimental.elm+4−3

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

11

22module JavaScript.Experimental where

33

4−import JavaScript as JS

4+import JavaScript (JSObject)

5+import Native.JavaScript

56

67-- Turn arbitrary JavaScript objects into Elm records.

78-- Arrays are converted into lists, nested objects are allowed.

@@ -15,7 +16,7 @@ import JavaScript as JS

1516-- { answer:null }

1617-- { info:[true,42,'what'] }

1718toRecord : JSObject -> a

18−toRecord = JS.toRecord

19+toRecord = Native.JavaScript.toRecord

1920

2021-- Turn arbitrary Elm records into JavaScript objects.

2122-- Lists become arrays, nested records are allowed. No ADTs.

@@ -28,4 +29,4 @@ toRecord = JS.toRecord

2829-- { answer = Nothing }

2930-- { result = Left "An error occurred" }

3031fromRecord : a -> JSObject

31−fromRecord = JS.fromRecord

32+fromRecord = Native.JavaScript.fromRecord

libraries/Json.elm+12−5

@@ -3,9 +3,12 @@

33

44module Json where

55

6−import Dict as Dict

6+import open Basics

7+import Dict

8+import Maybe (Maybe)

79import JavaScript as JS

8−import Native.Json as Native

10+import Native.Json

11+import JavaScript (JSObject, JSString)

912

1013-- This datatype can represent all valid values that can be held in a JSON

1114-- object. In Elm, a proper JSON object is represented as a (Dict String JsonValue)

@@ -16,7 +19,7 @@ data JsonValue

1619 | Boolean Bool

1720 | Null

1821 | Array [JsonValue]

19− | Object (Dict String JsonValue)

22+ | Object (Dict.Dict String JsonValue)

2023

2124

2225-- String Converters

@@ -25,24 +28,27 @@ data JsonValue

2528-- The first argument is a separator token (e.g. \" \", \"\\n\", etc.) that will

2629-- be used for indentation in the prettified string version of the JSON.

2730toString : String -> JsonValue -> String

28−toString sep v = JS.toString (Native.toJSString sep v)

31+toString sep v = JS.toString (Native.Json.toJSString sep v)

2932

3033-- Convert a proper JSON object into a JavaScript string.

3134-- Note that the type JSString seen here is not the same as the type constructor

3235-- JsonString used elsewhere in this module.

3336toJSString : String -> JsonValue -> JSString

37+toJSString = Native.Json.toJSString

3438

3539-- Parse a string representation of a proper JSON object into

3640-- its Elm representation.

3741fromString : String -> Maybe JsonValue

38−fromString s = Native.fromJSString (JS.fromString s)

42+fromString s = Native.Json.fromJSString (JS.fromString s)

3943

4044-- Parse a JavaScript string representation of a proper JSON object into

4145-- its Elm representation.

4246fromJSString : JSString -> Maybe JsonValue

47+fromJSString = Native.Json.fromJSString

4348

4449-- Convert a JS object into a `JsonValue`.

4550fromJSObject : JSObject -> JsonValue

51+fromJSObject = Native.Json.fromJSObject

4652

4753-- Convert a `JsonValue` into a `JSObject`. Paired with the

4854-- [`JavaScript.Experimental` library](/docs/JavaScript/Experimental.elm),

@@ -55,6 +61,7 @@ fromJSObject : JSObject -> JsonValue

5561-- Just jsonValue -> Just (JS.toRecord (toJSObject jsonValue))

5662-- Nothing -> Nothing

5763toJSObject : JsonValue -> JSObject

64+toJSObject = Native.Json.toJSObject

5865

5966 {-- Extract Elm values from Json values

6067

libraries/Keyboard.elm+17−12

@@ -1,12 +1,19 @@

11module Keyboard where

22

3−import Native.Keyboard as N

3+import Signal (Signal)

4+import Native.Keyboard

45

56-- Type alias to make it clearer what integers are supposed to represent

67-- in this library. Use [`Char.toCode`](docs/Char.elm#toCode) and

78-- [`Char.fromCode`](/docs/Char.elm#fromCode) to convert key codes to characters.

89type KeyCode = Int

910

11+-- Custom key directions so that you can support different locales.

12+-- The plan is to have a locale independent version of this function

13+-- that uses the physical location of keys, but I don't know how to do it.

14+directions : KeyCode -> KeyCode -> KeyCode -> KeyCode -> Signal { x:Int, y:Int }

15+directions = Native.Keyboard.directions

16+

1017-- A signal of records indicating which arrow keys are pressed.

1118--

1219-- `{ x = 0, y = 0 }` when pressing no arrows.<br>

@@ -14,39 +21,37 @@ type KeyCode = Int

1421-- `{ x = 1, y = 1 }` when pressing the up and right arrows.<br>

1522-- `{ x = 0, y =-1 }` when pressing the down, left, and right arrows.

1623arrows : Signal { x:Int, y:Int }

17−arrows = N.directions 38 40 37 39

24+arrows = directions 38 40 37 39

1825

1926-- Just like the arrows signal, but this uses keys w, a, s, and d,

2027-- which are common controls for many computer games.

2128wasd : Signal { x:Int, y:Int }

22−wasd = N.directions 87 83 65 68

23−

24−-- Custom key directions so that you can support different locales.

25−-- The plan is to have a locale independent version of this function

26−-- that uses the physical location of keys, but I don't know how to do it.

27−directions : KeyCode -> KeyCode -> KeyCode -> KeyCode -> Signal { x:Int, y:Int }

29+wasd = directions 87 83 65 68

2830

2931-- Whether an arbitrary key is pressed.

3032isDown : KeyCode -> Signal Bool

33+isDown = Native.Keyboard.isDown

3134

3235-- Whether the shift key is pressed.

3336shift : Signal Bool

34−shift = N.isDown 16

37+shift = isDown 16

3538

3639-- Whether the control key is pressed.

3740ctrl : Signal Bool

38−ctrl = N.isDown 17

41+ctrl = isDown 17

3942

4043-- Whether the space key is pressed.

4144space : Signal Bool

42−space = N.isDown 32

45+space = isDown 32

4346

4447-- Whether the enter key is pressed.

4548enter : Signal Bool

46−enter = N.isDown 13

49+enter = isDown 13

4750

4851-- List of keys that are currently down.

4952keysDown : Signal [KeyCode]

53+keysDown = Native.Keyboard.keysDown

5054

5155-- The latest key that has been pressed.

5256lastPressed : Signal KeyCode

57+lastPressed = Native.Keyboard.lastPressed

libraries/List.elm+50−25

@@ -1,29 +1,34 @@

11

22module List where

33

4−import Native.Utils (min, max)

5−import Native.List as L

4+import open Basics

5+import Native.List

66

77-- Add an element to the front of a list `(1 :: [2,3] == [1,2,3])`

88(::) : a -> [a] -> [a]

9+(::) = Native.List.cons

910

1011-- Puts two appendable things together:

1112--

1213-- [1,1] ++ [2,3] == [1,1,2,3]

1314-- "abc" ++ "123" == "abc123"

14−(++) : Appendable a -> Appendable a -> Appendable a

15+(++) : appendable -> appendable -> appendable

16+(++) = Native.List.append

1517

1618-- Extract the first element of a list. List must be non-empty.

1719-- `(head [1,2,3] == 1)`

1820head : [a] -> a

21+head = Native.List.head

1922

2023-- Extract the elements after the head of the list. List must be non-empty.

2124-- `(tail [1,2,3] == [2,3])`

2225tail : [a] -> [a]

26+tail = Native.List.tail

2327

2428-- Extract the last element of a list. List must be non-empty.

2529-- `(last [1,2,3] == 3)`

2630last : [a] -> a

31+last = Native.List.last

2732

2833-- Check if a list is empty `(isEmpty [] == True)`

2934isEmpty : [a] -> Bool

@@ -33,77 +38,92 @@ isEmpty xs =

3338 _ -> False

3439

3540-- Apply a function to every element of a list: `(map sqrt [1,4,9] == [1,2,3])`

36−map : (a -> b) -> [a] -> [b]

41+map : (a -> b) -> [a] -> [b]

42+map = Native.List.map

3743

3844-- Reduce a list from the left: `(foldl (::) [] "gateman" == "nametag")`

39−foldl : (a -> b -> b) -> b -> [a] -> b

45+foldl : (a -> b -> b) -> b -> [a] -> b

46+foldl = Native.List.foldl

4047

4148-- Reduce a list from the right: `(foldr (+) 0 [1,2,3] == 6)`

42−foldr : (a -> b -> b) -> b -> [a] -> b

49+foldr : (a -> b -> b) -> b -> [a] -> b

50+foldr = Native.List.foldr

4351

4452-- Reduce a list from the left without a base case. List must be non-empty.

4553foldl1 : (a -> a -> a) -> [a] -> a

54+foldl1 = Native.List.foldl1

4655

4756-- Reduce a list from the right without a base case. List must be non-empty.

4857foldr1 : (a -> a -> a) -> [a] -> a

58+foldr1 = Native.List.foldr1

4959

5060-- Reduce a list from the left, building up all of the intermediate results into a list.

5161--

5262-- scanl (+) 0 [1,2,3,4] == [0,1,3,6,10]

53−scanl : (a -> b -> b) -> b -> [a] -> [b]

63+scanl : (a -> b -> b) -> b -> [a] -> [b]

64+scanl = Native.List.scanl

5465

5566-- Same as scanl but it doesn't require a base case. List must be non-empty.

5667--

5768-- scanl1 (+) [1,2,3,4] == [1,3,6,10]

5869scanl1 : (a -> a -> a) -> [a] -> [a]

70+scanl1 = Native.List.scanl1

5971

6072-- Filter out elements which do not satisfy the predicate: `(filter isLower "AaBbCc" == "abc")`

61−filter : (a -> Bool) -> [a] -> [a]

73+filter : (a -> Bool) -> [a] -> [a]

74+filter = Native.List.filter

6275

6376-- Determine the length of a list: `(length "innumerable" == 11)`

64−length : [a] -> Int

77+length : [a] -> Int

78+length = Native.List.length

6579

6680-- Reverse a list. `(reverse [1..4] == [4,3,2,1])`

6781reverse : [a] -> [a]

82+reverse = Native.List.reverse

6883

6984-- Check to see if all elements satisfy the predicate.

7085all : (a -> Bool) -> [a] -> Bool

86+all = Native.List.all

7187

7288-- Check to see if any elements satisfy the predicate.

7389any : (a -> Bool) -> [a] -> Bool

90+any = Native.List.any

7491

7592-- Check to see if all elements are True.

7693and : [Bool] -> Bool

94+and = Native.List.and

7795

7896-- Check to see if any elements are True.

79−or : [Bool] -> Bool

97+or : [Bool] -> Bool

98+or = Native.List.or

8099

81100-- Concatenate a list of appendable things:

82101--

83102-- concat ["tree","house"] == "treehouse"

84−concat : [Appendable a] -> Appendable a

103+concat : [appendable] -> appendable

104+concat = Native.List.concat

85105

86106-- Map a given function onto a list and flatten the resulting lists.

87107--

88108-- concatMap f xs == concat (map f xs)

89−concatMap : (a -> Appendable b) -> [a] -> Appendable b

90−concatMap f = L.concat . L.map f

109+concatMap : (a -> appendable) -> [a] -> appendable

110+concatMap f list = concat (map f list)

91111

92112-- Get the sum of the list elements. `(sum [1..4] == 10)`

93−sum : [Number a] -> Number a

94−sum = L.foldl (+) 0

113+sum : [number] -> number

114+sum = foldl (+) 0

95115

96116-- Get the product of the list elements. `(product [1..4] == 24)`

97−product : [Number a] -> Number a

98−product = L.foldl (*) 1

117+product : [number] -> number

118+product = foldl (*) 1

99119

100−-- Find the highest number in a non-empty list.

101−maximum : [Number a] -> Number a

102−maximum = L.foldl1 max

120+-- Find the maximum element in a non-empty list: `maximum [1,4,2] == 4`

121+maximum : [comparable] -> comparable

122+maximum = foldl1 max

103123

104−-- Find the lowest number in a non-empty list.

105−minimum : [Number a] -> Number a

106−minimum = L.foldl1 min

124+-- Find the minimum element in a non-empty list: `minimum [3,2,1] == 1`

125+minimum : [comparable] -> comparable

126+minimum = foldl1 min

107127

108128-- Split a list based on the predicate.

109129partition : (a -> Bool) -> [a] -> ([a],[a])

@@ -119,12 +139,14 @@ partition pred lst =

119139-- zip [1,2,3] [6,7] == [(1,6),(2,7)]

120140-- zip == zipWith (,)

121141zip : [a] -> [b] -> [(a,b)]

142+zip = Native.List.zip

122143

123144-- Combine two lists, combining them with the given function.

124145-- If one list is longer, the extra elements are dropped.

125146--

126147-- zipWith (+) [1,2,3] [1,2,3,4] == [2,4,6]

127148zipWith : (a -> b -> c) -> [a] -> [b] -> [c]

149+zipWith = Native.List.zipWith

128150

129151-- Decompose a list of tuples.

130152unzip : [(a,b)] -> ([a],[b])

@@ -137,12 +159,14 @@ unzip pairs =

137159--

138160-- split "," "hello,there,friend" == ["hello", "there", "friend"]

139161split : [a] -> [a] -> [[a]]

162+split = Native.List.split

140163

141164-- Places the given value between all of the lists in the second argument

142165-- and concatenates the result.

143166--

144167-- join "a" ["H","w","ii","n"] == "Hawaiian"

145−join : Appendable a -> [Appendable a] -> Appendable a

168+join : appendable -> [appendable] -> appendable

169+join = Native.List.join

146170

147171-- Places the given value between all members of the given list.

148172--

@@ -156,7 +180,8 @@ intersperse sep xs =

156180

157181-- Take the first n members of a list: `(take 2 [1,2,3,4] == [1,2])`

158182take : Int -> [a] -> [a]

183+take = Native.List.take

159184

160185-- Drop the first n members of a list: `(drop 2 [1,2,3,4] == [3,4])`

161186drop : Int -> [a] -> [a]

162−

187+drop = Native.List.drop

libraries/Matrix2D.elm+11−5

@@ -1,13 +1,16 @@

11

22module Matrix2D where

33

4−import Native.Matrix2D as M

4+import Native.Matrix2D

5+

6+data Matrix2D = Matrix2D

57

68-- Create an identity matrix.

79--

810-- / 1 0 \\

911-- \\ 0 1 /

10−identity : Matrix2D

12+identity : Matrix2D

13+identity = Native.Matrix2D.identity

1114

1215-- Creates an arbitrary matrix. This lets you create scales, shears, reflections,

1316-- translations, or any other 2D transform.

@@ -18,14 +21,16 @@ identity : Matrix2D

1821-- \\ c d /

1922--

2023-- And `dx` and `dy` are the translation values.

21−matrix : Float -> Float -> Float -> Float -> Float -> Float -> Matrix2D

24+matrix : Float -> Float -> Float -> Float -> Float -> Float -> Matrix2D

25+matrix = Native.Matrix2D.matrix

2226

2327-- Creates a [rotation matrix](http://en.wikipedia.org/wiki/Rotation_matrix).

2428-- Given an angle t, it creates a counterclockwise rotation matrix:

2529--

2630-- / cos t -sin t \\

2731-- \\ sin t cos t /

28−rotation : Float -> Matrix2D

32+rotation : Float -> Matrix2D

33+rotation = Native.Matrix2D.rotation

2934

3035-- Multiplies two matrices together:

3136--

@@ -33,4 +38,5 @@ rotation : Float -> Matrix2D

3338--

3439-- / a11 a12 \\ . / b11 b12 \\

3540-- \\ a21 a22 / \\ b21 b22 /

36−multiply : Matrix2D -> Matrix2D -> Matrix2D

41+multiply : Matrix2D -> Matrix2D -> Matrix2D

42+multiply = Native.Matrix2D.multiply

libraries/Maybe.elm+3−2

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

11

22module Maybe where

33

4−import List as List

4+import Basics (not, (.))

5+import List (foldr)

56

67-- The Maybe datatype. Useful when a computation may or may not

78-- result in a value (e.g. logarithm is defined only for positive numbers).

@@ -30,4 +31,4 @@ cons mx xs = maybe xs (\x -> x :: xs) mx

3031

3132-- Filters out Nothings and extracts the remaining values.

3233justs : [Maybe a] -> [a]

33−justs = List.foldr cons []

34+justs = foldr cons []

libraries/Mouse.elm+8−1

@@ -1,24 +1,31 @@

11

22module Mouse where

33

4−import Native.Mouse as M

4+import Signal (Signal)

5+import Native.Mouse

56

67-- The current mouse position.

78position : Signal (Int,Int)

9+position = Native.Mouse.position

810

911-- The current x-coordinate of the mouse.

1012x : Signal Int

13+x = Native.Mouse.x

1114

1215-- The current y-coordinate of the mouse.

1316y : Signal Int

17+y = Native.Mouse.y

1418

1519-- The current state of the left mouse-button.

1620-- True when the button is down, and false otherwise.

1721isDown : Signal Bool

22+isDown = Native.Mouse.isDown

1823

1924-- True immediately after the left mouse-button has been clicked,

2025-- and false otherwise.

2126isClicked : Signal Bool

27+isClicked = Native.Mouse.isClicked

2228

2329-- Always equal to unit. Event triggers on every mouse click.

2430clicks : Signal ()

31+clicks = Native.Mouse.clicks

libraries/Native/Basics.jsnew file+108

@@ -0,0 +1,108 @@

1+

2+Elm.Native.Basics = function(elm) {

3+ 'use strict';

4+ if (elm.Native.Basics) return elm.Native.Basics;

5+

6+ var JS = Elm.Native.JavaScript(elm);

7+ // var Maybe = Elm.Maybe(elm);

8+ var Utils = Elm.Native.Utils(elm);

9+ //var Char = Elm.Char(elm);

10+

11+ function div(a,b) { return (a/b)|0; }

12+ function rem(a,b) { return a % b; }

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

23+ function truncate(n) { return n|0; }

24+

25+ function curry(f,a,b) { return f(Utils.Tuple2(a,b)); }

26+ function uncurry(f,v) { return A2(f,v._0,v._1); }

27+ function fst(t) { return t._0; }

28+ function snd(t) { return t._1; }

29+/*

30+ function readInt(str) {

31+ var s = JS.fromString(str);

32+ var len = s.length;

33+ if (len === 0) { return Maybe.Nothing; }

34+ var start = 0;

35+ if (s[0] == '-') {

36+ if (len === 1) { return Maybe.Nothing; }

37+ start = 1;

38+ }

39+ for (var i = start; i < len; ++i) {

40+ if (!Char.isDigit(s[i])) { return Maybe.Nothing; }

41+ }

42+ return Maybe.Just(parseInt(s, 10));

43+ }

44+

45+ function readFloat(str) {

46+ var s = JS.fromString(str);

47+ var len = s.length;

48+ if (len === 0) { return Maybe.Nothing; }

49+ var start = 0;

50+ if (s[0] == '-') {

51+ if (len === 1) { return Maybe.Nothing; }

52+ start = 1;

53+ }

54+ var dotCount = 0;

55+ for (var i = start; i < len; ++i) {

56+ if (Char.isDigit(s[i])) { continue; }

57+ if (s[i] === '.') {

58+ dotCount += 1;

59+ if (dotCount <= 1) { continue; }

60+ }

61+ return Maybe.Nothing;

62+ }

63+ return Maybe.Just(parseFloat(s));

64+ }

65+*/

66+ var basics = {

67+ div:F2(div),

68+ rem:F2(rem),

69+ mod:mod,

70+

71+ pi:Math.PI,

72+ e:Math.e,

73+ cos:Math.cos,

74+ sin:Math.sin,

75+ tan:Math.tan,

76+ acos:Math.acos,

77+ asin:Math.asin,

78+ atan:Math.atan,

79+ atan2:F2(Math.atan2),

80+

81+ sqrt:Math.sqrt,

82+ abs:abs,

83+ logBase:F2(logBase),

84+ min:F2(min),

85+ max:F2(max),

86+ clamp:F3(clamp),

87+ compare:Utils.compare,

88+

89+ xor:F2(xor),

90+ not:not,

91+

92+ truncate:truncate,

93+ ceiling:Math.ceil,

94+ floor:Math.floor,

95+ round:Math.round,

96+ toFloat:function(x) { return x; },

97+

98+ //readInt:readInt,

99+ //readFloat:readFloat,

100+

101+ curry:F3(curry),

102+ uncurry:F2(uncurry),

103+ fst:fst,

104+ snd:snd

105+ };

106+

107+ return elm.Native.Basics = basics;

108+};

libraries/Native/Error.js+16−6

@@ -6,14 +6,24 @@ Elm.Native.Error = function(elm) {

66

77 var fromString = Elm.Native.JavaScript(elm).fromString;

88

9− function Case(span) {

10− var msg = 'Non-exhaustive pattern match in case expression'

11− throw new Error(msg + " (" + span + ")")

9+ function indent(lines) {

10+ var msg = '';

11+ for (var i = 0; i < lines.length; ++i) {

12+ msg += '<br/>    ' + lines[i];

13+ }

14+ return msg;

1215 }

1316

14− function If(span) {

15− var msg = 'Non-exhaustive pattern match in multi-way-if expression'

16− throw new Error(msg + " (" + span + ")")

17+ function Case(moduleName, span) {

18+ var msg = indent(['Non-exhaustive pattern match in case-expression.',

19+ 'Make sure your patterns cover every case!']);

20+ throw new Error('Runtime error in module ' + moduleName + ' (' + span + '):' + msg);

21+ }

22+

23+ function If(moduleName, span) {

24+ var msg = indent(['Non-exhaustive pattern match in multi-way-if expression.',

25+ 'It is best to use \'otherwise\' as the last branch of multi-way-if.']);

26+ throw new Error('Runtime error in module ' + moduleName + ' (' + span + '):' + msg);

1727 }

1828

1929 function raise(str) { throw new Error(fromString(str)); }

libraries/Native/Graphics/Input.js+139−116

@@ -12,7 +12,8 @@ Elm.Native.Graphics.Input = function(elm) {

1212 var Signal = Elm.Signal(elm);

1313 var newElement = Elm.Graphics.Element(elm).newElement;

1414 var JS = Elm.Native.JavaScript(elm);

15− var Tuple2 = Elm.Native.Utils(elm).Tuple2;

15+ var Utils = Elm.Native.Utils(elm);

16+ var Tuple2 = Utils.Tuple2;

1617

1718 function dropDown(values) {

1819 var entries = JS.fromList(values);

@@ -56,29 +57,29 @@ Elm.Native.Graphics.Input = function(elm) {

5657 var events = Signal.constant(defaultValue);

5758

5859 function render(model) {

59− var b = newNode('button');

60− b.style.display = 'block';

61− b.elmEvent = model.event;

62− function click() { elm.notify(events.id, b.elmEvent); }

63− b.addEventListener('click', click);

64− b.innerHTML = model.text;

65− return b;

60+ var b = newNode('button');

61+ b.style.display = 'block';

62+ b.elmEvent = model.event;

63+ function click() { elm.notify(events.id, b.elmEvent); }

64+ b.addEventListener('click', click);

65+ b.innerHTML = model.text;

66+ return b;

6667 }

6768

6869 function update(node, oldModel, newModel) {

69− node.elmEvent = newModel.event;

70− var txt = newModel.text;

71− if (oldModel.text !== txt) node.innerHTML = txt;

70+ node.elmEvent = newModel.event;

71+ var txt = newModel.text;

72+ if (oldModel.text !== txt) node.innerHTML = txt;

7273 }

7374

7475 function button(evnt, txt) {

75− return A3(newElement, 100, 40, {

76+ return A3(newElement, 100, 40, {

7677 ctor: 'Custom',

77− type: 'Button',

78− render: render,

79− update: update,

80− model: { event:evnt, text:JS.fromString(txt) }

81− });

78+ type: 'Button',

79+ render: render,

80+ update: update,

81+ model: { event:evnt, text:JS.fromString(txt) }

82+ });

8283 }

8384

8485 return { _:{}, button:F2(button), events:events };

@@ -88,94 +89,115 @@ Elm.Native.Graphics.Input = function(elm) {

8889 var events = Signal.constant(defaultValue);

8990

9091 function render(model) {

91− var btn = newNode('div');

92− btn.elmEvent = model.event;

92+ var btn = newNode('div');

93+ btn.elmEvent = model.event;

9394

94− btn.elmUp = Render.render(model.up);

95− btn.elmHover = Render.render(model.hover);

96− btn.elmDown = Render.render(model.down);

95+ btn.elmUp = Render.render(model.up);

96+ btn.elmHover = Render.render(model.hover);

97+ btn.elmDown = Render.render(model.down);

9798

98− function replace(node) {

99+ function replace(node) {

99100 if (node !== btn.firstChild) btn.replaceChild(node, btn.firstChild);

100− }

101− var overCount = 0;

102− function over(e) {

103− if (overCount++ > 0) return;

104− replace(btn.elmHover);

105− }

106− function out(e) {

107− if (btn.contains(e.toElement || e.relatedTarget)) return;

108− overCount = 0;

109− replace(btn.elmUp);

110− }

111− function up() {

112− replace(btn.elmHover);

113− elm.notify(events.id, btn.elmEvent);

114− }

115− function down() { replace(btn.elmDown); }

116− btn.addEventListener('mouseover', over);

117− btn.addEventListener('mouseout' , out);

118− btn.addEventListener('mousedown', down);

119− btn.addEventListener('mouseup' , up);

120−

121− btn.appendChild(btn.elmUp);

122− return btn;

101+ }

102+ var overCount = 0;

103+ function over(e) {

104+ if (overCount++ > 0) return;

105+ replace(btn.elmHover);

106+ }

107+ function out(e) {

108+ if (btn.contains(e.toElement || e.relatedTarget)) return;

109+ overCount = 0;

110+ replace(btn.elmUp);

111+ }

112+ function up() {

113+ replace(btn.elmHover);

114+ elm.notify(events.id, btn.elmEvent);

115+ }

116+ function down() { replace(btn.elmDown); }

117+ btn.addEventListener('mouseover', over);

118+ btn.addEventListener('mouseout' , out);

119+ btn.addEventListener('mousedown', down);

120+ btn.addEventListener('mouseup' , up);

121+

122+ btn.appendChild(btn.elmUp);

123+

124+ var clicker = newNode('div');

125+ clicker.style.width = btn.elmUp.style.width;

126+ clicker.style.height = btn.elmUp.style.height;

127+ clicker.style.position = 'absolute';

128+ clicker.style.top = 0;

129+ btn.appendChild(clicker);

130+

131+ return btn;

123132 }

124133

125134 function update(node, oldModel, newModel) {

126− node.elmEvent = newModel.event;

127− Render.update(node.elmUp, oldModel.up, newModel.up)

128− Render.update(node.elmHover, oldModel.hover, newModel.hover)

129− Render.update(node.elmDown, oldModel.down, newModel.down)

135+ node.elmEvent = newModel.event;

136+ Render.update(node.elmUp, oldModel.up, newModel.up)

137+ Render.update(node.elmHover, oldModel.hover, newModel.hover)

138+ Render.update(node.elmDown, oldModel.down, newModel.down)

130139 }

131140

132141 function button(evnt, up, hover, down) {

133− return A3(newElement,

134− Math.max(up.props.width, hover.props.width, down.props.width),

135− Math.max(up.props.height, hover.props.height, down.props.height),

142+ return A3(newElement,

143+ Math.max(up.props.width, hover.props.width, down.props.width),

144+ Math.max(up.props.height, hover.props.height, down.props.height),

136145 { ctor: 'Custom',

137− type: 'CustomButton',

138− render: render,

139− update: update,

140− model: { event:evnt, up:up, hover:hover, down:down }

141− });

146+ type: 'CustomButton',

147+ render: render,

148+ update: update,

149+ model: { event:evnt, up:up, hover:hover, down:down }

150+ });

142151 }

143152

144153 return { _:{}, customButton:F4(button), events:events };

145154 }

146155

147156

157+ function hoverables(defaultValue) {

158+ var events = Signal.constant(defaultValue);

159+ function hoverable(handler, elem) {

160+ function onHover(bool) {

161+ elm.notify(events.id, handler(bool));

162+ }

163+ var props = Utils.replace([['hover',onHover]], elem.props);

164+ return { props:props, element:elem.element };

165+ }

166+ return { _:{}, hoverable:F2(hoverable), events:events };

167+ }

168+

169+

148170 function checkboxes(defaultValue) {

149171 var events = Signal.constant(defaultValue);

150172

151173 function render(model) {

152− var b = newNode('input');

153− b.type = 'checkbox';

154− b.checked = model.checked;

155− b.style.display = 'block';

156− b.elmHandler = model.handler;

157− function change() { elm.notify(events.id, b.elmHandler(b.checked)); }

158− b.addEventListener('change', change);

159− return b;

174+ var b = newNode('input');

175+ b.type = 'checkbox';

176+ b.checked = model.checked;

177+ b.style.display = 'block';

178+ b.elmHandler = model.handler;

179+ function change() { elm.notify(events.id, b.elmHandler(b.checked)); }

180+ b.addEventListener('change', change);

181+ return b;

160182 }

161183

162184 function update(node, oldModel, newModel) {

163− node.elmHandler = newModel.handler;

164− node.checked = newModel.checked;

165− return true;

185+ node.elmHandler = newModel.handler;

186+ node.checked = newModel.checked;

187+ return true;

166188 }

167189

168190 function box(handler, checked) {

169− return A3(newElement, 13, 13, {

191+ return A3(newElement, 13, 13, {

170192 ctor: 'Custom',

171− type: 'CheckBox',

172− render: render,

173− update: update,

174− model: { checked:checked, handler:handler }

175− });

193+ type: 'CheckBox',

194+ render: render,

195+ update: update,

196+ model: { checked:checked, handler:handler }

197+ });

176198 }

177199

178− return { _:{}, box:F2(box), events:events };

200+ return { _:{}, checkbox:F2(box), events:events };

179201 }

180202

181203 function setRange(node, start, end, dir) {

@@ -192,49 +214,49 @@ Elm.Native.Graphics.Input = function(elm) {

192214 var state = null;

193215

194216 function render(model) {

195− var field = newNode('input');

196− field.elmHandler = model.handler;

197−

198− field.id = 'test';

199− field.type = type;

200− field.placeholder = JS.fromString(model.placeHolder);

201− field.value = JS.fromString(model.state.string);

202− setRange(field, model.state.selectionStart, model.state.selectionEnd, 'forward');

203− field.style.border = 'none';

217+ var field = newNode('input');

218+ field.elmHandler = model.handler;

219+

220+ field.id = 'test';

221+ field.type = type;

222+ field.placeholder = JS.fromString(model.placeHolder);

223+ field.value = JS.fromString(model.state.string);

224+ setRange(field, model.state.selectionStart, model.state.selectionEnd, 'forward');

225+ field.style.border = 'none';

204226 state = model.state;

205227

206− function update() {

207− var start = field.selectionStart,

208− end = field.selectionEnd;

209− if (field.selectionDirection === 'backward') {

210− start = end;

211− end = field.selectionStart;

212− }

228+ function update() {

229+ var start = field.selectionStart,

230+ end = field.selectionEnd;

231+ if (field.selectionDirection === 'backward') {

232+ start = end;

233+ end = field.selectionStart;

234+ }

213235 state = { _:{},

214236 string:JS.toString(field.value),

215237 selectionStart:start,

216238 selectionEnd:end };

217− elm.notify(events.id, field.elmHandler(state));

218− }

219− function mousedown() {

220− update();

221− elm.node.addEventListener('mouseup', mouseup);

222− }

223− function mouseup() {

224− update();

225− elm.node.removeEventListener('mouseup', mouseup)

226− }

227− field.addEventListener('keyup', update);

228− field.addEventListener('mousedown', mousedown);

229−

230− return field;

239+ elm.notify(events.id, field.elmHandler(state));

240+ }

241+ function mousedown() {

242+ update();

243+ elm.node.addEventListener('mouseup', mouseup);

244+ }

245+ function mouseup() {

246+ update();

247+ elm.node.removeEventListener('mouseup', mouseup)

248+ }

249+ field.addEventListener('keyup', update);

250+ field.addEventListener('mousedown', mousedown);

251+

252+ return field;

231253 }

232254

233255 function update(node, oldModel, newModel) {

234− node.elmHandler = newModel.handler;

256+ node.elmHandler = newModel.handler;

235257 if (state === newModel.state) return;

236258 var newStr = JS.fromString(newModel.state.string);

237− if (node.value !== newStr) node.value = newStr;

259+ if (node.value !== newStr) node.value = newStr;

238260

239261 var start = newModel.state.selectionStart;

240262 var end = newModel.state.selectionEnd;

@@ -253,15 +275,15 @@ Elm.Native.Graphics.Input = function(elm) {

253275 }

254276

255277 function field(handler, placeHolder, state) {

256− return A3(newElement, 200, 30,

278+ return A3(newElement, 200, 30,

257279 { ctor: 'Custom',

258− type: type + 'Input',

259− render: render,

260− update: update,

261− model: { handler:handler,

262− placeHolder:placeHolder,

263− state:state }

264− });

280+ type: type + 'Input',

281+ render: render,

282+ update: update,

283+ model: { handler:handler,

284+ placeHolder:placeHolder,

285+ state:state }

286+ });

265287 }

266288

267289 return { _:{}, field:F3(field), events:events };

@@ -271,6 +293,7 @@ Elm.Native.Graphics.Input = function(elm) {

271293 return elm.Native.Graphics.Input = {

272294 buttons:buttons,

273295 customButtons:customButtons,

296+ hoverables:hoverables,

274297 checkboxes:checkboxes,

275298 fields:mkTextPool('text'),

276299 emails:mkTextPool('email'),

libraries/Native/JavaScript.js+48−45

@@ -9,57 +9,60 @@ Elm.Native.JavaScript = function(elm) {

99 var Render = ElmRuntime.use(ElmRuntime.Render.Element);

1010

1111 function fromJS(v) {

12− var type = typeof v;

13− if (type === 'number' ) return v;

14− if (type === 'boolean') return v;

15− if (type === 'string' ) return List.fromArray(v);

16− if (v instanceof Array) {

17− var arr = [];

18− var len = v.length;

19− for (var i = 0; i < len; ++i) {

20− var x = fromJS(v[i]);

21− if (x !== null) arr.push(x);

12+ var type = typeof v;

13+ if (type === 'number' ) return v;

14+ if (type === 'boolean') return v;

15+ if (type === 'string' ) return List.fromArray(v);

16+ if (v instanceof Array) {

17+ var arr = [];

18+ var len = v.length;

19+ for (var i = 0; i < len; ++i) {

20+ var x = fromJS(v[i]);

21+ if (x !== null) arr.push(x);

22+ }

23+ return List.fromArray(arr);

2224 }

23− return List.fromArray(arr);

24− }

25− if (type === 'object') {

26− var rec = { _:{} };

27− for (var f in v) {

28− var x = fromJS(v[f]);

29− if (x !== null) rec[f] = x;

25+ if (type === 'object') {

26+ var rec = { _:{} };

27+ for (var f in v) {

28+ var x = fromJS(v[f]);

29+ if (x !== null) rec[f] = x;

30+ }

31+ return rec;

3032 }

31− return rec;

32− }

33− return null;

33+ return null;

3434 }

3535

3636 function toJS(v) {

37− var type = typeof v;

38− if (type === 'number' || type === 'boolean') return v;

39− if (type === 'object' && '_' in v) {

40− var obj = {};

41− for (var k in v) {

42− var x = v[k];

43− if (x !== null) obj[k] = x;

44− }

45− return obj;

46− }

47− if (type === 'object' && (v.ctor === 'Cons' || v.ctor === 'Nil')) {

48− var array = List.toArray(v);

49− for (var i = array.length; i--; ) {

50− array[i] = toJS(array[i]);

51− }

52− if (typeof array[0] === 'string') array.join('');

53− return array;

54− }

55− return null;

37+ var type = typeof v;

38+ if (type === 'number' || type === 'boolean') return v;

39+ if (type === 'object' && '_' in v) {

40+ var obj = {};

41+ for (var k in v) {

42+ var x = toJS(v[k]);

43+ if (x !== null) obj[k] = x;

44+ }

45+ return obj;

46+ }

47+ if (type === 'object' && (v.ctor === '::' || v.ctor === '[]')) {

48+ var array = List.toArray(v);

49+ if (typeof array[0] === 'string') {

50+ array = array.join('');

51+ } else {

52+ for (var i = array.length; i--; ) {

53+ array[i] = toJS(array[i]);

54+ }

55+ }

56+ return array;

57+ }

58+ return null;

5659 }

57−

60+

5861 function fromRecord(r) {

59− if (typeof r === 'object' && '_' in r) {

60− return toJS(r);

61− }

62− throw new Error("'fromRecord' must be called on a record.");

62+ if (typeof r === 'object' && '_' in r) {

63+ return toJS(r);

64+ }

65+ throw new Error("'fromRecord' must be called on a record.");

6366 }

6467

6568 function id(n) { return n; }

@@ -99,4 +102,4 @@ Elm.Native.JavaScript = function(elm) {

99102 fromRecord : fromRecord

100103 };

101104

102−};

105+};

libraries/Native/List.js+34−28

@@ -9,7 +9,7 @@ Elm.Native.List = function(elm) {

99 var Utils = Elm.Native.Utils(elm);

1010

1111 // TODO: Improve Nil handling

12− // We can change places like: if (xs.ctor === 'Nil') ... to if (xs === Nil) ...

12+ // We can change places like: if (xs.ctor === '[]') ... to if (xs === Nil) ...

1313 // but only if we're confident Nil can only be defined once.

1414 // Currently (27Mar2013) each module can have different instantiations, so multiple Nil objects can exist

1515 // (and if they're used interchangeably then direct object comparison fails where ctor doesn't).

@@ -17,11 +17,11 @@ Elm.Native.List = function(elm) {

1717 // The performance overhead of the .ctor calls is 5-10% according to jsperf (depending on fn + list size)

1818 // (on firefox 19)

1919

20− var Nil = { ctor:'Nil' };

20+ var Nil = { ctor:'[]' };

2121

2222 // using freeze for every cons would be nice but is a huge (9x on firefox 19)

2323 // performance penalty

24− function Cons(hd,tl) { return { ctor:"Cons", _0:hd, _1:tl }; }

24+ function Cons(hd,tl) { return { ctor:"::", _0:hd, _1:tl }; }

2525

2626 function throwError(f) {

2727 throw new Error("Function '" + f + "' expects a non-empty list!");

@@ -29,7 +29,7 @@ Elm.Native.List = function(elm) {

2929

3030 function toArray(xs) {

3131 var out = [];

32− while (xs.ctor !== 'Nil') {

32+ while (xs.ctor !== '[]') {

3333 out.push(xs._0);

3434 xs = xs._1;

3535 }

@@ -54,11 +54,11 @@ Elm.Native.List = function(elm) {

5454

5555 function append(xs,ys) {

5656 if (typeof xs === "string") { return xs.concat(ys); }

57− if (xs.ctor === 'Nil') { return ys; }

57+ if (xs.ctor === '[]') { return ys; }

5858 var root = Cons(xs._0, Nil);

5959 var curr = root;

6060 xs = xs._1;

61− while (xs.ctor !== 'Nil') {

61+ while (xs.ctor !== '[]') {

6262 curr._1 = Cons(xs._0, Nil);

6363 xs = xs._1;

6464 curr = curr._1;

@@ -67,13 +67,13 @@ Elm.Native.List = function(elm) {

6767 return root;

6868 }

6969

70− function head(v) { return v.ctor === 'Nil' ? throwError('head') : v._0; }

71− function tail(v) { return v.ctor === 'Nil' ? throwError('tail') : v._1; }

70+ function head(v) { return v.ctor === '[]' ? throwError('head') : v._0; }

71+ function tail(v) { return v.ctor === '[]' ? throwError('tail') : v._1; }

7272

7373 function last(xs) {

74− if (xs.ctor === 'Nil') { throwError('last'); }

74+ if (xs.ctor === '[]') { throwError('last'); }

7575 var out = xs._0;

76− while (xs.ctor !== 'Nil') {

76+ while (xs.ctor !== '[]') {

7777 out = xs._0;

7878 xs = xs._1;

7979 }

@@ -82,7 +82,7 @@ Elm.Native.List = function(elm) {

8282

8383 function map(f, xs) {

8484 var arr = [];

85− while (xs.ctor !== 'Nil') {

85+ while (xs.ctor !== '[]') {

8686 arr.push(f(xs._0));

8787 xs = xs._1;

8888 }

@@ -90,10 +90,10 @@ Elm.Native.List = function(elm) {

9090 }

9191

9292 // f defined similarly for both foldl and foldr (NB: different from Haskell)

93− // ie, foldl :: (a -> b -> b) -> b -> [a] -> b

93+ // ie, foldl : (a -> b -> b) -> b -> [a] -> b

9494 function foldl(f, b, xs) {

9595 var acc = b;

96− while (xs.ctor !== 'Nil') {

96+ while (xs.ctor !== '[]') {

9797 acc = A2(f, xs._0, acc);

9898 xs = xs._1;

9999 }

@@ -110,11 +110,11 @@ Elm.Native.List = function(elm) {

110110 }

111111

112112 function foldl1(f, xs) {

113− return xs.ctor === 'Nil' ? throwError('foldl1') : foldl(f, xs._0, xs._1);

113+ return xs.ctor === '[]' ? throwError('foldl1') : foldl(f, xs._0, xs._1);

114114 }

115115

116116 function foldr1(f, xs) {

117− if (xs.ctor === 'Nil') { throwError('foldr1'); }

117+ if (xs.ctor === '[]') { throwError('foldr1'); }

118118 var arr = toArray(xs);

119119 var acc = arr.pop();

120120 for (var i = arr.length; i--; ) {

@@ -134,12 +134,12 @@ Elm.Native.List = function(elm) {

134134 }

135135

136136 function scanl1(f, xs) {

137− return xs.ctor === 'Nil' ? throwError('scanl1') : scanl(f, xs._0, xs._1);

137+ return xs.ctor === '[]' ? throwError('scanl1') : scanl(f, xs._0, xs._1);

138138 }

139139

140140 function filter(pred, xs) {

141141 var arr = [];

142− while (xs.ctor !== 'Nil') {

142+ while (xs.ctor !== '[]') {

143143 if (pred(xs._0)) { arr.push(xs._0); }

144144 xs = xs._1;

145145 }

@@ -148,7 +148,7 @@ Elm.Native.List = function(elm) {

148148

149149 function length(xs) {

150150 var out = 0;

151− while (xs.ctor !== 'Nil') {

151+ while (xs.ctor !== '[]') {

152152 out += 1;

153153 xs = xs._1;

154154 }

@@ -156,7 +156,7 @@ Elm.Native.List = function(elm) {

156156 }

157157

158158 function member(x, xs) {

159− while (xs.ctor !== 'Nil') {

159+ while (xs.ctor !== '[]') {

160160 if (Utils.eq(x,xs._0)) return true;

161161 xs = xs._1;

162162 }

@@ -166,7 +166,7 @@ Elm.Native.List = function(elm) {

166166 function reverse(xs) { return fromArray(toArray(xs).reverse()); }

167167

168168 function concat(xss) {

169− if (xss.ctor === 'Nil') return xss;

169+ if (xss.ctor === '[]') return xss;

170170 var arr = toArray(xss);

171171 var xs = arr[arr.length-1];

172172 for (var i = arr.length-1; i--; ) {

@@ -176,7 +176,7 @@ Elm.Native.List = function(elm) {

176176 }

177177

178178 function all(pred, xs) {

179− while (xs.ctor !== 'Nil') {

179+ while (xs.ctor !== '[]') {

180180 if (!pred(xs._0)) return false;

181181 xs = xs._1;

182182 }

@@ -184,7 +184,7 @@ Elm.Native.List = function(elm) {

184184 }

185185

186186 function any(pred, xs) {

187− while (xs.ctor !== 'Nil') {

187+ while (xs.ctor !== '[]') {

188188 if (pred(xs._0)) return true;

189189 xs = xs._1;

190190 }

@@ -193,7 +193,7 @@ Elm.Native.List = function(elm) {

193193

194194 function zipWith(f, xs, ys) {

195195 var arr = [];

196− while (xs.ctor !== 'Nil' && ys.ctor !== 'Nil') {

196+ while (xs.ctor !== '[]' && ys.ctor !== '[]') {

197197 arr.push(A2(f, xs._0, ys._0));

198198 xs = xs._1;

199199 ys = ys._1;

@@ -203,7 +203,7 @@ Elm.Native.List = function(elm) {

203203

204204 function zip(xs, ys) {

205205 var arr = [];

206− while (xs.ctor !== 'Nil' && ys.ctor !== 'Nil') {

206+ while (xs.ctor !== '[]' && ys.ctor !== '[]') {

207207 arr.push(Utils.Tuple2(xs._0, ys._0));

208208 xs = xs._1;

209209 ys = ys._1;

@@ -219,9 +219,13 @@ Elm.Native.List = function(elm) {

219219 return fromArray(toArray(xs).sort(cmp));

220220 }

221221

222+ function nth(xs, n) {

223+ return toArray(xs)[n];

224+ }

225+

222226 function take(n, xs) {

223227 var arr = [];

224− while (xs.ctor !== 'Nil' && n > 0) {

228+ while (xs.ctor !== '[]' && n > 0) {

225229 arr.push(xs._0);

226230 xs = xs._1;

227231 --n;

@@ -230,7 +234,7 @@ Elm.Native.List = function(elm) {

230234 }

231235

232236 function drop(n, xs) {

233− while (xs.ctor !== 'Nil' && n > 0) {

237+ while (xs.ctor !== '[]' && n > 0) {

234238 xs = xs._1;

235239 --n;

236240 }

@@ -239,11 +243,11 @@ Elm.Native.List = function(elm) {

239243

240244 function join(sep, xss) {

241245 if (typeof sep === 'string') return toArray(xss).join(sep);

242− if (xss.ctor === 'Nil') return Nil;

246+ if (xss.ctor === '[]') return Nil;

243247 var s = toArray(sep);

244248 var out = toArray(xss._0);

245249 xss = xss._1;

246− while (xss.ctor !== 'Nil') {

250+ while (xss.ctor !== '[]') {

247251 out = out.concat(s, toArray(xss._0));

248252 xss = xss._1;

249253 }

@@ -308,6 +312,7 @@ Elm.Native.List = function(elm) {

308312 Elm.Native.List.values = {

309313 Nil:Nil,

310314 Cons:Cons,

315+ cons:F2(Cons),

311316 toArray:toArray,

312317 fromArray:fromArray,

313318 range:range,

@@ -336,6 +341,7 @@ Elm.Native.List = function(elm) {

336341 zipWith:F3(zipWith),

337342 zip:F2(zip),

338343 sort:sort,

344+ nth:F2(nth),

339345 take:F2(take),

340346 drop:F2(drop),

341347

libraries/Native/Prelude.js+2−74

@@ -3,31 +3,10 @@ Elm.Native.Prelude = function(elm) {

33 'use strict';

44 if (elm.Native.Prelude) return elm.Native.Prelude;

55

6− var JS = Elm.JavaScript(elm);

6+ var JS = Elm.Native.JavaScript(elm);

77 var Maybe = Elm.Maybe(elm);

8− var Utils = Elm.Native.Utils(elm);

98 var Char = Elm.Char(elm);

109

11− function div(a,b) { return (a/b)|0; }

12− function rem(a,b) { return a % b; }

13− 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 a < b ? a : b; }

17− function max(a,b) { return a > b ? a : b; }

18− function clamp(lo,hi,n) { return n < lo ? lo : n > hi ? hi : n; }

19− function xor(a,b) { return a !== b; }

20− function not(b) { return !b; }

21−

22− function truncate(n) { return n|0; }

23−

24− function id(n) { return n; }

25− function flip(f,a,b) { return A2(f,b,a); }

26− function curry(f,a,b) { return f(Utils.Tuple2(a,b)); }

27− function uncurry(f,v) { return A2(f,v._0,v._1); }

28− function fst(t) { return t._0; }

29− function snd(t) { return t._1; }

30−

3110 function readInt(str) {

3211 var s = JS.fromString(str);

3312 var len = s.length;

@@ -64,60 +43,9 @@ Elm.Native.Prelude = function(elm) {

6443 return Maybe.Just(parseFloat(s));

6544 }

6645

67− var prelude = {

68− div:F2(div),

69− rem:F2(rem),

70− mod:mod,

71−

72− pi:Math.PI,

73− e:Math.e,

74− cos:Math.cos,

75− sin:Math.sin,

76− tan:Math.tan,

77− acos:Math.acos,

78− asin:Math.asin,

79− atan:Math.atan,

80− atan2:F2(Math.atan2),

81−

82− sqrt:Math.sqrt,

83− abs:abs,

84− logBase:F2(logBase),

85− min:F2(min),

86− max:F2(max),

87− clamp:F3(clamp),

88− compare:Utils.compare,

89−

90− xor:F2(xor),

91− not:not,

92− otherwise:true,

93−

94− truncate:truncate,

95− ceiling:Math.ceil,

96− floor:Math.floor,

97− round:Math.round,

98− toFloat:id,

99−

46+ return elm.Native.Prelude = {

10047 readInt:readInt,

10148 readFloat:readFloat,

102−

103− id:id,

104− flip:F3(flip),

105− curry:F3(curry),

106− uncurry:F2(uncurry),

107− fst:fst,

108− snd:snd

10949 };

11050

111− function add(Module) {

112− var M = Module(elm);

113− for (var k in M) { prelude[k] = M[k]; }

114− }

115− add(Elm.Native.Show);

116− add(Elm.Signal);

117− add(Elm.List);

118− add(Elm.Maybe);

119− add(Elm.Time);

120− add(Elm.Graphics.Element);

121−

122− return elm.Native.Prelude = prelude;

12351};

libraries/Native/Show.js+8−7

@@ -37,14 +37,14 @@ Elm.Native.Show = function(elm) {

3737 if (output.length === 0) return "{}";

3838 return "{ " + output.join(", ") + " }";

3939 } else if (typeof v === "object" && 'ctor' in v) {

40− if (v.ctor.substring(0,5) === "Tuple") {

40+ if (v.ctor.substring(0,6) === "_Tuple") {

4141 var output = [];

4242 for (var k in v) {

4343 if (k === 'ctor') continue;

4444 output.push(toString(v[k]));

4545 }

4646 return "(" + output.join(",") + ")";

47− } else if (v.ctor === "Cons") {

47+ } else if (v.ctor === "::") {

4848 var isStr = typeof v._0 === "string",

4949 start = isStr ? '"' : "[",

5050 end = isStr ? '"' : "]",

@@ -52,18 +52,18 @@ Elm.Native.Show = function(elm) {

5252 f = !isStr ? toString : showChar;

5353 var output = start + f(v._0);

5454 v = v._1;

55− while (v.ctor === "Cons") {

55+ while (v.ctor === "::") {

5656 output += sep + f(v._0);

5757 v = v._1;

5858 }

5959 return output + end;

60− } else if (v.ctor === "Nil") {

60+ } else if (v.ctor === "[]") {

6161 return "[]";

6262 } else if (v.ctor === "RBNode" || v.ctor === "RBEmpty") {

6363 var cons = F3(function(k,v,acc){return NList.Cons(Tuple2(k,v),acc)});

6464 var list = A3(Dict.foldr, cons, NList.Nil, v);

6565 var name = "Dict";

66− if (list.ctor === "Cons" && list._0._1.ctor === "Tuple0") {

66+ if (list.ctor === "::" && list._0._1.ctor === "_Tuple0") {

6767 name = "Set";

6868 list = A2(List.map, function(x){return x._0}, list);

6969 }

@@ -73,13 +73,14 @@ Elm.Native.Show = function(elm) {

7373 for (var i in v) {

7474 if (i === 'ctor') continue;

7575 var str = toString(v[i]);

76− var parenless = str[0] === '{' || str.indexOf(' ') < 0;

76+ var parenless = str[0] === '{' || str[0] === '<' || str.indexOf(' ') < 0;

7777 output += ' ' + (parenless ? str : '(' + str + ')');

7878 }

7979 return v.ctor + output;

8080 }

8181 }

82− return v+"";

82+ if (typeof v === 'object' && 'recv' in v) return '<signal>';

83+ return "<internal structure>";

8384 };

8485 function show(v) { return NList.fromArray(toString(v)); }

8586

libraries/Native/Signal/Http.js+1−1

@@ -11,7 +11,7 @@ Elm.Native.Http = function(elm) {

1111

1212

1313 function registerReq(queue,responses) { return function(req) {

14− if (req.url.ctor !== 'Nil') { sendReq(queue,responses,req); }

14+ if (req.url.ctor !== '[]') { sendReq(queue,responses,req); }

1515 };

1616 }

1717

libraries/Native/Signal/Keyboard.js+2−2

@@ -26,7 +26,7 @@ Elm.Native.Keyboard = function(elm) {

2626 });

2727

2828 function keySignal(f) {

29− var signal = A2( Signal.lift, f, keysDown );

29+ var signal = Signal.dropRepeats(A2(Signal.lift, f, keysDown));

3030 keysDown.defaultNumberOfKids += 1;

3131 signal.defaultNumberOfKids = 0;

3232 return signal;

@@ -35,7 +35,7 @@ Elm.Native.Keyboard = function(elm) {

3535 function dir(up, down, left, right) {

3636 function f(ks) {

3737 var x = 0, y = 0;

38− while (ks.ctor == "Cons") {

38+ while (ks.ctor === "::") {

3939 switch (ks._0) {

4040 case left : --x; break;

4141 case right: ++x; break;

libraries/Native/Signal/Time.js+4−3

@@ -3,6 +3,7 @@ Elm.Native.Time = function(elm) {

33 'use strict';

44

55 var Signal = Elm.Signal(elm);

6+ var NS = Elm.Native.Signal(elm);

67 var Maybe = Elm.Maybe(elm);

78 var Utils = Elm.Native.Utils(elm);

89

@@ -42,7 +43,7 @@ Elm.Native.Time = function(elm) {

4243

4344 function since(t, s) {

4445 function cmp(a,b) { return !Utils.eq(a,b); }

45− var dcount = Signal.count(A2(Signal.delay, t, s));

46+ var dcount = Signal.count(A2(NS.delay, t, s));

4647 return A3( Signal.lift2, F2(cmp), Signal.count(s), dcount );

4748 }

4849 function read(s) {

@@ -53,8 +54,8 @@ Elm.Native.Time = function(elm) {

5354 fpsWhen : F2(fpsWhen),

5455 fps : function(t) { return fpsWhen(t, Signal.constant(true)); },

5556 every : function(t) { return everyWhen(t, Signal.constant(true)) },

56− delay : Signal.delay,

57− timestamp : Signal.timestamp,

57+ delay : NS.delay,

58+ timestamp : NS.timestamp,

5859 since : F2(since),

5960 toDate : function(t) { return new window.Date(t); },

6061 read : read

libraries/Native/Text.js+1−1

@@ -71,7 +71,7 @@ Elm.Native.Text = function(elm) {

7171 }

7272 function size(px, text) { return addStyle('font-size', px + 'px', text) }

7373 var header = addTag('h1');

74− function height(h, text) { return addStyle('font-size', h+'em', text) }

74+ function height(h, text) { return addStyle('font-size', h+'px', text) }

7575 function italic(text) { return addStyle('font-style', 'italic', text) }

7676 var bold = addTag('b');

7777

libraries/Native/Utils.js+12−10

@@ -19,16 +19,18 @@ Elm.Native.Utils = function(elm) {

1919 return x === y;

2020 }

2121

22− var EQ = 0, LT = 1, GT = 2, ord = ['EQ','LT','GT'];

23− function compare(x,y) { return { ctor: ord[cmp(x,y)] } }

22+ // code in Generate/JavaScript.hs depends on the particular

23+ // integer values assigned to LT, EQ, and GT

24+ var LT = -1, EQ = 0, GT = 1, ord = ['LT','EQ','GT'];

25+ function compare(x,y) { return { ctor: ord[cmp(x,y)+1] } }

2426 function cmp(x,y) {

2527 var ord;

2628 if (typeof x !== 'object') return x === y ? EQ : x < y ? LT : GT;

2729

28− if (x.ctor === "Cons" || x.ctor === "Nil") {

30+ if (x.ctor === "::" || x.ctor === "[]") {

2931 while (true) {

30− if (x.ctor === "Nil" && y.ctor === "Nil") return EQ;

31− if (x.ctor !== y.ctor) return x.ctor === 'Nil' ? LT : GT;

32+ if (x.ctor === "[]" && y.ctor === "[]") return EQ;

33+ if (x.ctor !== y.ctor) return x.ctor === '[]' ? LT : GT;

3234 ord = cmp(x._0, y._0);

3335 if (ord !== EQ) return ord;

3436 x = x._1;

@@ -36,8 +38,8 @@ Elm.Native.Utils = function(elm) {

3638 }

3739 }

3840

39− if (x.ctor.slice(0,5) === 'Tuple') {

40− var n = x.ctor.slice(5) - 0;

41+ if (x.ctor.slice(0,6) === '_Tuple') {

42+ var n = x.ctor.slice(6) - 0;

4143 var err = 'cannot compare tuples with more than 6 elements.';

4244 if (n === 0) return EQ;

4345 if (n >= 1) { ord = cmp(x._0, y._0); if (ord !== EQ) return ord;

@@ -55,8 +57,8 @@ Elm.Native.Utils = function(elm) {

5557 }

5658

5759

58− var Tuple0 = { ctor: "Tuple0" };

59− function Tuple2(x,y) { return { ctor:"Tuple2", _0:x, _1:y } }

60+ var Tuple0 = { ctor: "_Tuple0" };

61+ function Tuple2(x,y) { return { ctor:"_Tuple2", _0:x, _1:y } }

6062

6163 var count = 0;

6264 function guid(_) { return count++ }

@@ -140,7 +142,7 @@ Elm.Native.Utils = function(elm) {

140142

141143 return elm.Native.Utils = {

142144 eq:eq,

143− cmp:compare,

145+ cmp:cmp,

144146 compare:F2(compare),

145147 Tuple0:Tuple0,

146148 Tuple2:Tuple2,

libraries/Prelude.elm+7−191

@@ -1,202 +1,18 @@

1−

21module Prelude where

32

4−import Native.Prelude as N

5−

6−-- Convert radians to standard Elm angles (radians).

7−radians : Float -> Float

8−radians t = t

9−

10−-- Convert degrees to standard Elm angles (radians).

11−degrees : Float -> Float

12−degrees d = d * Math.PI / 180

13−

14−-- Convert turns to standard Elm angles (radians).

15−-- One turn is equal to 360°.

16−turns : Float -> Float

17−turns r = 2 * Math.PI * r

18−

19−-- Start with polar coordinates (r,θ)

20−-- and get out cartesian coordinates (x,y).

21−fromPolar : (Float,Float) -> (Float,Float)

22−fromPolar (r,t) = (r * N.cos t, r * N.sin t)

23−

24−-- Start with cartesian coordinates (x,y)

25−-- and get out polar coordinates (r,θ).

26−toPolar : (Float,Float) -> (Float,Float)

27−toPolar (x,y) = (N.sqrt (x^2 + y^2), N.atan2 y x)

28−

29−(+) : Number a -> Number a -> Number a

30−(-) : Number a -> Number a -> Number a

31−(*) : Number a -> Number a -> Number a

32−

33−-- Floating point division.

34−(/) : Float -> Float -> Float

35−

36−-- Integer division, remainder is discarded.

37−div : Int -> Int -> Int

38−

39−-- Finds the remainder after dividing one number by another: ``4 `rem` 3 == 1``

40−rem : Int -> Int -> Int

41−

42−-- Perform modular arithmetic: ``7 `mod` 2 == 1``

43−mod : Int -> Int -> Int

44−

45−-- Exponentiation: `3^2 == 9`

46−(^) : Number a -> Number a -> Number a

47−

48−cos : Float -> Float

49−sin : Float -> Float

50−tan : Float -> Float

51−acos : Float -> Float

52−asin : Float -> Float

53−

54−-- You probably do not want to use this. Because it takes `(y/x)` as the argument

55−-- there is no way to know where the negative signs come from so the resulting

56−-- angle is always between π/2 and -π/2 (in quadrants I and IV).

57−atan : Float -> Float

58−

59−-- This helps you find the angle of a cartesian coordinate.

60−-- You will almost certainly want to use this instead of `atan`.

61−-- So `atan2 y x` computes *atan(y/x)* but also keeps track of which

62−-- quadrant the angle should really be in. The result will be between

63−-- π and -π, giving you the full range of angles.

64−atan2 : Float -> Float -> Float

65−

66−-- Take the square root of a number.

67−sqrt : Number a -> Number a

68−

69−-- Take the absolute value of a number.

70−abs : Number a -> Number a

71−

72−-- Calculate the logarithm of a number with a given base: `logBase 10 100 == 2`

73−logBase : Number a -> Number a -> Number a

74−

75−-- Given two numbers, returns the smaller one.

76−min : Number a -> Number a -> Number a

77−

78−-- Given two numbers, returns the larger one.

79−max : Number a -> Number a -> Number a

80−

81−-- Clamps a number within a given range. With the expression `clamp 100 200 x`

82−-- the results are as follows:

83−--

84−-- * `100 if x < 100`

85−-- * ` x if 100 <= x < 200`

86−-- * `200 if 200 <= x`

87−clamp : Number a -> Number a -> Number a -> Number a

88−

89−-- An approximation of pi.

90−pi : Float

91−

92−-- An approximation of e.

93−e : Float

94−

95−-- Compare any two values for structural equality. Functions cannot be compared.

96−(==) : a -> a -> Bool

97−(/=) : a -> a -> Bool

98−

99−(<) : Comparable a -> Comparable a -> Bool

100−(>) : Comparable a -> Comparable a -> Bool

101−(<=) : Comparable a -> Comparable a -> Bool

102−(>=) : Comparable a -> Comparable a -> Bool

103−

104−-- Compare any two comparable values. Comparable values include `String`, `Char`,

105−-- `Int`, `Float`, `Time`, or a list or tuple containing comparable values.

106−-- These are also the only values that work as `Dict` keys or `Set` members.

107−compare : Comparable a -> Comparable a -> Order

108−

109−-- Represents the relative ordering of two things.

110−-- The relations are less than, equal to, and greater than.

111−data Order = LT | EQ | GT

112−

113−-- The and operator. True if both inputs are True.

114−(&&) : Bool -> Bool -> Bool

115−

116−-- The or operator. True if one or both inputs are True.

117−(||) : Bool -> Bool -> Bool

118−

119−-- The exclusive-or operator. True if exactly one input is True.

120−xor : Bool -> Bool -> Bool

121−

122−-- Negate a boolean value: `(not True == False)` and `(not False == True)`

123−not : Bool -> Bool

124−

125−-- Equal to true. Useful as the last case of a multi-way-if.

126−otherwise : Bool

127−otherwise = True

128−

129−

130−-- Conversions

131−

132−-- Round a number to the nearest integer.

133−round : Float -> Int

134−

135−-- Truncate a decimal number, rounding towards zero.

136−truncate : Float -> Int

137−

138−-- Floor function, rounding down.

139−floor : Float -> Int

140−

141−-- Ceiling function, rounding up.

142−ceiling : Float -> Int

143−

144−-- Convert an integer into a float.

145−toFloat : Int -> Float

3+import Basics (String)

4+import Maybe (Maybe)

5+import Native.Prelude

6+import Native.Show

1467

1478-- Convert almost any value to its string representation.

1489show : a -> String

10+show = Native.Show.show

14911

15012-- Read an integer from a string

15113readInt : String -> Maybe Int

14+readInt = Native.Prelude.readInt

15215

15316-- Read a float from a string.

15417readFloat : String -> Maybe Float

155−

156−-- Function Helpers

157−

158−-- Function composition: `(f . g == (\\x -> f (g x)))`

159−(.) : (b -> c) -> (a -> b) -> (a -> c)

160−

161−-- Forward function application `x |> f == f x`. This function is useful

162−-- for avoiding parenthesis and writing code in a more natural way.

163−-- Consider the following code to create a pentagon:

164−--

165−-- scale 2 (move (10,10) (filled blue (ngon 5 30)))

166−--

167−-- This can also be written as:

168−--

169−-- ngon 5 30 |> filled blue

170−-- |> move (10,10)

171−-- |> scale 2

172−(|>) : a -> (a -> b) -> b

173−

174−-- Function application `f <| x == f x`. This function is useful for avoiding

175−-- parenthesis. Consider the following code to create a text element:

176−--

177−-- text (monospace (toText "code"))

178−--

179−-- This can also be written as:

180−--

181−-- text . monospace <| toText "code"

182−(<|) : (a -> b) -> a -> b

183−

184−-- Given a value, returns exactly the same value.

185−id : a -> a

186−

187−-- Given a 2-tuple, returns the first value.

188−fst : (a,b) -> a

189−

190−-- Given a 2-tuple, returns the second value.

191−snd : (a,b) -> b

192−

193−-- Flips the order of the first two arguments to a function.

194−flip : (a -> b -> c) -> (b -> a -> c)

195−

196−-- Change how arguments are passed to a function. This splits paired arguments

197−-- into two separate arguments.

198−curry : ((a,b) -> c) -> a -> b -> c

199−

200−-- Change how arguments are passed to a function. This combines two arguments

201−-- into a sigle pair.

202−uncurry : (a -> b -> c) -> (a,b) -> c

18+readFloat = Native.Prelude.readFloat

libraries/Random.elm+4−1

@@ -1,13 +1,16 @@

11

22module Random where

33

4−import Native.Random as R

4+import Signal (Signal)

5+import Native.Random

56

67-- Given a range from low to high and a signal of values, this produces

78-- a new signal that changes whenever the input signal changes. The new

89-- values are random number between 'low' and 'high' inclusive.

910range : Int -> Int -> Signal a -> Signal Int

11+range = Native.Random.range

1012

1113-- Produces a new signal that changes whenever the input signal changes.

1214-- The new values are random numbers in [0..1).

1315float : Signal a -> Signal Float

16+float = Native.Random.float

libraries/Set.elm+15−14

@@ -6,60 +6,61 @@ module Set (empty,singleton,insert,remove

66 ,toList,fromList

77 ) where

88

9+import Maybe (Maybe)

910import Dict as Dict

1011import List as List

1112

12−type Set t = Dict t ()

13+type Set t = Dict.Dict t ()

1314

1415-- Create an empty set.

15−empty : Set (Comparable k)

16+empty : Set comparable

1617empty = Dict.empty

1718

1819-- Create a set with one value.

19−singleton : Comparable k -> Set (Comparable k)

20+singleton : comparable -> Set comparable

2021singleton k = Dict.singleton k ()

2122

2223-- Insert a value into a set.

23−insert : Comparable k -> Set (Comparable k) -> Set (Comparable k)

24+insert : comparable -> Set comparable -> Set comparable

2425insert k = Dict.insert k ()

2526

2627-- Remove a value from a set. If the value is not found, no changes are made.

27−remove : Comparable k -> Set (Comparable k) -> Set (Comparable k)

28+remove : comparable -> Set comparable -> Set comparable

2829remove = Dict.remove

2930

3031-- Determine if a value is in a set.

31−member : Comparable k -> Set (Comparable k) -> Bool

32+member : comparable -> Set comparable -> Bool

3233member = Dict.member

3334

3435-- Get the union of two sets. Keep all values.

35−union : Set (Comparable k) -> Set (Comparable k) -> Set (Comparable k)

36+union : Set comparable -> Set comparable -> Set comparable

3637union = Dict.union

3738

3839-- Get the intersection of two sets. Keeps values that appear in both sets.

39−intersect : Set (Comparable k) -> Set (Comparable k) -> Set (Comparable k)

40+intersect : Set comparable -> Set comparable -> Set comparable

4041intersect = Dict.intersect

4142

4243-- Get the difference between the first set and the second. Keeps values

4344-- that do not appear in the second set.

44−diff : Set (Comparable k) -> Set (Comparable k) -> Set (Comparable k)

45+diff : Set comparable -> Set comparable -> Set comparable

4546diff = Dict.diff

4647

4748-- Convert a set into a list.

48−toList : Set (Comparable k) -> [Comparable k]

49+toList : Set comparable -> [comparable]

4950toList = Dict.keys

5051

5152-- Convert a list into a set, removing any duplicates.

52−fromList : [Comparable k] -> Set (Comparable k)

53+fromList : [comparable] -> Set comparable

5354fromList xs = List.foldl insert empty xs

5455

5556-- Fold over the values in a set, in order from lowest to highest.

56−foldl : (Comparable a -> b -> b) -> b -> Set (Comparable a) -> b

57+foldl : (comparable -> b -> b) -> b -> Set comparable -> b

5758foldl f b s = Dict.foldl (\k _ b -> f k b) b s

5859

5960-- Fold over the values in a set, in order from highest to lowest.

60−foldr : (Comparable a -> b -> b) -> b -> Set (Comparable a) -> b

61+foldr : (comparable -> b -> b) -> b -> Set comparable -> b

6162foldr f b s = Dict.foldr (\k _ b -> f k b) b s

6263

6364-- Map a function onto a set, creating a new set with no duplicates.

64−map : (Comparable a -> Comparable b) -> Set (Comparable a) -> Set (Comparable b)

65+map : (comparable -> comparable') -> Set comparable -> Set comparable'

6566map f s = fromList (List.map f (toList s))

libraries/Signal.elm+35−3

@@ -7,46 +7,68 @@

77-- Note: There are lift functions up to `lift8`.

88module Signal where

99

10−import Native.Signal as S

11−import List as L

10+import Native.Signal

11+import List (foldr)

12+

13+data Signal a = Signal

14+-- = Constant a

15+-- | Lift (a -> a) (Signal a)

1216

1317-- Create a constant signal that never changes.

1418constant : a -> Signal a

19+constant = Native.Signal.constant

1520

1621-- Transform a signal with a given function.

1722lift : (a -> b) -> Signal a -> Signal b

23+lift = Native.Signal.lift

1824

1925-- Combine two signals with a given function.

2026lift2 : (a -> b -> c) -> Signal a -> Signal b -> Signal c

27+lift2 = Native.Signal.lift2

2128

2229-- Combine three signals with a given function.

2330lift3 : (a -> b -> c -> d) -> Signal a -> Signal b -> Signal c -> Signal d

31+lift3 = Native.Signal.lift3

32+

2433lift4 : (a -> b -> c -> d -> e) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e

34+lift4 = Native.Signal.lift4

35+

2536lift5 : (a -> b -> c -> d -> e -> f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f

37+lift5 = Native.Signal.lift5

38+

2639lift6 : (a -> b -> c -> d -> e -> f -> g)

2740 -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f -> Signal g

41+lift6 = Native.Signal.lift6

42+

2843lift7 : (a -> b -> c -> d -> e -> f -> g -> h)

2944 -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f -> Signal g -> Signal h

45+lift7 = Native.Signal.lift7

46+

3047lift8 : (a -> b -> c -> d -> e -> f -> g -> h -> i)

3148 -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f -> Signal g -> Signal h -> Signal i

49+lift8 = Native.Signal.lift8

50+

3251

3352-- Create a past-dependent signal. Each value given on the input signal will

3453-- be accumulated, producing a new output value.

3554--

3655-- For instance, `(foldp (\\t acc -> acc + 1) 0 (Time.every second))` increments every second.

3756foldp : (a -> b -> b) -> b -> Signal a -> Signal b

57+foldp = Native.Signal.foldp

3858

3959-- Merge two signals into one, biased towards the first signal if both signals

4060-- update at the same time.

4161merge : Signal a -> Signal a -> Signal a

62+merge = Native.Signal.merge

4263

4364-- Merge many signals into one, biased towards the left-most signal if multiple

4465-- signals update simultaneously.

4566merges : [Signal a] -> Signal a

67+merges = Native.Signal.merges

4668

4769-- Combine a list of signals into a signal of lists.

4870combine : [Signal a] -> Signal [a]

49−combine = L.foldr (S.lift2 (::)) (S.constant [])

71+combine = foldr (Native.Signal.lift2 (::)) (Native.Signal.constant [])

5072

5173 -- Merge two signals into one, but distinguishing the values by marking the first

5274 -- signal as `Left` and the second signal as `Right`. This allows you to easily

@@ -55,19 +77,23 @@ combine = L.foldr (S.lift2 (::)) (S.constant [])

5577

5678-- Count the number of events that have occured.

5779count : Signal a -> Signal Int

80+count = Native.Signal.count

5881

5982-- Count the number of events that have occured that satisfy a given predicate.

6083countIf : (a -> Bool) -> Signal a -> Signal Int

84+countIf = Native.Signal.countIf

6185

6286-- Keep only events that satisfy the given predicate. Elm does not allow

6387-- undefined signals, so a base case must be provided in case the predicate is

6488-- never satisfied.

6589keepIf : (a -> Bool) -> a -> Signal a -> Signal a

90+keepIf = Native.Signal.keepIf

6691

6792-- Drop events that satisfy the given predicate. Elm does not allow undefined

6893-- signals, so a base case must be provided in case the predicate is never

6994-- satisfied.

7095dropIf : (a -> Bool) -> a -> Signal a -> Signal a

96+dropIf = Native.Signal.dropIf

7197

7298-- Keep events only when the first signal is true. When the first signal becomes

7399-- true, the most recent value of the second signal will be propagated. Until

@@ -75,6 +101,7 @@ dropIf : (a -> Bool) -> a -> Signal a -> Signal a

75101-- not allow undefined signals, so a base case must be provided in case the first

76102-- signal is never true.

77103keepWhen : Signal Bool -> a -> Signal a -> Signal a

104+keepWhen = Native.Signal.keepWhen

78105

79106-- Drop events when the first signal is true. When the first signal becomes false,

80107-- the most recent value of the second signal will be propagated. Until the first

@@ -82,22 +109,26 @@ keepWhen : Signal Bool -> a -> Signal a -> Signal a

82109-- undefined signals, so a base case must be provided in case the first signal is

83110-- always true.

84111dropWhen : Signal Bool -> a -> Signal a -> Signal a

112+dropWhen = Native.Signal.dropWhen

85113

86114-- Drop sequential repeated values. For example, if a signal produces the

87115-- sequence `[1,1,2,2,1]`, it becomes `[1,2,1]` by dropping the values that

88116-- are the same as the previous value.

89117dropRepeats : Signal a -> Signal a

118+dropRepeats = Native.Signal.dropRepeats

90119

91120-- Sample from the second input every time an event occurs on the first input.

92121-- For example, `(sampleOn clicks (every second))` will give the approximate

93122-- time of the latest click.

94123sampleOn : Signal a -> Signal b -> Signal b

124+sampleOn = Native.Signal.sampleOn

95125

96126-- An alias for `lift`. A prettier way to apply a

97127-- function to the current value of a signal.

98128--

99129-- lift f signal == f <~ signal

100130(<~) : (a -> b) -> Signal a -> Signal b

131+f <~ s = Native.Signal.lift f s

101132

102133-- Signal application. This takes two signals, holding a function and

103134-- a value. It applies the current function to the current value.

@@ -107,3 +138,4 @@ sampleOn : Signal a -> Signal b -> Signal b

107138-- scene <~ Window.dimensions ~ Mouse.position

108139-- lift2 scene Window.dimensions Mouse.position

109140(~) : Signal (a -> b) -> Signal a -> Signal b

141+sf ~ s = Native.Signal.lift2 (\f x -> f x) sf s

libraries/Text.elm+26−2

@@ -1,61 +1,84 @@

11

22module Text where

33

4−import Native.Text as T

4+import open Basics

5+import Color (Color)

6+import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)

7+import Maybe (Maybe)

8+import JavaScript (JSString)

9+import Native.Text

510

11+data Text = Text

612

713-- Convert a string into text which can be styled and displayed.

814toText : String -> Text

15+toText = Native.Text.toText

916

1017-- Set the typeface of some text. The first argument should be a comma separated listing of the desired typefaces

1118-- "helvetica, arial, sans-serif"

1219-- Works the same as the CSS font-family property.

1320typeface : String -> Text -> Text

21+typeface = Native.Text.typeface

1422

1523-- Switch to a monospace typeface. Good for code snippets.

1624monospace : Text -> Text

25+monospace = Native.Text.monospace

1726

1827-- Make text big and noticable.

1928header : Text -> Text

29+header = Native.Text.header

2030

2131-- Create a link.

2232link : String -> Text -> Text

33+link = Native.Text.link

2334

24−-- Set the height of text in \"ems\". 1em is the normal height of text. 2ems is twice that height.

35+-- Set the height of text in pixels.

2536height : Float -> Text -> Text

37+height = Native.Text.height

2638

2739-- Set the color of a string.

2840color : Color -> Text -> Text

41+color = Native.Text.color

2942

3043-- Make a string bold.

3144bold : Text -> Text

45+bold = Native.Text.bold

3246

3347-- Italicize a string.

3448italic : Text -> Text

49+italic = Native.Text.italic

3550

3651-- Draw a line above a string.

3752overline : Text -> Text

53+overline = Native.Text.overline

3854

3955-- Underline a string.

4056underline : Text -> Text

57+underline = Native.Text.underline

4158

4259-- Draw a line through a string.

4360strikeThrough : Text -> Text

61+strikeThrough = Native.Text.strikeThrough

4462

4563-- Display justified, styled text.

4664justified : Text -> Element

65+justified = Native.Text.justified

4766

4867-- Display centered, styled text.

4968centered : Text -> Element

69+centered = Native.Text.centered

5070

5171-- Display right justified, styled text.

5272righted : Text -> Element

73+righted = Native.Text.righted

5374

5475-- Display styled text.

5576text : Text -> Element

77+text = Native.Text.text

5678

5779-- Display a plain string.

5880plainText : String -> Element

81+plainText = Native.Text.plainText

5982

6083-- Convert anything to it's textual representation and make it displayable in browser

6184--

@@ -63,3 +86,4 @@ plainText : String -> Element

6386--

6487-- Excellent for debugging.

6588asText : a -> Element

89+asText = Native.Text.asText

libraries/Time.elm+11−3

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

11-- Library for working with time. Type `Time` represents some number of milliseconds.

22module Time where

33

4−import Native.Time as T

4+import open Basics

5+import Native.Time

6+import Signal (Signal)

57

68-- Type alias to make it clearer when you are working with time values.

79-- Using the `Time` constants instead of raw numbers is very highly recommended.

@@ -38,18 +40,21 @@ inHours t = t / hour

3840-- gives a sequence of time deltas as quickly as possible until it reaches

3941-- the desired FPS. A time delta is the time between the last frame and the

4042-- current frame.

41−fps : Number a -> Signal Time

43+fps : number -> Signal Time

44+fps = Native.Time.fps

4245

4346-- Same as the fps function, but you can turn it on and off. Allows you

4447-- to do brief animations based on user input without major inefficiencies.

4548-- The first time delta after a pause is always zero, no matter how long

4649-- the pause was. This way summing the deltas will actually give the amount

4750-- of time that the output signal has been running.

48−fpsWhen : Number a -> Signal Bool -> Signal Time

51+fpsWhen : number -> Signal Bool -> Signal Time

52+fpsWhen = Native.Time.fpsWhen

4953

5054-- Takes a time interval t. The resulting signal is the current time,

5155-- updated every t.

5256every : Time -> Signal Time

57+every = Native.Time.every

5358

5459-- Takes a time `t` and any signal. The resulting boolean signal

5560-- is true for time `t` after every event on the input signal.

@@ -57,13 +62,16 @@ every : Time -> Signal Time

5762-- that is true for one second after each mouse click and false

5863-- otherwise.

5964since : Time -> Signal a -> Signal Bool

65+since = Native.Time.since

6066

6167-- Add a timestamp to any signal. Timestamps increase monotonically. Each

6268-- timestamp is related to a specfic event, so `Mouse.x` and `Mouse.y` will

6369-- always have the same timestamp because they both rely on the same

6470-- underlying event.

6571timestamp : Signal a -> Signal (Time, a)

72+timestamp = Native.Time.timestamp

6673

6774-- Delay a signal by a certain amount of time. So `(delay second Mouse.clicks)`

6875-- will update one second later than any mouse click.

6976delay : Time -> Signal a -> Signal a

77+delay = Native.Time.delay

libraries/Touch.elm+5−1

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

22-- include gestures that would be useful for both games and web-pages.

33module Touch where

44

5−import Native.Touch as T

5+import Signal (Signal)

6+import Native.Touch

7+import Time (Time)

68

79-- Every `Touch` has `xy` coordinates. It also has an identifier `id` to

810-- distinguish one touch from another.

@@ -14,7 +16,9 @@ type Touch = { x:Int, y:Int, id:Int, x0:Int, y0:Int, t0:Time }

1416

1517-- A list of ongoing touches.

1618touches : Signal [Touch]

19+touches = Native.Touch.touches

1720

1821-- The last position that was tapped. Default value is `{x=0,y=0}`.

1922-- Updates whenever the user taps the screen.

2023taps : Signal { x:Int, y:Int }

24+taps = Native.Touch.taps

libraries/WebSocket.elm+4−1

@@ -2,12 +2,15 @@

22-- standard requests like GET, POST, etc.

33module WebSocket where

44

5−import Native.WebSocket as WS

5+import Signal (Signal)

6+import Basics (String)

7+import Native.WebSocket

68

79-- Create a web-socket. The first argument is the URL of the desired

810-- web-socket server. The input signal holds the outgoing messages,

911-- and the resulting signal contains the incoming ones.

1012connect : String -> Signal String -> Signal String

13+connect = Native.WebSocket.connect

1114

1215-- data Action = Open String | Close String | Send String String

1316-- connections : Signal Action -> Signal String

libraries/Window.elm+5−1

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

11

22module Window where

33

4−import Native.Window as W

4+import Signal (Signal)

5+import Native.Window

56

67-- The current dimensions of the window (i.e. the area viewable to the

78-- user, not including scroll bars).

89dimensions : Signal (Int,Int)

10+dimensions = Native.Window.dimensions

911

1012-- The current width of the window.

1113width : Signal Int

14+width = Native.Window.width

1215

1316-- The current height of the window.

1417height : Signal Int

18+height = Native.Window.height

runtime/Init.js+21−7

@@ -96,7 +96,15 @@ function init(display, container, module, moduleToReplace) {

9696 return newElm;

9797 }

9898

99− var Module = module(elm);

99+ var Module = {};

100+ var reportAnyErrors = function() {};

101+ try {

102+ Module = module(elm);

103+ } catch(e) {

104+ var directions = "<br/>    Open the developer console for more details."

105+ Module.main = Elm.Text(elm).text('<code>' + e.message + directions + '</code>');

106+ reportAnyErrors = function() { throw e; }

107+ }

100108 inputs = ElmRuntime.filterDeadInputs(inputs);

101109 filterListeners(inputs, listeners);

102110 if (display !== ElmRuntime.Display.NONE) {

@@ -112,6 +120,7 @@ function init(display, container, module, moduleToReplace) {

112120 }

113121 }

114122

123+ reportAnyErrors();

115124 return { send:send, recv:recv, swap:swap };

116125};

117126

@@ -148,20 +157,25 @@ function initGraphics(elm, Module) {

148157 }

149158 var currentScene = signalGraph.value;

150159

151− // Add the currentScene to the DOM

160+ // Add the currentScene to the DOM

152161 var Render = ElmRuntime.use(ElmRuntime.Render.Element);

153162 elm.node.appendChild(Render.render(currentScene));

154− if (elm.Native.Window) elm.Native.Window.resizeIfNeeded();

155163

156164 // set up updates so that the DOM is adjusted as necessary.

157165 function domUpdate(newScene, currentScene) {

158166 ElmRuntime.draw(function(_) {

159− Render.update(elm.node.firstChild, currentScene, newScene);

160− if (elm.Native.Window) elm.Native.Window.resizeIfNeeded();

161− });

167+ Render.update(elm.node.firstChild, currentScene, newScene);

168+ if (elm.Native.Window) elm.Native.Window.resizeIfNeeded();

169+ });

162170 return newScene;

163171 }

164− return A3(Signal.foldp, F2(domUpdate), currentScene, signalGraph);

172+ var renderer = A3(Signal.foldp, F2(domUpdate), currentScene, signalGraph);

173+

174+ // must check for resize after 'renderer' is created so

175+ // that changes show up.

176+ if (elm.Native.Window) elm.Native.Window.resizeIfNeeded();

177+

178+ return renderer;

165179}

166180

167181}());

runtime/Render/Collage.js+20−6

@@ -138,6 +138,7 @@ function renderForm(redo, ctx, form) {

138138 if (x !== 0 || y !== 0) ctx.translate(x, y);

139139 if (theta !== 0) ctx.rotate(theta);

140140 if (scale !== 1) ctx.scale(scale,scale);

141+ if (form.alpha !== 1) ctx.globalAlpha = ctx.globalAlpha * form.alpha;

141142 ctx.beginPath();

142143 var f = form.form;

143144 switch(f.ctor) {

@@ -198,6 +199,7 @@ function stepperHelp(list) {

198199function stepper(forms) {

199200 var ps = [stepperHelp(forms)];

200201 var matrices = [];

202+ var alphas = [];

201203 function peekNext() {

202204 var len = ps.length;

203205 var formType = '';

@@ -208,20 +210,30 @@ function stepper(forms) {

208210 }

209211 // assumes that there is a next element

210212 function next(ctx) {

211− while (!ps[0].peekNext()) { ps.shift(); matrices.pop(); if (ctx) { ctx.restore(); } }

213+ while (!ps[0].peekNext()) {

214+ ps.shift();

215+ matrices.pop();

216+ alphas.shift();

217+ if (ctx) { ctx.restore(); }

218+ }

212219 var out = ps[0].next();

213220 var f = out.form;

214221 if (f.ctor === 'FGroup') {

215222 ps.unshift(stepperHelp(f._1));

216− var m = A2( Matrix.multiply, f._0, formToMatrix(out));

223+ var m = A2(Matrix.multiply, f._0, formToMatrix(out));

217224 ctx.save();

218225 ctx.transform(m[0], m[3], m[1], m[4], m[2], m[5]);

219226 matrices.push(m);

227+

228+ var alpha = (alphas[0] || 1) * out.alpha;

229+ alphas.unshift(alpha);

230+ ctx.globalAlpha = alpha;

220231 }

221232 return out;

222233 }

223234 function transforms() { return matrices; }

224− return { peekNext:peekNext, next:next, transforms:transforms };

235+ function alpha() { return alphas[0] || 1; }

236+ return { peekNext:peekNext, next:next, transforms:transforms, alpha:alpha };

225237}

226238

227239function makeCanvas(w,h) {

@@ -274,7 +286,7 @@ function updateTracker(w,h,div) {

274286 ++i;

275287 return transform(transforms, canvas.getContext('2d'));

276288 }

277− function element(matrices, form) {

289+ function element(matrices, alpha, form) {

278290 var container = kids[i];

279291 if (!container || container.getContext) {

280292 container = newElement('div');

@@ -291,6 +303,7 @@ function updateTracker(w,h,div) {

291303

292304 container.style.width = w + 'px';

293305 container.style.height = h + 'px';

306+ container.style.opacity = alpha * form.alpha;

294307

295308 var elem = form.form._0;

296309 var node = container.firstChild;

@@ -331,17 +344,18 @@ function update(div, _, model) {

331344 while (formType = stpr.peekNext()) {

332345 if (ctx === null && formType !== 'FElement') {

333346 ctx = tracker.getContext(stpr.transforms());

347+ ctx.globalAlpha = stpr.alpha();

334348 }

335349 var form = stpr.next(ctx);

336350 if (formType === 'FElement') {

337− tracker.element(stpr.transforms(), form);

351+ tracker.element(stpr.transforms(), stpr.alpha(), form);

338352 ctx = null;

339353 } else if (formType !== 'FGroup') {

340354 renderForm(function() { update(div, model, model); }, ctx, form);

341355 }

342356 }

343357 tracker.clearRest();

344− return div;

358+ return false;

345359}

346360

347361return { render:render, update:update };

runtime/Render/Element.js+97−73

@@ -12,14 +12,32 @@ function setProps(props, e) {

1212 e.style.height = (props.height|0) + 'px';

1313 if (props.opacity !== 1) { e.style.opacity = props.opacity; }

1414 if (props.color.ctor === 'Just') {

15− e.style.backgroundColor = extract(props.color._0);

15+ e.style.backgroundColor = extract(props.color._0);

1616 }

1717 if (props.tag !== '') { e.id = props.tag; }

1818 if (props.href !== '') {

19− var a = newElement('a');

20− a.href = props.href;

21− a.appendChild(e);

22− return a;

19+ var a = newElement('a');

20+ a.href = props.href;

21+ a.style.width = '100%';

22+ a.style.height = '100%';

23+ a.style.top = 0;

24+ a.style.left = 0;

25+ a.style.display = 'block';

26+ a.style.position = 'absolute';

27+ e.style.position = 'relative';

28+ e.appendChild(a);

29+ }

30+ if (props.hover.ctor !== '_Tuple0') {

31+ var overCount = 0;

32+ e.addEventListener('mouseover', function() {

33+ if (overCount++ > 0) return;

34+ props.hover(true);

35+ });

36+ e.addEventListener('mouseout', function(evt) {

37+ if (e.contains(evt.toElement || evt.relatedTarget)) return;

38+ overCount = 0;

39+ props.hover(false);

40+ });

2341 }

2442 return e;

2543}

@@ -64,11 +82,11 @@ function croppedImage(elem, w, h, src) {

6482

6583 var img = newElement('img');

6684 img.onload = function() {

67− var sw = w / elem._1, sh = h / elem._2;

68− img.style.width = ((this.width * sw)|0) + 'px';

69− img.style.height = ((this.height * sh)|0) + 'px';

70− img.style.marginLeft = ((- pos._0 * sw)|0) + 'px';

71− img.style.marginTop = ((- pos._1 * sh)|0) + 'px';

85+ var sw = w / elem._1, sh = h / elem._2;

86+ img.style.width = ((this.width * sw)|0) + 'px';

87+ img.style.height = ((this.height * sh)|0) + 'px';

88+ img.style.marginLeft = ((- pos._0 * sw)|0) + 'px';

89+ img.style.marginTop = ((- pos._1 * sh)|0) + 'px';

7290 };

7391 img.src = src;

7492 img.name = src;

@@ -82,7 +100,7 @@ function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e;

82100function flowWith(f, array) {

83101 var container = newElement('div');

84102 for (var i = array.length; i--; ) {

85− container.appendChild(f(render(array[i])));

103+ container.appendChild(f(render(array[i])));

86104 }

87105 return container;

88106}

@@ -157,8 +175,8 @@ function update(node, curr, next) {

157175 if (node.tagName === 'A') { node = node.firstChild; }

158176 if (curr.props.id === next.props.id) return updateProps(node, curr, next);

159177 if (curr.element.ctor !== next.element.ctor) {

160− node.parentNode.replaceChild(render(next),node);

161− return true;

178+ node.parentNode.replaceChild(render(next),node);

179+ return true;

162180 }

163181 var nextE = next.element, currE = curr.element;

164182 switch(nextE.ctor) {

@@ -167,61 +185,61 @@ function update(node, curr, next) {

167185 if (nextE._0 !== currE._0) node.innerHTML = nextE._0;

168186 break;

169187 case "Image":

170− if (nextE._0.ctor === 'Plain') {

171− if (nextE._3 !== currE._3) node.src = nextE._3;

172− } else if (!eq(nextE,currE) ||

173− next.props.width !== curr.props.width ||

174− next.props.height !== curr.props.height) {

175− node.parentNode.replaceChild(render(next),node);

176− return true;

177− }

178− break;

188+ if (nextE._0.ctor === 'Plain') {

189+ if (nextE._3 !== currE._3) node.src = nextE._3;

190+ } else if (!eq(nextE,currE) ||

191+ next.props.width !== curr.props.width ||

192+ next.props.height !== curr.props.height) {

193+ node.parentNode.replaceChild(render(next),node);

194+ return true;

195+ }

196+ break;

179197 case "Flow":

180198 var arr = fromList(nextE._1);

181199 for (var i = arr.length; i--; ) { arr[i] = arr[i].element.ctor; }

182− if (nextE._0.ctor !== currE._0.ctor) {

183− node.parentNode.replaceChild(render(next),node);

184− return true;

185− }

186− var nexts = fromList(nextE._1);

187− var kids = node.childNodes;

188− if (nexts.length !== kids.length) {

189− node.parentNode.replaceChild(render(next),node);

190− return true;

191− }

192− var currs = fromList(currE._1);

193− var goDir = function(x) { return x; };

194− switch(nextE._0.ctor) {

195− case "DDown": case "DUp": goDir = goDown; break;

196− case "DRight": case "DLeft": goDir = goRight; break;

197− case "DOut": case "DIn": goDir = goIn; break;

198− }

199− for (var i = kids.length; i-- ;) {

200− update(kids[i],currs[i],nexts[i]);

201− goDir(kids[i]);

202− }

203− break;

200+ if (nextE._0.ctor !== currE._0.ctor) {

201+ node.parentNode.replaceChild(render(next),node);

202+ return true;

203+ }

204+ var nexts = fromList(nextE._1);

205+ var kids = node.childNodes;

206+ if (nexts.length !== kids.length) {

207+ node.parentNode.replaceChild(render(next),node);

208+ return true;

209+ }

210+ var currs = fromList(currE._1);

211+ var goDir = function(x) { return x; };

212+ switch(nextE._0.ctor) {

213+ case "DDown": case "DUp": goDir = goDown; break;

214+ case "DRight": case "DLeft": goDir = goRight; break;

215+ case "DOut": case "DIn": goDir = goIn; break;

216+ }

217+ for (var i = kids.length; i-- ;) {

218+ update(kids[i],currs[i],nexts[i]);

219+ goDir(kids[i]);

220+ }

221+ break;

204222 case "Container":

205− var inner = node.firstChild;

206− if (!update(inner, currE._1, nextE._1)) {

207− if (nextE._0.horizontal.ctor !== currE._0.horizontal.ctor) {

208− inner.style.left = inner.style.right = 'none';

209− removeTransform(inner.style);

210− }

211− if (nextE._0.vertical.ctor !== currE._0.vertical.ctor) {

212− inner.style.top = inner.style.bottom = 'none';

213− removeTransform(inner.style);

214− }

215− }

216− setPos(nextE._0, nextE._1.props.width, nextE._1.props.height, inner);

217− break;

223+ var inner = node.firstChild;

224+ if (!update(inner, currE._1, nextE._1)) {

225+ if (nextE._0.horizontal.ctor !== currE._0.horizontal.ctor) {

226+ inner.style.left = inner.style.right = 'none';

227+ removeTransform(inner.style);

228+ }

229+ if (nextE._0.vertical.ctor !== currE._0.vertical.ctor) {

230+ inner.style.top = inner.style.bottom = 'none';

231+ removeTransform(inner.style);

232+ }

233+ }

234+ setPos(nextE._0, nextE._1.props.width, nextE._1.props.height, inner);

235+ break;

218236 case "Custom":

219− if (currE.type === nextE.type) {

220− var done = nextE.update(node, currE.model, nextE.model);

221− if (done) return;

222− } else {

223− return node.parentNode.replaceChild(render(next), node);

224− }

237+ if (currE.type === nextE.type) {

238+ var done = nextE.update(node, currE.model, nextE.model);

239+ if (done) return;

240+ } else {

241+ return node.parentNode.replaceChild(render(next), node);

242+ }

225243 }

226244 updateProps(node, curr, next);

227245}

@@ -231,23 +249,29 @@ function updateProps(node, curr, next) {

231249 if (props.width !== currP.width) e.style.width = (props.width |0) + 'px';

232250 if (props.height !== currP.height) e.style.height = (props.height|0) + 'px';

233251 if (props.opacity !== 1 && props.opacity !== currP.opacity) {

234− e.style.opacity = props.opacity;

252+ e.style.opacity = props.opacity;

235253 }

236254 var nextColor = (props.color.ctor === 'Just' ?

237− extract(props.color._0) : 'transparent');

255+ extract(props.color._0) : 'transparent');

238256 if (e.style.backgroundColor !== nextColor) {

239257 e.style.backgroundColor = nextColor;

240258 }

241259 if (props.tag !== currP.tag) { e.id = props.tag; }

242260 if (props.href !== currP.href) {

243− if (currP.href === '') {

244− var a = newElement('a');

245− a.href = props.href;

246− a.appendChild(e);

247− e.parentNode.replaceChild(a,e);

248− } else {

249− node.parentNode.href = props.href;

250− }

261+ if (currP.href === '') {

262+ var a = newElement('a');

263+ a.href = props.href;

264+ a.style.width = '100%';

265+ a.style.height = '100%';

266+ a.style.top = 0;

267+ a.style.left = 0;

268+ a.style.display = 'block';

269+ a.style.position = 'absolute';

270+ e.style.position = 'relative';

271+ e.appendChild(a);

272+ } else {

273+ node.lastNode.href = props.href;

274+ }

251275 }

252276}

253277

tests/Everything.hsnew file+7

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

1+module Everything where

2+

3+import System.Exit

4+

5+main = do

6+ putStrLn "This test always fails"

7+ exitFailure

tests/good/Apply.elmnew file+3

@@ -0,0 +1,3 @@

1+let apply f x = f x

2+ id x = x

3+ in apply id (apply id (apply id (apply id (apply id (apply id 4)))))

tests/good/Soundness.elmnew file+8

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

1+

2+trickyID x = let y = x in y

3+

4+quad f = twice (twice f)

5+twice f x = f (f x)

6+

7+n = quad (quad trickyID) 4

8+c = twice trickyID 'a'

tests/good/Soundness1.elmnew file+2

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

1+test =

2+ let id x = x in id

tests/good/Soundness2.elmnew file+1

@@ -0,0 +1 @@

1+test x = let y = x in y

tests/good/Soundness3.elmnew file+2

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

1+test f = let g x = f x

2+ in g

tests/good/SoundnessAnnotated1.elmnew file+3

@@ -0,0 +1,3 @@

1+test = let id : a -> a

2+ id x = x

3+ in id

tests/good/SoundnessAnnotated2.elmnew file+2

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

1+test : a -> a

2+test x = let y = x in y

tests/good/SoundnessAnnotated3.elmnew file+3

@@ -0,0 +1,3 @@

1+test : (a -> b) -> a -> b

2+test f = let g x = f x

3+ in g