git.iko.soy/elk
on master help sign in
Merge branch 'types' into dev
aead290Evan Czaplicki
.gitignore+3−7
compare with master
unifiedsplit
@@ -5,11 +5,7 @@ cabal-dev
5*.chi
5*.chi
6*.chs.h
6*.chs.h
7*.aes
7*.aes
8+*.elmi
9+*.elmo
10+*/ElmFiles/*
8.DS_Store
11.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+63−66
@@ -22,153 +22,150 @@ Build-type: Custom
22
22
23Extra-source-files: changelog.txt
23Extra-source-files: changelog.txt
24Data-dir: dist/data
24Data-dir: dist/data
25−Data-files: elm-runtime.js docs.json
25+Data-files: elm-runtime.js interfaces.data
26−Cabal-version: >=1.8
26+Cabal-version: >=1.9
27
27
28source-repository head
28source-repository head
29 type: git
29 type: git
30 location: git://github.com/evancz/Elm.git
30 location: git://github.com/evancz/Elm.git
31
31
32Library
32Library
33− exposed-modules: Language.Elm,
33+ exposed-modules: Language.Elm
34− Language.Elm.Quasi
35 Hs-Source-Dirs: compiler
34 Hs-Source-Dirs: compiler
36 other-modules: Unique,
35 other-modules: Unique,
36+ SourceSyntax.Declaration,
37+ SourceSyntax.Expression,
38+ SourceSyntax.Everything,
37 SourceSyntax.Helpers,
39 SourceSyntax.Helpers,
38− SourceSyntax.Location,
39 SourceSyntax.Literal,
40 SourceSyntax.Literal,
40− SourceSyntax.Pattern,
41+ SourceSyntax.Location,
41− SourceSyntax.Expression,
42− SourceSyntax.Declaration,
43 SourceSyntax.Module,
42 SourceSyntax.Module,
44− SourceSyntax.Rename
43+ SourceSyntax.Pattern,
44+ SourceSyntax.PrettyPrint,
45+ SourceSyntax.Type,
45 Generate.JavaScript,
46 Generate.JavaScript,
46 Generate.Noscript,
47 Generate.Noscript,
47 Generate.Html,
48 Generate.Html,
48 Generate.Cases,
49 Generate.Cases,
50+ Transform.Canonicalize,
51+ Transform.Check,
52+ Transform.SortDefinitions,
49 Transform.Substitute,
53 Transform.Substitute,
50 Transform.Optimize,
54 Transform.Optimize,
51− Metadata.Libraries,
55+ Metadata.Prelude,
52− Metadata.LoadLibraries,
53 Initialize,
56 Initialize,
54 Parse.Binop,
57 Parse.Binop,
58+ Parse.Declaration,
55 Parse.Expression,
59 Parse.Expression,
56− Parse.Foreign,
57 Parse.Helpers,
60 Parse.Helpers,
58 Parse.Literal,
61 Parse.Literal,
59 Parse.Module,
62 Parse.Module,
60− Parse.Parser,
63+ Parse.Parse,
61 Parse.Pattern,
64 Parse.Pattern,
62 Parse.Type,
65 Parse.Type,
63− Types.Alias,
66+ Type.Constrain.Declaration,
64− Types.Types,
67+ Type.Constrain.Expression,
65− Types.Constrain,
68+ Type.Constrain.Literal,
66− Types.Hints,
69+ Type.Constrain.Pattern,
67− Types.Solver,
70+ Type.Environment,
68− Types.Substitutions,
71+ Type.Fragment,
72+ Type.Inference,
73+ Type.PrettyPrint,
74+ Type.Solve,
75+ Type.State,
76+ Type.Type,
69− Types.Unify,
77+ Type.Unify,
70 Paths_Elm
78 Paths_Elm
71
79
72 Build-depends: base >=4.2 && <5,
80 Build-depends: base >=4.2 && <5,
81+ binary,
73 blaze-html == 0.5.* || == 0.6.*,
82 blaze-html == 0.5.* || == 0.6.*,
74 blaze-markup == 0.5.1.*,
83 blaze-markup == 0.5.1.*,
75 bytestring,
84 bytestring,
76 cmdargs,
85 cmdargs,
77 containers >= 0.3,
86 containers >= 0.3,
78− deepseq,
79 directory,
87 directory,
80 filepath,
88 filepath,
81 hjsmin,
89 hjsmin,
82 indents,
90 indents,
83− json,
84 mtl >= 2,
91 mtl >= 2,
85 pandoc >= 1.10,
92 pandoc >= 1.10,
86 parsec >= 3.1.1,
93 parsec >= 3.1.1,
87− shakespeare,
94+ pretty,
88− text,
89− template-haskell,
90 transformers >= 0.2,
95 transformers >= 0.2,
91 union-find,
96 union-find,
92 uniplate
97 uniplate
93
98
94Executable elm
99Executable elm
95 Main-is: Compiler.hs
100 Main-is: Compiler.hs
101+ ghc-options: -threaded -O2
96 Hs-Source-Dirs: compiler
102 Hs-Source-Dirs: compiler
97 other-modules: Unique,
103 other-modules: Unique,
104+ SourceSyntax.Declaration,
105+ SourceSyntax.Expression,
106+ SourceSyntax.Everything,
98 SourceSyntax.Helpers,
107 SourceSyntax.Helpers,
99− SourceSyntax.Location,
100 SourceSyntax.Literal,
108 SourceSyntax.Literal,
101− SourceSyntax.Pattern,
109+ SourceSyntax.Location,
102− SourceSyntax.Expression,
103− SourceSyntax.Declaration,
104 SourceSyntax.Module,
110 SourceSyntax.Module,
105− SourceSyntax.Rename
111+ SourceSyntax.Pattern,
112+ SourceSyntax.PrettyPrint,
113+ SourceSyntax.Type,
106 Generate.JavaScript,
114 Generate.JavaScript,
107 Generate.Noscript,
115 Generate.Noscript,
108 Generate.Html,
116 Generate.Html,
109 Generate.Cases,
117 Generate.Cases,
118+ Transform.Canonicalize,
119+ Transform.Check,
120+ Transform.SortDefinitions,
110 Transform.Substitute,
121 Transform.Substitute,
111 Transform.Optimize,
122 Transform.Optimize,
112− Metadata.Libraries,
123+ Metadata.Prelude,
113− Metadata.LoadLibraries,
114 Initialize,
124 Initialize,
115 Parse.Binop,
125 Parse.Binop,
126+ Parse.Declaration,
116 Parse.Expression,
127 Parse.Expression,
117− Parse.Foreign,
118 Parse.Helpers,
128 Parse.Helpers,
119 Parse.Literal,
129 Parse.Literal,
120 Parse.Module,
130 Parse.Module,
121− Parse.Parser,
131+ Parse.Parse,
122 Parse.Pattern,
132 Parse.Pattern,
123 Parse.Type,
133 Parse.Type,
124− Types.Alias,
134+ Type.Constrain.Declaration,
125− Types.Types,
135+ Type.Constrain.Expression,
126− Types.Constrain,
136+ Type.Constrain.Literal,
127− Types.Hints,
137+ Type.Constrain.Pattern,
128− Types.Solver,
138+ Type.Environment,
129− Types.Substitutions,
139+ Type.Fragment,
140+ Type.Inference,
141+ Type.PrettyPrint,
142+ Type.Solve,
143+ Type.State,
144+ Type.Type,
130− Types.Unify,
145+ Type.Unify,
131 Paths_Elm
146 Paths_Elm
132
147
133 Build-depends: base >=4.2 && <5,
148 Build-depends: base >=4.2 && <5,
149+ binary,
134 blaze-html == 0.5.* || == 0.6.*,
150 blaze-html == 0.5.* || == 0.6.*,
135 blaze-markup == 0.5.1.*,
151 blaze-markup == 0.5.1.*,
136 bytestring,
152 bytestring,
137 cmdargs,
153 cmdargs,
138 containers >= 0.3,
154 containers >= 0.3,
139− deepseq,
140 directory,
155 directory,
141 filepath,
156 filepath,
142 hjsmin,
157 hjsmin,
143 indents,
158 indents,
144− json,
145 mtl >= 2,
159 mtl >= 2,
146 pandoc >= 1.10,
160 pandoc >= 1.10,
147 parsec >= 3.1.1,
161 parsec >= 3.1.1,
162+ pretty,
148 transformers >= 0.2,
163 transformers >= 0.2,
149 union-find,
164 union-find,
150 uniplate
165 uniplate
151
166
152−Executable elm-doc
167+Test-Suite test-elm
153− Main-is: Docs.hs
168+ Type: exitcode-stdio-1.0
154− Hs-Source-Dirs: compiler
169+ Hs-Source-Dirs: tests
155− other-modules: SourceSyntax.Helpers,
170+ Main-is: Everything.hs
156− SourceSyntax.Location,
157− SourceSyntax.Literal,
158− SourceSyntax.Pattern,
159− SourceSyntax.Expression,
160− SourceSyntax.Declaration,
161− SourceSyntax.Module,
162− SourceSyntax.Rename
163− Parse.Helpers,
164− Parse.Module
165−
166− Build-depends: base >=4.2 && <5,
171+ build-depends: base
167− containers >= 0.3,
168− transformers >= 0.2,
169− mtl >= 2,
170− parsec >= 3.1.1,
171− pandoc >= 1.10,
172− cmdargs,
173− filepath,
174− indents
Setup.hs+73−74
@@ -10,12 +10,13 @@ import System.IO
10import System.Process
10import System.Process
11
11
12import Control.Monad
12import Control.Monad
13+import qualified Data.Binary as Binary
13
14
14-- Part 1
15-- Part 1
15-- ------
16-- ------
16-- Add a build callout
17-- 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+-- We need to build elm-doc and run it because that generates the file "docs.json"
18−-- which is part of the elm library and executable
19+-- needs by Libraries.hs which is part of the elm library and executable
19-- Unfort. there seems to be no way to tell cabal that:
20-- Unfort. there seems to be no way to tell cabal that:
20-- (a) elm-doc generates docs.json, and
21-- (a) elm-doc generates docs.json, and
21-- (b) elm (library) depends on docs.json
22-- (b) elm (library) depends on docs.json
@@ -29,19 +30,20 @@ import Control.Monad
29
30
30-- Assumptions
31-- Assumptions
31-- Elm.cabal expects the generated files to end up in dist/data
32-- 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+-- git won't look in dist + cabal will clean it
34+rtsDir :: LocalBuildInfo -> FilePath
35+rtsDir lbi = buildDir lbi </> ".." </> "data"
36+
37+tempDir :: LocalBuildInfo -> FilePath
33−jsDir lbi = buildDir lbi </> ".." </> "js"
38+tempDir lbi = buildDir lbi </> ".." </> "temp"
34
39
35-- The runtime is called:
40-- The runtime is called:
41+rts :: LocalBuildInfo -> FilePath
36rts lbi = rtsDir lbi </> "elm-runtime.js"
42rts lbi = rtsDir lbi </> "elm-runtime.js"
37
43
38−-- The json file is called:
44+-- The interfaces for the Standard Libraries live in:
39−
45+interfaces :: LocalBuildInfo -> FilePath
40−-- The elm-docs executable is called:
46+interfaces lbi = rtsDir lbi </> "interfaces.data"
41−elmDoc = "elm-doc"
42−elm_doc lbi = buildDir lbi </> elmDoc </> elmDoc
43−
44−types lbi = rtsDir lbi </> "docs.json"
45
47
46-- buildDir with LocalBuildInfo points to "dist/build" (usually)
48-- buildDir with LocalBuildInfo points to "dist/build" (usually)
47elm lbi = buildDir lbi </> "elm" </> "elm"
49elm lbi = buildDir lbi </> "elm" </> "elm"
@@ -51,25 +53,11 @@ elm lbi = buildDir lbi </> "elm" </> "elm"
51
53
52
54
53main :: IO ()
55main :: IO ()
54−main = defaultMainWithHooks simpleUserHooks { {-- buildHook = myBuild, --} postBuild = myPostBuildWithTypes }
56+main = defaultMainWithHooks simpleUserHooks { postBuild = myPostBuild }
55
57
56
58
57-- Build
59-- Build
58
60
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−
73-- note(1): We use to include docs.json directly into LoadLibraries at compile time
61-- note(1): We use to include docs.json directly into LoadLibraries at compile time
74-- If docs.json is used in other (template) haskell files, they should be copied
62-- If docs.json is used in other (template) haskell files, they should be copied
75-- and compiled in a separate directory (eg, dist/copiedSrc).
63-- and compiled in a separate directory (eg, dist/copiedSrc).
@@ -77,42 +65,83 @@ myBuild pd lbi uh bf = do
77-- Copying is a better solution than 'touch'ing the source files
65-- Copying is a better solution than 'touch'ing the source files
78-- (touch is non-portable and confusing wrt RCS).
66-- (touch is non-portable and confusing wrt RCS).
79
67
80−-- In the PackageDescription, the list of stuff to build is held in library (in a Maybe)
68+-- In the PackageDescription, the list of stuff to build is held in library
81−-- and the executables list. We want a PackageDescription that only mentions the executable 'name'
69+-- (in a Maybe) and the executables list. We want a PackageDescription that
70+-- only mentions the executable 'name'
71+filterExe :: String -> PackageDescription -> PackageDescription
82filterExe name pd = pd {
72filterExe name pd = pd {
83 library = Nothing,
73 library = Nothing,
84 executables = filter (\x -> (exeName x == name)) (executables pd)
74 executables = filter (\x -> (exeName x == name)) (executables pd)
85 }
75 }
86
76
87−-- It's not enough to fix the PackageDescription, we also have to fix the LocalBuildInfo.
77+-- It's not enough to fix the PackageDescription, we also have to fix the
88−-- This includes the component build order (data ComponentName) which is horribly internal.
78+-- LocalBuildInfo. This includes the component build order (data ComponentName)
79+-- which is horribly internal.
80+filterLBI :: String -> LocalBuildInfo -> LocalBuildInfo
89filterLBI name lbi = lbi {
81filterLBI name lbi = lbi {
90 libraryConfig = Nothing,
82 libraryConfig = Nothing,
91 compBuildOrder = [CExeName name],
83 compBuildOrder = [CExeName name],
92 executableConfigs = filter (\a -> (fst a == name)) (executableConfigs lbi)
84 executableConfigs = filter (\a -> (fst a == name)) (executableConfigs lbi)
93 }
85 }
94
86
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−
101
87
102-- Post Build
88-- Post Build
103
89
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−
110myPostBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
90myPostBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
111myPostBuild as bfs pd lbi = do
91myPostBuild as bfs pd lbi = do
112− putStrLn "Custom post build step started: build elm-runtime.js"
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"
113− buildRuntime lbi
97+ buildRuntime lbi elmos
98+ removeDirectoryRecursive ("dist" </> "temp")
114 postBuild simpleUserHooks as bfs pd lbi
99 postBuild simpleUserHooks as bfs pd lbi
115
100
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+
116getFiles ext dir = do
145getFiles ext dir = do
117 contents <- map (dir </>) `fmap` getDirectoryContents dir
146 contents <- map (dir </>) `fmap` getDirectoryContents dir
118 let files = filter (\f -> takeExtension f == ext) contents
147 let files = filter (\f -> takeExtension f == ext) contents
@@ -125,33 +154,3 @@ appendJS lbi file = do
125 str <- readFile file
154 str <- readFile file
126 length str `seq` return ()
155 length str `seq` return ()
127 appendFile (rts lbi) str
156 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− removeDirectoryRecursive ("dist" </> "js")
155− mapM_ (appendJS lbi) =<< getFiles ".js" "libraries"
156− mapM_ (appendElm lbi) =<< getFiles ".elm" "libraries"
157− mapM_ (appendJS lbi) =<< getFiles ".js" "runtime"
changelog.txt+22−6
@@ -2,22 +2,38 @@
2Release 0.8.1
2Release 0.8.1
3=============
3=============
4
4
5+Website:
5* Hot-swapping
6* Hot-swapping
7+* Much faster page load with pre-compile Elm files (Max New)
6
8
7Syntax:
9Syntax:
8−* Type annotations in let expressions (Andrew)
9−* Record Constructors
10* Pattern matching on literals
10* Pattern matching on literals
11* Pattern aliases with `as` (Andrew)
11* Pattern aliases with `as` (Andrew)
12+* Unary negation
12* Triple-quoted multi-line strings
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
13−* Use if, let, case, and lambda in last term of a
20+* Unparenthesized if, let, case, and lambda in last
14− binary expression without parentheses
21+ term of a binary expression
15
22
16Libraries:
23Libraries:
17* Detect hovering over any Element
24* Detect hovering over any Element
18* Opacity on arbitrary forms in collages
25* Opacity on arbitrary forms in collages
19−* Switch Text.height to use px instead of em,
26+* Switch Text.height to use px instead of em
20− units like em and % can be created in Elm
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+
21
37
22
38
23forgot to fill this in again...
39forgot to fill this in again...
compiler/Compiler.hs+82−45
@@ -1,34 +1,42 @@
1{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2module Main where
2module Main where
3
3
4−import Control.Monad (foldM, when)
4+import Control.Monad
5import qualified Data.Map as Map
5import qualified Data.Map as Map
6−import Data.Either (lefts, rights)
6+import qualified Data.List as List
7−import Data.List (intersect, intercalate, lookup)
7+import qualified Data.Binary as Binary
8−import Data.Maybe (fromMaybe)
9import Data.Version (showVersion)
8import Data.Version (showVersion)
10−import System.Console.CmdArgs
9+import System.Console.CmdArgs hiding (program)
11import System.Directory
10import System.Directory
12import System.Exit
11import System.Exit
13import System.FilePath
12import System.FilePath
13+import GHC.Conc
14+
14import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
15import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
15import qualified Text.Blaze.Html.Renderer.String as Normal
16import qualified Text.Blaze.Html.Renderer.String as Normal
16−
17import qualified Text.Jasmine as JS
17import qualified Text.Jasmine as JS
18import qualified Data.ByteString.Lazy.Char8 as BS
18import qualified Data.ByteString.Lazy.Char8 as BS
19
19
20+import qualified Metadata.Prelude as Prelude
21+import qualified Transform.Canonicalize as Canonical
20import SourceSyntax.Module
22import SourceSyntax.Module
21−import Initialize (buildFromSource, getSortedModuleNames)
23+import Initialize (buildFromSource, getSortedDependencies)
22import Generate.JavaScript (jsModule)
24import Generate.JavaScript (jsModule)
23import Generate.Html (createHtml, JSStyle(..), JSSource(..))
25import Generate.Html (createHtml, JSStyle(..), JSSource(..))
24−import qualified Metadata.Libraries as Libraries
25import Paths_Elm
26import Paths_Elm
26
27
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+
27data Flags =
33data Flags =
28 Flags { make :: Bool
34 Flags { make :: Bool
29 , files :: [FilePath]
35 , files :: [FilePath]
30 , runtime :: Maybe FilePath
36 , runtime :: Maybe FilePath
31 , only_js :: Bool
37 , only_js :: Bool
38+ , print_types :: Bool
39+ , print_program :: Bool
32 , scripts :: [FilePath]
40 , scripts :: [FilePath]
33 , no_prelude :: Bool
41 , no_prelude :: Bool
34 , minify :: Bool
42 , minify :: Bool
@@ -44,6 +52,10 @@ flags = Flags
44 &= help "Specify a custom location for Elm's runtime system."
52 &= help "Specify a custom location for Elm's runtime system."
45 , only_js = False
53 , only_js = False
46 &= help "Compile only to JavaScript."
54 &= 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."
47 , scripts = [] &= typFile
59 , scripts = [] &= typFile
48 &= help "Load JavaScript files in generated HTML. Files will be included in the given order."
60 &= help "Load JavaScript files in generated HTML. Files will be included in the given order."
49 , no_prelude = False
61 , no_prelude = False
@@ -56,7 +68,8 @@ flags = Flags
56 &= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki")
68 &= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki")
57
69
58main :: IO ()
70main :: IO ()
71+main = do setNumCapabilities =<< getNumProcessors
59−main = compileArgs =<< cmdArgs flags
72+ compileArgs =<< cmdArgs flags
60
73
61compileArgs :: Flags -> IO ()
74compileArgs :: Flags -> IO ()
62compileArgs flags =
75compileArgs flags =
@@ -65,49 +78,77 @@ compileArgs flags =
65 fs -> mapM_ (build flags) fs
78 fs -> mapM_ (build flags) fs
66
79
67
80
68−type Interface = String
69−
70file :: Flags -> FilePath -> String -> FilePath
81file :: Flags -> FilePath -> String -> FilePath
71file flags filePath ext = output_directory flags </> replaceExtension filePath ext
82file flags filePath ext = output_directory flags </> replaceExtension filePath ext
72
83
73elmo :: Flags -> FilePath -> FilePath
84elmo :: Flags -> FilePath -> FilePath
74elmo flags filePath = file flags filePath "elmo"
85elmo flags filePath = file flags filePath "elmo"
75
86
87+elmi :: Flags -> FilePath -> FilePath
88+elmi flags filePath = file flags filePath "elmi"
76
89
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
81
90
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)
82 where
96 where
97+ getInterface :: (String, ModuleInterface) -> ModuleInterface
98+ getInterface = snd
99+
83 alreadyCompiled :: IO Bool
100 alreadyCompiled :: IO Bool
84 alreadyCompiled = do
101 alreadyCompiled = do
102+ existsi <- doesFileExist (elmi flags filePath)
85− exists <- doesFileExist (elmo flags filePath)
103+ existso <- doesFileExist (elmo flags filePath)
104+ if not existsi || not existso
86− if not exists then return False
105+ then return False
87− else do tsrc <- getModificationTime filePath
106+ else do tsrc <- getModificationTime filePath
88− tint <- getModificationTime (elmo flags filePath)
107+ tint <- getModificationTime (elmo flags filePath)
89− return (tsrc < tint)
108+ return (tsrc < tint)
90
109
91 number :: String
110 number :: String
92 number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
111 number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
93
112
94 name :: String
113 name :: String
95− name = intercalate "." (splitDirectories (dropExtensions filePath))
114+ name = List.intercalate "." (splitDirectories (dropExtensions filePath))
96
115
97− compile :: IO Interface
116+ compile :: IO ModuleInterface
98 compile = do
117 compile = do
99− putStrLn (number ++ " Compiling " ++ name)
118+ putStrLn $ concat [ number, " Compiling ", name
119+ , replicate (max 1 (20 - length name)) ' '
120+ , "( " ++ filePath ++ " )" ]
100 source <- readFile filePath
121 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 :: Module () String)
106− return (exs, jsModule modul)
107 createDirectoryIfMissing True (output_directory flags)
122 createDirectoryIfMissing True (output_directory flags)
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)
108− writeFile (elmo flags filePath) obj
143+ writeFile (elmo flags filePath) (jsModule metaModule)
109− return obj
144+ return interface
110−
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 ""
111
152
112getRuntime :: Flags -> IO FilePath
153getRuntime :: Flags -> IO FilePath
113getRuntime flags =
154getRuntime flags =
@@ -117,8 +158,10 @@ getRuntime flags =
117
158
118build :: Flags -> FilePath -> IO ()
159build :: Flags -> FilePath -> IO ()
119build flags rootFile = do
160build flags rootFile = do
161+ let noPrelude = no_prelude flags
120− files <- if make flags then getSortedModuleNames rootFile else return [rootFile]
162+ files <- if make flags then getSortedDependencies noPrelude rootFile else return [rootFile]
163+ let ifaces = if noPrelude then Map.empty else Prelude.interfaces
121− buildFiles flags (length files) Map.empty files
164+ interfaces <- buildFiles flags (length files) ifaces files
122 js <- foldM appendToOutput "" files
165 js <- foldM appendToOutput "" files
123 case only_js flags of
166 case only_js flags of
124 True -> do
167 True -> do
@@ -128,7 +171,7 @@ build flags rootFile = do
128 False -> do
171 False -> do
129 putStr "Generating HTML ... "
172 putStr "Generating HTML ... "
130 runtime <- getRuntime flags
173 runtime <- getRuntime flags
131− let html = genHtml $ createHtml runtime rootFile (sources js) ""
174+ let html = genHtml $ createHtml runtime (takeBaseName rootFile) (sources js) ""
132 writeFile (file flags rootFile "html") html
175 writeFile (file flags rootFile "html") html
133 putStrLn "Done"
176 putStrLn "Done"
134
177
@@ -144,16 +187,10 @@ build flags rootFile = do
144 [ Source (if minify flags then Minified else Readable) js ]
187 [ Source (if minify flags then Minified else Readable) js ]
145
188
146
189
147−buildFiles :: Flags -> Int -> Map.Map String Interface -> [FilePath] -> IO ()
190+buildFiles :: Flags -> Int -> Interfaces -> [FilePath] -> IO Interfaces
148−buildFiles _ _ _ [] = return ()
191+buildFiles _ _ interfaces [] = return interfaces
149buildFiles flags numModules interfaces (filePath:rest) = do
192buildFiles flags numModules interfaces (filePath:rest) = do
150− interface <- buildFile flags (numModules - length rest) numModules filePath
193+ interface <- buildFile flags (numModules - length rest) numModules interfaces filePath
151− let moduleName = intercalate "." (splitDirectories (dropExtensions filePath))
194+ let moduleName = List.intercalate "." . splitDirectories $ dropExtensions filePath
152 interfaces' = Map.insert moduleName interface interfaces
195 interfaces' = Map.insert moduleName interface interfaces
153 buildFiles flags numModules interfaces' rest
196 buildFiles flags numModules interfaces' rest
154−
155−
156−exportInfo :: Module t v -> IO String
157−exportInfo (Module names exs ims stmts) =
158− do print exs
159− return (show exs)
compiler/Docs.hs+5−6
@@ -4,16 +4,13 @@ module Main where
4import SourceSyntax.Declaration (Declaration(Datatype))
4import SourceSyntax.Declaration (Declaration(Datatype))
5import Control.Applicative ((<$>), (<*>))
5import Control.Applicative ((<$>), (<*>))
6import Data.List (intercalate)
6import Data.List (intercalate)
7−import Data.Maybe (catMaybes)
8−import Types.Types ((==>), Type ( ADT, VarT ) )
9−import Parse.Type (datatype)
7+import Parse.Type
10import Parse.Helpers
8import Parse.Helpers
11import Parse.Module (moduleDef)
9import Parse.Module (moduleDef)
12import Text.Parsec hiding (newline,spaces)
10import Text.Parsec hiding (newline,spaces)
13import System.Environment
11import System.Environment
14import System.Exit
12import System.Exit
15
13
16−
17main = do
14main = do
18 srcs <- mapM readFile =<< getArgs
15 srcs <- mapM readFile =<< getArgs
19 case mapM docParse srcs of
16 case mapM docParse srcs of
@@ -64,11 +61,13 @@ annotation exports =
64
61
65 typeDef = lookAhead ((string "data" <|> string "type") >> whitespace >> capVar)
62 typeDef = lookAhead ((string "data" <|> string "type") >> whitespace >> capVar)
66
63
67− adt = do
64+ adt = do undefined
65+{-- TODO: reimplement this
68 (Datatype name tvs constructors) <- datatype
66 (Datatype name tvs constructors) <- datatype
69 let toType (cName, typeArgs) =
67 let toType (cName, typeArgs) =
70− (cName, show $ foldr (==>) (ADT name $ map VarT tvs) typeArgs, "")
68+ (cName, show $ foldr (==>) (kADT name $ map kVarT tvs) typeArgs, "")
71 return $ map toType constructors
69 return $ map toType constructors
70+--}
72
71
73setupParser p source =
72setupParser p source =
74 case iParse p "" source of
73 case iParse p "" source of
compiler/Dummy.cabal−3
@@ -45,7 +45,6 @@ Library
45 SourceSyntax.Expression,
45 SourceSyntax.Expression,
46 SourceSyntax.Declaration,
46 SourceSyntax.Declaration,
47 SourceSyntax.Module,
47 SourceSyntax.Module,
48− SourceSyntax.Rename
49 Generate.JavaScript,
48 Generate.JavaScript,
50 Generate.Noscript,
49 Generate.Noscript,
51 Generate.Html,
50 Generate.Html,
@@ -103,7 +102,6 @@ Executable elm
103 SourceSyntax.Expression,
102 SourceSyntax.Expression,
104 SourceSyntax.Declaration,
103 SourceSyntax.Declaration,
105 SourceSyntax.Module,
104 SourceSyntax.Module,
106− SourceSyntax.Rename
107 Generate.JavaScript,
105 Generate.JavaScript,
108 Generate.Noscript,
106 Generate.Noscript,
109 Generate.Html,
107 Generate.Html,
@@ -158,7 +156,6 @@ Executable elm-doc
158 SourceSyntax.Expression,
156 SourceSyntax.Expression,
159 SourceSyntax.Declaration,
157 SourceSyntax.Declaration,
160 SourceSyntax.Module,
158 SourceSyntax.Module,
161− SourceSyntax.Rename
162 Parse.Helpers,
159 Parse.Helpers,
163 Parse.Module
160 Parse.Module
164
161
compiler/Generate/Cases.hs+7−8
@@ -14,7 +14,7 @@ import Transform.Substitute
14
14
15caseToMatch patterns = do
15caseToMatch patterns = do
16 v <- newVar
16 v <- newVar
17− match [v] (map (first (:[])) patterns) Fail
17+ (,) v `liftM` match [v] (map (first (:[])) patterns) Fail
18
18
19newVar = do n <- guid
19newVar = do n <- guid
20 return $ "case" ++ show n
20 return $ "case" ++ show n
@@ -35,8 +35,8 @@ matchSubst :: [(String,String)] -> Match t v -> Match t v
35matchSubst _ Break = Break
35matchSubst _ Break = Break
36matchSubst _ Fail = Fail
36matchSubst _ Fail = Fail
37matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
37matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
38−matchSubst pairs (Other (L t s e)) =
38+matchSubst pairs (Other (L s e)) =
39− Other . L t s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
39+ Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
40matchSubst pairs (Match n cs m) =
40matchSubst pairs (Match n cs m) =
41 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
41 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
42 where varSubst v = fromMaybe v (lookup v pairs)
42 where varSubst v = fromMaybe v (lookup v pairs)
@@ -63,24 +63,23 @@ match vs@(v:_) cs def
63 where
63 where
64 cs' = map (dealias v) cs
64 cs' = map (dealias v) cs
65
65
66−dealias v c@(p:ps, L t s e) =
66+dealias v c@(p:ps, L s e) =
67 case p of
67 case p of
68− PAlias x pattern -> (pattern:ps, L t s $ subst x (Var v) e)
68+ PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)
69 _ -> c
69 _ -> c
70
70
71matchVar :: [String] -> [([Pattern],LExpr t v)] -> Match t v
71matchVar :: [String] -> [([Pattern],LExpr t v)] -> Match t v
72 -> Unique (Match t v)
72 -> Unique (Match t v)
73matchVar (v:vs) cs def = match vs (map subVar cs) def
73matchVar (v:vs) cs def = match vs (map subVar cs) def
74 where
74 where
75− subVar (p:ps, ce@(L t s e)) = (ps, L t s $ subOnePattern p e)
75+ subVar (p:ps, ce@(L s e)) = (ps, L s $ subOnePattern p e)
76 where
76 where
77− loc = L t s
78 subOnePattern pattern e =
77 subOnePattern pattern e =
79 case pattern of
78 case pattern of
80 PVar x -> subst x (Var v) e
79 PVar x -> subst x (Var v) e
81 PAnything -> e
80 PAnything -> e
82 PRecord fs ->
81 PRecord fs ->
83− foldr (\x -> subst x (Access (loc (Var v)) x)) e fs
82+ foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
84
83
85matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v
84matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v
86 -> Unique (Match t v)
85 -> Unique (Match t v)
compiler/Generate/Html.hs+8−10
@@ -1,13 +1,12 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2−module Generate.Html (generateHtml,
2+module Generate.Html
3+ (generateHtml,
3− createHtml,
4+ createHtml,
4− JSStyle (..),
5+ JSStyle (..),
5− JSSource (..)
6+ JSSource (..)
6− ) where
7+ ) where
7
8
8−import Data.List (intercalate)
9import Text.Blaze (preEscapedToMarkup)
9import Text.Blaze (preEscapedToMarkup)
10−import Text.Blaze.Html (Html)
11import qualified Text.Blaze.Html5 as H
10import qualified Text.Blaze.Html5 as H
12import Text.Blaze.Html5 ((!))
11import Text.Blaze.Html5 ((!))
13import qualified Text.Blaze.Html5.Attributes as A
12import qualified Text.Blaze.Html5.Attributes as A
@@ -18,7 +17,6 @@ import qualified Data.ByteString.Lazy.Char8 as BS
18import Initialize (buildFromSource)
17import Initialize (buildFromSource)
19import Generate.JavaScript
18import Generate.JavaScript
20import Generate.Noscript
19import Generate.Noscript
21−import Metadata.Libraries as Libraries
22
20
23data JSStyle = Minified | Readable
21data JSStyle = Minified | Readable
24data JSSource = Link String | Source JSStyle String
22data JSSource = Link String | Source JSStyle String
@@ -41,7 +39,7 @@ makeScript source =
41generateHtml :: String -- ^ Location of elm-runtime.js as expected by the browser
39generateHtml :: String -- ^ Location of elm-runtime.js as expected by the browser
42 -> String -- ^ The page title
40 -> String -- ^ The page title
43 -> String -- ^ The elm source code.
41 -> String -- ^ The elm source code.
44− -> Html
42+ -> H.Html
45generateHtml libLoc title source = H.span "broken for now"
43generateHtml libLoc title source = H.span "broken for now"
46{--
44{--
47 case buildFromSource True source of
45 case buildFromSource True source of
@@ -61,7 +59,7 @@ modulesToHtml libLoc title scripts nscrpt modules =
61 where Module names _ _ _ = last modules
59 where Module names _ _ _ = last modules
62--}
60--}
63
61
64−createHtml :: FilePath -> String -> [JSSource] -> String -> Html
62+createHtml :: FilePath -> String -> [JSSource] -> String -> H.Html
65createHtml libLoc title scripts noscript =
63createHtml libLoc title scripts noscript =
66 H.docTypeHtml $ do
64 H.docTypeHtml $ do
67 H.head $ do
65 H.head $ do
compiler/Generate/JavaScript.hs+190−177
@@ -3,16 +3,20 @@ module Generate.JavaScript (showErr, jsModule) where
3import Control.Arrow (first,second)
3import Control.Arrow (first,second)
4import Control.Monad (liftM,(<=<),join,ap)
4import Control.Monad (liftM,(<=<),join,ap)
5import Data.Char (isAlpha,isDigit)
5import Data.Char (isAlpha,isDigit)
6−import Data.List (intercalate,sortBy,inits,foldl')
6+import qualified Data.List as List
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8+import qualified Data.Set as Set
8import Data.Either (partitionEithers)
9import Data.Either (partitionEithers)
9import qualified Text.Pandoc as Pan
10import qualified Text.Pandoc as Pan
10−import Data.Maybe (maybeToList)
11
11
12import Unique
12import Unique
13import Generate.Cases
13import Generate.Cases
14−import SourceSyntax.Everything hiding (parens)
14+import SourceSyntax.Everything
15−import Types.Types ( Type(RecordT) )
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)
16
20
17showErr :: String -> String
21showErr :: String -> String
18showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
22showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
@@ -24,19 +28,22 @@ indent = concatMap f
24 where f '\n' = "\n "
28 where f '\n' = "\n "
25 f c = [c]
29 f c = [c]
26
30
27−internalImports =
31+internalImports name =
28 [ ("N" , "Elm.Native"),
32 [ ("N" , "Elm.Native"),
29 ("_N", "N.Utils(elm)"),
33 ("_N", "N.Utils(elm)"),
30 ("_L", "N.List(elm)"),
34 ("_L", "N.List(elm)"),
31 ("_E", "N.Error(elm)"),
35 ("_E", "N.Error(elm)"),
32 ("_J", "N.JavaScript(elm)"),
36 ("_J", "N.JavaScript(elm)"),
33− ("_str", "_J.toString")
37+ ("_str", "_J.toString"),
38+ ("$moduleName", quoted name)
34 ]
39 ]
35
40
36parens s = "(" ++ s ++ ")"
41parens s = "(" ++ s ++ ")"
37brackets s = "{" ++ s ++ "}"
42brackets s = "{" ++ s ++ "}"
43+commaSep = List.intercalate ", "
44+dotSep = List.intercalate "."
38−jsObj = brackets . intercalate ", "
45+jsObj = brackets . commaSep
39−jsList ss = "["++ intercalate "," ss ++"]"
46+jsList ss = "["++ List.intercalate "," ss ++"]"
40jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
47jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
41assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
48assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
42ret e = "\nreturn "++ e ++";"
49ret e = "\nreturn "++ e ++";"
@@ -51,148 +58,116 @@ quoted s = "'" ++ concatMap f s ++ "'"
51globalAssign n e = "\n" ++ assign' n e ++ ";"
58globalAssign n e = "\n" ++ assign' n e ++ ";"
52assign' n e = n ++ " = " ++ e
59assign' n e = n ++ " = " ++ e
53
60
54−jsModule (Module names exports imports stmts) =
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)
55− setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
67+ , globalAssign ("Elm." ++ modName)
56− where
68+ (jsFunc "elm" $ makeProgram body foreignImport) ]
57− modNames = if null names then ["Main"] else names
58− modName = intercalate "." modNames
59− includes = concatMap jsImport imports
60− body = stmtsToJS stmts
61− defs = assign "$op" "{}"
62− program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
63− setup ("elm":"Native":modNames) ++
64− assign "_" ("elm.Native." ++ modName ++ "||{}") ++
65− getExports exports stmts ++ setup ("elm":modNames) ++
66− ret (assign' ("elm." ++ modName) "_") ++ "\n"
67− setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
68− map (intercalate ".") . drop 2 . inits $ init modNames
69− usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
70−
71−getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
72− where exNames n = either derename id n `elem` names
73− exports | null names = concatMap get stmts
74− | otherwise = filter exNames (concatMap get stmts)
75−
76− (fns,ops) = partitionEithers exports
77−
78− opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
79− fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
80−
81− op = ("_.$op = "++) . jsObj $ map opPair ops
82−
83− get' (FnDef x _ _) = Just (Left x)
84− get' (OpDef op _ _ _) = Just (Right op)
85− get' (TypeAnnotation _ _) = Nothing
86− get s = case s of Definition d -> maybeToList (get' d)
87− Datatype _ _ tcs -> map (Left . fst) tcs
88− ImportEvent _ _ x _ -> [ Left x ]
89− ExportEvent _ _ _ -> []
90− TypeAlias _ _ _ -> []
91−
92−
93−jsImport (modul, how) =
94− case how of
95− As name -> assign name ("Elm." ++ modul ++ parens "elm")
96− Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
97− "; for(var k in _){if(k in hiding)continue;" ++
98− "eval('var '+k+'=_[\"'+k+'\"]')}"
99− Importing vs -> include ++ named
100− where
101− imprt v = assign' v ("_." ++ v)
102− def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
103− named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
104 where
69 where
105− include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
70+ modName = dotSep (names modul)
106− setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
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))
107 where
86 where
108− defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
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"]
109− subnames = map (intercalate ".") . tail . inits . init . split
112+ subnames = map dotSep . tail . List.inits $ split modul
113+
110− split names = case go [] names of
114+ split names = case go [] names of
111− (name, []) -> [name]
115+ (name, []) -> [name]
112− (name, ns) -> name : split ns
116+ (name, ns) -> name : split ns
113− go name str = case str of
117+ go name str = case str of
114− '.':rest -> (reverse name, rest)
118+ '.':rest -> (reverse name, rest)
115− c:rest -> go (c:name) rest
119+ c:rest -> go (c:name) rest
116− [] -> (reverse name, [])
120+ [] -> (reverse name, [])
117−
121+
118−
119−
120−stmtsToJS :: [Declaration t v] -> String
121−stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
122− return (concat program)
123− where
124− cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
125− valueOf s = case s of
126− Datatype _ _ _ -> 1
127− ImportEvent _ _ _ _ -> 2
128− Definition (FnDef f [] _) ->
129− if derename f == "main" then 5 else 4
130− Definition (TypeAnnotation _ _) -> 0
131− Definition _ -> 3
132− ExportEvent _ _ _ -> 6
133− TypeAlias _ _ _ -> 0
134
122
135class ToJS a where
123class ToJS a where
136 toJS :: a -> Unique String
124 toJS :: a -> Unique String
137
125
126+
138instance ToJS (Def t v) where
127instance ToJS (Def t v) where
139− toJS (FnDef x [] e) = assign x `liftM` toJS' e
128+
140− toJS (FnDef f as e) = (assign f . wrapper . func) `liftM` toJS' e
129+ -- TODO: Make this handle patterns besides plain variables
141− where
130+ toJS (Def (PVar x) e)
142− func body = jsFunc (intercalate ", " as) (ret body)
131+ | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
143− wrapper e | length as == 1 = e
132+ | otherwise = assign (deprime x) `liftM` toJS' e
144− | otherwise = 'F' : show (length as) ++ parens e
133+
145− toJS (OpDef op a1 a2 e) =
134+ toJS (Def pattern e@(L s _)) =
146− do body <- toJS' e
135+ do n <- guid
147− let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
136+ let x = "_" ++ show n
148− return (globalAssign ("$op['" ++ op ++ "']") func)
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+
149 toJS (TypeAnnotation _ _) = return ""
144 toJS (TypeAnnotation _ _) = return ""
150
145
151
146
152−instance ToJS (Declaration t v) where
147+instance ToJS a => ToJS [a] where
153− toJS stmt =
154− case stmt of
155− Definition d -> toJS d
156− Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
148+ toJS xs = concat `liftM` mapM toJS xs
157− where toDef (name,args) =
158− let vars = map (('a':) . show) [1..length args] in
159− Definition . FnDef name vars . none $
160− Data (derename name) (map (none . Var) vars)
161− ImportEvent js base elm _ ->
162− do v <- toJS' base
163− return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
164− , "\ndocument.addEventListener('", js
165− , "_' + elm.id, function(e) { elm.notify(", elm
166− , ".id, e.value); });" ]
167− ExportEvent js elm _ ->
168− return $ concat [ "\nlift(function(v) { "
169− , "var e = document.createEvent('Event');"
170− , "e.initEvent('", js, "_' + elm.id, true, true);"
171− , "e.value = v;"
172− , "document.dispatchEvent(e); return v; })(", elm, ");" ]
173− TypeAlias n _ t -> return ""
174
149
175toJS' :: LExpr t v -> Unique String
150toJS' :: LExpr t v -> Unique String
176−toJS' (L txt span expr) =
151+toJS' (L span expr) =
177 case expr of
152 case expr of
178 MultiIf ps -> multiIfToJS span ps
153 MultiIf ps -> multiIfToJS span ps
179 Case e cases -> caseToJS span e cases
154 Case e cases -> caseToJS span e cases
180 _ -> toJS expr
155 _ -> toJS expr
181
156
182−remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
157+remove x e = "_N.remove('" ++ deprime x ++ "', " ++ e ++ ")"
183−addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
158+addField x v e = "_N.insert('" ++ deprime x ++ "', " ++ v ++ ", " ++ e ++ ")"
184setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
159setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
185− where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
160+ where f (x,v) = "['" ++ deprime x ++ "'," ++ v ++ "]"
186−access x e = e ++ "." ++ x
161+access x e = e ++ "." ++ deprime x
187makeRecord kvs = record `liftM` collect kvs
162makeRecord kvs = record `liftM` collect kvs
188 where
163 where
189 combine r (k,v) = Map.insertWith (++) k v r
164 combine r (k,v) = Map.insertWith (++) k v r
190− collect = liftM (foldl' combine Map.empty) . mapM prep
165+ collect = liftM (List.foldl' combine Map.empty) . mapM prep
191− prep (k, as, e@(L t s _)) =
166+ prep (k, e) =
192− do v <- toJS' (foldr (\x e -> L t s $ Lambda x e) e as)
167+ do v <- toJS' e
193− return (k,[v])
168+ return (deprime k, [v])
194 fields fs =
169 fields fs =
195− brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
170+ brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
196 hidden = fields . map (second jsList) .
171 hidden = fields . map (second jsList) .
197 filter (not . null . snd) . Map.toList . Map.map tail
172 filter (not . null . snd) . Map.toList . Map.map tail
198 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
173 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
@@ -211,7 +186,7 @@ instance ToJS Literal where
211instance ToJS (Expr t v) where
186instance ToJS (Expr t v) where
212 toJS expr =
187 toJS expr =
213 case expr of
188 case expr of
214− Var x -> return x
189+ Var x -> return (deprime x)
215 Literal lit -> toJS lit
190 Literal lit -> toJS lit
216 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
191 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
217 Access e x -> access x `liftM` toJS' e
192 Access e x -> access x `liftM` toJS' e
@@ -220,12 +195,30 @@ instance ToJS (Expr t v) where
220 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
195 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
221 setField fs' `liftM` toJS' e
196 setField fs' `liftM` toJS' e
222 Record fs -> makeRecord fs
197 Record fs -> makeRecord fs
223− Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
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..])
224
206
225− Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
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)
226
219
227 App e1 e2 -> jsApp e1 e2
220 App e1 e2 -> jsApp e1 e2
228− Let defs e -> jsLet defs e
221+ Let defs e -> jsLet $ SD.flattenLets defs e
229
222
230 ExplicitList es ->
223 ExplicitList es ->
231 do es' <- mapM toJS' es
224 do es' <- mapM toJS' es
@@ -239,7 +232,7 @@ instance ToJS (Expr t v) where
239 _ -> jsObj $ ("ctor:" ++ show name) : fields
232 _ -> jsObj $ ("ctor:" ++ show name) : fields
240 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
233 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
241
234
242− Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
235+ Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"
243 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
236 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
244 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
237 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
245
238
@@ -248,12 +241,12 @@ jsApp e1 e2 =
248 as <- mapM toJS' args
241 as <- mapM toJS' args
249 return $ case as of
242 return $ case as of
250 [a] -> f ++ parens a
243 [a] -> f ++ parens a
251− _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
244+ _ -> "A" ++ show (length as) ++ parens (commaSep (f:as))
252 where
245 where
253 (func, args) = go [e2] e1
246 (func, args) = go [e2] e1
254 go args e =
247 go args e =
255 case e of
248 case e of
256− (L _ _ (App e1 e2)) -> go (e2 : args) e1
249+ (L _ (App e1 e2)) -> go (e2 : args) e1
257 _ -> (e, args)
250 _ -> (e, args)
258
251
259formatMarkdown = concatMap f
252formatMarkdown = concatMap f
@@ -264,8 +257,8 @@ formatMarkdown = concatMap f
264
257
265multiIfToJS span ps =
258multiIfToJS span ps =
266 case last ps of
259 case last ps of
267− (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
260+ (L _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
268− _ -> format ("_E.If" ++ parens (quoted (show span))) ps
261+ _ -> format ("_E.If" ++ parens ("$moduleName," ++ quoted (show span))) ps
269 where
262 where
270 format base ps =
263 format base ps =
271 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
264 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
@@ -273,26 +266,18 @@ multiIfToJS span ps =
273 e' <- toJS' e
266 e' <- toJS' e
274 return (b' ++ " ? " ++ e')
267 return (b' ++ " ? " ++ e')
275
268
276−jsLet defs e' = do ds <- jsDefs defs
269+jsLet (defs,e') = do ds <- mapM toJS defs
277− e <- toJS' e'
270+ e <- toJS' e'
278− return $ jsFunc "" (concat ds ++ ret e) ++ "()"
271+ return $ jsFunc "" (concat ds ++ ret e) ++ "()"
279− where
280− jsDefs defs = mapM toJS (sortBy f defs)
281− f a b = compare (valueOf a) (valueOf b)
282− valueOf (FnDef _ [] _) = 2
283− valueOf (FnDef _ _ _) = 1
284− valueOf (OpDef _ _ _ _) = 1
285− valueOf (TypeAnnotation _ _) = 0
286
272
287caseToJS span e ps = do
273caseToJS span e ps = do
288− match <- caseToMatch ps
274+ (tempVar,match) <- caseToMatch ps
289 e' <- toJS' e
275 e' <- toJS' e
290− let (match',stmt) = case (match,e) of
276+ let (match',stmt) = case e of
291− (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
277+ L _ (Var x) -> (matchSubst [(tempVar,deprime x)] match, "")
292− (Match name _ _, _) -> (match, assign name e')
278+ _ -> (match, assign tempVar e')
293− _ -> (match, "")
294 matches <- matchToJS span match'
279 matches <- matchToJS span match'
295− return $ "function(){ " ++ stmt ++ matches ++ " }()"
280+ return $ jsFunc "" (stmt ++ matches) ++ "()"
296
281
297matchToJS span match =
282matchToJS span match =
298 case match of
283 case match of
@@ -305,7 +290,7 @@ matchToJS span match =
305 access = if any isLiteral clauses then "" else ".ctor"
290 access = if any isLiteral clauses then "" else ".ctor"
306 return $ concat [ "\nswitch (", name, access, ") {"
291 return $ concat [ "\nswitch (", name, access, ") {"
307 , indent cases, "\n}", finally ]
292 , indent cases, "\n}", finally ]
308− Fail -> return ("_E.Case" ++ parens (quoted (show span)))
293+ Fail -> return ("_E.Case" ++ parens ("$moduleName," ++ quoted (show span)))
309 Break -> return "break;"
294 Break -> return "break;"
310 Other e -> ret `liftM` toJS' e
295 Other e -> ret `liftM` toJS' e
311 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
296 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
@@ -320,36 +305,64 @@ clauseToJS span var (Clause value vars e) = do
320 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
305 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
321 s <- matchToJS span $ matchSubst (zip vars vars') e
306 s <- matchToJS span $ matchSubst (zip vars vars') e
322 return $ concat [ "\ncase ", case value of
307 return $ concat [ "\ncase ", case value of
323− Left name -> quoted name
324 Right (Boolean True) -> "true"
308 Right (Boolean True) -> "true"
325 Right (Boolean False) -> "false"
309 Right (Boolean False) -> "false"
326 Right lit -> show lit
310 Right lit -> show lit
311+ Left name -> quoted $ case List.elemIndices '.' name of
312+ [] -> name
313+ is -> drop (last is + 1) name
327 , ":", indent s ]
314 , ":", indent s ]
328
315
329jsNil = "_L.Nil"
316jsNil = "_L.Nil"
330jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
317jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
331jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
318jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
332−jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
319+jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
333
320
321+
334−binop (o:p) e1 e2
322+binop op e1 e2
335− | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens 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)
336 | otherwise =
330 | otherwise =
337− let ops = ["+","-","*","/","&&","||"] in
331+ binopNormal op `liftM` toJS' e1 `ap` toJS' e2
338− case o:p of
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 ++
339− "::" -> jsCons e1 e2
352+ [ ("::", jsCons s1 s2)
340− "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
353+ , ("List.++", "_L.append" ++ parens (s1 ++ "," ++ s2)) ]
341− "<|" -> e1 ++ parens e2
354+
342− "|>" -> e2 ++ parens e1
355+ ops = pow : map (\op -> (op, parens (s1 ++ op ++ s2))) ["+","-","*","/","&&","||"]
343− "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
344− "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
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)
345− "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
361+ , ("==", "_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
346− "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
362+ , ("/=", "!_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
347− "<" -> jsCompare e1 e2 "==='LT'"
363+ , ("<" , jsCompare s1 s2 "<0")
348− ">" -> jsCompare e1 e2 "==='GT'"
364+ , (">" , jsCompare s1 s2 ">0")
349− "<=" -> jsCompare e1 e2 "!=='GT'"
365+ , ("<=", jsCompare s1 s2 "<1")
350− ">=" -> jsCompare e1 e2 "!=='LT'"
366+ , (">=", jsCompare s1 s2 ">-1")
351− "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
367+ , ("div", parens (s1 ++ "/" ++ s2 ++ "|0"))
352− "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
368+ ])
353− _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
354− | otherwise -> concat [ "$op['", o:p, "']"
355− , parens e1, parens e2 ]
compiler/Generate/Noscript.hs+5−6
@@ -19,12 +19,11 @@ instance Extract (Declaration t v) where
19 extract _ = []
19 extract _ = []
20
20
21instance Extract (Def t v) where
21instance Extract (Def t v) where
22− extract (FnDef _ _ e) = extract e
22+ extract (Def _ e) = extract e
23− extract (OpDef _ _ _ e) = extract e
24 extract _ = []
23 extract _ = []
25
24
26instance Extract e => Extract (Located e) where
25instance Extract e => Extract (Located e) where
27− extract (L _ _ e) = extract e
26+ extract (L _ e) = extract e
28
27
29instance Extract (Expr t v) where
28instance Extract (Expr t v) where
30 extract expr =
29 extract expr =
@@ -35,11 +34,11 @@ instance Extract (Expr t v) where
35 ("++", [s1], [s2]) -> [s1 ++ s2]
34 ("++", [s1], [s2]) -> [s1 ++ s2]
36 (_ , ss1 , ss2 ) -> ss1 ++ ss2
35 (_ , ss1 , ss2 ) -> ss1 ++ ss2
37 Lambda v e -> f e
36 Lambda v e -> f e
38− App (L _ _ (App (L _ _ (App (L _ _ (Var func)) w)) h)) src
37+ App (L _ (App (L _ (App (L _ (Var func)) w)) h)) src
39 | "image" `isInfixOf` func -> extractImage src
38 | "image" `isInfixOf` func -> extractImage src
40− App (L _ _ (App (L _ _ (Var func)) src)) txt
39+ App (L _ (App (L _ (Var func)) src)) txt
41 | "link" `isInfixOf` func -> extractLink src txt
40 | "link" `isInfixOf` func -> extractLink src txt
42− App (L _ _ (Var func)) e
41+ App (L _ (Var func)) e
43 | "header" `isInfixOf` func -> tag "h1" e
42 | "header" `isInfixOf` func -> tag "h1" e
44 | "bold" `isInfixOf` func -> tag "b" e
43 | "bold" `isInfixOf` func -> tag "b" e
45 | "italic" `isInfixOf` func -> tag "i" e
44 | "italic" `isInfixOf` func -> tag "i" e
compiler/Initialize.hs+87−62
@@ -1,78 +1,103 @@
1−module Initialize (buildFromSource, getSortedModuleNames) where
1+module Initialize (buildFromSource, getSortedDependencies) where
2
2
3−import Control.Applicative ((<$>))
4−import Control.Monad.Error
5−import Data.List (lookup,nub)
6−import qualified Data.Map as Map
7import Data.Data
3import Data.Data
8−import SourceSyntax.Everything
4+import Control.Monad.State
9−import Data.List (intercalate,partition)
5+import qualified Data.Graph as Graph
10−import Parse.Parser (parseProgram, parseDependencies)
11−import qualified Metadata.Libraries as Libs
6+import qualified Data.List as List
12−import Types.Types ((-:))
7+import qualified Data.Map as Map
13−import Types.Hints (hints)
8+import qualified Data.Set as Set
14−import Types.Unify (unify)
15−import Types.Alias (dealias, mistakes)
16−import Transform.Optimize
17import System.Exit
9import System.Exit
18−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
19
27
20−checkMistakes :: (Data t, Data v) => Module t v -> Either String (Module t v)
28+ -- check for structural errors
21−checkMistakes modul@(Module name ex im stmts) =
29+ Module names exs ims decls <-
22− case mistakes stmts of
30+ case Check.mistakes decls' of
23− m:ms -> Left (unlines (m:ms))
24− [] -> return modul
31+ [] -> return modul
32+ ms -> Left ms
25
33
26−checkTypes :: (Data t, Data v) => Module t v -> Either String (Module t v)
34+ let exports'
27−checkTypes modul =
35+ | null exs =
28− do subs <- unify hints modul
36+ let get = Set.toList . SD.boundVars in
29− subs `seq` return (optimize (renameModule modul))
37+ concat [ get pattern | Definition (Def pattern _) <- decls ] ++
38+ concat [ map fst ctors | Datatype _ _ ctors <- decls ]
39+ | otherwise = exs
30
40
31−check :: (Data t, Data v) => Module t v -> Either String (Module t v)
41+ metaModule <- Canonical.metadataModule interfaces $ MetadataModule {
32−check = checkMistakes >=> checkTypes
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+ }
33
55
34−buildFromSource :: (Data t, Data v) => Bool -> String -> Either String (Module t v)
56+ types <- TI.infer interfaces metaModule
35−buildFromSource noPrelude src =
36− let add = if noPrelude then id else Libs.addPrelude in
37− (check . add) =<< (parseProgram src)
38
57
39−getSortedModuleNames :: FilePath -> IO [String]
58+ return $ metaModule { types = types }
40−getSortedModuleNames root =
41− sortDeps =<< readDeps [] root
42
59
60+
61+getSortedDependencies :: Bool -> FilePath -> IO [String]
62+getSortedDependencies noPrelude root =
63+ sortDeps =<< readDeps noPrelude root
64+
43−type Deps = (String, [String])
65+type Deps = (FilePath, String, [String])
44
66
45sortDeps :: [Deps] -> IO [String]
67sortDeps :: [Deps] -> IO [String]
46−sortDeps deps = go [] (nub deps)
68+sortDeps depends =
69+ if null mistakes
70+ then return (concat sccs)
71+ else print msg >> mapM print mistakes >> exitFailure
47− where
72+ where
73+ sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends
74+
75+ mistakes = filter (\scc -> length scc > 1) sccs
48− msg = "A cyclical or missing module dependency or was detected in: "
76+ msg = "A cyclical module dependency or was detected in: "
49−
77+
50− go :: [String] -> [Deps] -> IO [String]
78+readDeps :: Bool -> FilePath -> IO [Deps]
51− go sorted [] = return (map toFilePath sorted)
79+readDeps noPrelude root = evalStateT (go root) Set.empty
52− go sorted unsorted =
80+ where
53− case partition (all (`elem` sorted) . snd) unsorted of
81+ builtIns = if noPrelude then Set.empty
54− ([],m:ms) -> do putStrLn (msg ++ intercalate ", " (map fst (m:ms)) ++ show sorted ++ show unsorted)
82+ else Set.fromList (Map.keys Prelude.interfaces)
55− exitFailure
83+
56− (srtd,unsrtd) -> go (sorted ++ map fst srtd) unsrtd
57−
58−readDeps :: [FilePath] -> FilePath -> IO [Deps]
84+ go :: FilePath -> StateT (Set.Set String) IO [Deps]
59−readDeps seen root = do
85+ go root = do
60− txt <- readFile root
86+ txt <- liftIO $ readFile root
61− case parseDependencies txt of
87+ case Parse.dependencies txt of
62− Left err ->
88+ Left err -> liftIO (putStrLn msg >> print err >> exitFailure)
63− let msg = "Error resolving dependencies in " ++ root ++ ":\n" in
89+ where msg = "Error resolving dependencies in " ++ root ++ ":"
64− putStrLn (msg ++ err) >> exitFailure
90+
65− Right (name,deps) ->
91+ Right (name,deps) ->
66− do rest <- mapM (readDeps seen' . toFilePath) newDeps
92+ do seen <- get
67− return ((name, realDeps) : concat rest)
93+ let realDeps = Set.difference (Set.fromList deps) builtIns
68− where
69− realDeps = filter (`notElem` builtIns) deps
70− newDeps = filter (\d -> d `notElem` seen && not (isNative d)) realDeps
94+ newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
71− seen' = root : seen ++ newDeps
95+ put (Set.insert name (Set.union newDeps seen))
72− builtIns = Map.keys Libs.libraries
96+ rest <- mapM (go . toFilePath) (Set.toList newDeps)
97+ return ((makeRelative "." root, name, Set.toList realDeps) : concat rest)
73
98
74
99
75−isNative name = takeWhile (/='.') name == "Native"
100+isNative name = List.isPrefixOf "Native." name
76
101
77toFilePath :: String -> FilePath
102toFilePath :: String -> FilePath
78toFilePath name = map swapDots name ++ ext
103toFilePath name = map swapDots name ++ ext
compiler/Language/Elm.hs+9−6
@@ -11,7 +11,8 @@
11-}
11-}
12module Language.Elm (compile, toHtml, moduleName, runtime, docs) where
12module Language.Elm (compile, toHtml, moduleName, runtime, docs) where
13
13
14−import Data.List (intercalate)
14+import qualified Data.List as List
15+import qualified Data.Map as Map
15import Data.Version (showVersion)
16import Data.Version (showVersion)
16import Generate.JavaScript (showErr, jsModule)
17import Generate.JavaScript (showErr, jsModule)
17import Generate.Html (generateHtml)
18import Generate.Html (generateHtml)
@@ -21,15 +22,17 @@ import Parse.Module (moduleDef)
21import SourceSyntax.Module
22import SourceSyntax.Module
22import Text.Blaze.Html (Html)
23import Text.Blaze.Html (Html)
23import Text.Parsec (option,optional)
24import Text.Parsec (option,optional)
25+import qualified Text.PrettyPrint as P
26+import qualified Metadata.Prelude as Prelude
24import Paths_Elm
27import Paths_Elm
25
28
26-- |This function compiles Elm code to JavaScript. It will return either
29-- |This function compiles Elm code to JavaScript. It will return either
27-- an error message or the compiled JS code.
30-- an error message or the compiled JS code.
28compile :: String -> Either String String
31compile :: String -> Either String String
29−compile source = fmap jsModule modul
32+compile source =
30− where
31− modul :: Either String (Module () String)
32− modul = buildFromSource False 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 () ())
33
36
34-- |This function extracts the module name of a given source program.
37-- |This function extracts the module name of a given source program.
35moduleName :: String -> Maybe String
38moduleName :: String -> Maybe String
@@ -40,7 +43,7 @@ moduleName source = case iParse getModuleName "" source of
40 getModuleName = do
43 getModuleName = do
41 optional freshLine
44 optional freshLine
42 (names, _) <- moduleDef
45 (names, _) <- moduleDef
43− return (intercalate "." names)
46+ return (List.intercalate "." names)
44
47
45-- |This function compiles Elm code into a full HTML page.
48-- |This function compiles Elm code into a full HTML page.
46toHtml :: String -- ^ Location of elm-min.js as expected by the browser
49toHtml :: String -- ^ Location of elm-min.js as expected by the browser
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/Libraries.hsdeleted−59
@@ -1,59 +0,0 @@
1−module Metadata.Libraries (libraries, addPrelude) where
2−
3−import Control.Applicative ((<$>),(<*>))
4−import qualified Data.Map as Map
5−import Data.List (inits)
6−import Text.JSON
7−import Metadata.LoadLibraries as Libs
8−import SourceSyntax.Module
9−
10−addPrelude :: Module t v -> Module t v
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− [ ("::", "a -> [a] -> [a]")
33− , ("[]", "[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/Metadata/LoadLibraries.hsdeleted−34
@@ -1,34 +0,0 @@
1−module Metadata.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/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/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/Expression.hs+105−73
@@ -19,9 +19,6 @@ import SourceSyntax.Expression
19import SourceSyntax.Declaration (Declaration(Definition))
19import SourceSyntax.Declaration (Declaration(Definition))
20
20
21import Unique
21import Unique
22−import Types.Types (Type (VarT), Scheme (Forall))
23−
24−import System.IO.Unsafe
25
22
26
23
27-------- Basic Terms --------
24-------- Basic Terms --------
@@ -29,6 +26,7 @@ import System.IO.Unsafe
29varTerm :: IParser (Expr t v)
26varTerm :: IParser (Expr t v)
30varTerm = toVar <$> var <?> "variable"
27varTerm = toVar <$> var <?> "variable"
31
28
29+toVar :: String -> Expr t v
32toVar v = case v of "True" -> Literal (Literal.Boolean True)
30toVar v = case v of "True" -> Literal (Literal.Boolean True)
33 "False" -> Literal (Literal.Boolean False)
31 "False" -> Literal (Literal.Boolean False)
34 _ -> Var v
32 _ -> Var v
@@ -38,8 +36,16 @@ accessor = do
38 start <- getPosition
36 start <- getPosition
39 lbl <- try (string "." >> rLabel)
37 lbl <- try (string "." >> rLabel)
40 end <- getPosition
38 end <- getPosition
41− let loc e = Location.add ("." ++ lbl) (Location.at start end e)
39+ let loc e = Location.at start end e
42− return (Lambda "_" (loc $ Access (loc $ Var "_") lbl))
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)
43
49
44
50
45-------- Complex Terms --------
51-------- Complex Terms --------
@@ -56,50 +62,59 @@ listTerm =
56 ])
62 ])
57
63
58parensTerm :: IParser (LExpr t v)
64parensTerm :: IParser (LExpr t v)
59−parensTerm = parens $ choice
65+parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
60− [ do start <- getPosition
66+ where
67+ opFn = do
68+ start <- getPosition
61− op <- try anyOp
69+ op <- anyOp
62− end <- getPosition
70+ end <- getPosition
63− let loc = Location.at start end
71+ let loc = Location.at start end
64− return . loc . Lambda "x" . loc . Lambda "y" . loc $
72+ return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
65− Binop op (loc $ Var "x") (loc $ Var "y")
73+ Binop op (loc $ Var "x") (loc $ Var "y")
74+
75+ tupleFn = do
66− , do start <- getPosition
76+ start <- getPosition
67− let comma = char ',' <?> "comma ','"
77+ let comma = char ',' <?> "comma ','"
68− commas <- comma >> many (whitespace >> comma)
78+ commas <- comma >> many (whitespace >> comma)
69− end <- getPosition
79+ end <- getPosition
70− let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
80+ let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
71− loc = Location.at start end
81+ loc = Location.at start end
72− return $ foldr (\x e -> loc $ Lambda x e)
82+ return $ foldr (\x e -> loc $ Lambda x e)
73− (loc . tuple $ map (loc . Var) vars) vars
83+ (loc . tuple $ map (loc . Var) vars) (map PVar vars)
84+
85+ parened = do
74− , do start <- getPosition
86+ start <- getPosition
75− es <- commaSep expr
87+ es <- commaSep expr
76− end <- getPosition
88+ end <- getPosition
77− return $ case es of [e] -> e
89+ return $ case es of [e] -> e
78− _ -> Location.at start end (tuple es)
90+ _ -> Location.at start end (tuple es)
79− ]
80
91
81recordTerm :: IParser (LExpr t v)
92recordTerm :: IParser (LExpr t v)
82recordTerm = brackets $ choice [ misc, addLocation record ]
93recordTerm = brackets $ choice [ misc, addLocation record ]
83 where field = do
94 where field = do
95+ label <- rLabel
84− fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix Pattern.term
96+ patterns <- spacePrefix Pattern.term
85− whitespace
86− e <- string "=" >> whitespace >> expr
97+ whitespace >> string "=" >> whitespace
87− n <- sourceLine <$> getPosition
98+ body <- expr
88− runAt (1000 * n) $ Pattern.flatten fDefs e
99+ return (label, makeFunction patterns body)
89− extract [ FnDef f args exp ] = return (f,args,exp)
100+
90− extract _ = fail "Improperly formed record field."
91− record = Record <$> (mapM extract =<< commaSep field)
101+ record = Record <$> commaSep field
102+
92 change = do
103 change = do
93 lbl <- rLabel
104 lbl <- rLabel
94 whitespace >> string "<-" >> whitespace
105 whitespace >> string "<-" >> whitespace
95 (,) lbl <$> expr
106 (,) lbl <$> expr
107+
96 remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
108 remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
109+
97 insert r = addLocation $ do
110 insert r = addLocation $ do
98 string "|" >> whitespace
111 string "|" >> whitespace
99 Insert r <$> rLabel <*>
112 Insert r <$> rLabel <*>
100 (whitespace >> string "=" >> whitespace >> expr)
113 (whitespace >> string "=" >> whitespace >> expr)
114+
101 modify r = addLocation
115 modify r = addLocation
102 (string "|" >> whitespace >> Modify r <$> commaSep1 change)
116 (string "|" >> whitespace >> Modify r <$> commaSep1 change)
117+
103 misc = try $ do
118 misc = try $ do
104 record <- addLocation (Var <$> rLabel)
119 record <- addLocation (Var <$> rLabel)
105 whitespace
120 whitespace
@@ -111,7 +126,7 @@ recordTerm = brackets $ choice [ misc, addLocation record ]
111
126
112
127
113term :: IParser (LExpr t v)
128term :: IParser (LExpr t v)
114−term = addLocation (choice [ Literal <$> literal, listTerm, accessor ])
129+term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
115 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
130 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
116 <?> "basic term (4, x, 'c', etc.)"
131 <?> "basic term (4, x, 'c', etc.)"
117
132
@@ -119,10 +134,12 @@ term = addLocation (choice [ Literal <$> literal, listTerm, accessor ])
119
134
120appExpr :: IParser (LExpr t v)
135appExpr :: IParser (LExpr t v)
121appExpr = do
136appExpr = do
122− tlist <- spaceSep1 term
137+ t <- term
138+ ts <- constrainedSpacePrefix term $ \str ->
139+ if null str then notFollowedBy (char '-') else return ()
123− return $ case tlist of
140+ return $ case ts of
124− t:[] -> t
141+ [] -> t
125− t:ts -> foldl' (\f x -> Location.merge f x $ App f x) t ts
142+ _ -> foldl' (\f x -> Location.merge f x $ App f x) t ts
126
143
127-------- Normal Expressions --------
144-------- Normal Expressions --------
128
145
@@ -140,7 +157,8 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
140 thenBranch <- expr
157 thenBranch <- expr
141 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
158 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
142 elseBranch <- expr
159 elseBranch <- expr
143− return $ MultiIf [(bool, thenBranch), (Location.none (Var "otherwise"), elseBranch)]
160+ return $ MultiIf [(bool, thenBranch),
161+ (Location.sameAs elseBranch (Var "otherwise"), elseBranch)]
144 multiIf = MultiIf <$> spaceSep1 iff
162 multiIf = MultiIf <$> spaceSep1 iff
145 where iff = do string "|" ; whitespace
163 where iff = do string "|" ; whitespace
146 b <- expr ; whitespace ; string "->" ; whitespace
164 b <- expr ; whitespace ; string "->" ; whitespace
@@ -149,13 +167,13 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
149lambdaExpr :: IParser (LExpr t v)
167lambdaExpr :: IParser (LExpr t v)
150lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
168lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
151 whitespace
169 whitespace
152− pats <- spaceSep1 Pattern.term
170+ args <- spaceSep1 Pattern.term
153 whitespace ; arrow ; whitespace
171 whitespace ; arrow ; whitespace
154− e <- expr
172+ body <- expr
155− return . run $ Pattern.makeLambda pats e
173+ return (makeFunction args body)
156
174
157defSet :: IParser [Def t v]
175defSet :: IParser [Def t v]
158−defSet = concat <$> block (do d <- anyDef ; whitespace ; return d)
176+defSet = block (do d <- def ; whitespace ; return d)
159
177
160letExpr :: IParser (Expr t v)
178letExpr :: IParser (Expr t v)
161letExpr = do
179letExpr = do
@@ -178,33 +196,47 @@ expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
178 <|> binaryExpr
196 <|> binaryExpr
179 <?> "an expression"
197 <?> "an expression"
180
198
199+funcDef =
181−funcDef = try (do p1 <- try Pattern.term ; infics p1 <|> func p1)
200+ choice [ do p1 <- try Pattern.term
201+ infics p1 <|> func p1
202+ , func =<< (PVar <$> parens symOp)
182− <|> ((:[]) <$> Pattern.expr)
203+ , (:[]) <$> Pattern.expr
183− <?> "the definition of a variable (x = ...)"
204+ ] <?> "the definition of a variable (x = ...)"
205+ where
206+ func pattern =
207+ case pattern of
184− where func p@(PVar v) = (p:) <$> spacePrefix Pattern.term
208+ PVar v -> (pattern:) <$> spacePrefix Pattern.term
185− func p = do try (lookAhead (whitespace >> string "="))
209+ _ -> do try (lookAhead (whitespace >> string "="))
186− return [p]
210+ return [pattern]
211+
187− infics p1 = do
212+ infics p1 = do
188− o:p <- try (whitespace >> anyOp)
213+ o:p <- try (whitespace >> anyOp)
189− p2 <- (whitespace >> Pattern.term)
214+ p2 <- (whitespace >> Pattern.term)
190− return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
215+ return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
191− else [ PVar (o:p), p1, p2 ]
216+ else [ PVar (o:p), p1, p2 ]
192−
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+
193−assignExpr :: IParser [Def t v]
222+assignExpr :: IParser (Def t v)
194assignExpr = withPos $ do
223assignExpr = withPos $ do
195− fDefs <- funcDef
224+ (name:args) <- funcDef
196− whitespace
197− e <- string "=" >> whitespace >> expr
225+ whitespace >> string "=" >> whitespace
198− n <- sourceLine <$> getPosition
226+ body <- expr
199− runAt (1000 * n) $ Pattern.flatten fDefs e
227+ return . Def name $ makeFunction args body
200−
228+
201−anyDef =
229+typeAnnotation :: IParser (Def t v)
202− ((\d -> [d]) <$> Type.annotation) <|>
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)
203− assignExpr
237+def = typeAnnotation <|> assignExpr
204−
238+
205−def = map Definition <$> anyDef
239+attempt f parser str =
206−
207−parseDef str =
208− case iParse def "" str of
240+ case iParse parser "" str of
209− Right result -> Right result
241+ Right result -> f result
210− Left err -> Left $ "Parse error at " ++ show err
242+ Left err -> error $ "Parse error at " ++ show err
compiler/Parse/Foreign.hsdeleted−63
@@ -1,63 +0,0 @@
1−
2−module Parse.Foreign (foreignDef) where
3−
4−import Control.Applicative ((<$>), (<*>))
5−import Text.Parsec hiding (newline,spaces)
6−
7−import SourceSyntax.Declaration (Declaration(ExportEvent,ImportEvent))
8−import Parse.Helpers
9−import Parse.Expression (term)
10−import Parse.Type
11−import Types.Types (signalOf)
12−
13−foreignDef :: IParser (Declaration t v)
14−foreignDef = do try (reserved "foreign") ; whitespace
15− importEvent <|> exportEvent
16−
17−exportEvent :: IParser (Declaration t v)
18−exportEvent = do
19− try (reserved "export") >> whitespace >> reserved "jsevent" >> whitespace
20− js <- jsVar ; whitespace
21− elm <- lowVar ; whitespace
22− hasType ; whitespace
23− tipe <- typeExpr
24− case tipe of
25− ADTPT "Signal" [pt] ->
26− either error (return . ExportEvent js elm . signalOf) (toForeignType pt)
27− _ -> error "When exporting events, the exported value must be a Signal."
28−
29−importEvent :: IParser (Declaration t v)
30−importEvent = do
31− try (reserved "import") >> whitespace >> reserved "jsevent" >> whitespace
32− js <- jsVar ; whitespace
33− base <- term <?> "Base case for imported signal (signals cannot be undefined)"
34− whitespace
35− elm <- lowVar <?> "Name of imported signal"
36− whitespace ; hasType ; whitespace
37− tipe <- typeExpr
38− case tipe of
39− ADTPT "Signal" [pt] ->
40− either error (return . ImportEvent js base elm . signalOf) (toForeignType pt)
41− _ -> error "When importing events, the imported value must be a Signal."
42−
43−
44−jsVar :: IParser String
45−jsVar = betwixt '"' '"' $ do
46− v <- (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')
47− if v `notElem` jsReserveds then return v else
48− error $ "'" ++ v ++
49− "' is not a good name for a importing or exporting JS values."
50−
51−jsReserveds :: [String]
52−jsReserveds =
53− [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"
54− , "arguments", "int", "byte", "char", "goto", "long", "final", "float"
55− , "short", "double", "native", "throws", "boolean", "abstract", "volatile"
56− , "transient", "synchronized", "function", "break", "case", "catch"
57− , "continue", "debugger", "default", "delete", "do", "else", "finally"
58− , "for", "function", "if", "in", "instanceof", "new", "return", "switch"
59− , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"
60− , "const", "enum", "export", "extends", "import", "super", "implements"
61− , "interface", "let", "package", "private", "protected", "public"
62− , "static", "yield"
63− ]
compiler/Parse/Helpers.hs+38−18
@@ -4,10 +4,9 @@ import Control.Applicative ((<$>),(<*>))
4import Control.Monad
4import Control.Monad
5import Control.Monad.State
5import Control.Monad.State
6import Data.Char (isUpper)
6import Data.Char (isUpper)
7−import SourceSyntax.Helpers (isOp)
7+import SourceSyntax.Helpers as Help
8import SourceSyntax.Location as Location
8import SourceSyntax.Location as Location
9import SourceSyntax.Expression
9import SourceSyntax.Expression
10−import SourceSyntax.Rename (deprime)
11import Text.Parsec hiding (newline,spaces,State)
10import Text.Parsec hiding (newline,spaces,State)
12import Text.Parsec.Indent
11import Text.Parsec.Indent
13
12
@@ -39,8 +38,13 @@ lowVar = makeVar (lower <?> "lower case variable")
39capVar :: IParser String
38capVar :: IParser String
40capVar = makeVar (upper <?> "upper case variable")
39capVar = makeVar (upper <?> "upper case variable")
41
40
41+qualifiedVar :: IParser String
42+qualifiedVar = do
43+ vars <- many ((++) <$> capVar <*> string ".")
44+ (++) (concat vars) <$> lowVar
45+
42rLabel :: IParser String
46rLabel :: IParser String
43−rLabel = deprime <$> lowVar
47+rLabel = lowVar
44
48
45innerVarChar :: IParser Char
49innerVarChar :: IParser Char
46innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
50innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
@@ -56,10 +60,10 @@ reserved word =
56 <?> "reserved word '" ++ word ++ "'"
60 <?> "reserved word '" ++ word ++ "'"
57
61
58anyOp :: IParser String
62anyOp :: IParser String
59−anyOp = betwixt '`' '`' var <|> symOp <?> "infix operator (e.g. +, *, ||)"
63+anyOp = betwixt '`' '`' qualifiedVar <|> symOp <?> "infix operator (e.g. +, *, ||)"
60
64
61symOp :: IParser String
65symOp :: IParser String
62−symOp = do op <- many1 (satisfy isOp)
66+symOp = do op <- many1 (satisfy Help.isSymbol)
63 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
67 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
64 case op of
68 case op of
65 "." -> notFollowedBy lower >> return op
69 "." -> notFollowedBy lower >> return op
@@ -103,7 +107,14 @@ dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)
103spaceSep1 :: IParser a -> IParser [a]
107spaceSep1 :: IParser a -> IParser [a]
104spaceSep1 p = (:) <$> p <*> spacePrefix p
108spaceSep1 p = (:) <$> p <*> spacePrefix p
105
109
110+spacePrefix p = constrainedSpacePrefix p (\_ -> return ())
111+
112+constrainedSpacePrefix p constraint =
113+ many . try $ do
106−spacePrefix p = many (try (whitespace >> indented >> p))
114+ n <- whitespace
115+ constraint n
116+ indented
117+ p
107
118
108followedBy a b = do x <- a ; b ; return x
119followedBy a b = do x <- a ; b ; return x
109
120
@@ -134,7 +145,7 @@ addLocation expr = do
134accessible :: IParser (LExpr t v) -> IParser (LExpr t v)
145accessible :: IParser (LExpr t v) -> IParser (LExpr t v)
135accessible expr = do
146accessible expr = do
136 start <- getPosition
147 start <- getPosition
137− ce@(L s t e) <- expr
148+ ce@(L _ e) <- expr
138 let rest f = do
149 let rest f = do
139 let dot = char '.' >> notFollowedBy (char '.')
150 let dot = char '.' >> notFollowedBy (char '.')
140 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
151 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
@@ -150,34 +161,43 @@ accessible expr = do
150
161
151
162
152spaces :: IParser String
163spaces :: 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)
154
170
171+-- Just eats whitespace until the next meaningful character.
155−forcedWS :: IParser [String]
172+dumbWhitespace :: IParser String
156−forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)
173+dumbWhitespace = concat <$> many (spaces <|> newline)
157− where nl_space = try $ many1 newline >> spaces
158
174
159−whitespace :: IParser ()
175+whitespace :: IParser String
160−whitespace = optional forcedWS <?> ""
176+whitespace = option "" forcedWS <?> "whitespace"
161
177
162freshLine :: IParser [[String]]
178freshLine :: IParser [[String]]
163freshLine = try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""
179freshLine = try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""
164 where space_nl = try $ spaces >> many1 newline
180 where space_nl = try $ spaces >> many1 newline
165
181
166newline :: IParser String
182newline :: IParser String
167−newline = simpleNewline <|> lineComment <?> ""
183+newline = simpleNewline <|> lineComment <?> "newline"
168
184
169simpleNewline :: IParser String
185simpleNewline :: IParser String
170simpleNewline = try (string "\r\n") <|> string "\n"
186simpleNewline = try (string "\r\n") <|> string "\n"
171
187
172lineComment :: IParser String
188lineComment :: IParser String
173−lineComment = do try (string "--")
189+lineComment = do
190+ try (string "--")
174− manyTill anyChar $ simpleNewline <|> (eof >> return "\n")
191+ comment <- manyTill anyChar $ simpleNewline <|> (eof >> return "\n")
192+ return ("--" ++ comment)
175
193
176multiComment :: IParser String
194multiComment :: IParser String
177multiComment = do { try (string "{-"); closeComment }
195multiComment = do { try (string "{-"); closeComment }
178
196
179closeComment :: IParser String
197closeComment :: IParser String
198+closeComment = do
180−closeComment = manyTill anyChar . choice $
199+ comment <- manyTill anyChar . choice $
181 [ try (string "-}") <?> "close comment"
200 [ try (string "-}") <?> "close comment"
182 , do { try $ string "{-"; closeComment; closeComment }
201 , do { try $ string "{-"; closeComment; closeComment }
183− ]
202+ ]
203+ return ("{-" ++ comment ++ "-}")
compiler/Parse/Module.hs+17−19
@@ -6,7 +6,7 @@ import Data.List (intercalate)
6import Text.Parsec hiding (newline,spaces)
6import Text.Parsec hiding (newline,spaces)
7
7
8import Parse.Helpers
8import Parse.Helpers
9−import SourceSyntax.Module
9+import SourceSyntax.Module (Module(..), ImportMethod(..), Imports)
10
10
11varList :: IParser [String]
11varList :: IParser [String]
12varList = parens $ commaSep1 (var <|> parens symOp)
12varList = parens $ commaSep1 (var <|> parens symOp)
@@ -25,22 +25,20 @@ moduleDef = do
25imports :: IParser Imports
25imports :: IParser Imports
26imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
26imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
27
27
28−
29import' :: IParser (String, ImportMethod)
28import' :: IParser (String, ImportMethod)
30−import' = do
29+import' =
31− reserved "import"
30+ do reserved "import"
32− whitespace
31+ whitespace
33− open <- optionMaybe (reserved "open")
32+ open <- optionMaybe (reserved "open")
34− whitespace
33+ whitespace
35− name <- intercalate "." <$> dotSep1 capVar
34+ name <- intercalate "." <$> dotSep1 capVar
36− case open of
35+ case open of
37− Just _ -> return (name, Hiding [])
36+ Just _ -> return (name, Hiding [])
38− Nothing -> let how = try (whitespace >> (as' <|> importing'))
37+ Nothing -> let how = try (whitespace >> (as' <|> importing'))
39− in (,) name <$> option (Importing []) how
38+ in (,) name <$> option (As name) how
40−
39+ where
41−
42−as' :: IParser ImportMethod
40+ as' :: IParser ImportMethod
43−as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
41+ as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
44−
42+
45−importing' :: IParser ImportMethod
43+ importing' :: IParser ImportMethod
46−importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"
44+ 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−58
@@ -1,58 +0,0 @@
1−module Parse.Parser (parseProgram, parseDependencies, parseInfix) where
2−
3−import SourceSyntax.Module
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.Helpers
11−import Parse.Binop (infixStmt, OpTable)
12−import Parse.Expression
13−import Parse.Type
14−import Parse.Module
15−import Parse.Foreign
16−
17−statement = choice (typeAlias:defs) <|> def <?> "datatype or variable definition"
18− where defs = map ((:[]) <$>) [ foreignDef, datatype ]
19−
20−freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
21− freshLine
22− statement <?> "another datatype or variable definition"
23−
24−defs1 = do d <- statement <?> "at least one datatype or variable definition"
25− concat <$> (d:) <$> many freshDef
26−
27−program = do
28− optional freshLine
29− (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)
30− is <- (do try (lookAhead $ reserved "import")
31− imports `followedBy` freshLine) <|> return []
32− statements <- defs1
33− optional freshLine ; optional spaces ; eof
34− return $ Module names exports is statements
35−
36−parseProgram = setupParser program
37−
38−parseDependencies :: String -> Either String (String, [String])
39−parseDependencies =
40− setupParser $ do
41− optional skip
42− (,) <$> option "Main" moduleName <*> option [] imprts
43− where
44− skip = try (manyTill anyChar (try (string "/**")))
45− imprts = fmap (map fst) imports `followedBy` freshLine
46− getName = intercalate "." . fst
47− moduleName = do optional freshLine
48− getName <$> moduleDef `followedBy` freshLine
49−
50−parseInfix :: String -> Either String OpTable
51−parseInfix = setupParser . many $ do
52− manyTill (whitespace <|> (anyChar >> return ())) freshLine
53− infixStmt
54−
55−setupParser p source =
56− case iParse p "" source of
57− Right result -> Right result
58− Left err -> Left $ "Parse error at " ++ show err
compiler/Parse/Pattern.hs+6−10
@@ -1,10 +1,11 @@
1
1
2−module Parse.Pattern (term, expr, makeLambda, flatten) where
2+module Parse.Pattern (term, expr) where
3
3
4import Control.Applicative ((<$>),(<*>),pure)
4import Control.Applicative ((<$>),(<*>),pure)
5import Control.Monad
5import Control.Monad
6import Control.Monad.State
6import Control.Monad.State
7import Data.Char (isUpper)
7import Data.Char (isUpper)
8+import Data.List (intercalate)
8import Unique
9import Unique
9import Text.Parsec hiding (newline,spaces,State)
10import Text.Parsec hiding (newline,spaces,State)
10import Text.Parsec.Indent
11import Text.Parsec.Indent
@@ -12,7 +13,7 @@ import Text.Parsec.Indent
12import Parse.Helpers
13import Parse.Helpers
13import Parse.Literal
14import Parse.Literal
14import qualified SourceSyntax.Pattern as Pattern
15import qualified SourceSyntax.Pattern as Pattern
15−import SourceSyntax.Everything hiding (parens, tuple)
16+import SourceSyntax.Everything hiding (tuple)
16
17
17
18
18basic :: IParser Pattern
19basic :: IParser Pattern
@@ -53,7 +54,7 @@ term =
53
54
54patternConstructor :: IParser Pattern
55patternConstructor :: IParser Pattern
55patternConstructor = do
56patternConstructor = do
56− v <- capVar
57+ v <- intercalate "." <$> dotSep1 capVar
57 case v of
58 case v of
58 "True" -> return $ PLiteral (Boolean True)
59 "True" -> return $ PLiteral (Boolean True)
59 "False" -> return $ PLiteral (Boolean False)
60 "False" -> return $ PLiteral (Boolean False)
@@ -64,13 +65,7 @@ expr = do
64 patterns <- consSep1 (patternConstructor <|> term)
65 patterns <- consSep1 (patternConstructor <|> term)
65 asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
66 asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
66
67
67−makeLambda :: [Pattern] -> LExpr t v -> Unique (LExpr t v)
68+{--
68−makeLambda pats body = go (reverse pats) body
69− where go [] body = return body
70− go (p:ps) body@(L t s _) = do
71− (x,e) <- extract p body
72− go ps (L t s $ Lambda x e)
73−
74extract :: Pattern -> LExpr t v -> Unique (String, LExpr t v)
69extract :: Pattern -> LExpr t v -> Unique (String, LExpr t v)
75extract pattern body@(L t s _) =
70extract pattern body@(L t s _) =
76 let loc = L t s in
71 let loc = L t s in
@@ -136,3 +131,4 @@ matchSingle pat exp@(L t s _) p =
136 return (FnDef a [] exp : map toDef fs)
131 return (FnDef a [] exp : map toDef fs)
137
132
138 PAnything -> return []
133 PAnything -> return []
134+--}
compiler/Parse/Type.hs+67−163
@@ -7,171 +7,75 @@ import Data.List (lookup,intercalate)
7import Text.Parsec
7import Text.Parsec
8import Text.Parsec.Indent
8import Text.Parsec.Indent
9
9
10−import SourceSyntax.Location as Located
10+import SourceSyntax.Type as T
11−import SourceSyntax.Expression
12−import SourceSyntax.Declaration
13import Parse.Helpers
11import Parse.Helpers
14−import Types.Types hiding (parens,string)
15import Unique
12import Unique
16
13
17−data ParseType = VarPT String
14+tvar :: IParser T.Type
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"
15+tvar = T.Var <$> lowVar <?> "type variable"
28−
16+
29−typeList :: IParser ParseType
17+list :: IParser T.Type
30−typeList = listPT <$> braces typeExpr
18+list = listOf <$> braces expr
31−
19+
32−typeTuple :: IParser ParseType
20+tuple :: IParser T.Type
33−typeTuple = do ts <- parens (commaSep typeExpr)
21+tuple = do ts <- parens (commaSep expr)
34− return $ case ts of { [t] -> t ; _ -> tuplePT ts }
22+ return $ case ts of
35−
23+ [t] -> t
36−typeRecord :: IParser ParseType
24+ _ -> tupleOf ts
37−typeRecord = brackets (RecordPT <$> extend <*> fields)
25+
38− where extend = optionMaybe . try $ do
26+record :: IParser T.Type
39− t <- typeVar
27+record =
40− whitespace >> string "|" >> whitespace
28+ do char '{' ; whitespace
41− return t
29+ ext <- extend
42− fields = commaSep $ do
30+ fs <- fields
43− lbl <- rLabel
31+ dumbWhitespace ; char '}'
44− whitespace >> hasType >> whitespace
32+ return (T.Record fs ext)
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 [Declaration t v]
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 extension kvs ->
88− [toConstructor start end alias extension kvs]
89− _ -> []
90−
91−toConstructor start end alias Nothing kvs =
92− Definition (FnDef alias args (loc (Record rec)))
93− where
94− loc = Located.at start end
95− args = map fst kvs
96− rec = map (\a -> (a, [], loc (Var a))) args
97−toConstructor start end alias (Just _) kvs =
98− Definition (FnDef alias (args++["_ext_"]) (loc rec))
99 where
33 where
100− loc = Located.at start end
34+ extend = option T.EmptyRecord . try $ do
101− args = map fst kvs
35+ t <- tvar
102− rec = foldl insert (Var "_ext_") (zip args (map (loc . Var) args))
36+ whitespace >> string "|" >> whitespace
103− insert e (k,v) = Insert (loc e) k v
37+ return t
104−
38+ fields = commaSep $ do
105−annotation :: IParser (Def t v)
39+ lbl <- rLabel
106−annotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)
107− where start = do v <- lowVar <|> parens symOp
108− whitespace ; hasType ; whitespace ; return v
40+ whitespace >> hasType >> whitespace
109−
41+ (,) lbl <$> expr
110−datatype :: IParser (Declaration t v)
42+
111−datatype = do
43+capTypeVar = intercalate "." <$> dotSep1 capVar
112− reserved "data" <?> "datatype definition (data T = A | B | ...)"
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"
113− forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar
56+ args <- spacePrefix term
114− whitespace ; string "=" ; whitespace
57+ return (T.Data name args)
115− tcs <- pipeSep1 typeConstructor
116− case toDatatype name args tcs of
117− Right dt -> return dt
118− Left msg -> fail msg
119−
120−beta = liftM VarT guid
121−
122−toType :: ParseType -> Type
123−toType pt =
124− let frees :: ParseType -> [String]
125− frees pt = case pt of
126− LambdaPT a b -> frees a ++ frees b
127− ADTPT _ ts -> concatMap frees ts
128− RecordPT t fs -> maybe [] frees t ++ concatMap (frees . snd) fs
129− VarPT (c:cs) | isLower c -> [c:cs]
130− | otherwise -> []
131− in case toTypeWith "" (zip (frees pt) [1..]) pt of
132− Right t -> t
133− Left _ -> VarT 0
134−
135−toTypeWith :: String -> [(String,X)] -> ParseType -> Either String Type
136−toTypeWith name tvarDict pt =
137− let msg x = "Type variable '" ++ x ++ "' is unbound in type '" ++ name ++ "'."
138− toT = toTypeWith name tvarDict
139− in case pt of
140− LambdaPT t1 t2 -> (==>) <$> toT t1 <*> toT t2
141− ADTPT name args -> ADT name <$> mapM toT args
142− RecordPT t fs -> do fs' <- mapM (\(x,pt) -> (,) x <$> toT pt) fs
143− ext <- maybe (return EmptyRecord) toT t
144− return (RecordT (recordT fs') ext)
145− VarPT x@(c:_)
146− | not (isLower c) -> return $ ADT x []
147− | otherwise -> VarT <$> case lookup x tvarDict of
148− Just v -> Right v
149− Nothing -> Left (msg x)
150−
151−
152−toDatatype name args tcs = Datatype name [1..n] <$> mapM toC tcs
153− where n = length args
154− toType = toTypeWith name (zip args [1..n])
155− toC (name,pt) = (,) name <$> mapM toType pt
156−
157−
158−toForeignType (LambdaPT t1 t2) =
159− fail $ "Elm's JavaScript event interface does not yet handle functions. " ++
160− "Only simple values can be imported and exported in this release."
161−
162−toForeignType (ADTPT "JSArray" args) =
163− ADT "JSArray" <$> mapM toForeignType args
164−
165−toForeignType (ADTPT name _) =
166− Left $ "'" ++ name ++ "' is not an exportable type " ++
167− "constructor. Only 'JSArray' is exportable."
168−
169−toForeignType (VarPT x@(c:_))
170− | x `elem` jsTypes = Right (ADT x [])
171− | isLower c =
172− Left $ "All exported types must be concrete types." ++ msg
173− | otherwise =
174− Left $ "'" ++ x ++ "' is not an exportable type." ++ msg
175 where
58 where
176− msg = " The following types are exportable: " ++ intercalate ", " jsTypes
59+ tupleCtor = do
177− jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]
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/Paths_Elm.hs → compiler/Paths_El.hsrenamed

The content is the same.

compiler/SourceSyntax/Declaration.hs+5−5
@@ -3,16 +3,16 @@ module SourceSyntax.Declaration where
3
3
4import Data.Data
4import Data.Data
5import qualified SourceSyntax.Expression as Expr
5import qualified SourceSyntax.Expression as Expr
6−import Types.Types
6+import SourceSyntax.Type
7
7
8data Declaration tipe var
8data Declaration tipe var
9 = Definition (Expr.Def tipe var)
9 = Definition (Expr.Def tipe var)
10− | Datatype String [X] [(String,[Type])]
10+ | Datatype String [String] [(String,[Type])]
11− | TypeAlias String [X] Type
11+ | TypeAlias String [String] Type
12 | ImportEvent String (Expr.LExpr tipe var) String Type
12 | ImportEvent String (Expr.LExpr tipe var) String Type
13 | ExportEvent String String Type
13 | ExportEvent String String Type
14 | Fixity Assoc Int String
14 | Fixity Assoc Int String
15− deriving (Eq, Show, Data, Typeable)
15+ deriving (Eq, Show)
16
16
17data Assoc = L | N | R
17data Assoc = L | N | R
18− deriving (Eq, Show, Data, Typeable)
18+ deriving (Eq, Show)
compiler/SourceSyntax/Everything.hs+2−4
@@ -5,15 +5,13 @@ module SourceSyntax.Everything
5 module SourceSyntax.Pattern,
5 module SourceSyntax.Pattern,
6 module SourceSyntax.Expression,
6 module SourceSyntax.Expression,
7 module SourceSyntax.Declaration,
7 module SourceSyntax.Declaration,
8− module SourceSyntax.Module,
8+ module SourceSyntax.Module
9− module SourceSyntax.Rename
10 ) where
9 ) where
11
10
12import SourceSyntax.Helpers
11import SourceSyntax.Helpers
13import SourceSyntax.Location
12import SourceSyntax.Location
14import SourceSyntax.Literal
13import SourceSyntax.Literal
15−import SourceSyntax.Pattern hiding (tuple, list, cons, nil)
14+import SourceSyntax.Pattern hiding (tuple, list, cons, nil, prettyParens)
16import SourceSyntax.Expression
15import SourceSyntax.Expression
17import SourceSyntax.Declaration hiding (Assoc(..))
16import SourceSyntax.Declaration hiding (Assoc(..))
18import SourceSyntax.Module
17import SourceSyntax.Module
19−import SourceSyntax.Rename
compiler/SourceSyntax/Expression.hs+96−66
@@ -4,97 +4,127 @@ module SourceSyntax.Expression where
4import Data.Data
4import Data.Data
5import Data.List (intercalate)
5import Data.List (intercalate)
6import qualified Text.Pandoc as Pandoc
6import qualified Text.Pandoc as Pandoc
7+import SourceSyntax.PrettyPrint
8+import Text.PrettyPrint as P
7import qualified SourceSyntax.Helpers as Help
9import qualified SourceSyntax.Helpers as Help
8import qualified SourceSyntax.Location as Location
10import qualified SourceSyntax.Location as Location
9import qualified SourceSyntax.Pattern as Pattern
11import qualified SourceSyntax.Pattern as Pattern
12+import qualified SourceSyntax.Type as Type
10import qualified SourceSyntax.Literal as Literal
13import qualified SourceSyntax.Literal as Literal
11−import Types.Types
12
14
13type LExpr tipe var = Location.Located (Expr tipe var)
15type LExpr tipe var = Location.Located (Expr tipe var)
14data Expr t v
16data Expr t v
15 = Literal Literal.Literal
17 = Literal Literal.Literal
16 | Var String
18 | Var String
17 | Range (LExpr t v) (LExpr t v)
19 | Range (LExpr t v) (LExpr t v)
18− | Access (LExpr t v) String
20+ | ExplicitList [LExpr t v]
19− | Remove (LExpr t v) String
20− | Insert (LExpr t v) String (LExpr t v)
21− | Modify (LExpr t v) [(String, LExpr t v)]
22− | Record [(String, [String], LExpr t v)]
23 | Binop String (LExpr t v) (LExpr t v)
21 | Binop String (LExpr t v) (LExpr t v)
24− | Lambda String (LExpr t v)
22+ | Lambda Pattern.Pattern (LExpr t v)
25 | App (LExpr t v) (LExpr t v)
23 | App (LExpr t v) (LExpr t v)
26 | MultiIf [(LExpr t v,LExpr t v)]
24 | MultiIf [(LExpr t v,LExpr t v)]
27 | Let [Def t v] (LExpr t v)
25 | Let [Def t v] (LExpr t v)
28 | Case (LExpr t v) [(Pattern.Pattern, LExpr t v)]
26 | Case (LExpr t v) [(Pattern.Pattern, LExpr t v)]
29− | ExplicitList [LExpr t v]
30 | Data String [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)]
31 | Markdown Pandoc.Pandoc
33 | Markdown Pandoc.Pandoc
32− deriving (Eq, Data, Typeable)
34+ deriving (Eq, Show, Data, Typeable)
33
35
34data Def tipe var
36data Def tipe var
35− = FnDef String [String] (LExpr tipe var)
37+ = Def Pattern.Pattern (LExpr tipe var)
36− | OpDef String String String (LExpr tipe var)
37− | TypeAnnotation String Type
38+ | TypeAnnotation String Type.Type
38− deriving (Eq, Data, Typeable)
39+ deriving (Eq, Show, Data, Typeable)
39
40
40−tuple es = Data ("Tuple" ++ show (length es)) es
41+tuple es = Data ("_Tuple" ++ show (length es)) es
41
42
42−delist (Location.L _ _ (Data "::" [h,t])) = h : delist t
43+delist (Location.L _ (Data "::" [h,t])) = h : delist t
43delist _ = []
44delist _ = []
44
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
45
96
46−instance Show (Expr t v) where
47− show e =
48− let show' (Location.L _ _ e) = Help.parensIf (needsParens e) (show e) in
49− case e of
50− Literal lit -> show lit
51− Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
52− Access e x -> show' e ++ "." ++ x
53− Remove e x -> Help.brkt (show e ++ " - " ++ x)
54− Insert (Location.L _ _ (Remove e y)) x v ->
55− Help.brkt (show e ++ " - " ++ y ++ " | " ++ x ++ " = " ++ show v)
56− Insert e x v -> Help.brkt (show e ++ " | " ++ x ++ " = " ++ show v)
57− Modify e fs -> Help.brkt (show e ++" | "++ intercalate ", " (map field fs))
58− where field (x,e) = x ++ " <- " ++ show e
59− Record r -> Help.brkt (intercalate ", " (map fields r))
60− where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e
61− Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2
62− Lambda x e -> let (xs,e') = getLambdas (Location.none $ Lambda x e) in
63− concat [ "\\", intercalate " " xs, " -> ", show e' ]
64− App e1 e2 -> show' e1 ++ " " ++ show' e2
65− MultiIf (p:ps) -> concat [ "if | ", iff p, sep (map iff ps) ]
66− where iff (b,e) = show b ++ " -> " ++ show e
67− sep = concatMap ("\n | " ++)
68− Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e
69− Var (c:cs) -> if Help.isOp c then Help.parens (c:cs) else c:cs
70− Case e pats -> "case "++ show e ++" of " ++ Help.brkt (intercalate " ; " pats')
71− where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
72− ExplicitList es -> "[" ++ intercalate "," (map show es) ++ "]"
73− Data "::" [h,t] -> show h ++ " :: " ++ show t
74− Data "[]" [] -> "[]"
75− Data name es -> name ++ " " ++ intercalate " " (map show' es)
76− Markdown _ -> "[markdown| ... |]"
97+ Markdown _ -> P.text "[markdown| ... |]"
77
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
78
106
79−instance Show (Def t v) where
107+collectApps lexpr@(Location.L _ expr) =
80− show e =
81− case e of
108+ case expr of
82− FnDef v [] e -> v ++ " = " ++ show e
109+ App a b -> collectApps a ++ [b]
83− FnDef f args e -> f ++ concatMap (' ':) args ++ " = " ++ show e
110+ _ -> [lexpr]
84− OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e
85− TypeAnnotation n t -> n ++ " : " ++ show t
86
111
87−getLambdas (Location.L _ _ (Lambda x e)) = (x:xs,e')
112+collectLambdas lexpr@(Location.L _ expr) =
88− where (xs,e') = getLambdas e
113+ case expr of
89−getLambdas e = ([],e)
114+ Lambda pattern body ->
115+ let (ps, body') = collectLambdas body
116+ in (pretty pattern : ps, body')
117+ _ -> ([], lexpr)
90
118
91−needsParens e =
119+prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
120+ where
121+ needed =
92− case e of
122+ case expr of
93− Binop _ _ _ -> True
123+ Binop _ _ _ -> True
94− Lambda _ _ -> True
124+ Lambda _ _ -> True
95− App _ _ -> True
125+ App _ _ -> True
96− MultiIf _ -> True
126+ MultiIf _ -> True
97− Let _ _ -> True
127+ Let _ _ -> True
98− Case _ _ -> True
128+ Case _ _ -> True
99− Data name (x:xs) -> name /= "::"
129+ Data name (x:xs) -> name /= "::"
100− _ -> False
130+ _ -> False
compiler/SourceSyntax/Helpers.hs+11−4
@@ -1,11 +1,18 @@
1
1
2module SourceSyntax.Helpers where
2module SourceSyntax.Helpers where
3
3
4−import Data.Char (isSymbol)
4+import qualified Data.Char as Char
5
5
6+brkt :: String -> String
6brkt s = "{ " ++ s ++ " }"
7brkt s = "{ " ++ s ++ " }"
7
8
8−parens s = "(" ++ s ++ ")"
9+isTuple :: String -> Bool
9−parensIf b s = if b then parens s else s
10+isTuple name =
11+ take 6 name == "_Tuple" && all Char.isDigit (drop 6 name)
10
12
13+isOp :: String -> Bool
14+isOp = all isSymbol
15+
16+isSymbol :: Char -> Bool
17+isSymbol c =
11−isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
18+ Char.isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
compiler/SourceSyntax/Literal.hs+11−10
@@ -2,20 +2,21 @@
2module SourceSyntax.Literal where
2module SourceSyntax.Literal where
3
3
4import Data.Data
4import Data.Data
5+import SourceSyntax.PrettyPrint
6+import qualified Text.PrettyPrint as PP
5
7
6data Literal = IntNum Int
8data Literal = IntNum Int
7 | FloatNum Float
9 | FloatNum Float
8 | Chr Char
10 | Chr Char
9 | Str String
11 | Str String
10 | Boolean Bool
12 | Boolean Bool
11− deriving (Eq, Ord, Data, Typeable)
13+ deriving (Eq, Ord, Data, Typeable, Show)
12
14
13−
14−instance Show Literal where
15+instance Pretty Literal where
15− show e =
16+ pretty literal =
16− case e of
17+ case literal of
17− IntNum n -> show n
18+ IntNum n -> PP.int n
18− FloatNum n -> show n
19+ FloatNum n -> PP.float n
19− Chr c -> show c
20+ Chr c -> PP.quotes (PP.char c)
20− Str s -> show s
21+ Str s -> PP.text (show s)
21− Boolean b -> show b
22+ Boolean bool -> PP.text (show bool)
compiler/SourceSyntax/Location.hs+40−23
@@ -1,43 +1,60 @@
1{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2module SourceSyntax.Location where
2module SourceSyntax.Location where
3
3
4−import Text.Parsec.Pos
5import Data.Data
4import Data.Data
5+import Text.PrettyPrint
6+import SourceSyntax.PrettyPrint
7+import qualified Text.Parsec.Pos as Parsec
6
8
7−data SrcPos = Pos Int Int
9+data SrcPos = Pos { line :: Int, column :: Int }
8 deriving (Eq, Ord, Data, Typeable)
10 deriving (Eq, Ord, Data, Typeable)
9
11
10−data SrcSpan = Span SrcPos SrcPos | NoSpan
12+data SrcSpan = Span SrcPos SrcPos String | NoSpan String
11 deriving (Eq, Ord, Data, Typeable)
13 deriving (Eq, Ord, Data, Typeable)
12
14
15+data Located e = L SrcSpan e
13−data Located e = L (Maybe String) SrcSpan e deriving (Eq,Ord, Data, Typeable)
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
14
40
15
41
16instance Show SrcPos where
42instance Show SrcPos where
17− show (Pos r c) = "Line " ++ show r ++ ", Column " ++ show c
43+ show (Pos r c) = show r ++ "," ++ show c
18
44
19instance Show SrcSpan where
45instance Show SrcSpan where
20 show span =
46 show span =
21 case span of
47 case span of
22− Span start end -> show start
23− NoSpan -> ""
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)
24
54
25instance Show e => Show (Located e) where
55instance Show e => Show (Located e) where
26− show (L _ _ e) = show e
56+ show (L s e) = "L (" ++ show s ++ ") (" ++ show e ++ ")"
27−
28−
29
57
30−none = L Nothing NoSpan
58+instance Pretty a => Pretty (Located a) where
31−
59+ pretty (L _ e) = pretty e
32−at start end = L Nothing
33− (Span (Pos (sourceLine start) (sourceColumn start))
34− (Pos (sourceLine end ) (sourceColumn end )))
35−
36−merge (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
60
42−add x (L Nothing span e) = L (Just (show x)) span e
43−add x (L txt span e) = L txt span e
compiler/SourceSyntax/Module.hs+35−7
@@ -2,13 +2,20 @@
2module SourceSyntax.Module where
2module SourceSyntax.Module where
3
3
4import Data.Data
4import Data.Data
5+import Data.Binary
5import Data.List (intercalate)
6import 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)
6−import qualified SourceSyntax.Declaration as Decl
12+import SourceSyntax.Declaration
13+import SourceSyntax.Type
7import System.FilePath (joinPath)
14import System.FilePath (joinPath)
8−import Types.Types
15+import qualified Type.Type as Type
9
16
10data Module tipe var =
17data Module tipe var =
11− Module [String] Exports Imports [Decl.Declaration tipe var]
18+ Module [String] Exports Imports [Declaration tipe var]
12 deriving (Show)
19 deriving (Show)
13
20
14type Exports = [String]
21type Exports = [String]
@@ -17,8 +24,29 @@ type Imports = [(String, ImportMethod)]
17data ImportMethod = As String | Importing [String] | Hiding [String]
24data ImportMethod = As String | Importing [String] | Hiding [String]
18 deriving (Eq, Ord, Show, Data, Typeable)
25 deriving (Eq, Ord, Show, Data, Typeable)
19
26
20−name :: Module a b -> String
27+data MetadataModule t v = MetadataModule {
21−name (Module names _ _ _) = intercalate "." names
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
22
49
23−path :: Module a b -> FilePath
50+instance Binary ModuleInterface where
24−path (Module names _ _ _) = joinPath names
51+ put modul = put (iTypes modul) >> put (iAdts modul) >> put (iAliases modul)
52+ get = ModuleInterface <$> get <*> get <*> get
compiler/SourceSyntax/Pattern.hs+29−20
@@ -1,11 +1,12 @@
1{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2module SourceSyntax.Pattern where
2module SourceSyntax.Pattern where
3
3
4−import Data.Char (isDigit)
5import Data.List (intercalate)
4import Data.List (intercalate)
6import Data.Data
5import Data.Data
7−import SourceSyntax.Helpers
6+import SourceSyntax.Helpers as Help
7+import SourceSyntax.PrettyPrint
8+import Text.PrettyPrint as PP
8−import qualified SourceSyntax.Literal as Literal
9+import SourceSyntax.Literal as Literal
9
10
10data Pattern = PData String [Pattern]
11data Pattern = PData String [Pattern]
11 | PRecord [String]
12 | PRecord [String]
@@ -13,27 +14,35 @@ data Pattern = PData String [Pattern]
13 | PVar String
14 | PVar String
14 | PAnything
15 | PAnything
15 | PLiteral Literal.Literal
16 | PLiteral Literal.Literal
16− deriving (Eq, Ord, Data, Typeable)
17+ deriving (Eq, Ord, Data, Typeable, Show)
17
18
18cons h t = PData "::" [h,t]
19cons h t = PData "::" [h,t]
19nil = PData "[]" []
20nil = PData "[]" []
20list = foldr cons nil
21list = foldr cons nil
21−tuple es = PData ("Tuple" ++ show (length es)) es
22+tuple es = PData ("_Tuple" ++ show (length es)) es
22
23
23
24
24−instance Show Pattern where
25+instance Pretty Pattern where
25− show p =
26+ pretty pattern =
26− case p of
27+ case pattern of
27− PVar x -> x
28+ PVar x -> variable x
28− PLiteral lit -> show lit
29+ PLiteral lit -> pretty lit
29− PRecord fs -> brkt (intercalate ", " fs)
30+ PRecord fs -> PP.braces (commaCat $ map PP.text fs)
30− PAlias x p -> show p ++ " as " ++ x
31+ PAlias x p -> prettyParens p <+> PP.text "as" <+> PP.text x
31− PAnything -> "_"
32+ PAnything -> PP.text "_"
32− PData "::" [hd@(PData "::" _),tl] ->
33+ PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
33− parens (show hd) ++ " :: " ++ show tl
34+ where isCons = case hd of
34− PData "::" [hd,tl] -> show hd ++ " :: " ++ show tl
35+ PData "::" _ -> True
35− PData "[]" [] -> "[]"
36+ _ -> False
36 PData name ps ->
37 PData name ps ->
37− if take 5 name == "Tuple" && all isDigit (drop 5 name) then
38+ if isTuple name then
38− parens . intercalate ", " $ map show ps
39+ PP.parens . commaCat $ map pretty ps
39− else parensIf (not (null ps)) $ unwords (name : map show 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/Rename.hsdeleted−164
@@ -1,164 +0,0 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−module SourceSyntax.Rename (renameModule, derename, deprime) where
3−
4−import Control.Arrow (first)
5−import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
6−import Control.Monad.State (evalState, State, get, put)
7−import Data.Char (isLower,isDigit)
8−import qualified Data.Map as Map
9−import Unique
10−import SourceSyntax.Location
11−import SourceSyntax.Pattern
12−import SourceSyntax.Expression
13−import SourceSyntax.Declaration hiding (Assoc(..))
14−import SourceSyntax.Module
15−
16−derename var
17− | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
18− | otherwise = var
19−
20−renameModule :: Module t v -> Module t v
21−renameModule modul = run (rename Map.empty modul)
22−
23−type Env = Map.Map String String
24−
25−replace :: Env -> String -> String
26−replace env v =
27− Map.findWithDefault (deprime v) v env
28−
29−class Rename a where
30− rename :: Env -> a -> Unique a
31−
32−instance Rename (Module t v) where
33− rename env (Module name ex im stmts) = do stmts' <- renameStmts env stmts
34− return (Module name ex im stmts')
35−
36−instance Rename (Def t v) where
37− rename env (OpDef op a1 a2 e) =
38− do env' <- extends env [a1,a2]
39− OpDef op (replace env' a1) (replace env' a2) `liftM` rename env' e
40− rename env (FnDef f args e) =
41− do env' <- extends env args
42− FnDef (replace env f) (map (replace env') args) `liftM` rename env' e
43− rename env (TypeAnnotation n t) = return (TypeAnnotation (replace env n) t)
44−
45−
46−instance Rename (Declaration t v) where
47− rename env stmt =
48− case stmt of
49− Definition def -> Definition `liftM` rename env def
50− Datatype name args tcs ->
51− return $ Datatype name args $ map (first $ replace env) tcs
52− TypeAlias n xs t -> return (TypeAlias n xs t)
53− ImportEvent js base elm tipe ->
54− do base' <- rename env base
55− return $ ImportEvent js base' (replace env elm) tipe
56− ExportEvent js elm tipe ->
57− return $ ExportEvent js (replace env elm) tipe
58−
59−renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
60− mapM (rename env') stmts
61− where getNames stmt = case stmt of
62− Definition (FnDef n _ _) -> [n]
63− Datatype _ _ tcs -> map fst tcs
64− ImportEvent _ _ n _ -> [n]
65− _ -> []
66−
67−instance Rename a => Rename (Located a) where
68− rename env (L t s e) = L t s `liftM` rename env e
69−
70−instance Rename (Expr t v) where
71− rename env expr =
72− let rnm = rename env in
73− case expr of
74−
75− Range e1 e2 -> Range `liftM` rnm e1
76− `ap` rnm e2
77−
78− Access e x -> Access `liftM` rnm e
79− `ap` return x
80−
81− Remove e x -> flip Remove x `liftM` rnm e
82−
83− Insert e x v -> flip Insert x `liftM` rnm e
84− `ap` rnm v
85−
86− Modify e fs -> Modify `liftM` rnm e
87− `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
88−
89− Record fs -> Record `liftM` mapM frnm fs
90− where frnm (f,as,e) = do
91− env' <- extends env as
92− e' <- rename env' e
93− return (f, map (replace env') as, e')
94−
95− Binop op@(h:_) e1 e2 ->
96− let rop = if isLower h || '_' == h
97− then replace env op
98− else op
99− in Binop rop `liftM` rnm e1
100− `ap` rnm e2
101−
102− Lambda x e -> do
103− (rx, env') <- extend env x
104− Lambda rx `liftM` rename env' e
105−
106− App e1 e2 -> App `liftM` rnm e1
107− `ap` rnm e2
108−
109− MultiIf ps -> MultiIf `liftM` mapM grnm ps
110− where grnm (b,e) = (,) `liftM` rnm b
111− `ap` rnm e
112−
113− Let defs e -> renameLet env defs e
114−
115− Var x -> return $ Var (replace env x)
116−
117− Data name es -> Data name `liftM` mapM rnm es
118−
119− ExplicitList es -> ExplicitList `liftM` mapM rnm es
120−
121− Case e cases -> Case `liftM` rnm e
122− `ap` mapM (patternRename env) cases
123−
124− _ -> return expr
125−
126−deprime = map (\c -> if c == '\'' then '$' else c)
127−
128−extend :: Env -> String -> Unique (String, Env)
129−extend env x = do
130− n <- guid
131− let rx = deprime x ++ "_" ++ show n
132− return (rx, Map.insert x rx env)
133−
134−extends :: Env -> [String] -> Unique Env
135−extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
136−
137−patternExtend :: Pattern -> Env -> Unique (Pattern, Env)
138−patternExtend pattern env =
139− case pattern of
140− PLiteral _ -> return (pattern, env)
141− PAnything -> return (pattern, env)
142− PVar x -> first PVar `liftM` extend env x
143− PAlias x p -> do
144− (x', env') <- extend env x
145− (p', env'') <- patternExtend p env'
146− return (PAlias x' p', env'')
147− PData name ps ->
148− first (PData name . reverse) `liftM` foldM f ([], env) ps
149− where f (rps,env') p = do (rp,env'') <- patternExtend p env'
150− return (rp:rps, env'')
151− PRecord fs ->
152− return (pattern, Map.union (Map.fromList $ map (\f -> (f,f)) fs) env)
153−
154−patternRename :: Env -> (Pattern, LExpr t v) -> Unique (Pattern, LExpr t v)
155−patternRename env (p,e) = do
156− (rp,env') <- patternExtend p env
157− re <- rename env' e
158− return (rp,re)
159−
160−renameLet env defs e = do env' <- extends env $ concatMap getNames defs
161− defs' <- mapM (rename env') defs
162− Let defs' `liftM` rename env' e
163− where getNames (FnDef n _ _) = [n]
164− getNames _ = []
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/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+15−27
@@ -3,7 +3,6 @@ module Transform.Optimize (optimize) where
3import SourceSyntax.Everything
3import SourceSyntax.Everything
4import Control.Arrow (second, (***))
4import Control.Arrow (second, (***))
5import Data.Char (isAlpha)
5import Data.Char (isAlpha)
6−import Transform.Substitute
7
6
8optimize (Module name ims exs stmts) =
7optimize (Module name ims exs stmts) =
9 Module name ims exs (map optimizeStmt stmts)
8 Module name ims exs (map optimizeStmt stmts)
@@ -20,12 +19,11 @@ instance Simplify (Declaration t v) where
20 simp stmt = stmt
19 simp stmt = stmt
21
20
22instance Simplify (Def t v) where
21instance Simplify (Def t v) where
23− simp (FnDef func args e) = FnDef func args (simp e)
22+ simp (Def name e) = Def name (simp e)
24− simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)
25 simp x = x
23 simp x = x
26
24
27instance Simplify e => Simplify (Located e) where
25instance Simplify e => Simplify (Located e) where
28− simp (L t s e) = L t s (simp e)
26+ simp (L s e) = L s (simp e)
29
27
30instance Simplify (Expr t v) where
28instance Simplify (Expr t v) where
31 simp expr =
29 simp expr =
@@ -34,11 +32,7 @@ instance Simplify (Expr t v) where
34 Range e1 e2 -> Range (f e1) (f e2)
32 Range e1 e2 -> Range (f e1) (f e2)
35 Binop op e1 e2 -> binop op (f e1) (f e2)
33 Binop op e1 e2 -> binop op (f e1) (f e2)
36 Lambda x e -> Lambda x (f e)
34 Lambda x e -> Lambda x (f e)
37− Record fs -> Record (map (\(f,as,e) -> (f, as, simp e)) fs)
35+ Record fs -> Record (map (second simp) fs)
38− App (L t s (Lambda x e1)) e2 ->
39− if isValue e2' then subst x e2' e1' else App (L t s (Lambda x ce1')) ce2'
40− where ce1'@(L _ _ e1') = f e1
41− ce2'@(L _ _ e2') = f e2
42 App e1 e2 -> App (f e1) (f e2)
36 App e1 e2 -> App (f e1) (f e2)
43 Let defs e -> Let (map simp defs) (f e)
37 Let defs e -> Let (map simp defs) (f e)
44 Data name es -> Data name (map f es)
38 Data name es -> Data name (map f es)
@@ -50,7 +44,7 @@ instance Simplify (Expr t v) where
50clipBranches [] = []
44clipBranches [] = []
51clipBranches (e:es) =
45clipBranches (e:es) =
52 case e of
46 case e of
53− (L _ _ (Literal (Boolean True)), _) -> [e]
47+ (L _ (Literal (Boolean True)), _) -> [e]
54 _ -> e : clipBranches es
48 _ -> e : clipBranches es
55
49
56
50
@@ -62,9 +56,9 @@ isValue e =
62 _ -> False
56 _ -> False
63
57
64
58
65−binop op ce1@(L t1 s1 e1) ce2@(L t2 s2 e2) =
59+binop op ce1@(L s1 e1) ce2@(L s2 e2) =
66− let c1 = L t1 s1
60+ let c1 = L s1
67− c2 = L t2 s2
61+ c2 = L s2
68 int = Literal . IntNum
62 int = Literal . IntNum
69 str = Literal . Str
63 str = Literal . Str
70 bool = Literal . Boolean
64 bool = Literal . Boolean
@@ -92,18 +86,18 @@ binop op ce1@(L t1 s1 e1) ce2@(L t2 s2 e2) =
92 ("*", _, IntNum n) -> binop "*" ce2 ce1
86 ("*", _, IntNum n) -> binop "*" ce2 ce1
93
87
94 ("+", IntNum 0, _) -> e2
88 ("+", IntNum 0, _) -> e2
95− ("+", IntNum n, Binop "+" (L _ _ (IntNum m)) ce) ->
89+ ("+", IntNum n, Binop "+" (L _ (IntNum m)) ce) ->
96 binop "+" (c1 $ IntNum (n+m)) ce
90 binop "+" (c1 $ IntNum (n+m)) ce
97− ("+", Binop "+" (L _ _ (IntNum n)) ce1'
91+ ("+", Binop "+" (L _ (IntNum n)) ce1'
98− , Binop "+" (L _ _ (IntNum m)) ce2') ->
92+ , Binop "+" (L _ (IntNum m)) ce2') ->
99 binop "+" (none $ IntNum (n+m)) (none $ Binop "+" ce1' ce2')
93 binop "+" (none $ IntNum (n+m)) (none $ Binop "+" ce1' ce2')
100
94
101 ("*", IntNum 0, _) -> e1
95 ("*", IntNum 0, _) -> e1
102 ("*", IntNum 1, _) -> e2
96 ("*", IntNum 1, _) -> e2
103− ("*", IntNum n, Binop "*" (L _ _ (IntNum m)) ce) ->
97+ ("*", IntNum n, Binop "*" (L _ (IntNum m)) ce) ->
104 binop "*" (none $ IntNum (n*m)) ce
98 binop "*" (none $ IntNum (n*m)) ce
105− ("*", Binop "*" (L _ _ (IntNum n)) ce1'
99+ ("*", Binop "*" (L _ (IntNum n)) ce1'
106− , Binop "*" (L _ _ (IntNum m)) ce2') ->
100+ , Binop "*" (L _ (IntNum m)) ce2') ->
107 binop "*" (none $ IntNum (n*m)) (none $ Binop "*" ce1' ce2')
101 binop "*" (none $ IntNum (n*m)) (none $ Binop "*" ce1' ce2')
108
102
109 ("-", _, IntNum 0) -> e1
103 ("-", _, IntNum 0) -> e1
@@ -124,21 +118,15 @@ binop op ce1@(L t1 s1 e1) ce2@(L t2 s2 e2) =
124 ("::", _, _) -> Data "::" [ce1, ce2]
118 ("::", _, _) -> Data "::" [ce1, ce2]
125
119
126 ("++", Literal (Str s1), Literal (Str s2)) -> str $ s1 ++ s2
120 ("++", Literal (Str s1), Literal (Str s2)) -> str $ s1 ++ s2
127− ("++", Literal (Str s1), Binop "++" (L _ _ (Literal (Str s2))) ce) ->
121+ ("++", Literal (Str s1), Binop "++" (L _ (Literal (Str s2))) ce) ->
128 Binop "++" (c1 . str $ s1 ++ s2) ce
122 Binop "++" (c1 . str $ s1 ++ s2) ce
129− ("++", Binop "++" e (L _ _ (Literal (Str s1))), Literal (Str s2)) ->
123+ ("++", Binop "++" e (L _ (Literal (Str s1))), Literal (Str s2)) ->
130 Binop "++" e (c1 . str $ s1 ++ s2)
124 Binop "++" e (c1 . str $ s1 ++ s2)
131
125
132 ("++", Data "[]" [], _) -> e2
126 ("++", Data "[]" [], _) -> e2
133 ("++", _, Data "[]" []) -> e1
127 ("++", _, Data "[]" []) -> e1
134 ("++", Data "::" [h,t], _) -> Data "::" [h, none $ binop "++" t ce2]
128 ("++", Data "::" [h,t], _) -> Data "::" [h, none $ binop "++" t ce2]
135
129
136− ("|>", _, _) -> App ce2 ce1
137− ("<|", _, _) -> App ce1 ce2
138− (".", _, _) ->
139− Lambda "x" (none $
140− App ce1 (none $ App ce2 (none $ Var "x")))
141−
142 _ | isAlpha (head op) || '_' == head op ->
130 _ | isAlpha (head op) || '_' == head op ->
143 App (none $ App (none $ Var op) ce1) ce2
131 App (none $ App (none $ Var op) ce1) ce2
144 | otherwise -> Binop op ce1 ce2
132 | otherwise -> Binop op ce1 ce2
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+5−6
@@ -7,18 +7,17 @@ import Control.Arrow (second, (***))
7
7
8subst :: String -> Expr t v -> Expr t v -> Expr t v
8subst :: String -> Expr t v -> Expr t v -> Expr t v
9subst old new expr =
9subst old new expr =
10− 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
11 case expr of
11 case expr of
12 Range e1 e2 -> Range (f e1) (f e2)
12 Range e1 e2 -> Range (f e1) (f e2)
13 ExplicitList es -> ExplicitList (map f es)
13 ExplicitList es -> ExplicitList (map f es)
14 Binop op e1 e2 -> Binop op (f e1) (f e2)
14 Binop op e1 e2 -> Binop op (f e1) (f e2)
15− Lambda x e -> if x == old then expr else Lambda x (f e)
15+ Lambda p e -> Lambda p (f e)
16 App e1 e2 -> App (f e1) (f e2)
16 App e1 e2 -> App (f e1) (f e2)
17 MultiIf ps -> MultiIf (map (f *** f) ps)
17 MultiIf ps -> MultiIf (map (f *** f) ps)
18 Let defs body -> Let (map substDef defs) (f body)
18 Let defs body -> Let (map substDef defs) (f body)
19− where substDef (FnDef name vs e) = FnDef name vs (f e)
19+ where substDef (Def name e) = Def name (f e)
20− substDef (OpDef op a1 a2 e) = OpDef op a1 a2 (f e)
20+ substDef anno@(TypeAnnotation _ _) = anno
21− substDef x = x
22 Var x -> if x == old then new else expr
21 Var x -> if x == old then new else expr
23 Case e cases -> Case (f e) $ map (second f) cases
22 Case e cases -> Case (f e) $ map (second f) cases
24 Data name es -> Data name (map f es)
23 Data name es -> Data name (map f es)
@@ -26,6 +25,6 @@ subst old new expr =
26 Remove e x -> Remove (f e) x
25 Remove e x -> Remove (f e) x
27 Insert e x v -> Insert (f e) x (f v)
26 Insert e x v -> Insert (f e) x (f v)
28 Modify r fs -> Modify (f r) (map (second f) fs)
27 Modify r fs -> Modify (f r) (map (second f) fs)
29− Record fs -> Record (map (\(lbl,as,e) -> (lbl,as,f e)) fs)
28+ Record fs -> Record (map (second f) fs)
30 Literal _ -> expr
29 Literal _ -> expr
31 Markdown _ -> 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−159
@@ -1,159 +0,0 @@
1−{-# LANGUAGE PatternGuards #-}
2−module Types.Alias (dealias, get, mistakes) where
3−
4−import SourceSyntax.Everything
5−import Control.Arrow (second)
6−import Data.List (group,sort)
7−import qualified Data.Map as Map
8−import qualified Data.Set as Set
9−import Types.Substitutions (subst)
10−import Types.Types
11−import Data.Data
12−import Data.Generics.Uniplate.Data
13−
14−builtins :: [(String,([X],Type))]
15−builtins =
16− let touch = ("t0", time) : map (flip (,) int) ["x","y","x0","y0","id"]
17− state = [("string", string), ("selectionStart", int), ("selectionEnd", int)]
18− line = [("color", tipe "Color"), ("width", float),
19− ("cap", tipe "LineCap"), ("join", tipe "LineJoin"),
20− ("miterLimit", float), ("dashing", listOf int),
21− ("dashOffset", int)]
22− makeRecord fields =
23− RecordT (Map.fromList $ map (second (:[])) fields) EmptyRecord
24− in [ ("String", ([], listOf char)),
25− ("Time", ([], float)),
26− ("KeyCode", ([], int)),
27− ("Touch", ([], makeRecord touch)),
28− ("FieldState", ([], makeRecord state)),
29− ("LineStyle", ([], makeRecord line))
30− ]
31−
32−type AliasDict = Map.Map String ([X],Type)
33−
34−get :: [Declaration t v] -> AliasDict
35−get decl = Map.fromList (builtins ++ concatMap getAlias decl)
36− where
37− getAlias decl = case decl of
38− TypeAlias alias xs t -> [(alias, (xs,t))]
39− _ -> []
40−
41−dealias :: AliasDict -> Type -> Type
42−dealias aliases t =
43− let f = dealias aliases in
44− case t of
45− ADT name ts -> case Map.lookup name aliases of
46− Just (xs,t) -> f (subst (zip xs ts) t)
47− Nothing -> ADT name (map f ts)
48− LambdaT t u -> LambdaT (f t) (f u)
49− RecordT r t -> RecordT (Map.map (map f) r) (f t)
50− _ -> t
51−
52−mistakes :: (Data t, Data v) => [Declaration t v] -> [String]
53−mistakes decls = badKinds decls ++ dups decls ++ badOrder decls
54−
55−badKinds :: (Data t, Data v) => [Declaration t v] -> [String]
56−badKinds decls = map msg (concatMap bad decls)
57− where
58− msg x = "Type Error: Type alias '" ++ x ++
59− "' was given the wrong number of arguments."
60−
61− aliases :: AliasDict
62− aliases = get decls
63−
64− badType :: Type -> [String]
65− badType t =
66− case t of
67− ADT name ts ->
68− case Map.lookup name aliases of
69− Just (xs,t) | length xs == length ts -> []
70− | otherwise -> [name]
71− Nothing -> concatMap badType ts
72− LambdaT t u -> badType t ++ badType u
73− RecordT r t -> badType t ++ concatMap badType (concat (Map.elems r))
74− _ -> []
75−
76− --badDef :: AliasDict -> Def t v -> [String]
77− badDef def =
78− case def of
79− TypeAnnotation _ tipe -> badType tipe
80− FnDef _ _ expr ->
81− concatMap badDef $ concat [defList | Let defList _ <- universeBi expr]
82− OpDef _ _ _ expr ->
83− concatMap badDef $ concat [defList | Let defList _ <- universeBi expr]
84−
85− --bad :: Declaration t v -> [String]
86− bad s =
87− case s of
88− Datatype _ _ tcs -> concatMap badType (concatMap snd tcs)
89− ExportEvent _ _ tipe -> badType tipe
90− ImportEvent _ _ _ tipe -> badType tipe
91− TypeAlias _ _ tipe -> badType tipe
92− Definition d -> badDef d
93−
94−annotation :: Declaration t v -> [String]
95−annotation s =
96− case s of
97− Definition (TypeAnnotation name _) -> [name]
98− _ -> []
99−
100−definition :: Declaration t v -> [String]
101−definition s =
102− case s of
103− Definition d -> defName d
104− _ -> []
105−
106−defName :: Def t v -> [String]
107−defName d =
108− case d of
109− FnDef n _ _ -> [n]
110− OpDef n _ _ _ -> [n]
111− _ -> []
112−
113−dups :: [Declaration t v] -> [String]
114−dups decls = map defMsg (dup definition) ++ map annMsg (dup annotation)
115− where
116− --dup :: (Declaration t v -> [String]) -> [String]
117− dup f = map head . filter ((>1) . length) . group . sort $ concatMap f decls
118−
119− msg = "Syntax Error: There can only be one "
120− defMsg x = msg ++ "top-level definition of '" ++ x ++ "'."
121− annMsg x = msg ++ "type annotation for '" ++ x ++ "'."
122−
123−badOrder :: (Data t, Data v) => [Declaration t v] -> [String]
124−badOrder decls =
125− map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs decls)
126− where
127− msg x = "Syntax Error: The type annotation for '" ++ x ++
128− "' must be directly above its definition."
129− as = sort $ concatMap annotation decls
130− ds = sort $ concatMap definition decls
131−
132− expectedPairs :: [String] -> [String] -> [String]
133− expectedPairs as ds =
134− case (as,ds) of
135− (x:xs, y:ys) -> case compare x y of
136− LT -> expectedPairs xs (y:ys)
137− EQ -> x : expectedPairs xs ys
138− GT -> expectedPairs (x:xs) ys
139− ( _ , _ ) -> []
140−
141− --actualPairs :: [Def t v] -> [String]
142− actualPairs decls =
143− case decls of
144− Definition (TypeAnnotation n _) : Definition (FnDef m _ _) : rest ->
145− (if n == m then [n] else []) ++ actualPairs rest
146− Definition (TypeAnnotation n _) : Definition (OpDef m _ _ _) : rest ->
147− (if n == m then [n] else []) ++ actualPairs rest
148− t:s:rest -> actualPairs (s:rest)
149− _ -> []
150−
151− missings :: [String] -> [String] -> [String]
152− missings expected actual =
153− case (expected, actual) of
154− (e:es, a:as) -> case compare e a of
155− LT -> e : missings es (a:as)
156− EQ -> missings es as
157− GT -> a : missings (e:es) as
158− ( [] , _ ) -> actual
159− ( _ , [] ) -> expected
compiler/Types/Constrain.hsdeleted−344
@@ -1,344 +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 SourceSyntax.Everything
13−import Unique
14−
15−import Types.Types
16−import qualified Types.Substitutions as Subs
17−
18−import System.IO.Unsafe
19−
20−beta = VarT `liftM` guid
21−unionA = Map.unionWith (++)
22−unionsA = Map.unionsWith (++)
23−
24−getAliases :: [(String,ImportMethod)] -> [(String,Scheme)] -> [(String,Scheme)]
25−getAliases imports hints = concatMap aliasesFrom imports
26− where
27− -- Get the names of values that are now in scope after a particular
28− -- import statement.
29− aliasesFrom :: (String,ImportMethod) -> [(String,Scheme)]
30− aliasesFrom (name,method) =
31− let values = concatMap (getValue name) hints
32− prefixed name = map (\(n,t) -> (name ++ "." ++ n, t)) values
33− in case method of
34− As alias -> prefixed alias
35− Hiding vs -> prefixed name ++ filter (\(n,t) -> n `notElem` vs) values
36− Importing vs -> prefixed name ++ filter (\(n,t) -> n `elem` vs) values
37−
38− -- Take a module name and a type annotation. Return the unprefxed
39− -- type annotation: getValue "List" ("List.map",t) == [("map",t)]
40− getValue :: String -> (String,Scheme) -> [(String,Scheme)]
41− getValue inModule (name,tipe) =
42− case inModule `isPrefixOf` name of
43− True -> [ (drop (length inModule + 1) name, tipe) ]
44− False -> []
45−
46−findAmbiguous hints assumptions continue =
47− let potentialDups = map head . filter (\g -> length g > 1) . group . sort $
48− filter (elem '.') hints
49− dups = filter (\k -> Map.member k assumptions) potentialDups
50− in case dups of
51− n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++
52− "' could refer to " ++
53− intercalate ", " (filter (isSuffixOf n) hints)
54− _ -> continue
55−
56−mergeSchemes :: [Map.Map String Scheme]
57− -> Unique (TVarMap, Constraints, Map.Map String Scheme)
58−mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
59− return (Map.unions ass, concat css, Map.unions sss)
60− where
61− kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)
62− split (k,vs) =
63− let ps = zipWith (\s v -> (s++k,v)) (map (flip replicate '_') [0..]) vs
64− eq t u = L (Just $ msg ++ k) NoSpan (VarT t :=: VarT u)
65− msg = "the definition of "
66− in do xs <- mapM (\_ -> guid) vs
67− return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)
68− , case xs of
69− t:ts -> zipWith eq xs ts
70− [] -> []
71− , Map.fromList ps )
72−
73−--constrain :: Map.Map String Scheme
74−-- -> Module
75−-- -> Unique (Either String Constraints)
76−constrain typeHints (Module _ _ imports stmts) = do
77− (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
78− aliasHints <- getAliases imports `liftM` typeHints
79− (as', cs', schemes) <- mergeSchemes schemess
80− let constraints = concat (cs':css)
81− as = unionsA (as':ass)
82− allHints = Map.union schemes (Map.fromList aliasHints)
83− insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
84− assumptions <- foldM insert as (Map.keys schemes)
85− findAmbiguous (map fst aliasHints) assumptions $ do
86− let f k s vs = map (\v -> L (Just k) NoSpan $ v :<<: s) vs
87− cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
88− escapees = Map.keys $ Map.difference assumptions allHints
89− msg = "Warning! Type-checker could not find variables:\n" ++ intercalate ", " escapees
90− return $ case escapees of
91− [] -> Right (schemess, constraints ++ cs)
92− _ -> unsafePerformIO (putStrLn msg) `seq` Right (schemess, constraints ++ cs)
93− --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)
94−
95−type TVarMap = Map.Map String [X]
96−type Constraints = [Located Constraint]
97−
98−loc e span = L (Just $ show e) span
99−
100−gen :: LExpr t v -> Unique (TVarMap, Constraints, Type)
101−gen (L _ span expr) =
102− let loc' = L (Just $ show expr) span in
103− case expr of
104− Var x ->
105− do b <- guid
106− return (Map.singleton x [b], [], VarT b)
107−
108− App e1 e2 ->
109− do (a1,c1,t1) <- gen e1
110− (a2,c2,t2) <- gen e2
111− b <- beta
112− return ( unionA a1 a2
113− , c1 ++ c2 ++ [loc' $ t1 :=: (LambdaT t2 b)]
114− , b )
115−
116− Lambda x e ->
117− do (a,c,t) <- gen e
118− b <- beta
119− v <- guid
120− return ( Map.delete x a
121− , (++) c . 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− , 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− b <- beta
146− return ( unionsA $ as:ass
147− , let cases' = map snd cases
148− locs = zipWith merge cases' (tail cases')
149− cs' = zipWith (\t loc -> loc (b :=: t)) ts locs
150− in concat $ cs' : cs : css
151− , b)
152−
153− ExplicitList es ->
154− do (ass,css,ts) <- unzip3 `liftM` mapM gen es
155− t <- beta
156− let cs = zipWith (\t' (L a b _) -> L a b (t :=: t')) ts es
157− return ( unionsA ass, cs ++ concat css, listOf t )
158−
159− Data name es ->
160− gen $ foldl' (\f x -> merge f x $ App f x) (loc' $ Var name) es
161−
162− Binop op e1 e2 ->
163− gen $ loc' (App (loc' $ App (loc' $ Var op) e1) e2)
164−
165− Access e label ->
166− do (as,cs,rtype) <- gen e
167− t <- beta
168− rtype' <- beta
169− let fs = Map.singleton label [t]
170− c = (loc' (RecordT fs rtype' :=: rtype))
171− return (as, c:cs, t)
172−
173− Remove e x ->
174− do (as,cs,rtype) <- gen e
175− t <- beta
176− rtype' <- beta
177− let c = (loc' (RecordT (Map.singleton x [t]) rtype' :=: rtype))
178− return (as, c:cs, rtype')
179−
180− Insert e x v ->
181− do (eas,ecs,etype) <- gen e
182− (vas,vcs,vtype) <- gen v
183− return ( unionA eas vas
184− , ecs ++ vcs
185− , RecordT (Map.singleton x [vtype]) etype )
186−
187− Modify record fields ->
188− do (ras,rcs,rtype) <- gen record
189− (ass,css,newTs) <- unzip3 `liftM` mapM gen (map snd fields)
190− oldTs <- mapM (\_ -> beta) fields
191− rtype' <- beta
192− let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'
193− c = [ loc' (rtype :=: rT oldTs) ]
194− return ( unionsA (ras:ass), concat (c : rcs : css), rT newTs )
195−
196− Record fields ->
197− let insert label tipe = Map.insertWith (++) label [tipe]
198− getScheme (f,args,e) = do
199− (as, _, (label, Forall _ cs tipe)) <- defGenHelp f args e
200− return (as, cs, insert label tipe)
201− in do (ass, css, fs) <- unzip3 `liftM` mapM getScheme fields
202− return ( unionsA ass
203− , concat css
204− , RecordT (foldr ($) Map.empty fs) EmptyRecord )
205−
206− Range e1@(L w1 s1 _) e2@(L w2 s2 _) ->
207− do (a1,c1,t1) <- gen e1
208− (a2,c2,t2) <- gen e2
209− return ( unionsA [a1,a2]
210− , c1 ++ c2 ++ [ L w1 s1 (t1 :=: int), L w1 s2 (t2 :=: int) ]
211− , listOf int )
212−
213− MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
214− let cs = map (loc' . (t :=:)) ts
215− return (unionsA ass, concat (cs:css), t)
216− where genPair (b@(L t s _),e) = do
217− (a1,c1,t1) <- gen b
218− (a2,c2,t2) <- gen e
219− return ( unionsA [a1,a2]
220− , c1 ++ c2 ++ [ L t s (t1 :=: bool) ]
221− , t2 )
222−
223− Markdown _ -> primitive element
224− Literal lit -> literalGen loc' lit
225−
226−literalGen :: (Constraint -> Located Constraint)
227− -> Literal
228− -> Unique (TVarMap, Constraints, Type)
229−literalGen loc lit =
230− case lit of
231− IntNum _ -> do t <- beta
232− return (Map.empty, [loc $ t :<: number], t)
233− FloatNum _ -> primitive float
234− Boolean _ -> primitive bool
235− Chr _ -> primitive char
236− Str _ -> primitive string
237−
238−
239−primitive :: Type -> Unique (TVarMap, Constraints, Type)
240−primitive t = return (Map.empty, [], t)
241−
242−caseGen :: Type
243− -> (Pattern, LExpr t v)
244− -> Unique (TVarMap, Constraints, 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', cs ++ cs', t )
249−
250−patternGen :: (Constraint -> Located Constraint)
251− -> Type -- Type of e in `case e of ...`
252− -> TVarMap
253− -> Pattern
254− -> Unique (TVarMap, Constraints, Type)
255−patternGen loc tipe as pattern =
256− case pattern of
257− PAnything -> do b <- beta ; return ( as, [], b )
258−
259− PLiteral lit -> literalGen loc lit
260−
261− PVar v -> do
262− b <- beta
263− let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
264− return ( Map.delete v as, loc (b :=: tipe) : cs, b )
265−
266− PAlias v p -> do
267− b <- beta
268− let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
269− (as', cs', tipe') <- patternGen loc b as p
270− return (Map.delete v as',
271− cs' ++ [ loc (b :=: tipe), loc (b :=: tipe') ] ++ cs,
272− b)
273−
274− PData name ps -> do
275− constr <- guid
276− output <- beta
277− let step (as,cs,tipe) p = do b <- beta
278− (as',cs',t) <- patternGen loc b as p
279− return (as', cs ++ cs', t ==> tipe)
280− (as',cs, t) <- foldM step (as,[],tipe) (reverse ps)
281− return ( Map.insert name [constr] as'
282− , loc (VarT constr :=: t) : cs
283− , output )
284− PRecord fs ->
285− do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs
286− b <- beta
287− let t = RecordT (Map.fromList $ map (second (:[])) pairs) b
288− mkCs (name,tipe) = map (loc . (tipe :=:) . VarT)
289− (Map.findWithDefault [] name as)
290− return ( foldr Map.delete as fs
291− , loc (t :=: tipe) : concatMap mkCs pairs
292− , t )
293−
294−
295−defScheme :: Def t v -> Unique (Map.Map String [X], Scheme)
296−defScheme def = do (as,cs,hint) <- defGen def
297− return ( as, snd hint )
298−
299−defGen def = case def of
300− FnDef f args e -> defGenHelp f args e
301− OpDef op a1 a2 e -> defGenHelp op [a1,a2] e
302− TypeAnnotation name tipe -> do
303− schm <- Subs.generalize [] =<< Subs.superize name tipe
304− return (Map.empty, [], (name, schm))
305−
306−defGenHelp name args e = do
307− argDict <- mapM (\a -> liftM ((,) a) guid) args
308− (as,cs,t) <- gen e
309− let as' = foldr Map.delete as args
310− tipe = foldr (==>) t $ map (VarT . snd) argDict
311− genCs (arg,x) = do
312− v <- guid
313− let as' = Map.findWithDefault [v] arg as
314− return $ map (\y -> loc arg NoSpan $ VarT x :=: VarT y) as'
315− cs' <- concat `liftM` mapM genCs argDict
316− scheme <- Subs.generalize (concat $ Map.elems as') $
317− Forall (map snd argDict) (cs' ++ cs) tipe
318− return ( as', [], (name, scheme) )
319−
320−
321−stmtGen :: Declaration t v
322− -> Unique (TVarMap, Constraints, Map.Map String Scheme)
323−stmtGen stmt =
324− case stmt of
325− Definition def -> do (as,cs,hint) <- defGen def
326− return ( as, cs, uncurry Map.singleton hint )
327−
328− Datatype name xs tcs ->
329− let toScheme ts = Forall xs [] (foldr (==>) (ADT name $ map VarT xs) ts)
330− in return (Map.empty, [], Map.fromList (map (second toScheme) tcs))
331−
332− ExportEvent js elm tipe ->
333− do x <- guid
334− return ( Map.singleton elm [x]
335− , [ loc elm NoSpan $ VarT x :=: tipe ]
336− , Map.empty )
337−
338− ImportEvent js e@(L txt span base) elm tipe ->
339− do (as,cs,t) <- gen e
340− return ( as
341− , L txt span (signalOf t :=: tipe) : cs
342− , Map.singleton elm (Forall [] [] tipe) )
343−
344− TypeAlias _ _ _ -> return (Map.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 Unique
8−import qualified Metadata.Libraries as Libs
9−import Parse.Helpers (iParse)
10−import Parse.Type
11−import qualified Types.Substitutions as Subs
12−import Types.Types
13−
14−hints :: Unique [(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) -> Unique (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−215
@@ -1,215 +0,0 @@
1−
2−module Types.Solver (solver) where
3−
4−import SourceSyntax.Everything
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 Unique
13−import Types.Types
14−import Types.Substitutions
15−import Types.Alias (dealias)
16−
17−import System.IO.Unsafe
18−
19−isSolved ss (L _ _ (t1 :=: t2)) = t1 == t2
20−isSolved ss (L _ _ (x :<<: _)) = isJust (lookup x ss)
21−isSolved ss c = False
22−
23−type Aliases = Map.Map String ([X],Type)
24−
25−crush :: Aliases -> Scheme -> Unique (Either String Scheme)
26−crush aliases forall@(Forall xs cs t) =
27− do subs <- solver aliases Map.empty cs
28− return $ do ss' <- subs
29− let ss = Map.toList ss'
30− cs' = filter (not . isSolved ss) (subst ss cs)
31− f x = x {-(unsafePerformIO $ do
32− print forall >> putStrLn "-------"
33− print x >> putStrLn "~~~~~~~") `seq` x-}
34− return . f $ Forall xs cs' (subst ss t)
35−
36−schemeSubHelp txt span x s t1 rltn t2 = do
37− (t1',cs1) <- sub t1
38− (t2',cs2) <- sub t2
39− return (L txt span (rltn t1' t2') : cs1 ++ cs2)
40− where sub t | not (occurs x t) = return (t, [])
41− | otherwise = do (st, cs) <- concretize s
42− return (subst [(x,st)] t, cs)
43−
44−schemeSub x s' c =
45− case s' of
46− Right s'' -> Right `liftM` schemeSub' x s'' c
47− Left err -> return $ Left err
48−
49−schemeSub' x s c@(L txt span constraint) =
50− case constraint of
51− (t1 :=: t2) -> schemeSubHelp txt span x s t1 (:=:) t2
52− (t1 :<: t2) -> schemeSubHelp txt span x s t1 (:<:) t2
53− (y :<<: Forall cxs ccs ctipe)
54− | not (occurs x c) -> return [c]
55− | otherwise ->
56− do Forall xs cs tipe <- rescheme s
57− let ss = [(x,tipe)]
58− constraints = subst ss (cs ++ ccs)
59− c' = y :<<: Forall (cxs ++ xs) constraints (subst ss ctipe)
60− return [ L txt span c' ]
61−
62−recordConstraints eq fs t fs' t' =
63− liftM concat . sequence $
64− [ constrain fs fs'
65− , liftM concat . mapM (\(k,ts) -> zipper [] k ts []) . Map.toList $
66− Map.difference fs fs'
67− , liftM concat . mapM (\(k,ts) -> zipper [] k [] ts) . Map.toList $
68− Map.difference fs' fs
69− ]
70− where constrain :: Map.Map String [Type] -> Map.Map String [Type]
71− -> Unique [Located Constraint]
72− constrain as bs = liftM concat . sequence . Map.elems $
73− Map.intersectionWithKey (zipper []) as bs
74− zipper :: [Located Constraint] -> String -> [Type] -> [Type]
75− -> Unique [Located Constraint]
76− zipper cs k xs ys =
77− case (xs,ys) of
78− (a:as, b:bs) -> zipper (eq a b : cs) k as bs
79− ([],[]) -> return cs
80− (as,[]) -> do x <- guid
81− let tipe = RecordT (Map.singleton k as) (VarT x)
82− return (cs ++ [eq t' tipe])
83− ([],bs) -> do x <- guid
84− let tipe = RecordT (Map.singleton k bs) (VarT x)
85− return (cs ++ [eq t tipe])
86−
87−solver :: Aliases
88− -> Map.Map X Type
89− -> [Located Constraint]
90− -> Unique (Either String (Map.Map X Type))
91−solver _ subs [] = return $ Right subs
92−solver aliases subs (L txt span c : cs) =
93− let loc = L txt span
94− eq t1 t2 = loc (t1 :=: t2)
95− solv = solver aliases subs
96− uniError' = uniError (\t1 t2 -> solv (eq t1 t2 : cs)) aliases txt span
97− in case c of
98− -- Destruct Type-constructors
99− t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2) ->
100− if n1 == n2 then solv (zipWith eq ts1 ts2 ++ cs)
101− else uniError' t1 t2
102−
103− LambdaT t1 t2 :=: LambdaT t1' t2' ->
104− solv ([ eq t1 t1', eq t2 t2' ] ++ cs)
105−
106− RecordT fs t :=: RecordT fs' t' ->
107− do cs' <- recordConstraints eq fs t fs' t'
108− solv (cs' ++ cs)
109−
110− -- Type-equality
111− VarT x :=: VarT y
112− | x == y -> solv cs
113− | otherwise ->
114− case (Map.lookup x subs, Map.lookup y subs) of
115− (Just (Super xts), Just (Super yts)) ->
116− let ts = Set.intersection xts yts
117− setXY t = Map.insert x t . Map.insert y t
118− in case Set.toList ts of
119− [] -> unionError txt span xts yts
120− [t] -> let cs1 = subst [(x,t),(y,t)] cs in
121− cs1 `seq` solver aliases (setXY t subs) cs1
122− _ -> solver aliases (setXY (Super ts) subs) cs
123− (Just (Super xts), _) ->
124− let cs2 = subst [(y,VarT x)] cs in
125− solver aliases (Map.insert y (VarT x) subs) cs2
126− (_, _) ->
127− let cs3 = subst [(x,VarT y)] cs in
128− solver aliases (Map.insert x (VarT y) subs) cs3
129−
130− VarT x :=: t -> do
131− if x `occurs` t then occursError txt span (VarT x) t else
132− (case Map.lookup x subs of
133− Nothing ->
134− let cs4 = subst [(x,t)] cs
135− subs' = Map.map (subst [(x,t)]) $ Map.insert x t subs
136− in solver aliases subs' cs4
137− Just (Super ts) ->
138− let ts' = Set.intersection ts (Set.singleton t) in
139− case Set.toList ts' of
140− [] -> solv (loc (t :<: Super ts) : cs)
141− [t'] -> let cs5 = subst [(x,t)] cs in
142− solver aliases (Map.insert x t' subs) cs5
143− _ -> solver aliases (Map.insert x (Super ts') subs) cs
144− Just t' -> solv (loc (t' :=: t) : cs)
145− )
146−
147− t :=: VarT x -> solv ((loc (VarT x :=: t)) : cs)
148−
149− t1 :=: t2 | t1 == t2 -> solv cs
150− | otherwise -> uniError' t1 t2
151−
152− -- subtypes
153− VarT x :<: Super ts ->
154− case Map.lookup x subs of
155− Nothing -> solver aliases (Map.insert x (Super ts) subs) cs
156− Just (Super ts') ->
157− case Set.toList $ Set.intersection ts ts' of
158− [] -> unionError txt span ts ts'
159− [t] -> solver aliases (Map.insert x t subs) (subst [(x,t)] cs)
160− ts'' -> solver aliases subs' cs
161− where subs' = Map.insert x (Super $ Set.fromList ts'') subs
162−
163− ADT "List" [t] :<: Super ts
164− | any f (Set.toList ts) -> solv cs
165− | otherwise -> subtypeError txt span (ADT "List" [t]) (Super ts)
166− where f (ADT "List" [VarT _]) = True
167− f (ADT "List" [t']) = dealias aliases t == t'
168− f _ = False
169−
170− t :<: Super ts
171− | Set.member t ts -> solv cs
172− | Set.member (dealias aliases t) ts -> solv cs
173− | otherwise -> subtypeError txt span t (Super ts)
174−
175− x :<<: s
176− | any (occurs x) cs ->
177− do s' <- crush aliases s
178− css <- mapM (schemeSub x s') cs
179− case lefts css of
180− err : _ -> return $ Left err
181− [] -> solv (concat (rights css))
182− | otherwise ->
183− do (t,cs7) <- concretize s
184− solv (cs ++ loc (VarT x :=: t) : cs7)
185−
186−showMsg msg = case msg of
187− Just str -> "\nIn context: " ++ str
188− Nothing -> ""
189−
190−occursError msg span t1 t2 =
191− return . Left $ concat
192− [ "Type error (" ++ show span ++ "):\n"
193− , "Occurs check: cannot construct the infinite type:\n"
194− , show t1, " = ", show t2, showMsg msg ]
195−
196−uniError solveWith aliases msg span t1 t2 =
197− let t1' = dealias aliases t1
198− t2' = dealias aliases t2
199− in if t1 /= t1' || t2 /= t2'
200− then solveWith t1' t2'
201− else return . Left $ concat
202− [ "Type error (" ++ show span ++ "):\n"
203− , show t1, " is not equal to ", show t2, showMsg msg ]
204−
205−unionError msg span ts ts' =
206− return . Left $ concat
207− [ "Type error (" ++ show span ++ "):\n"
208− , "There are no types in both "
209− , show (Super ts), " and ", show (Super ts'), showMsg msg ]
210−
211−subtypeError msg span t s =
212− return . Left $ concat
213− [ "Type error (" ++ show span ++ "):\n"
214− , show t, " is not a ", show s, showMsg msg ]
215−
compiler/Types/Substitutions.hsdeleted−138
@@ -1,138 +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 SourceSyntax.Everything
11−import Control.Monad (liftM, liftM2)
12−import Control.Monad.State (runState, State, get, put)
13−import Data.List (nub)
14−import qualified Data.Set as Set
15−import qualified Data.Map as Map
16−import Unique
17−import Types.Types
18−
19−class Subst a where
20− subst :: [(X,Type)] -> a -> a
21−
22−instance Subst Type where
23− subst ss t =
24− case t of
25− VarT x -> case lookup x ss of
26− Nothing -> VarT x
27− Just (Super _) -> VarT x
28− Just t -> t
29− LambdaT t1 t2 -> LambdaT (subst ss t1) (subst ss t2)
30− ADT name ts -> ADT name (subst ss ts)
31− RecordT fs t -> RecordT (Map.map (subst ss) fs) (subst ss t)
32− EmptyRecord -> EmptyRecord
33− Super ts -> Super ts
34−
35−instance Subst Scheme where
36− subst ss (Forall vs cs t) = Forall vs (subst ss cs) (subst ss t)
37−
38−instance Subst Constraint where
39− subst ss (t1 :=: t2) = subst ss t1 :=: subst ss t2
40− subst ss (t :<: super) = subst ss t :<: super
41− subst ss (x :<<: poly) = (case lookup x ss of
42− Just (VarT y) -> y
43− _ -> x
44− ) :<<: subst ss poly
45−
46−instance Subst a => Subst (Located a) where
47− subst ss (L str span c) = L str span (subst ss c)
48−
49−instance Subst a => Subst [a] where
50− subst ss as = map (subst ss) as
51−
52−
53−class FreeVars a where
54− freeVars :: a -> [X]
55−
56−instance FreeVars Type where
57− freeVars t =
58− case t of
59− VarT v -> [v]
60− LambdaT t1 t2 -> freeVars t1 ++ freeVars t2
61− ADT _ ts -> concatMap freeVars ts
62− RecordT fs t -> freeVars (concat $ Map.elems fs) ++ freeVars t
63− EmptyRecord -> []
64− Super _ -> []
65−
66−instance FreeVars Constraint where
67− freeVars (t1 :=: t2) = freeVars t1 ++ freeVars t2
68− freeVars (t1 :<: t2) = freeVars t1 ++ freeVars t2
69− freeVars (x :<<: Forall xs cs t) = filter (`notElem` xs) frees
70− where frees = concatMap freeVars cs ++ freeVars t
71−
72−instance FreeVars a => FreeVars (Located a) where
73− freeVars (L _ _ c) = freeVars c
74−
75−instance FreeVars a => FreeVars [a] where
76− freeVars = concatMap freeVars
77−
78−occurs x t = x `elem` freeVars t
79−
80−concretize :: Scheme -> Unique (Type, [Located Constraint])
81−concretize (Forall xs cs t) = do
82− ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs
83− return (subst ss t, subst ss cs)
84−
85−rescheme :: Scheme -> Unique Scheme
86−rescheme (Forall xs cs t) = do
87− xs' <- mapM (const guid) xs
88− let ss = zip xs (map VarT xs')
89− return $ Forall xs' (subst ss cs) (subst ss t)
90−
91−generalize :: [X] -> Scheme -> Unique Scheme
92−generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)
93− where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs
94− frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)
95−
96−newtype Superize a = S { runSuper :: State ([X], [X], [X]) a }
97− deriving (Monad)
98−
99−superize :: String -> Type -> Unique Scheme
100−superize name tipe =
101− do constraints <- liftM concat $
102− sequence [ mapM (<: nmbr) (nub ns)
103− , mapM (<: apnd) (nub as)
104− , mapM (<: comp) (nub cs) ]
105− return (Forall (concat [ns,as,cs]) constraints tipe')
106− where
107− (tipe', (ns,as,cs)) = runState (runSuper (go tipe)) ([],[],[])
108− t <: super = do x <- guid
109− return $ L (Just name) NoSpan (VarT t :<: super x)
110−
111− nmbr t = number
112− apnd t = appendable t
113− comp t = comparable t
114−
115− go :: Type -> Superize Type
116− go t =
117− case t of
118− EmptyRecord -> return t
119− Super _ -> return t
120− VarT _ -> return t
121− LambdaT t1 t2 -> liftM2 LambdaT (go t1) (go t2)
122− ADT "Number" [VarT t] -> addNumber t
123− ADT "Appendable" [VarT t] -> addAppendable t
124− ADT "Comparable" [VarT t] -> addComparable t
125− ADT name ts -> liftM (ADT name) (mapM go ts)
126− RecordT fs t -> liftM2 RecordT fs' (go t)
127− where pairs = Map.toList fs
128− fs' = do ps <- mapM (\(f,t) -> liftM ((,) f) (mapM go t)) pairs
129− return (Map.fromList ps)
130−
131− add :: (X -> ([X],[X],[X]) -> ([X],[X],[X])) -> X -> Superize Type
132− add f v = S $ do (ns, as, cs) <- get
133− put $ f v (ns, as, cs)
134− return (VarT v)
135−
136− addNumber = add (\n (ns,as,cs) -> (n:ns,as,cs))
137− addAppendable = add (\a (ns,as,cs) -> (ns,a:as,cs))
138− addComparable = add (\c (ns,as,cs) -> (ns,as,c:cs))
compiler/Types/Types.hsdeleted−96
@@ -1,96 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−module Types.Types where
3−
4−import SourceSyntax.Location
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
22− deriving (Eq, Ord, Show, Data, Typeable)
23−
24−data Constraint = Type :=: Type
25− | Type :<: Type
26− | X :<<: Scheme
27− deriving (Eq, Ord, Show, Data, Typeable)
28−
29−recordT :: [(String,Type)] -> Map.Map String [Type]
30−recordT fields =
31− foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
32−
33−recordOf :: [(String,Type)] -> Type
34−recordOf fields = RecordT (recordT fields) EmptyRecord
35−
36−tipe t = ADT t []
37−
38−int = tipe "Int"
39−float = tipe "Float"
40−time = tipe "Time"
41−date = tipe "Date"
42−
43−char = tipe "Char"
44−bool = tipe "Bool"
45−text = tipe "Text"
46−order = tipe "Order"
47−string = tipe "String"
48−
49−number = Super $ Set.fromList [ int, float, time ]
50−appendable t = Super $ Set.fromList [ string, text, listOf (VarT t) ]
51−comparable t = Super $ Set.fromList [ int, float, char, string, time, date ]
52−
53−element = tipe "Element"
54−
55−listOf t = ADT "List" [t]
56−signalOf t = ADT "Signal" [t]
57−tupleOf ts = ADT ("Tuple" ++ show (length ts)) ts
58−maybeOf t = ADT "Maybe" [t]
59−eitherOf a b = ADT "Either" [a,b]
60−pairOf t = tupleOf [t,t]
61−point = pairOf int
62−
63−infixr ==>
64−t1 ==> t2 = LambdaT t1 t2
65−
66−infix 8 -:
67−name -: tipe = (,) name $ Forall [] [] tipe
68−
69−parens = ("("++) . (++")")
70−
71−instance Show Type where
72− show t =
73− let addParens (c:cs) =
74− if notElem ' ' cs || c == '(' || c == '{' then c:cs else parens (c:cs)
75− in case t of
76− LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2
77− LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
78− VarT x -> 't' : show x
79− ADT "List" [ADT "Char" []] -> "String"
80− ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
81− ADT name cs ->
82− if isTupleString name
83− then parens . intercalate "," $ map show cs
84− else name ++ concatMap ((' ':) . addParens . show) cs
85− Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
86− EmptyRecord -> "{}"
87− RecordT fs t ->
88− start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"
89− where field n s = n ++ " : " ++ show s
90− fields (n,ss) = map (field n) ss
91− start = case t of
92− EmptyRecord -> "{ "
93− _ -> "{ " ++ show t ++ " | "
94−
95−
96−isTupleString str = "Tuple" `isPrefixOf` str && all isDigit (drop 5 str)
compiler/Types/Unify.hsdeleted−27
@@ -1,27 +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 SourceSyntax.Module
8−import Unique
9−import qualified Types.Constrain as Constrain
10−import qualified Types.Solver as Solver
11−import qualified Types.Alias as Alias
12−
13−import qualified Types.Substitutions as Subst
14−import System.IO.Unsafe
15−import Control.Arrow (second)
16−
17−unify hints modul@(Module _ _ _ stmts) = run $ do
18− result <- Constrain.constrain hints modul
19− case result of
20− Left err -> return (Left err)
21− Right (schemes, constraints) ->
22− do subs <- {- unsafePerformIO (mapM print constraints) `seq` -}
23− Solver.solver (Alias.get stmts) Map.empty constraints
24− let ss = either (const []) Map.toList subs
25− -- unsafePerformIO (mapM print . map (second (Subst.subst ss)) $ concatMap Map.toList schemes) `seq`
26− return subs
27−
libraries/Automaton.elm+5−4
@@ -4,8 +4,9 @@
4-- it can be used.
4-- it can be used.
5module Automaton where
5module Automaton where
6
6
7+import open Basics
7−import Signal (lift,foldp)
8+import Signal (lift,foldp,Signal)
8−import List (reverse)
9+import open List
9import Maybe (Just, Nothing)
10import Maybe (Just, Nothing)
10
11
11data Automaton a b = Step (a -> (Automaton a b, b))
12data Automaton a b = Step (a -> (Automaton a b, b))
@@ -15,7 +16,7 @@ data Automaton a b = Step (a -> (Automaton a b, b))
15run : Automaton a b -> b -> Signal a -> Signal b
16run : Automaton a b -> b -> Signal a -> Signal b
16run auto base inputs =
17run auto base inputs =
17 let step a (Step f, _) = f a
18 let step a (Step f, _) = f a
18− in lift (\(x,y) -> y) <| foldp step (auto,base) inputs
19+ in lift (\(x,y) -> y) (foldp step (auto,base) inputs)
19
20
20-- Step an automaton forward once with a given input.
21-- Step an automaton forward once with a given input.
21step : a -> Automaton a b -> (Automaton a b, b)
22step : a -> Automaton a b -> (Automaton a b, b)
@@ -35,7 +36,7 @@ g <<< f = f >>> g
35-- Combine a list of automatons into a single automaton that produces a list.
36-- Combine a list of automatons into a single automaton that produces a list.
36combine : [Automaton a b] -> Automaton a [b]
37combine : [Automaton a b] -> Automaton a [b]
37combine autos =
38combine autos =
38− Step (\a -> let (autos', bs) = unzip $ map (step a) autos
39+ Step (\a -> let (autos', bs) = unzip (map (step a) autos)
39 in (combine autos', bs))
40 in (combine autos', bs))
40
41
41-- Create an automaton with no memory. It just applies the given function to
42-- Create an automaton with no memory. It just applies the given function to
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&deg;.
18+turns : Float -> Float
19+turns r = 2 * Native.Basics.pi * r
20+
21+-- Start with polar coordinates (r,&theta;)
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,&theta;).
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 &pi;/2 and -&pi;/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+-- &pi; and -&pi;, 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 @@
1
1
2module Char where
2module Char where
3
3
4−import Native.Char as N
4+import Native.Char
5
5
6-- True for upper case letters.
6-- True for upper case letters.
7isUpper : Char -> Bool
7isUpper : Char -> Bool
8+isUpper = Native.Char.isUpper
8
9
9-- True for lower case letters.
10-- True for lower case letters.
10isLower : Char -> Bool
11isLower : Char -> Bool
12+isLower = Native.Char.isLower
11
13
12-- True for ASCII digits (`0..9`).
14-- True for ASCII digits (`0..9`).
13isDigit : Char -> Bool
15isDigit : Char -> Bool
16+isDigit = Native.Char.isDigit
14
17
15-- True for ASCII octal digits (`0..7`).
18-- True for ASCII octal digits (`0..7`).
16isOctDigit : Char -> Bool
19isOctDigit : Char -> Bool
20+isOctDigit = Native.Char.isOctDigit
17
21
18-- True for ASCII hexadecimal digits (`0..9a..fA..F`).
22-- True for ASCII hexadecimal digits (`0..9a..fA..F`).
19isHexDigit : Char -> Bool
23isHexDigit : Char -> Bool
24+isHexDigit = Native.Char.isHexDigit
20
25
21-- Convert to upper case.
26-- Convert to upper case.
22toUpper : Char -> Char
27toUpper : Char -> Char
28+toUpper = Native.Char.toUpper
23
29
24-- Convert to lower case.
30-- Convert to lower case.
25toLower : Char -> Char
31toLower : Char -> Char
32+toLower = Native.Char.toLower
26
33
27-- Convert to upper case, according to any locale-specific case mappings.
34-- Convert to upper case, according to any locale-specific case mappings.
28toLocaleUpper : Char -> Char
35toLocaleUpper : Char -> Char
36+toLocaleUpper = Native.Char.toLocaleUpper
29
37
30-- Convert to lower case, according to any locale-specific case mappings.
38-- Convert to lower case, according to any locale-specific case mappings.
31toLocaleLower : Char -> Char
39toLocaleLower : Char -> Char
40+toLocaleLower = Native.Char.toLocaleLower
41+
42+type KeyCode = Int
32
43
33-- Convert to unicode.
44-- Convert to unicode.
34toCode : Char -> KeyCode
45toCode : Char -> KeyCode
46+toCode = Native.Char.toCode
35
47
36-- Convert from unicode.
48-- Convert from unicode.
37fromCode : KeyCode -> Char
49fromCode : KeyCode -> Char
38−
50+fromCode = Native.Char.fromCode
libraries/Color.elm+7−2
@@ -1,6 +1,8 @@
1
1
2module Color where
2module Color where
3
3
4+import Native.Color
5+
4data Color = Color Int Int Int Float
6data Color = Color Int Int Int Float
5
7
6-- Create RGB colors with an alpha component for transparency.
8-- Create RGB colors with an alpha component for transparency.
@@ -56,16 +58,19 @@ forestGreen = Color 34 139 34 1
56-- Produce a &ldquo;complementary color&rdquo;.
58-- Produce a &ldquo;complementary color&rdquo;.
57-- The two colors will accent each other.
59-- The two colors will accent each other.
58complement : Color -> Color
60complement : Color -> Color
61+complement = Native.Color.complement
59
62
60-- Create [HSV colors](http://en.wikipedia.org/wiki/HSL_and_HSV)
63-- Create [HSV colors](http://en.wikipedia.org/wiki/HSL_and_HSV)
61-- with an alpha component for transparency.
64-- with an alpha component for transparency.
62hsva : Float -> Float -> Float -> Float -> Color
65hsva : Float -> Float -> Float -> Float -> Color
66+hsva = Native.Color.hsva
63
67
64-- Create [HSV colors](http://en.wikipedia.org/wiki/HSL_and_HSV).
68-- Create [HSV colors](http://en.wikipedia.org/wiki/HSL_and_HSV).
65-- This is very convenient for creating colors that cycle and shift.
69-- This is very convenient for creating colors that cycle and shift.
66--
70--
67-- hsv (degrees 240) 1 1 == blue
71-- hsv (degrees 240) 1 1 == blue
68hsv : Float -> Float -> Float -> Color
72hsv : Float -> Float -> Float -> Color
73+hsv = Native.Color.hsv
69
74
70data Gradient
75data Gradient
71 = Linear (Float,Float) (Float,Float) [(Float,Color)]
76 = Linear (Float,Float) (Float,Float) [(Float,Color)]
@@ -75,7 +80,7 @@ data Gradient
75-- of &ldquo;color stops&rdquo; that indicate how to interpolate between
80-- of &ldquo;color stops&rdquo; that indicate how to interpolate between
76-- the start and end points. See [this example](/edit/examples/Elements/LinearGradient.elm) for
81-- the start and end points. See [this example](/edit/examples/Elements/LinearGradient.elm) for
77-- a more visual explanation.
82-- 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
79linear = Linear
84linear = Linear
80
85
81-- Create a radial gradient. First takes a start point and inner radius.
86-- Create a radial gradient. First takes a start point and inner radius.
@@ -83,5 +88,5 @@ linear = Linear
83-- of &ldquo;color stops&rdquo; that indicate how to interpolate between
88-- of &ldquo;color stops&rdquo; that indicate how to interpolate between
84-- the inner and outer circles. See [this example](/edit/examples/Elements/RadialGradient.elm) for
89-- the inner and outer circles. See [this example](/edit/examples/Elements/RadialGradient.elm) for
85-- a more visual explanation.
90-- 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
87radial = Radial
92radial = Radial
libraries/Date.elm+19−4
@@ -4,6 +4,13 @@
4-- locale formatting or something.
4-- locale formatting or something.
5module Date where
5module Date where
6
6
7+import Basics (String)
8+import Native.Date
9+import Time (Time)
10+import Maybe (Maybe)
11+
12+data Date = Date
13+
7-- Represents the days of the week.
14-- Represents the days of the week.
8data Day = Mon | Tue | Wed | Thu | Fri | Sat | Sun
15data Day = Mon | Tue | Wed | Thu | Fri | Sat | Sun
9
16
@@ -14,37 +21,45 @@ data Month = Jan | Feb | Mar | Apr
14
21
15-- Attempt to read a date from a string.
22-- Attempt to read a date from a string.
16read : String -> Maybe Date
23read : String -> Maybe Date
24+read = Native.Date.read
17
25
18-- Convert a date into a time since midnight (UTC) of 1 January 1990 (i.e.
26-- Convert a date into a time since midnight (UTC) of 1 January 1990 (i.e.
19-- [UNIX time](http://en.wikipedia.org/wiki/Unix_time)). Given the date 23 June
27-- [UNIX time](http://en.wikipedia.org/wiki/Unix_time)). Given the date 23 June
20-- 1990 at 11:45AM this returns the corresponding time.
28-- 1990 at 11:45AM this returns the corresponding time.
21toTime : Date -> Time
29toTime : Date -> Time
30+toTime = Native.Date.toTime
22
31
23-- Extract the year of a given date. Given the date 23 June 1990 at 11:45AM
32-- Extract the year of a given date. Given the date 23 June 1990 at 11:45AM
24-- this returns the integer `1990`.
33-- this returns the integer `1990`.
25−year : Date -> Int
34+year : Date -> Int
35+year = Native.Date.year
26
36
27-- Extract the month of a given date. Given the date 23 June 1990 at 11:45AM
37-- Extract the month of a given date. Given the date 23 June 1990 at 11:45AM
28-- this returns the Month `Jun` as defined below.
38-- this returns the Month `Jun` as defined below.
29month : Date -> Month
39month : Date -> Month
30−
40+month = Native.Date.month
31
41
32-- Extract the day of a given date. Given the date 23 June 1990 at 11:45AM
42-- Extract the day of a given date. Given the date 23 June 1990 at 11:45AM
33-- this returns the integer `23`.
43-- this returns the integer `23`.
34−day : Date -> Int
44+day : Date -> Int
45+day = Native.Date.day
35
46
36-- Extract the day of the week for a given date. Given the date 23 June
47-- Extract the day of the week for a given date. Given the date 23 June
37-- 1990 at 11:45AM this returns the Day `Thu` as defined below.
48-- 1990 at 11:45AM this returns the Day `Thu` as defined below.
38dayOfWeek : Date -> Day
49dayOfWeek : Date -> Day
50+dayOfWeek = Native.Date.dayOfWeek
39
51
40-- Extract the hour of a given date. Given the date 23 June 1990 at 11:45AM
52-- Extract the hour of a given date. Given the date 23 June 1990 at 11:45AM
41-- this returns the integer `11`.
53-- this returns the integer `11`.
42−hour : Date -> Int
54+hour : Date -> Int
55+hour = Native.Date.hour
43
56
44-- Extract the minute of a given date. Given the date 23 June 1990 at 11:45AM
57-- Extract the minute of a given date. Given the date 23 June 1990 at 11:45AM
45-- this returns the integer `45`.
58-- this returns the integer `45`.
46minute : Date -> Int
59minute : Date -> Int
60+minute = Native.Date.minute
47
61
48-- Extract the second of a given date. Given the date 23 June 1990 at 11:45AM
62-- Extract the second of a given date. Given the date 23 June 1990 at 11:45AM
49-- this returns the integer `0`.
63-- this returns the integer `0`.
50second : Date -> Int
64second : Date -> Int
65+second = Native.Date.second
libraries/Dict.elm+41−40
@@ -8,17 +8,18 @@ module Dict (empty,singleton,insert
8 ,toList,fromList
8 ,toList,fromList
9 ) where
9 ) where
10
10
11−import Maybe as Maybe
11+import open Basics
12+import open Maybe
12−import Native.Error as Error
13+import Native.Error
13import List as List
14import List as List
14−import Native.Utils (compare)
15+import Native.Utils
15
16
16data NColor = Red | Black
17data NColor = Red | Black
17
18
18data Dict k v = RBNode NColor k v (Dict k v) (Dict k v) | RBEmpty
19data Dict k v = RBNode NColor k v (Dict k v) (Dict k v) | RBEmpty
19
20
20-- Create an empty dictionary.
21-- Create an empty dictionary.
21−empty : Dict (Comparable k) v
22+empty : Dict comparable v
22empty = RBEmpty
23empty = RBEmpty
23
24
24{-- Helpers for checking invariants
25{-- Helpers for checking invariants
@@ -104,36 +105,36 @@ min t =
104 case t of
105 case t of
105 RBNode _ k v RBEmpty _ -> (k,v)
106 RBNode _ k v RBEmpty _ -> (k,v)
106 RBNode _ _ _ l _ -> min l
107 RBNode _ _ _ l _ -> min l
107− RBEmpty -> Error.raise "(min Empty) is not defined"
108+ RBEmpty -> Native.Error.raise "(min Empty) is not defined"
108
109
109{--
110{--
110max t =
111max t =
111 case t of
112 case t of
112 { RBNode _ k v _ RBEmpty -> (k,v)
113 { RBNode _ k v _ RBEmpty -> (k,v)
113 ; RBNode _ _ _ _ r -> max r
114 ; RBNode _ _ _ _ r -> max r
114− ; RBEmpty -> Error.raise "(max Empty) is not defined"
115+ ; RBEmpty -> Native.Error.raise "(max Empty) is not defined"
115 }
116 }
116--}
117--}
117
118
118-- Lookup the value associated with a key.
119-- 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
120lookup k t =
121lookup k t =
121 case t of
122 case t of
122− RBEmpty -> Maybe.Nothing
123+ RBEmpty -> Nothing
123 RBNode _ k' v l r ->
124 RBNode _ k' v l r ->
124− case compare k k' of
125+ case Native.Utils.compare k k' of
125 LT -> lookup k l
126 LT -> lookup k l
126− EQ -> Maybe.Just v
127+ EQ -> Just v
127 GT -> lookup k r
128 GT -> lookup k r
128
129
129-- Find the value associated with a key. If the key is not found,
130-- Find the value associated with a key. If the key is not found,
130-- return the default value.
131-- return the default value.
131−findWithDefault : v -> Comparable k -> Dict (Comparable k) v -> v
132+findWithDefault : v -> comparable -> Dict comparable v -> v
132findWithDefault base k t =
133findWithDefault base k t =
133 case t of
134 case t of
134 RBEmpty -> base
135 RBEmpty -> base
135 RBNode _ k' v l r ->
136 RBNode _ k' v l r ->
136− case compare k k' of
137+ case Native.Utils.compare k k' of
137 LT -> findWithDefault base k l
138 LT -> findWithDefault base k l
138 EQ -> v
139 EQ -> v
139 GT -> findWithDefault base k r
140 GT -> findWithDefault base k r
@@ -142,9 +143,9 @@ findWithDefault base k t =
142-- Find the value associated with a key. If the key is not found, there will be a runtime error.
143-- Find the value associated with a key. If the key is not found, there will be a runtime error.
143find k t =
144find k t =
144 case t of
145 case t of
145− { RBEmpty -> Error.raise "Key was not found in dictionary!"
146+ { RBEmpty -> Native.Error.raise "Key was not found in dictionary!"
146 ; RBNode _ k' v l r ->
147 ; RBNode _ k' v l r ->
147− case compare k k' of
148+ case Native.Utils.compare k k' of
148 { LT -> find k l
149 { LT -> find k l
149 ; EQ -> v
150 ; EQ -> v
150 ; GT -> find k r }
151 ; GT -> find k r }
@@ -152,15 +153,15 @@ find k t =
152--}
153--}
153
154
154-- Determine if a key is in a dictionary.
155-- Determine if a key is in a dictionary.
155−member : Comparable k -> Dict (Comparable k) v -> Bool
156+member : comparable -> Dict comparable v -> Bool
156-- Does t contain k?
157-- Does t contain k?
157−member k t = Maybe.isJust $ lookup k t
158+member k t = isJust <| lookup k t
158
159
159rotateLeft : Dict k v -> Dict k v
160rotateLeft : Dict k v -> Dict k v
160rotateLeft t =
161rotateLeft t =
161 case t of
162 case t of
162 RBNode cy ky vy a (RBNode cz kz vz b c) -> RBNode cy kz vz (RBNode Red ky vy a b) c
163 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"
164
165
165-- rotateRight -- the reverse, and
166-- rotateRight -- the reverse, and
166-- makes Y have Z's color, and makes Z Red.
167-- makes Y have Z's color, and makes Z Red.
@@ -168,7 +169,7 @@ rotateRight : Dict k v -> Dict k v
168rotateRight t =
169rotateRight t =
169 case t of
170 case t of
170 RBNode cz kz vz (RBNode cy ky vy a b) c -> RBNode cz ky vy a (RBNode Red kz vz b c)
171 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"
172
173
173rotateLeftIfNeeded : Dict k v -> Dict k v
174rotateLeftIfNeeded : Dict k v -> Dict k v
174rotateLeftIfNeeded t =
175rotateLeftIfNeeded t =
@@ -191,7 +192,7 @@ color_flip t =
191 RBNode (otherColor c1) bk bv
192 RBNode (otherColor c1) bk bv
192 (RBNode (otherColor c2) ak av la ra)
193 (RBNode (otherColor c2) ak av la ra)
193 (RBNode (otherColor c3) ck cv lc rc)
194 (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"
195
196
196color_flipIfNeeded : Dict k v -> Dict k v
197color_flipIfNeeded : Dict k v -> Dict k v
197color_flipIfNeeded t =
198color_flipIfNeeded t =
@@ -209,13 +210,13 @@ ensureBlackRoot t =
209
210
210-- Insert a key-value pair into a dictionary. Replaces value when there is
211-- Insert a key-value pair into a dictionary. Replaces value when there is
211-- a collision.
212-- 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
213insert k v t = -- Invariant: t is a valid left-leaning rb tree
214insert k v t = -- Invariant: t is a valid left-leaning rb tree
214 let ins t =
215 let ins t =
215 case t of
216 case t of
216 RBEmpty -> RBNode Red k v RBEmpty RBEmpty
217 RBEmpty -> RBNode Red k v RBEmpty RBEmpty
217 RBNode c k' v' l r ->
218 RBNode c k' v' l r ->
218− let h = case compare k k' of
219+ let h = case Native.Utils.compare k k' of
219 LT -> RBNode c k' v' (ins l) r
220 LT -> RBNode c k' v' (ins l) r
220 EQ -> RBNode c k' v l r -- replace
221 EQ -> RBNode c k' v l r -- replace
221 GT -> RBNode c k' v' l (ins r)
222 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
223 in ensureBlackRoot (ins t)
224 in ensureBlackRoot (ins t)
224{--
225{--
225 if not (invariants_hold t) then
226 if not (invariants_hold t) then
226− Error.raise "invariants broken before insert"
227+ Native.Error.raise "invariants broken before insert"
227 else (let new_t = ensureBlackRoot (ins t) in
228 else (let new_t = ensureBlackRoot (ins t) in
228 if not (invariants_hold new_t) then
229 if not (invariants_hold new_t) then
229− Error.raise "invariants broken after insert"
230+ Native.Error.raise "invariants broken after insert"
230 else new_t)
231 else new_t)
231--}
232--}
232
233
233-- Create a dictionary with one key-value pair.
234-- Create a dictionary with one key-value pair.
234−singleton : Comparable k -> v -> Dict (Comparable k) v
235+singleton : comparable -> v -> Dict comparable v
235singleton k v = insert k v RBEmpty
236singleton k v = insert k v RBEmpty
236
237
237isRed : Dict k v -> Bool
238isRed : Dict k v -> Bool
@@ -313,21 +314,21 @@ deleteMax t =
313
314
314-- Remove a key-value pair from a dictionary. If the key is not found,
315-- Remove a key-value pair from a dictionary. If the key is not found,
315-- no changes are made.
316-- 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
317remove k t =
318remove k t =
318 let eq_and_noRightNode t =
319 let eq_and_noRightNode t =
319 case t of { RBNode _ k' _ _ RBEmpty -> k == k' ; _ -> False }
320 case t of { RBNode _ k' _ _ RBEmpty -> k == k' ; _ -> False }
320 eq t = case t of { RBNode _ k' _ _ _ -> k == k' ; _ -> False }
321 eq t = case t of { RBNode _ k' _ _ _ -> k == k' ; _ -> False }
321 delLT t = case moveRedLeftIfNeeded t of
322 delLT t = case moveRedLeftIfNeeded t of
322 RBNode c k' v l r -> fixUp (RBNode c k' v (del l) r)
323 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"
324 delEQ t = case t of -- Replace with successor
325 delEQ t = case t of -- Replace with successor
325 RBNode c _ _ l r -> let (k',v') = min r in
326 RBNode c _ _ l r -> let (k',v') = min r in
326 fixUp (RBNode c k' v' l (deleteMin r))
327 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"
328 delGT t = case t of
329 delGT t = case t of
329 RBNode c k' v l r -> fixUp (RBNode c k' v l (del r))
330 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"
331 del t = case t of
332 del t = case t of
332 RBEmpty -> RBEmpty
333 RBEmpty -> RBEmpty
333 RBNode _ k' _ _ _ ->
334 RBNode _ k' _ _ _ ->
@@ -339,14 +340,14 @@ remove k t =
339 in if member k t then ensureBlackRoot (del t) else t
340 in if member k t then ensureBlackRoot (del t) else t
340{--
341{--
341 if not (invariants_hold t) then
342 if not (invariants_hold t) then
342− Error.raise "invariants broken before remove"
343+ Native.Error.raise "invariants broken before remove"
343 else (let t' = ensureBlackRoot (del t) in
344 else (let t' = ensureBlackRoot (del t) in
344 if invariants_hold t' then t' else
345 if invariants_hold t' then t' else
345− Error.raise "invariants broken after remove")
346+ Native.Error.raise "invariants broken after remove")
346--}
347--}
347
348
348-- Apply a function to all values in a dictionary.
349-- 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
350map f t =
351map f t =
351 case t of
352 case t of
352 RBEmpty -> RBEmpty
353 RBEmpty -> RBEmpty
@@ -354,7 +355,7 @@ map f t =
354
355
355-- Fold over the key-value pairs in a dictionary, in order from lowest
356-- Fold over the key-value pairs in a dictionary, in order from lowest
356-- key to highest key.
357-- 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
358foldl f acc t =
359foldl f acc t =
359 case t of
360 case t of
360 RBEmpty -> acc
361 RBEmpty -> acc
@@ -362,7 +363,7 @@ foldl f acc t =
362
363
363-- Fold over the key-value pairs in a dictionary, in order from highest
364-- Fold over the key-value pairs in a dictionary, in order from highest
364-- key to lowest key.
365-- 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
366foldr f acc t =
367foldr f acc t =
367 case t of
368 case t of
368 RBEmpty -> acc
369 RBEmpty -> acc
@@ -370,33 +371,33 @@ foldr f acc t =
370
371
371-- Combine two dictionaries. If there is a collision, preference is given
372-- Combine two dictionaries. If there is a collision, preference is given
372-- to the first dictionary.
373-- 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
374union t1 t2 = foldl insert t2 t1
375union t1 t2 = foldl insert t2 t1
375
376
376-- Keep a key-value pair when its key appears in the second dictionary.
377-- Keep a key-value pair when its key appears in the second dictionary.
377-- Preference is given to values in the first dictionary.
378-- 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
379intersect t1 t2 =
380intersect t1 t2 =
380 let combine k v t = if k `member` t2 then insert k v t else t
381 let combine k v t = if k `member` t2 then insert k v t else t
381 in foldl combine empty t1
382 in foldl combine empty t1
382
383
383-- Keep a key-value pair when its key does not appear in the second dictionary.
384-- Keep a key-value pair when its key does not appear in the second dictionary.
384-- Preference is given to the first dictionary.
385-- 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
386diff t1 t2 = foldl (\k v t -> remove k t) t1 t2
387diff t1 t2 = foldl (\k v t -> remove k t) t1 t2
387
388
388-- Get all of the keys in a dictionary.
389-- Get all of the keys in a dictionary.
389−keys : Dict (Comparable k) v -> [Comparable k]
390+keys : Dict comparable v -> [comparable]
390keys t = foldr (\k v acc -> k :: acc) [] t
391keys t = foldr (\k v acc -> k :: acc) [] t
391
392
392-- Get all of the values in a dictionary.
393-- Get all of the values in a dictionary.
393−values : Dict (Comparable k) v -> [v]
394+values : Dict comparable v -> [v]
394values t = foldr (\k v acc -> v :: acc) [] t
395values t = foldr (\k v acc -> v :: acc) [] t
395
396
396-- Convert a dictionary into an association list of key-value pairs.
397-- 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)]
398toList t = foldr (\k v acc -> (k,v) :: acc) [] t
399toList t = foldr (\k v acc -> (k,v) :: acc) [] t
399
400
400-- Convert an association list into a dictionary.
401-- Convert an association list into a dictionary.
401−fromList : [(Comparable k,v)] -> Dict (Comparable k) v
402+fromList : [(comparable,v)] -> Dict comparable v
402fromList assocs = List.foldl (\(k,v) d -> insert k v d) empty assocs
403fromList assocs = List.foldl (\(k,v) d -> insert k v d) empty assocs
libraries/Graphics/Collage.elm+31−28
@@ -1,13 +1,15 @@
1
1
2module Graphics.Collage where
2module Graphics.Collage where
3
3
4+import open Basics
4import List
5import List
5−import Native.Utils (toFloat)
6+import Either (Either, Left, Right)
6−import Either
7−import Native.Matrix2D as Matrix
7+import Matrix2D (Matrix2D, identity)
8−import Native.Graphics.Collage as N
8+import Native.Graphics.Collage
9−import Graphics.Element
9+import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)
10−import Color
10+import Color (Color, black, Gradient)
11+import Maybe (Maybe)
12+import JavaScript (JSString)
11
13
12type Form = {
14type Form = {
13 theta : Float,
15 theta : Float,
@@ -21,7 +23,7 @@ type Form = {
21data FillStyle
23data FillStyle
22 = Solid Color
24 = Solid Color
23 | Texture String
25 | Texture String
24− | Gradient Gradient
26+ | Grad Gradient
25
27
26-- The shape of the ends of a line.
28-- The shape of the ends of a line.
27data LineCap = Flat | Round | Padded
29data LineCap = Flat | Round | Padded
@@ -49,7 +51,7 @@ type LineStyle = {
49-- { defaultLine | width <- 10 }
51-- { defaultLine | width <- 10 }
50defaultLine : LineStyle
52defaultLine : LineStyle
51defaultLine = {
53defaultLine = {
52− color = Color.black,
54+ color = black,
53 width = 1,
55 width = 1,
54 cap = Flat,
56 cap = Flat,
55 join = Sharp 10,
57 join = Sharp 10,
@@ -79,7 +81,7 @@ data BasicForm
79form : BasicForm -> Form
81form : BasicForm -> Form
80form f = { theta=0, scale=1, x=0, y=0, alpha=1, form=f }
82form f = { theta=0, scale=1, x=0, y=0, alpha=1, form=f }
81
83
82−fill style shape = form (FShape (Either.Right style) shape)
84+fill style shape = form (FShape (Right style) shape)
83
85
84-- Create a filled in shape.
86-- Create a filled in shape.
85filled : Color -> Shape -> Form
87filled : Color -> Shape -> Form
@@ -92,11 +94,11 @@ textured src shape = fill (Texture src) shape
92
94
93-- Fill a shape with a [gradient](/docs/Color.elm#linear).
95-- Fill a shape with a [gradient](/docs/Color.elm#linear).
94gradient : Gradient -> Shape -> Form
96gradient : Gradient -> Shape -> Form
95−gradient grad shape = fill (Gradient grad) shape
97+gradient grad shape = fill (Grad grad) shape
96
98
97-- Outline a shape with a given line style.
99-- Outline a shape with a given line style.
98outlined : LineStyle -> Shape -> Form
100outlined : LineStyle -> Shape -> Form
99−outlined style shape = form (FShape (Either.Left style) shape)
101+outlined style shape = form (FShape (Left style) shape)
100
102
101-- Trace a path with a given line style.
103-- Trace a path with a given line style.
102traced : LineStyle -> Path -> Form
104traced : LineStyle -> Path -> Form
@@ -116,7 +118,7 @@ toForm e = form (FElement e)
116-- Flatten many forms into a single `Form`. This lets you move and rotate them
118-- Flatten many forms into a single `Form`. This lets you move and rotate them
117-- as a single unit, making it possible to build small, modular components.
119-- as a single unit, making it possible to build small, modular components.
118group : [Form] -> Form
120group : [Form] -> Form
119−group fs = form (FGroup Matrix.identity fs)
121+group fs = form (FGroup identity fs)
120
122
121-- Flatten many forms into a single `Form` and then apply a matrix
123-- Flatten many forms into a single `Form` and then apply a matrix
122-- transformation.
124-- transformation.
@@ -149,23 +151,24 @@ moveX x f = { f | x <- f.x + x }
149moveY : Float -> Form -> Form
151moveY : Float -> Form -> Form
150moveY y f = { f | y <- f.y + y }
152moveY y f = { f | y <- f.y + y }
151
153
152−-- Set the opacity of a `Form`. The default is 1, and 0 is totally transparent.
154+-- Set the alpha of a `Form`. The default is 1, and 0 is totally transparent.
153−opacity : Float -> Form -> Form
155+alpha : Float -> Form -> Form
154−opacity a f = { f | alpha <- a }
156+alpha a f = { f | alpha <- a }
155
157
156-- A collage is a collection of 2D forms. There are no strict positioning
158-- A collage is a collection of 2D forms. There are no strict positioning
157-- relationships between forms, so you are free to do all kinds of 2D graphics.
159-- relationships between forms, so you are free to do all kinds of 2D graphics.
158collage : Int -> Int -> [Form] -> Element
160collage : Int -> Int -> [Form] -> Element
161+collage = Native.Graphics.Collage.collage
159
162
160
163
161type Path = [(Float,Float)]
164type Path = [(Float,Float)]
162
165
163-- Create a path that follows a sequence of points.
166-- Create a path that follows a sequence of points.
164−path : [(Number a,Number a)] -> Path
167+path : [(Float,Float)] -> Path
165path ps = ps
168path ps = ps
166
169
167-- Create a path along a given line segment.
170-- Create a path along a given line segment.
168−segment : (Number a,Number a) -> (Number a,Number a) -> Path
171+segment : (Float,Float) -> (Float,Float) -> Path
169segment p1 p2 = [p1,p2]
172segment p1 p2 = [p1,p2]
170
173
171type Shape = [(Float,Float)]
174type Shape = [(Float,Float)]
@@ -173,31 +176,31 @@ type Shape = [(Float,Float)]
173-- Create an arbitrary polygon by specifying its corners in order.
176-- Create an arbitrary polygon by specifying its corners in order.
174-- `polygon` will automatically close all shapes, so the given list
177-- `polygon` will automatically close all shapes, so the given list
175-- of points does not need to start and end with the same position.
178-- of points does not need to start and end with the same position.
176−polygon : [(Number a,Number a)] -> Shape
179+polygon : [(Float,Float)] -> Shape
177polygon points = points
180polygon points = points
178
181
179-- A rectangle with a given width and height.
182-- A rectangle with a given width and height.
180−rect : Number a -> Number a -> Shape
183+rect : Float -> Float -> Shape
181rect w h = let hw = w/2
184rect w h = let hw = w/2
182 hh = h/2
185 hh = h/2
183 in [ (0-hw,0-hh), (0-hw,hh), (hw,hh), (hw,0-hh) ]
186 in [ (0-hw,0-hh), (0-hw,hh), (hw,hh), (hw,0-hh) ]
184
187
185-- A square with a given edge length.
188-- A square with a given edge length.
186−square : Number a -> Shape
189+square : Float -> Shape
187square n = rect n n
190square n = rect n n
188
191
189-- An oval with a given width and height.
192-- An oval with a given width and height.
190−oval : Number a -> Number a -> Shape
193+oval : Float -> Float -> Shape
191oval w h =
194oval w h =
192 let n = 50
195 let n = 50
193− t = 2 * Math.PI / n
196+ t = 2 * pi / n
194 hw = w/2
197 hw = w/2
195 hh = h/2
198 hh = h/2
196− f i = (hw * Math.cos (t*i), hh * Math.sin (t*i))
199+ f i = (hw * cos (t*i), hh * sin (t*i))
197 in List.map f [0..n-1]
200 in List.map f [0..n-1]
198
201
199-- A circle with a given radius.
202-- A circle with a given radius.
200−circle : Number a -> Shape
203+circle : Float -> Shape
201circle r = oval (2*r) (2*r)
204circle r = oval (2*r) (2*r)
202
205
203-- A regular polygon with N sides. The first argument specifies the number
206-- A regular polygon with N sides. The first argument specifies the number
@@ -205,9 +208,9 @@ circle r = oval (2*r) (2*r)
205-- 30 you would say:
208-- 30 you would say:
206--
209--
207-- ngon 5 30
210-- ngon 5 30
208−ngon : Int -> Number a -> Shape
211+ngon : Int -> Float -> Shape
209ngon n r =
212ngon n r =
210 let m = toFloat n
213 let m = toFloat n
211− t = 2 * Math.PI / m
214+ t = 2 * pi / m
212− f i = ( r * Math.cos (t*i), r * Math.sin (t*i) )
215+ f i = ( r * cos (t*i), r * sin (t*i) )
213− in List.map f [0..n-1]
216+ in List.map f [0..m-1]
libraries/Graphics/Element.elm+30−32
@@ -1,22 +1,13 @@
1
1
2−module Graphics.Element (widthOf, heightOf, sizeOf,
2+module Graphics.Element where
3− width, height, size, opacity, color, tag, link,
3+
4− image, fittedImage, croppedImage, tiledImage,
4+import open Basics
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)
5+import Native.Utils
16import JavaScript as JS
6import JavaScript as JS
7+import JavaScript (JSString)
17import List as List
8import List as List
18−import Color
9+import open Color
19−import Maybe (Just, Nothing)
10+import Maybe (Maybe, Just, Nothing)
20
11
21type Properties = {
12type Properties = {
22 id : Int,
13 id : Int,
@@ -45,20 +36,22 @@ sizeOf e = (e.props.width, e.props.height)
45
36
46-- Create an `Element` with a given width.
37-- Create an `Element` with a given width.
47width : Int -> Element -> Element
38width : Int -> Element -> Element
39+width nw e =
48−width nw e = let p = e.props
40+ let p = e.props
49− props = case e.element of
41+ props = case e.element of
50− Image _ w h _ -> {p| height <- h/w*nw }
42+ Image _ w h _ -> {p| height <- round (toFloat h / toFloat w * toFloat nw) }
51− RawHtml html -> {p| height <- let (w,h) = htmlHeight nw html in h}
43+ RawHtml html -> {p| height <- snd (Native.Utils.htmlHeight nw html)}
52− _ -> p
44+ _ -> p
53− in { element=e.element, props={props| width <- nw} }
45+ in { element=e.element, props={ props | width <- nw } }
54
46
55-- Create an `Element` with a given height.
47-- Create an `Element` with a given height.
56height : Int -> Element -> Element
48height : Int -> Element -> Element
49+height nh e =
57−height nh e = let p = e.props
50+ let p = e.props
58− props = case e.element of
51+ props = case e.element of
59− Image _ w h _ -> {p| width <- w/h*nh }
52+ Image _ w h _ -> {p| width <- round (toFloat w / toFloat h * toFloat nh) }
60− _ -> p
53+ _ -> p
61− in { element=e.element, props={p| height <- nh} }
54+ in { element=e.element, props={ p | height <- nh} }
62
55
63-- Create an `Element` with a new width and height.
56-- Create an `Element` with a new width and height.
64size : Int -> Int -> Element -> Element
57size : Int -> Int -> Element -> Element
@@ -71,24 +64,26 @@ opacity o e = let p = e.props in { element=e.element, props={p| opacity <- o} }
71
64
72-- Create an `Element` with a given background color.
65-- Create an `Element` with a given background color.
73color : Color -> Element -> Element
66color : Color -> Element -> Element
74−color c e = let p = e.props in
67+color c e = let p = e.props in
68+ { element = e.element
75− { element=e.element, props={p| color <- Just c} }
69+ , props = { p | color <- Just c}
70+ }
76
71
77-- Create an `Element` with a tag. This lets you link directly to it.
72-- Create an `Element` with a tag. This lets you link directly to it.
78-- The element `(tag "all-about-badgers" thirdParagraph)` can be reached
73-- The element `(tag "all-about-badgers" thirdParagraph)` can be reached
79-- with a link lik this: `/facts-about-animals.elm#all-about-badgers`
74-- with a link lik this: `/facts-about-animals.elm#all-about-badgers`
80tag : String -> Element -> Element
75tag : String -> Element -> Element
81tag name e = let p = e.props in
76tag name e = let p = e.props in
82− { element=e.element, props={p| tag <- JS.fromString name} }
77+ { element=e.element, props={p | tag <- JS.fromString name} }
83
78
84-- Create an `Element` that is a hyper-link.
79-- Create an `Element` that is a hyper-link.
85link : String -> Element -> Element
80link : String -> Element -> Element
86link href e = let p = e.props in
81link href e = let p = e.props in
87− { element=e.element, props={p| href <- JS.fromString href} }
82+ { element=e.element, props={p | href <- JS.fromString href} }
88
83
89emptyStr = JS.fromString ""
84emptyStr = JS.fromString ""
90newElement w h e =
85newElement w h e =
91− { 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 }
92
87
93data ElementPrim
88data ElementPrim
94 = Image ImageStyle Int Int JSString
89 = Image ImageStyle Int Int JSString
@@ -122,6 +117,9 @@ tiledImage : Int -> Int -> String -> Element
122tiledImage w h src =
117tiledImage w h src =
123 newElement w h (Image Tiled w h (JS.fromString src))
118 newElement w h (Image Tiled w h (JS.fromString src))
124
119
120+markdown : Element
121+markdown = Native.Utils.undefined
122+
125data Three = P | Z | N
123data Three = P | Z | N
126data Pos = Absolute Int | Relative Float
124data Pos = Absolute Int | Relative Float
127type Position = { horizontal : Three, vertical : Three, x : Pos, y : Pos }
125type Position = { horizontal : Three, vertical : Three, x : Pos, y : Pos }
libraries/Graphics/Input.elm+22−11
@@ -1,9 +1,14 @@
1
1
2module Graphics.Input where
2module Graphics.Input where
3
3
4+import Basics (String)
4−import Signal (lift,dropRepeats)
5+import Signal (Signal,lift,dropRepeats)
5−import Native.Graphics.Input as N
6+import Native.Graphics.Input
6import List
7import List
8+import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)
9+import Color (Color)
10+import Maybe (Maybe)
11+import JavaScript (JSString)
7
12
8id x = x
13id x = x
9
14
@@ -17,12 +22,13 @@ id x = x
17-- The `a` value is sent to `events` whenever the button is pressed.
22-- The `a` value is sent to `events` whenever the button is pressed.
18buttons : a -> { events : Signal a,
23buttons : a -> { events : Signal a,
19 button : a -> String -> Element }
24 button : a -> String -> Element }
25+buttons = Native.Graphics.Input.buttons
20
26
21-- Create a button with a given label. The result is an `Element` and
27-- Create a button with a given label. The result is an `Element` and
22-- a signal of units. This signal triggers whenever the button is pressed.
28-- a signal of units. This signal triggers whenever the button is pressed.
23button : String -> (Element, Signal ())
29button : String -> (Element, Signal ())
24button txt =
30button txt =
25− let pool = N.buttons ()
31+ let pool = buttons ()
26 in (pool.button () txt, pool.events)
32 in (pool.button () txt, pool.events)
27
33
28-- Create a group of custom buttons.
34-- Create a group of custom buttons.
@@ -36,13 +42,14 @@ button txt =
36-- The `a` value is sent to `events` whenever the button is pressed.
42-- The `a` value is sent to `events` whenever the button is pressed.
37customButtons : a -> { events : Signal a,
43customButtons : a -> { events : Signal a,
38 customButton : a -> Element -> Element -> Element -> Element }
44 customButton : a -> Element -> Element -> Element -> Element }
45+customButtons = Native.Graphics.Input.customButtons
39
46
40-- Create a button with custom states for up, hovering, and down
47-- Create a button with custom states for up, hovering, and down
41-- (given in that order). The result is an `Element` and
48-- (given in that order). The result is an `Element` and
42-- a signal of units. This signal triggers whenever the button is pressed.
49-- a signal of units. This signal triggers whenever the button is pressed.
43customButton : Element -> Element -> Element -> (Element, Signal ())
50customButton : Element -> Element -> Element -> (Element, Signal ())
44customButton up hover down =
51customButton up hover down =
45− let pool = N.customButtons ()
52+ let pool = customButtons ()
46 in (pool.customButton () up hover down, pool.events)
53 in (pool.customButton () up hover down, pool.events)
47
54
48-- Create a group of checkboxes.
55-- Create a group of checkboxes.
@@ -57,6 +64,7 @@ customButton up hover down =
57-- lets you add an ID to distinguish between checkboxes.
64-- lets you add an ID to distinguish between checkboxes.
58checkboxes : a -> { events : Signal a,
65checkboxes : a -> { events : Signal a,
59 checkbox : (Bool -> a) -> Bool -> Element }
66 checkbox : (Bool -> a) -> Bool -> Element }
67+checkboxes = Native.Graphics.Input.checkboxes
60
68
61-- Create a checkbox with a given start state. Unlike `button`, this result
69-- Create a checkbox with a given start state. Unlike `button`, this result
62-- is a *signal* of elements. That is because a checkbox has state that
70-- is a *signal* of elements. That is because a checkbox has state that
@@ -64,15 +72,16 @@ checkboxes : a -> { events : Signal a,
64-- The boolean signal represents the current state of the checkbox.
72-- The boolean signal represents the current state of the checkbox.
65checkbox : Bool -> (Signal Element, Signal Bool)
73checkbox : Bool -> (Signal Element, Signal Bool)
66checkbox b =
74checkbox b =
67− let cbs = N.checkboxes b
75+ let cbs = checkboxes b
68− in (lift (cbs.box id) cbs.events, cbs.events)
76+ in (lift (cbs.checkbox id) cbs.events, cbs.events)
69
77
70hoverables : a -> { events : Signal a,
78hoverables : a -> { events : Signal a,
71 hoverable : (Bool -> a) -> Element -> Element }
79 hoverable : (Bool -> a) -> Element -> Element }
80+hoverables = Native.Graphics.Input.hoverables
72
81
73hoverable : Element -> (Element, Signal Bool)
82hoverable : Element -> (Element, Signal Bool)
74hoverable elem =
83hoverable elem =
75− let pool = N.hoverables False
84+ let pool = hoverables False
76 in (pool.hoverable id elem, pool.events)
85 in (pool.hoverable id elem, pool.events)
77
86
78-- Represents the current state of a text field. The `string` represents the
87-- Represents the current state of a text field. The `string` represents the
@@ -98,6 +107,7 @@ type FieldState = { string:String, selectionStart:Int, selectionEnd:Int }
98-- lets you add an ID to distinguish between input fields.
107-- lets you add an ID to distinguish between input fields.
99fields : a -> { events : Signal a,
108fields : a -> { events : Signal a,
100 field : (FieldState -> a) -> String -> FieldState -> Element }
109 field : (FieldState -> a) -> String -> FieldState -> Element }
110+fields = Native.Graphics.Input.fields
101
111
102-- The empty field state:
112-- The empty field state:
103--
113--
@@ -110,7 +120,7 @@ emptyFieldState = { string="", selectionStart=0, selectionEnd=0 }
110-- content of the field.
120-- content of the field.
111field : String -> (Signal Element, Signal String)
121field : String -> (Signal Element, Signal String)
112field placeHolder =
122field placeHolder =
113− let tfs = N.fields emptyFieldState
123+ let tfs = fields emptyFieldState
114 changes = dropRepeats tfs.events
124 changes = dropRepeats tfs.events
115 in (lift (tfs.field id placeHolder) changes,
125 in (lift (tfs.field id placeHolder) changes,
116 dropRepeats (lift .string changes))
126 dropRepeats (lift .string changes))
@@ -118,7 +128,7 @@ field placeHolder =
118-- Same as `field` but the UI element blocks out each characters.
128-- Same as `field` but the UI element blocks out each characters.
119password : String -> (Signal Element, Signal String)
129password : String -> (Signal Element, Signal String)
120password placeHolder =
130password placeHolder =
121− let tfs = N.passwords emptyFieldState
131+ let tfs = Native.Graphics.Input.passwords emptyFieldState
122 changes = dropRepeats tfs.events
132 changes = dropRepeats tfs.events
123 in (lift (tfs.field id placeHolder) changes,
133 in (lift (tfs.field id placeHolder) changes,
124 dropRepeats (lift .string changes))
134 dropRepeats (lift .string changes))
@@ -128,7 +138,7 @@ password placeHolder =
128-- get a custom keyboard with an `@` and `.com` button.
138-- get a custom keyboard with an `@` and `.com` button.
129email : String -> (Signal Element, Signal String)
139email : String -> (Signal Element, Signal String)
130email placeHolder =
140email placeHolder =
131− let tfs = N.emails emptyFieldState
141+ let tfs = Native.Graphics.Input.emails emptyFieldState
132 changes = dropRepeats tfs.events
142 changes = dropRepeats tfs.events
133 in (lift (tfs.field id placeHolder) changes,
143 in (lift (tfs.field id placeHolder) changes,
134 dropRepeats (lift .string changes))
144 dropRepeats (lift .string changes))
@@ -138,9 +148,10 @@ email placeHolder =
138-- value. This lets you avoid manually mapping the string onto
148-- value. This lets you avoid manually mapping the string onto
139-- functions and values.
149-- functions and values.
140dropDown : [(String,a)] -> (Signal Element, Signal a)
150dropDown : [(String,a)] -> (Signal Element, Signal a)
151+dropDown = Native.Graphics.Input.dropDown
141
152
142-- Create a drop-down menu for selecting strings. The resulting
153-- Create a drop-down menu for selecting strings. The resulting
143-- signal of strings represents the string that is currently selected.
154-- signal of strings represents the string that is currently selected.
144stringDropDown : [String] -> (Signal Element, Signal String)
155stringDropDown : [String] -> (Signal Element, Signal String)
145stringDropDown strs =
156stringDropDown strs =
146− 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 @@
4
4
5module Http where
5module Http where
6
6
7+import open Basics
8+import open Signal
7−import Native.Http (send)
9+import Native.Http
8−import Signal (lift)
9
10
10-- The datatype for responses. Success contains only the returned message.
11-- The datatype for responses. Success contains only the returned message.
11-- Failures contain both an error code and an error message.
12-- Failures contain both an error code and an error message.
@@ -35,6 +36,7 @@ post url body = Request "POST" url body []
35-- Performs an HTTP request with the given requests. Produces a signal
36-- Performs an HTTP request with the given requests. Produces a signal
36-- that carries the responses.
37-- that carries the responses.
37send : Signal (Request a) -> Signal (Response String)
38send : Signal (Request a) -> Signal (Response String)
39+send = Native.Http.send
38
40
39-- Performs an HTTP GET request with the given urls. Produces a signal
41-- Performs an HTTP GET request with the given urls. Produces a signal
40-- that carries the responses.
42-- that carries the responses.
libraries/JavaScript.elm+31−1
@@ -1,26 +1,56 @@
1
1
2module JavaScript where
2module JavaScript where
3
3
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
4
13
5-- Requires that the input array be uniform (all members have the same type)
14-- Requires that the input array be uniform (all members have the same type)
6toList : JSArray a -> [a]
15toList : JSArray a -> [a]
16+toList = Native.JavaScript.toList
17+
7toInt : JSNumber -> Int
18toInt : JSNumber -> Int
19+toInt = Native.JavaScript.toInt
20+
8toFloat : JSNumber -> Float
21toFloat : JSNumber -> Float
22+toFloat = Native.JavaScript.toFloat
23+
9toBool : JSBool -> Bool
24toBool : JSBool -> Bool
25+toBool = Native.JavaScript.toBool
26+
10toString : JSString -> String
27toString : JSString -> String
28+toString = Native.JavaScript.toString
11
29
12
30
13-- Produces a uniform JavaScript array with all members of the same type.
31-- Produces a uniform JavaScript array with all members of the same type.
14fromList : [a] -> JSArray a
32fromList : [a] -> JSArray a
33+fromList = Native.JavaScript.fromList
34+
15fromInt : Int -> JSNumber
35fromInt : Int -> JSNumber
36+fromInt = Native.JavaScript.fromInt
37+
16fromFloat : Float -> JSNumber
38fromFloat : Float -> JSNumber
39+fromFloat = Native.JavaScript.fromFloat
40+
17fromBool : Bool -> JSBool
41fromBool : Bool -> JSBool
18−fromString : String -> JSString
42+fromBool = Native.JavaScript.fromBool
19
43
44+fromString : String -> JSString
45+fromString = Native.JavaScript.fromString
20
46
47+{--
21-- Turn an `Element` into a plain old DOM node.
48-- Turn an `Element` into a plain old DOM node.
22fromElement : Element -> JSDomNode
49fromElement : Element -> JSDomNode
50+fromElement = Native.JavaScript.fromElement
23
51
24-- Turn a DOM node into an `Element`. You can resize the node
52-- Turn a DOM node into an `Element`. You can resize the node
25-- using the normal `width` and `height` functions.
53-- using the normal `width` and `height` functions.
26toElement : Int -> Int -> JSDomNode -> Element
54toElement : Int -> Int -> JSDomNode -> Element
55+toElement = Native.JavaScript.toElement
56+--}
libraries/JavaScript/Experimental.elm+4−3
@@ -1,7 +1,8 @@
1
1
2module JavaScript.Experimental where
2module JavaScript.Experimental where
3
3
4−import JavaScript as JS
4+import JavaScript (JSObject)
5+import Native.JavaScript
5
6
6-- Turn arbitrary JavaScript objects into Elm records.
7-- Turn arbitrary JavaScript objects into Elm records.
7-- Arrays are converted into lists, nested objects are allowed.
8-- Arrays are converted into lists, nested objects are allowed.
@@ -15,7 +16,7 @@ import JavaScript as JS
15-- { answer:null }
16-- { answer:null }
16-- { info:[true,42,'what'] }
17-- { info:[true,42,'what'] }
17toRecord : JSObject -> a
18toRecord : JSObject -> a
18−toRecord = JS.toRecord
19+toRecord = Native.JavaScript.toRecord
19
20
20-- Turn arbitrary Elm records into JavaScript objects.
21-- Turn arbitrary Elm records into JavaScript objects.
21-- Lists become arrays, nested records are allowed. No ADTs.
22-- Lists become arrays, nested records are allowed. No ADTs.
@@ -28,4 +29,4 @@ toRecord = JS.toRecord
28-- { answer = Nothing }
29-- { answer = Nothing }
29-- { result = Left "An error occurred" }
30-- { result = Left "An error occurred" }
30fromRecord : a -> JSObject
31fromRecord : a -> JSObject
31−fromRecord = JS.fromRecord
32+fromRecord = Native.JavaScript.fromRecord
libraries/Json.elm+12−5
@@ -3,9 +3,12 @@
3
3
4module Json where
4module Json where
5
5
6−import Dict as Dict
6+import open Basics
7+import Dict
8+import Maybe (Maybe)
7import JavaScript as JS
9import JavaScript as JS
8−import Native.Json as Native
10+import Native.Json
11+import JavaScript (JSObject, JSString)
9
12
10-- This datatype can represent all valid values that can be held in a JSON
13-- This datatype can represent all valid values that can be held in a JSON
11-- object. In Elm, a proper JSON object is represented as a (Dict String JsonValue)
14-- object. In Elm, a proper JSON object is represented as a (Dict String JsonValue)
@@ -16,7 +19,7 @@ data JsonValue
16 | Boolean Bool
19 | Boolean Bool
17 | Null
20 | Null
18 | Array [JsonValue]
21 | Array [JsonValue]
19− | Object (Dict String JsonValue)
22+ | Object (Dict.Dict String JsonValue)
20
23
21
24
22-- String Converters
25-- String Converters
@@ -25,24 +28,27 @@ data JsonValue
25-- The first argument is a separator token (e.g. \" \", \"\\n\", etc.) that will
28-- The first argument is a separator token (e.g. \" \", \"\\n\", etc.) that will
26-- be used for indentation in the prettified string version of the JSON.
29-- be used for indentation in the prettified string version of the JSON.
27toString : String -> JsonValue -> String
30toString : String -> JsonValue -> String
28−toString sep v = JS.toString (Native.toJSString sep v)
31+toString sep v = JS.toString (Native.Json.toJSString sep v)
29
32
30-- Convert a proper JSON object into a JavaScript string.
33-- Convert a proper JSON object into a JavaScript string.
31-- Note that the type JSString seen here is not the same as the type constructor
34-- Note that the type JSString seen here is not the same as the type constructor
32-- JsonString used elsewhere in this module.
35-- JsonString used elsewhere in this module.
33toJSString : String -> JsonValue -> JSString
36toJSString : String -> JsonValue -> JSString
37+toJSString = Native.Json.toJSString
34
38
35-- Parse a string representation of a proper JSON object into
39-- Parse a string representation of a proper JSON object into
36-- its Elm representation.
40-- its Elm representation.
37fromString : String -> Maybe JsonValue
41fromString : String -> Maybe JsonValue
38−fromString s = Native.fromJSString (JS.fromString s)
42+fromString s = Native.Json.fromJSString (JS.fromString s)
39
43
40-- Parse a JavaScript string representation of a proper JSON object into
44-- Parse a JavaScript string representation of a proper JSON object into
41-- its Elm representation.
45-- its Elm representation.
42fromJSString : JSString -> Maybe JsonValue
46fromJSString : JSString -> Maybe JsonValue
47+fromJSString = Native.Json.fromJSString
43
48
44-- Convert a JS object into a `JsonValue`.
49-- Convert a JS object into a `JsonValue`.
45fromJSObject : JSObject -> JsonValue
50fromJSObject : JSObject -> JsonValue
51+fromJSObject = Native.Json.fromJSObject
46
52
47-- Convert a `JsonValue` into a `JSObject`. Paired with the
53-- Convert a `JsonValue` into a `JSObject`. Paired with the
48-- [`JavaScript.Experimental` library](/docs/JavaScript/Experimental.elm),
54-- [`JavaScript.Experimental` library](/docs/JavaScript/Experimental.elm),
@@ -55,6 +61,7 @@ fromJSObject : JSObject -> JsonValue
55-- Just jsonValue -> Just (JS.toRecord (toJSObject jsonValue))
61-- Just jsonValue -> Just (JS.toRecord (toJSObject jsonValue))
56-- Nothing -> Nothing
62-- Nothing -> Nothing
57toJSObject : JsonValue -> JSObject
63toJSObject : JsonValue -> JSObject
64+toJSObject = Native.Json.toJSObject
58
65
59 {-- Extract Elm values from Json values
66 {-- Extract Elm values from Json values
60
67
libraries/Keyboard.elm+17−12
@@ -1,12 +1,19 @@
1module Keyboard where
1module Keyboard where
2
2
3+import Signal (Signal)
3−import Native.Keyboard as N
4+import Native.Keyboard
4
5
5-- Type alias to make it clearer what integers are supposed to represent
6-- Type alias to make it clearer what integers are supposed to represent
6-- in this library. Use [`Char.toCode`](docs/Char.elm#toCode) and
7-- in this library. Use [`Char.toCode`](docs/Char.elm#toCode) and
7-- [`Char.fromCode`](/docs/Char.elm#fromCode) to convert key codes to characters.
8-- [`Char.fromCode`](/docs/Char.elm#fromCode) to convert key codes to characters.
8type KeyCode = Int
9type KeyCode = Int
9
10
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+
10-- A signal of records indicating which arrow keys are pressed.
17-- A signal of records indicating which arrow keys are pressed.
11--
18--
12-- `{ x = 0, y = 0 }` when pressing no arrows.<br>
19-- `{ x = 0, y = 0 }` when pressing no arrows.<br>
@@ -14,39 +21,37 @@ type KeyCode = Int
14-- `{ x = 1, y = 1 }` when pressing the up and right arrows.<br>
21-- `{ x = 1, y = 1 }` when pressing the up and right arrows.<br>
15-- `{ x = 0, y =-1 }` when pressing the down, left, and right arrows.
22-- `{ x = 0, y =-1 }` when pressing the down, left, and right arrows.
16arrows : Signal { x:Int, y:Int }
23arrows : Signal { x:Int, y:Int }
17−arrows = N.directions 38 40 37 39
24+arrows = directions 38 40 37 39
18
25
19-- Just like the arrows signal, but this uses keys w, a, s, and d,
26-- Just like the arrows signal, but this uses keys w, a, s, and d,
20-- which are common controls for many computer games.
27-- which are common controls for many computer games.
21wasd : Signal { x:Int, y:Int }
28wasd : Signal { x:Int, y:Int }
22−wasd = N.directions 87 83 65 68
29+wasd = 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 }
28
30
29-- Whether an arbitrary key is pressed.
31-- Whether an arbitrary key is pressed.
30isDown : KeyCode -> Signal Bool
32isDown : KeyCode -> Signal Bool
33+isDown = Native.Keyboard.isDown
31
34
32-- Whether the shift key is pressed.
35-- Whether the shift key is pressed.
33shift : Signal Bool
36shift : Signal Bool
34−shift = N.isDown 16
37+shift = isDown 16
35
38
36-- Whether the control key is pressed.
39-- Whether the control key is pressed.
37ctrl : Signal Bool
40ctrl : Signal Bool
38−ctrl = N.isDown 17
41+ctrl = isDown 17
39
42
40-- Whether the space key is pressed.
43-- Whether the space key is pressed.
41space : Signal Bool
44space : Signal Bool
42−space = N.isDown 32
45+space = isDown 32
43
46
44-- Whether the enter key is pressed.
47-- Whether the enter key is pressed.
45enter : Signal Bool
48enter : Signal Bool
46−enter = N.isDown 13
49+enter = isDown 13
47
50
48-- List of keys that are currently down.
51-- List of keys that are currently down.
49keysDown : Signal [KeyCode]
52keysDown : Signal [KeyCode]
53+keysDown = Native.Keyboard.keysDown
50
54
51-- The latest key that has been pressed.
55-- The latest key that has been pressed.
52lastPressed : Signal KeyCode
56lastPressed : Signal KeyCode
57+lastPressed = Native.Keyboard.lastPressed
libraries/List.elm+50−25
@@ -1,29 +1,34 @@
1
1
2module List where
2module List where
3
3
4−import Native.Utils (min, max)
4+import open Basics
5−import Native.List as L
5+import Native.List
6
6
7-- Add an element to the front of a list `(1 :: [2,3] == [1,2,3])`
7-- Add an element to the front of a list `(1 :: [2,3] == [1,2,3])`
8(::) : a -> [a] -> [a]
8(::) : a -> [a] -> [a]
9+(::) = Native.List.cons
9
10
10-- Puts two appendable things together:
11-- Puts two appendable things together:
11--
12--
12-- [1,1] ++ [2,3] == [1,1,2,3]
13-- [1,1] ++ [2,3] == [1,1,2,3]
13-- "abc" ++ "123" == "abc123"
14-- "abc" ++ "123" == "abc123"
14−(++) : Appendable a -> Appendable a -> Appendable a
15+(++) : appendable -> appendable -> appendable
16+(++) = Native.List.append
15
17
16-- Extract the first element of a list. List must be non-empty.
18-- Extract the first element of a list. List must be non-empty.
17-- `(head [1,2,3] == 1)`
19-- `(head [1,2,3] == 1)`
18head : [a] -> a
20head : [a] -> a
21+head = Native.List.head
19
22
20-- Extract the elements after the head of the list. List must be non-empty.
23-- Extract the elements after the head of the list. List must be non-empty.
21-- `(tail [1,2,3] == [2,3])`
24-- `(tail [1,2,3] == [2,3])`
22tail : [a] -> [a]
25tail : [a] -> [a]
26+tail = Native.List.tail
23
27
24-- Extract the last element of a list. List must be non-empty.
28-- Extract the last element of a list. List must be non-empty.
25-- `(last [1,2,3] == 3)`
29-- `(last [1,2,3] == 3)`
26last : [a] -> a
30last : [a] -> a
31+last = Native.List.last
27
32
28-- Check if a list is empty `(isEmpty [] == True)`
33-- Check if a list is empty `(isEmpty [] == True)`
29isEmpty : [a] -> Bool
34isEmpty : [a] -> Bool
@@ -33,77 +38,92 @@ isEmpty xs =
33 _ -> False
38 _ -> False
34
39
35-- Apply a function to every element of a list: `(map sqrt [1,4,9] == [1,2,3])`
40-- 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
37
43
38-- Reduce a list from the left: `(foldl (::) [] "gateman" == "nametag")`
44-- 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
40
47
41-- Reduce a list from the right: `(foldr (+) 0 [1,2,3] == 6)`
48-- 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
43
51
44-- Reduce a list from the left without a base case. List must be non-empty.
52-- Reduce a list from the left without a base case. List must be non-empty.
45foldl1 : (a -> a -> a) -> [a] -> a
53foldl1 : (a -> a -> a) -> [a] -> a
54+foldl1 = Native.List.foldl1
46
55
47-- Reduce a list from the right without a base case. List must be non-empty.
56-- Reduce a list from the right without a base case. List must be non-empty.
48foldr1 : (a -> a -> a) -> [a] -> a
57foldr1 : (a -> a -> a) -> [a] -> a
58+foldr1 = Native.List.foldr1
49
59
50-- Reduce a list from the left, building up all of the intermediate results into a list.
60-- Reduce a list from the left, building up all of the intermediate results into a list.
51--
61--
52-- scanl (+) 0 [1,2,3,4] == [0,1,3,6,10]
62-- 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
54
65
55-- Same as scanl but it doesn't require a base case. List must be non-empty.
66-- Same as scanl but it doesn't require a base case. List must be non-empty.
56--
67--
57-- scanl1 (+) [1,2,3,4] == [1,3,6,10]
68-- scanl1 (+) [1,2,3,4] == [1,3,6,10]
58scanl1 : (a -> a -> a) -> [a] -> [a]
69scanl1 : (a -> a -> a) -> [a] -> [a]
70+scanl1 = Native.List.scanl1
59
71
60-- Filter out elements which do not satisfy the predicate: `(filter isLower "AaBbCc" == "abc")`
72-- 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
62
75
63-- Determine the length of a list: `(length "innumerable" == 11)`
76-- Determine the length of a list: `(length "innumerable" == 11)`
64−length : [a] -> Int
77+length : [a] -> Int
78+length = Native.List.length
65
79
66-- Reverse a list. `(reverse [1..4] == [4,3,2,1])`
80-- Reverse a list. `(reverse [1..4] == [4,3,2,1])`
67reverse : [a] -> [a]
81reverse : [a] -> [a]
82+reverse = Native.List.reverse
68
83
69-- Check to see if all elements satisfy the predicate.
84-- Check to see if all elements satisfy the predicate.
70all : (a -> Bool) -> [a] -> Bool
85all : (a -> Bool) -> [a] -> Bool
86+all = Native.List.all
71
87
72-- Check to see if any elements satisfy the predicate.
88-- Check to see if any elements satisfy the predicate.
73any : (a -> Bool) -> [a] -> Bool
89any : (a -> Bool) -> [a] -> Bool
90+any = Native.List.any
74
91
75-- Check to see if all elements are True.
92-- Check to see if all elements are True.
76and : [Bool] -> Bool
93and : [Bool] -> Bool
94+and = Native.List.and
77
95
78-- Check to see if any elements are True.
96-- Check to see if any elements are True.
79−or : [Bool] -> Bool
97+or : [Bool] -> Bool
98+or = Native.List.or
80
99
81-- Concatenate a list of appendable things:
100-- Concatenate a list of appendable things:
82--
101--
83-- concat ["tree","house"] == "treehouse"
102-- concat ["tree","house"] == "treehouse"
84−concat : [Appendable a] -> Appendable a
103+concat : [appendable] -> appendable
104+concat = Native.List.concat
85
105
86-- Map a given function onto a list and flatten the resulting lists.
106-- Map a given function onto a list and flatten the resulting lists.
87--
107--
88-- concatMap f xs == concat (map f xs)
108-- concatMap f xs == concat (map f xs)
89−concatMap : (a -> Appendable b) -> [a] -> Appendable b
109+concatMap : (a -> appendable) -> [a] -> appendable
90−concatMap f = L.concat . L.map f
110+concatMap f list = concat (map f list)
91
111
92-- Get the sum of the list elements. `(sum [1..4] == 10)`
112-- Get the sum of the list elements. `(sum [1..4] == 10)`
93−sum : [Number a] -> Number a
113+sum : [number] -> number
94−sum = L.foldl (+) 0
114+sum = foldl (+) 0
95
115
96-- Get the product of the list elements. `(product [1..4] == 24)`
116-- Get the product of the list elements. `(product [1..4] == 24)`
97−product : [Number a] -> Number a
117+product : [number] -> number
98−product = L.foldl (*) 1
118+product = foldl (*) 1
99
119
100−-- Find the highest number in a non-empty list.
120+-- Find the maximum element in a non-empty list: `maximum [1,4,2] == 4`
101−maximum : [Number a] -> Number a
121+maximum : [comparable] -> comparable
102−maximum = L.foldl1 max
122+maximum = foldl1 max
103
123
104−-- Find the lowest number in a non-empty list.
124+-- Find the minimum element in a non-empty list: `minimum [3,2,1] == 1`
105−minimum : [Number a] -> Number a
125+minimum : [comparable] -> comparable
106−minimum = L.foldl1 min
126+minimum = foldl1 min
107
127
108-- Split a list based on the predicate.
128-- Split a list based on the predicate.
109partition : (a -> Bool) -> [a] -> ([a],[a])
129partition : (a -> Bool) -> [a] -> ([a],[a])
@@ -119,12 +139,14 @@ partition pred lst =
119-- zip [1,2,3] [6,7] == [(1,6),(2,7)]
139-- zip [1,2,3] [6,7] == [(1,6),(2,7)]
120-- zip == zipWith (,)
140-- zip == zipWith (,)
121zip : [a] -> [b] -> [(a,b)]
141zip : [a] -> [b] -> [(a,b)]
142+zip = Native.List.zip
122
143
123-- Combine two lists, combining them with the given function.
144-- Combine two lists, combining them with the given function.
124-- If one list is longer, the extra elements are dropped.
145-- If one list is longer, the extra elements are dropped.
125--
146--
126-- zipWith (+) [1,2,3] [1,2,3,4] == [2,4,6]
147-- zipWith (+) [1,2,3] [1,2,3,4] == [2,4,6]
127zipWith : (a -> b -> c) -> [a] -> [b] -> [c]
148zipWith : (a -> b -> c) -> [a] -> [b] -> [c]
149+zipWith = Native.List.zipWith
128
150
129-- Decompose a list of tuples.
151-- Decompose a list of tuples.
130unzip : [(a,b)] -> ([a],[b])
152unzip : [(a,b)] -> ([a],[b])
@@ -137,12 +159,14 @@ unzip pairs =
137--
159--
138-- split "," "hello,there,friend" == ["hello", "there", "friend"]
160-- split "," "hello,there,friend" == ["hello", "there", "friend"]
139split : [a] -> [a] -> [[a]]
161split : [a] -> [a] -> [[a]]
162+split = Native.List.split
140
163
141-- Places the given value between all of the lists in the second argument
164-- Places the given value between all of the lists in the second argument
142-- and concatenates the result.
165-- and concatenates the result.
143--
166--
144-- join "a" ["H","w","ii","n"] == "Hawaiian"
167-- 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
146
170
147-- Places the given value between all members of the given list.
171-- Places the given value between all members of the given list.
148--
172--
@@ -156,7 +180,8 @@ intersperse sep xs =
156
180
157-- Take the first n members of a list: `(take 2 [1,2,3,4] == [1,2])`
181-- Take the first n members of a list: `(take 2 [1,2,3,4] == [1,2])`
158take : Int -> [a] -> [a]
182take : Int -> [a] -> [a]
183+take = Native.List.take
159
184
160-- Drop the first n members of a list: `(drop 2 [1,2,3,4] == [3,4])`
185-- Drop the first n members of a list: `(drop 2 [1,2,3,4] == [3,4])`
161drop : Int -> [a] -> [a]
186drop : Int -> [a] -> [a]
162−
187+drop = Native.List.drop
libraries/Matrix2D.elm+11−5
@@ -1,13 +1,16 @@
1
1
2module Matrix2D where
2module Matrix2D where
3
3
4−import Native.Matrix2D as M
4+import Native.Matrix2D
5+
6+data Matrix2D = Matrix2D
5
7
6-- Create an identity matrix.
8-- Create an identity matrix.
7--
9--
8-- / 1 0 \\
10-- / 1 0 \\
9-- \\ 0 1 /
11-- \\ 0 1 /
10−identity : Matrix2D
12+identity : Matrix2D
13+identity = Native.Matrix2D.identity
11
14
12-- Creates an arbitrary matrix. This lets you create scales, shears, reflections,
15-- Creates an arbitrary matrix. This lets you create scales, shears, reflections,
13-- translations, or any other 2D transform.
16-- translations, or any other 2D transform.
@@ -18,14 +21,16 @@ identity : Matrix2D
18-- \\ c d /
21-- \\ c d /
19--
22--
20-- And `dx` and `dy` are the translation values.
23-- 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
22
26
23-- Creates a [rotation matrix](http://en.wikipedia.org/wiki/Rotation_matrix).
27-- Creates a [rotation matrix](http://en.wikipedia.org/wiki/Rotation_matrix).
24-- Given an angle t, it creates a counterclockwise rotation matrix:
28-- Given an angle t, it creates a counterclockwise rotation matrix:
25--
29--
26-- / cos t -sin t \\
30-- / cos t -sin t \\
27-- \\ sin t cos t /
31-- \\ sin t cos t /
28−rotation : Float -> Matrix2D
32+rotation : Float -> Matrix2D
33+rotation = Native.Matrix2D.rotation
29
34
30-- Multiplies two matrices together:
35-- Multiplies two matrices together:
31--
36--
@@ -33,4 +38,5 @@ rotation : Float -> Matrix2D
33--
38--
34-- / a11 a12 \\ . / b11 b12 \\
39-- / a11 a12 \\ . / b11 b12 \\
35-- \\ a21 a22 / \\ b21 b22 /
40-- \\ 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 @@
1
1
2module Maybe where
2module Maybe where
3
3
4−import List as List
4+import Basics (not, (.))
5+import List (foldr)
5
6
6-- The Maybe datatype. Useful when a computation may or may not
7-- The Maybe datatype. Useful when a computation may or may not
7-- result in a value (e.g. logarithm is defined only for positive numbers).
8-- 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
30
31
31-- Filters out Nothings and extracts the remaining values.
32-- Filters out Nothings and extracts the remaining values.
32justs : [Maybe a] -> [a]
33justs : [Maybe a] -> [a]
33−justs = List.foldr cons []
34+justs = foldr cons []
libraries/Mouse.elm+8−1
@@ -1,24 +1,31 @@
1
1
2module Mouse where
2module Mouse where
3
3
4+import Signal (Signal)
4−import Native.Mouse as M
5+import Native.Mouse
5
6
6-- The current mouse position.
7-- The current mouse position.
7position : Signal (Int,Int)
8position : Signal (Int,Int)
9+position = Native.Mouse.position
8
10
9-- The current x-coordinate of the mouse.
11-- The current x-coordinate of the mouse.
10x : Signal Int
12x : Signal Int
13+x = Native.Mouse.x
11
14
12-- The current y-coordinate of the mouse.
15-- The current y-coordinate of the mouse.
13y : Signal Int
16y : Signal Int
17+y = Native.Mouse.y
14
18
15-- The current state of the left mouse-button.
19-- The current state of the left mouse-button.
16-- True when the button is down, and false otherwise.
20-- True when the button is down, and false otherwise.
17isDown : Signal Bool
21isDown : Signal Bool
22+isDown = Native.Mouse.isDown
18
23
19-- True immediately after the left mouse-button has been clicked,
24-- True immediately after the left mouse-button has been clicked,
20-- and false otherwise.
25-- and false otherwise.
21isClicked : Signal Bool
26isClicked : Signal Bool
27+isClicked = Native.Mouse.isClicked
22
28
23-- Always equal to unit. Event triggers on every mouse click.
29-- Always equal to unit. Event triggers on every mouse click.
24clicks : Signal ()
30clicks : 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) {
6
6
7 var fromString = Elm.Native.JavaScript(elm).fromString;
7 var fromString = Elm.Native.JavaScript(elm).fromString;
8
8
9− function Case(span) {
9+ function indent(lines) {
10− var msg = 'Non-exhaustive pattern match in case expression'
10+ var msg = '';
11− throw new Error(msg + " (" + span + ")")
11+ for (var i = 0; i < lines.length; ++i) {
12+ msg += '<br/>&nbsp; &nbsp; ' + lines[i];
13+ }
14+ return msg;
12 }
15 }
13
16
14− function If(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) {
15− var msg = 'Non-exhaustive pattern match in multi-way-if expression'
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.']);
16− throw new Error(msg + " (" + span + ")")
26+ throw new Error('Runtime error in module ' + moduleName + ' (' + span + '):' + msg);
17 }
27 }
18
28
19 function raise(str) { throw new Error(fromString(str)); }
29 function raise(str) { throw new Error(fromString(str)); }
libraries/Native/Graphics/Input.js+123−115
@@ -57,29 +57,29 @@ Elm.Native.Graphics.Input = function(elm) {
57 var events = Signal.constant(defaultValue);
57 var events = Signal.constant(defaultValue);
58
58
59 function render(model) {
59 function render(model) {
60− var b = newNode('button');
60+ var b = newNode('button');
61− b.style.display = 'block';
61+ b.style.display = 'block';
62− b.elmEvent = model.event;
62+ b.elmEvent = model.event;
63− function click() { elm.notify(events.id, b.elmEvent); }
63+ function click() { elm.notify(events.id, b.elmEvent); }
64− b.addEventListener('click', click);
64+ b.addEventListener('click', click);
65− b.innerHTML = model.text;
65+ b.innerHTML = model.text;
66− return b;
66+ return b;
67 }
67 }
68
68
69 function update(node, oldModel, newModel) {
69 function update(node, oldModel, newModel) {
70− node.elmEvent = newModel.event;
70+ node.elmEvent = newModel.event;
71− var txt = newModel.text;
71+ var txt = newModel.text;
72− if (oldModel.text !== txt) node.innerHTML = txt;
72+ if (oldModel.text !== txt) node.innerHTML = txt;
73 }
73 }
74
74
75 function button(evnt, txt) {
75 function button(evnt, txt) {
76− return A3(newElement, 100, 40, {
76+ return A3(newElement, 100, 40, {
77 ctor: 'Custom',
77 ctor: 'Custom',
78− type: 'Button',
78+ type: 'Button',
79− render: render,
79+ render: render,
80− update: update,
80+ update: update,
81− model: { event:evnt, text:JS.fromString(txt) }
81+ model: { event:evnt, text:JS.fromString(txt) }
82− });
82+ });
83 }
83 }
84
84
85 return { _:{}, button:F2(button), events:events };
85 return { _:{}, button:F2(button), events:events };
@@ -89,57 +89,65 @@ Elm.Native.Graphics.Input = function(elm) {
89 var events = Signal.constant(defaultValue);
89 var events = Signal.constant(defaultValue);
90
90
91 function render(model) {
91 function render(model) {
92− var btn = newNode('div');
92+ var btn = newNode('div');
93− btn.elmEvent = model.event;
93+ btn.elmEvent = model.event;
94
94
95− btn.elmUp = Render.render(model.up);
95+ btn.elmUp = Render.render(model.up);
96− btn.elmHover = Render.render(model.hover);
96+ btn.elmHover = Render.render(model.hover);
97− btn.elmDown = Render.render(model.down);
97+ btn.elmDown = Render.render(model.down);
98
98
99− function replace(node) {
99+ function replace(node) {
100 if (node !== btn.firstChild) btn.replaceChild(node, btn.firstChild);
100 if (node !== btn.firstChild) btn.replaceChild(node, btn.firstChild);
101− }
101+ }
102− var overCount = 0;
102+ var overCount = 0;
103− function over(e) {
103+ function over(e) {
104− if (overCount++ > 0) return;
104+ if (overCount++ > 0) return;
105− replace(btn.elmHover);
105+ replace(btn.elmHover);
106− }
106+ }
107− function out(e) {
107+ function out(e) {
108− if (btn.contains(e.toElement || e.relatedTarget)) return;
108+ if (btn.contains(e.toElement || e.relatedTarget)) return;
109− overCount = 0;
109+ overCount = 0;
110− replace(btn.elmUp);
110+ replace(btn.elmUp);
111− }
111+ }
112− function up() {
112+ function up() {
113− replace(btn.elmHover);
113+ replace(btn.elmHover);
114− elm.notify(events.id, btn.elmEvent);
114+ elm.notify(events.id, btn.elmEvent);
115− }
115+ }
116− function down() { replace(btn.elmDown); }
116+ function down() { replace(btn.elmDown); }
117− btn.addEventListener('mouseover', over);
117+ btn.addEventListener('mouseover', over);
118− btn.addEventListener('mouseout' , out);
118+ btn.addEventListener('mouseout' , out);
119− btn.addEventListener('mousedown', down);
119+ btn.addEventListener('mousedown', down);
120− btn.addEventListener('mouseup' , up);
120+ btn.addEventListener('mouseup' , up);
121−
121+
122− btn.appendChild(btn.elmUp);
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+
123− return btn;
131+ return btn;
124 }
132 }
125
133
126 function update(node, oldModel, newModel) {
134 function update(node, oldModel, newModel) {
127− node.elmEvent = newModel.event;
135+ node.elmEvent = newModel.event;
128− Render.update(node.elmUp, oldModel.up, newModel.up)
136+ Render.update(node.elmUp, oldModel.up, newModel.up)
129− Render.update(node.elmHover, oldModel.hover, newModel.hover)
137+ Render.update(node.elmHover, oldModel.hover, newModel.hover)
130− Render.update(node.elmDown, oldModel.down, newModel.down)
138+ Render.update(node.elmDown, oldModel.down, newModel.down)
131 }
139 }
132
140
133 function button(evnt, up, hover, down) {
141 function button(evnt, up, hover, down) {
134− return A3(newElement,
142+ return A3(newElement,
135− Math.max(up.props.width, hover.props.width, down.props.width),
143+ Math.max(up.props.width, hover.props.width, down.props.width),
136− Math.max(up.props.height, hover.props.height, down.props.height),
144+ Math.max(up.props.height, hover.props.height, down.props.height),
137 { ctor: 'Custom',
145 { ctor: 'Custom',
138− type: 'CustomButton',
146+ type: 'CustomButton',
139− render: render,
147+ render: render,
140− update: update,
148+ update: update,
141− model: { event:evnt, up:up, hover:hover, down:down }
149+ model: { event:evnt, up:up, hover:hover, down:down }
142− });
150+ });
143 }
151 }
144
152
145 return { _:{}, customButton:F4(button), events:events };
153 return { _:{}, customButton:F4(button), events:events };
@@ -163,33 +171,33 @@ Elm.Native.Graphics.Input = function(elm) {
163 var events = Signal.constant(defaultValue);
171 var events = Signal.constant(defaultValue);
164
172
165 function render(model) {
173 function render(model) {
166− var b = newNode('input');
174+ var b = newNode('input');
167− b.type = 'checkbox';
175+ b.type = 'checkbox';
168− b.checked = model.checked;
176+ b.checked = model.checked;
169− b.style.display = 'block';
177+ b.style.display = 'block';
170− b.elmHandler = model.handler;
178+ b.elmHandler = model.handler;
171− function change() { elm.notify(events.id, b.elmHandler(b.checked)); }
179+ function change() { elm.notify(events.id, b.elmHandler(b.checked)); }
172− b.addEventListener('change', change);
180+ b.addEventListener('change', change);
173− return b;
181+ return b;
174 }
182 }
175
183
176 function update(node, oldModel, newModel) {
184 function update(node, oldModel, newModel) {
177− node.elmHandler = newModel.handler;
185+ node.elmHandler = newModel.handler;
178− node.checked = newModel.checked;
186+ node.checked = newModel.checked;
179− return true;
187+ return true;
180 }
188 }
181
189
182 function box(handler, checked) {
190 function box(handler, checked) {
183− return A3(newElement, 13, 13, {
191+ return A3(newElement, 13, 13, {
184 ctor: 'Custom',
192 ctor: 'Custom',
185− type: 'CheckBox',
193+ type: 'CheckBox',
186− render: render,
194+ render: render,
187− update: update,
195+ update: update,
188− model: { checked:checked, handler:handler }
196+ model: { checked:checked, handler:handler }
189− });
197+ });
190 }
198 }
191
199
192− return { _:{}, box:F2(box), events:events };
200+ return { _:{}, checkbox:F2(box), events:events };
193 }
201 }
194
202
195 function setRange(node, start, end, dir) {
203 function setRange(node, start, end, dir) {
@@ -206,49 +214,49 @@ Elm.Native.Graphics.Input = function(elm) {
206 var state = null;
214 var state = null;
207
215
208 function render(model) {
216 function render(model) {
209− var field = newNode('input');
217+ var field = newNode('input');
210− field.elmHandler = model.handler;
218+ field.elmHandler = model.handler;
211−
219+
212− field.id = 'test';
220+ field.id = 'test';
213− field.type = type;
221+ field.type = type;
214− field.placeholder = JS.fromString(model.placeHolder);
222+ field.placeholder = JS.fromString(model.placeHolder);
215− field.value = JS.fromString(model.state.string);
223+ field.value = JS.fromString(model.state.string);
216− setRange(field, model.state.selectionStart, model.state.selectionEnd, 'forward');
224+ setRange(field, model.state.selectionStart, model.state.selectionEnd, 'forward');
217− field.style.border = 'none';
225+ field.style.border = 'none';
218 state = model.state;
226 state = model.state;
219
227
220− function update() {
228+ function update() {
221− var start = field.selectionStart,
229+ var start = field.selectionStart,
222− end = field.selectionEnd;
230+ end = field.selectionEnd;
223− if (field.selectionDirection === 'backward') {
231+ if (field.selectionDirection === 'backward') {
224− start = end;
232+ start = end;
225− end = field.selectionStart;
233+ end = field.selectionStart;
226− }
234+ }
227 state = { _:{},
235 state = { _:{},
228 string:JS.toString(field.value),
236 string:JS.toString(field.value),
229 selectionStart:start,
237 selectionStart:start,
230 selectionEnd:end };
238 selectionEnd:end };
231− elm.notify(events.id, field.elmHandler(state));
239+ elm.notify(events.id, field.elmHandler(state));
232− }
240+ }
233− function mousedown() {
241+ function mousedown() {
234− update();
242+ update();
235− elm.node.addEventListener('mouseup', mouseup);
243+ elm.node.addEventListener('mouseup', mouseup);
236− }
244+ }
237− function mouseup() {
245+ function mouseup() {
238− update();
246+ update();
239− elm.node.removeEventListener('mouseup', mouseup)
247+ elm.node.removeEventListener('mouseup', mouseup)
240− }
248+ }
241− field.addEventListener('keyup', update);
249+ field.addEventListener('keyup', update);
242− field.addEventListener('mousedown', mousedown);
250+ field.addEventListener('mousedown', mousedown);
243−
251+
244− return field;
252+ return field;
245 }
253 }
246
254
247 function update(node, oldModel, newModel) {
255 function update(node, oldModel, newModel) {
248− node.elmHandler = newModel.handler;
256+ node.elmHandler = newModel.handler;
249 if (state === newModel.state) return;
257 if (state === newModel.state) return;
250 var newStr = JS.fromString(newModel.state.string);
258 var newStr = JS.fromString(newModel.state.string);
251− if (node.value !== newStr) node.value = newStr;
259+ if (node.value !== newStr) node.value = newStr;
252
260
253 var start = newModel.state.selectionStart;
261 var start = newModel.state.selectionStart;
254 var end = newModel.state.selectionEnd;
262 var end = newModel.state.selectionEnd;
@@ -267,15 +275,15 @@ Elm.Native.Graphics.Input = function(elm) {
267 }
275 }
268
276
269 function field(handler, placeHolder, state) {
277 function field(handler, placeHolder, state) {
270− return A3(newElement, 200, 30,
278+ return A3(newElement, 200, 30,
271 { ctor: 'Custom',
279 { ctor: 'Custom',
272− type: type + 'Input',
280+ type: type + 'Input',
273− render: render,
281+ render: render,
274− update: update,
282+ update: update,
275− model: { handler:handler,
283+ model: { handler:handler,
276− placeHolder:placeHolder,
284+ placeHolder:placeHolder,
277− state:state }
285+ state:state }
278− });
286+ });
279 }
287 }
280
288
281 return { _:{}, field:F3(field), events:events };
289 return { _:{}, field:F3(field), events:events };
libraries/Native/List.js+7−1
@@ -90,7 +90,7 @@ Elm.Native.List = function(elm) {
90 }
90 }
91
91
92 // f defined similarly for both foldl and foldr (NB: different from Haskell)
92 // 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
94 function foldl(f, b, xs) {
94 function foldl(f, b, xs) {
95 var acc = b;
95 var acc = b;
96 while (xs.ctor !== '[]') {
96 while (xs.ctor !== '[]') {
@@ -219,6 +219,10 @@ Elm.Native.List = function(elm) {
219 return fromArray(toArray(xs).sort(cmp));
219 return fromArray(toArray(xs).sort(cmp));
220 }
220 }
221
221
222+ function nth(xs, n) {
223+ return toArray(xs)[n];
224+ }
225+
222 function take(n, xs) {
226 function take(n, xs) {
223 var arr = [];
227 var arr = [];
224 while (xs.ctor !== '[]' && n > 0) {
228 while (xs.ctor !== '[]' && n > 0) {
@@ -308,6 +312,7 @@ Elm.Native.List = function(elm) {
308 Elm.Native.List.values = {
312 Elm.Native.List.values = {
309 Nil:Nil,
313 Nil:Nil,
310 Cons:Cons,
314 Cons:Cons,
315+ cons:F2(Cons),
311 toArray:toArray,
316 toArray:toArray,
312 fromArray:fromArray,
317 fromArray:fromArray,
313 range:range,
318 range:range,
@@ -336,6 +341,7 @@ Elm.Native.List = function(elm) {
336 zipWith:F3(zipWith),
341 zipWith:F3(zipWith),
337 zip:F2(zip),
342 zip:F2(zip),
338 sort:sort,
343 sort:sort,
344+ nth:F2(nth),
339 take:F2(take),
345 take:F2(take),
340 drop:F2(drop),
346 drop:F2(drop),
341
347
libraries/Native/Prelude.js+2−74
@@ -3,31 +3,10 @@ Elm.Native.Prelude = function(elm) {
3 'use strict';
3 'use strict';
4 if (elm.Native.Prelude) return elm.Native.Prelude;
4 if (elm.Native.Prelude) return elm.Native.Prelude;
5
5
6− var JS = Elm.JavaScript(elm);
6+ var JS = Elm.Native.JavaScript(elm);
7 var Maybe = Elm.Maybe(elm);
7 var Maybe = Elm.Maybe(elm);
8− var Utils = Elm.Native.Utils(elm);
9 var Char = Elm.Char(elm);
8 var Char = Elm.Char(elm);
10
9
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−
31 function readInt(str) {
10 function readInt(str) {
32 var s = JS.fromString(str);
11 var s = JS.fromString(str);
33 var len = s.length;
12 var len = s.length;
@@ -64,60 +43,9 @@ Elm.Native.Prelude = function(elm) {
64 return Maybe.Just(parseFloat(s));
43 return Maybe.Just(parseFloat(s));
65 }
44 }
66
45
67− var prelude = {
46+ return elm.Native.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−
100 readInt:readInt,
47 readInt:readInt,
101 readFloat:readFloat,
48 readFloat:readFloat,
102−
103− id:id,
104− flip:F3(flip),
105− curry:F3(curry),
106− uncurry:F2(uncurry),
107− fst:fst,
108− snd:snd
109 };
49 };
110
50
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;
123};
51};
libraries/Native/Show.js+5−4
@@ -37,7 +37,7 @@ Elm.Native.Show = function(elm) {
37 if (output.length === 0) return "{}";
37 if (output.length === 0) return "{}";
38 return "{ " + output.join(", ") + " }";
38 return "{ " + output.join(", ") + " }";
39 } else if (typeof v === "object" && 'ctor' in v) {
39 } else if (typeof v === "object" && 'ctor' in v) {
40− if (v.ctor.substring(0,5) === "Tuple") {
40+ if (v.ctor.substring(0,6) === "_Tuple") {
41 var output = [];
41 var output = [];
42 for (var k in v) {
42 for (var k in v) {
43 if (k === 'ctor') continue;
43 if (k === 'ctor') continue;
@@ -63,7 +63,7 @@ Elm.Native.Show = function(elm) {
63 var cons = F3(function(k,v,acc){return NList.Cons(Tuple2(k,v),acc)});
63 var cons = F3(function(k,v,acc){return NList.Cons(Tuple2(k,v),acc)});
64 var list = A3(Dict.foldr, cons, NList.Nil, v);
64 var list = A3(Dict.foldr, cons, NList.Nil, v);
65 var name = "Dict";
65 var name = "Dict";
66− if (list.ctor === "::" && list._0._1.ctor === "Tuple0") {
66+ if (list.ctor === "::" && list._0._1.ctor === "_Tuple0") {
67 name = "Set";
67 name = "Set";
68 list = A2(List.map, function(x){return x._0}, list);
68 list = A2(List.map, function(x){return x._0}, list);
69 }
69 }
@@ -73,13 +73,14 @@ Elm.Native.Show = function(elm) {
73 for (var i in v) {
73 for (var i in v) {
74 if (i === 'ctor') continue;
74 if (i === 'ctor') continue;
75 var str = toString(v[i]);
75 var str = toString(v[i]);
76− var parenless = str[0] === '{' || str.indexOf(' ') < 0;
76+ var parenless = str[0] === '{' || str[0] === '<' || str.indexOf(' ') < 0;
77 output += ' ' + (parenless ? str : '(' + str + ')');
77 output += ' ' + (parenless ? str : '(' + str + ')');
78 }
78 }
79 return v.ctor + output;
79 return v.ctor + output;
80 }
80 }
81 }
81 }
82− return v+"";
82+ if (typeof v === 'object' && 'recv' in v) return '<signal>';
83+ return "<internal structure>";
83 };
84 };
84 function show(v) { return NList.fromArray(toString(v)); }
85 function show(v) { return NList.fromArray(toString(v)); }
85
86
libraries/Native/Signal/Time.js+4−3
@@ -3,6 +3,7 @@ Elm.Native.Time = function(elm) {
3 'use strict';
3 'use strict';
4
4
5 var Signal = Elm.Signal(elm);
5 var Signal = Elm.Signal(elm);
6+ var NS = Elm.Native.Signal(elm);
6 var Maybe = Elm.Maybe(elm);
7 var Maybe = Elm.Maybe(elm);
7 var Utils = Elm.Native.Utils(elm);
8 var Utils = Elm.Native.Utils(elm);
8
9
@@ -42,7 +43,7 @@ Elm.Native.Time = function(elm) {
42
43
43 function since(t, s) {
44 function since(t, s) {
44 function cmp(a,b) { return !Utils.eq(a,b); }
45 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));
46 return A3( Signal.lift2, F2(cmp), Signal.count(s), dcount );
47 return A3( Signal.lift2, F2(cmp), Signal.count(s), dcount );
47 }
48 }
48 function read(s) {
49 function read(s) {
@@ -53,8 +54,8 @@ Elm.Native.Time = function(elm) {
53 fpsWhen : F2(fpsWhen),
54 fpsWhen : F2(fpsWhen),
54 fps : function(t) { return fpsWhen(t, Signal.constant(true)); },
55 fps : function(t) { return fpsWhen(t, Signal.constant(true)); },
55 every : function(t) { return everyWhen(t, Signal.constant(true)) },
56 every : function(t) { return everyWhen(t, Signal.constant(true)) },
56− delay : Signal.delay,
57+ delay : NS.delay,
57− timestamp : Signal.timestamp,
58+ timestamp : NS.timestamp,
58 since : F2(since),
59 since : F2(since),
59 toDate : function(t) { return new window.Date(t); },
60 toDate : function(t) { return new window.Date(t); },
60 read : read
61 read : read
libraries/Native/Utils.js+9−7
@@ -19,8 +19,10 @@ Elm.Native.Utils = function(elm) {
19 return x === y;
19 return x === y;
20 }
20 }
21
21
22+ // code in Generate/JavaScript.hs depends on the particular
23+ // integer values assigned to LT, EQ, and GT
22− var EQ = 0, LT = 1, GT = 2, ord = ['EQ','LT','GT'];
24+ var LT = -1, EQ = 0, GT = 1, ord = ['LT','EQ','GT'];
23− function compare(x,y) { return { ctor: ord[cmp(x,y)] } }
25+ function compare(x,y) { return { ctor: ord[cmp(x,y)+1] } }
24 function cmp(x,y) {
26 function cmp(x,y) {
25 var ord;
27 var ord;
26 if (typeof x !== 'object') return x === y ? EQ : x < y ? LT : GT;
28 if (typeof x !== 'object') return x === y ? EQ : x < y ? LT : GT;
@@ -36,8 +38,8 @@ Elm.Native.Utils = function(elm) {
36 }
38 }
37 }
39 }
38
40
39− if (x.ctor.slice(0,5) === 'Tuple') {
41+ if (x.ctor.slice(0,6) === '_Tuple') {
40− var n = x.ctor.slice(5) - 0;
42+ var n = x.ctor.slice(6) - 0;
41 var err = 'cannot compare tuples with more than 6 elements.';
43 var err = 'cannot compare tuples with more than 6 elements.';
42 if (n === 0) return EQ;
44 if (n === 0) return EQ;
43 if (n >= 1) { ord = cmp(x._0, y._0); if (ord !== EQ) return ord;
45 if (n >= 1) { ord = cmp(x._0, y._0); if (ord !== EQ) return ord;
@@ -55,8 +57,8 @@ Elm.Native.Utils = function(elm) {
55 }
57 }
56
58
57
59
58− var Tuple0 = { ctor: "Tuple0" };
60+ var Tuple0 = { ctor: "_Tuple0" };
59− function Tuple2(x,y) { return { ctor:"Tuple2", _0:x, _1:y } }
61+ function Tuple2(x,y) { return { ctor:"_Tuple2", _0:x, _1:y } }
60
62
61 var count = 0;
63 var count = 0;
62 function guid(_) { return count++ }
64 function guid(_) { return count++ }
@@ -140,7 +142,7 @@ Elm.Native.Utils = function(elm) {
140
142
141 return elm.Native.Utils = {
143 return elm.Native.Utils = {
142 eq:eq,
144 eq:eq,
143− cmp:compare,
145+ cmp:cmp,
144 compare:F2(compare),
146 compare:F2(compare),
145 Tuple0:Tuple0,
147 Tuple0:Tuple0,
146 Tuple2:Tuple2,
148 Tuple2:Tuple2,
libraries/Prelude.elm+7−191
@@ -1,202 +1,18 @@
1−
2module Prelude where
1module Prelude where
3
2
4−import Native.Prelude as N
3+import Basics (String)
5−
4+import Maybe (Maybe)
6−-- Convert radians to standard Elm angles (radians).
5+import Native.Prelude
7−radians : Float -> Float
6+import Native.Show
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&deg;.
16−turns : Float -> Float
17−turns r = 2 * Math.PI * r
18−
19−-- Start with polar coordinates (r,&theta;)
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,&theta;).
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 &pi;/2 and -&pi;/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−-- &pi; and -&pi;, 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
146
7
147-- Convert almost any value to its string representation.
8-- Convert almost any value to its string representation.
148show : a -> String
9show : a -> String
10+show = Native.Show.show
149
11
150-- Read an integer from a string
12-- Read an integer from a string
151readInt : String -> Maybe Int
13readInt : String -> Maybe Int
14+readInt = Native.Prelude.readInt
152
15
153-- Read a float from a string.
16-- Read a float from a string.
154readFloat : String -> Maybe Float
17readFloat : String -> Maybe Float
155−
18+readFloat = Native.Prelude.readFloat
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
libraries/Random.elm+4−1
@@ -1,13 +1,16 @@
1
1
2module Random where
2module Random where
3
3
4+import Signal (Signal)
4−import Native.Random as R
5+import Native.Random
5
6
6-- Given a range from low to high and a signal of values, this produces
7-- Given a range from low to high and a signal of values, this produces
7-- a new signal that changes whenever the input signal changes. The new
8-- a new signal that changes whenever the input signal changes. The new
8-- values are random number between 'low' and 'high' inclusive.
9-- values are random number between 'low' and 'high' inclusive.
9range : Int -> Int -> Signal a -> Signal Int
10range : Int -> Int -> Signal a -> Signal Int
11+range = Native.Random.range
10
12
11-- Produces a new signal that changes whenever the input signal changes.
13-- Produces a new signal that changes whenever the input signal changes.
12-- The new values are random numbers in [0..1).
14-- The new values are random numbers in [0..1).
13float : Signal a -> Signal Float
15float : Signal a -> Signal Float
16+float = Native.Random.float
libraries/Set.elm+15−14
@@ -6,60 +6,61 @@ module Set (empty,singleton,insert,remove
6 ,toList,fromList
6 ,toList,fromList
7 ) where
7 ) where
8
8
9+import Maybe (Maybe)
9import Dict as Dict
10import Dict as Dict
10import List as List
11import List as List
11
12
12−type Set t = Dict t ()
13+type Set t = Dict.Dict t ()
13
14
14-- Create an empty set.
15-- Create an empty set.
15−empty : Set (Comparable k)
16+empty : Set comparable
16empty = Dict.empty
17empty = Dict.empty
17
18
18-- Create a set with one value.
19-- Create a set with one value.
19−singleton : Comparable k -> Set (Comparable k)
20+singleton : comparable -> Set comparable
20singleton k = Dict.singleton k ()
21singleton k = Dict.singleton k ()
21
22
22-- Insert a value into a set.
23-- Insert a value into a set.
23−insert : Comparable k -> Set (Comparable k) -> Set (Comparable k)
24+insert : comparable -> Set comparable -> Set comparable
24insert k = Dict.insert k ()
25insert k = Dict.insert k ()
25
26
26-- Remove a value from a set. If the value is not found, no changes are made.
27-- 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
28remove = Dict.remove
29remove = Dict.remove
29
30
30-- Determine if a value is in a set.
31-- Determine if a value is in a set.
31−member : Comparable k -> Set (Comparable k) -> Bool
32+member : comparable -> Set comparable -> Bool
32member = Dict.member
33member = Dict.member
33
34
34-- Get the union of two sets. Keep all values.
35-- 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
36union = Dict.union
37union = Dict.union
37
38
38-- Get the intersection of two sets. Keeps values that appear in both sets.
39-- 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
40intersect = Dict.intersect
41intersect = Dict.intersect
41
42
42-- Get the difference between the first set and the second. Keeps values
43-- Get the difference between the first set and the second. Keeps values
43-- that do not appear in the second set.
44-- 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
45diff = Dict.diff
46diff = Dict.diff
46
47
47-- Convert a set into a list.
48-- Convert a set into a list.
48−toList : Set (Comparable k) -> [Comparable k]
49+toList : Set comparable -> [comparable]
49toList = Dict.keys
50toList = Dict.keys
50
51
51-- Convert a list into a set, removing any duplicates.
52-- Convert a list into a set, removing any duplicates.
52−fromList : [Comparable k] -> Set (Comparable k)
53+fromList : [comparable] -> Set comparable
53fromList xs = List.foldl insert empty xs
54fromList xs = List.foldl insert empty xs
54
55
55-- Fold over the values in a set, in order from lowest to highest.
56-- 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
57foldl f b s = Dict.foldl (\k _ b -> f k b) b s
58foldl f b s = Dict.foldl (\k _ b -> f k b) b s
58
59
59-- Fold over the values in a set, in order from highest to lowest.
60-- 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
61foldr f b s = Dict.foldr (\k _ b -> f k b) b s
62foldr f b s = Dict.foldr (\k _ b -> f k b) b s
62
63
63-- Map a function onto a set, creating a new set with no duplicates.
64-- 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'
65map f s = fromList (List.map f (toList s))
66map f s = fromList (List.map f (toList s))
libraries/Signal.elm+35−3
@@ -7,46 +7,68 @@
7-- Note: There are lift functions up to `lift8`.
7-- Note: There are lift functions up to `lift8`.
8module Signal where
8module Signal where
9
9
10−import Native.Signal as S
10+import Native.Signal
11−import List as L
11+import List (foldr)
12+
13+data Signal a = Signal
14+-- = Constant a
15+-- | Lift (a -> a) (Signal a)
12
16
13-- Create a constant signal that never changes.
17-- Create a constant signal that never changes.
14constant : a -> Signal a
18constant : a -> Signal a
19+constant = Native.Signal.constant
15
20
16-- Transform a signal with a given function.
21-- Transform a signal with a given function.
17lift : (a -> b) -> Signal a -> Signal b
22lift : (a -> b) -> Signal a -> Signal b
23+lift = Native.Signal.lift
18
24
19-- Combine two signals with a given function.
25-- Combine two signals with a given function.
20lift2 : (a -> b -> c) -> Signal a -> Signal b -> Signal c
26lift2 : (a -> b -> c) -> Signal a -> Signal b -> Signal c
27+lift2 = Native.Signal.lift2
21
28
22-- Combine three signals with a given function.
29-- Combine three signals with a given function.
23lift3 : (a -> b -> c -> d) -> Signal a -> Signal b -> Signal c -> Signal d
30lift3 : (a -> b -> c -> d) -> Signal a -> Signal b -> Signal c -> Signal d
31+lift3 = Native.Signal.lift3
32+
24lift4 : (a -> b -> c -> d -> e) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e
33lift4 : (a -> b -> c -> d -> e) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e
34+lift4 = Native.Signal.lift4
35+
25lift5 : (a -> b -> c -> d -> e -> f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f
36lift5 : (a -> b -> c -> d -> e -> f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f
37+lift5 = Native.Signal.lift5
38+
26lift6 : (a -> b -> c -> d -> e -> f -> g)
39lift6 : (a -> b -> c -> d -> e -> f -> g)
27 -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f -> Signal g
40 -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f -> Signal g
41+lift6 = Native.Signal.lift6
42+
28lift7 : (a -> b -> c -> d -> e -> f -> g -> h)
43lift7 : (a -> b -> c -> d -> e -> f -> g -> h)
29 -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f -> Signal g -> Signal h
44 -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f -> Signal g -> Signal h
45+lift7 = Native.Signal.lift7
46+
30lift8 : (a -> b -> c -> d -> e -> f -> g -> h -> i)
47lift8 : (a -> b -> c -> d -> e -> f -> g -> h -> i)
31 -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f -> Signal g -> Signal h -> Signal i
48 -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f -> Signal g -> Signal h -> Signal i
49+lift8 = Native.Signal.lift8
50+
32
51
33-- Create a past-dependent signal. Each value given on the input signal will
52-- Create a past-dependent signal. Each value given on the input signal will
34-- be accumulated, producing a new output value.
53-- be accumulated, producing a new output value.
35--
54--
36-- For instance, `(foldp (\\t acc -> acc + 1) 0 (Time.every second))` increments every second.
55-- For instance, `(foldp (\\t acc -> acc + 1) 0 (Time.every second))` increments every second.
37foldp : (a -> b -> b) -> b -> Signal a -> Signal b
56foldp : (a -> b -> b) -> b -> Signal a -> Signal b
57+foldp = Native.Signal.foldp
38
58
39-- Merge two signals into one, biased towards the first signal if both signals
59-- Merge two signals into one, biased towards the first signal if both signals
40-- update at the same time.
60-- update at the same time.
41merge : Signal a -> Signal a -> Signal a
61merge : Signal a -> Signal a -> Signal a
62+merge = Native.Signal.merge
42
63
43-- Merge many signals into one, biased towards the left-most signal if multiple
64-- Merge many signals into one, biased towards the left-most signal if multiple
44-- signals update simultaneously.
65-- signals update simultaneously.
45merges : [Signal a] -> Signal a
66merges : [Signal a] -> Signal a
67+merges = Native.Signal.merges
46
68
47-- Combine a list of signals into a signal of lists.
69-- Combine a list of signals into a signal of lists.
48combine : [Signal a] -> Signal [a]
70combine : [Signal a] -> Signal [a]
49−combine = L.foldr (S.lift2 (::)) (S.constant [])
71+combine = foldr (Native.Signal.lift2 (::)) (Native.Signal.constant [])
50
72
51 -- Merge two signals into one, but distinguishing the values by marking the first
73 -- Merge two signals into one, but distinguishing the values by marking the first
52 -- signal as `Left` and the second signal as `Right`. This allows you to easily
74 -- 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 [])
55
77
56-- Count the number of events that have occured.
78-- Count the number of events that have occured.
57count : Signal a -> Signal Int
79count : Signal a -> Signal Int
80+count = Native.Signal.count
58
81
59-- Count the number of events that have occured that satisfy a given predicate.
82-- Count the number of events that have occured that satisfy a given predicate.
60countIf : (a -> Bool) -> Signal a -> Signal Int
83countIf : (a -> Bool) -> Signal a -> Signal Int
84+countIf = Native.Signal.countIf
61
85
62-- Keep only events that satisfy the given predicate. Elm does not allow
86-- Keep only events that satisfy the given predicate. Elm does not allow
63-- undefined signals, so a base case must be provided in case the predicate is
87-- undefined signals, so a base case must be provided in case the predicate is
64-- never satisfied.
88-- never satisfied.
65keepIf : (a -> Bool) -> a -> Signal a -> Signal a
89keepIf : (a -> Bool) -> a -> Signal a -> Signal a
90+keepIf = Native.Signal.keepIf
66
91
67-- Drop events that satisfy the given predicate. Elm does not allow undefined
92-- Drop events that satisfy the given predicate. Elm does not allow undefined
68-- signals, so a base case must be provided in case the predicate is never
93-- signals, so a base case must be provided in case the predicate is never
69-- satisfied.
94-- satisfied.
70dropIf : (a -> Bool) -> a -> Signal a -> Signal a
95dropIf : (a -> Bool) -> a -> Signal a -> Signal a
96+dropIf = Native.Signal.dropIf
71
97
72-- Keep events only when the first signal is true. When the first signal becomes
98-- Keep events only when the first signal is true. When the first signal becomes
73-- true, the most recent value of the second signal will be propagated. Until
99-- 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
75-- not allow undefined signals, so a base case must be provided in case the first
101-- not allow undefined signals, so a base case must be provided in case the first
76-- signal is never true.
102-- signal is never true.
77keepWhen : Signal Bool -> a -> Signal a -> Signal a
103keepWhen : Signal Bool -> a -> Signal a -> Signal a
104+keepWhen = Native.Signal.keepWhen
78
105
79-- Drop events when the first signal is true. When the first signal becomes false,
106-- Drop events when the first signal is true. When the first signal becomes false,
80-- the most recent value of the second signal will be propagated. Until the first
107-- 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
82-- undefined signals, so a base case must be provided in case the first signal is
109-- undefined signals, so a base case must be provided in case the first signal is
83-- always true.
110-- always true.
84dropWhen : Signal Bool -> a -> Signal a -> Signal a
111dropWhen : Signal Bool -> a -> Signal a -> Signal a
112+dropWhen = Native.Signal.dropWhen
85
113
86-- Drop sequential repeated values. For example, if a signal produces the
114-- Drop sequential repeated values. For example, if a signal produces the
87-- sequence `[1,1,2,2,1]`, it becomes `[1,2,1]` by dropping the values that
115-- sequence `[1,1,2,2,1]`, it becomes `[1,2,1]` by dropping the values that
88-- are the same as the previous value.
116-- are the same as the previous value.
89dropRepeats : Signal a -> Signal a
117dropRepeats : Signal a -> Signal a
118+dropRepeats = Native.Signal.dropRepeats
90
119
91-- Sample from the second input every time an event occurs on the first input.
120-- Sample from the second input every time an event occurs on the first input.
92-- For example, `(sampleOn clicks (every second))` will give the approximate
121-- For example, `(sampleOn clicks (every second))` will give the approximate
93-- time of the latest click.
122-- time of the latest click.
94sampleOn : Signal a -> Signal b -> Signal b
123sampleOn : Signal a -> Signal b -> Signal b
124+sampleOn = Native.Signal.sampleOn
95
125
96-- An alias for `lift`. A prettier way to apply a
126-- An alias for `lift`. A prettier way to apply a
97-- function to the current value of a signal.
127-- function to the current value of a signal.
98--
128--
99-- lift f signal == f <~ signal
129-- lift f signal == f <~ signal
100(<~) : (a -> b) -> Signal a -> Signal b
130(<~) : (a -> b) -> Signal a -> Signal b
131+f <~ s = Native.Signal.lift f s
101
132
102-- Signal application. This takes two signals, holding a function and
133-- Signal application. This takes two signals, holding a function and
103-- a value. It applies the current function to the current value.
134-- a value. It applies the current function to the current value.
@@ -107,3 +138,4 @@ sampleOn : Signal a -> Signal b -> Signal b
107-- scene <~ Window.dimensions ~ Mouse.position
138-- scene <~ Window.dimensions ~ Mouse.position
108-- lift2 scene Window.dimensions Mouse.position
139-- lift2 scene Window.dimensions Mouse.position
109(~) : Signal (a -> b) -> Signal a -> Signal b
140(~) : Signal (a -> b) -> Signal a -> Signal b
141+sf ~ s = Native.Signal.lift2 (\f x -> f x) sf s
libraries/Text.elm+25−1
@@ -1,61 +1,84 @@
1
1
2module Text where
2module Text where
3
3
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)
4−import Native.Text as T
9+import Native.Text
5
10
11+data Text = Text
6
12
7-- Convert a string into text which can be styled and displayed.
13-- Convert a string into text which can be styled and displayed.
8toText : String -> Text
14toText : String -> Text
15+toText = Native.Text.toText
9
16
10-- Set the typeface of some text. The first argument should be a comma separated listing of the desired typefaces
17-- Set the typeface of some text. The first argument should be a comma separated listing of the desired typefaces
11-- "helvetica, arial, sans-serif"
18-- "helvetica, arial, sans-serif"
12-- Works the same as the CSS font-family property.
19-- Works the same as the CSS font-family property.
13typeface : String -> Text -> Text
20typeface : String -> Text -> Text
21+typeface = Native.Text.typeface
14
22
15-- Switch to a monospace typeface. Good for code snippets.
23-- Switch to a monospace typeface. Good for code snippets.
16monospace : Text -> Text
24monospace : Text -> Text
25+monospace = Native.Text.monospace
17
26
18-- Make text big and noticable.
27-- Make text big and noticable.
19header : Text -> Text
28header : Text -> Text
29+header = Native.Text.header
20
30
21-- Create a link.
31-- Create a link.
22link : String -> Text -> Text
32link : String -> Text -> Text
33+link = Native.Text.link
23
34
24-- Set the height of text in pixels.
35-- Set the height of text in pixels.
25height : Float -> Text -> Text
36height : Float -> Text -> Text
37+height = Native.Text.height
26
38
27-- Set the color of a string.
39-- Set the color of a string.
28color : Color -> Text -> Text
40color : Color -> Text -> Text
41+color = Native.Text.color
29
42
30-- Make a string bold.
43-- Make a string bold.
31bold : Text -> Text
44bold : Text -> Text
45+bold = Native.Text.bold
32
46
33-- Italicize a string.
47-- Italicize a string.
34italic : Text -> Text
48italic : Text -> Text
49+italic = Native.Text.italic
35
50
36-- Draw a line above a string.
51-- Draw a line above a string.
37overline : Text -> Text
52overline : Text -> Text
53+overline = Native.Text.overline
38
54
39-- Underline a string.
55-- Underline a string.
40underline : Text -> Text
56underline : Text -> Text
57+underline = Native.Text.underline
41
58
42-- Draw a line through a string.
59-- Draw a line through a string.
43strikeThrough : Text -> Text
60strikeThrough : Text -> Text
61+strikeThrough = Native.Text.strikeThrough
44
62
45-- Display justified, styled text.
63-- Display justified, styled text.
46justified : Text -> Element
64justified : Text -> Element
65+justified = Native.Text.justified
47
66
48-- Display centered, styled text.
67-- Display centered, styled text.
49centered : Text -> Element
68centered : Text -> Element
69+centered = Native.Text.centered
50
70
51-- Display right justified, styled text.
71-- Display right justified, styled text.
52righted : Text -> Element
72righted : Text -> Element
73+righted = Native.Text.righted
53
74
54-- Display styled text.
75-- Display styled text.
55text : Text -> Element
76text : Text -> Element
77+text = Native.Text.text
56
78
57-- Display a plain string.
79-- Display a plain string.
58plainText : String -> Element
80plainText : String -> Element
81+plainText = Native.Text.plainText
59
82
60-- Convert anything to it's textual representation and make it displayable in browser
83-- Convert anything to it's textual representation and make it displayable in browser
61--
84--
@@ -63,3 +86,4 @@ plainText : String -> Element
63--
86--
64-- Excellent for debugging.
87-- Excellent for debugging.
65asText : a -> Element
88asText : a -> Element
89+asText = Native.Text.asText
libraries/Time.elm+11−3
@@ -1,7 +1,9 @@
1-- Library for working with time. Type `Time` represents some number of milliseconds.
1-- Library for working with time. Type `Time` represents some number of milliseconds.
2module Time where
2module Time where
3
3
4+import open Basics
4−import Native.Time as T
5+import Native.Time
6+import Signal (Signal)
5
7
6-- Type alias to make it clearer when you are working with time values.
8-- Type alias to make it clearer when you are working with time values.
7-- Using the `Time` constants instead of raw numbers is very highly recommended.
9-- Using the `Time` constants instead of raw numbers is very highly recommended.
@@ -38,18 +40,21 @@ inHours t = t / hour
38-- gives a sequence of time deltas as quickly as possible until it reaches
40-- gives a sequence of time deltas as quickly as possible until it reaches
39-- the desired FPS. A time delta is the time between the last frame and the
41-- the desired FPS. A time delta is the time between the last frame and the
40-- current frame.
42-- current frame.
41−fps : Number a -> Signal Time
43+fps : number -> Signal Time
44+fps = Native.Time.fps
42
45
43-- Same as the fps function, but you can turn it on and off. Allows you
46-- Same as the fps function, but you can turn it on and off. Allows you
44-- to do brief animations based on user input without major inefficiencies.
47-- to do brief animations based on user input without major inefficiencies.
45-- The first time delta after a pause is always zero, no matter how long
48-- The first time delta after a pause is always zero, no matter how long
46-- the pause was. This way summing the deltas will actually give the amount
49-- the pause was. This way summing the deltas will actually give the amount
47-- of time that the output signal has been running.
50-- 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
49
53
50-- Takes a time interval t. The resulting signal is the current time,
54-- Takes a time interval t. The resulting signal is the current time,
51-- updated every t.
55-- updated every t.
52every : Time -> Signal Time
56every : Time -> Signal Time
57+every = Native.Time.every
53
58
54-- Takes a time `t` and any signal. The resulting boolean signal
59-- Takes a time `t` and any signal. The resulting boolean signal
55-- is true for time `t` after every event on the input signal.
60-- is true for time `t` after every event on the input signal.
@@ -57,13 +62,16 @@ every : Time -> Signal Time
57-- that is true for one second after each mouse click and false
62-- that is true for one second after each mouse click and false
58-- otherwise.
63-- otherwise.
59since : Time -> Signal a -> Signal Bool
64since : Time -> Signal a -> Signal Bool
65+since = Native.Time.since
60
66
61-- Add a timestamp to any signal. Timestamps increase monotonically. Each
67-- Add a timestamp to any signal. Timestamps increase monotonically. Each
62-- timestamp is related to a specfic event, so `Mouse.x` and `Mouse.y` will
68-- timestamp is related to a specfic event, so `Mouse.x` and `Mouse.y` will
63-- always have the same timestamp because they both rely on the same
69-- always have the same timestamp because they both rely on the same
64-- underlying event.
70-- underlying event.
65timestamp : Signal a -> Signal (Time, a)
71timestamp : Signal a -> Signal (Time, a)
72+timestamp = Native.Time.timestamp
66
73
67-- Delay a signal by a certain amount of time. So `(delay second Mouse.clicks)`
74-- Delay a signal by a certain amount of time. So `(delay second Mouse.clicks)`
68-- will update one second later than any mouse click.
75-- will update one second later than any mouse click.
69delay : Time -> Signal a -> Signal a
76delay : Time -> Signal a -> Signal a
77+delay = Native.Time.delay
libraries/Touch.elm+5−1
@@ -2,7 +2,9 @@
2-- include gestures that would be useful for both games and web-pages.
2-- include gestures that would be useful for both games and web-pages.
3module Touch where
3module Touch where
4
4
5+import Signal (Signal)
5−import Native.Touch as T
6+import Native.Touch
7+import Time (Time)
6
8
7-- Every `Touch` has `xy` coordinates. It also has an identifier `id` to
9-- Every `Touch` has `xy` coordinates. It also has an identifier `id` to
8-- distinguish one touch from another.
10-- distinguish one touch from another.
@@ -14,7 +16,9 @@ type Touch = { x:Int, y:Int, id:Int, x0:Int, y0:Int, t0:Time }
14
16
15-- A list of ongoing touches.
17-- A list of ongoing touches.
16touches : Signal [Touch]
18touches : Signal [Touch]
19+touches = Native.Touch.touches
17
20
18-- The last position that was tapped. Default value is `{x=0,y=0}`.
21-- The last position that was tapped. Default value is `{x=0,y=0}`.
19-- Updates whenever the user taps the screen.
22-- Updates whenever the user taps the screen.
20taps : Signal { x:Int, y:Int }
23taps : Signal { x:Int, y:Int }
24+taps = Native.Touch.taps
libraries/WebSocket.elm+4−1
@@ -2,12 +2,15 @@
2-- standard requests like GET, POST, etc.
2-- standard requests like GET, POST, etc.
3module WebSocket where
3module WebSocket where
4
4
5+import Signal (Signal)
6+import Basics (String)
5−import Native.WebSocket as WS
7+import Native.WebSocket
6
8
7-- Create a web-socket. The first argument is the URL of the desired
9-- Create a web-socket. The first argument is the URL of the desired
8-- web-socket server. The input signal holds the outgoing messages,
10-- web-socket server. The input signal holds the outgoing messages,
9-- and the resulting signal contains the incoming ones.
11-- and the resulting signal contains the incoming ones.
10connect : String -> Signal String -> Signal String
12connect : String -> Signal String -> Signal String
13+connect = Native.WebSocket.connect
11
14
12-- data Action = Open String | Close String | Send String String
15-- data Action = Open String | Close String | Send String String
13-- connections : Signal Action -> Signal String
16-- connections : Signal Action -> Signal String
libraries/Window.elm+5−1
@@ -1,14 +1,18 @@
1
1
2module Window where
2module Window where
3
3
4+import Signal (Signal)
4−import Native.Window as W
5+import Native.Window
5
6
6-- The current dimensions of the window (i.e. the area viewable to the
7-- The current dimensions of the window (i.e. the area viewable to the
7-- user, not including scroll bars).
8-- user, not including scroll bars).
8dimensions : Signal (Int,Int)
9dimensions : Signal (Int,Int)
10+dimensions = Native.Window.dimensions
9
11
10-- The current width of the window.
12-- The current width of the window.
11width : Signal Int
13width : Signal Int
14+width = Native.Window.width
12
15
13-- The current height of the window.
16-- The current height of the window.
14height : Signal Int
17height : Signal Int
18+height = Native.Window.height
runtime/Init.js+21−7
@@ -96,7 +96,15 @@ function init(display, container, module, moduleToReplace) {
96 return newElm;
96 return newElm;
97 }
97 }
98
98
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/>&nbsp; &nbsp; 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+ }
100 inputs = ElmRuntime.filterDeadInputs(inputs);
108 inputs = ElmRuntime.filterDeadInputs(inputs);
101 filterListeners(inputs, listeners);
109 filterListeners(inputs, listeners);
102 if (display !== ElmRuntime.Display.NONE) {
110 if (display !== ElmRuntime.Display.NONE) {
@@ -112,6 +120,7 @@ function init(display, container, module, moduleToReplace) {
112 }
120 }
113 }
121 }
114
122
123+ reportAnyErrors();
115 return { send:send, recv:recv, swap:swap };
124 return { send:send, recv:recv, swap:swap };
116};
125};
117
126
@@ -148,20 +157,25 @@ function initGraphics(elm, Module) {
148 }
157 }
149 var currentScene = signalGraph.value;
158 var currentScene = signalGraph.value;
150
159
151− // Add the currentScene to the DOM
160+ // Add the currentScene to the DOM
152 var Render = ElmRuntime.use(ElmRuntime.Render.Element);
161 var Render = ElmRuntime.use(ElmRuntime.Render.Element);
153 elm.node.appendChild(Render.render(currentScene));
162 elm.node.appendChild(Render.render(currentScene));
154− if (elm.Native.Window) elm.Native.Window.resizeIfNeeded();
155
163
156 // set up updates so that the DOM is adjusted as necessary.
164 // set up updates so that the DOM is adjusted as necessary.
157 function domUpdate(newScene, currentScene) {
165 function domUpdate(newScene, currentScene) {
158 ElmRuntime.draw(function(_) {
166 ElmRuntime.draw(function(_) {
159− Render.update(elm.node.firstChild, currentScene, newScene);
167+ Render.update(elm.node.firstChild, currentScene, newScene);
160− if (elm.Native.Window) elm.Native.Window.resizeIfNeeded();
168+ if (elm.Native.Window) elm.Native.Window.resizeIfNeeded();
161− });
169+ });
162 return newScene;
170 return newScene;
163 }
171 }
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;
165}
179}
166
180
167}());
181}());
runtime/Render/Element.js+93−81
@@ -12,26 +12,32 @@ function setProps(props, e) {
12 e.style.height = (props.height|0) + 'px';
12 e.style.height = (props.height|0) + 'px';
13 if (props.opacity !== 1) { e.style.opacity = props.opacity; }
13 if (props.opacity !== 1) { e.style.opacity = props.opacity; }
14 if (props.color.ctor === 'Just') {
14 if (props.color.ctor === 'Just') {
15− e.style.backgroundColor = extract(props.color._0);
15+ e.style.backgroundColor = extract(props.color._0);
16 }
16 }
17 if (props.tag !== '') { e.id = props.tag; }
17 if (props.tag !== '') { e.id = props.tag; }
18 if (props.href !== '') {
18 if (props.href !== '') {
19− var a = newElement('a');
19+ var a = newElement('a');
20− a.href = props.href;
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';
21− a.appendChild(e);
28+ e.appendChild(a);
22− return a;
23 }
29 }
24− if (props.hover.ctor !== 'Tuple0') {
30+ if (props.hover.ctor !== '_Tuple0') {
25 var overCount = 0;
31 var overCount = 0;
26 e.addEventListener('mouseover', function() {
32 e.addEventListener('mouseover', function() {
27− if (overCount++ > 0) return;
33+ if (overCount++ > 0) return;
28− props.hover(true);
34+ props.hover(true);
29− });
35+ });
30 e.addEventListener('mouseout', function(evt) {
36 e.addEventListener('mouseout', function(evt) {
31− if (e.contains(evt.toElement || evt.relatedTarget)) return;
37+ if (e.contains(evt.toElement || evt.relatedTarget)) return;
32− overCount = 0;
38+ overCount = 0;
33− props.hover(false);
39+ props.hover(false);
34− });
40+ });
35 }
41 }
36 return e;
42 return e;
37}
43}
@@ -76,11 +82,11 @@ function croppedImage(elem, w, h, src) {
76
82
77 var img = newElement('img');
83 var img = newElement('img');
78 img.onload = function() {
84 img.onload = function() {
79− var sw = w / elem._1, sh = h / elem._2;
85+ var sw = w / elem._1, sh = h / elem._2;
80− img.style.width = ((this.width * sw)|0) + 'px';
86+ img.style.width = ((this.width * sw)|0) + 'px';
81− img.style.height = ((this.height * sh)|0) + 'px';
87+ img.style.height = ((this.height * sh)|0) + 'px';
82− img.style.marginLeft = ((- pos._0 * sw)|0) + 'px';
88+ img.style.marginLeft = ((- pos._0 * sw)|0) + 'px';
83− img.style.marginTop = ((- pos._1 * sh)|0) + 'px';
89+ img.style.marginTop = ((- pos._1 * sh)|0) + 'px';
84 };
90 };
85 img.src = src;
91 img.src = src;
86 img.name = src;
92 img.name = src;
@@ -94,7 +100,7 @@ function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e;
94function flowWith(f, array) {
100function flowWith(f, array) {
95 var container = newElement('div');
101 var container = newElement('div');
96 for (var i = array.length; i--; ) {
102 for (var i = array.length; i--; ) {
97− container.appendChild(f(render(array[i])));
103+ container.appendChild(f(render(array[i])));
98 }
104 }
99 return container;
105 return container;
100}
106}
@@ -169,8 +175,8 @@ function update(node, curr, next) {
169 if (node.tagName === 'A') { node = node.firstChild; }
175 if (node.tagName === 'A') { node = node.firstChild; }
170 if (curr.props.id === next.props.id) return updateProps(node, curr, next);
176 if (curr.props.id === next.props.id) return updateProps(node, curr, next);
171 if (curr.element.ctor !== next.element.ctor) {
177 if (curr.element.ctor !== next.element.ctor) {
172− node.parentNode.replaceChild(render(next),node);
178+ node.parentNode.replaceChild(render(next),node);
173− return true;
179+ return true;
174 }
180 }
175 var nextE = next.element, currE = curr.element;
181 var nextE = next.element, currE = curr.element;
176 switch(nextE.ctor) {
182 switch(nextE.ctor) {
@@ -179,61 +185,61 @@ function update(node, curr, next) {
179 if (nextE._0 !== currE._0) node.innerHTML = nextE._0;
185 if (nextE._0 !== currE._0) node.innerHTML = nextE._0;
180 break;
186 break;
181 case "Image":
187 case "Image":
182− if (nextE._0.ctor === 'Plain') {
188+ if (nextE._0.ctor === 'Plain') {
183− if (nextE._3 !== currE._3) node.src = nextE._3;
189+ if (nextE._3 !== currE._3) node.src = nextE._3;
184− } else if (!eq(nextE,currE) ||
190+ } else if (!eq(nextE,currE) ||
185− next.props.width !== curr.props.width ||
191+ next.props.width !== curr.props.width ||
186− next.props.height !== curr.props.height) {
192+ next.props.height !== curr.props.height) {
187− node.parentNode.replaceChild(render(next),node);
193+ node.parentNode.replaceChild(render(next),node);
188− return true;
194+ return true;
189− }
195+ }
190− break;
196+ break;
191 case "Flow":
197 case "Flow":
192 var arr = fromList(nextE._1);
198 var arr = fromList(nextE._1);
193 for (var i = arr.length; i--; ) { arr[i] = arr[i].element.ctor; }
199 for (var i = arr.length; i--; ) { arr[i] = arr[i].element.ctor; }
194− if (nextE._0.ctor !== currE._0.ctor) {
200+ if (nextE._0.ctor !== currE._0.ctor) {
195− node.parentNode.replaceChild(render(next),node);
201+ node.parentNode.replaceChild(render(next),node);
196− return true;
202+ return true;
197− }
203+ }
198− var nexts = fromList(nextE._1);
204+ var nexts = fromList(nextE._1);
199− var kids = node.childNodes;
205+ var kids = node.childNodes;
200− if (nexts.length !== kids.length) {
206+ if (nexts.length !== kids.length) {
201− node.parentNode.replaceChild(render(next),node);
207+ node.parentNode.replaceChild(render(next),node);
202− return true;
208+ return true;
203− }
209+ }
204− var currs = fromList(currE._1);
210+ var currs = fromList(currE._1);
205− var goDir = function(x) { return x; };
211+ var goDir = function(x) { return x; };
206− switch(nextE._0.ctor) {
212+ switch(nextE._0.ctor) {
207− case "DDown": case "DUp": goDir = goDown; break;
213+ case "DDown": case "DUp": goDir = goDown; break;
208− case "DRight": case "DLeft": goDir = goRight; break;
214+ case "DRight": case "DLeft": goDir = goRight; break;
209− case "DOut": case "DIn": goDir = goIn; break;
215+ case "DOut": case "DIn": goDir = goIn; break;
210− }
216+ }
211− for (var i = kids.length; i-- ;) {
217+ for (var i = kids.length; i-- ;) {
212− update(kids[i],currs[i],nexts[i]);
218+ update(kids[i],currs[i],nexts[i]);
213− goDir(kids[i]);
219+ goDir(kids[i]);
214− }
220+ }
215− break;
221+ break;
216 case "Container":
222 case "Container":
217− var inner = node.firstChild;
223+ var inner = node.firstChild;
218− if (!update(inner, currE._1, nextE._1)) {
224+ if (!update(inner, currE._1, nextE._1)) {
219− if (nextE._0.horizontal.ctor !== currE._0.horizontal.ctor) {
225+ if (nextE._0.horizontal.ctor !== currE._0.horizontal.ctor) {
220− inner.style.left = inner.style.right = 'none';
226+ inner.style.left = inner.style.right = 'none';
221− removeTransform(inner.style);
227+ removeTransform(inner.style);
222− }
228+ }
223− if (nextE._0.vertical.ctor !== currE._0.vertical.ctor) {
229+ if (nextE._0.vertical.ctor !== currE._0.vertical.ctor) {
224− inner.style.top = inner.style.bottom = 'none';
230+ inner.style.top = inner.style.bottom = 'none';
225− removeTransform(inner.style);
231+ removeTransform(inner.style);
226− }
232+ }
227− }
233+ }
228− setPos(nextE._0, nextE._1.props.width, nextE._1.props.height, inner);
234+ setPos(nextE._0, nextE._1.props.width, nextE._1.props.height, inner);
229− break;
235+ break;
230 case "Custom":
236 case "Custom":
231− if (currE.type === nextE.type) {
237+ if (currE.type === nextE.type) {
232− var done = nextE.update(node, currE.model, nextE.model);
238+ var done = nextE.update(node, currE.model, nextE.model);
233− if (done) return;
239+ if (done) return;
234− } else {
240+ } else {
235− return node.parentNode.replaceChild(render(next), node);
241+ return node.parentNode.replaceChild(render(next), node);
236− }
242+ }
237 }
243 }
238 updateProps(node, curr, next);
244 updateProps(node, curr, next);
239}
245}
@@ -243,23 +249,29 @@ function updateProps(node, curr, next) {
243 if (props.width !== currP.width) e.style.width = (props.width |0) + 'px';
249 if (props.width !== currP.width) e.style.width = (props.width |0) + 'px';
244 if (props.height !== currP.height) e.style.height = (props.height|0) + 'px';
250 if (props.height !== currP.height) e.style.height = (props.height|0) + 'px';
245 if (props.opacity !== 1 && props.opacity !== currP.opacity) {
251 if (props.opacity !== 1 && props.opacity !== currP.opacity) {
246− e.style.opacity = props.opacity;
252+ e.style.opacity = props.opacity;
247 }
253 }
248 var nextColor = (props.color.ctor === 'Just' ?
254 var nextColor = (props.color.ctor === 'Just' ?
249− extract(props.color._0) : 'transparent');
255+ extract(props.color._0) : 'transparent');
250 if (e.style.backgroundColor !== nextColor) {
256 if (e.style.backgroundColor !== nextColor) {
251 e.style.backgroundColor = nextColor;
257 e.style.backgroundColor = nextColor;
252 }
258 }
253 if (props.tag !== currP.tag) { e.id = props.tag; }
259 if (props.tag !== currP.tag) { e.id = props.tag; }
254 if (props.href !== currP.href) {
260 if (props.href !== currP.href) {
255− if (currP.href === '') {
261+ if (currP.href === '') {
256− var a = newElement('a');
262+ var a = newElement('a');
257− a.href = props.href;
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';
258− a.appendChild(e);
271+ e.appendChild(a);
259− e.parentNode.replaceChild(a,e);
260− } else {
272+ } else {
261− node.parentNode.href = props.href;
273+ node.lastNode.href = props.href;
262− }
274+ }
263 }
275 }
264}
276}
265
277
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