git.iko.soy/elk
on master help sign in
Merge branch 'types'
51dfa67Evan 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+118−102
@@ -22,134 +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, compiler/Gen, compiler/Model, compiler/Transform
34+ Hs-Source-Dirs: compiler
36− other-modules: Ast,
35+ other-modules: Unique,
37− Located,
36+ SourceSyntax.Declaration,
38− CompileToJS,
37+ SourceSyntax.Expression,
38+ SourceSyntax.Everything,
39+ SourceSyntax.Helpers,
40+ SourceSyntax.Literal,
41+ SourceSyntax.Location,
42+ SourceSyntax.Module,
43+ SourceSyntax.Pattern,
44+ SourceSyntax.PrettyPrint,
45+ SourceSyntax.Type,
46+ Generate.JavaScript,
47+ Generate.Noscript,
48+ Generate.Html,
39− Cases,
49+ Generate.Cases,
50+ Transform.Canonicalize,
51+ Transform.Check,
52+ Transform.SortDefinitions,
40− Substitute,
53+ Transform.Substitute,
41− ExtractNoscript,
42− GenerateHtml,
43− Guid,
44− Libraries,
45− LoadLibraries,
46− Optimize,
54+ Transform.Optimize,
55+ Metadata.Prelude,
47 Initialize,
56 Initialize,
48− Rename,
57+ Parse.Binop,
49− Parse.Binops,
58+ Parse.Declaration,
50− Parse.Expr,
59+ Parse.Expression,
51− Parse.Foreign,
60+ Parse.Helpers,
52− Parse.Library,
61+ Parse.Literal,
53− Parse.Modules,
62+ Parse.Module,
54− Parse.Parser,
63+ Parse.Parse,
55− Parse.Patterns,
64+ Parse.Pattern,
56− Parse.Types,
65+ Parse.Type,
57− Types.Alias,
66+ Type.Constrain.Declaration,
58− Types.Types,
67+ Type.Constrain.Expression,
68+ Type.Constrain.Literal,
59− Types.Constrain,
69+ Type.Constrain.Pattern,
60− Types.Hints,
70+ Type.Environment,
61− Types.Solver,
71+ Type.Fragment,
62− Types.Substitutions,
72+ Type.Inference,
73+ Type.PrettyPrint,
74+ Type.Solve,
75+ Type.State,
76+ Type.Type,
63− Types.Unify,
77+ Type.Unify,
64 Paths_Elm
78 Paths_Elm
65
79
66 Build-depends: base >=4.2 && <5,
80 Build-depends: base >=4.2 && <5,
67− containers >= 0.3,
81+ binary,
68− uniplate >= 1.6,
69− transformers >= 0.2,
70− mtl >= 2,
71− deepseq,
72− parsec >= 3.1.1,
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− text,
76− shakespeare >= 1,
77− template-haskell,
78− pandoc >= 1.10,
79 bytestring,
84 bytestring,
85+ cmdargs,
86+ containers >= 0.3,
87+ directory,
88+ filepath,
80 hjsmin,
89 hjsmin,
81 indents,
90 indents,
82− filepath,
91+ mtl >= 2,
83− json,
92+ pandoc >= 1.10,
84− directory
93+ parsec >= 3.1.1,
94+ pretty,
95+ transformers >= 0.2,
96+ union-find,
97+ uniplate
85
98
86Executable elm
99Executable elm
87 Main-is: Compiler.hs
100 Main-is: Compiler.hs
101+ ghc-options: -threaded -O2
88− Hs-Source-Dirs: compiler, compiler/Gen, compiler/Model, compiler/Transform
102+ Hs-Source-Dirs: compiler
89− extensions: CPP
90− cpp-options: -DELM_COMPILEDATADIR="dist/data"
91− other-modules: Ast,
103+ other-modules: Unique,
92− Located,
104+ SourceSyntax.Declaration,
93− CompileToJS,
105+ SourceSyntax.Expression,
106+ SourceSyntax.Everything,
107+ SourceSyntax.Helpers,
108+ SourceSyntax.Literal,
109+ SourceSyntax.Location,
110+ SourceSyntax.Module,
111+ SourceSyntax.Pattern,
112+ SourceSyntax.PrettyPrint,
113+ SourceSyntax.Type,
114+ Generate.JavaScript,
115+ Generate.Noscript,
116+ Generate.Html,
94− Cases,
117+ Generate.Cases,
118+ Transform.Canonicalize,
119+ Transform.Check,
120+ Transform.SortDefinitions,
95− Substitute,
121+ Transform.Substitute,
96− ExtractNoscript,
97− GenerateHtml,
98− Guid,
99− Libraries,
100− LoadLibraries,
101− Optimize,
122+ Transform.Optimize,
123+ Metadata.Prelude,
102 Initialize,
124 Initialize,
103− Rename,
125+ Parse.Binop,
104− Parse.Binops,
126+ Parse.Declaration,
105− Parse.Expr,
127+ Parse.Expression,
106− Parse.Foreign,
128+ Parse.Helpers,
107− Parse.Library,
129+ Parse.Literal,
108− Parse.Modules,
130+ Parse.Module,
109− Parse.Parser,
131+ Parse.Parse,
110− Parse.Patterns,
132+ Parse.Pattern,
111− Parse.Types,
133+ Parse.Type,
112− Types.Alias,
134+ Type.Constrain.Declaration,
113− Types.Types,
135+ Type.Constrain.Expression,
136+ Type.Constrain.Literal,
114− Types.Constrain,
137+ Type.Constrain.Pattern,
115− Types.Hints,
138+ Type.Environment,
116− Types.Solver,
139+ Type.Fragment,
117− Types.Substitutions,
140+ Type.Inference,
141+ Type.PrettyPrint,
142+ Type.Solve,
143+ Type.State,
144+ Type.Type,
118− Types.Unify,
145+ Type.Unify,
119 Paths_Elm
146 Paths_Elm
120
147
121 Build-depends: base >=4.2 && <5,
148 Build-depends: base >=4.2 && <5,
122− containers >= 0.3,
149+ binary,
123− uniplate >= 1.6,
124− transformers >= 0.2,
125− mtl >= 2,
126− deepseq,
127− parsec >= 3.1.1,
128 blaze-html == 0.5.* || == 0.6.*,
150 blaze-html == 0.5.* || == 0.6.*,
129 blaze-markup == 0.5.1.*,
151 blaze-markup == 0.5.1.*,
130− cmdargs,
131− pandoc >= 1.10,
132 bytestring,
152 bytestring,
153+ cmdargs,
154+ containers >= 0.3,
155+ directory,
156+ filepath,
133 hjsmin,
157 hjsmin,
134 indents,
158 indents,
135− filepath,
136− json,
137− directory
138−
139−Executable elm-doc
140− Main-is: Docs.hs
141− Hs-Source-Dirs: compiler, compiler/Model, compiler/Transform
142− other-modules: Ast,
143− Located,
144− Parse.Library,
145− Parse.Modules,
146− Rename
147−
148− Build-depends: base >=4.2 && <5,
149− containers >= 0.3,
150− transformers >= 0.2,
151 mtl >= 2,
159 mtl >= 2,
152− parsec >= 3.1.1,
153 pandoc >= 1.10,
160 pandoc >= 1.10,
154− cmdargs,
161+ parsec >= 3.1.1,
155− indents
162+ pretty,
163+ transformers >= 0.2,
164+ union-find,
165+ uniplate
166+
167+Test-Suite test-elm
168+ Type: exitcode-stdio-1.0
169+ Hs-Source-Dirs: tests
170+ Main-is: Everything.hs
171+ build-depends: base
Setup.hs+75−75
@@ -10,12 +10,13 @@ import System.IO
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,47 +30,34 @@ 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
33−jsDir lbi = (buildDir lbi) </> ".." </> "js"
35+rtsDir lbi = buildDir lbi </> ".." </> "data"
34
36
35−-- The runtime is called:
37+tempDir :: LocalBuildInfo -> FilePath
36−rts lbi = (rtsDir lbi) </> "elm-runtime.js"
38+tempDir lbi = buildDir lbi </> ".." </> "temp"
37−
38−-- The json file is called:
39
39
40−-- The elm-docs executable is called:
40+-- The runtime is called:
41−elmDoc = "elm-doc"
41+rts :: LocalBuildInfo -> FilePath
42−elm_doc lbi = (buildDir lbi) </> elmDoc </> elmDoc
42+rts lbi = rtsDir lbi </> "elm-runtime.js"
43
43
44−types lbi = (rtsDir lbi) </> "docs.json"
44+-- The interfaces for the Standard Libraries live in:
45+interfaces :: LocalBuildInfo -> FilePath
46+interfaces lbi = rtsDir lbi </> "interfaces.data"
45
47
46-- buildDir with LocalBuildInfo points to "dist/build" (usually)
48-- buildDir with LocalBuildInfo points to "dist/build" (usually)
47−elm lbi = (buildDir lbi) </> "elm" </> "elm"
49+elm lbi = buildDir lbi </> "elm" </> "elm"
48
50
49-- Care! This appears to be based on an unstable API
51-- Care! This appears to be based on an unstable API
50-- See: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html#2
52-- See: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html#2
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,32 +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− mapM_ (appendJS lbi) =<< getFiles ".js" "libraries"
155− mapM_ (appendElm lbi) =<< getFiles ".elm" "libraries"
156− mapM_ (appendJS lbi) =<< getFiles ".js" "runtime"
changelog.txt+40
@@ -1,4 +1,44 @@
1
1
2+Release 0.8.1
3+=============
4+
5+Website:
6+* Hot-swapping
7+* Much faster page load with pre-compile Elm files (Max New)
8+
9+Syntax:
10+* Pattern matching on literals
11+* Pattern aliases with `as` (Andrew)
12+* Unary negation
13+* Triple-quoted multi-line strings
14+* Custom infix precedence and associativity
15+* Type annotations in let expressions (Andrew)
16+* Record Constructors
17+* Record type aliases can be closed on the zeroth column
18+* (,,) syntax in types
19+* "(+) = " is permitted
20+* Unparenthesized if, let, case, and lambda in last
21+ term of a binary expression
22+
23+Libraries:
24+* Detect hovering over any Element
25+* Opacity on arbitrary forms in collages
26+* Switch Text.height to use px instead of em
27+
28+Error Messages:
29+* Cross-module type errors
30+* Pretty printing of expressions and types
31+* Type-variables look more natural (a,b,c instead of t1,t2,t3)
32+
33+Build Improvements:
34+* Module-level compilation, only re-compile if necessary
35+* Import type aliases between modules
36+
37+
38+
39+forgot to fill this in again...
40+
41+
2Release 0.7.2
42Release 0.7.2
3=============
43=============
4
44
compiler/Compiler.hs+86−43
@@ -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 Ast
20+import qualified Metadata.Prelude as Prelude
21+import qualified Transform.Canonicalize as Canonical
22+import SourceSyntax.Module
21−import Initialize (buildFromSource, getSortedModuleNames)
23+import Initialize (buildFromSource, getSortedDependencies)
22−import CompileToJS (jsModule)
24+import Generate.JavaScript (jsModule)
23−import GenerateHtml (createHtml, JSStyle(..), JSSource(..))
25+import Generate.Html (createHtml, JSStyle(..), JSSource(..))
24−import qualified 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
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,11 +187,11 @@ 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
197
@@ -156,4 +199,4 @@ buildFiles flags numModules interfaces (filePath:rest) = do
156exportInfo :: Module -> IO String
199exportInfo :: Module -> IO String
157exportInfo (Module names exs ims stmts) =
200exportInfo (Module names exs ims stmts) =
158 do print exs
201 do print exs
159− return (show exs)
202+ return (show exs)
compiler/Docs.hs+8−9
@@ -1,19 +1,16 @@
1
1
2module Main where
2module Main where
3
3
4−import Ast
4+import SourceSyntax.Declaration (Declaration(Datatype))
5import Control.Applicative ((<$>), (<*>))
5import Control.Applicative ((<$>), (<*>))
6import Data.List (intercalate)
6import Data.List (intercalate)
7−import Data.Maybe (catMaybes)
7+import Parse.Type
8−import Types.Types ((==>), Type ( ADT, VarT ) )
9−import Parse.Types (datatype)
8+import Parse.Helpers
10−import Parse.Library
9+import Parse.Module (moduleDef)
11−import Parse.Modules (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.cabalnew file+170
@@ -0,0 +1,170 @@
1+-- This is a dummy .cabal file that makes it possible to build the
2+-- compiler with GHCi from within emacs. Do not actually use this
3+-- file to install things.
4+
5+Name: Elm
6+Version: 0.8.0.3
7+Synopsis: The Elm language module.
8+Description: Elm aims to make client-side web-development more pleasant.
9+ It is a statically/strongly typed, functional reactive
10+ language to HTML, CSS, and JS. This package provides a
11+ library for Elm compilation in Haskell and a compiler
12+ executable.
13+
14+Homepage: http://elm-lang.org
15+
16+License: BSD3
17+License-file: LICENSE
18+
19+Author: Evan Czaplicki
20+Maintainer: info@elm-lang.org
21+Copyright: Copyright: (c) 2011-2012 Evan Czaplicki
22+
23+Category: Compiler, Language
24+
25+Build-type: Custom
26+
27+Extra-source-files: changelog.txt
28+Data-dir: dist/data
29+Data-files: elm-runtime.js docs.json
30+Cabal-version: >=1.8
31+
32+source-repository head
33+ type: git
34+ location: git://github.com/evancz/Elm.git
35+
36+Library
37+ exposed-modules: Language.Elm,
38+ Language.Elm.Quasi
39+ Hs-Source-Dirs: compiler
40+ other-modules: Unique,
41+ SourceSyntax.Helpers,
42+ SourceSyntax.Location,
43+ SourceSyntax.Literal,
44+ SourceSyntax.Pattern,
45+ SourceSyntax.Expression,
46+ SourceSyntax.Declaration,
47+ SourceSyntax.Module,
48+ Generate.JavaScript,
49+ Generate.Noscript,
50+ Generate.Html,
51+ Generate.Cases,
52+ Transform.Substitute,
53+ Transform.Optimize,
54+ Metadata.Libraries,
55+ Metadata.LoadLibraries,
56+ Initialize,
57+ Parse.Binop,
58+ Parse.Expression,
59+ Parse.Foreign,
60+ Parse.Helpers,
61+ Parse.Module,
62+ Parse.Parser,
63+ Parse.Pattern,
64+ Parse.Type,
65+ Types.Alias,
66+ Types.Types,
67+ Types.Constrain,
68+ Types.Hints,
69+ Types.Solver,
70+ Types.Substitutions,
71+ Types.Unify,
72+ Paths_Elm
73+
74+ Build-depends: base >=4.2 && <5,
75+ containers >= 0.3,
76+ transformers >= 0.2,
77+ mtl >= 2,
78+ deepseq,
79+ parsec >= 3.1.1,
80+ blaze-html == 0.5.* || == 0.6.*,
81+ blaze-markup == 0.5.1.*,
82+ text,
83+ shakespeare >= 1,
84+ template-haskell,
85+ pandoc >= 1.10,
86+ bytestring,
87+ uniplate,
88+ hjsmin,
89+ indents,
90+ filepath,
91+ json,
92+ directory
93+
94+Executable elm
95+ Main-is: Compiler.hs
96+ Hs-Source-Dirs: compiler
97+ other-modules: Unique,
98+ SourceSyntax.Helpers,
99+ SourceSyntax.Location,
100+ SourceSyntax.Literal,
101+ SourceSyntax.Pattern,
102+ SourceSyntax.Expression,
103+ SourceSyntax.Declaration,
104+ SourceSyntax.Module,
105+ Generate.JavaScript,
106+ Generate.Noscript,
107+ Generate.Html,
108+ Generate.Cases,
109+ Transform.Substitute,
110+ Transform.Optimize,
111+ Metadata.Libraries,
112+ Metadata.LoadLibraries,
113+ Initialize,
114+ Parse.Binop,
115+ Parse.Expression,
116+ Parse.Foreign,
117+ Parse.Helpers,
118+ Parse.Module,
119+ Parse.Parser,
120+ Parse.Pattern,
121+ Parse.Type,
122+ Types.Alias,
123+ Types.Types,
124+ Types.Constrain,
125+ Types.Hints,
126+ Types.Solver,
127+ Types.Substitutions,
128+ Types.Unify,
129+ Paths_Elm
130+
131+ Build-depends: base >=4.2 && <5,
132+ containers >= 0.3,
133+ transformers >= 0.2,
134+ mtl >= 2,
135+ deepseq,
136+ parsec >= 3.1.1,
137+ blaze-html == 0.5.* || == 0.6.*,
138+ blaze-markup == 0.5.1.*,
139+ cmdargs,
140+ pandoc >= 1.10,
141+ bytestring,
142+ uniplate,
143+ hjsmin,
144+ indents,
145+ filepath,
146+ json,
147+ directory
148+
149+Executable elm-doc
150+ Main-is: Docs.hs
151+ Hs-Source-Dirs: compiler
152+ other-modules: SourceSyntax.Helpers,
153+ SourceSyntax.Location,
154+ SourceSyntax.Literal,
155+ SourceSyntax.Pattern,
156+ SourceSyntax.Expression,
157+ SourceSyntax.Declaration,
158+ SourceSyntax.Module,
159+ Parse.Helpers,
160+ Parse.Module
161+
162+ Build-depends: base >=4.2 && <5,
163+ containers >= 0.3,
164+ transformers >= 0.2,
165+ mtl >= 2,
166+ parsec >= 3.1.1,
167+ pandoc >= 1.10,
168+ cmdargs,
169+ filepath,
170+ indents
compiler/Gen/Cases.hsdeleted−87
@@ -1,87 +0,0 @@
1−
2−module Cases (caseToMatch, Match (..), Clause (..), matchSubst) where
3−
4−import Control.Arrow (first)
5−import Control.Monad (liftM,foldM)
6−import Data.List (groupBy,sortBy,lookup)
7−import Data.Maybe (fromMaybe)
8−
9−import Ast
10−import Located
11−import Guid
12−import Substitute
13−
14−caseToMatch patterns = do
15− v <- newVar
16− match [v] (map (first (:[])) patterns) Fail
17−
18−newVar = do n <- guid
19− return $ "case" ++ show n
20−
21−data Match = Match String [Clause] Match
22− | Break
23− | Fail
24− | Other CExpr
25− | Seq [Match]
26− deriving Show
27−
28−data Clause = Clause String [String] Match
29− deriving Show
30−
31−matchSubst :: [(String,String)] -> Match -> Match
32−matchSubst _ Break = Break
33−matchSubst _ Fail = Fail
34−matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
35−matchSubst pairs (Other (L t s e)) =
36− Other . L t s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
37−matchSubst pairs (Match n cs m) =
38− Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
39− where varSubst v = fromMaybe v (lookup v pairs)
40− clauseSubst (Clause c vs m) =
41− Clause c (map varSubst vs) (matchSubst pairs m)
42−
43−isCon (PData _ _ : _, _) = True
44−isCon _ = False
45−
46−isVar p = not (isCon p)
47−
48−match :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
49−match [] [] def = return def
50−match [] [([],e)] Fail = return $ Other e
51−match [] [([],e)] Break = return $ Other e
52−match [] cs def = return $ Seq (map (Other . snd) cs ++ [def])
53−match vs cs def
54− | all isVar cs = matchVar vs cs def
55− | all isCon cs = matchCon vs cs def
56− | otherwise = matchMix vs cs def
57−
58−matchVar :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
59−matchVar (v:vs) cs def = match vs (map subVar cs) def
60− where
61− subVar (p:ps, ce@(L t s e)) =
62− let loc = L t s in
63− (ps, case p of
64− PVar x -> L t s $ subst x (Var v) e
65− PAnything -> ce
66− PRecord fs ->
67− loc $ foldr (\x -> subst x (Access (loc (Var v)) x)) e fs
68− )
69−
70−matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
71−matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css
72− where css = groupBy (withName (==)) $ sortBy (withName compare) cs
73− withName f (PData n1 _:_,_) (PData n2 _:_,_) = f n1 n2
74− toClause cs = let (PData name _ : _ , _) = head cs in
75− matchClause name (v:vs) cs Break
76−
77−matchClause :: String -> [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Clause
78−matchClause c (v:vs) cs def =
79− do vs' <- getVars
80− Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def
81− where flatten (PData _ ps' : ps, e) = (ps' ++ ps, e)
82− getVars = let (PData _ ps : _, _) = head cs in
83− mapM (\_ -> newVar) ps
84−
85−matchMix :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
86−matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
87− where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
compiler/Gen/CompileToJS.hsdeleted−341
@@ -1,341 +0,0 @@
1−module CompileToJS (showErr, jsModule) where
2−
3−import Control.Arrow (first,second)
4−import Control.Monad (liftM,(<=<),join,ap)
5−import Data.Char (isAlpha,isDigit)
6−import Data.List (intercalate,sortBy,inits,foldl')
7−import qualified Data.Map as Map
8−import Data.Either (partitionEithers)
9−import qualified Text.Pandoc as Pan
10−import Data.Maybe (maybeToList)
11−
12−import Ast
13−import Located
14−import Rename (derename)
15−import Cases
16−import Guid
17−import Rename (deprime)
18−import Types.Types ( Type(RecordT) )
19−
20−showErr :: String -> String
21−showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
22− where msg = show . concatMap (++"<br>") . lines $ err
23− body = "var T = Elm.Text(elm);\n\
24− \return { main : T.text(T.monospace(" ++ msg ++ ")) };"
25−
26−indent = concatMap f
27− where f '\n' = "\n "
28− f c = [c]
29−
30−internalImports =
31− [ ("N" , "Elm.Native"),
32− ("_N", "N.Utils(elm)"),
33− ("_L", "N.List(elm)"),
34− ("_E", "N.Error(elm)"),
35− ("_str", "N.JavaScript(elm).toString")
36− ]
37−
38−parens s = "(" ++ s ++ ")"
39−brackets s = "{" ++ s ++ "}"
40−jsObj = brackets . intercalate ", "
41−jsList ss = "["++ intercalate "," ss ++"]"
42−jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
43−assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
44−ret e = "\nreturn "++ e ++";"
45−iff a b c = a ++ "?" ++ b ++ ":" ++ c
46−quoted s = "'" ++ concatMap f s ++ "'"
47− where f '\n' = "\\n"
48− f '\'' = "\\'"
49− f '\t' = "\\t"
50− f '\"' = "\\\""
51− f '\\' = "\\\\"
52− f c = [c]
53−
54−globalAssign n e = "\n" ++ assign' n e ++ ";"
55−assign' n e = n ++ " = " ++ e
56−
57−jsModule (Module names exports imports stmts) =
58− setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
59− where
60− modNames = if null names then ["Main"] else names
61− modName = intercalate "." modNames
62− includes = concatMap jsImport imports
63− body = stmtsToJS stmts
64− defs = assign "$op" "{}"
65− program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
66− setup ("elm":"Native":modNames) ++
67− assign "_" ("elm.Native." ++ modName ++ "||{}") ++
68− getExports exports stmts ++ setup ("elm":modNames) ++
69− ret (assign' ("elm." ++ modName) "_") ++ "\n"
70− setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
71− map (intercalate ".") . drop 2 . inits $ init modNames
72− usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
73−
74−getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
75− where exNames n = either derename id n `elem` names
76− exports | null names = concatMap get stmts
77− | otherwise = filter exNames (concatMap get stmts)
78−
79− (fns,ops) = partitionEithers exports
80−
81− opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
82− fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
83−
84− op = ("_.$op = "++) . jsObj $ map opPair ops
85−
86− get' (FnDef x _ _) = Just (Left x)
87− get' (OpDef op _ _ _) = Just (Right op)
88− get' (TypeAnnotation _ _) = Nothing
89− get s = case s of Definition d -> maybeToList (get' d)
90− Datatype _ _ tcs -> map (Left . fst) tcs
91− ImportEvent _ _ x _ -> [ Left x ]
92− ExportEvent _ _ _ -> []
93− TypeAlias _ _ _ -> []
94−
95−
96−jsImport (modul, how) =
97− case how of
98− As name -> assign name ("Elm." ++ modul ++ parens "elm")
99− Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
100− "; for(var k in _){if(k in hiding)continue;" ++
101− "eval('var '+k+'=_[\"'+k+'\"]')}"
102− Importing vs -> include ++ named
103− where
104− imprt v = assign' v ("_." ++ v)
105− def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
106− named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
107− where
108− include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
109− setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
110− where
111− defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
112− subnames = map (intercalate ".") . tail . inits . init . split
113− split names = case go [] names of
114− (name, []) -> [name]
115− (name, ns) -> name : split ns
116− go name str = case str of
117− '.':rest -> (reverse name, rest)
118− c:rest -> go (c:name) rest
119− [] -> (reverse name, [])
120−
121−
122−
123−stmtsToJS :: [Statement] -> String
124−stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
125− return (concat program)
126− where
127− cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
128− valueOf s = case s of
129− Datatype _ _ _ -> 1
130− ImportEvent _ _ _ _ -> 2
131− Definition (FnDef f [] _) ->
132− if derename f == "main" then 5 else 4
133− Definition (TypeAnnotation _ _) -> 0
134− Definition _ -> 3
135− ExportEvent _ _ _ -> 6
136− TypeAlias _ _ _ -> 0
137−
138−class ToJS a where
139− toJS :: a -> GuidCounter String
140−
141−instance ToJS Def where
142− toJS (FnDef x [] e) = assign x `liftM` toJS' e
143− toJS (FnDef f as e) = (assign f . wrapper . func) `liftM` toJS' e
144− where
145− func body = jsFunc (intercalate ", " as) (ret body)
146− wrapper e | length as == 1 = e
147− | otherwise = 'F' : show (length as) ++ parens e
148− toJS (OpDef op a1 a2 e) =
149− do body <- toJS' e
150− let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
151− return (globalAssign ("$op['" ++ op ++ "']") func)
152− toJS (TypeAnnotation _ _) = return ""
153−
154−
155−instance ToJS Statement where
156− toJS stmt =
157− case stmt of
158− Definition d -> toJS d
159− Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
160− where toDef (name,args) =
161− let vars = map (('a':) . show) [1..length args] in
162− Definition . FnDef name vars . notLocated $
163− Data (derename name) (map (notLocated . Var) vars)
164− ImportEvent js base elm _ ->
165− do v <- toJS' base
166− return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
167− , "\ndocument.addEventListener('", js
168− , "_' + elm.id, function(e) { elm.notify(", elm
169− , ".id, e.value); });" ]
170− ExportEvent js elm _ ->
171− return $ concat [ "\nlift(function(v) { "
172− , "var e = document.createEvent('Event');"
173− , "e.initEvent('", js, "_' + elm.id, true, true);"
174− , "e.value = v;"
175− , "document.dispatchEvent(e); return v; })(", elm, ");" ]
176− TypeAlias n _ t -> return ""
177−
178−toJS' :: CExpr -> GuidCounter String
179−toJS' (L txt span expr) =
180− case expr of
181− MultiIf ps -> multiIfToJS span ps
182− Case e cases -> caseToJS span e cases
183− _ -> toJS expr
184−
185−remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
186−addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
187−setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
188− where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
189−access x e = e ++ "." ++ x
190−makeRecord kvs = record `liftM` collect kvs
191− where
192− combine r (k,v) = Map.insertWith (++) k v r
193− collect = liftM (foldl' combine Map.empty) . mapM prep
194− prep (k, as, e@(L t s _)) =
195− do v <- toJS' (foldr (\x e -> L t s $ Lambda x e) e as)
196− return (k,[v])
197− fields fs =
198− brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
199− hidden = fields . map (second jsList) .
200− filter (not . null . snd) . Map.toList . Map.map tail
201− record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
202−
203−
204−instance ToJS Expr where
205− toJS expr =
206− case expr of
207− Var x -> return $ x
208− Chr c -> return $ quoted [c]
209− Str s -> return $ "_str" ++ parens (quoted s)
210− IntNum n -> return $ show n
211− FloatNum n -> return $ show n
212− Boolean b -> return $ if b then "true" else "false"
213− Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
214− Access e x -> access x `liftM` toJS' e
215− Remove e x -> remove x `liftM` toJS' e
216− Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
217− Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
218− setField fs' `liftM` toJS' e
219− Record fs -> makeRecord fs
220− Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
221−
222− If eb et ef ->
223− parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
224−
225− Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
226−
227− App e1 e2 -> jsApp e1 e2
228− Let defs e -> jsLet defs e
229− Data name es ->
230− do fs <- mapM toJS' es
231− return $ case name of
232− "Nil" -> jsNil
233− "Cons" -> jsCons (head fs) ((head . tail) fs)
234− _ -> jsObj $ ("ctor:" ++ show name) : fields
235− where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
236−
237− Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
238− where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
239− md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
240−
241−jsApp e1 e2 =
242− do f <- toJS' func
243− as <- mapM toJS' args
244− return $ case as of
245− [a] -> f ++ parens a
246− _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
247− where
248− (func, args) = go [e2] e1
249− go args e =
250− case e of
251− (L _ _ (App e1 e2)) -> go (e2 : args) e1
252− _ -> (e, args)
253−
254−formatMarkdown = concatMap f
255− where f '\'' = "\\'"
256− f '\n' = "\\n"
257− f '"' = "\""
258− f c = [c]
259−
260−multiIfToJS span ps =
261− case last ps of
262− (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
263− _ -> format ("_E.If" ++ parens (quoted (show span))) ps
264− where
265− format base ps =
266− foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
267− f (b,e) = do b' <- toJS' b
268− e' <- toJS' e
269− return (b' ++ " ? " ++ e')
270−
271−jsLet defs e' = do ds <- jsDefs defs
272− e <- toJS' e'
273− return $ jsFunc "" (concat ds ++ ret e) ++ "()"
274− where
275− jsDefs defs = mapM toJS (sortBy f defs)
276− f a b = compare (valueOf a) (valueOf b)
277− valueOf (FnDef _ [] _) = 2
278− valueOf (FnDef _ _ _) = 1
279− valueOf (OpDef _ _ _ _) = 1
280− valueOf (TypeAnnotation _ _) = 0
281−
282−caseToJS span e ps = do
283− match <- caseToMatch ps
284− e' <- toJS' e
285− let (match',stmt) = case (match,e) of
286− (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
287− (Match name _ _, _) -> (match, assign name e')
288− _ -> (match, "")
289− matches <- matchToJS span match'
290− return $ "function(){ " ++ stmt ++ matches ++ " }()"
291−
292−matchToJS span match =
293− case match of
294− Match name clauses def ->
295− do cases <- concat `liftM` mapM (clauseToJS span name) clauses
296− finally <- matchToJS span def
297− return $ concat [ "\nswitch (", name, ".ctor) {",
298− indent cases, "\n}", finally ]
299− Fail -> return ("_E.Case" ++ parens (quoted (show span)))
300− Break -> return "break;"
301− Other e -> ret `liftM` toJS' e
302− Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
303− where
304− dropEnd acc [] = acc
305− dropEnd acc (m:ms) =
306− case m of
307− Other _ -> acc ++ [m]
308− _ -> dropEnd (acc ++ [m]) ms
309−
310−clauseToJS span var (Clause name vars e) = do
311− let vars' = map (\n -> var ++ "._" ++ show n) [0..]
312− s <- matchToJS span $ matchSubst (zip vars vars') e
313− return $ concat [ "\ncase ", quoted name, ":", indent s ]
314−
315−jsNil = "_L.Nil"
316−jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
317−jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
318−jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
319−
320−binop (o:p) e1 e2
321− | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
322− | otherwise =
323− let ops = ["+","-","*","/","&&","||"] in
324− case o:p of
325− "::" -> jsCons e1 e2
326− "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
327− "<|" -> e1 ++ parens e2
328− "|>" -> e2 ++ parens e1
329− "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
330− "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
331− "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
332− "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
333− "<" -> jsCompare e1 e2 "==='LT'"
334− ">" -> jsCompare e1 e2 "==='GT'"
335− "<=" -> jsCompare e1 e2 "!=='GT'"
336− ">=" -> jsCompare e1 e2 "!=='LT'"
337− "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
338− "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
339− _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
340− | otherwise -> concat [ "$op['", o:p, "']"
341− , parens e1, parens e2 ]
compiler/Gen/ExtractNoscript.hsdeleted−59
@@ -1,59 +0,0 @@
1−module ExtractNoscript (extractNoscript) where
2−
3−import Ast
4−import Located
5−import qualified Text.Pandoc as Pan
6−
7−extractNoscript :: Module -> String
8−extractNoscript modul = concat (extract modul)
9−
10−class Extract a where
11− extract :: a -> [String]
12−
13−instance Extract Module where
14− extract (Module _ _ _ stmts) =
15− map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)
16−
17−instance Extract Statement where
18− extract (Definition d) = extract d
19− extract _ = []
20−
21−instance Extract Def where
22− extract (FnDef _ _ e) = extract e
23− extract (OpDef _ _ _ e) = extract e
24− extract _ = []
25−
26−instance Extract e => Extract (Located e) where
27− extract (L _ _ e) = extract e
28−
29−instance Extract Expr where
30− extract expr =
31− let f = extract in
32− case expr of
33− Str s -> [s]
34− Binop op e1 e2 -> case (op, f e1, f e2) of
35− ("++", [s1], [s2]) -> [s1 ++ s2]
36− (_ , ss1 , ss2 ) -> ss1 ++ ss2
37− Lambda v e -> f e
38− App (L _ _ (App (L _ _ (Var "link")) src)) txt -> linkExtract src txt
39− App (L _ _ (App (L _ _ (Var "Text.link")) src)) txt -> linkExtract src txt
40− App (L _ _ (Var "header")) e -> tag "h1" e
41− App (L _ _ (Var "bold")) e -> tag "b" e
42− App (L _ _ (Var "italic")) e -> tag "i" e
43− App (L _ _ (Var "monospace")) e -> tag "code" e
44− App e1 e2 -> f e1 ++ f e2
45− If eb et ef -> f et ++ f ef
46− Let defs e -> concatMap extract defs ++ f e
47− Var _ -> []
48− Case e cases -> concatMap (f . snd) cases
49− Data _ es -> concatMap f es
50− Markdown doc -> [ Pan.writeHtmlString Pan.def doc ]
51− _ -> []
52−
53−linkExtract src txt =
54− case (extract src, extract txt) of
55− ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]
56− ( ss1, ss2) -> ss1 ++ ss2
57−
58−
59−tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)
compiler/Generate/Cases.hsnew file+128
@@ -0,0 +1,128 @@
1+module Generate.Cases (caseToMatch, Match (..), Clause (..), matchSubst) where
2+
3+import Control.Arrow (first)
4+import Control.Monad (liftM,foldM)
5+import Data.List (groupBy,sortBy,lookup)
6+import Data.Maybe (fromMaybe)
7+
8+import Unique
9+import SourceSyntax.Location
10+import SourceSyntax.Literal
11+import SourceSyntax.Pattern
12+import SourceSyntax.Expression
13+import Transform.Substitute
14+
15+caseToMatch patterns = do
16+ v <- newVar
17+ (,) v `liftM` match [v] (map (first (:[])) patterns) Fail
18+
19+newVar = do n <- guid
20+ return $ "case" ++ show n
21+
22+data Match t v
23+ = Match String [Clause t v] (Match t v)
24+ | Break
25+ | Fail
26+ | Other (LExpr t v)
27+ | Seq [Match t v]
28+ deriving Show
29+
30+data Clause t v =
31+ Clause (Either String Literal) [String] (Match t v)
32+ deriving Show
33+
34+matchSubst :: [(String,String)] -> Match t v -> Match t v
35+matchSubst _ Break = Break
36+matchSubst _ Fail = Fail
37+matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
38+matchSubst pairs (Other (L s e)) =
39+ Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
40+matchSubst pairs (Match n cs m) =
41+ Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
42+ where varSubst v = fromMaybe v (lookup v pairs)
43+ clauseSubst (Clause c vs m) =
44+ Clause c (map varSubst vs) (matchSubst pairs m)
45+
46+isCon (p:ps, e) =
47+ case p of
48+ PData _ _ -> True
49+ PLiteral _ -> True
50+ _ -> False
51+
52+isVar p = not (isCon p)
53+
54+match :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Match t v)
55+match [] [] def = return def
56+match [] [([],e)] Fail = return $ Other e
57+match [] [([],e)] Break = return $ Other e
58+match [] cs def = return $ Seq (map (Other . snd) cs ++ [def])
59+match vs@(v:_) cs def
60+ | all isVar cs' = matchVar vs cs' def
61+ | all isCon cs' = matchCon vs cs' def
62+ | otherwise = matchMix vs cs' def
63+ where
64+ cs' = map (dealias v) cs
65+
66+dealias v c@(p:ps, L s e) =
67+ case p of
68+ PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)
69+ _ -> c
70+
71+matchVar :: [String] -> [([Pattern],LExpr t v)] -> Match t v
72+ -> Unique (Match t v)
73+matchVar (v:vs) cs def = match vs (map subVar cs) def
74+ where
75+ subVar (p:ps, ce@(L s e)) = (ps, L s $ subOnePattern p e)
76+ where
77+ subOnePattern pattern e =
78+ case pattern of
79+ PVar x -> subst x (Var v) e
80+ PAnything -> e
81+ PRecord fs ->
82+ foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
83+
84+matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v
85+ -> Unique (Match t v)
86+matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css
87+ where
88+ css = groupBy eq (sortBy cmp cs)
89+
90+ cmp (p1:_,_) (p2:_,_) =
91+ case (p1,p2) of
92+ (PData n1 _, PData n2 _) -> compare n1 n2
93+ _ -> compare p1 p2
94+
95+ eq (p1:_,_) (p2:_,_) =
96+ case (p1,p2) of
97+ (PData n1 _, PData n2 _) -> n1 == n2
98+ _ -> p1 == p2
99+
100+ toClause cs =
101+ case head cs of
102+ (PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
103+ (PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
104+
105+matchClause :: Either String Literal
106+ -> [String]
107+ -> [([Pattern],LExpr t v)]
108+ -> Match t v
109+ -> Unique (Clause t v)
110+matchClause c (v:vs) cs def =
111+ do vs' <- getVars
112+ Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def
113+ where
114+
115+ flatten (p:ps, e) =
116+ case p of
117+ PData _ ps' -> (ps' ++ ps, e)
118+ PLiteral _ -> (ps, e)
119+
120+ getVars =
121+ case head cs of
122+ (PData _ ps : _, _) -> mapM (\_ -> newVar) ps
123+ (PLiteral _ : _, _) -> return []
124+
125+matchMix :: [String] -> [([Pattern],LExpr t v)] -> Match t v
126+ -> Unique (Match t v)
127+matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
128+ where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
compiler/Gen/GenerateHtml.hs → compiler/Generate/Html.hsrenamed+10−13
@@ -1,13 +1,12 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2+module Generate.Html
2−module GenerateHtml (generateHtml,
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
@@ -15,11 +14,9 @@ import qualified Text.Blaze.Html5.Attributes as A
15import Text.Jasmine (minify)
14import Text.Jasmine (minify)
16import qualified Data.ByteString.Lazy.Char8 as BS
15import qualified Data.ByteString.Lazy.Char8 as BS
17
16
18−import Ast
19import Initialize (buildFromSource)
17import Initialize (buildFromSource)
20−import CompileToJS
18+import Generate.JavaScript
21−import ExtractNoscript
19+import Generate.Noscript
22−import Libraries as Libraries
23
20
24data JSStyle = Minified | Readable
21data JSStyle = Minified | Readable
25data JSSource = Link String | Source JSStyle String
22data JSSource = Link String | Source JSStyle String
@@ -42,7 +39,7 @@ makeScript source =
42generateHtml :: String -- ^ Location of elm-runtime.js as expected by the browser
39generateHtml :: String -- ^ Location of elm-runtime.js as expected by the browser
43 -> String -- ^ The page title
40 -> String -- ^ The page title
44 -> String -- ^ The elm source code.
41 -> String -- ^ The elm source code.
45− -> Html
42+ -> H.Html
46generateHtml libLoc title source = H.span "broken for now"
43generateHtml libLoc title source = H.span "broken for now"
47{--
44{--
48 case buildFromSource True source of
45 case buildFromSource True source of
@@ -62,7 +59,7 @@ modulesToHtml libLoc title scripts nscrpt modules =
62 where Module names _ _ _ = last modules
59 where Module names _ _ _ = last modules
63--}
60--}
64
61
65−createHtml :: FilePath -> String -> [JSSource] -> String -> Html
62+createHtml :: FilePath -> String -> [JSSource] -> String -> H.Html
66createHtml libLoc title scripts noscript =
63createHtml libLoc title scripts noscript =
67 H.docTypeHtml $ do
64 H.docTypeHtml $ do
68 H.head $ do
65 H.head $ do
compiler/Generate/JavaScript.hsnew file+368
@@ -0,0 +1,368 @@
1+module Generate.JavaScript (showErr, jsModule) where
2+
3+import Control.Arrow (first,second)
4+import Control.Monad (liftM,(<=<),join,ap)
5+import Data.Char (isAlpha,isDigit)
6+import qualified Data.List as List
7+import qualified Data.Map as Map
8+import qualified Data.Set as Set
9+import Data.Either (partitionEithers)
10+import qualified Text.Pandoc as Pan
11+
12+import Unique
13+import Generate.Cases
14+import SourceSyntax.Everything
15+import SourceSyntax.Location
16+import qualified Transform.SortDefinitions as SD
17+
18+deprime :: String -> String
19+deprime = map (\c -> if c == '\'' then '$' else c)
20+
21+showErr :: String -> String
22+showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
23+ where msg = show . concatMap (++"<br>") . lines $ err
24+ body = "var T = Elm.Text(elm);\n\
25+ \return { main : T.text(T.monospace(" ++ msg ++ ")) };"
26+
27+indent = concatMap f
28+ where f '\n' = "\n "
29+ f c = [c]
30+
31+internalImports name =
32+ [ ("N" , "Elm.Native"),
33+ ("_N", "N.Utils(elm)"),
34+ ("_L", "N.List(elm)"),
35+ ("_E", "N.Error(elm)"),
36+ ("_J", "N.JavaScript(elm)"),
37+ ("_str", "_J.toString"),
38+ ("$moduleName", quoted name)
39+ ]
40+
41+parens s = "(" ++ s ++ ")"
42+brackets s = "{" ++ s ++ "}"
43+commaSep = List.intercalate ", "
44+dotSep = List.intercalate "."
45+jsObj = brackets . commaSep
46+jsList ss = "["++ List.intercalate "," ss ++"]"
47+jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
48+assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
49+ret e = "\nreturn "++ e ++";"
50+quoted s = "'" ++ concatMap f s ++ "'"
51+ where f '\n' = "\\n"
52+ f '\'' = "\\'"
53+ f '\t' = "\\t"
54+ f '\"' = "\\\""
55+ f '\\' = "\\\\"
56+ f c = [c]
57+
58+globalAssign n e = "\n" ++ assign' n e ++ ";"
59+assign' n e = n ++ " = " ++ e
60+
61+jsModule :: MetadataModule t v -> String
62+jsModule modul =
63+ run $ do
64+ body <- toJS . fst . SD.flattenLets [] $ program modul
65+ foreignImport <- mapM importEvent (foreignImports modul)
66+ return $ concat [ setup ("Elm": names modul)
67+ , globalAssign ("Elm." ++ modName)
68+ (jsFunc "elm" $ makeProgram body foreignImport) ]
69+ where
70+ modName = dotSep (names modul)
71+ makeProgram body foreignImport =
72+ concat [ "\nvar " ++ usefulFuncs ++ ";"
73+ , concatMap jsImport (imports modul)
74+ , concat foreignImport
75+ , assign "_op" "{}"
76+ , body
77+ , concatMap exportEvent $ foreignExports modul
78+ , jsExports
79+ ]
80+ setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
81+ map dotSep . drop 2 . List.inits $ init names
82+ usefulFuncs = commaSep (map (uncurry assign') (internalImports modName))
83+
84+ jsExports = setup ("elm" : names modul) ++
85+ ret (assign' ("elm." ++ modName) (brackets exs))
86+ where
87+ exs = indent . commaSep . concatMap (pair . deprime) $ "_op" : exports modul
88+ pair x | isOp x = []
89+ | otherwise = ["\n" ++ x ++ " : " ++ x]
90+
91+
92+ importEvent (js,base,elm,_) =
93+ do v <- toJS' base
94+ return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"
95+ , "\ndocument.addEventListener('", js
96+ , "_' + elm.id, function(e) { elm.notify(", elm
97+ , ".id, e.value); });" ]
98+
99+ exportEvent (js,elm,_) =
100+ concat [ "\nA2( Signal.lift, function(v) { "
101+ , "var e = document.createEvent('Event');"
102+ , "e.initEvent('", js, "_' + elm.id, true, true);"
103+ , "e.value = v;"
104+ , "document.dispatchEvent(e); return v; }, ", elm, ");" ]
105+
106+jsImport (modul, method) =
107+ concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
108+ where
109+ starters = "\nvar " : repeat "\n"
110+ values = map (\name -> name ++ " || {}") (init subnames) ++
111+ ["Elm." ++ modul ++ parens "elm"]
112+ subnames = map dotSep . tail . List.inits $ split modul
113+
114+ split names = case go [] names of
115+ (name, []) -> [name]
116+ (name, ns) -> name : split ns
117+ go name str = case str of
118+ '.':rest -> (reverse name, rest)
119+ c:rest -> go (c:name) rest
120+ [] -> (reverse name, [])
121+
122+
123+class ToJS a where
124+ toJS :: a -> Unique String
125+
126+
127+instance ToJS (Def t v) where
128+
129+ -- TODO: Make this handle patterns besides plain variables
130+ toJS (Def (PVar x) e)
131+ | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
132+ | otherwise = assign (deprime x) `liftM` toJS' e
133+
134+ toJS (Def pattern e@(L s _)) =
135+ do n <- guid
136+ let x = "_" ++ show n
137+ var = L s . Var
138+ toDef y' = let y = deprime y' in
139+ Def (PVar y) (L s $ Case (var x) [(pattern, var y)])
140+ stmt <- assign x `liftM` toJS' e
141+ vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
142+ return (stmt ++ vars)
143+
144+ toJS (TypeAnnotation _ _) = return ""
145+
146+
147+instance ToJS a => ToJS [a] where
148+ toJS xs = concat `liftM` mapM toJS xs
149+
150+toJS' :: LExpr t v -> Unique String
151+toJS' (L span expr) =
152+ case expr of
153+ MultiIf ps -> multiIfToJS span ps
154+ Case e cases -> caseToJS span e cases
155+ _ -> toJS expr
156+
157+remove x e = "_N.remove('" ++ deprime x ++ "', " ++ e ++ ")"
158+addField x v e = "_N.insert('" ++ deprime x ++ "', " ++ v ++ ", " ++ e ++ ")"
159+setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
160+ where f (x,v) = "['" ++ deprime x ++ "'," ++ v ++ "]"
161+access x e = e ++ "." ++ deprime x
162+makeRecord kvs = record `liftM` collect kvs
163+ where
164+ combine r (k,v) = Map.insertWith (++) k v r
165+ collect = liftM (List.foldl' combine Map.empty) . mapM prep
166+ prep (k, e) =
167+ do v <- toJS' e
168+ return (deprime k, [v])
169+ fields fs =
170+ brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
171+ hidden = fields . map (second jsList) .
172+ filter (not . null . snd) . Map.toList . Map.map tail
173+ record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
174+
175+
176+instance ToJS Literal where
177+ toJS lit =
178+ case lit of
179+ Chr c -> return $ quoted [c]
180+ Str s -> return $ "_str" ++ parens (quoted s)
181+ IntNum n -> return $ show n
182+ FloatNum n -> return $ show n
183+ Boolean b -> return $ if b then "true" else "false"
184+
185+
186+instance ToJS (Expr t v) where
187+ toJS expr =
188+ case expr of
189+ Var x -> return (deprime x)
190+ Literal lit -> toJS lit
191+ Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
192+ Access e x -> access x `liftM` toJS' e
193+ Remove e x -> remove x `liftM` toJS' e
194+ Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
195+ Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
196+ setField fs' `liftM` toJS' e
197+ Record fs -> makeRecord fs
198+ Binop op e1 e2 -> binop op e1 e2
199+
200+ Lambda p e@(L s _) -> liftM (fastFunc . ret) (toJS' body)
201+ where
202+ fastFunc body
203+ | length args < 2 || length args > 9 = foldr jsFunc body args
204+ | otherwise = "F" ++ show (length args) ++ parens (jsFunc (commaSep args) body)
205+ (args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])
206+
207+ depattern (pattern,n) (args, body) =
208+ case pattern of
209+ PVar x -> (deprime x : args, body)
210+ _ -> let arg = "arg" ++ show n
211+ in (arg:args, L s (Case (L s (Var arg)) [(pattern, body)]))
212+
213+ (patterns, innerBody) = collect [p] e
214+
215+ collect patterns lexpr@(L _ expr) =
216+ case expr of
217+ Lambda p e -> collect (p:patterns) e
218+ _ -> (patterns, lexpr)
219+
220+ App e1 e2 -> jsApp e1 e2
221+ Let defs e -> jsLet $ SD.flattenLets defs e
222+
223+ ExplicitList es ->
224+ do es' <- mapM toJS' es
225+ return $ "_J.toList" ++ parens (jsList es')
226+
227+ Data name es ->
228+ do fs <- mapM toJS' es
229+ return $ case name of
230+ "[]" -> jsNil
231+ "::" -> jsCons (head fs) ((head . tail) fs)
232+ _ -> jsObj $ ("ctor:" ++ show name) : fields
233+ where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
234+
235+ Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"
236+ where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
237+ md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
238+
239+jsApp e1 e2 =
240+ do f <- toJS' func
241+ as <- mapM toJS' args
242+ return $ case as of
243+ [a] -> f ++ parens a
244+ _ -> "A" ++ show (length as) ++ parens (commaSep (f:as))
245+ where
246+ (func, args) = go [e2] e1
247+ go args e =
248+ case e of
249+ (L _ (App e1 e2)) -> go (e2 : args) e1
250+ _ -> (e, args)
251+
252+formatMarkdown = concatMap f
253+ where f '\'' = "\\'"
254+ f '\n' = "\\n"
255+ f '"' = "\""
256+ f c = [c]
257+
258+multiIfToJS span ps =
259+ case last ps of
260+ (L _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
261+ _ -> format ("_E.If" ++ parens ("$moduleName," ++ quoted (show span))) ps
262+ where
263+ format base ps =
264+ foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
265+ f (b,e) = do b' <- toJS' b
266+ e' <- toJS' e
267+ return (b' ++ " ? " ++ e')
268+
269+jsLet (defs,e') = do ds <- mapM toJS defs
270+ e <- toJS' e'
271+ return $ jsFunc "" (concat ds ++ ret e) ++ "()"
272+
273+caseToJS span e ps = do
274+ (tempVar,match) <- caseToMatch ps
275+ e' <- toJS' e
276+ let (match',stmt) = case e of
277+ L _ (Var x) -> (matchSubst [(tempVar,deprime x)] match, "")
278+ _ -> (match, assign tempVar e')
279+ matches <- matchToJS span match'
280+ return $ jsFunc "" (stmt ++ matches) ++ "()"
281+
282+matchToJS span match =
283+ case match of
284+ Match name clauses def ->
285+ do cases <- concat `liftM` mapM (clauseToJS span name) clauses
286+ finally <- matchToJS span def
287+ let isLiteral p = case p of
288+ Clause (Right _) _ _ -> True
289+ _ -> False
290+ access = if any isLiteral clauses then "" else ".ctor"
291+ return $ concat [ "\nswitch (", name, access, ") {"
292+ , indent cases, "\n}", finally ]
293+ Fail -> return ("_E.Case" ++ parens ("$moduleName," ++ quoted (show span)))
294+ Break -> return "break;"
295+ Other e -> ret `liftM` toJS' e
296+ Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
297+ where
298+ dropEnd acc [] = acc
299+ dropEnd acc (m:ms) =
300+ case m of
301+ Other _ -> acc ++ [m]
302+ _ -> dropEnd (acc ++ [m]) ms
303+
304+clauseToJS span var (Clause value vars e) = do
305+ let vars' = map (\n -> var ++ "._" ++ show n) [0..]
306+ s <- matchToJS span $ matchSubst (zip vars vars') e
307+ return $ concat [ "\ncase ", case value of
308+ Right (Boolean True) -> "true"
309+ Right (Boolean False) -> "false"
310+ Right lit -> show lit
311+ Left name -> quoted $ case List.elemIndices '.' name of
312+ [] -> name
313+ is -> drop (last is + 1) name
314+ , ":", indent s ]
315+
316+jsNil = "_L.Nil"
317+jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
318+jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
319+jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
320+
321+
322+binop op e1 e2
323+ | op == "Basics.." =
324+ do ss <- mapM toJS' (e1 : collect [] e2)
325+ return . jsFunc "$" . ret $ apply "$" ss
326+ | op == "Basics.<|" =
327+ do arg <- toJS' e2
328+ funcs <- mapM toJS' (collect [] e1)
329+ return (apply arg funcs)
330+ | otherwise =
331+ binopNormal op `liftM` toJS' e1 `ap` toJS' e2
332+ where
333+ apply = foldr (\f arg-> f ++ parens arg)
334+
335+ collect es e =
336+ case e of
337+ L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
338+ _ -> es ++ [e]
339+
340+binopNormal op s1 s2 =
341+ case Map.lookup op opDict of
342+ Just e -> e
343+ Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, s1, s2 ])
344+ where
345+ func | isOp op' = "_op['" ++ op' ++ "']"
346+ | otherwise = op'
347+ (prefix, op') = case List.elemIndices '.' op of
348+ [] -> ("", op)
349+ xs -> splitAt (last xs + 1) op
350+
351+ opDict = Map.fromList $ basics ++
352+ [ ("::", jsCons s1 s2)
353+ , ("List.++", "_L.append" ++ parens (s1 ++ "," ++ s2)) ]
354+
355+ ops = pow : map (\op -> (op, parens (s1 ++ op ++ s2))) ["+","-","*","/","&&","||"]
356+ where pow = ("^" , "Math.pow(" ++ s1 ++ "," ++ s2 ++ ")")
357+
358+ basics = ops ++ map (\(op,e) -> ("Basics." ++ op, e))
359+ (ops ++ [ ("<|", s1 ++ parens s2)
360+ , ("|>", s2 ++ parens s1)
361+ , ("==", "_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
362+ , ("/=", "!_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
363+ , ("<" , jsCompare s1 s2 "<0")
364+ , (">" , jsCompare s1 s2 ">0")
365+ , ("<=", jsCompare s1 s2 "<1")
366+ , (">=", jsCompare s1 s2 ">-1")
367+ , ("div", parens (s1 ++ "/" ++ s2 ++ "|0"))
368+ ])
compiler/Generate/Noscript.hsnew file+65
@@ -0,0 +1,65 @@
1+module Generate.Noscript (noscript) where
2+
3+import Data.List (isInfixOf)
4+import SourceSyntax.Everything
5+import qualified Text.Pandoc as Pan
6+
7+noscript :: Module t v -> String
8+noscript modul = concat (extract modul)
9+
10+class Extract a where
11+ extract :: a -> [String]
12+
13+instance Extract (Module t v) where
14+ extract (Module _ _ _ stmts) =
15+ map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)
16+
17+instance Extract (Declaration t v) where
18+ extract (Definition d) = extract d
19+ extract _ = []
20+
21+instance Extract (Def t v) where
22+ extract (Def _ e) = extract e
23+ extract _ = []
24+
25+instance Extract e => Extract (Located e) where
26+ extract (L _ e) = extract e
27+
28+instance Extract (Expr t v) where
29+ extract expr =
30+ let f = extract in
31+ case expr of
32+ Literal (Str s) -> [s]
33+ Binop op e1 e2 -> case (op, f e1, f e2) of
34+ ("++", [s1], [s2]) -> [s1 ++ s2]
35+ (_ , ss1 , ss2 ) -> ss1 ++ ss2
36+ Lambda v e -> f e
37+ App (L _ (App (L _ (App (L _ (Var func)) w)) h)) src
38+ | "image" `isInfixOf` func -> extractImage src
39+ App (L _ (App (L _ (Var func)) src)) txt
40+ | "link" `isInfixOf` func -> extractLink src txt
41+ App (L _ (Var func)) e
42+ | "header" `isInfixOf` func -> tag "h1" e
43+ | "bold" `isInfixOf` func -> tag "b" e
44+ | "italic" `isInfixOf` func -> tag "i" e
45+ | "monospace" `isInfixOf` func -> tag "code" e
46+ App e1 e2 -> f e1 ++ f e2
47+ Let defs e -> concatMap extract defs ++ f e
48+ Var _ -> []
49+ Case e cases -> concatMap (f . snd) cases
50+ Data _ es -> concatMap f es
51+ MultiIf es -> concatMap (f . snd) es
52+ Markdown doc -> [ Pan.writeHtmlString Pan.def doc ]
53+ _ -> []
54+
55+extractLink src txt =
56+ case (extract src, extract txt) of
57+ ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]
58+ ( ss1, ss2) -> ss1 ++ ss2
59+
60+extractImage src =
61+ case extract src of
62+ [s] -> ["<img src=\"" ++ s ++ "\">"]
63+ ss -> ss
64+
65+tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)
compiler/Initialize.hs+87−64
@@ -1,80 +1,103 @@
1−module Initialize (buildFromSource, getSortedModuleNames) where
1+module Initialize (buildFromSource, getSortedDependencies) where
2
2
3−import Control.Applicative ((<$>))
3+import Data.Data
4−import Control.Monad.Error
4+import Control.Monad.State
5+import qualified Data.Graph as Graph
5−import Data.List (lookup,nub)
6+import qualified Data.List as List
6import qualified Data.Map as Map
7import qualified Data.Map as Map
7−
8−import Ast
9−import Data.Either (lefts,rights)
10−import Data.List (intercalate,partition)
11−import Parse.Parser (parseProgram, parseDependencies)
12−import Rename
13−import qualified Libraries as Libs
8+import qualified Data.Set as Set
14−import Types.Types ((-:))
15−import Types.Hints (hints)
16−import Types.Unify (unify)
17−import Types.Alias (dealias, mistakes)
18−import Optimize
19import System.Exit
9import System.Exit
20−import System.FilePath
10+import System.FilePath as FP
11+import Text.PrettyPrint (Doc)
12+
13+import SourceSyntax.Everything
14+import SourceSyntax.Type
15+import qualified Parse.Parse as Parse
16+import qualified Metadata.Prelude as Prelude
17+import qualified Transform.Check as Check
18+import qualified Transform.SortDefinitions as SD
19+import qualified Type.Inference as TI
20+import qualified Type.Constrain.Declaration as TcDecl
21+import qualified Transform.Canonicalize as Canonical
22+
23+buildFromSource :: Bool -> Interfaces -> String -> Either [Doc] (MetadataModule () ())
24+buildFromSource noPrelude interfaces source =
25+ do let add = if noPrelude then id else Prelude.add
26+ modul@(Module _ _ _ decls') <- add `fmap` Parse.program source
27+
28+ -- check for structural errors
29+ Module names exs ims decls <-
30+ case Check.mistakes decls' of
31+ [] -> return modul
32+ ms -> Left ms
21
33
22−checkMistakes :: Module -> Either String Module
34+ let exports'
23−checkMistakes modul@(Module name ex im stmts) =
35+ | null exs =
24− case mistakes stmts of
36+ let get = Set.toList . SD.boundVars in
25− m:ms -> Left (unlines (m:ms))
37+ concat [ get pattern | Definition (Def pattern _) <- decls ] ++
26− [] -> return modul
38+ concat [ map fst ctors | Datatype _ _ ctors <- decls ]
39+ | otherwise = exs
27
40
28−checkTypes :: Module -> Either String Module
41+ metaModule <- Canonical.metadataModule interfaces $ MetadataModule {
29−checkTypes modul =
42+ names = names,
30− do subs <- unify hints modul
43+ path = FP.joinPath names,
31− subs `seq` return (optimize (renameModule modul))
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+ }
32
55
33−check :: Module -> Either String Module
56+ types <- TI.infer interfaces metaModule
34−check = checkMistakes >=> checkTypes
35
57
36−buildFromSource :: Bool -> String -> Either String Module
58+ return $ metaModule { types = types }
37−buildFromSource noPrelude src =
38− let add = if noPrelude then id else Libs.addPrelude in
39− (check . add) =<< (parseProgram src)
40
59
41−getSortedModuleNames :: FilePath -> IO [String]
42−getSortedModuleNames root =
43− sortDeps =<< readDeps [] root
44
60
61+getSortedDependencies :: Bool -> FilePath -> IO [String]
62+getSortedDependencies noPrelude root =
63+ sortDeps =<< readDeps noPrelude root
64+
45−type Deps = (String, [String])
65+type Deps = (FilePath, String, [String])
46
66
47sortDeps :: [Deps] -> IO [String]
67sortDeps :: [Deps] -> IO [String]
48−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
49− where
72+ where
73+ sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends
74+
75+ mistakes = filter (\scc -> length scc > 1) sccs
50− msg = "A cyclical or missing module dependency or was detected in: "
76+ msg = "A cyclical module dependency or was detected in: "
51−
77+
52− go :: [String] -> [Deps] -> IO [String]
78+readDeps :: Bool -> FilePath -> IO [Deps]
53− go sorted [] = return (map toFilePath sorted)
79+readDeps noPrelude root = evalStateT (go root) Set.empty
54− go sorted unsorted =
80+ where
55− case partition (all (`elem` sorted) . snd) unsorted of
81+ builtIns = if noPrelude then Set.empty
56− ([],m:ms) -> do putStrLn (msg ++ intercalate ", " (map fst (m:ms)) ++ show sorted ++ show unsorted)
82+ else Set.fromList (Map.keys Prelude.interfaces)
57− exitFailure
83+
58− (srtd,unsrtd) -> go (sorted ++ map fst srtd) unsrtd
59−
60−readDeps :: [FilePath] -> FilePath -> IO [Deps]
84+ go :: FilePath -> StateT (Set.Set String) IO [Deps]
61−readDeps seen root = do
85+ go root = do
62− txt <- readFile root
86+ txt <- liftIO $ readFile root
63− case parseDependencies txt of
87+ case Parse.dependencies txt of
64− Left err ->
88+ Left err -> liftIO (putStrLn msg >> print err >> exitFailure)
65− let msg = "Error resolving dependencies in " ++ root ++ ":\n" in
89+ where msg = "Error resolving dependencies in " ++ root ++ ":"
66− putStrLn (msg ++ err) >> exitFailure
90+
67− Right (name,deps) ->
91+ Right (name,deps) ->
68− do rest <- mapM (readDeps seen' . toFilePath) newDeps
92+ do seen <- get
69− return ((name, realDeps) : concat rest)
93+ let realDeps = Set.difference (Set.fromList deps) builtIns
70− where
71− realDeps = filter (`notElem` builtIns) deps
72− newDeps = filter (\d -> d `notElem` seen && not (isNative d)) realDeps
94+ newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
73− seen' = root : seen ++ newDeps
95+ put (Set.insert name (Set.union newDeps seen))
74− builtIns = Map.keys Libs.libraries
96+ rest <- mapM (go . toFilePath) (Set.toList newDeps)
97+ return ((makeRelative "." root, name, Set.toList realDeps) : concat rest)
75
98
76
99
77−isNative name = takeWhile (/='.') name == "Native"
100+isNative name = List.isPrefixOf "Native." name
78
101
79toFilePath :: String -> FilePath
102toFilePath :: String -> FilePath
80toFilePath name = map swapDots name ++ ext
103toFilePath name = map swapDots name ++ ext
compiler/Language/Elm.hs+22−21
@@ -1,10 +1,6 @@
1{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
1{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
2{- | This module exports the functions necessary for compiling Elm code into the
2{- | This module exports the functions necessary for compiling Elm code into the
3− respective HTML, JS and CSS code.
3+ respective HTML, CSS, and JS code.
4−
5− The type class @'ElmSource'@ requires an instance for all types that the Elm
6− compiler understands. The provided instances for String, Text and QuasiQuoted
7− Elm source code should be sufficient.
8
4
9 The documentation for the Elm language is available at
5 The documentation for the Elm language is available at
10 <http://elm-lang.org/Documentation.elm>, and many interactive examples are
6 <http://elm-lang.org/Documentation.elm>, and many interactive examples are
@@ -15,33 +11,39 @@
15-}
11-}
16module Language.Elm (compile, toHtml, moduleName, runtime, docs) where
12module Language.Elm (compile, toHtml, moduleName, runtime, docs) where
17
13
18−import Data.List (intercalate)
14+import qualified Data.List as List
15+import qualified Data.Map as Map
19import Data.Version (showVersion)
16import Data.Version (showVersion)
20−import CompileToJS (showErr, jsModule)
17+import Generate.JavaScript (showErr, jsModule)
21−import GenerateHtml (generateHtml)
18+import Generate.Html (generateHtml)
22import Initialize (buildFromSource)
19import Initialize (buildFromSource)
23−import Parse.Library
20+import Parse.Helpers
24−import Parse.Modules (moduleDef)
21+import Parse.Module (moduleDef)
22+import SourceSyntax.Module
25import Text.Blaze.Html (Html)
23import Text.Blaze.Html (Html)
26import Text.Parsec (option,optional)
24import Text.Parsec (option,optional)
25+import qualified Text.PrettyPrint as P
26+import qualified Metadata.Prelude as Prelude
27import Paths_Elm
27import Paths_Elm
28
28
29−-- |This function compiles Elm code to JavaScript.
29+-- |This function compiles Elm code to JavaScript. It will return either
30−compile :: String -> String
30+-- an error message or the compiled JS code.
31−compile source = either showErr jsModule modul
31+compile :: String -> Either String String
32− where
32+compile source =
33− modul = buildFromSource True 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 () ())
34
36
35-- |This function extracts the module name of a given source program.
37-- |This function extracts the module name of a given source program.
36−moduleName :: String -> String
38+moduleName :: String -> Maybe String
37moduleName source = case iParse getModuleName "" source of
39moduleName source = case iParse getModuleName "" source of
38− Right name -> name
40+ Right name -> Just name
39− Left _ -> "Main"
41+ Left _ -> Nothing
40 where
42 where
41 getModuleName = do
43 getModuleName = do
42 optional freshLine
44 optional freshLine
43− (names, _) <- option (["Main"],[]) moduleDef
45+ (names, _) <- moduleDef
44− return (intercalate "." names)
46+ return (List.intercalate "." names)
45
47
46-- |This function compiles Elm code into a full HTML page.
48-- |This function compiles Elm code into a full HTML page.
47toHtml :: String -- ^ Location of elm-min.js as expected by the browser
49toHtml :: String -- ^ Location of elm-min.js as expected by the browser
@@ -57,4 +59,3 @@ runtime = getDataFileName "elm-runtime.js"
57-- |The absolute path to Elm's core library documentation.
59-- |The absolute path to Elm's core library documentation.
58docs :: IO FilePath
60docs :: IO FilePath
59docs = getDataFileName "docs.json"
61docs = getDataFileName "docs.json"
60−
compiler/Language/Elm/DevTools.hsnew file+46
@@ -0,0 +1,46 @@
1+{- | This module aims to make it easier to create dev tools for Elm.
2+
3+ It provides the ability to:
4+
5+ * Detect problems in a program
6+ * Figure out types of particular expressions
7+ * Canonicalize variables
8+ * Convert expressions to JS and HTML
9+
10+ This module gives limeted access to the structure of an Elm Program.
11+ Giving full access would expose many internal details that are likely to
12+ change as Elm progresses. These details have been hidden to avoid breaking
13+ changes.
14+-}
15+module Language.Elm.DevTools where
16+
17+data Program
18+
19+-- | Parse an Elm program into an AST.
20+parse :: String -> Either [Problem] Program
21+
22+-- | Get the type of a region of the program. Lets you look
23+-- up the type of particular values and expressions.
24+typeOf :: Program -> Region -> Either [Problem] String
25+
26+-- | Canonicalize a variable. So in a normal module `map` would be canonicalized
27+-- to `List.map`.
28+canonicalize :: Program -> Region -> [String]
29+
30+-- | Any problem that may come up while parsing or typing a program.
31+-- All problems come with a region that is causing the problem.
32+data Problem = Problem { message :: String, region :: Region }
33+
34+type Row = Int
35+type Column = Int
36+
37+-- | Represents a region, spanning two points in the source code.
38+data Region = Region { start :: (Row,Column), end :: (Row,Column) }
39+
40+-- | Takes a specific point in the source code, such as the cursor position.
41+-- It then determines the region that best represents that point. When the
42+-- cursor is within a variable, it chooses the variable. When the cursor is
43+-- on parentheses, it selects the region within the parentheses. When the
44+-- cursor is on keywords like let, it chooses the whole let-expression.
45+region :: (Row,Column) -> Region
46+region pos = Region pos pos
compiler/Language/Elm/Quasi.hsdeleted−96
@@ -1,96 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE CPP #-}
5−{-# OPTIONS_GHC -fno-warn-missing-fields #-}
6−
7−-- | This module contains Shakespearean (see "Text.Shakespeare") templates
8−-- for Elm. It introduces type-safe compile-time variable and URL
9−-- interpolation. A typeclass @'ToElm'@ is provided for interpolated
10−-- variables.
11−--
12−-- Further reading on Shakespearean templates:
13−-- <http://www.yesodweb.com/book/templates>
14−--
15−-- Further reading on Elm: <http://elm-lang.org>
16−module Language.Elm.Quasi
17− ( -- * Functions
18− -- ** Template-Reading Functions
19− -- |These QuasiQuoters return functions of the type @(t -> 'Elm')@
20− -- where @t@ is the URL rendering function if type-safe URLs are used.
21− --
22− -- A usage example for both type-safe (Yesod) and standard path segment
23− -- (Happstack) URLs is provided in the Examples folder in the Git
24− -- repository.
25− elm
26− , elmFile
27− , elmFileReload
28−
29− -- * Datatypes
30− , Elm (..)
31−
32− -- * Typeclass for interpolated variables
33− , ToElm (..)
34−
35− -- ** Rendering Functions
36− , renderElm
37−
38− ) where
39−
40−import Language.Haskell.TH.Quote (QuasiQuoter (..))
41−import Language.Haskell.TH.Syntax
42−import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText)
43−import Data.Monoid
44−import qualified Data.Text as TS
45−import qualified Data.Text.Lazy as TL
46−import Text.Shakespeare
47−
48−-- | Render Elm to lazy Text.
49−renderElm :: Elm -> TL.Text
50−renderElm (Elm b) = toLazyText b
51−
52−-- | Newtype wrapper of 'Builder'.
53−newtype Elm = Elm { unElm :: Builder }
54− deriving Monoid
55−
56−-- | A typeclass for types that can be interpolated in Elm templates.
57−class ToElm a where
58− toElm :: a -> Builder
59−instance ToElm [Char] where toElm = fromLazyText . TL.pack
60−instance ToElm TS.Text where toElm = fromText
61−instance ToElm TL.Text where toElm = fromLazyText
62−
63−elmSettings :: Q ShakespeareSettings
64−elmSettings = do
65− toJExp <- [|toElm|]
66− wrapExp <- [|Elm|]
67− unWrapExp <- [|unElm|]
68− return $ defaultShakespeareSettings { toBuilder = toJExp
69− , wrap = wrapExp
70− , unwrap = unWrapExp
71− }
72−
73−-- |QuasiQuoter for embedding Elm code inside of Haskell code.
74−--
75−-- Usage:
76−-- @[elm|main = plaintext \"Some elm code\"|]@
77−elm :: QuasiQuoter
78−elm = QuasiQuoter { quoteExp = \s -> do
79− rs <- elmSettings
80− quoteExp (shakespeare rs) s
81− }
82−
83−-- |A Template Haskell function for embedding Elm code from external
84−-- .elm files.
85−--
86−-- Usage:
87−-- @$(elmFile \"elm_source/index.elm\")@
88−elmFile :: FilePath -> Q Exp
89−elmFile fp = do
90− rs <- elmSettings
91− shakespeareFile rs fp
92−
93−elmFileReload :: FilePath -> Q Exp
94−elmFileReload fp = do
95− rs <- elmSettings
96− shakespeareFileReload rs fp
compiler/Metadata/Prelude.hsnew file+51
@@ -0,0 +1,51 @@
1+module Metadata.Prelude (interfaces, add) where
2+
3+import qualified Data.Map as Map
4+import qualified Control.Exception as E
5+import qualified Paths_Elm as Path
6+import System.Directory
7+import System.Exit
8+import System.FilePath
9+import System.IO.Unsafe (unsafePerformIO)
10+import SourceSyntax.Module
11+import qualified Data.Binary as Binary
12+
13+
14+add :: Module t v -> Module t v
15+add (Module name exs ims stmts) = Module name exs (customIms ++ ims) stmts
16+ where
17+ customIms = concatMap addModule prelude
18+
19+ addModule (n, method) = case lookup n ims of
20+ Nothing -> [(n, method)]
21+ Just (As m) -> [(n, method)]
22+ Just _ -> []
23+
24+prelude :: [(String, ImportMethod)]
25+prelude = text ++ map (\n -> (n, Hiding [])) modules
26+ where
27+ text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]
28+ modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"
29+ , "Graphics.Element", "Color", "Graphics.Collage" ]
30+
31+{-# NOINLINE interfaces #-}
32+interfaces :: Interfaces
33+interfaces =
34+ unsafePerformIO (safeReadDocs =<< Path.getDataFileName "interfaces.data")
35+
36+safeReadDocs :: FilePath -> IO Interfaces
37+safeReadDocs name =
38+ E.catch (readDocs name) $ \err -> do
39+ let _ = err :: IOError
40+ putStrLn $ unlines [ "Error reading types for standard library!"
41+ , " The file should be at " ++ name
42+ , " If you are using a stable version of Elm,"
43+ , " please report an issue at github.com/evancz/Elm"
44+ , " and specify your versions of Elm and your OS" ]
45+ exitFailure
46+
47+readDocs :: FilePath -> IO Interfaces
48+readDocs name = do
49+ exists <- doesFileExist name
50+ if exists then Map.fromList `fmap` Binary.decodeFile name
51+ else ioError . userError $ "File Not Found"
compiler/Model/Ast.hsdeleted−156
@@ -1,156 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−module Ast where
3−
4−import Located
5−import Data.Char (isDigit, isSymbol)
6−import Data.List (intercalate)
7−import Types.Types
8−import qualified Text.Pandoc as Pandoc
9−import Data.Data
10−
11−data Module = Module [String] Exports Imports [Statement]
12− deriving Show
13−
14−type Exports = [String]
15−
16−type Imports = [(String, ImportMethod)]
17−data ImportMethod = As String | Importing [String] | Hiding [String]
18− deriving (Eq, Ord, Show, Data, Typeable)
19−
20−
21−data Pattern = PData String [Pattern]
22− | PRecord [String]
23− | PVar String
24− | PAnything
25− deriving (Eq, Data, Typeable)
26−
27−type CExpr = Located Expr
28−data Expr = IntNum Int
29− | FloatNum Float
30− | Chr Char
31− | Str String
32− | Boolean Bool
33− | Range CExpr CExpr
34− | Access CExpr String
35− | Remove CExpr String
36− | Insert CExpr String CExpr
37− | Modify CExpr [(String,CExpr)]
38− | Record [(String,[String],CExpr)]
39− | Binop String CExpr CExpr
40− | Lambda String CExpr
41− | App CExpr CExpr
42− | If CExpr CExpr CExpr
43− | MultiIf [(CExpr,CExpr)]
44− | Let [Def] CExpr
45− | Var String
46− | Case CExpr [(Pattern,CExpr)]
47− | Data String [CExpr]
48− | Markdown Pandoc.Pandoc
49− deriving (Eq, Data, Typeable)
50−
51−data Def = FnDef String [String] CExpr
52− | OpDef String String String CExpr
53− | TypeAnnotation String Type
54− deriving (Eq, Data, Typeable)
55−
56−data Statement = Definition Def
57− | Datatype String [X] [(String,[Type])]
58− | TypeAlias String [X] Type
59− | ImportEvent String CExpr String Type
60− | ExportEvent String String Type
61− deriving (Eq, Show, Data, Typeable)
62−
63−cons h t = epos h t (Data "Cons" [h,t])
64−nil = L (Just "[]") NoSpan (Data "Nil" [])
65−list = foldr cons nil
66−tuple es = Data ("Tuple" ++ show (length es)) es
67−
68−delist (L _ _ (Data "Cons" [h,t])) = h : delist t
69−delist _ = []
70−
71−
72−pcons h t = PData "Cons" [h,t]
73−pnil = PData "Nil" []
74−plist = foldr pcons pnil
75−ptuple es = PData ("Tuple" ++ show (length es)) es
76−
77−brkt s = "{ " ++ s ++ " }"
78−parensIf b s = if b then parens s else s
79−isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
80−
81−instance Show Pattern where
82− show p =
83− case p of
84− PRecord fs -> brkt (intercalate ", " fs)
85− PVar x -> x
86− PAnything -> "_"
87− PData "Cons" [hd@(PData "Cons" _),tl] ->
88− parens (show hd) ++ " :: " ++ show tl
89− PData "Cons" [hd,tl] -> show hd ++ " : " ++ show tl
90− PData "Nil" [] -> "[]"
91− PData name ps ->
92− if take 5 name == "Tuple" && all isDigit (drop 5 name) then
93− parens . intercalate ", " $ map show ps
94− else parensIf (not (null ps)) $ unwords (name : map show ps)
95−
96−instance Show Expr where
97− show e =
98− let show' (L _ _ e) = parensIf (needsParens e) (show e) in
99− case e of
100− IntNum n -> show n
101− FloatNum n -> show n
102− Chr c -> show c
103− Str s -> show s
104− Boolean b -> show b
105− Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
106− Access e x -> show' e ++ "." ++ x
107− Remove e x -> brkt (show e ++ " - " ++ x)
108− Insert (L _ _ (Remove e y)) x v ->
109− brkt (show e ++ " - " ++ y ++ " | " ++ x ++ " = " ++ show v)
110− Insert e x v -> brkt (show e ++ " | " ++ x ++ " = " ++ show v)
111− Modify e fs -> brkt (show e ++" | "++ intercalate ", " (map field fs))
112− where field (x,e) = x ++ " <- " ++ show e
113− Record r -> brkt (intercalate ", " (map fields r))
114− where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e
115− Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2
116− Lambda x e -> let (xs,e') = getLambdas (notLocated $ Lambda x e) in
117− concat [ "\\", intercalate " " xs, " -> ", show e' ]
118− App e1 e2 -> show' e1 ++ " " ++ show' e2
119− If e1 e2 e3 -> concat [ "if ", show e1, " then ", show e2, " else ", show e3 ]
120− MultiIf (p:ps) -> concat [ "if | ", iff p, sep (map iff ps) ]
121− where iff (b,e) = show b ++ " -> " ++ show e
122− sep = concatMap ("\n | " ++)
123− Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e
124− Var (c:cs) -> if isOp c then parens (c:cs) else c:cs
125− Case e pats -> "case "++ show e ++" of " ++ brkt (intercalate " ; " pats')
126− where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
127− Data name es
128− | name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $
129− delist (notLocated $ Data "Cons" es)
130− | name == "Nil" -> "[]"
131− | otherwise -> name ++ " " ++ intercalate " " (map show' es)
132− Markdown _ -> "[markdown| ... |]"
133−
134−
135−instance Show Def where
136− show e =
137− case e of
138− FnDef v [] e -> v ++ " = " ++ show e
139− FnDef f args e -> f ++ concatMap (' ':) args ++ " = " ++ show e
140− OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e
141− TypeAnnotation n t -> n ++ " : " ++ show t
142−
143−getLambdas (L _ _ (Lambda x e)) = (x:xs,e')
144− where (xs,e') = getLambdas e
145−getLambdas e = ([],e)
146−
147−needsParens e =
148− case e of
149− Binop _ _ _ -> True
150− Lambda _ _ -> True
151− App _ _ -> True
152− If _ _ _ -> True
153− Let _ _ -> True
154− Case _ _ -> True
155− Data name (x:xs) -> name /= "Cons"
156− _ -> False
compiler/Model/Guid.hsdeleted−19
@@ -1,19 +0,0 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−module Guid (guid, set, run, runAt, GuidCounter) where
3−
4−import Control.Monad.State (evalState, State, get, put)
5−
6−-- Wrapper around State monad.
7−newtype GuidCounter a = GC { runGC :: State Int a }
8− deriving (Monad)
9−
10−-- Get the next GUID, incrementing the counter.
11−guid :: GuidCounter Int
12−guid = GC $ do n <- get
13− put (n + 1)
14− return n
15−
16−set n = GC (put n)
17−
18−run = runAt 0
19−runAt n x = evalState (runGC x) n
compiler/Model/Libraries.hsdeleted−59
@@ -1,59 +0,0 @@
1−module Libraries (libraries, addPrelude) where
2−
3−import Ast
4−import Control.Applicative ((<$>),(<*>))
5−import qualified Data.Map as Map
6−import Data.List (inits)
7−import Text.JSON
8−import LoadLibraries as Libs
9−
10−addPrelude :: Module -> Module
11−addPrelude (Module name exs ims stmts) = Module name exs (customIms ++ ims) stmts
12− where customIms = concatMap addModule prelude
13−
14− addModule (n, method) = case lookup n ims of
15− Nothing -> [(n, method)]
16− Just (As m) -> [(n, method)]
17− Just _ -> []
18−
19−prelude = text : map (\n -> (n, Hiding [])) modules
20− where
21− text = ("Text", Hiding ["link", "color", "height"])
22− modules = [ "Prelude", "Signal", "List", "Maybe", "Time"
23− , "Graphics.Element", "Color", "Graphics.Collage" ]
24−
25−libraries :: Map.Map String (Map.Map String String)
26−libraries =
27− case getLibs of
28− Error err -> error err
29− Ok libs -> Map.unionWith Map.union libs nilAndTuples
30− where nilAndTuples = Map.singleton "Prelude" (Map.fromList pairs)
31− pairs =
32− [ ("Cons", "a -> [a] -> [a]")
33− , ("Nil", "[a]")
34− ] ++ map makeTuple (inits ['a'..'i'])
35−
36− makeTuple cs =
37− let name = "Tuple" ++ show (length cs)
38− in (name, concatMap (\c -> c : " -> ") cs ++
39− name ++ concatMap (\c -> [' ',c]) cs)
40−
41−getLibs :: Result (Map.Map String (Map.Map String String))
42−getLibs = do
43− obj <- decodeStrict Libs.docs :: Result (JSObject JSValue)
44− modules <- valFromObj "modules" obj :: Result [JSObject JSValue]
45− Map.fromList `fmap` mapM getValues modules
46−
47−
48−get :: String -> JSObject JSValue -> Result String
49−get = valFromObj
50−
51−getValue :: JSObject JSValue -> Result (String,String)
52−getValue obj = (,) <$> get "name" obj <*> get "type" obj
53−
54−getValues :: JSObject JSValue -> Result (String, Map.Map String String)
55−getValues obj = do
56− name <- get "name" obj
57− vs <- valFromObj "values" obj
58− vals <- mapM getValue vs
59− return (name, Map.fromList vals)
compiler/Model/LoadLibraries.hsdeleted−34
@@ -1,34 +0,0 @@
1−module LoadLibraries (docs) where
2−
3−import Control.DeepSeq (force)
4−import qualified Control.Exception as E
5−import Paths_Elm
6−import System.Directory
7−import System.FilePath
8−import System.IO.Unsafe (unsafePerformIO)
9−
10−-- See stackoverflow discussion for trade-off between using unsafeIO or TemplateHaskell:
11−-- http://stackoverflow.com/questions/12716215/load-pure-global-variable-from-file
12−
13−-- Given the awkwardness of including a compile-time generated file
14−-- vs loading static data, then the unsafeIO seems better.
15−
16−{-# NOINLINE docs #-}
17−docs :: String
18−docs = force $ unsafePerformIO (safeReadDocs =<< getDataFileName "docs.json")
19−
20−safeReadDocs :: FilePath -> IO String
21−safeReadDocs name = E.catch (readDocs name) (emitError name)
22−
23−readDocs :: FilePath -> IO String
24−readDocs name = do
25− exists <- doesFileExist name
26− if exists then readFile name
27− else ioError . userError $ "File Not Found"
28−
29−
30−emitError :: FilePath -> IOError -> IO String
31−emitError name err = do
32− putStrLn $ "Error! Types for standard library not loaded properly!\n File should be here:" ++ name ++ "\n The file is created and copied by command: cabal install"
33− putStrLn (show err)
34− return "{\"modules\":[]}"
compiler/Model/Located.hsdeleted−43
@@ -1,43 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−module Located where
3−
4−import Text.Parsec.Pos
5−import Data.Data
6−
7−data SrcPos = Pos Int Int
8− deriving (Eq, Ord, Data, Typeable)
9−
10−data SrcSpan = Span SrcPos SrcPos | NoSpan
11− deriving (Eq, Ord, Data, Typeable)
12−
13−data Located e = L (Maybe String) SrcSpan e deriving (Eq,Ord, Data, Typeable)
14−
15−
16−instance Show SrcPos where
17− show (Pos r c) = "Line " ++ show r ++ ", Column " ++ show c
18−
19−instance Show SrcSpan where
20− show span =
21− case span of
22− Span start end -> show start
23− NoSpan -> ""
24−
25−instance Show e => Show (Located e) where
26− show (L _ _ e) = show e
27−
28−
29−
30−notLocated = L Nothing NoSpan
31−
32−pos start end = L Nothing
33− (Span (Pos (sourceLine start) (sourceColumn start))
34− (Pos (sourceLine end ) (sourceColumn end )))
35−
36−epos (L _ s1 _) (L _ s2 _) = L Nothing span
37− where span = case (s1,s2) of
38− (Span start _, Span _ end) -> Span start end
39− (_, NoSpan) -> s1
40− (NoSpan, _) -> s2
41−
42−addLoc x (L Nothing span e) = L (Just (show x)) span e
43−addLoc x (L txt span e) = L txt span e
compiler/Parse/Binops.hs → compiler/Parse/Binop.hsrenamed+34−25
@@ -1,18 +1,15 @@
1−module Parse.Binops (binops, infixStmt, OpTable) where
1+module Parse.Binop (binops, infixStmt, OpTable) where
2
2
3−import Ast
3+import Control.Applicative ((<$>))
4−import Control.Monad (liftM,guard)
5import Control.Monad.Error
4import Control.Monad.Error
6−import Data.List (foldl',splitAt,elemIndices
5+import Data.List (intercalate)
7− ,group,groupBy,sortBy,find,intercalate)
8import qualified Data.Map as Map
6import qualified Data.Map as Map
9−import Data.Maybe (mapMaybe)
10
7
11−import Located (epos)
8+import SourceSyntax.Location (merge)
9+import SourceSyntax.Expression (LExpr, Expr(Binop))
10+import SourceSyntax.Declaration (Assoc(..))
12import Text.Parsec
11import Text.Parsec
13−import Parse.Library
12+import Parse.Helpers
14−
15−data Assoc = L | N | R deriving (Eq,Show)
16
13
17type OpTable = [(Int, Assoc, String)]
14type OpTable = [(Int, Assoc, String)]
18
15
@@ -39,20 +36,31 @@ opAssoc :: OpTable -> String -> Assoc
39opAssoc table op = Map.findWithDefault R op dict
36opAssoc table op = Map.findWithDefault R op dict
40 where dict = Map.fromList (map (\(_,assoc,op) -> (op,assoc)) table)
37 where dict = Map.fromList (map (\(_,assoc,op) -> (op,assoc)) table)
41
38
42−hasLevel :: OpTable -> Int -> (String,CExpr) -> Bool
39+hasLevel :: OpTable -> Int -> (String, LExpr t v) -> Bool
43hasLevel table n (op,_) = opLevel table op == n
40hasLevel table n (op,_) = opLevel table op == n
44
41
45−binops :: OpTable -> IParser CExpr -> IParser String -> IParser CExpr
42+binops :: OpTable
43+ -> IParser (LExpr t v)
44+ -> IParser (LExpr t v)
45+ -> IParser String
46+ -> IParser (LExpr t v)
46−binops table term anyOp =
47+binops table term last anyOp =
47 do e <- term
48 do e <- term
48− split (table ++ preludeTable) 0 e =<< many nextOp
49+ split (table ++ preludeTable) 0 e =<< nextOps
49 where
50 where
50− nextOp = commitIf (whitespace >> anyOp) $ do
51+ nextOps = choice [ commitIf (whitespace >> anyOp) $ do
51− whitespace ; op <- anyOp
52+ whitespace ; op <- anyOp ; whitespace
52− whitespace ; e <- term
53+ expr <- Left <$> try term <|> Right <$> last
54+ case expr of
55+ Left t -> (:) (op,t) <$> nextOps
53− return (op,e)
56+ Right e -> return [(op,e)]
57+ , return [] ]
54
58
55−split :: OpTable -> Int -> CExpr -> [(String, CExpr)] -> IParser CExpr
59+split :: OpTable
60+ -> Int
61+ -> LExpr t v
62+ -> [(String, LExpr t v)]
63+ -> IParser (LExpr t v)
56split _ _ e [] = return e
64split _ _ e [] = return e
57split table n e eops = do
65split table n e eops = do
58 assoc <- getAssoc table n eops
66 assoc <- getAssoc table n eops
@@ -61,25 +69,26 @@ split table n e eops = do
61 case assoc of R -> joinR es ops
69 case assoc of R -> joinR es ops
62 _ -> joinL es ops
70 _ -> joinL es ops
63
71
64−splitLevel :: OpTable -> Int -> CExpr -> [(String, CExpr)] -> [IParser CExpr]
72+splitLevel :: OpTable -> Int -> LExpr t v -> [(String, LExpr t v)]
73+ -> [IParser (LExpr t v)]
65splitLevel table n e eops =
74splitLevel table n e eops =
66 case break (hasLevel table n) eops of
75 case break (hasLevel table n) eops of
67 (lops, (op,e'):rops) ->
76 (lops, (op,e'):rops) ->
68 split table (n+1) e lops : splitLevel table n e' rops
77 split table (n+1) e lops : splitLevel table n e' rops
69 (lops, []) -> [ split table (n+1) e lops ]
78 (lops, []) -> [ split table (n+1) e lops ]
70
79
71−joinL :: [CExpr] -> [String] -> IParser CExpr
80+joinL :: [LExpr t v] -> [String] -> IParser (LExpr t v)
72joinL [e] [] = return e
81joinL [e] [] = return e
73−joinL (a:b:es) (op:ops) = joinL (epos a b (Binop op a b) : es) ops
82+joinL (a:b:es) (op:ops) = joinL (merge a b (Binop op a b) : es) ops
74joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."
83joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."
75
84
76−joinR :: [CExpr] -> [String] -> IParser CExpr
85+joinR :: [LExpr t v] -> [String] -> IParser (LExpr t v)
77joinR [e] [] = return e
86joinR [e] [] = return e
78joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
87joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
79− return (epos a e (Binop op a e))
88+ return (merge a e (Binop op a e))
80joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."
89joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."
81
90
82−getAssoc :: OpTable -> Int -> [(String,CExpr)] -> IParser Assoc
91+getAssoc :: OpTable -> Int -> [(String,LExpr t v)] -> IParser Assoc
83getAssoc table n eops
92getAssoc table n eops
84 | all (==L) assocs = return L
93 | all (==L) assocs = return L
85 | all (==R) assocs = return R
94 | all (==R) assocs = return R
compiler/Parse/Declaration.hsnew file+134
@@ -0,0 +1,134 @@
1+
2+module Parse.Declaration where
3+
4+import Control.Applicative ((<$>), (<*>))
5+import qualified Data.List as List
6+import Text.Parsec hiding (newline,spaces)
7+import Text.Parsec.Indent
8+import qualified Text.Pandoc as Pan
9+
10+import Parse.Helpers
11+import qualified Parse.Expression as Expr
12+import qualified SourceSyntax.Type as T
13+import qualified Parse.Type as Type
14+import SourceSyntax.Declaration (Declaration(..), Assoc(..))
15+
16+import Unique
17+
18+declaration :: IParser (Declaration t v)
19+declaration = alias <|> datatype <|> infixDecl <|> foreignDef <|> definition
20+
21+definition :: IParser (Declaration t v)
22+definition = Definition <$> Expr.def
23+
24+alias :: IParser (Declaration t v)
25+alias = do
26+ reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
27+ forcedWS
28+ alias <- capVar
29+ args <- spacePrefix lowVar
30+ whitespace ; string "=" ; whitespace
31+ tipe <- Type.expr
32+ return (TypeAlias alias args tipe)
33+
34+datatype :: IParser (Declaration t v)
35+datatype = do
36+ reserved "data" <?> "datatype definition (data T = A | B | ...)"
37+ forcedWS
38+ name <- capVar <?> "name of data-type"
39+ args <- spacePrefix lowVar
40+ whitespace ; string "=" ; whitespace
41+ tcs <- pipeSep1 Type.constructor
42+ return $ Datatype name args tcs
43+
44+
45+infixDecl :: IParser (Declaration t v)
46+infixDecl = do
47+ assoc <- choice [ reserved "infixl" >> return L
48+ , reserved "infix" >> return N
49+ , reserved "infixr" >> return R ]
50+ whitespace
51+ n <- digit
52+ forcedWS
53+ Fixity assoc (read [n]) <$> anyOp
54+
55+
56+foreignDef :: IParser (Declaration t v)
57+foreignDef = do
58+ try (reserved "foreign")
59+ whitespace
60+ importEvent <|> exportEvent
61+
62+exportEvent :: IParser (Declaration t v)
63+exportEvent = do
64+ try (reserved "export") >> whitespace >> reserved "jsevent" >> whitespace
65+ eventName <- jsVar
66+ whitespace
67+ elmVar <- lowVar
68+ whitespace ; hasType ; whitespace
69+ tipe <- Type.expr
70+ case tipe of
71+ T.Data "Signal" [t] ->
72+ case isExportable t of
73+ Nothing -> return (ExportEvent eventName elmVar tipe)
74+ Just err -> error err
75+ _ -> error "When importing foreign events, the imported value must have type Signal."
76+
77+importEvent :: IParser (Declaration t v)
78+importEvent = do
79+ try (reserved "import") >> whitespace >> reserved "jsevent" >> whitespace
80+ eventName <- jsVar
81+ whitespace
82+ baseValue <- Expr.term <?> "Base case for imported signal (signals cannot be undefined)"
83+ whitespace
84+ elmVar <- lowVar <?> "Name of imported signal"
85+ whitespace ; hasType ; whitespace
86+ tipe <- Type.expr
87+ case tipe of
88+ T.Data "Signal" [t] ->
89+ case isExportable t of
90+ Nothing -> return (ImportEvent eventName baseValue elmVar tipe)
91+ Just err -> error err
92+ _ -> error "When importing foreign events, the imported value must have type Signal."
93+
94+jsVar :: IParser String
95+jsVar = betwixt '"' '"' $ do
96+ v <- (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')
97+ if v `notElem` jsReserveds then return v else
98+ error $ "'" ++ v ++
99+ "' is not a good name for a importing or exporting JS values."
100+
101+jsReserveds :: [String]
102+jsReserveds =
103+ [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"
104+ , "arguments", "int", "byte", "char", "goto", "long", "final", "float"
105+ , "short", "double", "native", "throws", "boolean", "abstract", "volatile"
106+ , "transient", "synchronized", "function", "break", "case", "catch"
107+ , "continue", "debugger", "default", "delete", "do", "else", "finally"
108+ , "for", "function", "if", "in", "instanceof", "new", "return", "switch"
109+ , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"
110+ , "const", "enum", "export", "extends", "import", "super", "implements"
111+ , "interface", "let", "package", "private", "protected", "public"
112+ , "static", "yield"
113+ ]
114+
115+isExportable tipe =
116+ case tipe of
117+ T.Lambda _ _ ->
118+ Just $ "Elm's JavaScript event interface does not yet handle functions. " ++
119+ "Only simple values can be imported and exported in this release."
120+
121+ T.Data "JSArray" [t] -> isExportable t
122+
123+ T.Data name []
124+ | any (`List.isSuffixOf` name) jsTypes -> Nothing
125+ | otherwise -> Just $ "'" ++ name ++ "' is not an exportable type." ++ msg
126+
127+ T.Data name _ ->
128+ Just $ "'" ++ name ++ "' is not an exportable type " ++
129+ "constructor. Only 'JSArray' is an exportable container."
130+
131+ T.Var _ -> Just $ "Cannot export type variables." ++ msg
132+ where
133+ msg = " The following types are exportable: " ++ List.intercalate ", " jsTypes
134+ jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]
compiler/Parse/Expr.hsdeleted−220
@@ -1,220 +0,0 @@
1−module Parse.Expr (def,term) where
2−
3−import Ast
4−import Located
5−import Control.Applicative ((<$>), (<*>))
6−import Control.Monad
7−import Data.Char (isSymbol, isDigit)
8−import Data.List (foldl')
9−import Text.Parsec hiding (newline,spaces)
10−import Text.Parsec.Indent
11−import qualified Text.Pandoc as Pan
12−
13−import Parse.Library
14−import Parse.Patterns
15−import Parse.Binops
16−import Parse.Types
17−
18−import Guid
19−import Types.Types (Type (VarT), Scheme (Forall))
20−
21−import System.IO.Unsafe
22−
23−
24−-------- Basic Terms --------
25−
26−numTerm :: IParser Expr
27−numTerm = toExpr <$> (preNum <?> "number")
28− where toExpr n | '.' `elem` n = FloatNum (read n)
29− | otherwise = IntNum (read n)
30− preNum = (++) <$> many1 digit <*> option "" postNum
31− postNum = do try $ lookAhead (string "." >> digit)
32− string "."
33− ('.':) <$> many1 digit
34−
35−strTerm :: IParser Expr
36−strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $
37− backslashed <|> satisfy (/='"')
38−
39−varTerm :: IParser Expr
40−varTerm = toVar <$> var <?> "variable"
41−
42−toVar v = case v of "True" -> Boolean True
43− "False" -> Boolean False
44− _ -> Var v
45−
46−chrTerm :: IParser Expr
47−chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
48− <?> "character"
49−
50−accessor :: IParser Expr
51−accessor = do
52− start <- getPosition
53− lbl <- try (string "." >> rLabel)
54− end <- getPosition
55− let loc e = addLoc ("." ++ lbl) (pos start end e)
56− return (Lambda "_" (loc $ Access (loc $ Var "_") lbl))
57−
58−
59−-------- Complex Terms --------
60−
61−listTerm :: IParser Expr
62−listTerm =
63− (do { try $ string "[markdown|"
64− ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")
65− ; return . Markdown $ Pan.readMarkdown Pan.def md })
66− <|> (braces $ choice
67− [ try $ do { lo <- expr; whitespace; string ".." ; whitespace
68− ; Range lo <$> expr }
69− , do (L _ _ e) <- list <$> commaSep expr
70− return e
71− ])
72−
73−parensTerm :: IParser CExpr
74−parensTerm = parens $ choice
75− [ do start <- getPosition
76− op <- try anyOp
77− end <- getPosition
78− let loc = pos start end
79− return . loc . Lambda "x" . loc . Lambda "y" . loc $
80− Binop op (loc $ Var "x") (loc $ Var "y")
81− , do start <- getPosition
82− let comma = char ',' <?> "comma ','"
83− commas <- comma >> many (whitespace >> comma)
84− end <- getPosition
85− let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
86− loc = pos start end
87− return $ foldr (\x e -> loc $ Lambda x e)
88− (loc . tuple $ map (loc . Var) vars) vars
89− , do start <- getPosition
90− es <- commaSep expr
91− end <- getPosition
92− return $ case es of [e] -> e
93− _ -> pos start end (tuple es)
94− ]
95−
96−recordTerm :: IParser CExpr
97−recordTerm = brackets $ choice [ misc, addLocation record ]
98− where field = do
99− fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix patternTerm
100− whitespace
101− e <- string "=" >> whitespace >> expr
102− n <- sourceLine <$> getPosition
103− runAt (1000 * n) $ flattenPatterns fDefs e
104− extract [ FnDef f args exp ] = return (f,args,exp)
105− extract _ = fail "Improperly formed record field."
106− record = Record <$> (mapM extract =<< commaSep field)
107− change = do
108− lbl <- rLabel
109− whitespace >> string "<-" >> whitespace
110− (,) lbl <$> expr
111− remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
112− insert r = addLocation $ do
113− string "|" >> whitespace
114− Insert r <$> rLabel <*>
115− (whitespace >> string "=" >> whitespace >> expr)
116− modify r = addLocation
117− (string "|" >> whitespace >> Modify r <$> commaSep1 change)
118− misc = try $ do
119− record <- addLocation (Var <$> rLabel)
120− whitespace
121− opt <- optionMaybe (remove record)
122− whitespace
123− case opt of
124− Just e -> try (insert e) <|> return e
125− Nothing -> try (insert record) <|> try (modify record)
126−
127−
128−term :: IParser CExpr
129−term = addLocation (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])
130− <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
131− <?> "basic term (4, x, 'c', etc.)"
132−
133−-------- Applications --------
134−
135−appExpr :: IParser CExpr
136−appExpr = do
137− tlist <- spaceSep1 term
138− return $ case tlist of
139− t:[] -> t
140− t:ts -> foldl' (\f x -> epos f x $ App f x) t ts
141−
142−-------- Normal Expressions --------
143−
144−binaryExpr :: IParser CExpr
145−binaryExpr = binops [] appExpr anyOp
146−
147−ifExpr :: IParser Expr
148−ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
149− where normal = do e1 <- expr ; whitespace
150− reserved "then" ; whitespace ; e2 <- expr
151− whitespace <?> "an 'else' branch"
152− reserved "else" <?> "an 'else' branch" ; whitespace
153− If e1 e2 <$> expr
154− multiIf = (MultiIf <$> spaceSep1 iff)
155− where iff = do string "|" ; whitespace
156− b <- expr ; whitespace ; string "->" ; whitespace
157− (,) b <$> expr
158−
159−lambdaExpr :: IParser CExpr
160−lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
161− whitespace
162− pats <- spaceSep1 patternTerm
163− whitespace ; arrow ; whitespace
164− e <- expr
165− return . run $ makeLambda pats e
166−
167−defSet :: IParser [Def]
168−defSet = concat <$> block (do d <- anyDef ; whitespace ; return d)
169−
170−letExpr :: IParser Expr
171−letExpr = do
172− reserved "let" ; whitespace
173− defs <- defSet
174− whitespace ; reserved "in" ; whitespace
175− Let defs <$> expr
176−
177−caseExpr :: IParser Expr
178−caseExpr = do
179− reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
180− Case e <$> (with <|> without)
181− where case_ = do p <- patternExpr; whitespace; arrow; whitespace
182− (,) p <$> expr
183− with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
184− without = block (do c <- case_ ; whitespace ; return c)
185−
186−expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
187− <|> lambdaExpr
188− <|> binaryExpr
189− <?> "an expression"
190−
191−funcDef = try (do p1 <- try patternTerm ; infics p1 <|> func p1)
192− <|> ((:[]) <$> patternExpr)
193− <?> "the definition of a variable (x = ...)"
194− where func p@(PVar v) = (p:) <$> spacePrefix patternTerm
195− func p = do try (lookAhead (whitespace >> string "="))
196− return [p]
197− infics p1 = do
198− o:p <- try (whitespace >> anyOp)
199− p2 <- (whitespace >> patternTerm)
200− return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
201− else [ PVar (o:p), p1, p2 ]
202−
203−assignExpr :: IParser [Def]
204−assignExpr = withPos $ do
205− fDefs <- funcDef
206− whitespace
207− e <- string "=" >> whitespace >> expr
208− n <- sourceLine <$> getPosition
209− runAt (1000 * n) $ flattenPatterns fDefs e
210−
211−anyDef =
212− ((\d -> [d]) <$> typeAnnotation) <|>
213− assignExpr
214−
215−def = map Definition <$> anyDef
216−
217−parseDef str =
218− case iParse def "" str of
219− Right result -> Right result
220− Left err -> Left $ "Parse error at " ++ show err
compiler/Parse/Expression.hsnew file+242
@@ -0,0 +1,242 @@
1+module Parse.Expression (def,term) where
2+
3+import Control.Applicative ((<$>), (<*>))
4+import Data.List (foldl')
5+import Text.Parsec hiding (newline,spaces)
6+import Text.Parsec.Indent
7+import qualified Text.Pandoc as Pan
8+
9+import Parse.Helpers
10+import qualified Parse.Pattern as Pattern
11+import qualified Parse.Type as Type
12+import Parse.Binop
13+import Parse.Literal
14+
15+import SourceSyntax.Location as Location
16+import SourceSyntax.Pattern hiding (tuple,list)
17+import qualified SourceSyntax.Literal as Literal
18+import SourceSyntax.Expression
19+import SourceSyntax.Declaration (Declaration(Definition))
20+
21+import Unique
22+
23+
24+-------- Basic Terms --------
25+
26+varTerm :: IParser (Expr t v)
27+varTerm = toVar <$> var <?> "variable"
28+
29+toVar :: String -> Expr t v
30+toVar v = case v of "True" -> Literal (Literal.Boolean True)
31+ "False" -> Literal (Literal.Boolean False)
32+ _ -> Var v
33+
34+accessor :: IParser (Expr t v)
35+accessor = do
36+ start <- getPosition
37+ lbl <- try (string "." >> rLabel)
38+ end <- getPosition
39+ let loc e = Location.at start end e
40+ return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
41+
42+negative :: IParser (Expr t v)
43+negative = do
44+ start <- getPosition
45+ nTerm <- try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term
46+ end <- getPosition
47+ let loc e = Location.at start end e
48+ return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)
49+
50+
51+-------- Complex Terms --------
52+
53+listTerm :: IParser (Expr t v)
54+listTerm =
55+ (do { try $ string "[markdown|"
56+ ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")
57+ ; return . Markdown $ Pan.readMarkdown Pan.def md })
58+ <|> (braces $ choice
59+ [ try $ do { lo <- expr; whitespace; string ".." ; whitespace
60+ ; Range lo <$> expr }
61+ , ExplicitList <$> commaSep expr
62+ ])
63+
64+parensTerm :: IParser (LExpr t v)
65+parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
66+ where
67+ opFn = do
68+ start <- getPosition
69+ op <- anyOp
70+ end <- getPosition
71+ let loc = Location.at start end
72+ return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
73+ Binop op (loc $ Var "x") (loc $ Var "y")
74+
75+ tupleFn = do
76+ start <- getPosition
77+ let comma = char ',' <?> "comma ','"
78+ commas <- comma >> many (whitespace >> comma)
79+ end <- getPosition
80+ let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
81+ loc = Location.at start end
82+ return $ foldr (\x e -> loc $ Lambda x e)
83+ (loc . tuple $ map (loc . Var) vars) (map PVar vars)
84+
85+ parened = do
86+ start <- getPosition
87+ es <- commaSep expr
88+ end <- getPosition
89+ return $ case es of [e] -> e
90+ _ -> Location.at start end (tuple es)
91+
92+recordTerm :: IParser (LExpr t v)
93+recordTerm = brackets $ choice [ misc, addLocation record ]
94+ where field = do
95+ label <- rLabel
96+ patterns <- spacePrefix Pattern.term
97+ whitespace >> string "=" >> whitespace
98+ body <- expr
99+ return (label, makeFunction patterns body)
100+
101+ record = Record <$> commaSep field
102+
103+ change = do
104+ lbl <- rLabel
105+ whitespace >> string "<-" >> whitespace
106+ (,) lbl <$> expr
107+
108+ remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
109+
110+ insert r = addLocation $ do
111+ string "|" >> whitespace
112+ Insert r <$> rLabel <*>
113+ (whitespace >> string "=" >> whitespace >> expr)
114+
115+ modify r = addLocation
116+ (string "|" >> whitespace >> Modify r <$> commaSep1 change)
117+
118+ misc = try $ do
119+ record <- addLocation (Var <$> rLabel)
120+ whitespace
121+ opt <- optionMaybe (remove record)
122+ whitespace
123+ case opt of
124+ Just e -> try (insert e) <|> return e
125+ Nothing -> try (insert record) <|> try (modify record)
126+
127+
128+term :: IParser (LExpr t v)
129+term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
130+ <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
131+ <?> "basic term (4, x, 'c', etc.)"
132+
133+-------- Applications --------
134+
135+appExpr :: IParser (LExpr t v)
136+appExpr = do
137+ t <- term
138+ ts <- constrainedSpacePrefix term $ \str ->
139+ if null str then notFollowedBy (char '-') else return ()
140+ return $ case ts of
141+ [] -> t
142+ _ -> foldl' (\f x -> Location.merge f x $ App f x) t ts
143+
144+-------- Normal Expressions --------
145+
146+binaryExpr :: IParser (LExpr t v)
147+binaryExpr = binops [] appExpr lastExpr anyOp
148+ where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
149+ <|> lambdaExpr
150+
151+ifExpr :: IParser (Expr t v)
152+ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
153+ where
154+ normal = do
155+ bool <- expr
156+ whitespace ; reserved "then" ; whitespace
157+ thenBranch <- expr
158+ whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
159+ elseBranch <- expr
160+ return $ MultiIf [(bool, thenBranch),
161+ (Location.sameAs elseBranch (Var "otherwise"), elseBranch)]
162+ multiIf = MultiIf <$> spaceSep1 iff
163+ where iff = do string "|" ; whitespace
164+ b <- expr ; whitespace ; string "->" ; whitespace
165+ (,) b <$> expr
166+
167+lambdaExpr :: IParser (LExpr t v)
168+lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
169+ whitespace
170+ args <- spaceSep1 Pattern.term
171+ whitespace ; arrow ; whitespace
172+ body <- expr
173+ return (makeFunction args body)
174+
175+defSet :: IParser [Def t v]
176+defSet = block (do d <- def ; whitespace ; return d)
177+
178+letExpr :: IParser (Expr t v)
179+letExpr = do
180+ reserved "let" ; whitespace
181+ defs <- defSet
182+ whitespace ; reserved "in" ; whitespace
183+ Let defs <$> expr
184+
185+caseExpr :: IParser (Expr t v)
186+caseExpr = do
187+ reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
188+ Case e <$> (with <|> without)
189+ where case_ = do p <- Pattern.expr; whitespace; arrow; whitespace
190+ (,) p <$> expr
191+ with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
192+ without = block (do c <- case_ ; whitespace ; return c)
193+
194+expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
195+ <|> lambdaExpr
196+ <|> binaryExpr
197+ <?> "an expression"
198+
199+funcDef =
200+ choice [ do p1 <- try Pattern.term
201+ infics p1 <|> func p1
202+ , func =<< (PVar <$> parens symOp)
203+ , (:[]) <$> Pattern.expr
204+ ] <?> "the definition of a variable (x = ...)"
205+ where
206+ func pattern =
207+ case pattern of
208+ PVar v -> (pattern:) <$> spacePrefix Pattern.term
209+ _ -> do try (lookAhead (whitespace >> string "="))
210+ return [pattern]
211+
212+ infics p1 = do
213+ o:p <- try (whitespace >> anyOp)
214+ p2 <- (whitespace >> Pattern.term)
215+ return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
216+ else [ PVar (o:p), p1, p2 ]
217+
218+makeFunction :: [Pattern] -> LExpr t v -> LExpr t v
219+makeFunction args body@(L s _) =
220+ foldr (\arg body' -> L s $ Lambda arg body') body args
221+
222+assignExpr :: IParser (Def t v)
223+assignExpr = withPos $ do
224+ (name:args) <- funcDef
225+ whitespace >> string "=" >> whitespace
226+ body <- expr
227+ return . Def name $ makeFunction args body
228+
229+typeAnnotation :: IParser (Def t v)
230+typeAnnotation = TypeAnnotation <$> try start <*> Type.expr
231+ where
232+ start = do v <- lowVar <|> parens symOp
233+ whitespace ; hasType ; whitespace
234+ return v
235+
236+def :: IParser (Def t v)
237+def = typeAnnotation <|> assignExpr
238+
239+attempt f parser str =
240+ case iParse parser "" str of
241+ Right result -> f result
242+ Left err -> error $ "Parse error at " ++ show err
compiler/Parse/Foreign.hsdeleted−60
@@ -1,60 +0,0 @@
1−
2−module Parse.Foreign (foreignDef) where
3−
4−import Control.Applicative ((<$>), (<*>))
5−import Data.Either (partitionEithers)
6−import Text.Parsec hiding (newline,spaces)
7−
8−import Ast
9−import Parse.Library
10−import Parse.Expr (term)
11−import Parse.Types
12−import Types.Types (signalOf)
13−
14−foreignDef = do try (reserved "foreign") ; whitespace
15− importEvent <|> exportEvent
16−
17−exportEvent = do
18− try (reserved "export") >> whitespace >> reserved "jsevent" >> whitespace
19− js <- jsVar ; whitespace
20− elm <- lowVar ; whitespace
21− hasType ; whitespace
22− tipe <- typeExpr
23− case tipe of
24− ADTPT "Signal" [pt] ->
25− either error (return . ExportEvent js elm . signalOf) (toForeignType pt)
26− _ -> error "When exporting events, the exported value must be a Signal."
27−
28−importEvent = do
29− try (reserved "import") >> whitespace >> reserved "jsevent" >> whitespace
30− js <- jsVar ; whitespace
31− base <- term <?> "Base case for imported signal (signals cannot be undefined)"
32− whitespace
33− elm <- lowVar <?> "Name of imported signal"
34− whitespace ; hasType ; whitespace
35− tipe <- typeExpr
36− case tipe of
37− ADTPT "Signal" [pt] ->
38− either error (return . ImportEvent js base elm . signalOf) (toForeignType pt)
39− _ -> error "When importing events, the imported value must be a Signal."
40−
41−
42−jsVar :: (Monad m) => ParsecT [Char] u m String
43−jsVar = betwixt '"' '"' $ do
44− v <- (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')
45− if v `notElem` jsReserveds then return v else
46− error $ "'" ++ v ++
47− "' is not a good name for a importing or exporting JS values."
48−
49−jsReserveds =
50− [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"
51− , "arguments", "int", "byte", "char", "goto", "long", "final", "float"
52− , "short", "double", "native", "throws", "boolean", "abstract", "volatile"
53− , "transient", "synchronized", "function", "break", "case", "catch"
54− , "continue", "debugger", "default", "delete", "do", "else", "finally"
55− , "for", "function", "if", "in", "instanceof", "new", "return", "switch"
56− , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"
57− , "const", "enum", "export", "extends", "import", "super", "implements"
58− , "interface", "let", "package", "private", "protected", "public"
59− , "static", "yield"
60− ]
compiler/Parse/Library.hs → compiler/Parse/Helpers.hsrenamed+45−25
@@ -1,13 +1,12 @@
1+module Parse.Helpers where
1
2
2−module Parse.Library where
3−
4−import Ast
5−import Located
6import Control.Applicative ((<$>),(<*>))
3import Control.Applicative ((<$>),(<*>))
7import Control.Monad
4import Control.Monad
8import Control.Monad.State
5import Control.Monad.State
9import Data.Char (isUpper)
6import Data.Char (isUpper)
10−import Rename (deprime)
7+import SourceSyntax.Helpers as Help
8+import SourceSyntax.Location as Location
9+import SourceSyntax.Expression
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
@@ -124,17 +135,17 @@ parens = surround '(' ')' "paren"
124brackets :: IParser a -> IParser a
135brackets :: IParser a -> IParser a
125brackets = surround '{' '}' "bracket"
136brackets = surround '{' '}' "bracket"
126
137
127−addLocation :: IParser Expr -> IParser CExpr
138+addLocation :: IParser (Expr t v) -> IParser (LExpr t v)
128addLocation expr = do
139addLocation expr = do
129 start <- getPosition
140 start <- getPosition
130 e <- expr
141 e <- expr
131 end <- getPosition
142 end <- getPosition
132− return (pos start end e)
143+ return (Location.at start end e)
133
144
134−accessible :: IParser CExpr -> IParser CExpr
145+accessible :: 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)")
@@ -143,41 +154,50 @@ accessible expr = do
143 Just _ -> accessible $ do
154 Just _ -> accessible $ do
144 v <- var <?> "field access (e.g. List.map)"
155 v <- var <?> "field access (e.g. List.map)"
145 end <- getPosition
156 end <- getPosition
146− return (pos start end (f v))
157+ return (Location.at start end (f v))
147 case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
158 case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
148 | otherwise -> rest (Access ce)
159 | otherwise -> rest (Access ce)
149 _ -> rest (Access ce)
160 _ -> rest (Access ce)
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/Literal.hsnew file+31
@@ -0,0 +1,31 @@
1+module Parse.Literal (literal) where
2+
3+import Control.Applicative ((<$>), (<*>))
4+import Control.Monad
5+import Text.Parsec hiding (newline,spaces)
6+import Text.Parsec.Indent
7+
8+import Parse.Helpers
9+import SourceSyntax.Literal
10+
11+literal = num <|> str <|> chr
12+
13+num :: IParser Literal
14+num = fmap toLit (preNum <?> "number")
15+ where toLit n | '.' `elem` n = FloatNum (read n)
16+ | otherwise = IntNum (read n)
17+ preNum = (++) <$> many1 digit <*> option "" postNum
18+ postNum = do try $ lookAhead (string "." >> digit)
19+ string "."
20+ ('.':) <$> many1 digit
21+
22+str :: IParser Literal
23+str = choice [ let quote = try (string "\"\"\"")
24+ in quote >> Str <$> manyTill (backslashed <|> anyChar) quote
25+ , liftM Str . expecting "string" . betwixt '"' '"' . many $
26+ backslashed <|> satisfy (/='"')
27+ ]
28+
29+chr :: IParser Literal
30+chr = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
31+ <?> "character"
compiler/Parse/Module.hsnew file+44
@@ -0,0 +1,44 @@
1+
2+module Parse.Module (moduleDef, imports) where
3+
4+import Control.Applicative ((<$>), (<*>))
5+import Data.List (intercalate)
6+import Text.Parsec hiding (newline,spaces)
7+
8+import Parse.Helpers
9+import SourceSyntax.Module (Module(..), ImportMethod(..), Imports)
10+
11+varList :: IParser [String]
12+varList = parens $ commaSep1 (var <|> parens symOp)
13+
14+moduleDef :: IParser ([String], [String])
15+moduleDef = do
16+ try (reserved "module")
17+ whitespace
18+ names <- dotSep1 capVar <?> "name of module"
19+ whitespace
20+ exports <- option [] varList
21+ whitespace <?> "reserved word 'where'"
22+ reserved "where"
23+ return (names, exports)
24+
25+imports :: IParser Imports
26+imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
27+
28+import' :: IParser (String, ImportMethod)
29+import' =
30+ do reserved "import"
31+ whitespace
32+ open <- optionMaybe (reserved "open")
33+ whitespace
34+ name <- intercalate "." <$> dotSep1 capVar
35+ case open of
36+ Just _ -> return (name, Hiding [])
37+ Nothing -> let how = try (whitespace >> (as' <|> importing'))
38+ in (,) name <$> option (As name) how
39+ where
40+ as' :: IParser ImportMethod
41+ as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
42+
43+ importing' :: IParser ImportMethod
44+ importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"
compiler/Parse/Modules.hsdeleted−46
@@ -1,46 +0,0 @@
1−
2−module Parse.Modules (moduleDef, imports) where
3−
4−import Control.Applicative ((<$>), (<*>))
5−import Data.List (intercalate)
6−import Text.Parsec hiding (newline,spaces)
7−
8−import Ast
9−import Parse.Library
10−
11−varList :: IParser [String]
12−varList = parens $ commaSep1 (var <|> parens symOp)
13−
14−moduleDef :: IParser ([String], [String])
15−moduleDef = do
16− try (reserved "module")
17− whitespace
18− names <- dotSep1 capVar <?> "name of module"
19− whitespace
20− exports <- option [] varList
21− whitespace <?> "reserved word 'where'"
22− reserved "where"
23− return (names, exports)
24−
25−imports :: IParser Imports
26−imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
27−
28−
29−import' :: IParser (String, ImportMethod)
30−import' = do
31− reserved "import"
32− whitespace
33− open <- optionMaybe (reserved "open")
34− whitespace
35− name <- intercalate "." <$> dotSep1 capVar
36− case open of
37− Just _ -> return (name, Hiding [])
38− Nothing -> let how = try (whitespace >> (as' <|> importing'))
39− in (,) name <$> option (Importing []) how
40−
41−
42−as' :: IParser ImportMethod
43−as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
44−
45−importing' :: IParser ImportMethod
46−importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"
compiler/Parse/Parse.hsnew file+47
@@ -0,0 +1,47 @@
1+module Parse.Parse (program, dependencies) where
2+
3+import Control.Applicative ((<$>), (<*>))
4+import Control.Monad
5+import Data.Char (isSymbol, isDigit)
6+import Data.List (foldl',intercalate)
7+import Text.Parsec hiding (newline,spaces)
8+import qualified Text.PrettyPrint as P
9+
10+import qualified SourceSyntax.Module as S
11+import Parse.Helpers
12+import Parse.Binop (infixStmt, OpTable)
13+import Parse.Expression
14+import Parse.Type
15+import Parse.Module
16+import qualified Parse.Declaration as Decl
17+
18+freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
19+ freshLine
20+ Decl.declaration <?> "another datatype or variable definition"
21+
22+decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"
23+ (d:) <$> many freshDef
24+
25+program :: String -> Either [P.Doc] (S.Module t v)
26+program = setupParser $ do
27+ optional freshLine
28+ (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)
29+ is <- (do try (lookAhead $ reserved "import")
30+ imports `followedBy` freshLine) <|> return []
31+ declarations <- decls
32+ optional freshLine ; optional spaces ; eof
33+ return $ S.Module names exports is declarations
34+
35+dependencies :: String -> Either [P.Doc] (String, [String])
36+dependencies =
37+ let getName = intercalate "." . fst in
38+ setupParser $ do
39+ optional freshLine
40+ (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)
41+ <*> option [] (map fst <$> imports `followedBy` freshLine)
42+
43+setupParser :: IParser a -> String -> Either [P.Doc] a
44+setupParser p source =
45+ case iParse p "" source of
46+ Right result -> Right result
47+ Left err -> Left [ P.text $ "Parse error at " ++ show err ]
compiler/Parse/Parser.hsdeleted−59
@@ -1,59 +0,0 @@
1−module Parse.Parser (parseProgram, parseDependencies, parseInfix) where
2−
3−import Ast
4−import Control.Applicative ((<$>), (<*>))
5−import Control.Monad
6−import Data.Char (isSymbol, isDigit)
7−import Data.List (foldl',intercalate)
8−import Text.Parsec hiding (newline,spaces)
9−
10−import Parse.Library
11−import Parse.Binops (infixStmt, OpTable)
12−import Parse.Expr
13−import Parse.Types
14−import Parse.Modules
15−import Parse.Foreign
16−
17−
18−statement = choice (typeAlias:defs) <|> def <?> "datatype or variable definition"
19− where defs = map ((:[]) <$>) [ foreignDef, datatype ]
20−
21−freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
22− freshLine
23− statement <?> "another datatype or variable definition"
24−
25−defs1 = do d <- statement <?> "at least one datatype or variable definition"
26− concat <$> (d:) <$> many freshDef
27−
28−program = do
29− optional freshLine
30− (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)
31− is <- (do try (lookAhead $ reserved "import")
32− imports `followedBy` freshLine) <|> return []
33− statements <- defs1
34− optional freshLine ; optional spaces ; eof
35− return $ Module names exports is statements
36−
37−parseProgram = setupParser program
38−
39−parseDependencies :: String -> Either String (String, [String])
40−parseDependencies =
41− setupParser $ do
42− optional skip
43− (,) <$> option "Main" moduleName <*> option [] imprts
44− where
45− skip = try (manyTill anyChar (try (string "/**")))
46− imprts = fmap (map fst) imports `followedBy` freshLine
47− getName = intercalate "." . fst
48− moduleName = do optional freshLine
49− getName <$> moduleDef `followedBy` freshLine
50−
51−parseInfix :: String -> Either String OpTable
52−parseInfix = setupParser . many $ do
53− manyTill (whitespace <|> (anyChar >> return ())) freshLine
54− infixStmt
55−
56−setupParser p source =
57− case iParse p "" source of
58− Right result -> Right result
59− Left err -> Left $ "Parse error at " ++ show err
compiler/Parse/Pattern.hsnew file+134
@@ -0,0 +1,134 @@
1+
2+module Parse.Pattern (term, expr) where
3+
4+import Control.Applicative ((<$>),(<*>),pure)
5+import Control.Monad
6+import Control.Monad.State
7+import Data.Char (isUpper)
8+import Data.List (intercalate)
9+import Unique
10+import Text.Parsec hiding (newline,spaces,State)
11+import Text.Parsec.Indent
12+
13+import Parse.Helpers
14+import Parse.Literal
15+import qualified SourceSyntax.Pattern as Pattern
16+import SourceSyntax.Everything hiding (tuple)
17+
18+
19+basic :: IParser Pattern
20+basic = choice
21+ [ char '_' >> return PAnything
22+ , do v <- var
23+ return $ case v of
24+ "True" -> PLiteral (Boolean True)
25+ "False" -> PLiteral (Boolean False)
26+ c : _ -> if isUpper c then PData v [] else PVar v
27+ , do lit <- literal
28+ return $ case lit of
29+ Str s -> foldr combine (PData "[]" []) s
30+ where combine h t = PData "::" [PLiteral (Chr h),t]
31+ _ -> PLiteral lit
32+ ]
33+
34+asPattern :: Pattern -> IParser Pattern
35+asPattern pattern = do
36+ var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
37+ return $ case var of
38+ Just v -> PAlias v pattern
39+ Nothing -> pattern
40+
41+record :: IParser Pattern
42+record = PRecord <$> brackets (commaSep1 lowVar)
43+
44+tuple :: IParser Pattern
45+tuple = do ps <- parens (commaSep expr)
46+ return $ case ps of { [p] -> p; _ -> Pattern.tuple ps }
47+
48+list :: IParser Pattern
49+list = Pattern.list <$> braces (commaSep expr)
50+
51+term :: IParser Pattern
52+term =
53+ (choice [ record, tuple, list, basic ]) <?> "pattern"
54+
55+patternConstructor :: IParser Pattern
56+patternConstructor = do
57+ v <- intercalate "." <$> dotSep1 capVar
58+ case v of
59+ "True" -> return $ PLiteral (Boolean True)
60+ "False" -> return $ PLiteral (Boolean False)
61+ _ -> PData v <$> spacePrefix term
62+
63+expr :: IParser Pattern
64+expr = do
65+ patterns <- consSep1 (patternConstructor <|> term)
66+ asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
67+
68+{--
69+extract :: Pattern -> LExpr t v -> Unique (String, LExpr t v)
70+extract pattern body@(L t s _) =
71+ let loc = L t s in
72+ let fn x e = (x,e) in
73+ case pattern of
74+ PAnything -> return $ fn "_" body
75+ PVar x -> return $ fn x body
76+ PAlias x PAnything -> return $ fn x body
77+ PAlias x p -> do
78+ (x', body') <- extract p body
79+ return $ fn x (loc $ Let [FnDef x' [] (loc $ Var x)] body')
80+ PData name ps -> do
81+ x <- guid
82+ let a = '_' : show x
83+ return . fn a . loc $ Case (loc (Var a)) [(pattern, body)]
84+ PRecord fs -> do
85+ x <- guid
86+ let a = '_' : show x
87+ toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
88+ return . fn a . loc $ Let (map toDef fs) body
89+
90+extracts :: [Pattern] -> LExpr t v -> Unique ([String], LExpr t v)
91+extracts ps body = go [] (reverse ps) body
92+ where go args [] body = return (args, body)
93+ go args (p:ps) body = do (x,e) <- extract p body
94+ go (x:args) ps e
95+
96+flatten :: [Pattern] -> LExpr t v -> Unique (IParser [Def t v])
97+flatten patterns exp@(L t s _) =
98+ let loc = L t s in
99+ case patterns of
100+ PVar f : args -> do
101+ (as,e) <- extracts args exp
102+ return . return $
103+ if isOp (head f) then let [a,b] = as in [ OpDef f a b e ]
104+ else [ FnDef f as e ]
105+
106+ [p] -> return `liftM` matchSingle p exp p
107+
108+ _ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++
109+ ") cannot be used on the left-hand side of an assign statement."
110+
111+matchSingle :: Pattern -> LExpr t v -> Pattern -> Unique [Def t v]
112+matchSingle pat exp@(L t s _) p =
113+ let loc = L t s in
114+ case p of
115+ PData _ ps -> do
116+ x <- guid
117+ let v = '_' : show x
118+ dss <- mapM (matchSingle pat . loc $ Var v) ps
119+ return (FnDef v [] exp : concat dss)
120+
121+ PVar x ->
122+ return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]
123+
124+ PAlias x p' -> do
125+ subPat <- matchSingle p' (loc $ Var x) p'
126+ return $ (FnDef x [] (loc $ Case exp [(pat, loc $ Var x)])):subPat
127+
128+ PRecord fs -> do
129+ a <- (\x -> '_' : show x) `liftM` guid
130+ let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
131+ return (FnDef a [] exp : map toDef fs)
132+
133+ PAnything -> return []
134+--}
compiler/Parse/Patterns.hsdeleted−105
@@ -1,105 +0,0 @@
1−
2−module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where
3−
4−import Ast
5−import Located
6−import Control.Applicative ((<$>),(<*>))
7−import Control.Monad
8−import Control.Monad.State
9−import Data.Char (isUpper)
10−import Guid
11−import Text.Parsec hiding (newline,spaces,State)
12−import Text.Parsec.Indent
13−import Parse.Library
14−
15−patternBasic :: IParser Pattern
16−patternBasic =
17− choice [ char '_' >> return PAnything
18− , do x@(c:_) <- var
19− return $ if isUpper c then PData x [] else PVar x
20− ]
21−
22−patternRecord :: IParser Pattern
23−patternRecord = PRecord <$> brackets (commaSep1 lowVar)
24−
25−patternTuple :: IParser Pattern
26−patternTuple = do ps <- parens (commaSep patternExpr)
27− return $ case ps of { [p] -> p; _ -> ptuple ps }
28−
29−patternList :: IParser Pattern
30−patternList = plist <$> braces (commaSep patternExpr)
31−
32−patternTerm :: IParser Pattern
33−patternTerm = choice [ patternRecord, patternTuple, patternList, patternBasic ]
34− <?> "pattern"
35−
36−patternConstructor :: IParser Pattern
37−patternConstructor = PData <$> capVar <*> spacePrefix patternTerm
38−
39−patternExpr :: IParser Pattern
40−patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"
41−
42−makeLambda :: [Pattern] -> CExpr -> GuidCounter CExpr
43−makeLambda pats body = go (reverse pats) body
44− where go [] body = return body
45− go (p:ps) body@(L t s _) = do
46− (x,e) <- extract p body
47− go ps (L t s $ Lambda x e)
48−
49−extract :: Pattern -> CExpr -> GuidCounter (String, CExpr)
50−extract pattern body@(L t s _) =
51− let loc = L t s in
52− let fn x e = (x,e) in
53− case pattern of
54− PAnything -> return $ fn "_" body
55− PVar x -> return $ fn x body
56− PData name ps -> do
57− x <- guid
58− let a = '_' : show x
59− return . fn a . loc $ Case (loc (Var a)) [(pattern, body)]
60− PRecord fs -> do
61− x <- guid
62− let a = '_' : show x
63− toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
64− return . fn a . loc $ Let (map toDef fs) body
65−
66−extracts :: [Pattern] -> CExpr -> GuidCounter ([String], CExpr)
67−extracts ps body = go [] (reverse ps) body
68− where go args [] body = return (args, body)
69− go args (p:ps) body = do (x,e) <- extract p body
70− go (x:args) ps e
71−
72−flattenPatterns :: [Pattern] -> CExpr -> GuidCounter (IParser [Def])
73−flattenPatterns patterns exp@(L t s _) =
74− let loc = L t s in
75− case patterns of
76− PVar f : args -> do
77− (as,e) <- extracts args exp
78− return . return $
79− if isOp (head f) then let [a,b] = as in [ OpDef f a b e ]
80− else [ FnDef f as e ]
81−
82− [p] -> return `liftM` matchSingle p exp p
83−
84− _ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++
85− ") cannot be used on the left-hand side of an assign statement."
86−
87−matchSingle :: Pattern -> CExpr -> Pattern -> GuidCounter [Def]
88−matchSingle pat exp@(L t s _) p =
89− let loc = L t s in
90− case p of
91− PData _ ps -> do
92− x <- guid
93− let v = '_' : show x
94− dss <- mapM (matchSingle pat . loc $ Var v) ps
95− return (FnDef v [] exp : concat dss)
96−
97− PVar x ->
98− return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]
99−
100− PRecord fs -> do
101− a <- (\x -> '_' : show x) `liftM` guid
102− let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
103− return (FnDef a [] exp : map toDef fs)
104−
105− PAnything -> return []
compiler/Parse/Type.hsnew file+81
@@ -0,0 +1,81 @@
1+module Parse.Type where
2+
3+import Control.Applicative ((<$>),(<*>))
4+import Control.Monad (liftM,mapM)
5+import Data.Char (isLower)
6+import Data.List (lookup,intercalate)
7+import Text.Parsec
8+import Text.Parsec.Indent
9+
10+import SourceSyntax.Type as T
11+import Parse.Helpers
12+import Unique
13+
14+tvar :: IParser T.Type
15+tvar = T.Var <$> lowVar <?> "type variable"
16+
17+list :: IParser T.Type
18+list = listOf <$> braces expr
19+
20+tuple :: IParser T.Type
21+tuple = do ts <- parens (commaSep expr)
22+ return $ case ts of
23+ [t] -> t
24+ _ -> tupleOf ts
25+
26+record :: IParser T.Type
27+record =
28+ do char '{' ; whitespace
29+ ext <- extend
30+ fs <- fields
31+ dumbWhitespace ; char '}'
32+ return (T.Record fs ext)
33+ where
34+ extend = option T.EmptyRecord . try $ do
35+ t <- tvar
36+ whitespace >> string "|" >> whitespace
37+ return t
38+ fields = commaSep $ do
39+ lbl <- rLabel
40+ whitespace >> hasType >> whitespace
41+ (,) lbl <$> expr
42+
43+capTypeVar = intercalate "." <$> dotSep1 capVar
44+
45+constructor0 :: IParser T.Type
46+constructor0 =
47+ do name <- capTypeVar
48+ return (T.Data name [])
49+
50+term :: IParser T.Type
51+term = list <|> tuple <|> record <|> tvar <|> constructor0
52+
53+app :: IParser T.Type
54+app =
55+ do name <- capTypeVar <|> try tupleCtor <?> "type constructor"
56+ args <- spacePrefix term
57+ return (T.Data name args)
58+ where
59+ tupleCtor = do
60+ n <- length <$> parens (many (char ','))
61+ return $ "_Tuple" ++ show (if n == 0 then 0 else n+1)
62+
63+expr :: IParser T.Type
64+expr =
65+ do t1 <- app <|> term
66+ whitespace
67+ arr <- optionMaybe arrow
68+ whitespace
69+ case arr of
70+ Just _ -> T.Lambda t1 <$> expr
71+ Nothing -> return t1
72+
73+constructor :: IParser (String, [T.Type])
74+constructor = (,) <$> (capTypeVar <?> "another type constructor")
75+ <*> spacePrefix term
76+
77+readType :: String -> Type
78+readType str =
79+ case iParse expr "" str of
80+ Left err -> error (show err)
81+ Right tipe -> tipe
compiler/Parse/Types.hsdeleted−170
@@ -1,170 +0,0 @@
1−module Parse.Types where
2−
3−import Ast
4−import Control.Applicative ((<$>),(<*>))
5−import Control.Monad (liftM,mapM)
6−import Data.Char (isUpper,isLower)
7−import Data.Maybe (fromMaybe)
8−import Data.List (lookup,intercalate)
9−import Text.Parsec
10−import Text.Parsec.Indent
11−
12−import Located
13−import Parse.Library
14−import Types.Types hiding (parens,string)
15−import Guid
16−
17−data ParseType = VarPT String
18− | LambdaPT ParseType ParseType
19− | ADTPT String [ParseType]
20− | RecordPT (Maybe ParseType) [(String,ParseType)]
21− deriving (Show)
22−
23−listPT t = ADTPT "List" [t]
24−tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts
25−
26−typeVar :: IParser ParseType
27−typeVar = VarPT <$> lowVar <?> "type variable"
28−
29−typeList :: IParser ParseType
30−typeList = listPT <$> braces typeExpr
31−
32−typeTuple :: IParser ParseType
33−typeTuple = do ts <- parens (commaSep typeExpr)
34− return $ case ts of { [t] -> t ; _ -> tuplePT ts }
35−
36−typeRecord :: IParser ParseType
37−typeRecord = brackets (RecordPT <$> extend <*> fields)
38− where extend = optionMaybe . try $ do
39− t <- typeVar
40− whitespace >> string "|" >> whitespace
41− return t
42− fields = commaSep $ do
43− lbl <- rLabel
44− whitespace >> hasType >> whitespace
45− (,) lbl <$> typeExpr
46−
47−typeUnambiguous :: IParser ParseType
48−typeUnambiguous = typeList <|> typeTuple <|> typeRecord
49−
50−typeSimple :: IParser ParseType
51−typeSimple = VarPT <$> var
52−
53−typeApp :: IParser ParseType
54−typeApp = do name <- capVar <?> "type constructor"
55− args <- spacePrefix (typeUnambiguous <|> typeSimple)
56− return $ case args of
57− [] -> VarPT name
58− _ -> ADTPT name args
59−
60−typeExpr :: IParser ParseType
61−typeExpr = do
62− t1 <- typeVar <|> typeApp <|> typeUnambiguous
63− whitespace ; arr <- optionMaybe arrow ; whitespace
64− case arr of
65− Just _ -> LambdaPT t1 <$> typeExpr
66− Nothing -> return t1
67−
68−typeConstructor :: IParser (String, [ParseType])
69−typeConstructor = (,) <$> (capVar <?> "another type constructor")
70− <*> spacePrefix (typeSimple <|> typeUnambiguous)
71−
72−typeAlias :: IParser [Statement]
73−typeAlias = do
74− start <- getPosition
75− reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
76− forcedWS
77− alias <- capVar
78− args <- spacePrefix lowVar
79− whitespace ; string "=" ; whitespace
80− let n = length args
81− tipe <- typeExpr
82− end <- getPosition
83− case toTypeWith alias (zip args [1..n]) tipe of
84− Left msg -> fail msg
85− Right t -> return (TypeAlias alias [1..n] t : ctor)
86− where ctor = case tipe of
87− RecordPT _ kvs -> [toConstructor start end alias kvs]
88− _ -> []
89−
90−toConstructor start end alias kvs =
91− Definition (FnDef alias args (loc (Record rec)))
92− where
93− loc = pos start end
94− args = map fst kvs
95− rec = map (\a -> (a, [], loc (Var a))) args
96−
97−
98−typeAnnotation :: IParser Def
99−typeAnnotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)
100− where start = do v <- lowVar <|> parens symOp
101− whitespace ; hasType ; whitespace ; return v
102−
103−datatype :: IParser Statement
104−datatype = do
105− reserved "data" <?> "datatype definition (data T = A | B | ...)"
106− forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar
107− whitespace ; string "=" ; whitespace
108− tcs <- pipeSep1 typeConstructor
109− case toDatatype name args tcs of
110− Right dt -> return dt
111− Left msg -> fail msg
112−
113−beta = liftM VarT guid
114−
115−toType :: ParseType -> Type
116−toType pt =
117− let frees :: ParseType -> [String]
118− frees pt = case pt of
119− LambdaPT a b -> frees a ++ frees b
120− ADTPT _ ts -> concatMap frees ts
121− RecordPT t fs -> maybe [] frees t ++ concatMap (frees . snd) fs
122− VarPT (c:cs) | isLower c -> [c:cs]
123− | otherwise -> []
124− in case toTypeWith "" (zip (frees pt) [1..]) pt of
125− Right t -> t
126− Left _ -> VarT 0
127−
128−toTypeWith :: String -> [(String,X)] -> ParseType -> Either String Type
129−toTypeWith name tvarDict pt =
130− let msg x = "Type variable '" ++ x ++ "' is unbound in type '" ++ name ++ "'."
131− toT = toTypeWith name tvarDict
132− in case pt of
133− LambdaPT t1 t2 -> (==>) <$> toT t1 <*> toT t2
134− ADTPT name args -> ADT name <$> mapM toT args
135− RecordPT t fs -> do fs' <- mapM (\(x,pt) -> (,) x <$> toT pt) fs
136− ext <- maybe (return EmptyRecord) toT t
137− return (RecordT (recordT fs') ext)
138− VarPT x@(c:_)
139− | not (isLower c) -> return $ ADT x []
140− | otherwise -> VarT <$> case lookup x tvarDict of
141− Just v -> Right v
142− Nothing -> Left (msg x)
143−
144−
145−toDatatype name args tcs = Datatype name [1..n] <$> mapM toC tcs
146− where n = length args
147− toType = toTypeWith name (zip args [1..n])
148− toC (name,pt) = (,) name <$> mapM toType pt
149−
150−
151−toForeignType (LambdaPT t1 t2) =
152− fail $ "Elm's JavaScript event interface does not yet handle functions. " ++
153− "Only simple values can be imported and exported in this release."
154−
155−toForeignType (ADTPT "JSArray" args) =
156− ADT "JSArray" <$> mapM toForeignType args
157−
158−toForeignType (ADTPT name _) =
159− Left $ "'" ++ name ++ "' is not an exportable type " ++
160− "constructor. Only 'JSArray' is exportable."
161−
162−toForeignType (VarPT x@(c:_))
163− | x `elem` jsTypes = Right (ADT x [])
164− | isLower c =
165− Left $ "All exported types must be concrete types." ++ msg
166− | otherwise =
167− Left $ "'" ++ x ++ "' is not an exportable type." ++ msg
168− where
169− msg = " The following types are exportable: " ++ intercalate ", " jsTypes
170− jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]
compiler/Paths_El.hsnew file+15
@@ -0,0 +1,15 @@
1+-- This is a dummy file, but it should not be removed.
2+-- It makes it possible to build the compiler in GHCi, so you
3+-- can do some testing from within emacs (or whatever inferior
4+-- editor you use instead).
5+
6+module Paths_Elm where
7+
8+import Data.Version
9+import System.FilePath
10+
11+getDataFileName :: FilePath -> IO FilePath
12+getDataFileName path = return ("dist" </> "data" </> path)
13+
14+version :: Version
15+version = Version [0,8,0,3] []
compiler/SourceSyntax/Declaration.hsnew file+18
@@ -0,0 +1,18 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+module SourceSyntax.Declaration where
3+
4+import Data.Data
5+import qualified SourceSyntax.Expression as Expr
6+import SourceSyntax.Type
7+
8+data Declaration tipe var
9+ = Definition (Expr.Def tipe var)
10+ | Datatype String [String] [(String,[Type])]
11+ | TypeAlias String [String] Type
12+ | ImportEvent String (Expr.LExpr tipe var) String Type
13+ | ExportEvent String String Type
14+ | Fixity Assoc Int String
15+ deriving (Eq, Show)
16+
17+data Assoc = L | N | R
18+ deriving (Eq, Show)
compiler/SourceSyntax/Everything.hsnew file+17
@@ -0,0 +1,17 @@
1+module SourceSyntax.Everything
2+ (module SourceSyntax.Helpers,
3+ module SourceSyntax.Location,
4+ module SourceSyntax.Literal,
5+ module SourceSyntax.Pattern,
6+ module SourceSyntax.Expression,
7+ module SourceSyntax.Declaration,
8+ module SourceSyntax.Module
9+ ) where
10+
11+import SourceSyntax.Helpers
12+import SourceSyntax.Location
13+import SourceSyntax.Literal
14+import SourceSyntax.Pattern hiding (tuple, list, cons, nil, prettyParens)
15+import SourceSyntax.Expression
16+import SourceSyntax.Declaration hiding (Assoc(..))
17+import SourceSyntax.Module
compiler/SourceSyntax/Expression.hsnew file+130
@@ -0,0 +1,130 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+module SourceSyntax.Expression where
3+
4+import Data.Data
5+import Data.List (intercalate)
6+import qualified Text.Pandoc as Pandoc
7+import SourceSyntax.PrettyPrint
8+import Text.PrettyPrint as P
9+import qualified SourceSyntax.Helpers as Help
10+import qualified SourceSyntax.Location as Location
11+import qualified SourceSyntax.Pattern as Pattern
12+import qualified SourceSyntax.Type as Type
13+import qualified SourceSyntax.Literal as Literal
14+
15+type LExpr tipe var = Location.Located (Expr tipe var)
16+data Expr t v
17+ = Literal Literal.Literal
18+ | Var String
19+ | Range (LExpr t v) (LExpr t v)
20+ | ExplicitList [LExpr t v]
21+ | Binop String (LExpr t v) (LExpr t v)
22+ | Lambda Pattern.Pattern (LExpr t v)
23+ | App (LExpr t v) (LExpr t v)
24+ | MultiIf [(LExpr t v,LExpr t v)]
25+ | Let [Def t v] (LExpr t v)
26+ | Case (LExpr t v) [(Pattern.Pattern, LExpr t v)]
27+ | Data String [LExpr t v]
28+ | Access (LExpr t v) String
29+ | Remove (LExpr t v) String
30+ | Insert (LExpr t v) String (LExpr t v)
31+ | Modify (LExpr t v) [(String, LExpr t v)]
32+ | Record [(String, LExpr t v)]
33+ | Markdown Pandoc.Pandoc
34+ deriving (Eq, Show, Data, Typeable)
35+
36+data Def tipe var
37+ = Def Pattern.Pattern (LExpr tipe var)
38+ | TypeAnnotation String Type.Type
39+ deriving (Eq, Show, Data, Typeable)
40+
41+tuple es = Data ("_Tuple" ++ show (length es)) es
42+
43+delist (Location.L _ (Data "::" [h,t])) = h : delist t
44+delist _ = []
45+
46+saveEnvName = "_save_the_environment!!!"
47+
48+dummyLet defs =
49+ Location.none $ Let defs (Location.none $ Var saveEnvName)
50+
51+instance Pretty (Expr t v) where
52+ pretty expr =
53+ case expr of
54+ Literal lit -> pretty lit
55+ Var x -> variable x
56+ Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
57+ ExplicitList es -> P.brackets (commaCat (map pretty es))
58+ Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
59+ where op' = if Help.isOp op then op else "`" ++ op ++ "`"
60+ Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)
61+ in P.text "\\" <> P.sep ps <+> P.text "->" <+> pretty body
62+ App _ _ -> P.hang func 2 (P.sep args)
63+ where func:args = map prettyParens (collectApps (Location.none expr))
64+ MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
65+ where
66+ iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
67+ Let defs e ->
68+ P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
69+ , P.text "in" <+> pretty e ]
70+ Case e pats ->
71+ P.hang pexpr 2 (P.vcat (map pretty' pats))
72+ where
73+ pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
74+ pretty' (p,e) = pretty p <+> P.text "->" <+> pretty e
75+ Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
76+ Data "[]" [] -> P.text "[]"
77+ Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
78+ Access e x -> prettyParens e <> P.text "." <> P.text x
79+ Remove e x -> P.braces (pretty e <+> P.text "-" <+> P.text x)
80+ Insert (Location.L _ (Remove e y)) x v ->
81+ P.braces (pretty e <+> P.text "-" <+> P.text y <+> P.text "|" <+> P.text x <+> P.text "=" <+> pretty v)
82+ Insert e x v ->
83+ P.braces (pretty e <+> P.text "|" <+> P.text x <+> P.text "=" <+> pretty v)
84+
85+ Modify e fs ->
86+ P.braces $ P.hang (pretty e <+> P.text "|")
87+ 4
88+ (commaSep $ map field fs)
89+ where
90+ field (x,e) = P.text x <+> P.text "<-" <+> pretty e
91+
92+ Record fs ->
93+ P.braces $ P.nest 2 (commaSep $ map field fs)
94+ where
95+ field (x,e) = P.text x <+> P.text "=" <+> pretty e
96+
97+ Markdown _ -> P.text "[markdown| ... |]"
98+
99+instance Pretty (Def t v) where
100+ pretty def =
101+ case def of
102+ TypeAnnotation name tipe ->
103+ variable name <+> P.text ":" <+> pretty tipe
104+ Def pattern expr ->
105+ pretty pattern <+> P.text "=" <+> pretty expr
106+
107+collectApps lexpr@(Location.L _ expr) =
108+ case expr of
109+ App a b -> collectApps a ++ [b]
110+ _ -> [lexpr]
111+
112+collectLambdas lexpr@(Location.L _ expr) =
113+ case expr of
114+ Lambda pattern body ->
115+ let (ps, body') = collectLambdas body
116+ in (pretty pattern : ps, body')
117+ _ -> ([], lexpr)
118+
119+prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
120+ where
121+ needed =
122+ case expr of
123+ Binop _ _ _ -> True
124+ Lambda _ _ -> True
125+ App _ _ -> True
126+ MultiIf _ -> True
127+ Let _ _ -> True
128+ Case _ _ -> True
129+ Data name (x:xs) -> name /= "::"
130+ _ -> False
compiler/SourceSyntax/Helpers.hsnew file+18
@@ -0,0 +1,18 @@
1+
2+module SourceSyntax.Helpers where
3+
4+import qualified Data.Char as Char
5+
6+brkt :: String -> String
7+brkt s = "{ " ++ s ++ " }"
8+
9+isTuple :: String -> Bool
10+isTuple name =
11+ take 6 name == "_Tuple" && all Char.isDigit (drop 6 name)
12+
13+isOp :: String -> Bool
14+isOp = all isSymbol
15+
16+isSymbol :: Char -> Bool
17+isSymbol c =
18+ Char.isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
compiler/SourceSyntax/Literal.hsnew file+22
@@ -0,0 +1,22 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+module SourceSyntax.Literal where
3+
4+import Data.Data
5+import SourceSyntax.PrettyPrint
6+import qualified Text.PrettyPrint as PP
7+
8+data Literal = IntNum Int
9+ | FloatNum Float
10+ | Chr Char
11+ | Str String
12+ | Boolean Bool
13+ deriving (Eq, Ord, Data, Typeable, Show)
14+
15+instance Pretty Literal where
16+ pretty literal =
17+ case literal of
18+ IntNum n -> PP.int n
19+ FloatNum n -> PP.float n
20+ Chr c -> PP.quotes (PP.char c)
21+ Str s -> PP.text (show s)
22+ Boolean bool -> PP.text (show bool)
compiler/SourceSyntax/Location.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+module SourceSyntax.Location where
3+
4+import Data.Data
5+import Text.PrettyPrint
6+import SourceSyntax.PrettyPrint
7+import qualified Text.Parsec.Pos as Parsec
8+
9+data SrcPos = Pos { line :: Int, column :: Int }
10+ deriving (Eq, Ord, Data, Typeable)
11+
12+data SrcSpan = Span SrcPos SrcPos String | NoSpan String
13+ deriving (Eq, Ord, Data, Typeable)
14+
15+data Located e = L SrcSpan e
16+ deriving (Eq, Ord, Data, Typeable)
17+
18+none e = L (NoSpan (render $ pretty e)) e
19+noneNoDocs = L (NoSpan "")
20+
21+at start end e = L (Span (Pos (Parsec.sourceLine start) (Parsec.sourceColumn start))
22+ (Pos (Parsec.sourceLine end ) (Parsec.sourceColumn end ))
23+ (render $ pretty e)) e
24+
25+merge (L s1 _) (L s2 _) e = L (span (render $ pretty e)) e
26+ where span = case (s1,s2) of
27+ (Span start _ _, Span _ end _) -> Span start end
28+ (Span start end _, _) -> Span start end
29+ (_, Span start end _) -> Span start end
30+ (_, _) -> NoSpan
31+
32+mergeOldDocs (L s1 _) (L s2 _) e = L span e
33+ where span = case (s1,s2) of
34+ (Span start _ d1, Span _ end d2) -> Span start end (d1 ++ "\n\n" ++ d2)
35+ (Span _ _ _, _) -> s1
36+ (_, Span _ _ _) -> s2
37+ (_, _) -> NoSpan ""
38+
39+sameAs (L s _) = L s
40+
41+
42+instance Show SrcPos where
43+ show (Pos r c) = show r ++ "," ++ show c
44+
45+instance Show SrcSpan where
46+ show span =
47+ case span of
48+ NoSpan _ -> ""
49+ Span start end _ ->
50+ case line start == line end of
51+ False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
52+ True -> "line " ++ show (line end) ++ ", column " ++
53+ show (column start) ++ " to " ++ show (column end)
54+
55+instance Show e => Show (Located e) where
56+ show (L s e) = "L (" ++ show s ++ ") (" ++ show e ++ ")"
57+
58+instance Pretty a => Pretty (Located a) where
59+ pretty (L _ e) = pretty e
60+
compiler/SourceSyntax/Module.hsnew file+52
@@ -0,0 +1,52 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+module SourceSyntax.Module where
3+
4+import Data.Data
5+import Data.Binary
6+import Data.List (intercalate)
7+import qualified Data.Map as Map
8+import Control.Applicative ((<$>), (<*>))
9+import Control.Arrow (second)
10+
11+import SourceSyntax.Expression (LExpr)
12+import SourceSyntax.Declaration
13+import SourceSyntax.Type
14+import System.FilePath (joinPath)
15+import qualified Type.Type as Type
16+
17+data Module tipe var =
18+ Module [String] Exports Imports [Declaration tipe var]
19+ deriving (Show)
20+
21+type Exports = [String]
22+
23+type Imports = [(String, ImportMethod)]
24+data ImportMethod = As String | Importing [String] | Hiding [String]
25+ deriving (Eq, Ord, Show, Data, Typeable)
26+
27+data MetadataModule t v = MetadataModule {
28+ names :: [String],
29+ path :: FilePath,
30+ exports :: [String],
31+ imports :: [(String, ImportMethod)],
32+ program :: LExpr t v,
33+ types :: Map.Map String Type.Variable,
34+ fixities :: [(Assoc, Int, String)],
35+ aliases :: [(String, [String], Type)],
36+ datatypes :: [ (String, [String], [(String,[Type])]) ],
37+ foreignImports :: [(String, LExpr t v, String, Type)],
38+ foreignExports :: [(String, String, Type)]
39+}
40+
41+type Interfaces = Map.Map String ModuleInterface
42+type ADT = (String, [String], [(String,[Type])])
43+
44+data ModuleInterface = ModuleInterface {
45+ iTypes :: Map.Map String Type,
46+ iAdts :: [ADT],
47+ iAliases :: [(String, [String], Type)]
48+} deriving Show
49+
50+instance Binary ModuleInterface where
51+ put modul = put (iTypes modul) >> put (iAdts modul) >> put (iAliases modul)
52+ get = ModuleInterface <$> get <*> get <*> get
compiler/SourceSyntax/Pattern.hsnew file+48
@@ -0,0 +1,48 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+module SourceSyntax.Pattern where
3+
4+import Data.List (intercalate)
5+import Data.Data
6+import SourceSyntax.Helpers as Help
7+import SourceSyntax.PrettyPrint
8+import Text.PrettyPrint as PP
9+import SourceSyntax.Literal as Literal
10+
11+data Pattern = PData String [Pattern]
12+ | PRecord [String]
13+ | PAlias String Pattern
14+ | PVar String
15+ | PAnything
16+ | PLiteral Literal.Literal
17+ deriving (Eq, Ord, Data, Typeable, Show)
18+
19+cons h t = PData "::" [h,t]
20+nil = PData "[]" []
21+list = foldr cons nil
22+tuple es = PData ("_Tuple" ++ show (length es)) es
23+
24+
25+instance Pretty Pattern where
26+ pretty pattern =
27+ case pattern of
28+ PVar x -> variable x
29+ PLiteral lit -> pretty lit
30+ PRecord fs -> PP.braces (commaCat $ map PP.text fs)
31+ PAlias x p -> prettyParens p <+> PP.text "as" <+> PP.text x
32+ PAnything -> PP.text "_"
33+ PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
34+ where isCons = case hd of
35+ PData "::" _ -> True
36+ _ -> False
37+ PData name ps ->
38+ if isTuple name then
39+ PP.parens . commaCat $ map pretty ps
40+ else sep (PP.text name : map prettyParens ps)
41+
42+prettyParens pattern = parensIf needsThem (pretty pattern)
43+ where
44+ needsThem =
45+ case pattern of
46+ PData name (_:_) | not (isTuple name) -> True
47+ PAlias _ _ -> True
48+ _ -> False
compiler/SourceSyntax/PrettyPrint.hsnew file+18
@@ -0,0 +1,18 @@
1+
2+module SourceSyntax.PrettyPrint where
3+
4+import Text.PrettyPrint
5+import qualified SourceSyntax.Helpers as Help
6+
7+class Pretty a where
8+ pretty :: a -> Doc
9+
10+instance Pretty () where
11+ pretty () = empty
12+
13+commaCat docs = cat (punctuate comma docs)
14+commaSep docs = sep (punctuate comma docs)
15+
16+parensIf bool doc = if bool then parens doc else doc
17+
18+variable x = parensIf (Help.isOp x) (text x)
compiler/SourceSyntax/Type.hsnew file+85
@@ -0,0 +1,85 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+module SourceSyntax.Type where
3+
4+import Data.Binary
5+import Data.Data
6+import qualified Data.Map as Map
7+import qualified SourceSyntax.Helpers as Help
8+import Control.Applicative ((<$>), (<*>))
9+import SourceSyntax.PrettyPrint
10+import Text.PrettyPrint as P
11+
12+data Type = Lambda Type Type
13+ | Var String
14+ | Data String [Type]
15+ | EmptyRecord
16+ | Record [(String,Type)] Type
17+ deriving (Eq, Show, Data, Typeable)
18+
19+fieldMap :: [(String,a)] -> Map.Map String [a]
20+fieldMap fields =
21+ foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
22+
23+recordOf :: [(String,Type)] -> Type
24+recordOf fields = Record fields EmptyRecord
25+
26+listOf :: Type -> Type
27+listOf t = Data "_List" [t]
28+
29+tupleOf :: [Type] -> Type
30+tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
31+
32+
33+instance Pretty Type where
34+ pretty tipe =
35+ case tipe of
36+ Lambda t1 t2 -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
37+ where t:ts = collectLambdas tipe
38+ Var x -> P.text x
39+ Data "_List" [t] -> P.brackets (pretty t)
40+ Data name tipes
41+ | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes
42+ | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)
43+ EmptyRecord -> P.braces P.empty
44+ Record fields ext -> P.braces $ P.hang (pretty ext <+> P.text "|") 4 prettyFields
45+ where
46+ prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
47+ prettyFields = commaSep . map prettyField $ fields
48+
49+collectLambdas tipe =
50+ case tipe of
51+ Lambda arg@(Lambda _ _) body -> P.parens (pretty arg) : collectLambdas body
52+ Lambda arg body -> pretty arg : collectLambdas body
53+ _ -> [pretty tipe]
54+
55+prettyParens tipe = parensIf needed (pretty tipe)
56+ where
57+ needed =
58+ case tipe of
59+ Lambda _ _ -> True
60+ Data _ [] -> False
61+ Data _ _ -> True
62+ _ -> False
63+
64+instance Binary Type where
65+ put tipe =
66+ case tipe of
67+ Lambda t1 t2 ->
68+ putWord8 0 >> put t1 >> put t2
69+ Var x ->
70+ putWord8 1 >> put x
71+ Data ctor tipes ->
72+ putWord8 2 >> put ctor >> put tipes
73+ EmptyRecord ->
74+ putWord8 3
75+ Record fs ext ->
76+ putWord8 4 >> put fs >> put ext
77+
78+ get = do
79+ n <- getWord8
80+ case n of
81+ 0 -> Lambda <$> get <*> get
82+ 1 -> Var <$> get
83+ 2 -> Data <$> get <*> get
84+ 3 -> return EmptyRecord
85+ 4 -> Record <$> get <*> get
compiler/SourceSyntax/Variable.hsnew file+2
@@ -0,0 +1,2 @@
1+module SourceSyntax.Variable where
2+
compiler/Transform/Canonicalize.hsnew file+177
@@ -0,0 +1,177 @@
1+module Transform.Canonicalize (interface, metadataModule) where
2+
3+import Control.Arrow ((***))
4+import Control.Monad.Identity
5+import qualified Data.Map as Map
6+import qualified Data.Set as Set
7+import qualified Data.List as List
8+import qualified Data.Either as Either
9+import SourceSyntax.Module
10+import SourceSyntax.Expression
11+import SourceSyntax.Location as Loc
12+import SourceSyntax.Pattern
13+import SourceSyntax.Helpers (isOp)
14+import qualified SourceSyntax.Type as Type
15+import qualified Transform.SortDefinitions as SD
16+import Text.PrettyPrint as P
17+
18+
19+interface :: String -> ModuleInterface -> ModuleInterface
20+interface moduleName iface =
21+ ModuleInterface {
22+ iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface)),
23+ iAdts = map (both prefix renameCtors) (iAdts iface),
24+ iAliases = map (both prefix renameType') (iAliases iface)
25+ }
26+ where
27+ both f g (a,b,c) = (f a, b, g c)
28+ prefix name = moduleName ++ "." ++ name
29+
30+ pair name = (name, moduleName ++ "." ++ name)
31+ canon (name,_,_) = pair name
32+ canons = Map.fromList $ concat
33+ [ map canon (iAdts iface), map canon (iAliases iface) ]
34+
35+ renameCtors ctors =
36+ map (prefix *** map renameType') ctors
37+ renameType' =
38+ runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
39+
40+renameType :: (Monad m) => (String -> m String) -> Type.Type -> m Type.Type
41+renameType rename tipe =
42+ let rnm = renameType rename in
43+ case tipe of
44+ Type.Lambda a b -> Type.Lambda `liftM` rnm a `ap` rnm b
45+ Type.Var x -> return tipe
46+ Type.Data name ts -> Type.Data `liftM` rename name `ap` mapM rnm ts
47+ Type.EmptyRecord -> return tipe
48+ Type.Record fields ext -> Type.Record `liftM` mapM rnm' fields `ap` rnm ext
49+ where rnm' (f,t) = (,) f `liftM` rnm t
50+
51+metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)
52+metadataModule ifaces modul =
53+ do _ <- case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
54+ [] -> Right ()
55+ missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
56+ program' <- rename initialEnv (program modul)
57+ aliases' <- mapM (third renameType') (aliases modul)
58+ datatypes' <- mapM (third (mapM (second (mapM renameType')))) (datatypes modul)
59+ return $ modul { program = program', aliases = aliases', datatypes = datatypes' }
60+ where
61+ second f (a,b) = (,) a `fmap` f b
62+ third f (a,b,c) = (,,) a b `fmap` f c
63+ renameType' =
64+ Either.either (\err -> Left [P.text err]) return . renameType (replace initialEnv)
65+
66+ get1 (a,_,_) = a
67+ canon (name, importMethod) =
68+ let pair pre var = (pre ++ drop (length name + 1) var, var)
69+ iface = ifaces Map.! name
70+ allNames = concat [ Map.keys (iTypes iface)
71+ , map get1 (iAliases iface)
72+ , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]
73+ in case importMethod of
74+ As alias -> map (pair (alias ++ ".")) allNames
75+ Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames
76+ where vs = Set.fromList vars
77+ Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames
78+ where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
79+
80+ pair n = (n,n)
81+ localEnv = map pair (map get1 (aliases modul) ++ map get1 (datatypes modul))
82+ globalEnv = map pair $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool"] ++
83+ map (\n -> "_Tuple" ++ show n) [0..9]
84+ realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
85+ initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)
86+
87+
88+type Env = Map.Map String String
89+
90+extend :: Env -> Pattern -> Env
91+extend env pattern = Map.union (Map.fromList (zip xs xs)) env
92+ where xs = Set.toList (SD.boundVars pattern)
93+
94+
95+replace :: Env -> String -> Either String String
96+replace env v =
97+ if List.isPrefixOf "Native." v then return v else
98+ case Map.lookup v env of
99+ Just v' -> return v'
100+ Nothing -> Left $ "Could not find variable '" ++ v ++ "'." ++ msg
101+ where
102+ matches = filter (List.isInfixOf v) (Map.keys env)
103+ msg = if null matches then "" else
104+ "\nClose matches include: " ++ List.intercalate ", " matches
105+
106+rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)
107+rename env lexpr@(L s expr) =
108+ let rnm = rename env
109+ throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
110+ format = Either.either throw return
111+ in
112+ L s `liftM`
113+ case expr of
114+ Literal lit -> return expr
115+
116+ Range e1 e2 -> Range `liftM` rnm e1 `ap` rnm e2
117+
118+ Access e x -> Access `liftM` rnm e `ap` return x
119+
120+ Remove e x -> flip Remove x `liftM` rnm e
121+
122+ Insert e x v -> flip Insert x `liftM` rnm e `ap` rnm v
123+
124+ Modify e fs ->
125+ Modify `liftM` rnm e `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
126+
127+ Record fs -> Record `liftM` mapM frnm fs
128+ where
129+ frnm (f,e) = (,) f `liftM` rename env e
130+
131+ Binop op e1 e2 ->
132+ do op' <- format (replace env op)
133+ Binop op' `liftM` rnm e1 `ap` rnm e2
134+
135+ Lambda pattern e ->
136+ let env' = extend env pattern in
137+ Lambda pattern `liftM` rename env' e
138+
139+ App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2
140+
141+ MultiIf ps -> MultiIf `liftM` mapM grnm ps
142+ where grnm (b,e) = (,) `liftM` rnm b `ap` rnm e
143+
144+ Let defs e -> Let `liftM` mapM rename' defs `ap` rename env' e
145+ where
146+ env' = foldl extend env [ pattern | Def pattern _ <- defs ]
147+ rename' def =
148+ case def of
149+ Def p exp ->
150+ Def `liftM` format (renamePattern env' p) `ap` rename env' exp
151+ TypeAnnotation name tipe ->
152+ TypeAnnotation name `liftM` renameType (format . replace env') tipe
153+
154+ Var x -> Var `liftM` format (replace env x)
155+
156+ Data name es -> Data name `liftM` mapM rnm es
157+
158+ ExplicitList es -> ExplicitList `liftM` mapM rnm es
159+
160+ Case e cases -> Case `liftM` rnm e `ap` mapM branch cases
161+ where
162+ branch (pattern,e) = (,) `liftM` format (renamePattern env pattern)
163+ `ap` rename (extend env pattern) e
164+
165+ Markdown _ -> return expr
166+
167+
168+renamePattern :: Env -> Pattern -> Either String Pattern
169+renamePattern env pattern =
170+ case pattern of
171+ PVar _ -> return pattern
172+ PLiteral _ -> return pattern
173+ PRecord _ -> return pattern
174+ PAnything -> return pattern
175+ PAlias x p -> PAlias x `liftM` renamePattern env p
176+ PData name ps -> PData `liftM` replace env name
177+ `ap` mapM (renamePattern env) ps
compiler/Transform/Check.hsnew file+63
@@ -0,0 +1,63 @@
1+module Transform.Check (mistakes) where
2+
3+import Transform.SortDefinitions (boundVars)
4+import SourceSyntax.Everything
5+import qualified SourceSyntax.Type as T
6+import Data.List as List
7+import qualified Data.Map as Map
8+import qualified Data.Set as Set
9+import Data.Data
10+import Data.Generics.Uniplate.Data
11+import Text.PrettyPrint as P
12+
13+
14+mistakes :: (Data t, Data v) => [Declaration t v] -> [Doc]
15+mistakes decls =
16+ map P.text $ concatMap findErrors (getLets decls)
17+ where
18+ findErrors defs = duplicates defs ++ badOrder defs
19+
20+
21+getLets :: (Data t, Data v) => [Declaration t v] -> [[Def t v]]
22+getLets decls = defs : concatMap getSubLets defs
23+ where
24+ defs = concatMap (\d -> case d of Definition d -> [d] ; _ -> []) decls
25+
26+ getSubLets def =
27+ case def of
28+ Def pattern expr -> [ defs | Let defs _ <- universeBi expr ]
29+ TypeAnnotation _ _ -> []
30+
31+
32+duplicates :: [Def t v] -> [String]
33+duplicates defs =
34+ map defMsg (dups definitions) ++ map annMsg (dups annotations)
35+ where
36+ annotations = List.sort [ name | TypeAnnotation name _ <- defs ]
37+ definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]
38+
39+ dups = map head . filter ((>1) . length) . List.group
40+
41+ msg = "Syntax Error: There can only be one "
42+ defMsg x = msg ++ " definition of '" ++ x ++ "'."
43+ annMsg x = msg ++ " type annotation for '" ++ x ++ "'."
44+
45+
46+badOrder :: [Def t v] -> [String]
47+badOrder defs = go defs
48+ where
49+ msg x = "Syntax Error: The type annotation for '" ++ x ++
50+ "' must be directly above its definition."
51+
52+ go defs =
53+ case defs of
54+ TypeAnnotation name _ : Def (PVar name') _ : rest
55+ | name == name' -> go rest
56+
57+ TypeAnnotation name _ : rest -> [msg name] ++ go rest
58+
59+ _ : rest -> go rest
60+
61+ _ -> []
62+
63+
compiler/Transform/Optimize.hs+83−87
@@ -1,10 +1,8 @@
1−module Optimize (optimize) where
1+module Transform.Optimize (optimize) where
2
2
3−import Ast
3+import SourceSyntax.Everything
4−import Located
5−import Control.Arrow (second)
4+import Control.Arrow (second, (***))
6import Data.Char (isAlpha)
5import Data.Char (isAlpha)
7−import Substitute
8
6
9optimize (Module name ims exs stmts) =
7optimize (Module name ims exs stmts) =
10 Module name ims exs (map optimizeStmt stmts)
8 Module name ims exs (map optimizeStmt stmts)
@@ -15,122 +13,120 @@ optimizeStmt stmt = if stmt == stmt' then stmt' else optimizeStmt stmt'
15class Simplify a where
13class Simplify a where
16 simp :: a -> a
14 simp :: a -> a
17
15
18−instance Simplify Statement where
16+instance Simplify (Declaration t v) where
19 simp (Definition def) = Definition (simp def)
17 simp (Definition def) = Definition (simp def)
20 simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t
18 simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t
21 simp stmt = stmt
19 simp stmt = stmt
22
20
23−instance Simplify Def where
21+instance Simplify (Def t v) where
24− simp (FnDef func args e) = FnDef func args (simp e)
22+ simp (Def name e) = Def name (simp e)
25− simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)
26 simp x = x
23 simp x = x
27
24
28instance Simplify e => Simplify (Located e) where
25instance Simplify e => Simplify (Located e) where
29− simp (L t s e) = L t s (simp e)
26+ simp (L s e) = L s (simp e)
30
27
31−instance Simplify Expr where
28+instance Simplify (Expr t v) where
32 simp expr =
29 simp expr =
33 let f = simp in
30 let f = simp in
34 case expr of
31 case expr of
35 Range e1 e2 -> Range (f e1) (f e2)
32 Range e1 e2 -> Range (f e1) (f e2)
36− Binop op e1 e2 -> simp_binop op (f e1) (f e2)
33+ Binop op e1 e2 -> binop op (f e1) (f e2)
37 Lambda x e -> Lambda x (f e)
34 Lambda x e -> Lambda x (f e)
38− Record fs -> Record (map (\(f,as,e) -> (f, as, simp e)) fs)
35+ Record fs -> Record (map (second simp) fs)
39− App (L t s (Lambda x e1)) e2 ->
40− if isValue e2' then subst x e2' e1' else App (L t s (Lambda x ce1')) ce2'
41− where ce1'@(L _ _ e1') = f e1
42− ce2'@(L _ _ e2') = f e2
43 App e1 e2 -> App (f e1) (f e2)
36 App e1 e2 -> App (f e1) (f e2)
44− If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
45 Let defs e -> Let (map simp defs) (f e)
37 Let defs e -> Let (map simp defs) (f e)
46 Data name es -> Data name (map f es)
38 Data name es -> Data name (map f es)
39+ MultiIf es -> MultiIf . clipBranches $ map (f *** f) es
47 Case e cases -> Case (f e) (map (second f) cases)
40 Case e cases -> Case (f e) (map (second f) cases)
48 _ -> expr
41 _ -> expr
49
42
50−simp_if (L _ _ (Boolean b)) (L _ _ e2) (L _ _ e3) = if b then e2 else e3
43+
51−simp_if a b c = If a b c
44+clipBranches [] = []
45+clipBranches (e:es) =
46+ case e of
47+ (L _ (Literal (Boolean True)), _) -> [e]
48+ _ -> e : clipBranches es
49+
52
50
53isValue e =
51isValue e =
54− case e of { IntNum _ -> True
52+ case e of
55− ; FloatNum _ -> True
56− ; Chr _ -> True
57− ; Str _ -> True
58− ; Boolean _ -> True
53+ Literal _ -> True
59− ; Var _ -> True
54+ Var _ -> True
60− ; Data _ _ -> True
55+ Data _ _ -> True
61− ; _ -> False }
56+ _ -> False
62−
57+
63−simp_binop = binop
58+
64−
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 in
60+ let c1 = L s1
67− let c2 = L t2 s2 in
61+ c2 = L s2
62+ int = Literal . IntNum
63+ str = Literal . Str
64+ bool = Literal . Boolean
65+ in
68 case (op, e1, e2) of
66 case (op, e1, e2) of
69− (_, IntNum n, IntNum m) -> case op of
67+ (_, Literal (IntNum n), Literal (IntNum m)) ->
70− { "+" -> IntNum $ (+) n m
68+ case op of
71− ; "-" -> IntNum $ (-) n m
69+ { "+" -> int $ (+) n m
72− ; "*" -> IntNum $ (*) n m
70+ ; "-" -> int $ (-) n m
73− ; "^" -> IntNum $ n ^ m
71+ ; "*" -> int $ (*) n m
72+ ; "^" -> int $ n ^ m
74− ; "div" -> IntNum $ div n m
73+ ; "div" -> int $ div n m
75− ; "mod" -> IntNum $ mod n m
74+ ; "mod" -> int $ mod n m
76− ; "<" -> Boolean $ n < m
75+ ; "rem" -> int $ rem n m
77− ; ">" -> Boolean $ n < m
76+ ; "<" -> bool $ n < m
78− ; "<=" -> Boolean $ n <= m
77+ ; ">" -> bool $ n > m
79− ; ">=" -> Boolean $ n >= m
78+ ; "<=" -> bool $ n <= m
80− ; "==" -> Boolean $ n == m
79+ ; ">=" -> bool $ n >= m
81− ; "/=" -> Boolean $ n /= m
80+ ; "==" -> bool $ n == m
81+ ; "/=" -> bool $ n /= m
82− ; _ -> Binop op ce1 ce2 }
82+ ; _ -> Binop op ce1 ce2 }
83−
83+ {--
84 -- flip order to move lone integers to the left
84 -- flip order to move lone integers to the left
85 ("+", _, IntNum n) -> binop "+" ce2 ce1
85 ("+", _, IntNum n) -> binop "+" ce2 ce1
86 ("*", _, IntNum n) -> binop "*" ce2 ce1
86 ("*", _, IntNum n) -> binop "*" ce2 ce1
87
87
88 ("+", IntNum 0, _) -> e2
88 ("+", IntNum 0, _) -> e2
89− ("+", IntNum n, Binop "+" (L _ _ (IntNum m)) ce) ->
89+ ("+", IntNum n, Binop "+" (L _ (IntNum m)) ce) ->
90 binop "+" (c1 $ IntNum (n+m)) ce
90 binop "+" (c1 $ IntNum (n+m)) ce
91− ("+", Binop "+" (L _ _ (IntNum n)) ce1'
91+ ("+", Binop "+" (L _ (IntNum n)) ce1'
92− , Binop "+" (L _ _ (IntNum m)) ce2') ->
92+ , Binop "+" (L _ (IntNum m)) ce2') ->
93− binop "+" (notLocated $ IntNum (n+m)) (notLocated $ Binop "+" ce1' ce2')
93+ binop "+" (none $ IntNum (n+m)) (none $ Binop "+" ce1' ce2')
94
94
95 ("*", IntNum 0, _) -> e1
95 ("*", IntNum 0, _) -> e1
96 ("*", IntNum 1, _) -> e2
96 ("*", IntNum 1, _) -> e2
97− ("*", IntNum n, Binop "*" (L _ _ (IntNum m)) ce) ->
97+ ("*", IntNum n, Binop "*" (L _ (IntNum m)) ce) ->
98− binop "*" (notLocated $ IntNum (n*m)) ce
98+ binop "*" (none $ IntNum (n*m)) ce
99− ("*", Binop "*" (L _ _ (IntNum n)) ce1'
99+ ("*", Binop "*" (L _ (IntNum n)) ce1'
100− , Binop "*" (L _ _ (IntNum m)) ce2') ->
100+ , Binop "*" (L _ (IntNum m)) ce2') ->
101− binop "*" (notLocated $ IntNum (n*m)) (notLocated $ Binop "*" ce1' ce2')
101+ binop "*" (none $ IntNum (n*m)) (none $ Binop "*" ce1' ce2')
102
102
103 ("-", _, IntNum 0) -> e1
103 ("-", _, IntNum 0) -> e1
104 ("/", _, IntNum 1) -> e1
104 ("/", _, IntNum 1) -> e1
105 ("div", _, IntNum 1) -> e1
105 ("div", _, IntNum 1) -> e1
106−
106+--}
107− (_, Boolean n, Boolean m) -> case op of "&&" -> Boolean $ n && m
107+ (_, Literal (Boolean n), Literal (Boolean m)) ->
108− "||" -> Boolean $ n || m
108+ case op of
109+ "&&" -> bool $ n && m
110+ "||" -> bool $ n || m
109− _ -> Binop op ce1 ce2
111+ _ -> Binop op ce1 ce2
110−
112+
111− ("&&", Boolean True, _) -> e2
113+ ("&&", Literal (Boolean True), _) -> e2
112− ("&&", Boolean False, _) -> Boolean False
114+ ("&&", Literal (Boolean False), _) -> bool False
113− ("||", Boolean True, _) -> Boolean True
115+ ("||", Literal (Boolean True), _) -> bool True
114− ("||", Boolean False, _) -> e2
116+ ("||", Literal (Boolean False), _) -> e2
115−
117+
116− ("::", _, _) -> let (L _ _ e) = cons ce1 ce2 in e
118+ ("::", _, _) -> Data "::" [ce1, ce2]
117−
119+
118− ("++", Str s1, Str s2) -> Str $ s1 ++ s2
120+ ("++", Literal (Str s1), Literal (Str s2)) -> str $ s1 ++ s2
119− ("++", Str s1, Binop "++" (L _ _ (Str s2)) ce) ->
121+ ("++", Literal (Str s1), Binop "++" (L _ (Literal (Str s2))) ce) ->
120− Binop "++" (c1 $ Str $ s1 ++ s2) ce
122+ Binop "++" (c1 . str $ s1 ++ s2) ce
121− ("++", Binop "++" e (L _ _ (Str s1)), Str s2) ->
123+ ("++", Binop "++" e (L _ (Literal (Str s1))), Literal (Str s2)) ->
122− Binop "++" e (c1 $ Str $ s1 ++ s2)
124+ Binop "++" e (c1 . str $ s1 ++ s2)
123−
125+
124− ("++", Data "Nil" [], _) -> e2
126+ ("++", Data "[]" [], _) -> e2
125− ("++", _, Data "Nil" []) -> e1
127+ ("++", _, Data "[]" []) -> e1
126− ("++", Data "Cons" [h,t], _) -> Data "Cons" [h, notLocated $ binop "++" t ce2]
128+ ("++", Data "::" [h,t], _) -> Data "::" [h, none $ binop "++" t ce2]
127−
128− ("|>", _, _) -> App ce2 ce1
129− ("<|", _, _) -> App ce1 ce2
130− (".", _, _) ->
131− Lambda "x" (notLocated $
132− App ce1 (notLocated $ App ce2 (notLocated $ Var "x")))
133
129
134 _ | isAlpha (head op) || '_' == head op ->
130 _ | isAlpha (head op) || '_' == head op ->
135− App (notLocated $ App (notLocated $ Var op) ce1) ce2
131+ App (none $ App (none $ Var op) ce1) ce2
136− | otherwise -> Binop op ce1 ce2
132+ | otherwise -> Binop op ce1 ce2
compiler/Transform/Rename.hsdeleted−150
@@ -1,150 +0,0 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−module Rename (renameModule, derename, deprime) where
3−
4−import Ast
5−import Located
6−import Control.Arrow (first)
7−import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
8−import Control.Monad.State (evalState, State, get, put)
9−import Data.Char (isLower,isDigit)
10−import Guid
11−
12−derename var
13− | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
14− | otherwise = var
15−
16−renameModule :: Module -> Module
17−renameModule modul = run (rename deprime modul)
18−
19−class Rename a where
20− rename :: (String -> String) -> a -> GuidCounter a
21−
22−instance Rename Module where
23− rename env (Module name ex im stmts) = do stmts' <- renameStmts env stmts
24− return (Module name ex im stmts')
25−
26−instance Rename Def where
27− rename env (OpDef op a1 a2 e) =
28− do env' <- extends env [a1,a2]
29− OpDef op (env' a1) (env' a2) `liftM` rename env' e
30− rename env (FnDef f args e) =
31− do env' <- extends env args
32− FnDef (env f) (map env' args) `liftM` rename env' e
33− rename env (TypeAnnotation n t) = return (TypeAnnotation (env n) t)
34−
35−
36−instance Rename Statement where
37− rename env stmt =
38− case stmt of
39− Definition def -> Definition `liftM` rename env def
40− Datatype name args tcs ->
41− return $ Datatype name args $ map (first env) tcs
42− TypeAlias n xs t -> return (TypeAlias n xs t)
43− ImportEvent js base elm tipe ->
44− do base' <- rename env base
45− return $ ImportEvent js base' (env elm) tipe
46− ExportEvent js elm tipe ->
47− return $ ExportEvent js (env elm) tipe
48−
49−renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
50− mapM (rename env') stmts
51− where getNames stmt = case stmt of
52− Definition (FnDef n _ _) -> [n]
53− Datatype _ _ tcs -> map fst tcs
54− ImportEvent _ _ n _ -> [n]
55− _ -> []
56−
57−instance Rename a => Rename (Located a) where
58− rename env (L t s e) = L t s `liftM` rename env e
59−
60−instance Rename Expr where
61− rename env expr =
62− let rnm = rename env in
63− case expr of
64−
65− Range e1 e2 -> Range `liftM` rnm e1
66− `ap` rnm e2
67−
68− Access e x -> Access `liftM` rnm e
69− `ap` return x
70−
71− Remove e x -> flip Remove x `liftM` rnm e
72−
73− Insert e x v -> flip Insert x `liftM` rnm e
74− `ap` rnm v
75−
76− Modify e fs -> Modify `liftM` rnm e
77− `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
78−
79− Record fs -> Record `liftM` mapM frnm fs
80− where frnm (f,as,e) = do env' <- extends env as
81− e' <- rename env' e
82− return (f, map env' as, e')
83−
84− Binop op@(h:_) e1 e2 ->
85− let rop = if isLower h || '_' == h
86− then env op
87− else op
88− in Binop rop `liftM` rnm e1
89− `ap` rnm e2
90−
91− Lambda x e -> do
92− (rx, env') <- extend env x
93− Lambda rx `liftM` rename env' e
94−
95− App e1 e2 -> App `liftM` rnm e1
96− `ap` rnm e2
97−
98− If e1 e2 e3 -> If `liftM` rnm e1
99− `ap` rnm e2
100− `ap` rnm e3
101−
102− MultiIf ps -> MultiIf `liftM` mapM grnm ps
103− where grnm (b,e) = (,) `liftM` rnm b
104− `ap` rnm e
105−
106− Let defs e -> renameLet env defs e
107−
108− Var x -> return . Var $ env x
109−
110− Data name es -> Data name `liftM` mapM rnm es
111−
112− Case e cases -> Case `liftM` rnm e
113− `ap` mapM (patternRename env) cases
114−
115− _ -> return expr
116−
117−deprime = map (\c -> if c == '\'' then '$' else c)
118−
119−extend :: (String -> String) -> String -> GuidCounter (String, String -> String)
120−extend env x = do
121− n <- guid
122− let rx = deprime x ++ "_" ++ show n
123− return (rx, \y -> if y == x then rx else env y)
124−
125−extends :: (String -> String) -> [String] -> GuidCounter (String -> String)
126−extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
127−
128−patternExtend :: Pattern -> (String -> String) -> GuidCounter (Pattern, String -> String)
129−patternExtend pattern env =
130− case pattern of
131− PAnything -> return (PAnything, env)
132− PVar x -> first PVar `liftM` extend env x
133− PData name ps ->
134− first (PData name . reverse) `liftM` foldM f ([], env) ps
135− where f (rps,env') p = do (rp,env'') <- patternExtend p env'
136− return (rp:rps, env'')
137− PRecord fs ->
138− return (pattern, foldr (\f e n -> if n == f then f else env n) env fs)
139−
140−patternRename :: (String -> String) -> (Pattern, CExpr) -> GuidCounter (Pattern, CExpr)
141−patternRename env (p,e) = do
142− (rp,env') <- patternExtend p env
143− re <- rename env' e
144− return (rp,re)
145−
146−renameLet env defs e = do env' <- extends env $ concatMap getNames defs
147− defs' <- mapM (rename env') defs
148− Let defs' `liftM` rename env' e
149− where getNames (FnDef n _ _) = [n]
150− getNames _ = []
compiler/Transform/Replace.hs+6−3
@@ -20,6 +20,7 @@ replace y v expr =
20 Let defs e -> if y `elem` vs then Let defs e else Let (zip vs (map f es)) (f e)
20 Let defs e -> if y `elem` vs then Let defs e else Let (zip vs (map f es)) (f e)
21 where (vs,es) = unzip defs
21 where (vs,es) = unzip defs
22 Var x -> if x == y then v else Var x
22 Var x -> if x == y then v else Var x
23+ ExplicitList es -> ExplicitList (map f es)
23 Data name es -> Data name (map f es)
24 Data name es -> Data name (map f es)
24 Case e cases -> Case (f e) $ map (caseReplace y v) cases
25 Case e cases -> Case (f e) $ map (caseReplace y v) cases
25 _ -> expr
26 _ -> expr
@@ -32,8 +33,10 @@ patternVars :: Pattern -> Set String
32patternVars pattern =
33patternVars pattern =
33 case pattern of
34 case pattern of
34 PData _ ps -> unions (map patternVars ps)
35 PData _ ps -> unions (map patternVars ps)
35− PVar x -> singleton x
36+ PVar x -> singleton x
37+ PAsVar x p -> insert x (patternVars p)
36− PAnything -> empty
38+ PAnything -> empty
39+ PLiteral _ -> empty
37
40
38depth :: Expr -> Integer
41depth :: Expr -> Integer
39depth = depth' 0
42depth = depth' 0
@@ -51,7 +54,7 @@ depth' d expr =
51 Fold e1 e2 e3 -> maximum [f e1, f e2, f e3]
54 Fold e1 e2 e3 -> maximum [f e1, f e2, f e3]
52 Async e -> f e
55 Async e -> f e
53 Let defs e -> let (_,es) = unzip defs in maximum $ f e : map f es
56 Let defs e -> let (_,es) = unzip defs in maximum $ f e : map f es
54− Data "Cons" es -> maximum $ map (depth' d) es
57+ Data "::" es -> maximum $ map (depth' d) es
55 Data name es -> maximum $ 1 : map f es
58 Data name es -> maximum $ 1 : map f es
56 Case e cases -> maximum $ f e : map (f . snd) cases
59 Case e cases -> maximum $ f e : map (f . snd) cases
57 _ -> d
60 _ -> d
compiler/Transform/SortDefinitions.hsnew file+198
@@ -0,0 +1,198 @@
1+
2+module Transform.SortDefinitions (sortDefs, boundVars, flattenLets) where
3+
4+import Control.Monad.State
5+import Control.Applicative ((<$>))
6+import qualified Data.Set as Set
7+import qualified Data.Map as Map
8+import qualified SourceSyntax.Type as ST
9+import SourceSyntax.Everything
10+import qualified Data.Graph as Graph
11+import qualified Data.Map as Map
12+import qualified Data.Maybe as Maybe
13+
14+boundVars :: Pattern -> Set.Set String
15+boundVars pattern =
16+ case pattern of
17+ PVar x -> Set.singleton x
18+ PAlias x p -> Set.insert x (boundVars p)
19+ PData _ ps -> Set.unions (map boundVars ps)
20+ PRecord fields -> Set.fromList fields
21+ PAnything -> Set.empty
22+ PLiteral _ -> Set.empty
23+
24+ctors :: Pattern -> [String]
25+ctors pattern =
26+ case pattern of
27+ PVar x -> []
28+ PAlias x p -> ctors p
29+ PData ctor ps -> ctor : concatMap ctors ps
30+ PRecord fields -> []
31+ PAnything -> []
32+ PLiteral _ -> []
33+
34+free :: String -> State (Set.Set String) ()
35+free x = modify (Set.insert x)
36+
37+bound :: Set.Set String -> State (Set.Set String) ()
38+bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
39+
40+sortDefs :: LExpr t v -> LExpr t v
41+sortDefs expr = evalState (reorder expr) Set.empty
42+
43+flattenLets defs lexpr@(L _ expr) =
44+ case expr of
45+ Let ds body -> flattenLets (defs ++ ds) body
46+ _ -> (defs, lexpr)
47+
48+
49+reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)
50+reorder lexpr@(L s expr) =
51+ L s `liftM`
52+ case expr of
53+ -- Be careful adding and restricting freeVars
54+ Var x -> free x >> return expr
55+
56+ Lambda p e ->
57+ uncurry Lambda `liftM` bindingReorder (p,e)
58+
59+ Binop op e1 e2 ->
60+ do free op
61+ Binop op `liftM` reorder e1 `ap` reorder e2
62+
63+ Case e cases ->
64+ Case `liftM` reorder e `ap` mapM bindingReorder cases
65+
66+ Data name es ->
67+ do free name
68+ Data name `liftM` mapM reorder es
69+
70+ -- Just pipe the reorder though
71+ Literal _ -> return expr
72+
73+ Range e1 e2 ->
74+ Range `liftM` reorder e1 `ap` reorder e2
75+
76+ ExplicitList es ->
77+ ExplicitList `liftM` mapM reorder es
78+
79+ App e1 e2 ->
80+ App `liftM` reorder e1 `ap` reorder e2
81+
82+ MultiIf branches ->
83+ MultiIf `liftM` mapM reorderPair branches
84+
85+ Access e lbl ->
86+ Access `liftM` reorder e `ap` return lbl
87+
88+ Remove e lbl ->
89+ Remove `liftM` reorder e `ap` return lbl
90+
91+ Insert e lbl v ->
92+ Insert `liftM` reorder e `ap` return lbl `ap` reorder v
93+
94+ Modify e fields ->
95+ Modify `liftM` reorder e `ap` mapM reorderField fields
96+
97+ Record fields ->
98+ Record `liftM` mapM reorderField fields
99+
100+ Markdown _ -> return expr
101+
102+ -- Actually do some reordering
103+ Let defs body ->
104+ do body' <- reorder body
105+
106+ -- Sort defs into strongly connected components.This
107+ -- allows the programmer to write definitions in whatever
108+ -- order they please, we can still define things in order
109+ -- and generalize polymorphic functions when appropriate.
110+ sccs <- Graph.stronglyConnComp <$> buildDefDict defs
111+ let defss = map Graph.flattenSCC sccs
112+
113+ -- remove let-bound variables from the context
114+ let getPatterns def =
115+ case def of
116+ Def pattern _ -> pattern
117+ TypeAnnotation name _ -> PVar name
118+ forM (map getPatterns defs) $ \pattern -> do
119+ bound (boundVars pattern)
120+ mapM free (ctors pattern)
121+
122+ let addDefs ds bod = L s (Let (concatMap toDefs ds) bod)
123+ where
124+ toDefs (pattern, expr, Nothing) = [ Def pattern expr ]
125+ toDefs (PVar name, expr, Just tipe) =
126+ [ TypeAnnotation name tipe, Def (PVar name) expr ]
127+
128+ L _ let' = foldr addDefs body' defss
129+
130+ return let'
131+
132+
133+reorderField (label, expr) =
134+ (,) label `liftM` reorder expr
135+
136+reorderPair (e1,e2) =
137+ (,) `liftM` reorder e1 `ap` reorder e2
138+
139+bindingReorder :: (Pattern, LExpr t v) -> State (Set.Set String) (Pattern, LExpr t v)
140+bindingReorder (pattern,expr) =
141+ do expr' <- reorder expr
142+ bound (boundVars pattern)
143+ mapM free (ctors pattern)
144+ return (pattern, expr')
145+
146+
147+type PDef t v = (Pattern, LExpr t v, Maybe ST.Type)
148+
149+reorderAndGetDependencies :: PDef t v -> State (Set.Set String) (PDef t v, [String])
150+reorderAndGetDependencies (pattern, expr, mType) =
151+ do globalFrees <- get
152+ -- work in a fresh environment
153+ put Set.empty
154+ expr' <- reorder expr
155+ localFrees <- get
156+ -- merge with global frees
157+ modify (Set.union globalFrees)
158+ return ((pattern, expr', mType), Set.toList localFrees)
159+
160+
161+-- This also reorders the all of the sub-expressions in the Def list.
162+buildDefDict :: [Def t v] -> State (Set.Set String) [(PDef t v, Int, [Int])]
163+buildDefDict defs =
164+ do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)
165+ return $ realDeps (addKey pdefsDeps)
166+
167+ where
168+ getPDefs :: [Def t v] -> [PDef t v]
169+ getPDefs defs = map (\(p,(e,t)) -> (p,e,t)) $
170+ Map.toList $ go defs Map.empty Map.empty
171+ where
172+ go [] ds ts =
173+ Map.unions [ Map.difference ds ts
174+ , Map.intersectionWith (\(e,_) t -> (e,Just t)) ds ts ]
175+
176+ go (def:defs) ds ts =
177+ case def of
178+ Def p e -> go defs (Map.insert p (e, Nothing) ds) ts
179+ TypeAnnotation name tipe -> go defs ds (Map.insert (PVar name) tipe ts)
180+
181+ addKey :: [(PDef t v, [String])] -> [(PDef t v, Int, [String])]
182+ addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
183+
184+ variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]
185+ variableToKey ((pattern, _, _), key, _) =
186+ [ (var, key) | var <- Set.toList (boundVars pattern) ]
187+
188+ variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int
189+ variableToKeyMap pdefsDeps =
190+ Map.fromList (concatMap variableToKey pdefsDeps)
191+
192+ realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]
193+ realDeps pdefsDeps = map convert pdefsDeps
194+ where
195+ varDict = variableToKeyMap pdefsDeps
196+ convert (pdef, key, deps) =
197+ (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
198+
compiler/Transform/Substitute.hs+18−17
@@ -1,29 +1,30 @@
1+{-# OPTIONS_GHC -Wall #-}
1−module Substitute (subst) where
2+module Transform.Substitute (subst) where
2
3
3−import Ast
4+import SourceSyntax.Expression
4−import Located
5+import SourceSyntax.Location
5import Control.Arrow (second, (***))
6import Control.Arrow (second, (***))
6
7
7−subst :: String -> Expr -> Expr -> Expr
8+subst :: String -> Expr t v -> Expr t v -> Expr t v
8subst old new expr =
9subst old new expr =
9− let f (L t s e) = L t s (subst old new e) in
10+ let f (L s e) = L s (subst old new e) in
10 case expr of
11 case expr of
11 Range e1 e2 -> Range (f e1) (f e2)
12 Range e1 e2 -> Range (f e1) (f e2)
12− Access e x -> Access (f e) x
13+ ExplicitList es -> ExplicitList (map f es)
13− Remove e x -> Remove (f e) x
14− Insert e x v -> Insert (f e) x (f v)
15− Modify r fs -> Modify (f r) (map (second f) fs)
16− Record fs -> Record (map (\(lbl,as,e) -> (lbl,as,f e)) fs)
17 Binop op e1 e2 -> Binop op (f e1) (f e2)
14 Binop op e1 e2 -> Binop op (f e1) (f e2)
18− Lambda x e -> if x == old then expr else Lambda x (f e)
15+ Lambda p e -> Lambda p (f e)
19 App e1 e2 -> App (f e1) (f e2)
16 App e1 e2 -> App (f e1) (f e2)
20− If e1 e2 e3 -> If (f e1) (f e2) (f e3)
21 MultiIf ps -> MultiIf (map (f *** f) ps)
17 MultiIf ps -> MultiIf (map (f *** f) ps)
22− Let defs e -> Let (map substDef defs) (f e)
18+ Let defs body -> Let (map substDef defs) (f body)
23− where substDef (FnDef name vs e) = FnDef name vs (f e)
19+ where substDef (Def name e) = Def name (f e)
24− substDef (OpDef op a1 a2 e) = OpDef op a1 a2 (f e)
20+ substDef anno@(TypeAnnotation _ _) = anno
25− substDef x = x
26 Var x -> if x == old then new else expr
21 Var x -> if x == old then new else expr
27 Case e cases -> Case (f e) $ map (second f) cases
22 Case e cases -> Case (f e) $ map (second f) cases
28 Data name es -> Data name (map f es)
23 Data name es -> Data name (map f es)
24+ Access e x -> Access (f e) x
25+ Remove e x -> Remove (f e) x
26+ Insert e x v -> Insert (f e) x (f v)
27+ Modify r fs -> Modify (f r) (map (second f) fs)
28+ Record fs -> Record (map (second f) fs)
29+ Literal _ -> expr
29− _ -> expr
30+ Markdown _ -> expr
compiler/Type/Constrain/Declaration.hsnew file+68
@@ -0,0 +1,68 @@
1+module Type.Constrain.Declaration where
2+
3+import Control.Monad
4+import Control.Applicative ((<$>))
5+
6+import qualified Data.Map as Map
7+
8+import qualified Type.Constrain.Expression as TcExpr
9+import qualified Type.Environment as Env
10+
11+import SourceSyntax.Declaration
12+import qualified SourceSyntax.Everything as Src
13+import qualified SourceSyntax.Type as Type
14+
15+toExpr :: [Declaration t v] -> [Src.Def t v]
16+toExpr = concatMap toDefs
17+
18+toDefs :: Declaration t v -> [Src.Def t v]
19+toDefs decl =
20+ case decl of
21+ Definition def -> [def]
22+
23+ Datatype name tvars constructors -> concatMap toDefs constructors
24+ where
25+ toDefs (ctor, tipes) =
26+ let vars = take (length tipes) arguments
27+ tbody = Type.Data name $ map Type.Var tvars
28+ body = Src.none . Src.Data ctor $ map (Src.none . Src.Var) vars
29+ in [ Src.TypeAnnotation ctor $ foldr Type.Lambda tbody tipes
30+ , Src.Def (Src.PVar ctor) $ buildFunction body vars
31+ ]
32+
33+ TypeAlias name tvars tipe@(Type.Record fields ext) ->
34+ [ Src.TypeAnnotation name $ foldr Type.Lambda tipe args
35+ , Src.Def (Src.PVar name) $ buildFunction record vars ]
36+ where
37+ args = case ext of
38+ Type.EmptyRecord -> map snd fields
39+ _ -> map snd fields ++ [ext]
40+
41+ var = Src.none . Src.Var
42+ vars = take (length args) arguments
43+
44+ efields = zip (map fst fields) (map var vars)
45+ record = case ext of
46+ Type.EmptyRecord -> Src.none $ Src.Record efields
47+ _ -> foldl (\r (f,v) -> Src.none $ Src.Insert r f v) (var $ last vars) efields
48+
49+ -- Type aliases must be added to an extended equality dictionary,
50+ -- but they do not require any basic constraints.
51+ TypeAlias _ _ _ -> []
52+
53+ ImportEvent _ expr@(Src.L s _) name tipe ->
54+ [ Src.TypeAnnotation name tipe
55+ , Src.Def (Src.PVar name) (Src.L s $ Src.App (Src.L s $ Src.Var "constant") expr) ]
56+
57+ ExportEvent _ name tipe ->
58+ [ Src.TypeAnnotation name tipe ]
59+
60+ -- no constraints are needed for fixity declarations
61+ Fixity _ _ _ -> []
62+
63+
64+arguments :: [String]
65+arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show n) [1..]
66+
67+buildFunction body@(Src.L s _) vars =
68+ foldr (\p e -> Src.L s (Src.Lambda p e)) body (map Src.PVar vars)
compiler/Type/Constrain/Expression.hsnew file+215
@@ -0,0 +1,215 @@
1+module Type.Constrain.Expression where
2+
3+import qualified Data.List as List
4+import qualified Data.Map as Map
5+import qualified Data.Set as Set
6+import Control.Arrow (second)
7+import Control.Applicative ((<$>),(<*>))
8+import qualified Control.Monad as Monad
9+import Control.Monad.State
10+import Data.Traversable (traverse)
11+
12+import SourceSyntax.Location as Loc
13+import SourceSyntax.Pattern (Pattern(PVar))
14+import SourceSyntax.Expression
15+import qualified SourceSyntax.Type as SrcT
16+import Type.Type hiding (Descriptor(..))
17+import Type.Fragment
18+import qualified Type.Environment as Env
19+import qualified Type.Constrain.Literal as Literal
20+import qualified Type.Constrain.Pattern as Pattern
21+import qualified Transform.SortDefinitions as SD
22+
23+
24+constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint
25+constrain env (L span expr) tipe =
26+ let list t = Env.get env Env.types "_List" <| t
27+ and = L span . CAnd
28+ true = L span CTrue
29+ t1 === t2 = L span (CEqual t1 t2)
30+ x <? t = L span (CInstance x t)
31+ clet schemes c = L span (CLet schemes c)
32+ in
33+ case expr of
34+ Literal lit -> Literal.constrain env span lit tipe
35+
36+ Var name -> return (name <? tipe)
37+
38+ Range lo hi ->
39+ exists $ \x -> do
40+ clo <- constrain env lo x
41+ chi <- constrain env hi x
42+ return $ and [clo, chi, list x === tipe]
43+
44+ ExplicitList exprs ->
45+ exists $ \x -> do
46+ cs <- mapM (\e -> constrain env e x) exprs
47+ return . and $ list x === tipe : cs
48+
49+ Binop op e1 e2 ->
50+ exists $ \t1 ->
51+ exists $ \t2 -> do
52+ c1 <- constrain env e1 t1
53+ c2 <- constrain env e2 t2
54+ return $ and [ c1, c2, op <? (t1 ==> t2 ==> tipe) ]
55+
56+ Lambda p e ->
57+ exists $ \t1 ->
58+ exists $ \t2 -> do
59+ fragment <- Pattern.constrain env p t1
60+ c2 <- constrain env e t2
61+ let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
62+ (typeConstraint fragment /\ c2 ))
63+ return $ c /\ tipe === (t1 ==> t2)
64+
65+ App e1 e2 ->
66+ exists $ \t -> do
67+ c1 <- constrain env e1 (t ==> tipe)
68+ c2 <- constrain env e2 t
69+ return $ c1 /\ c2
70+
71+ MultiIf branches -> and <$> mapM constrain' branches
72+ where
73+ bool = Env.get env Env.types "Bool"
74+ constrain' (b,e) = do
75+ cb <- constrain env b bool
76+ ce <- constrain env e tipe
77+ return (cb /\ ce)
78+
79+ Case exp branches ->
80+ exists $ \t -> do
81+ ce <- constrain env exp t
82+ let branch (p,e) = do
83+ fragment <- Pattern.constrain env p t
84+ clet [toScheme fragment] <$> constrain env e tipe
85+ and . (:) ce <$> mapM branch branches
86+
87+ Data name exprs ->
88+ do pairs <- mapM pair exprs
89+ (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)
90+ return (cs /\ name <? ctipe)
91+ where
92+ pair e = do v <- var Flexible -- needs an ex
93+ return (e, VarN v)
94+
95+ step (t,c) (e,x) = do
96+ c' <- constrain env e x
97+ return (x ==> t, c /\ c')
98+
99+ Access e label ->
100+ exists $ \t ->
101+ constrain env e (record (Map.singleton label [tipe]) t)
102+
103+ Remove e label ->
104+ exists $ \t ->
105+ constrain env e (record (Map.singleton label [t]) tipe)
106+
107+ Insert e label value ->
108+ exists $ \tVal ->
109+ exists $ \tRec -> do
110+ cVal <- constrain env value tVal
111+ cRec <- constrain env e tRec
112+ let c = tipe === record (Map.singleton label [tVal]) tRec
113+ return (and [cVal, cRec, c])
114+
115+ Modify e fields ->
116+ exists $ \t -> do
117+ oldVars <- forM fields $ \_ -> var Flexible
118+ let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))
119+ cOld <- ex oldVars <$> constrain env e (record oldFields t)
120+
121+ newVars <- forM fields $ \_ -> var Flexible
122+ let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))
123+ let cNew = tipe === record newFields t
124+
125+ cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
126+
127+ return $ cOld /\ ex newVars (and (cNew : cs))
128+
129+ Record fields ->
130+ do vars <- forM fields $ \_ -> var Flexible
131+ cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
132+ let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))
133+ recordType = record fields' (TermN EmptyRecord1)
134+ return . ex vars . and $ tipe === recordType : cs
135+
136+ Markdown _ ->
137+ return ("Graphics.Element.markdown" <? tipe)
138+
139+ Let defs body ->
140+ do c <- case body of
141+ L _ (Var name) | name == saveEnvName -> return (L span CSaveEnv)
142+ _ -> constrain env body tipe
143+ (schemes, rqs, fqs, header, c2, c1) <-
144+ Monad.foldM (constrainDef env)
145+ ([], [], [], Map.empty, true, true)
146+ (collapseDefs defs)
147+ return $ clet schemes
148+ (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]
149+ (c1 /\ c))
150+
151+constrainDef env info (pattern, expr, maybeTipe) =
152+ let qs = [] -- should come from the def, but I'm not sure what would live there...
153+ (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info
154+ in
155+ case (pattern, maybeTipe) of
156+ (PVar name, Just tipe) ->
157+ do flexiVars <- mapM (\_ -> var Flexible) qs
158+ let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
159+ env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
160+ (vars, typ) <- Env.instantiateType env tipe Map.empty
161+ let scheme = Scheme { rigidQuantifiers = [],
162+ flexibleQuantifiers = flexiVars ++ vars,
163+ constraint = Loc.noneNoDocs CTrue,
164+ header = Map.singleton name typ }
165+ c <- constrain env' expr typ
166+ return ( scheme : schemes
167+ , rigidQuantifiers
168+ , flexibleQuantifiers
169+ , headers
170+ , c2
171+ , fl rigidQuantifiers c /\ c1 )
172+
173+ (PVar name, Nothing) ->
174+ do v <- var Flexible
175+ rigidVars <- mapM (\_ -> var Rigid) qs -- Some mistake may be happening here.
176+ -- Currently, qs is always the empty list.
177+ let tipe = VarN v
178+ inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
179+ env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
180+ c <- constrain env' expr tipe
181+ return ( schemes
182+ , rigidVars ++ rigidQuantifiers
183+ , v : flexibleQuantifiers
184+ , Map.insert name tipe headers
185+ , c /\ c2
186+ , c1 )
187+
188+
189+expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)
190+ -> [(Pattern, LExpr t v, Maybe SrcT.Type)]
191+expandPattern triple@(pattern, lexpr@(L s _), maybeType) =
192+ case pattern of
193+ PVar _ -> [triple]
194+ _ -> (PVar x, lexpr, maybeType) : map toDef vars
195+ where
196+ vars = Set.toList $ SD.boundVars pattern
197+ x = concat vars
198+ var = L s . Var
199+ toDef y = (PVar y, L s $ Case (var x) [(pattern, var y)], Nothing)
200+
201+collapseDefs :: [Def t v] -> [(Pattern, LExpr t v, Maybe SrcT.Type)]
202+collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty
203+ where
204+ go output defs typs [] =
205+ output ++ concatMap Map.elems [
206+ Map.intersectionWithKey (\k v t -> (PVar k, v, Just t)) defs typs,
207+ Map.mapWithKey (\k v -> (PVar k, v, Nothing)) (Map.difference defs typs) ]
208+ go output defs typs (d:ds) =
209+ case d of
210+ Def (PVar name) body ->
211+ go output (Map.insert name body defs) typs ds
212+ Def pattern body ->
213+ go ((pattern, body, Nothing) : output) defs typs ds
214+ TypeAnnotation name typ ->
215+ go output defs (Map.insert name typ typs) ds
compiler/Type/Constrain/Literal.hsnew file+21
@@ -0,0 +1,21 @@
1+module Type.Constrain.Literal where
2+
3+import SourceSyntax.Literal
4+import SourceSyntax.Location
5+import Type.Type
6+import Type.Environment as Env
7+
8+constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint
9+constrain env span literal tipe =
10+ do tipe' <- litType
11+ return . L span $ CEqual tipe tipe'
12+ where
13+ prim name = Env.get env Env.types name
14+
15+ litType =
16+ case literal of
17+ IntNum _ -> VarN `fmap` var (Is Number)
18+ FloatNum _ -> return (prim "Float")
19+ Chr _ -> return (prim "Char")
20+ Str _ -> return (TermN (App1 (prim "_List") (prim "Char")))
21+ Boolean _ -> return (prim "Bool")
compiler/Type/Constrain/Pattern.hsnew file+68
@@ -0,0 +1,68 @@
1+module Type.Constrain.Pattern where
2+
3+import Control.Arrow (second)
4+import Control.Applicative ((<$>))
5+import qualified Control.Monad as Monad
6+import qualified Data.List as List
7+import qualified Data.Maybe as Maybe
8+import qualified Data.Map as Map
9+
10+import SourceSyntax.Pattern
11+import SourceSyntax.PrettyPrint
12+import Text.PrettyPrint (render)
13+import qualified SourceSyntax.Location as Loc
14+import Type.Type
15+import Type.Fragment
16+import Type.Environment as Env
17+import qualified Type.Constrain.Literal as Literal
18+
19+
20+constrain :: Environment -> Pattern -> Type -> IO Fragment
21+constrain env pattern tipe =
22+ let span = Loc.NoSpan (render $ pretty pattern)
23+ t1 === t2 = Loc.L span (CEqual t1 t2)
24+ x <? t = Loc.L span (CInstance x t)
25+ in
26+ case pattern of
27+ PAnything -> return emptyFragment
28+
29+ PLiteral lit -> do
30+ c <- Literal.constrain env span lit tipe
31+ return $ emptyFragment { typeConstraint = c }
32+
33+ PVar name -> do
34+ v <- var Flexible
35+ return $ Fragment {
36+ typeEnv = Map.singleton name (VarN v),
37+ vars = [v],
38+ typeConstraint = VarN v === tipe
39+ }
40+
41+ PAlias name p -> do
42+ fragment <- constrain env p tipe
43+ return $ fragment {
44+ typeEnv = Map.insert name tipe (typeEnv fragment),
45+ typeConstraint = name <? tipe /\ typeConstraint fragment
46+ }
47+
48+ PData name patterns -> do
49+ (kind, cvars, args, result) <- freshDataScheme env name
50+ let msg = concat [ "Constructor '", name, "' expects ", show kind
51+ , " argument", if kind == 1 then "" else "s"
52+ , " but was given ", show (length patterns), "." ]
53+ if length patterns /= kind then error msg else do
54+ fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
55+ return $ fragment {
56+ typeConstraint = typeConstraint fragment /\ tipe === result,
57+ vars = cvars ++ vars fragment
58+ }
59+
60+ PRecord fields -> do
61+ pairs <- mapM (\name -> (,) name <$> var Flexible) fields
62+ let tenv = Map.fromList (map (second VarN) pairs)
63+ c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
64+ return $ Fragment {
65+ typeEnv = tenv,
66+ vars = map snd pairs,
67+ typeConstraint = c
68+ }
compiler/Type/Environment.hsnew file+161
@@ -0,0 +1,161 @@
1+module Type.Environment where
2+
3+import Control.Applicative ((<$>), (<*>))
4+import Control.Monad
5+import qualified Control.Monad.State as State
6+import qualified Data.Traversable as Traverse
7+import qualified Data.Map as Map
8+import Data.List (isPrefixOf)
9+import qualified Data.UnionFind.IO as UF
10+
11+import qualified SourceSyntax.Type as Src
12+import SourceSyntax.Module (ADT)
13+import Type.Type
14+
15+type TypeDict = Map.Map String Type
16+type VarDict = Map.Map String Variable
17+
18+data Environment = Environment {
19+ constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
20+ aliases :: Map.Map String ([String], Src.Type),
21+ types :: TypeDict,
22+ value :: TypeDict
23+}
24+
25+initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment
26+initialEnvironment datatypes aliases = do
27+ types <- makeTypes datatypes
28+ let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases
29+ env = Environment {
30+ constructor = Map.empty,
31+ value = Map.empty,
32+ types = types,
33+ aliases = aliases' }
34+
35+ return $ env { constructor = makeConstructors env datatypes }
36+
37+makeTypes :: [ADT] -> IO TypeDict
38+makeTypes datatypes =
39+ Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
40+ where
41+ nameAndKind (name, tvars, _) = (name, length tvars)
42+
43+ makeCtor (name, kind) = do
44+ ctor <- VarN <$> namedVar Constant name
45+ return (name, ctor)
46+
47+ tuple n = ("_Tuple" ++ show n, n)
48+
49+ kind n names = map (\name -> (name, n)) names
50+
51+ builtins :: [(String,Int)]
52+ builtins = concat [ map tuple [0..9]
53+ , kind 1 ["_List"]
54+ , kind 0 ["Int","Float","Char","Bool"]
55+ ]
56+
57+
58+makeConstructors :: Environment
59+ -> [ADT]
60+ -> Map.Map String (IO (Int, [Variable], [Type], Type))
61+makeConstructors env datatypes = Map.fromList builtins
62+ where
63+ list t = (types env Map.! "_List") <| t
64+
65+ inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
66+ inst numTVars tipe = do
67+ vars <- forM [1..numTVars] $ \_ -> var Flexible
68+ let (args, result) = tipe (map VarN vars)
69+ return (length args, vars, args, result)
70+
71+ tupleCtor n =
72+ let name = "_Tuple" ++ show n
73+ in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
74+
75+ builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
76+ builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
77+ , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
78+ ] ++ map tupleCtor [0..9]
79+ ++ concatMap (ctorToType env) datatypes
80+
81+
82+ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
83+ctorToType env (name, tvars, ctors) =
84+ zip (map fst ctors) (map inst ctors)
85+ where
86+ inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)
87+ inst ctor = do
88+ ((args, tipe), (dict,_)) <- State.runStateT (go ctor) (Map.empty, Map.empty)
89+ return (length args, Map.elems dict, args, tipe)
90+
91+
92+ go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)
93+ go (ctor, args) = do
94+ types <- mapM (instantiator env) args
95+ returnType <- instantiator env (Src.Data name (map Src.Var tvars))
96+ return (types, returnType)
97+
98+
99+get :: Environment -> (Environment -> Map.Map String a) -> String -> a
100+get env subDict key = Map.findWithDefault err key (subDict env)
101+ where
102+ err = error $ "Could not find type constructor '" ++ key ++ "' while checking types."
103+
104+
105+freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
106+freshDataScheme env name = get env constructor name
107+
108+instantiateType ::
109+ Environment -> Src.Type -> VarDict -> IO ([Variable], Type)
110+instantiateType env sourceType dict =
111+ do (tipe, (dict',_)) <- State.runStateT (instantiator env sourceType) (dict, Map.empty)
112+ return (Map.elems dict', tipe)
113+
114+instantiator :: Environment -> Src.Type
115+ -> State.StateT (VarDict, TypeDict) IO Type
116+instantiator env sourceType = go sourceType
117+ where
118+ go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type
119+ go sourceType =
120+ case sourceType of
121+ Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
122+
123+ Src.Var x -> do
124+ (dict, aliases) <- State.get
125+ case Map.lookup x dict of
126+ Just var -> return (VarN var)
127+ Nothing ->
128+ case Map.lookup x aliases of
129+ Just t -> return t
130+ Nothing ->
131+ do var <- State.liftIO $ namedVar flex x
132+ State.put (Map.insert x var dict, aliases)
133+ return (VarN var)
134+ where
135+ flex | "number" `isPrefixOf` x = Is Number
136+ | "comparable" `isPrefixOf` x = Is Comparable
137+ | "appendable" `isPrefixOf` x = Is Appendable
138+ | otherwise = Flexible
139+
140+ Src.Data "String" [] ->
141+ return (get env types "_List" <| get env types "Char")
142+
143+ Src.Data name ts -> do
144+ ts' <- mapM go ts
145+ case Map.lookup name (types env) of
146+ Just t -> return $ foldl (<|) t ts'
147+ Nothing ->
148+ case Map.lookup name (aliases env) of
149+ Nothing -> error $ "Could not find type constructor '" ++ name ++ "' while checking types."
150+ Just (tvars, t) ->
151+ let msg = "Type alias '" ++ name ++ "' expects " ++ show (length tvars) ++
152+ " but was given " ++ show (length ts')
153+ in if length ts' /= length tvars then error msg else
154+ do (dict, aliases) <- State.get
155+ State.put (dict, Map.union aliases . Map.fromList $ zip tvars ts')
156+ go t
157+
158+ Src.EmptyRecord -> return (TermN EmptyRecord1)
159+
160+ Src.Record fields ext ->
161+ TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)
compiler/Type/Fragment.hsnew file+28
@@ -0,0 +1,28 @@
1+module Type.Fragment where
2+
3+import qualified Data.List as List
4+import qualified Data.Map as Map
5+
6+import Type.Type
7+import SourceSyntax.Pattern
8+import SourceSyntax.Location (noneNoDocs)
9+
10+data Fragment = Fragment {
11+ typeEnv :: Map.Map String Type,
12+ vars :: [Variable],
13+ typeConstraint :: TypeConstraint
14+} deriving Show
15+
16+emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
17+
18+joinFragment f1 f2 = Fragment {
19+ typeEnv = Map.union (typeEnv f1) (typeEnv f2),
20+ vars = vars f1 ++ vars f2,
21+ typeConstraint = typeConstraint f1 /\ typeConstraint f2
22+}
23+
24+joinFragments = List.foldl' (flip joinFragment) emptyFragment
25+
26+
27+toScheme fragment =
28+ Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)
compiler/Type/Inference.hsnew file+51
@@ -0,0 +1,51 @@
1+module Type.Inference where
2+
3+import qualified Data.Map as Map
4+
5+import qualified Type.Type as T
6+import qualified Type.Environment as Env
7+import qualified Type.Constrain.Expression as TcExpr
8+import qualified Type.Constrain.Declaration as TcDecl
9+import qualified Type.Solve as Solve
10+
11+import SourceSyntax.Module as Module
12+import qualified SourceSyntax.Expression as Expr
13+import SourceSyntax.Location (Located, noneNoDocs)
14+import SourceSyntax.PrettyPrint
15+import Text.PrettyPrint
16+import qualified Type.State as TS
17+import Control.Monad.State
18+import Control.Arrow (second)
19+import Transform.SortDefinitions as Sort
20+
21+import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
22+ -- the IO monad. I don't think that'd be worthwhile.
23+
24+
25+infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)
26+infer interfaces modul = unsafePerformIO $ do
27+ env <- Env.initialEnvironment
28+ (datatypes modul ++ concatMap iAdts (Map.elems interfaces))
29+ (aliases modul ++ concatMap iAliases (Map.elems interfaces))
30+ ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
31+ do (_, vars, args, result) <- Env.freshDataScheme env name
32+ return (name, (vars, foldr (T.==>) result args))
33+
34+ importedVars <-
35+ forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->
36+ (,) name `fmap` Env.instantiateType env tipe Map.empty
37+
38+ let allTypes = ctors ++ importedVars
39+ vars = concatMap (fst . snd) allTypes
40+ header = Map.map snd (Map.fromList allTypes)
41+ environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
42+
43+ fvar <- T.var T.Flexible
44+ constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)
45+
46+ state <- execStateT (Solve.solve constraint) TS.initialState
47+ let errors = TS.sErrors state
48+ if null errors
49+ then return $ Right (Map.difference (TS.sSavedEnv state) header)
50+ else Left `fmap` sequence (reverse errors)
51+
compiler/Type/PrettyPrint.hsnew file+13
@@ -0,0 +1,13 @@
1+
2+module Type.PrettyPrint where
3+
4+import Text.PrettyPrint
5+
6+data ParensWhen = Fn | App | Never
7+
8+class PrettyType a where
9+ pretty :: ParensWhen -> a -> Doc
10+
11+commaSep docs = sep (punctuate comma docs)
12+
13+parensIf bool doc = if bool then parens doc else doc
compiler/Type/Solve.hsnew file+186
@@ -0,0 +1,186 @@
1+module Type.Solve (solve) where
2+
3+import Control.Monad
4+import Control.Monad.State
5+import qualified Data.UnionFind.IO as UF
6+import qualified Data.Map as Map
7+import qualified Data.Traversable as Traversable
8+import qualified Data.Maybe as Maybe
9+import qualified Data.List as List
10+import Type.Type
11+import Type.Unify
12+import qualified Type.Environment as Env
13+import qualified Type.State as TS
14+import qualified Text.PrettyPrint as P
15+import SourceSyntax.Location (Located(L), SrcSpan)
16+
17+
18+-- | Every variable has rank less than or equal to the maxRank of the pool.
19+-- This sorts variables into the young and old pools accordingly.
20+generalize :: TS.Pool -> StateT TS.SolverState IO ()
21+generalize youngPool = do
22+ youngMark <- TS.uniqueMark
23+ let youngRank = TS.maxRank youngPool
24+ insert dict var = do
25+ desc <- liftIO $ UF.descriptor var
26+ liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })
27+ return $ Map.insertWith (++) (rank desc) [var] dict
28+
29+ -- Sort the youngPool variables by rank.
30+ rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)
31+
32+ -- get the ranks right for each entry.
33+ -- start at low ranks so that we only have to pass
34+ -- over the information once.
35+ visitedMark <- TS.uniqueMark
36+ mapM (\(poolRank, vars) -> mapM (adjustRank youngMark visitedMark poolRank) vars) (Map.toList rankDict)
37+
38+ -- For variables that have rank lowerer than youngRank, register them in
39+ -- the old pool if they are not redundant.
40+ let registerIfNotRedundant var = do
41+ isRedundant <- liftIO $ UF.redundant var
42+ if isRedundant then return var else TS.register var
43+
44+ let rankDict' = Map.delete youngRank rankDict
45+ Traversable.traverse (mapM registerIfNotRedundant) rankDict'
46+
47+ -- For variables with rank youngRank
48+ -- If rank < youngRank: register in oldPool
49+ -- otherwise generalize
50+ let registerIfLowerRank var = do
51+ isRedundant <- liftIO $ UF.redundant var
52+ if isRedundant then return () else do
53+ desc <- liftIO $ UF.descriptor var
54+ if rank desc < youngRank
55+ then TS.register var >> return ()
56+ else let flex' = if flex desc == Flexible then Rigid else flex desc
57+ in liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
58+
59+ mapM registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
60+
61+ return ()
62+
63+
64+-- adjust the ranks of variables such that ranks never increase as you
65+-- move deeper into a variable.
66+adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int
67+adjustRank youngMark visitedMark groupRank variable =
68+ let adjust = adjustRank youngMark visitedMark groupRank in
69+ do desc <- liftIO $ UF.descriptor variable
70+ case () of
71+ () | mark desc == youngMark ->
72+ do rank' <- case structure desc of
73+ Nothing -> return groupRank
74+ Just term ->
75+ case term of
76+ App1 a b -> max `liftM` adjust a `ap` adjust b
77+ Fun1 a b -> max `liftM` adjust a `ap` adjust b
78+ Var1 x -> adjust x
79+ EmptyRecord1 -> return outermostRank
80+ Record1 fields extension ->
81+ do ranks <- mapM adjust (concat (Map.elems fields))
82+ rnk <- adjust extension
83+ return . maximum $ rnk : ranks
84+ liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })
85+ return rank'
86+
87+ | mark desc /= visitedMark ->
88+ do let rank' = min groupRank (rank desc)
89+ liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })
90+ return rank'
91+
92+ | otherwise -> return (rank desc)
93+
94+
95+
96+solve :: TypeConstraint -> StateT TS.SolverState IO ()
97+solve (L span constraint) =
98+ case constraint of
99+ CTrue -> return ()
100+
101+ CSaveEnv -> TS.saveLocalEnv
102+
103+ CEqual term1 term2 -> do
104+ t1 <- TS.flatten term1
105+ t2 <- TS.flatten term2
106+ unify span t1 t2
107+
108+ CAnd cs -> mapM_ solve cs
109+
110+ CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do
111+ oldEnv <- TS.getEnv
112+ mapM TS.introduce fqs
113+ solve constraint'
114+ TS.modifyEnv (\_ -> oldEnv)
115+
116+ CLet schemes constraint' -> do
117+ oldEnv <- TS.getEnv
118+ headers <- mapM (solveScheme span) schemes
119+ TS.modifyEnv $ \env -> Map.unions (headers ++ [env])
120+ solve constraint'
121+ TS.modifyEnv (\_ -> oldEnv)
122+
123+ CInstance name term -> do
124+ env <- TS.getEnv
125+ freshCopy <-
126+ case Map.lookup name env of
127+ Just tipe -> TS.makeInstance tipe
128+ Nothing
129+ | List.isPrefixOf "Native." name -> liftIO (var Flexible)
130+ | otherwise ->
131+ error ("Could not find '" ++ name ++ "' when solving type constraints.")
132+
133+ t <- TS.flatten term
134+ unify span freshCopy t
135+
136+solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
137+solveScheme span scheme =
138+ case scheme of
139+ Scheme [] [] constraint header -> do
140+ solve constraint
141+ Traversable.traverse TS.flatten header
142+
143+ Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do
144+ let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
145+ oldPool <- TS.getPool
146+
147+ -- fill in a new pool when working on this scheme's constraints
148+ freshPool <- TS.nextRankPool
149+ TS.switchToPool freshPool
150+ mapM TS.introduce quantifiers
151+ header' <- Traversable.traverse TS.flatten header
152+ solve constraint
153+
154+ allDistinct span rigidQuantifiers
155+ youngPool <- TS.getPool
156+ TS.switchToPool oldPool
157+ generalize youngPool
158+ mapM (isGeneric span) rigidQuantifiers
159+ return header'
160+
161+
162+-- Checks that all of the given variables belong to distinct equivalence classes.
163+-- Also checks that their structure is Nothing, so they represent a variable, not
164+-- a more complex term.
165+allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()
166+allDistinct span vars = do
167+ seen <- TS.uniqueMark
168+ let check var = do
169+ desc <- liftIO $ UF.descriptor var
170+ case structure desc of
171+ Just _ ->
172+ TS.addError span "Cannot generalize something that is not a type variable" var var
173+ Nothing -> do
174+ if mark desc == seen
175+ then TS.addError span "Duplicate variable during generalization" var var
176+ else return ()
177+ liftIO $ UF.setDescriptor var (desc { mark = seen })
178+ mapM_ check vars
179+
180+-- Check that a variable has rank == noRank, meaning that it can be generalized.
181+isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()
182+isGeneric span var = do
183+ desc <- liftIO $ UF.descriptor var
184+ if rank desc == noRank
185+ then return ()
186+ else TS.addError span "Cannot generalize. Variable must have not have a rank." var var
compiler/Type/State.hsnew file+201
@@ -0,0 +1,201 @@
1+module Type.State where
2+
3+import Type.Type
4+import qualified Data.Map as Map
5+import qualified Data.List as List
6+import qualified Type.Environment as Env
7+import qualified Data.UnionFind.IO as UF
8+import Control.Monad.State
9+import Control.Applicative ((<$>),(<*>), Applicative)
10+import qualified Data.Traversable as Traversable
11+import Text.PrettyPrint as P
12+import SourceSyntax.PrettyPrint
13+import SourceSyntax.Location
14+
15+-- Pool
16+-- Holds a bunch of variables
17+-- The rank of each variable is less than or equal to the pool's "maxRank"
18+-- The young pool exists to make it possible to identify these vars in constant time.
19+
20+data Pool = Pool {
21+ maxRank :: Int,
22+ inhabitants :: [Variable]
23+} deriving Show
24+
25+emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }
26+
27+-- Keeps track of the environment, type variable pool, and a list of errors
28+data SolverState = SS {
29+ sEnv :: Map.Map String Variable,
30+ sSavedEnv :: Map.Map String Variable,
31+ sPool :: Pool,
32+ sMark :: Int,
33+ sErrors :: [IO P.Doc]
34+}
35+
36+initialState = SS {
37+ sEnv = Map.empty,
38+ sSavedEnv = Map.empty,
39+ sPool = emptyPool,
40+ sMark = noMark + 1, -- The mark must never be equal to noMark!
41+ sErrors = []
42+}
43+
44+modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
45+modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
46+
47+addError span message t1 t2 =
48+ modify $ \state -> state { sErrors = err : sErrors state }
49+ where
50+ err = makeError <$> extraPretty t1 <*> extraPretty t2
51+
52+ location = case span of
53+ NoSpan msg -> ""
54+ Span p1 p2 msg ->
55+ if line p1 == line p2 then " on line " ++ show (line p1)
56+ else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
57+
58+ display msg = if null msg then "\n"
59+ else "\n" ++ unlines (map (" "++) $ lines msg)
60+
61+ src = case span of
62+ NoSpan msg -> display msg
63+ Span _ _ msg -> display msg
64+
65+ makeError pt1 pt2 =
66+ P.vcat [ P.text $ "Type error" ++ location ++ ":"
67+ , if null message then empty else P.vcat . map P.text $ lines message
68+ , P.text src
69+ , P.text " Expected Type:" <+> pt1
70+ , P.text " Actual Type:" <+> pt2 <> P.text "\n"
71+ ]
72+
73+switchToPool pool = modifyPool (\_ -> pool)
74+
75+getPool :: StateT SolverState IO Pool
76+getPool = sPool <$> get
77+
78+getEnv :: StateT SolverState IO (Map.Map String Variable)
79+getEnv = sEnv <$> get
80+
81+saveLocalEnv :: StateT SolverState IO ()
82+saveLocalEnv = do
83+ env <- sEnv <$> get
84+ modify $ \state -> state { sSavedEnv = env }
85+
86+uniqueMark :: StateT SolverState IO Int
87+uniqueMark = do
88+ state <- get
89+ let mark = sMark state
90+ put $ state { sMark = mark + 1 }
91+ return mark
92+
93+nextRankPool :: StateT SolverState IO Pool
94+nextRankPool = do
95+ pool <- getPool
96+ return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
97+
98+register :: Variable -> StateT SolverState IO Variable
99+register variable = do
100+ modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
101+ return variable
102+
103+introduce :: Variable -> StateT SolverState IO Variable
104+introduce variable = do
105+ pool <- getPool
106+ liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
107+ register variable
108+
109+flatten :: Type -> StateT SolverState IO Variable
110+flatten term =
111+ case term of
112+ VarN v -> return v
113+ TermN t -> do
114+ flatStructure <- traverseTerm flatten t
115+ pool <- getPool
116+ var <- liftIO . UF.fresh $ Descriptor {
117+ structure = Just flatStructure,
118+ rank = maxRank pool,
119+ flex = Flexible,
120+ name = Nothing,
121+ copy = Nothing,
122+ mark = noMark
123+ }
124+ register var
125+
126+makeInstance :: Variable -> StateT SolverState IO Variable
127+makeInstance var = do
128+ alreadyCopied <- uniqueMark
129+ freshVar <- makeCopy alreadyCopied var
130+ restore alreadyCopied var
131+ return freshVar
132+
133+makeCopy :: Int -> Variable -> StateT SolverState IO Variable
134+makeCopy alreadyCopied variable = do
135+ desc <- liftIO $ UF.descriptor variable
136+ case () of
137+ () | mark desc == alreadyCopied ->
138+ case copy desc of
139+ Just v -> return v
140+ Nothing -> error "This should be impossible."
141+
142+ | rank desc /= noRank || flex desc == Constant ->
143+ return variable
144+
145+ | otherwise -> do
146+ pool <- getPool
147+ newVar <- liftIO $ UF.fresh $ Descriptor {
148+ structure = Nothing,
149+ rank = maxRank pool,
150+ mark = noMark,
151+ flex = case flex desc of
152+ Is s -> Is s
153+ _ -> Flexible,
154+ copy = Nothing,
155+ name = case flex desc of
156+ Rigid -> Nothing
157+ _ -> name desc
158+ }
159+ register newVar
160+
161+ -- Link the original variable to the new variable. This lets us
162+ -- avoid making multiple copies of the variable we are instantiating.
163+ --
164+ -- Need to do this before recursively copying the structure of
165+ -- the variable to avoid looping on cyclic terms.
166+ liftIO $ UF.modifyDescriptor variable $ \desc ->
167+ desc { mark = alreadyCopied, copy = Just newVar }
168+
169+ -- Now we recursively copy the structure of the variable.
170+ -- We have already marked the variable as copied, so we
171+ -- will not repeat this work or crawl this variable again.
172+ case structure desc of
173+ Nothing -> return newVar
174+ Just term -> do
175+ newTerm <- traverseTerm (makeCopy alreadyCopied) term
176+ liftIO $ UF.modifyDescriptor newVar $ \desc ->
177+ desc { structure = Just newTerm }
178+ return newVar
179+
180+restore :: Int -> Variable -> StateT SolverState IO Variable
181+restore alreadyCopied variable = do
182+ desc <- liftIO $ UF.descriptor variable
183+ if mark desc /= alreadyCopied
184+ then return variable
185+ else do
186+ restoredStructure <-
187+ Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
188+ liftIO $ UF.modifyDescriptor variable $ \desc ->
189+ desc { mark = noMark, rank = noRank, structure = restoredStructure }
190+ return variable
191+
192+traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
193+traverseTerm f term =
194+ case term of
195+ App1 a b -> App1 <$> f a <*> f b
196+ Fun1 a b -> Fun1 <$> f a <*> f b
197+ Var1 x -> Var1 <$> f x
198+ EmptyRecord1 -> return EmptyRecord1
199+ Record1 fields ext ->
200+ Record1 <$> Traversable.traverse (mapM f) fields <*> f ext
201+
compiler/Type/Type.hsnew file+391
@@ -0,0 +1,391 @@
1+module Type.Type where
2+
3+import qualified Data.Char as Char
4+import qualified Data.List as List
5+import qualified Data.Map as Map
6+import qualified Data.UnionFind.IO as UF
7+import Type.PrettyPrint
8+import Text.PrettyPrint as P
9+import System.IO.Unsafe
10+import Control.Applicative ((<$>),(<*>))
11+import Control.Monad.State
12+import Data.Traversable (traverse)
13+import SourceSyntax.Location
14+import SourceSyntax.Helpers (isTuple)
15+import qualified SourceSyntax.Type as Src
16+
17+data Term1 a
18+ = App1 a a
19+ | Fun1 a a
20+ | Var1 a
21+ | EmptyRecord1
22+ | Record1 (Map.Map String [a]) a
23+ deriving Show
24+
25+data TermN a
26+ = VarN a
27+ | TermN (Term1 (TermN a))
28+ deriving Show
29+
30+record :: Map.Map String [TermN a] -> TermN a -> TermN a
31+record fs rec = TermN (Record1 fs rec)
32+
33+type Type = TermN Variable
34+type Variable = UF.Point Descriptor
35+
36+type SchemeName = String
37+type TypeName = String
38+
39+type Constraint a b = Located (BasicConstraint a b)
40+data BasicConstraint a b
41+ = CTrue
42+ | CSaveEnv
43+ | CEqual a a
44+ | CAnd [Constraint a b]
45+ | CLet [Scheme a b] (Constraint a b)
46+ | CInstance SchemeName a
47+ deriving Show
48+
49+data Scheme a b = Scheme {
50+ rigidQuantifiers :: [b],
51+ flexibleQuantifiers :: [b],
52+ constraint :: Constraint a b,
53+ header :: Map.Map String a
54+} deriving Show
55+
56+type TypeConstraint = Constraint Type Variable
57+type TypeScheme = Scheme Type Variable
58+
59+monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
60+
61+infixl 8 /\
62+
63+(/\) :: Constraint a b -> Constraint a b -> Constraint a b
64+a@(L s1 c1) /\ b@(L s2 c2) =
65+ case (c1, c2) of
66+ (CTrue, _) -> b
67+ (_, CTrue) -> a
68+ _ -> mergeOldDocs a b (CAnd [a,b])
69+
70+infixr 9 ==>
71+(==>) :: Type -> Type -> Type
72+a ==> b = TermN (Fun1 a b)
73+
74+f <| a = TermN (App1 f a)
75+
76+data Descriptor = Descriptor {
77+ structure :: Maybe (Term1 Variable),
78+ rank :: Int,
79+ flex :: Flex,
80+ name :: Maybe TypeName,
81+ copy :: Maybe Variable,
82+ mark :: Int
83+} deriving Show
84+
85+noRank = -1
86+outermostRank = 0 :: Int
87+
88+noMark = 0
89+initialMark = 1
90+
91+data Flex = Rigid | Flexible | Constant | Is SuperType
92+ deriving (Show, Eq)
93+
94+data SuperType = Number | Comparable | Appendable
95+ deriving (Show, Eq)
96+
97+namedVar flex name = UF.fresh $ Descriptor {
98+ structure = Nothing,
99+ rank = noRank,
100+ flex = flex,
101+ name = Just name,
102+ copy = Nothing,
103+ mark = noMark
104+ }
105+
106+var flex = UF.fresh $ Descriptor {
107+ structure = Nothing,
108+ rank = noRank,
109+ flex = flex,
110+ name = Nothing,
111+ copy = Nothing,
112+ mark = noMark
113+ }
114+
115+structuredVar structure = UF.fresh $ Descriptor {
116+ structure = Just structure,
117+ rank = noRank,
118+ flex = Flexible,
119+ name = Nothing,
120+ copy = Nothing,
121+ mark = noMark
122+ }
123+
124+
125+-- ex qs constraint == exists qs. constraint
126+ex :: [Variable] -> TypeConstraint -> TypeConstraint
127+ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s CTrue)
128+
129+-- fl qs constraint == forall qs. constraint
130+fl :: [Variable] -> TypeConstraint -> TypeConstraint
131+fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)
132+
133+exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint
134+exists f = do
135+ v <- var Flexible
136+ ex [v] <$> f (VarN v)
137+
138+
139+instance Show a => Show (UF.Point a) where
140+ show point = unsafePerformIO $ fmap show (UF.descriptor point)
141+
142+
143+instance PrettyType a => PrettyType (UF.Point a) where
144+ pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
145+
146+
147+instance PrettyType a => PrettyType (Located a) where
148+ pretty when (L _ e) = pretty when e
149+
150+
151+instance PrettyType a => PrettyType (Term1 a) where
152+ pretty when term =
153+ let prty = pretty Never in
154+ case term of
155+ App1 f x | P.render px == "_List" -> P.brackets (pretty Never x)
156+ | otherwise -> parensIf needed (px <+> pretty App x)
157+ where
158+ px = prty f
159+ needed = case when of
160+ App -> True
161+ _ -> False
162+
163+ Fun1 arg body ->
164+ parensIf needed (pretty Fn arg <+> P.text "->" <+> prty body)
165+ where
166+ needed = case when of
167+ Never -> False
168+ _ -> True
169+
170+ Var1 x -> prty x
171+
172+ EmptyRecord1 -> P.braces P.empty
173+
174+ Record1 fields ext -> P.braces (extend <+> commaSep prettyFields)
175+ where
176+ prettyExt = prty ext
177+ extend | P.render prettyExt == "{}" = P.empty
178+ | otherwise = prettyExt <+> P.text "|"
179+ mkPretty f t = P.text f <+> P.text ":" <+> prty t
180+ prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)
181+
182+
183+instance PrettyType a => PrettyType (TermN a) where
184+ pretty when term =
185+ case term of
186+ VarN x -> pretty when x
187+ TermN t1 -> pretty when t1
188+
189+
190+instance PrettyType Descriptor where
191+ pretty when desc =
192+ case (structure desc, name desc) of
193+ (Just term, _) -> pretty when term
194+ (_, Just name) -> if not (isTuple name) then P.text name else
195+ P.parens . P.text $ replicate (read (drop 6 name) - 1) ','
196+ _ -> P.text "?"
197+
198+
199+instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
200+ pretty _ constraint =
201+ let prty = pretty Never in
202+ case constraint of
203+ CTrue -> P.text "True"
204+ CSaveEnv -> P.text "SaveTheEnvironment!!!"
205+ CEqual a b -> prty a <+> P.text "=" <+> prty b
206+ CAnd [] -> P.text "True"
207+
208+ CAnd cs ->
209+ P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
210+
211+ CLet [Scheme [] fqs constraint header] (L _ CTrue) | Map.null header ->
212+ P.sep [ binder, pretty Never c ]
213+ where
214+ mergeExists vs (L _ c) =
215+ case c of
216+ CLet [Scheme [] fqs' c' _] (L _ CTrue) -> mergeExists (vs ++ fqs') c'
217+ _ -> (vs, c)
218+
219+ (fqs', c) = mergeExists fqs constraint
220+
221+ binder = if null fqs' then P.empty else
222+ P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."
223+
224+ CLet schemes constraint ->
225+ P.fsep [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)
226+ , P.text "in", pretty Never constraint ]
227+
228+ CInstance name tipe ->
229+ P.text name <+> P.text "<" <+> prty tipe
230+
231+instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
232+ pretty _ (Scheme rqs fqs (L _ constraint) headers) =
233+ P.sep [ forall, cs, headers' ]
234+ where
235+ prty = pretty Never
236+
237+ forall = if null rqs && null fqs then P.empty else
238+ P.text "\x2200" <+> frees <+> rigids
239+
240+ frees = P.hsep $ map prty fqs
241+ rigids = if null rqs then P.empty else P.braces . P.hsep $ map prty rqs
242+
243+ cs = case constraint of
244+ CTrue -> P.empty
245+ CAnd [] -> P.empty
246+ _ -> P.brackets (pretty Never constraint)
247+
248+ headers' = if Map.size headers > 0 then dict else P.empty
249+ dict = P.parens . commaSep . map prettyPair $ Map.toList headers
250+ prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t
251+
252+
253+extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc
254+extraPretty t = pretty Never <$> addNames t
255+
256+addNames :: (Crawl t) => t -> IO t
257+addNames value = do
258+ (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)
259+ let vars = map head . List.group $ List.sort rawVars
260+ suffix s = map (++s) (map (:[]) ['a'..'z'])
261+ allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]
262+ okayVars = filter (`notElem` vars) allVars
263+ runStateT (crawl rename value) (okayVars, 0, 0, 0)
264+ return value
265+ where
266+ getNames desc state@(vars, a, b, c) =
267+ let name' = name desc in
268+ case name' of
269+ Just var -> (name', (var:vars, a, b, c))
270+ Nothing -> (name', state)
271+
272+ rename desc state@(vars, a, b, c) =
273+ case name desc of
274+ Just var -> (Just var, state)
275+ Nothing ->
276+ case flex desc of
277+ Is Number -> (Just $ "number" ++ replicate a '\'', (vars, a+1, b, c))
278+ Is Comparable -> (Just $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))
279+ Is Appendable -> (Just $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))
280+ _ -> (Just $ head vars, (tail vars, a, b, c))
281+
282+
283+type CrawlState = ([String], Int, Int, Int)
284+
285+-- Code for traversing all the type data-structures and giving
286+-- names to the variables embedded deep in there.
287+class Crawl t where
288+ crawl :: (Descriptor -> CrawlState -> (Maybe TypeName, CrawlState))
289+ -> t
290+ -> StateT CrawlState IO t
291+
292+instance Crawl a => Crawl (Located a) where
293+ crawl nextState (L s e) = L s <$> crawl nextState e
294+
295+instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
296+ crawl nextState constraint =
297+ let rnm = crawl nextState in
298+ case constraint of
299+ CTrue -> return CTrue
300+ CSaveEnv -> return CSaveEnv
301+ CEqual a b -> CEqual <$> rnm a <*> rnm b
302+ CAnd cs -> CAnd <$> crawl nextState cs
303+ CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c
304+ CInstance name tipe -> CInstance name <$> rnm tipe
305+
306+instance Crawl a => Crawl [a] where
307+ crawl nextState list = mapM (crawl nextState) list
308+
309+instance (Crawl t, Crawl v) => Crawl (Scheme t v) where
310+ crawl nextState (Scheme rqs fqs c headers) =
311+ let rnm = crawl nextState in
312+ Scheme <$> rnm rqs <*> rnm fqs <*> crawl nextState c <*> return headers
313+
314+instance Crawl t => Crawl (TermN t) where
315+ crawl nextState tipe =
316+ case tipe of
317+ VarN x -> VarN <$> crawl nextState x
318+ TermN term -> TermN <$> crawl nextState term
319+
320+instance Crawl t => Crawl (Term1 t) where
321+ crawl nextState term =
322+ let rnm = crawl nextState in
323+ case term of
324+ App1 a b -> App1 <$> rnm a <*> rnm b
325+ Fun1 a b -> Fun1 <$> rnm a <*> rnm b
326+ Var1 a -> Var1 <$> rnm a
327+ EmptyRecord1 -> return EmptyRecord1
328+ Record1 fields ext ->
329+ Record1 <$> traverse (mapM rnm) fields <*> rnm ext
330+
331+instance Crawl a => Crawl (UF.Point a) where
332+ crawl nextState point = do
333+ desc <- liftIO $ UF.descriptor point
334+ desc' <- crawl nextState desc
335+ liftIO $ UF.setDescriptor point desc'
336+ return point
337+
338+instance Crawl Descriptor where
339+ crawl nextState desc = do
340+ state <- get
341+ let (name', state') = nextState desc state
342+ structure' <- traverse (crawl nextState) (structure desc)
343+ put state'
344+ return $ desc { name = name', structure = structure' }
345+
346+
347+toSrcType :: Variable -> IO Src.Type
348+toSrcType variable = do
349+ desc <- UF.descriptor =<< addNames variable
350+ case structure desc of
351+ Just term ->
352+ case term of
353+ App1 a b -> do
354+ Src.Data name ts <- toSrcType a
355+ b' <- toSrcType b
356+ return (Src.Data name (ts ++ [b']))
357+ Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b
358+ Var1 a -> toSrcType a
359+ EmptyRecord1 -> return Src.EmptyRecord
360+ Record1 fs ext -> do
361+ fs' <- traverse (mapM toSrcType) fs
362+ let fs'' = concat [ map ((,) name) ts | (name,ts) <- Map.toList fs' ]
363+ Src.Record fs'' <$> toSrcType ext
364+ Nothing ->
365+ case name desc of
366+ Just x@(c:cs) | Char.isLower c -> return (Src.Var x)
367+ | otherwise -> return (Src.Data x [])
368+ Nothing ->
369+ error $ concat
370+ [ "Problem converting the following type "
371+ , "from a type-checker type to a source-syntax type:"
372+ , P.render (pretty Never variable) ]
373+
374+
375+data AppStructure = List Variable | Tuple [Variable] | Other
376+
377+collectApps :: Variable -> IO AppStructure
378+collectApps variable = go [] variable
379+ where
380+ go vars variable = do
381+ desc <- UF.descriptor variable
382+ case (structure desc, vars) of
383+ (Nothing, [v] ) -> case name desc of
384+ Just "_List" -> return (List v)
385+ _ -> return Other
386+ (Nothing, vs ) -> case name desc of
387+ Just ctor | isTuple ctor -> return (Tuple vs)
388+ _ -> return Other
389+ (Just term, vs) -> case term of
390+ App1 a b -> go (vars ++ [b]) a
391+ _ -> return Other
compiler/Type/Unify.hsnew file+185
@@ -0,0 +1,185 @@
1+module Type.Unify (unify) where
2+
3+import Type.Type
4+import qualified Data.UnionFind.IO as UF
5+import qualified Data.Map as Map
6+import qualified Type.State as TS
7+import Control.Arrow (first,second)
8+import Control.Monad.State
9+import SourceSyntax.Location
10+
11+unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
12+unify span variable1 variable2 = do
13+ equivalent <- liftIO $ UF.equivalent variable1 variable2
14+ if equivalent then return ()
15+ else actuallyUnify span variable1 variable2
16+
17+actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
18+actuallyUnify span variable1 variable2 = do
19+ desc1 <- liftIO $ UF.descriptor variable1
20+ desc2 <- liftIO $ UF.descriptor variable2
21+ let unify' = unify span
22+
23+ name' :: Maybe String
24+ name' = case (name desc1, name desc2) of
25+ (Just name1, Just name2) ->
26+ case (flex desc1, flex desc2) of
27+ (_, Flexible) -> Just name1
28+ (Flexible, _) -> Just name2
29+ (Is Number, Is _) -> Just name1
30+ (Is _, Is Number) -> Just name2
31+ (Is _, Is _) -> Just name1
32+ (_, _) -> Nothing
33+ (Just name1, _) -> Just name1
34+ (_, Just name2) -> Just name2
35+ _ -> Nothing
36+
37+ flex' :: Flex
38+ flex' = case (flex desc1, flex desc2) of
39+ (f, Flexible) -> f
40+ (Flexible, f) -> f
41+ (Is Number, Is _) -> Is Number
42+ (Is _, Is Number) -> Is Number
43+ (Is super, Is _) -> Is super
44+ (_, _) -> Flexible
45+
46+ rank' :: Int
47+ rank' = min (rank desc1) (rank desc2)
48+
49+ merge1 :: StateT TS.SolverState IO ()
50+ merge1 = liftIO $ do
51+ if rank desc1 < rank desc2 then UF.union variable2 variable1
52+ else UF.union variable1 variable2
53+ UF.modifyDescriptor variable1 $ \desc ->
54+ desc { structure = structure desc1, flex = flex', name = name' }
55+
56+ merge2 :: StateT TS.SolverState IO ()
57+ merge2 = liftIO $ do
58+ if rank desc1 < rank desc2 then UF.union variable2 variable1
59+ else UF.union variable1 variable2
60+ UF.modifyDescriptor variable2 $ \desc ->
61+ desc { structure = structure desc2, flex = flex', name = name' }
62+
63+ merge = if rank desc1 < rank desc2 then merge1 else merge2
64+
65+ fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
66+ fresh structure = do
67+ var <- liftIO . UF.fresh $ Descriptor {
68+ structure = structure, rank = rank', flex = flex',
69+ name = name', copy = Nothing, mark = noMark
70+ }
71+ TS.register var
72+
73+ flexAndUnify var = do
74+ liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }
75+ unify' variable1 variable2
76+
77+ unifyNumber svar name
78+ | name `elem` ["Int","Float"] = flexAndUnify svar
79+ | otherwise = TS.addError span "Expecting a number (Int or Float)" variable1 variable2
80+
81+ comparableError str = TS.addError span (str ++ msg) variable1 variable2
82+ where msg = "Expecting something comparable such as an\n" ++
83+ "Int, Float, Char, or a list or tuple of comparables."
84+
85+ unifyComparable var name
86+ | name `elem` ["Int","Float","Char"] = flexAndUnify var
87+ | otherwise = comparableError ""
88+
89+ unifyComparableStructure varSuper varFlex =
90+ do struct <- liftIO $ collectApps varFlex
91+ case struct of
92+ Other -> comparableError ""
93+ List v -> do flexAndUnify varSuper
94+ unify' v =<< liftIO (var $ Is Comparable)
95+ Tuple vs
96+ | length vs > 6 ->
97+ comparableError "Cannot compare a tuple with more than 6 elements.\n"
98+ | otherwise ->
99+ do flexAndUnify varSuper
100+ cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)
101+ zipWithM_ unify' vs cmpVars
102+
103+ unifyAppendable varSuper varFlex =
104+ do struct <- liftIO $ collectApps varFlex
105+ case struct of
106+ List _ -> flexAndUnify varSuper
107+ _ -> comparableError ""
108+
109+ superUnify =
110+ case (flex desc1, flex desc2, name desc1, name desc2) of
111+ (Is super1, Is super2, _, _)
112+ | super1 == super2 -> merge
113+ (Is Number, Is Comparable, _, _) -> merge1
114+ (Is Comparable, Is Number, _, _) -> merge2
115+
116+ (Is Number, _, _, Just name) -> unifyNumber variable1 name
117+ (_, Is Number, Just name, _) -> unifyNumber variable2 name
118+
119+ (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
120+ (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
121+ (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
122+ (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
123+
124+ (Is Appendable, _, _, Just "Text.Text") -> flexAndUnify variable1
125+ (_, Is Appendable, Just "Text.Text", _) -> flexAndUnify variable2
126+ (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
127+ (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
128+
129+ _ -> TS.addError span "" variable1 variable2
130+
131+ case (structure desc1, structure desc2) of
132+ (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
133+ (Nothing, _) | flex desc1 == Flexible -> merge2
134+ (_, Nothing) | flex desc2 == Flexible -> merge1
135+
136+ (Just (Var1 v), _) -> unify' v variable2
137+ (_, Just (Var1 v)) -> unify' v variable1
138+
139+ (Nothing, _) -> superUnify
140+ (_, Nothing) -> superUnify
141+
142+ (Just type1, Just type2) ->
143+ case (type1,type2) of
144+ (App1 term1 term2, App1 term1' term2') ->
145+ do merge
146+ unify' term1 term1'
147+ unify' term2 term2'
148+ (Fun1 term1 term2, Fun1 term1' term2') ->
149+ do merge
150+ unify' term1 term1'
151+ unify' term2 term2'
152+
153+ (EmptyRecord1, EmptyRecord1) ->
154+ return ()
155+
156+ (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
157+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
158+
159+ (Record1 fields1 ext1, Record1 fields2 ext2) ->
160+ do sequence . concat . Map.elems $ Map.intersectionWith (zipWith unify') fields1 fields2
161+ let mkRecord fs ext = liftIO . structuredVar $ Record1 fs ext
162+ case (Map.null fields1', Map.null fields2') of
163+ (True , True ) -> unify' ext1 ext2
164+ (True , False) -> do
165+ record2' <- mkRecord fields2' ext2
166+ unify' ext1 record2'
167+ (False, True ) -> do
168+ record1' <- mkRecord fields1' ext1
169+ unify' record1' ext2
170+ (False, False) -> do
171+ record1' <- mkRecord fields1' =<< liftIO (var Flexible)
172+ record2' <- mkRecord fields2' =<< liftIO (var Flexible)
173+ unify' record1' ext2
174+ unify' ext1 record2'
175+ where
176+ fields1' = unmerged fields1 fields2
177+ fields2' = unmerged fields2 fields1
178+
179+ unmerged a b = Map.filter (not . null) $ Map.union (Map.intersectionWith eat a b) a
180+
181+ eat (x:xs) (y:ys) = eat xs ys
182+ eat xs ys = xs
183+
184+ _ -> TS.addError span "" variable1 variable2
185+
compiler/Types/Alias.hsdeleted−138
@@ -1,138 +0,0 @@
1−{-# LANGUAGE PatternGuards #-}
2−module Types.Alias (dealias, get, mistakes) where
3−
4−import Ast
5−import Located
6−import Control.Arrow (second)
7−import Data.List (group,sort)
8−import Data.Maybe (mapMaybe)
9−import qualified Data.Map as Map
10−import qualified Data.Set as Set
11−import Types.Substitutions (subst)
12−import Types.Types
13−import Data.Generics.Uniplate.Data
14−
15−builtins :: [(String,([X],Type))]
16−builtins =
17− let touch = ("t0", time) : map (flip (,) int) ["x","y","x0","y0","id"]
18− state = [("string", string), ("selectionStart", int), ("selectionEnd", int)]
19− line = [("color", tipe "Color"), ("width", float),
20− ("cap", tipe "LineCap"), ("join", tipe "LineJoin"),
21− ("miterLimit", float), ("dashing", listOf int),
22− ("dashOffset", int)]
23− makeRecord fields =
24− RecordT (Map.fromList $ map (second (:[])) fields) EmptyRecord
25− in [ ("String", ([], listOf char)),
26− ("Time", ([], float)),
27− ("KeyCode", ([], int)),
28− ("Touch", ([], makeRecord touch)),
29− ("FieldState", ([], makeRecord state)),
30− ("LineStyle", ([], makeRecord line))
31− ]
32−
33−get :: [Statement] -> Map.Map String ([X],Type)
34−get stmts = Map.fromList (builtins ++ concatMap getAlias stmts)
35− where getAlias stmt = case stmt of
36− TypeAlias alias xs t -> [(alias, (xs,t))]
37− _ -> []
38−
39−dealias :: Map.Map String ([X],Type) -> Type -> Type
40−dealias aliases t =
41− let f = dealias aliases in
42− case t of
43− ADT name ts -> case Map.lookup name aliases of
44− Just (xs,t) -> f (subst (zip xs ts) t)
45− Nothing -> ADT name (map f ts)
46− LambdaT t u -> LambdaT (f t) (f u)
47− RecordT r t -> RecordT (Map.map (map f) r) (f t)
48− _ -> t
49−
50−mistakes :: [Statement] -> [String]
51−mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts
52−
53−badKinds :: [Statement] -> [String]
54−badKinds stmts = [msg tname | t <- universeBi stmts, tname <- badT t]
55− where
56− msg x = "Type Error: Type alias '" ++ x ++
57− "' was given the wrong number of arguments."
58−
59− badT :: Type -> [String]
60− badT (ADT name ts)
61− | Just (xs, _) <- Map.lookup name (get stmts),
62− length xs /= length ts = [name]
63− badT _ = []
64−
65−annotation :: Def -> Maybe String
66−annotation s =
67− case s of
68− TypeAnnotation name _ -> Just name
69− _ -> Nothing
70−
71−definition :: Def -> Maybe String
72−definition s =
73− case s of
74− FnDef name _ _ -> Just name
75− OpDef name _ _ _ -> Just name
76− _ -> Nothing
77−
78−checkTopLevelAndLets :: [Statement] -> (String -> [Def] -> [a]) -> [a]
79−checkTopLevelAndLets stmts fcheck =
80− fcheck "at top-level" topLevelDefs ++
81− concatMap (fcheck "in let binding") allLetDefs
82− where
83− topLevelDefs = mapMaybe maybeDef stmts
84− maybeDef (Definition d) = Just d
85− maybeDef _ = Nothing
86− allLetDefs = [defList | Let defList _ <- universeBi stmts]
87−
88−dups :: [Statement] -> [String]
89−dups stmts = checkTopLevelAndLets stmts $ \ctxt defs ->
90− let
91− dup :: (Def -> Maybe String) -> [String]
92− dup f = map head . filter ((>1) . length) . group . sort $ mapMaybe f defs
93−
94− msg = "Syntax Error: There can only be one "
95− defMsg x = msg ++ "definition of '" ++ x ++ "' " ++ ctxt ++ "."
96− annMsg x = msg ++ "type annotation for '" ++ x ++ "'" ++ ctxt ++ "."
97− in
98− map defMsg (dup definition) ++ map annMsg (dup annotation)
99−
100−badOrder :: [Statement] -> [String]
101−badOrder stmts = checkTopLevelAndLets stmts $ \ctxt defs ->
102− let
103− msg x = "Syntax Error: The type annotation for '" ++ x ++
104− "' must be directly above its definition in " ++ ctxt ++ "."
105− as = sort $ mapMaybe annotation defs
106− ds = sort $ mapMaybe definition defs
107−
108− expectedPairs :: [String] -> [String] -> [String]
109− expectedPairs as ds =
110− case (as,ds) of
111− (x:xs, y:ys) -> case compare x y of
112− LT -> expectedPairs xs (y:ys)
113− EQ -> x : expectedPairs xs ys
114− GT -> expectedPairs (x:xs) ys
115− ( _ , _ ) -> []
116−
117− actualPairs :: [Def] -> [String]
118− actualPairs stmts =
119− case stmts of
120− TypeAnnotation n _ : rest@(d : _) ->
121− (if Just n == definition d
122− then [n]
123− else []
124− ) ++ actualPairs rest
125− t:s:rest -> actualPairs (s:rest)
126− _ -> []
127−
128− missings :: [String] -> [String] -> [String]
129− missings expected actual =
130− case (expected, actual) of
131− (e:es, a:as) -> case compare e a of
132− LT -> e : missings es (a:as)
133− EQ -> missings es as
134− GT -> a : missings (e:es) as
135− ( [] , _ ) -> actual
136− ( _ , [] ) -> expected
137− in
138− map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs defs)
compiler/Types/Constrain.hsdeleted−332
@@ -1,332 +0,0 @@
1−
2−module Types.Constrain (constrain) where
3−
4−import Control.Arrow (second)
5−import Control.Monad (liftM,mapM,zipWithM,foldM)
6−import Control.Monad.State (evalState)
7−import Data.Char (isDigit)
8−import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf)
9−import qualified Data.Map as Map
10−import qualified Data.Set as Set
11−
12−import Ast
13−import Located
14−import Guid
15−
16−import Types.Types
17−import qualified Types.Substitutions as Subs
18−
19−import System.IO.Unsafe
20−
21−beta = VarT `liftM` guid
22−unionA = Map.unionWith (++)
23−unionsA = Map.unionsWith (++)
24−
25−getAliases :: [(String,ImportMethod)] -> [(String,Scheme)] -> [(String,Scheme)]
26−getAliases imports hints = concatMap aliasesFrom imports
27− where
28− -- Get the names of values that are now in scope after a particular
29− -- import statement.
30− aliasesFrom :: (String,ImportMethod) -> [(String,Scheme)]
31− aliasesFrom (name,method) =
32− let values = concatMap (getValue name) hints
33− prefixed name = map (\(n,t) -> (name ++ "." ++ n, t)) values
34− in case method of
35− As alias -> prefixed alias
36− Hiding vs -> prefixed name ++ filter (\(n,t) -> n `notElem` vs) values
37− Importing vs -> prefixed name ++ filter (\(n,t) -> n `elem` vs) values
38−
39− -- Take a module name and a type annotation. Return the unprefxed
40− -- type annotation: getValue "List" ("List.map",t) == [("map",t)]
41− getValue :: String -> (String,Scheme) -> [(String,Scheme)]
42− getValue inModule (name,tipe) =
43− case inModule `isPrefixOf` name of
44− True -> [ (drop (length inModule + 1) name, tipe) ]
45− False -> []
46−
47−findAmbiguous hints assumptions continue =
48− let potentialDups = map head . filter (\g -> length g > 1) . group . sort $
49− filter (elem '.') hints
50− dups = filter (\k -> Map.member k assumptions) potentialDups
51− in case dups of
52− n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++
53− "' could refer to " ++
54− intercalate ", " (filter (isSuffixOf n) hints)
55− _ -> continue
56−
57−mergeSchemes :: [Map.Map String Scheme]
58− -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)
59−mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
60− return (Map.unions ass, Set.unions css, Map.unions sss)
61− where
62− kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)
63− split (k,vs) =
64− let ps = zipWith (\s v -> (s++k,v)) (map (flip replicate '_') [0..]) vs
65− eq t u = L (Just $ msg ++ k) NoSpan (VarT t :=: VarT u)
66− msg = "the definition of "
67− in do xs <- mapM (\_ -> guid) vs
68− return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)
69− , case xs of
70− t:ts -> Set.fromList $ zipWith eq (t:ts) ts
71− [] -> Set.empty
72− , Map.fromList ps )
73−
74−constrain typeHints (Module _ _ imports stmts) = do
75− (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
76− aliasHints <- getAliases imports `liftM` typeHints
77− (as', cs', schemes) <- mergeSchemes schemess
78− let constraints = Set.unions (cs':css)
79− as = unionsA (as':ass)
80− allHints = Map.union schemes (Map.fromList aliasHints)
81− insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
82− assumptions <- foldM insert as (Map.keys schemes)
83− findAmbiguous (map fst aliasHints) assumptions $ do
84− let f k s vs = map (\v -> L (Just k) NoSpan $ v :<<: s) vs
85− cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
86− escapees = Map.keys $ Map.difference assumptions allHints
87− msg = "Warning! Type-checker could not find variables:\n" ++ intercalate ", " escapees
88− return $ case escapees of
89− [] -> Right (Set.toList constraints ++ cs)
90− _ -> unsafePerformIO (putStrLn msg) `seq` Right (Set.toList constraints ++ cs)
91− --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)
92−
93−type TVarMap = Map.Map String [X]
94−type ConstraintSet = Set.Set (Located Constraint)
95−
96−loc e span = L (Just $ show e) span
97−
98−gen :: CExpr -> GuidCounter (TVarMap, ConstraintSet, Type)
99−gen (L _ span expr) =
100− let loc' = L (Just $ show expr) span in
101− case expr of
102− Var x ->
103− do b <- guid
104− return (Map.singleton x [b], Set.empty, VarT b)
105−
106− App e1 e2 ->
107− do (a1,c1,t1) <- gen e1
108− (a2,c2,t2) <- gen e2
109− b <- beta
110− return ( unionA a1 a2
111− , Set.unions [c1,c2
112− ,Set.singleton . loc' $ t1 :=: (LambdaT t2 b)]
113− , b )
114−
115− Lambda x e ->
116− do (a,c,t) <- gen e
117− b <- beta
118− v <- guid
119− return ( Map.delete x a
120− , Set.union c . Set.fromList .
121− map (\x -> loc' $ VarT x :=: b) $
122− Map.findWithDefault [v] x a
123− , LambdaT b t )
124−
125− Let defs e ->
126− do (as,cs,t) <- gen e
127− (ass, schemes) <- liftM unzip (mapM defScheme defs)
128− let assumptions = unionsA (as:ass)
129− getName d = case d of FnDef f _ _ -> f
130− OpDef op _ _ _ -> op
131− TypeAnnotation n _ -> n
132− names = map getName defs
133− genCs name s = do
134− v <- guid
135− let vs = Map.findWithDefault [v] name assumptions
136− return $ map (\x -> loc name span $ x :<<: s) vs
137− cs' <- zipWithM genCs names schemes
138− return ( foldr Map.delete assumptions names
139− , Set.union (Set.fromList . concat $ cs') cs
140− , t )
141−
142− Case e cases ->
143− do (as,cs,t) <- gen e
144− (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases
145− return ( unionsA $ as:ass
146− , let cases' = map snd cases
147− locs = zipWith epos cases' (tail cases')
148− csts = zipWith (:=:) ts (tail ts)
149− cs' = Set.fromList (zipWith ($) locs csts)
150− in Set.unions $ cs' : cs : css
151− , head ts)
152−
153− If e1 e2 e3 ->
154− do (a1,c1,t1) <- gen e1
155− (a2,c2,t2) <- gen e2
156− (a3,c3,t3) <- gen e3
157− return ( unionsA [a1,a2,a3]
158− , let c4 = Set.fromList [ loc e1 span (t1 :=: bool)
159− , loc' (t2 :=: t3) ]
160− in Set.unions [c1,c2,c3,c4]
161− , t2 )
162−
163− Data name es ->
164− gen $ foldl' (\f x -> epos f x $ App f x) (loc' $ Var name) es
165−
166− Binop op e1 e2 ->
167− gen $ loc' (App (loc' $ App (loc' $ Var op) e1) e2)
168−
169− Access e label ->
170− do (as,cs,rtype) <- gen e
171− t <- beta
172− rtype' <- beta
173− let fs = Map.singleton label [t]
174− c = (loc' (RecordT fs rtype' :=: rtype))
175− return (as, Set.insert c cs, t)
176−
177− Remove e x ->
178− do (as,cs,rtype) <- gen e
179− t <- beta
180− rtype' <- beta
181− let c = (loc' (RecordT (Map.singleton x [t]) rtype' :=: rtype))
182− return (as, Set.insert c cs, rtype')
183−
184− Insert e x v ->
185− do (eas,ecs,etype) <- gen e
186− (vas,vcs,vtype) <- gen v
187− return ( unionA eas vas
188− , Set.union ecs vcs
189− , RecordT (Map.singleton x [vtype]) etype )
190−
191− Modify record fields ->
192− do (ras,rcs,rtype) <- gen record
193− (ass,css,newTs) <- unzip3 `liftM` mapM gen (map snd fields)
194− oldTs <- mapM (\_ -> beta) fields
195− rtype' <- beta
196− let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'
197− c = Set.singleton (loc' (rtype :=: rT oldTs))
198− return ( unionsA (ras:ass), Set.unions (c : rcs : css), rT newTs )
199−
200− Record fields ->
201− let insert label tipe = Map.insertWith (++) label [tipe]
202− getScheme (f,args,e) = do
203− (as, _, (label, Forall _ cs tipe)) <- defGenHelp f args e
204− return (as, cs, insert label tipe)
205− in do (ass, css, fs) <- unzip3 `liftM` mapM getScheme fields
206− return ( unionsA ass
207− , Set.fromList (concat css)
208− , RecordT (foldr ($) Map.empty fs) EmptyRecord )
209−
210− Range e1@(L w1 s1 _) e2@(L w2 s2 _) ->
211− do (a1,c1,t1) <- gen e1
212− (a2,c2,t2) <- gen e2
213− return ( unionsA [a1,a2]
214− , Set.unions [ c1, c2, Set.fromList [ L w1 s1 (t1 :=: int)
215− , L w1 s2 (t2 :=: int) ] ]
216− , listOf int )
217−
218− MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
219− let cs = Set.fromList (map (loc' . (t :=:)) ts)
220− return (unionsA ass, Set.unions (cs:css), t)
221− where genPair (b@(L t s _),e) = do
222− (a1,c1,t1) <- gen b
223− (a2,c2,t2) <- gen e
224− return ( unionsA [a1,a2]
225− , Set.unions [ c1, c2
226− , Set.singleton (L t s (t1 :=: bool)) ]
227− , t2 )
228−
229− IntNum _ -> do t <- beta
230− return (Map.empty, Set.singleton (loc' $ t :<: number), t)
231−
232− FloatNum _ -> primitive float
233− Chr _ -> primitive char
234− Str _ -> primitive string
235− Boolean _ -> primitive bool
236− Markdown _ -> primitive element
237−
238−
239−primitive :: Type -> GuidCounter (TVarMap, ConstraintSet, Type)
240−primitive t = return (Map.empty, Set.empty, t)
241−
242−caseGen :: Type
243− -> (Pattern, CExpr)
244− -> GuidCounter (TVarMap, ConstraintSet, Type)
245−caseGen tipe (p, ce@(L _ span e)) = do
246− (as ,cs ,t) <- gen ce
247− (as',cs',_) <- patternGen (loc p span) tipe as p
248− return ( as', Set.union cs cs', t )
249−
250−patternGen :: (Constraint -> Located Constraint)
251− -> Type -- Type of e in `case e of ...`
252− -> TVarMap
253− -> Pattern
254− -> GuidCounter (TVarMap, ConstraintSet, Type)
255−patternGen loc tipe as pattern =
256− case pattern of
257− PAnything -> do b <- beta ; return ( as, Set.empty, b )
258− PVar v -> do
259− b <- beta
260− let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
261− return ( Map.delete v as, Set.fromList (loc (b :=: tipe) : cs), b )
262− PData name ps -> do
263− constr <- guid
264− output <- beta
265− let step (as,cs,tipe) p = do b <- beta
266− (as',cs',t) <- patternGen loc b as p
267− return (as', Set.union cs cs', t ==> tipe)
268− (as',cs, t) <- foldM step (as,Set.empty,tipe) (reverse ps)
269− return ( Map.insert name [constr] as'
270− , Set.insert (loc (VarT constr :=: t)) cs
271− , output )
272− PRecord fs ->
273− do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs
274− b <- beta
275− let t = RecordT (Map.fromList $ map (second (:[])) pairs) b
276− mkCs (name,tipe) = map (loc . (tipe :=:) . VarT)
277− (Map.findWithDefault [] name as)
278− return ( foldr Map.delete as fs
279− , Set.fromList (loc (t :=: tipe) : concatMap mkCs pairs)
280− , t )
281−
282−
283−defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme)
284−defScheme def = do (as,cs,hint) <- defGen def
285− return ( as, snd hint )
286−
287−defGen def = case def of
288− FnDef f args e -> defGenHelp f args e
289− OpDef op a1 a2 e -> defGenHelp op [a1,a2] e
290− TypeAnnotation name tipe -> do
291− schm <- Subs.generalize [] =<< Subs.superize name tipe
292− return (Map.empty, Set.empty, (name, schm))
293−
294−defGenHelp name args e = do
295− argDict <- mapM (\a -> liftM ((,) a) guid) args
296− (as,cs,t) <- gen e
297− let as' = foldr Map.delete as args
298− tipe = foldr (==>) t $ map (VarT . snd) argDict
299− genCs (arg,x) = do
300− v <- guid
301− let as' = Map.findWithDefault [v] arg as
302− return $ map (\y -> loc arg NoSpan $ VarT x :=: VarT y) as'
303− cs' <- concat `liftM` mapM genCs argDict
304− scheme <- Subs.generalize (concat $ Map.elems as') $
305− Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
306− return ( as', Set.empty, (name, scheme) )
307−
308−
309−stmtGen :: Statement
310− -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)
311−stmtGen stmt =
312− case stmt of
313− Definition def -> do (as,cs,hint) <- defGen def
314− return ( as, cs, uncurry Map.singleton hint )
315−
316− Datatype name xs tcs ->
317− let toScheme ts = Forall xs [] (foldr (==>) (ADT name $ map VarT xs) ts)
318− in return (Map.empty, Set.empty, Map.fromList (map (second toScheme) tcs))
319−
320− ExportEvent js elm tipe ->
321− do x <- guid
322− return ( Map.singleton elm [x]
323− , Set.singleton . loc elm NoSpan $ VarT x :=: tipe
324− , Map.empty )
325−
326− ImportEvent js e@(L txt span base) elm tipe ->
327− do (as,cs,t) <- gen e
328− return ( as
329− , Set.insert (L txt span (signalOf t :=: tipe)) cs
330− , Map.singleton elm (Forall [] [] tipe) )
331−
332− TypeAlias _ _ _ -> return (Map.empty, Set.empty, Map.empty)
compiler/Types/Hints.hsdeleted−32
@@ -1,32 +0,0 @@
1−module Types.Hints (hints) where
2−
3−import Control.Arrow (first)
4−import Control.Monad (liftM)
5−import Data.Maybe (catMaybes)
6−import qualified Data.Map as Map
7−import Guid
8−import qualified Libraries as Libs
9−import Parse.Library (iParse)
10−import Parse.Types
11−import qualified Types.Substitutions as Subs
12−import Types.Types
13−
14−hints :: GuidCounter [(String, Scheme)]
15−hints = liftM catMaybes (mapM toScheme values)
16− where
17− values :: [(String, String)]
18− values = addPrefixes (Map.toList (Map.map Map.toList Libs.libraries))
19−
20− addPrefixes :: [(String,[(String, String)])] -> [(String, String)]
21− addPrefixes = concatMap (\(m,vs) -> map (first (\n -> m ++ "." ++ n)) vs)
22−
23− toScheme :: (String, String) -> GuidCounter (Maybe (String, Scheme))
24− toScheme (name, 't':'y':'p':'e':' ':_) = return Nothing
25− toScheme (name, 'd':'a':'t':'a':' ':_) = return Nothing
26− toScheme (name, tipeString) =
27− let err = "compiler error parsing type of " ++ name ++ ":\n" ++ tipeString
28− in case iParse (fmap toType typeExpr) err tipeString of
29− Left err -> error (show err)
30− Right tipe -> do
31− scheme <- Subs.generalize [] =<< Subs.superize name tipe
32− return (Just (name, scheme))
compiler/Types/Solver.hsdeleted−210
@@ -1,210 +0,0 @@
1−
2−module Types.Solver (solver) where
3−
4−import Located
5−import Control.Arrow (second)
6−import Control.Monad (liftM)
7−import Data.Either (lefts,rights)
8−import Data.List (foldl')
9−import Data.Maybe (isJust)
10−import qualified Data.Set as Set
11−import qualified Data.Map as Map
12−import Guid
13−import Types.Types
14−import Types.Substitutions
15−import Types.Alias (dealias)
16−
17−isSolved ss (L _ _ (t1 :=: t2)) = t1 == t2
18−isSolved ss (L _ _ (x :<<: _)) = isJust (lookup x ss)
19−isSolved ss c = False
20−
21−type Aliases = Map.Map String ([X],Type)
22−
23−crush :: Aliases -> Scheme -> GuidCounter (Either String Scheme)
24−crush aliases (Forall xs cs t) =
25− do subs <- solver aliases Map.empty cs
26− return $ do ss' <- subs
27− let ss = Map.toList ss'
28− cs' = filter (not . isSolved ss) (subst ss cs)
29− return $ Forall xs cs' (subst ss t)
30−
31−schemeSubHelp txt span x s t1 rltn t2 = do
32− (t1',cs1) <- sub t1
33− (t2',cs2) <- sub t2
34− return (L txt span (rltn t1' t2') : cs1 ++ cs2)
35− where sub t | not (occurs x t) = return (t, [])
36− | otherwise = do (st, cs) <- concretize s
37− return (subst [(x,st)] t, cs)
38−
39−schemeSub aliases x s c =
40− do s' <- crush aliases s
41− case s' of
42− Right s'' -> Right `liftM` schemeSub' x s'' c
43− Left err -> return $ Left err
44−
45−schemeSub' x s c@(L txt span constraint) =
46− case constraint of
47− (t1 :=: t2) -> schemeSubHelp txt span x s t1 (:=:) t2
48− (t1 :<: t2) -> schemeSubHelp txt span x s t1 (:<:) t2
49− (y :<<: Forall cxs ccs ctipe)
50− | not (occurs x c) -> return [c]
51− | otherwise ->
52− do Forall xs cs tipe <- rescheme s
53− let ss = [(x,tipe)]
54− constraints = subst ss (cs ++ ccs)
55− c' = y :<<: Forall (cxs ++ xs) constraints (subst ss ctipe)
56− return [ L txt span c' ]
57−
58−recordConstraints eq fs t fs' t' =
59− liftM concat . sequence $
60− [ constrain fs fs'
61− , liftM concat . mapM (\(k,ts) -> zipper [] k ts []) . Map.toList $
62− Map.difference fs fs'
63− , liftM concat . mapM (\(k,ts) -> zipper [] k [] ts) . Map.toList $
64− Map.difference fs' fs
65− ]
66− where constrain :: Map.Map String [Type] -> Map.Map String [Type]
67− -> GuidCounter [Located Constraint]
68− constrain as bs = liftM concat . sequence . Map.elems $
69− Map.intersectionWithKey (zipper []) as bs
70− zipper :: [Located Constraint] -> String -> [Type] -> [Type]
71− -> GuidCounter [Located Constraint]
72− zipper cs k xs ys =
73− case (xs,ys) of
74− (a:as, b:bs) -> zipper (eq a b : cs) k as bs
75− ([],[]) -> return cs
76− (as,[]) -> do x <- guid
77− let tipe = RecordT (Map.singleton k as) (VarT x)
78− return (cs ++ [eq t' tipe])
79− ([],bs) -> do x <- guid
80− let tipe = RecordT (Map.singleton k bs) (VarT x)
81− return (cs ++ [eq t tipe])
82−
83−solver :: Aliases
84− -> Map.Map X Type
85− -> [Located Constraint]
86− -> GuidCounter (Either String (Map.Map X Type))
87−solver _ subs [] = return $ Right subs
88−solver aliases subs (L txt span c : cs) =
89− let loc = L txt span
90− eq t1 t2 = loc (t1 :=: t2)
91− solv = solver aliases subs
92− uniError' = uniError (\t1 t2 -> solv (eq t1 t2 : cs)) aliases txt span
93− in case c of
94− -- Destruct Type-constructors
95− t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2) ->
96− if n1 == n2 then solv (zipWith eq ts1 ts2 ++ cs)
97− else uniError' t1 t2
98−
99− LambdaT t1 t2 :=: LambdaT t1' t2' ->
100− solv ([ eq t1 t1', eq t2 t2' ] ++ cs)
101−
102− RecordT fs t :=: RecordT fs' t' ->
103− do cs' <- recordConstraints eq fs t fs' t'
104− solv (cs' ++ cs)
105−
106− -- Type-equality
107− VarT x :=: VarT y
108− | x == y -> solv cs
109− | otherwise ->
110− case (Map.lookup x subs, Map.lookup y subs) of
111− (Just (Super xts), Just (Super yts)) ->
112− let ts = Set.intersection xts yts
113− setXY t = Map.insert x t . Map.insert y t
114− in case Set.toList ts of
115− [] -> unionError txt span xts yts
116− [t] -> let cs1 = subst [(x,t),(y,t)] cs in
117− cs1 `seq` solver aliases (setXY t subs) cs1
118− _ -> solver aliases (setXY (Super ts) subs) cs
119− (Just (Super xts), _) ->
120− let cs2 = subst [(y,VarT x)] cs in
121− solver aliases (Map.insert y (VarT x) subs) cs2
122− (_, _) ->
123− let cs3 = subst [(x,VarT y)] cs in
124− solver aliases (Map.insert x (VarT y) subs) cs3
125−
126− VarT x :=: t -> do
127− if x `occurs` t then occursError txt span (VarT x) t else
128− (case Map.lookup x subs of
129− Nothing ->
130− let cs4 = subst [(x,t)] cs
131− subs' = Map.map (subst [(x,t)]) $ Map.insert x t subs
132− in solver aliases subs' cs4
133− Just (Super ts) ->
134− let ts' = Set.intersection ts (Set.singleton t) in
135− case Set.toList ts' of
136− [] -> solv (loc (t :<: Super ts) : cs)
137− [t'] -> let cs5 = subst [(x,t)] cs in
138− solver aliases (Map.insert x t' subs) cs5
139− _ -> solver aliases (Map.insert x (Super ts') subs) cs
140− Just t' -> solv (loc (t' :=: t) : cs)
141− )
142−
143− t :=: VarT x -> solv ((loc (VarT x :=: t)) : cs)
144−
145− t1 :=: t2 | t1 == t2 -> solv cs
146− | otherwise -> uniError' t1 t2
147−
148− -- subtypes
149− VarT x :<: Super ts ->
150− case Map.lookup x subs of
151− Nothing -> solver aliases (Map.insert x (Super ts) subs) cs
152− Just (Super ts') ->
153− case Set.toList $ Set.intersection ts ts' of
154− [] -> unionError txt span ts ts'
155− [t] -> solver aliases (Map.insert x t subs) (subst [(x,t)] cs)
156− ts'' -> solver aliases subs' cs
157− where subs' = Map.insert x (Super $ Set.fromList ts'') subs
158−
159− ADT "List" [t] :<: Super ts
160− | any f (Set.toList ts) -> solv cs
161− | otherwise -> subtypeError txt span (ADT "List" [t]) (Super ts)
162− where f (ADT "List" [VarT _]) = True
163− f (ADT "List" [t']) = dealias aliases t == t'
164− f _ = False
165−
166− t :<: Super ts
167− | Set.member t ts -> solv cs
168− | Set.member (dealias aliases t) ts -> solv cs
169− | otherwise -> subtypeError txt span t (Super ts)
170−
171− x :<<: s
172− | any (occurs x) cs ->
173− do css <- mapM (schemeSub aliases x s) cs
174− case lefts css of
175− err : _ -> return $ Left err
176− [] -> solv (concat (rights css))
177− | otherwise ->
178− do (t,cs7) <- concretize s
179− solv (cs ++ loc (VarT x :=: t) : cs7)
180−
181−showMsg msg = case msg of
182− Just str -> "\nIn context: " ++ str
183− Nothing -> ""
184−
185−occursError msg span t1 t2 =
186− return . Left $ concat
187− [ "Type error (" ++ show span ++ "):\n"
188− , "Occurs check: cannot construct the infinite type:\n"
189− , show t1, " = ", show t2, showMsg msg ]
190−
191−uniError solveWith aliases msg span t1 t2 =
192− let t1' = dealias aliases t1
193− t2' = dealias aliases t2
194− in if t1 /= t1' || t2 /= t2'
195− then solveWith t1' t2'
196− else return . Left $ concat
197− [ "Type error (" ++ show span ++ "):\n"
198− , show t1, " is not equal to ", show t2, showMsg msg ]
199−
200−unionError msg span ts ts' =
201− return . Left $ concat
202− [ "Type error (" ++ show span ++ "):\n"
203− , "There are no types in both "
204− , show (Super ts), " and ", show (Super ts'), showMsg msg ]
205−
206−subtypeError msg span t s =
207− return . Left $ concat
208− [ "Type error (" ++ show span ++ "):\n"
209− , show t, " is not a ", show s, showMsg msg ]
210−
compiler/Types/Substitutions.hsdeleted−136
@@ -1,136 +0,0 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−module Types.Substitutions (subst,
3− occurs,
4− freeVars,
5− concretize,
6− rescheme,
7− generalize,
8− superize) where
9−
10−import Ast
11−import Located
12−import Control.Monad (liftM, liftM2)
13−import Control.Monad.State (runState, State, get, put)
14−import Data.List (nub)
15−import qualified Data.Set as Set
16−import qualified Data.Map as Map
17−import Guid
18−import Types.Types
19−
20−class Subst a where
21− subst :: [(X,Type)] -> a -> a
22−
23−instance Subst Type where
24− subst ss t =
25− case t of
26− VarT x -> case lookup x ss of
27− Nothing -> VarT x
28− Just (Super _) -> VarT x
29− Just t -> t
30− LambdaT t1 t2 -> LambdaT (subst ss t1) (subst ss t2)
31− ADT name ts -> ADT name (subst ss ts)
32− RecordT fs t -> RecordT (Map.map (subst ss) fs) (subst ss t)
33− EmptyRecord -> EmptyRecord
34− Super ts -> Super ts
35−
36−instance Subst Scheme where
37− subst ss (Forall vs cs t) = Forall vs (subst ss cs) (subst ss t)
38−
39−instance Subst Constraint where
40− subst ss (t1 :=: t2) = subst ss t1 :=: subst ss t2
41− subst ss (t :<: super) = subst ss t :<: super
42− subst ss (x :<<: poly) = x :<<: subst ss poly
43−
44−instance Subst a => Subst (Located a) where
45− subst ss (L str span c) = L str span (subst ss c)
46−
47−instance Subst a => Subst [a] where
48− subst ss as = map (subst ss) as
49−
50−
51−class FreeVars a where
52− freeVars :: a -> [X]
53−
54−instance FreeVars Type where
55− freeVars t =
56− case t of
57− VarT v -> [v]
58− LambdaT t1 t2 -> freeVars t1 ++ freeVars t2
59− ADT _ ts -> concatMap freeVars ts
60− RecordT fs t -> freeVars (concat $ Map.elems fs) ++ freeVars t
61− EmptyRecord -> []
62− Super _ -> []
63−
64−instance FreeVars Constraint where
65− freeVars (t1 :=: t2) = freeVars t1 ++ freeVars t2
66− freeVars (t1 :<: t2) = freeVars t1 ++ freeVars t2
67− freeVars (x :<<: Forall xs cs t) = filter (`notElem` xs) frees
68− where frees = concatMap freeVars cs ++ freeVars t
69−
70−instance FreeVars a => FreeVars (Located a) where
71− freeVars (L _ _ c) = freeVars c
72−
73−instance FreeVars a => FreeVars [a] where
74− freeVars = concatMap freeVars
75−
76−occurs x t = x `elem` freeVars t
77−
78−concretize :: Scheme -> GuidCounter (Type, [Located Constraint])
79−concretize (Forall xs cs t) = do
80− ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs
81− return (subst ss t, subst ss cs)
82−
83−rescheme :: Scheme -> GuidCounter Scheme
84−rescheme (Forall xs cs t) = do
85− xs' <- mapM (const guid) xs
86− let ss = zip xs (map VarT xs')
87− return $ Forall xs' (subst ss cs) (subst ss t)
88−
89−generalize :: [X] -> Scheme -> GuidCounter Scheme
90−generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)
91− where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs
92− frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)
93−
94−newtype Superize a = S { runSuper :: State ([X], [X], [X]) a }
95− deriving (Monad)
96−
97−superize :: String -> Type -> GuidCounter Scheme
98−superize name tipe =
99− do constraints <- liftM concat $
100− sequence [ mapM (<: nmbr) (nub ns)
101− , mapM (<: apnd) (nub as)
102− , mapM (<: comp) (nub cs) ]
103− return (Forall (concat [ns,as,cs]) constraints tipe')
104− where
105− (tipe', (ns,as,cs)) = runState (runSuper (go tipe)) ([],[],[])
106− t <: super = do x <- guid
107− return $ L (Just name) NoSpan (VarT t :<: super x)
108−
109− nmbr t = number
110− apnd t = appendable t
111− comp t = comparable t
112−
113− go :: Type -> Superize Type
114− go t =
115− case t of
116− EmptyRecord -> return t
117− Super _ -> return t
118− VarT _ -> return t
119− LambdaT t1 t2 -> liftM2 LambdaT (go t1) (go t2)
120− ADT "Number" [VarT t] -> addNumber t
121− ADT "Appendable" [VarT t] -> addAppendable t
122− ADT "Comparable" [VarT t] -> addComparable t
123− ADT name ts -> liftM (ADT name) (mapM go ts)
124− RecordT fs t -> liftM2 RecordT fs' (go t)
125− where pairs = Map.toList fs
126− fs' = do ps <- mapM (\(f,t) -> liftM ((,) f) (mapM go t)) pairs
127− return (Map.fromList ps)
128−
129− add :: (X -> ([X],[X],[X]) -> ([X],[X],[X])) -> X -> Superize Type
130− add f v = S $ do (ns, as, cs) <- get
131− put $ f v (ns, as, cs)
132− return (VarT v)
133−
134− addNumber = add (\n (ns,as,cs) -> (n:ns,as,cs))
135− addAppendable = add (\a (ns,as,cs) -> (ns,a:as,cs))
136− addComparable = add (\c (ns,as,cs) -> (ns,as,c:cs))
compiler/Types/Types.hsdeleted−95
@@ -1,95 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−module Types.Types where
3−
4−import Located
5−import Data.Char (isDigit)
6−import Data.List (intercalate,isPrefixOf)
7−import qualified Data.Set as Set
8−import qualified Data.Map as Map
9−import Data.Data
10−
11−type X = Int
12−
13−data Type = LambdaT Type Type
14− | VarT X
15− | ADT String [Type]
16− | EmptyRecord
17− | RecordT (Map.Map String [Type]) Type
18− | Super (Set.Set Type)
19− deriving (Eq, Ord, Data, Typeable)
20−
21−data Scheme = Forall [X] [Located Constraint] Type deriving (Eq, Ord, Show, Data, Typeable)
22−
23−data Constraint = Type :=: Type
24− | Type :<: Type
25− | X :<<: Scheme
26− deriving (Eq, Ord, Show, Data, Typeable)
27−
28−recordT :: [(String,Type)] -> Map.Map String [Type]
29−recordT fields =
30− foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
31−
32−recordOf :: [(String,Type)] -> Type
33−recordOf fields = RecordT (recordT fields) EmptyRecord
34−
35−tipe t = ADT t []
36−
37−int = tipe "Int"
38−float = tipe "Float"
39−time = tipe "Time"
40−date = tipe "Date"
41−
42−char = tipe "Char"
43−bool = tipe "Bool"
44−text = tipe "Text"
45−order = tipe "Order"
46−string = tipe "String"
47−
48−number = Super $ Set.fromList [ int, float, time ]
49−appendable t = Super $ Set.fromList [ string, text, listOf (VarT t) ]
50−comparable t = Super $ Set.fromList [ int, float, char, string, time, date ]
51−
52−element = tipe "Element"
53−
54−listOf t = ADT "List" [t]
55−signalOf t = ADT "Signal" [t]
56−tupleOf ts = ADT ("Tuple" ++ show (length ts)) ts
57−maybeOf t = ADT "Maybe" [t]
58−eitherOf a b = ADT "Either" [a,b]
59−pairOf t = tupleOf [t,t]
60−point = pairOf int
61−
62−infixr ==>
63−t1 ==> t2 = LambdaT t1 t2
64−
65−infix 8 -:
66−name -: tipe = (,) name $ Forall [] [] tipe
67−
68−parens = ("("++) . (++")")
69−
70−instance Show Type where
71− show t =
72− let addParens (c:cs) =
73− if notElem ' ' cs || c == '(' then c:cs else parens (c:cs)
74− in case t of
75− LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2
76− LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
77− VarT x -> 't' : show x
78− ADT "List" [ADT "Char" []] -> "String"
79− ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
80− ADT name cs ->
81− if isTupleString name
82− then parens . intercalate "," $ map show cs
83− else name ++ concatMap ((' ':) . addParens . show) cs
84− Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
85− EmptyRecord -> "{}"
86− RecordT fs t ->
87− start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"
88− where field n s = n ++ " : " ++ show s
89− fields (n,ss) = map (field n) ss
90− start = case t of
91− EmptyRecord -> "{ "
92− _ -> "{ " ++ show t ++ " | "
93−
94−
95−isTupleString str = "Tuple" `isPrefixOf` str && all isDigit (drop 5 str)
compiler/Types/Unify.hsdeleted−16
@@ -1,16 +0,0 @@
1−
2−module Types.Unify (unify) where
3−
4−import Control.Monad (liftM)
5−import qualified Data.Map as Map
6−
7−import Ast
8−import Guid
9−import qualified Types.Constrain as Constrain
10−import qualified Types.Solver as Solver
11−import qualified Types.Alias as Alias
12−
13−unify hints modul@(Module _ _ _ stmts) = run $ do
14− constraints <- Constrain.constrain hints modul
15− either (return . Left) (Solver.solver (Alias.get stmts) Map.empty) constraints
16−
compiler/Unique.hsnew file+19
@@ -0,0 +1,19 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+module Unique (guid, set, run, runAt, Unique) where
3+
4+import Control.Monad.State (evalState, State, get, put)
5+
6+-- Wrapper around State monad.
7+newtype Unique a = U { runU :: State Int a }
8+ deriving (Monad)
9+
10+-- Get the next GUID, incrementing the counter.
11+guid :: Unique Int
12+guid = U $ do n <- get
13+ put (n + 1)
14+ return n
15+
16+set n = U (put n)
17+
18+run = runAt 0
19+runAt n x = evalState (runU x) n
libraries/Automaton.elm+7−4
@@ -4,7 +4,10 @@
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)
9+import open List
10+import Maybe (Just, Nothing)
8
11
9data Automaton a b = Step (a -> (Automaton a b, b))
12data Automaton a b = Step (a -> (Automaton a b, b))
10
13
@@ -13,7 +16,7 @@ data Automaton a b = Step (a -> (Automaton a b, b))
13run : Automaton a b -> b -> Signal a -> Signal b
16run : Automaton a b -> b -> Signal a -> Signal b
14run auto base inputs =
17run auto base inputs =
15 let step a (Step f, _) = f a
18 let step a (Step f, _) = f a
16− in lift (\(x,y) -> y) <| foldp step (auto,base) inputs
19+ in lift (\(x,y) -> y) (foldp step (auto,base) inputs)
17
20
18-- Step an automaton forward once with a given input.
21-- Step an automaton forward once with a given input.
19step : a -> Automaton a b -> (Automaton a b, b)
22step : a -> Automaton a b -> (Automaton a b, b)
@@ -33,7 +36,7 @@ g <<< f = f >>> g
33-- 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.
34combine : [Automaton a b] -> Automaton a [b]
37combine : [Automaton a b] -> Automaton a [b]
35combine autos =
38combine autos =
36− Step (\a -> let (autos', bs) = unzip <| map (step a) autos
39+ Step (\a -> let (autos', bs) = unzip (map (step a) autos)
37 in (combine autos', bs))
40 in (combine autos', bs))
38
41
39-- 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
@@ -69,7 +72,7 @@ empty = ([],[])
69enqueue x (en,de) = (x::en, de)
72enqueue x (en,de) = (x::en, de)
70dequeue q = case q of
73dequeue q = case q of
71 ([],[]) -> Nothing
74 ([],[]) -> Nothing
72− (en,[]) -> enqueue ([], reverse en)
75+ (en,[]) -> dequeue ([], reverse en)
73 (en,hd::tl) -> Just (hd, (en,tl))
76 (en,hd::tl) -> Just (hd, (en,tl))
74
77
75-- Computes the running average of the last `n` inputs.
78-- Computes the running average of the last `n` inputs.
libraries/Basics.elmnew file+254
@@ -0,0 +1,254 @@
1+
2+module Basics where
3+
4+import Native.Basics
5+
6+type String = [Char]
7+
8+-- Convert radians to standard Elm angles (radians).
9+radians : Float -> Float
10+radians t = t
11+
12+-- Convert degrees to standard Elm angles (radians).
13+degrees : Float -> Float
14+degrees d = d * Native.Basics.pi / 180
15+
16+-- Convert turns to standard Elm angles (radians).
17+-- One turn is equal to 360&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+35−26
@@ -1,26 +1,29 @@
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,
14 scale : Float,
16 scale : Float,
15 x : Float,
17 x : Float,
16 y : Float,
18 y : Float,
19+ alpha : Float,
17 form : BasicForm
20 form : BasicForm
18 }
21 }
19
22
20data FillStyle
23data FillStyle
21 = Solid Color
24 = Solid Color
22 | Texture String
25 | Texture String
23− | Gradient Gradient
26+ | Grad Gradient
24
27
25-- The shape of the ends of a line.
28-- The shape of the ends of a line.
26data LineCap = Flat | Round | Padded
29data LineCap = Flat | Round | Padded
@@ -48,7 +51,7 @@ type LineStyle = {
48-- { defaultLine | width <- 10 }
51-- { defaultLine | width <- 10 }
49defaultLine : LineStyle
52defaultLine : LineStyle
50defaultLine = {
53defaultLine = {
51− color = Color.black,
54+ color = black,
52 width = 1,
55 width = 1,
53 cap = Flat,
56 cap = Flat,
54 join = Sharp 10,
57 join = Sharp 10,
@@ -75,9 +78,10 @@ data BasicForm
75 | FElement Element
78 | FElement Element
76 | FGroup Matrix2D [Form]
79 | FGroup Matrix2D [Form]
77
80
81+form : BasicForm -> Form
78−form f = { theta = 0, scale = 1, x = 0, y = 0, form = f }
82+form f = { theta=0, scale=1, x=0, y=0, alpha=1, form=f }
79
83
80−fill style shape = form (FShape (Either.Right style) shape)
84+fill style shape = form (FShape (Right style) shape)
81
85
82-- Create a filled in shape.
86-- Create a filled in shape.
83filled : Color -> Shape -> Form
87filled : Color -> Shape -> Form
@@ -90,11 +94,11 @@ textured src shape = fill (Texture src) shape
90
94
91-- Fill a shape with a [gradient](/docs/Color.elm#linear).
95-- Fill a shape with a [gradient](/docs/Color.elm#linear).
92gradient : Gradient -> Shape -> Form
96gradient : Gradient -> Shape -> Form
93−gradient grad shape = fill (Gradient grad) shape
97+gradient grad shape = fill (Grad grad) shape
94
98
95-- Outline a shape with a given line style.
99-- Outline a shape with a given line style.
96outlined : LineStyle -> Shape -> Form
100outlined : LineStyle -> Shape -> Form
97−outlined style shape = form (FShape (Either.Left style) shape)
101+outlined style shape = form (FShape (Left style) shape)
98
102
99-- Trace a path with a given line style.
103-- Trace a path with a given line style.
100traced : LineStyle -> Path -> Form
104traced : LineStyle -> Path -> Form
@@ -114,7 +118,7 @@ toForm e = form (FElement e)
114-- 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
115-- 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.
116group : [Form] -> Form
120group : [Form] -> Form
117−group fs = form (FGroup Matrix.identity fs)
121+group fs = form (FGroup identity fs)
118
122
119-- 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
120-- transformation.
124-- transformation.
@@ -147,19 +151,24 @@ moveX x f = { f | x <- f.x + x }
147moveY : Float -> Form -> Form
151moveY : Float -> Form -> Form
148moveY y f = { f | y <- f.y + y }
152moveY y f = { f | y <- f.y + y }
149
153
154+-- Set the alpha of a `Form`. The default is 1, and 0 is totally transparent.
155+alpha : Float -> Form -> Form
156+alpha a f = { f | alpha <- a }
157+
150-- 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
151-- 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.
152collage : Int -> Int -> [Form] -> Element
160collage : Int -> Int -> [Form] -> Element
161+collage = Native.Graphics.Collage.collage
153
162
154
163
155type Path = [(Float,Float)]
164type Path = [(Float,Float)]
156
165
157-- Create a path that follows a sequence of points.
166-- Create a path that follows a sequence of points.
158−path : [(Number a,Number a)] -> Path
167+path : [(Float,Float)] -> Path
159path ps = ps
168path ps = ps
160
169
161-- Create a path along a given line segment.
170-- Create a path along a given line segment.
162−segment : (Number a,Number a) -> (Number a,Number a) -> Path
171+segment : (Float,Float) -> (Float,Float) -> Path
163segment p1 p2 = [p1,p2]
172segment p1 p2 = [p1,p2]
164
173
165type Shape = [(Float,Float)]
174type Shape = [(Float,Float)]
@@ -167,31 +176,31 @@ type Shape = [(Float,Float)]
167-- Create an arbitrary polygon by specifying its corners in order.
176-- Create an arbitrary polygon by specifying its corners in order.
168-- `polygon` will automatically close all shapes, so the given list
177-- `polygon` will automatically close all shapes, so the given list
169-- 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.
170−polygon : [(Number a,Number a)] -> Shape
179+polygon : [(Float,Float)] -> Shape
171polygon points = points
180polygon points = points
172
181
173-- A rectangle with a given width and height.
182-- A rectangle with a given width and height.
174−rect : Number a -> Number a -> Shape
183+rect : Float -> Float -> Shape
175rect w h = let hw = w/2
184rect w h = let hw = w/2
176 hh = h/2
185 hh = h/2
177 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) ]
178
187
179-- A square with a given edge length.
188-- A square with a given edge length.
180−square : Number a -> Shape
189+square : Float -> Shape
181square n = rect n n
190square n = rect n n
182
191
183-- An oval with a given width and height.
192-- An oval with a given width and height.
184−oval : Number a -> Number a -> Shape
193+oval : Float -> Float -> Shape
185oval w h =
194oval w h =
186 let n = 50
195 let n = 50
187− t = 2 * Math.PI / n
196+ t = 2 * pi / n
188 hw = w/2
197 hw = w/2
189 hh = h/2
198 hh = h/2
190− f i = (hw * Math.cos (t*i), hh * Math.sin (t*i))
199+ f i = (hw * cos (t*i), hh * sin (t*i))
191 in List.map f [0..n-1]
200 in List.map f [0..n-1]
192
201
193-- A circle with a given radius.
202-- A circle with a given radius.
194−circle : Number a -> Shape
203+circle : Float -> Shape
195circle r = oval (2*r) (2*r)
204circle r = oval (2*r) (2*r)
196
205
197-- 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
@@ -199,9 +208,9 @@ circle r = oval (2*r) (2*r)
199-- 30 you would say:
208-- 30 you would say:
200--
209--
201-- ngon 5 30
210-- ngon 5 30
202−ngon : Int -> Number a -> Shape
211+ngon : Int -> Float -> Shape
203ngon n r =
212ngon n r =
204 let m = toFloat n
213 let m = toFloat n
205− t = 2 * Math.PI / m
214+ t = 2 * pi / m
206− f i = ( r * Math.cos (t*i), r * Math.sin (t*i) )
215+ f i = ( r * cos (t*i), r * sin (t*i) )
207− in List.map f [0..n-1]
216+ in List.map f [0..m-1]
libraries/Graphics/Element.elm+32−33
@@ -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,
@@ -25,7 +16,8 @@ type Properties = {
25 opacity : Float,
16 opacity : Float,
26 color : Maybe Color,
17 color : Maybe Color,
27 href : JSString,
18 href : JSString,
28− tag : JSString
19+ tag : JSString,
20+ hover : ()
29 }
21 }
30
22
31type Element = { props : Properties, element : ElementPrim }
23type Element = { props : Properties, element : ElementPrim }
@@ -44,20 +36,22 @@ sizeOf e = (e.props.width, e.props.height)
44
36
45-- Create an `Element` with a given width.
37-- Create an `Element` with a given width.
46width : Int -> Element -> Element
38width : Int -> Element -> Element
39+width nw e =
47−width nw e = let p = e.props
40+ let p = e.props
48− props = case e.element of
41+ props = case e.element of
49− Image _ w h _ -> {p| height <- h/w*nw }
42+ Image _ w h _ -> {p| height <- round (toFloat h / toFloat w * toFloat nw) }
50− RawHtml html -> {p| height <- let (w,h) = htmlHeight nw html in h}
43+ RawHtml html -> {p| height <- snd (Native.Utils.htmlHeight nw html)}
51− _ -> p
44+ _ -> p
52− in { element=e.element, props={props| width <- nw} }
45+ in { element=e.element, props={ props | width <- nw } }
53
46
54-- Create an `Element` with a given height.
47-- Create an `Element` with a given height.
55height : Int -> Element -> Element
48height : Int -> Element -> Element
49+height nh e =
56−height nh e = let p = e.props
50+ let p = e.props
57− props = case e.element of
51+ props = case e.element of
58− Image _ w h _ -> {p| width <- w/h*nh }
52+ Image _ w h _ -> {p| width <- round (toFloat w / toFloat h * toFloat nh) }
59− _ -> p
53+ _ -> p
60− in { element=e.element, props={p| height <- nh} }
54+ in { element=e.element, props={ p | height <- nh} }
61
55
62-- Create an `Element` with a new width and height.
56-- Create an `Element` with a new width and height.
63size : Int -> Int -> Element -> Element
57size : Int -> Int -> Element -> Element
@@ -70,24 +64,26 @@ opacity o e = let p = e.props in { element=e.element, props={p| opacity <- o} }
70
64
71-- Create an `Element` with a given background color.
65-- Create an `Element` with a given background color.
72color : Color -> Element -> Element
66color : Color -> Element -> Element
73−color c e = let p = e.props in
67+color c e = let p = e.props in
68+ { element = e.element
74− { element=e.element, props={p| color <- Just c} }
69+ , props = { p | color <- Just c}
70+ }
75
71
76-- 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.
77-- The element `(tag "all-about-badgers" thirdParagraph)` can be reached
73-- The element `(tag "all-about-badgers" thirdParagraph)` can be reached
78-- 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`
79tag : String -> Element -> Element
75tag : String -> Element -> Element
80tag name e = let p = e.props in
76tag name e = let p = e.props in
81− { element=e.element, props={p| tag <- JS.fromString name} }
77+ { element=e.element, props={p | tag <- JS.fromString name} }
82
78
83-- Create an `Element` that is a hyper-link.
79-- Create an `Element` that is a hyper-link.
84link : String -> Element -> Element
80link : String -> Element -> Element
85link href e = let p = e.props in
81link href e = let p = e.props in
86− { element=e.element, props={p| href <- JS.fromString href} }
82+ { element=e.element, props={p | href <- JS.fromString href} }
87
83
88emptyStr = JS.fromString ""
84emptyStr = JS.fromString ""
89newElement w h e =
85newElement w h e =
90− { props = Properties (guid ()) w h 1 Nothing emptyStr emptyStr, element = e }
86+ { props = Properties (Native.Utils.guid ()) w h 1 Nothing emptyStr emptyStr (), element = e }
91
87
92data ElementPrim
88data ElementPrim
93 = Image ImageStyle Int Int JSString
89 = Image ImageStyle Int Int JSString
@@ -121,6 +117,9 @@ tiledImage : Int -> Int -> String -> Element
121tiledImage w h src =
117tiledImage w h src =
122 newElement w h (Image Tiled w h (JS.fromString src))
118 newElement w h (Image Tiled w h (JS.fromString src))
123
119
120+markdown : Element
121+markdown = Native.Utils.undefined
122+
124data Three = P | Z | N
123data Three = P | Z | N
125data Pos = Absolute Int | Relative Float
124data Pos = Absolute Int | Relative Float
126type Position = { horizontal : Three, vertical : Three, x : Pos, y : Pos }
125type Position = { horizontal : Three, vertical : Three, x : Pos, y : Pos }
libraries/Graphics/Input.elm+29−10
@@ -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,8 +72,17 @@ 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)
77+
78+hoverables : a -> { events : Signal a,
79+ hoverable : (Bool -> a) -> Element -> Element }
80+hoverables = Native.Graphics.Input.hoverables
81+
82+hoverable : Element -> (Element, Signal Bool)
83+hoverable elem =
84+ let pool = hoverables False
85+ in (pool.hoverable id elem, pool.events)
69
86
70-- 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
71-- characters filling the text field. The `selectionStart` and `selectionEnd`
88-- characters filling the text field. The `selectionStart` and `selectionEnd`
@@ -90,6 +107,7 @@ type FieldState = { string:String, selectionStart:Int, selectionEnd:Int }
90-- lets you add an ID to distinguish between input fields.
107-- lets you add an ID to distinguish between input fields.
91fields : a -> { events : Signal a,
108fields : a -> { events : Signal a,
92 field : (FieldState -> a) -> String -> FieldState -> Element }
109 field : (FieldState -> a) -> String -> FieldState -> Element }
110+fields = Native.Graphics.Input.fields
93
111
94-- The empty field state:
112-- The empty field state:
95--
113--
@@ -102,7 +120,7 @@ emptyFieldState = { string="", selectionStart=0, selectionEnd=0 }
102-- content of the field.
120-- content of the field.
103field : String -> (Signal Element, Signal String)
121field : String -> (Signal Element, Signal String)
104field placeHolder =
122field placeHolder =
105− let tfs = N.fields emptyFieldState
123+ let tfs = fields emptyFieldState
106 changes = dropRepeats tfs.events
124 changes = dropRepeats tfs.events
107 in (lift (tfs.field id placeHolder) changes,
125 in (lift (tfs.field id placeHolder) changes,
108 dropRepeats (lift .string changes))
126 dropRepeats (lift .string changes))
@@ -110,7 +128,7 @@ field placeHolder =
110-- Same as `field` but the UI element blocks out each characters.
128-- Same as `field` but the UI element blocks out each characters.
111password : String -> (Signal Element, Signal String)
129password : String -> (Signal Element, Signal String)
112password placeHolder =
130password placeHolder =
113− let tfs = N.passwords emptyFieldState
131+ let tfs = Native.Graphics.Input.passwords emptyFieldState
114 changes = dropRepeats tfs.events
132 changes = dropRepeats tfs.events
115 in (lift (tfs.field id placeHolder) changes,
133 in (lift (tfs.field id placeHolder) changes,
116 dropRepeats (lift .string changes))
134 dropRepeats (lift .string changes))
@@ -120,7 +138,7 @@ password placeHolder =
120-- get a custom keyboard with an `@` and `.com` button.
138-- get a custom keyboard with an `@` and `.com` button.
121email : String -> (Signal Element, Signal String)
139email : String -> (Signal Element, Signal String)
122email placeHolder =
140email placeHolder =
123− let tfs = N.emails emptyFieldState
141+ let tfs = Native.Graphics.Input.emails emptyFieldState
124 changes = dropRepeats tfs.events
142 changes = dropRepeats tfs.events
125 in (lift (tfs.field id placeHolder) changes,
143 in (lift (tfs.field id placeHolder) changes,
126 dropRepeats (lift .string changes))
144 dropRepeats (lift .string changes))
@@ -130,9 +148,10 @@ email placeHolder =
130-- value. This lets you avoid manually mapping the string onto
148-- value. This lets you avoid manually mapping the string onto
131-- functions and values.
149-- functions and values.
132dropDown : [(String,a)] -> (Signal Element, Signal a)
150dropDown : [(String,a)] -> (Signal Element, Signal a)
151+dropDown = Native.Graphics.Input.dropDown
133
152
134-- Create a drop-down menu for selecting strings. The resulting
153-- Create a drop-down menu for selecting strings. The resulting
135-- signal of strings represents the string that is currently selected.
154-- signal of strings represents the string that is currently selected.
136stringDropDown : [String] -> (Signal Element, Signal String)
155stringDropDown : [String] -> (Signal Element, Signal String)
137stringDropDown strs =
156stringDropDown strs =
138− N.dropDown (List.map (\s -> (s,s)) strs)
157+ dropDown (List.map (\s -> (s,s)) strs)
libraries/Http.elm+4−2
@@ -4,8 +4,9 @@
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+139−116
@@ -12,7 +12,8 @@ Elm.Native.Graphics.Input = function(elm) {
12 var Signal = Elm.Signal(elm);
12 var Signal = Elm.Signal(elm);
13 var newElement = Elm.Graphics.Element(elm).newElement;
13 var newElement = Elm.Graphics.Element(elm).newElement;
14 var JS = Elm.Native.JavaScript(elm);
14 var JS = Elm.Native.JavaScript(elm);
15− var Tuple2 = Elm.Native.Utils(elm).Tuple2;
15+ var Utils = Elm.Native.Utils(elm);
16+ var Tuple2 = Utils.Tuple2;
16
17
17 function dropDown(values) {
18 function dropDown(values) {
18 var entries = JS.fromList(values);
19 var entries = JS.fromList(values);
@@ -56,29 +57,29 @@ Elm.Native.Graphics.Input = function(elm) {
56 var events = Signal.constant(defaultValue);
57 var events = Signal.constant(defaultValue);
57
58
58 function render(model) {
59 function render(model) {
59− var b = newNode('button');
60+ var b = newNode('button');
60− b.style.display = 'block';
61+ b.style.display = 'block';
61− b.elmEvent = model.event;
62+ b.elmEvent = model.event;
62− function click() { elm.notify(events.id, b.elmEvent); }
63+ function click() { elm.notify(events.id, b.elmEvent); }
63− b.addEventListener('click', click);
64+ b.addEventListener('click', click);
64− b.innerHTML = model.text;
65+ b.innerHTML = model.text;
65− return b;
66+ return b;
66 }
67 }
67
68
68 function update(node, oldModel, newModel) {
69 function update(node, oldModel, newModel) {
69− node.elmEvent = newModel.event;
70+ node.elmEvent = newModel.event;
70− var txt = newModel.text;
71+ var txt = newModel.text;
71− if (oldModel.text !== txt) node.innerHTML = txt;
72+ if (oldModel.text !== txt) node.innerHTML = txt;
72 }
73 }
73
74
74 function button(evnt, txt) {
75 function button(evnt, txt) {
75− return A3(newElement, 100, 40, {
76+ return A3(newElement, 100, 40, {
76 ctor: 'Custom',
77 ctor: 'Custom',
77− type: 'Button',
78+ type: 'Button',
78− render: render,
79+ render: render,
79− update: update,
80+ update: update,
80− model: { event:evnt, text:JS.fromString(txt) }
81+ model: { event:evnt, text:JS.fromString(txt) }
81− });
82+ });
82 }
83 }
83
84
84 return { _:{}, button:F2(button), events:events };
85 return { _:{}, button:F2(button), events:events };
@@ -88,94 +89,115 @@ Elm.Native.Graphics.Input = function(elm) {
88 var events = Signal.constant(defaultValue);
89 var events = Signal.constant(defaultValue);
89
90
90 function render(model) {
91 function render(model) {
91− var btn = newNode('div');
92+ var btn = newNode('div');
92− btn.elmEvent = model.event;
93+ btn.elmEvent = model.event;
93
94
94− btn.elmUp = Render.render(model.up);
95+ btn.elmUp = Render.render(model.up);
95− btn.elmHover = Render.render(model.hover);
96+ btn.elmHover = Render.render(model.hover);
96− btn.elmDown = Render.render(model.down);
97+ btn.elmDown = Render.render(model.down);
97
98
98− function replace(node) {
99+ function replace(node) {
99 if (node !== btn.firstChild) btn.replaceChild(node, btn.firstChild);
100 if (node !== btn.firstChild) btn.replaceChild(node, btn.firstChild);
100− }
101+ }
101− var overCount = 0;
102+ var overCount = 0;
102− function over(e) {
103+ function over(e) {
103− if (overCount++ > 0) return;
104+ if (overCount++ > 0) return;
104− replace(btn.elmHover);
105+ replace(btn.elmHover);
105− }
106+ }
106− function out(e) {
107+ function out(e) {
107− if (btn.contains(e.toElement || e.relatedTarget)) return;
108+ if (btn.contains(e.toElement || e.relatedTarget)) return;
108− overCount = 0;
109+ overCount = 0;
109− replace(btn.elmUp);
110+ replace(btn.elmUp);
110− }
111+ }
111− function up() {
112+ function up() {
112− replace(btn.elmHover);
113+ replace(btn.elmHover);
113− elm.notify(events.id, btn.elmEvent);
114+ elm.notify(events.id, btn.elmEvent);
114− }
115+ }
115− function down() { replace(btn.elmDown); }
116+ function down() { replace(btn.elmDown); }
116− btn.addEventListener('mouseover', over);
117+ btn.addEventListener('mouseover', over);
117− btn.addEventListener('mouseout' , out);
118+ btn.addEventListener('mouseout' , out);
118− btn.addEventListener('mousedown', down);
119+ btn.addEventListener('mousedown', down);
119− btn.addEventListener('mouseup' , up);
120+ btn.addEventListener('mouseup' , up);
120−
121+
121− 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+
122− return btn;
131+ return btn;
123 }
132 }
124
133
125 function update(node, oldModel, newModel) {
134 function update(node, oldModel, newModel) {
126− node.elmEvent = newModel.event;
135+ node.elmEvent = newModel.event;
127− Render.update(node.elmUp, oldModel.up, newModel.up)
136+ Render.update(node.elmUp, oldModel.up, newModel.up)
128− Render.update(node.elmHover, oldModel.hover, newModel.hover)
137+ Render.update(node.elmHover, oldModel.hover, newModel.hover)
129− Render.update(node.elmDown, oldModel.down, newModel.down)
138+ Render.update(node.elmDown, oldModel.down, newModel.down)
130 }
139 }
131
140
132 function button(evnt, up, hover, down) {
141 function button(evnt, up, hover, down) {
133− return A3(newElement,
142+ return A3(newElement,
134− Math.max(up.props.width, hover.props.width, down.props.width),
143+ Math.max(up.props.width, hover.props.width, down.props.width),
135− Math.max(up.props.height, hover.props.height, down.props.height),
144+ Math.max(up.props.height, hover.props.height, down.props.height),
136 { ctor: 'Custom',
145 { ctor: 'Custom',
137− type: 'CustomButton',
146+ type: 'CustomButton',
138− render: render,
147+ render: render,
139− update: update,
148+ update: update,
140− model: { event:evnt, up:up, hover:hover, down:down }
149+ model: { event:evnt, up:up, hover:hover, down:down }
141− });
150+ });
142 }
151 }
143
152
144 return { _:{}, customButton:F4(button), events:events };
153 return { _:{}, customButton:F4(button), events:events };
145 }
154 }
146
155
147
156
157+ function hoverables(defaultValue) {
158+ var events = Signal.constant(defaultValue);
159+ function hoverable(handler, elem) {
160+ function onHover(bool) {
161+ elm.notify(events.id, handler(bool));
162+ }
163+ var props = Utils.replace([['hover',onHover]], elem.props);
164+ return { props:props, element:elem.element };
165+ }
166+ return { _:{}, hoverable:F2(hoverable), events:events };
167+ }
168+
169+
148 function checkboxes(defaultValue) {
170 function checkboxes(defaultValue) {
149 var events = Signal.constant(defaultValue);
171 var events = Signal.constant(defaultValue);
150
172
151 function render(model) {
173 function render(model) {
152− var b = newNode('input');
174+ var b = newNode('input');
153− b.type = 'checkbox';
175+ b.type = 'checkbox';
154− b.checked = model.checked;
176+ b.checked = model.checked;
155− b.style.display = 'block';
177+ b.style.display = 'block';
156− b.elmHandler = model.handler;
178+ b.elmHandler = model.handler;
157− function change() { elm.notify(events.id, b.elmHandler(b.checked)); }
179+ function change() { elm.notify(events.id, b.elmHandler(b.checked)); }
158− b.addEventListener('change', change);
180+ b.addEventListener('change', change);
159− return b;
181+ return b;
160 }
182 }
161
183
162 function update(node, oldModel, newModel) {
184 function update(node, oldModel, newModel) {
163− node.elmHandler = newModel.handler;
185+ node.elmHandler = newModel.handler;
164− node.checked = newModel.checked;
186+ node.checked = newModel.checked;
165− return true;
187+ return true;
166 }
188 }
167
189
168 function box(handler, checked) {
190 function box(handler, checked) {
169− return A3(newElement, 13, 13, {
191+ return A3(newElement, 13, 13, {
170 ctor: 'Custom',
192 ctor: 'Custom',
171− type: 'CheckBox',
193+ type: 'CheckBox',
172− render: render,
194+ render: render,
173− update: update,
195+ update: update,
174− model: { checked:checked, handler:handler }
196+ model: { checked:checked, handler:handler }
175− });
197+ });
176 }
198 }
177
199
178− return { _:{}, box:F2(box), events:events };
200+ return { _:{}, checkbox:F2(box), events:events };
179 }
201 }
180
202
181 function setRange(node, start, end, dir) {
203 function setRange(node, start, end, dir) {
@@ -192,49 +214,49 @@ Elm.Native.Graphics.Input = function(elm) {
192 var state = null;
214 var state = null;
193
215
194 function render(model) {
216 function render(model) {
195− var field = newNode('input');
217+ var field = newNode('input');
196− field.elmHandler = model.handler;
218+ field.elmHandler = model.handler;
197−
219+
198− field.id = 'test';
220+ field.id = 'test';
199− field.type = type;
221+ field.type = type;
200− field.placeholder = JS.fromString(model.placeHolder);
222+ field.placeholder = JS.fromString(model.placeHolder);
201− field.value = JS.fromString(model.state.string);
223+ field.value = JS.fromString(model.state.string);
202− setRange(field, model.state.selectionStart, model.state.selectionEnd, 'forward');
224+ setRange(field, model.state.selectionStart, model.state.selectionEnd, 'forward');
203− field.style.border = 'none';
225+ field.style.border = 'none';
204 state = model.state;
226 state = model.state;
205
227
206− function update() {
228+ function update() {
207− var start = field.selectionStart,
229+ var start = field.selectionStart,
208− end = field.selectionEnd;
230+ end = field.selectionEnd;
209− if (field.selectionDirection === 'backward') {
231+ if (field.selectionDirection === 'backward') {
210− start = end;
232+ start = end;
211− end = field.selectionStart;
233+ end = field.selectionStart;
212− }
234+ }
213 state = { _:{},
235 state = { _:{},
214 string:JS.toString(field.value),
236 string:JS.toString(field.value),
215 selectionStart:start,
237 selectionStart:start,
216 selectionEnd:end };
238 selectionEnd:end };
217− elm.notify(events.id, field.elmHandler(state));
239+ elm.notify(events.id, field.elmHandler(state));
218− }
240+ }
219− function mousedown() {
241+ function mousedown() {
220− update();
242+ update();
221− elm.node.addEventListener('mouseup', mouseup);
243+ elm.node.addEventListener('mouseup', mouseup);
222− }
244+ }
223− function mouseup() {
245+ function mouseup() {
224− update();
246+ update();
225− elm.node.removeEventListener('mouseup', mouseup)
247+ elm.node.removeEventListener('mouseup', mouseup)
226− }
248+ }
227− field.addEventListener('keyup', update);
249+ field.addEventListener('keyup', update);
228− field.addEventListener('mousedown', mousedown);
250+ field.addEventListener('mousedown', mousedown);
229−
251+
230− return field;
252+ return field;
231 }
253 }
232
254
233 function update(node, oldModel, newModel) {
255 function update(node, oldModel, newModel) {
234− node.elmHandler = newModel.handler;
256+ node.elmHandler = newModel.handler;
235 if (state === newModel.state) return;
257 if (state === newModel.state) return;
236 var newStr = JS.fromString(newModel.state.string);
258 var newStr = JS.fromString(newModel.state.string);
237− if (node.value !== newStr) node.value = newStr;
259+ if (node.value !== newStr) node.value = newStr;
238
260
239 var start = newModel.state.selectionStart;
261 var start = newModel.state.selectionStart;
240 var end = newModel.state.selectionEnd;
262 var end = newModel.state.selectionEnd;
@@ -253,15 +275,15 @@ Elm.Native.Graphics.Input = function(elm) {
253 }
275 }
254
276
255 function field(handler, placeHolder, state) {
277 function field(handler, placeHolder, state) {
256− return A3(newElement, 200, 30,
278+ return A3(newElement, 200, 30,
257 { ctor: 'Custom',
279 { ctor: 'Custom',
258− type: type + 'Input',
280+ type: type + 'Input',
259− render: render,
281+ render: render,
260− update: update,
282+ update: update,
261− model: { handler:handler,
283+ model: { handler:handler,
262− placeHolder:placeHolder,
284+ placeHolder:placeHolder,
263− state:state }
285+ state:state }
264− });
286+ });
265 }
287 }
266
288
267 return { _:{}, field:F3(field), events:events };
289 return { _:{}, field:F3(field), events:events };
@@ -271,6 +293,7 @@ Elm.Native.Graphics.Input = function(elm) {
271 return elm.Native.Graphics.Input = {
293 return elm.Native.Graphics.Input = {
272 buttons:buttons,
294 buttons:buttons,
273 customButtons:customButtons,
295 customButtons:customButtons,
296+ hoverables:hoverables,
274 checkboxes:checkboxes,
297 checkboxes:checkboxes,
275 fields:mkTextPool('text'),
298 fields:mkTextPool('text'),
276 emails:mkTextPool('email'),
299 emails:mkTextPool('email'),
libraries/Native/JavaScript.js+48−45
@@ -9,57 +9,60 @@ Elm.Native.JavaScript = function(elm) {
9 var Render = ElmRuntime.use(ElmRuntime.Render.Element);
9 var Render = ElmRuntime.use(ElmRuntime.Render.Element);
10
10
11 function fromJS(v) {
11 function fromJS(v) {
12− var type = typeof v;
12+ var type = typeof v;
13− if (type === 'number' ) return v;
13+ if (type === 'number' ) return v;
14− if (type === 'boolean') return v;
14+ if (type === 'boolean') return v;
15− if (type === 'string' ) return List.fromArray(v);
15+ if (type === 'string' ) return List.fromArray(v);
16− if (v instanceof Array) {
16+ if (v instanceof Array) {
17− var arr = [];
17+ var arr = [];
18− var len = v.length;
18+ var len = v.length;
19− for (var i = 0; i < len; ++i) {
19+ for (var i = 0; i < len; ++i) {
20− var x = fromJS(v[i]);
20+ var x = fromJS(v[i]);
21− if (x !== null) arr.push(x);
21+ if (x !== null) arr.push(x);
22+ }
23+ return List.fromArray(arr);
22 }
24 }
23− return List.fromArray(arr);
24− }
25− if (type === 'object') {
25+ if (type === 'object') {
26− var rec = { _:{} };
26+ var rec = { _:{} };
27− for (var f in v) {
27+ for (var f in v) {
28− var x = fromJS(v[f]);
28+ var x = fromJS(v[f]);
29− if (x !== null) rec[f] = x;
29+ if (x !== null) rec[f] = x;
30+ }
31+ return rec;
30 }
32 }
31− return rec;
33+ return null;
32− }
33− return null;
34 }
34 }
35
35
36 function toJS(v) {
36 function toJS(v) {
37− var type = typeof v;
37+ var type = typeof v;
38− if (type === 'number' || type === 'boolean') return v;
38+ if (type === 'number' || type === 'boolean') return v;
39− if (type === 'object' && '_' in v) {
39+ if (type === 'object' && '_' in v) {
40− var obj = {};
40+ var obj = {};
41− for (var k in v) {
41+ for (var k in v) {
42− var x = v[k];
42+ var x = toJS(v[k]);
43− if (x !== null) obj[k] = x;
43+ if (x !== null) obj[k] = x;
44− }
44+ }
45− return obj;
45+ return obj;
46− }
46+ }
47− if (type === 'object' && (v.ctor === 'Cons' || v.ctor === 'Nil')) {
47+ if (type === 'object' && (v.ctor === '::' || v.ctor === '[]')) {
48− var array = List.toArray(v);
48+ var array = List.toArray(v);
49− for (var i = array.length; i--; ) {
50− array[i] = toJS(array[i]);
51− }
52− if (typeof array[0] === 'string') array.join('');
49+ if (typeof array[0] === 'string') {
50+ array = array.join('');
51+ } else {
52+ for (var i = array.length; i--; ) {
53+ array[i] = toJS(array[i]);
54+ }
55+ }
53− return array;
56+ return array;
54− }
57+ }
55− return null;
58+ return null;
56 }
59 }
57−
60+
58 function fromRecord(r) {
61 function fromRecord(r) {
59− if (typeof r === 'object' && '_' in r) {
62+ if (typeof r === 'object' && '_' in r) {
60− return toJS(r);
63+ return toJS(r);
61− }
64+ }
62− throw new Error("'fromRecord' must be called on a record.");
65+ throw new Error("'fromRecord' must be called on a record.");
63 }
66 }
64
67
65 function id(n) { return n; }
68 function id(n) { return n; }
@@ -99,4 +102,4 @@ Elm.Native.JavaScript = function(elm) {
99 fromRecord : fromRecord
102 fromRecord : fromRecord
100 };
103 };
101
104
102−};
105+};
libraries/Native/List.js+34−28
@@ -9,7 +9,7 @@ Elm.Native.List = function(elm) {
9 var Utils = Elm.Native.Utils(elm);
9 var Utils = Elm.Native.Utils(elm);
10
10
11 // TODO: Improve Nil handling
11 // TODO: Improve Nil handling
12− // We can change places like: if (xs.ctor === 'Nil') ... to if (xs === Nil) ...
12+ // We can change places like: if (xs.ctor === '[]') ... to if (xs === Nil) ...
13 // but only if we're confident Nil can only be defined once.
13 // but only if we're confident Nil can only be defined once.
14 // Currently (27Mar2013) each module can have different instantiations, so multiple Nil objects can exist
14 // Currently (27Mar2013) each module can have different instantiations, so multiple Nil objects can exist
15 // (and if they're used interchangeably then direct object comparison fails where ctor doesn't).
15 // (and if they're used interchangeably then direct object comparison fails where ctor doesn't).
@@ -17,11 +17,11 @@ Elm.Native.List = function(elm) {
17 // The performance overhead of the .ctor calls is 5-10% according to jsperf (depending on fn + list size)
17 // The performance overhead of the .ctor calls is 5-10% according to jsperf (depending on fn + list size)
18 // (on firefox 19)
18 // (on firefox 19)
19
19
20− var Nil = { ctor:'Nil' };
20+ var Nil = { ctor:'[]' };
21
21
22 // using freeze for every cons would be nice but is a huge (9x on firefox 19)
22 // using freeze for every cons would be nice but is a huge (9x on firefox 19)
23 // performance penalty
23 // performance penalty
24− function Cons(hd,tl) { return { ctor:"Cons", _0:hd, _1:tl }; }
24+ function Cons(hd,tl) { return { ctor:"::", _0:hd, _1:tl }; }
25
25
26 function throwError(f) {
26 function throwError(f) {
27 throw new Error("Function '" + f + "' expects a non-empty list!");
27 throw new Error("Function '" + f + "' expects a non-empty list!");
@@ -29,7 +29,7 @@ Elm.Native.List = function(elm) {
29
29
30 function toArray(xs) {
30 function toArray(xs) {
31 var out = [];
31 var out = [];
32− while (xs.ctor !== 'Nil') {
32+ while (xs.ctor !== '[]') {
33 out.push(xs._0);
33 out.push(xs._0);
34 xs = xs._1;
34 xs = xs._1;
35 }
35 }
@@ -54,11 +54,11 @@ Elm.Native.List = function(elm) {
54
54
55 function append(xs,ys) {
55 function append(xs,ys) {
56 if (typeof xs === "string") { return xs.concat(ys); }
56 if (typeof xs === "string") { return xs.concat(ys); }
57− if (xs.ctor === 'Nil') { return ys; }
57+ if (xs.ctor === '[]') { return ys; }
58 var root = Cons(xs._0, Nil);
58 var root = Cons(xs._0, Nil);
59 var curr = root;
59 var curr = root;
60 xs = xs._1;
60 xs = xs._1;
61− while (xs.ctor !== 'Nil') {
61+ while (xs.ctor !== '[]') {
62 curr._1 = Cons(xs._0, Nil);
62 curr._1 = Cons(xs._0, Nil);
63 xs = xs._1;
63 xs = xs._1;
64 curr = curr._1;
64 curr = curr._1;
@@ -67,13 +67,13 @@ Elm.Native.List = function(elm) {
67 return root;
67 return root;
68 }
68 }
69
69
70− function head(v) { return v.ctor === 'Nil' ? throwError('head') : v._0; }
70+ function head(v) { return v.ctor === '[]' ? throwError('head') : v._0; }
71− function tail(v) { return v.ctor === 'Nil' ? throwError('tail') : v._1; }
71+ function tail(v) { return v.ctor === '[]' ? throwError('tail') : v._1; }
72
72
73 function last(xs) {
73 function last(xs) {
74− if (xs.ctor === 'Nil') { throwError('last'); }
74+ if (xs.ctor === '[]') { throwError('last'); }
75 var out = xs._0;
75 var out = xs._0;
76− while (xs.ctor !== 'Nil') {
76+ while (xs.ctor !== '[]') {
77 out = xs._0;
77 out = xs._0;
78 xs = xs._1;
78 xs = xs._1;
79 }
79 }
@@ -82,7 +82,7 @@ Elm.Native.List = function(elm) {
82
82
83 function map(f, xs) {
83 function map(f, xs) {
84 var arr = [];
84 var arr = [];
85− while (xs.ctor !== 'Nil') {
85+ while (xs.ctor !== '[]') {
86 arr.push(f(xs._0));
86 arr.push(f(xs._0));
87 xs = xs._1;
87 xs = xs._1;
88 }
88 }
@@ -90,10 +90,10 @@ 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 !== 'Nil') {
96+ while (xs.ctor !== '[]') {
97 acc = A2(f, xs._0, acc);
97 acc = A2(f, xs._0, acc);
98 xs = xs._1;
98 xs = xs._1;
99 }
99 }
@@ -110,11 +110,11 @@ Elm.Native.List = function(elm) {
110 }
110 }
111
111
112 function foldl1(f, xs) {
112 function foldl1(f, xs) {
113− return xs.ctor === 'Nil' ? throwError('foldl1') : foldl(f, xs._0, xs._1);
113+ return xs.ctor === '[]' ? throwError('foldl1') : foldl(f, xs._0, xs._1);
114 }
114 }
115
115
116 function foldr1(f, xs) {
116 function foldr1(f, xs) {
117− if (xs.ctor === 'Nil') { throwError('foldr1'); }
117+ if (xs.ctor === '[]') { throwError('foldr1'); }
118 var arr = toArray(xs);
118 var arr = toArray(xs);
119 var acc = arr.pop();
119 var acc = arr.pop();
120 for (var i = arr.length; i--; ) {
120 for (var i = arr.length; i--; ) {
@@ -134,12 +134,12 @@ Elm.Native.List = function(elm) {
134 }
134 }
135
135
136 function scanl1(f, xs) {
136 function scanl1(f, xs) {
137− return xs.ctor === 'Nil' ? throwError('scanl1') : scanl(f, xs._0, xs._1);
137+ return xs.ctor === '[]' ? throwError('scanl1') : scanl(f, xs._0, xs._1);
138 }
138 }
139
139
140 function filter(pred, xs) {
140 function filter(pred, xs) {
141 var arr = [];
141 var arr = [];
142− while (xs.ctor !== 'Nil') {
142+ while (xs.ctor !== '[]') {
143 if (pred(xs._0)) { arr.push(xs._0); }
143 if (pred(xs._0)) { arr.push(xs._0); }
144 xs = xs._1;
144 xs = xs._1;
145 }
145 }
@@ -148,7 +148,7 @@ Elm.Native.List = function(elm) {
148
148
149 function length(xs) {
149 function length(xs) {
150 var out = 0;
150 var out = 0;
151− while (xs.ctor !== 'Nil') {
151+ while (xs.ctor !== '[]') {
152 out += 1;
152 out += 1;
153 xs = xs._1;
153 xs = xs._1;
154 }
154 }
@@ -156,7 +156,7 @@ Elm.Native.List = function(elm) {
156 }
156 }
157
157
158 function member(x, xs) {
158 function member(x, xs) {
159− while (xs.ctor !== 'Nil') {
159+ while (xs.ctor !== '[]') {
160 if (Utils.eq(x,xs._0)) return true;
160 if (Utils.eq(x,xs._0)) return true;
161 xs = xs._1;
161 xs = xs._1;
162 }
162 }
@@ -166,7 +166,7 @@ Elm.Native.List = function(elm) {
166 function reverse(xs) { return fromArray(toArray(xs).reverse()); }
166 function reverse(xs) { return fromArray(toArray(xs).reverse()); }
167
167
168 function concat(xss) {
168 function concat(xss) {
169− if (xss.ctor === 'Nil') return xss;
169+ if (xss.ctor === '[]') return xss;
170 var arr = toArray(xss);
170 var arr = toArray(xss);
171 var xs = arr[arr.length-1];
171 var xs = arr[arr.length-1];
172 for (var i = arr.length-1; i--; ) {
172 for (var i = arr.length-1; i--; ) {
@@ -176,7 +176,7 @@ Elm.Native.List = function(elm) {
176 }
176 }
177
177
178 function all(pred, xs) {
178 function all(pred, xs) {
179− while (xs.ctor !== 'Nil') {
179+ while (xs.ctor !== '[]') {
180 if (!pred(xs._0)) return false;
180 if (!pred(xs._0)) return false;
181 xs = xs._1;
181 xs = xs._1;
182 }
182 }
@@ -184,7 +184,7 @@ Elm.Native.List = function(elm) {
184 }
184 }
185
185
186 function any(pred, xs) {
186 function any(pred, xs) {
187− while (xs.ctor !== 'Nil') {
187+ while (xs.ctor !== '[]') {
188 if (pred(xs._0)) return true;
188 if (pred(xs._0)) return true;
189 xs = xs._1;
189 xs = xs._1;
190 }
190 }
@@ -193,7 +193,7 @@ Elm.Native.List = function(elm) {
193
193
194 function zipWith(f, xs, ys) {
194 function zipWith(f, xs, ys) {
195 var arr = [];
195 var arr = [];
196− while (xs.ctor !== 'Nil' && ys.ctor !== 'Nil') {
196+ while (xs.ctor !== '[]' && ys.ctor !== '[]') {
197 arr.push(A2(f, xs._0, ys._0));
197 arr.push(A2(f, xs._0, ys._0));
198 xs = xs._1;
198 xs = xs._1;
199 ys = ys._1;
199 ys = ys._1;
@@ -203,7 +203,7 @@ Elm.Native.List = function(elm) {
203
203
204 function zip(xs, ys) {
204 function zip(xs, ys) {
205 var arr = [];
205 var arr = [];
206− while (xs.ctor !== 'Nil' && ys.ctor !== 'Nil') {
206+ while (xs.ctor !== '[]' && ys.ctor !== '[]') {
207 arr.push(Utils.Tuple2(xs._0, ys._0));
207 arr.push(Utils.Tuple2(xs._0, ys._0));
208 xs = xs._1;
208 xs = xs._1;
209 ys = ys._1;
209 ys = ys._1;
@@ -219,9 +219,13 @@ 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 !== 'Nil' && n > 0) {
228+ while (xs.ctor !== '[]' && n > 0) {
225 arr.push(xs._0);
229 arr.push(xs._0);
226 xs = xs._1;
230 xs = xs._1;
227 --n;
231 --n;
@@ -230,7 +234,7 @@ Elm.Native.List = function(elm) {
230 }
234 }
231
235
232 function drop(n, xs) {
236 function drop(n, xs) {
233− while (xs.ctor !== 'Nil' && n > 0) {
237+ while (xs.ctor !== '[]' && n > 0) {
234 xs = xs._1;
238 xs = xs._1;
235 --n;
239 --n;
236 }
240 }
@@ -239,11 +243,11 @@ Elm.Native.List = function(elm) {
239
243
240 function join(sep, xss) {
244 function join(sep, xss) {
241 if (typeof sep === 'string') return toArray(xss).join(sep);
245 if (typeof sep === 'string') return toArray(xss).join(sep);
242− if (xss.ctor === 'Nil') return Nil;
246+ if (xss.ctor === '[]') return Nil;
243 var s = toArray(sep);
247 var s = toArray(sep);
244 var out = toArray(xss._0);
248 var out = toArray(xss._0);
245 xss = xss._1;
249 xss = xss._1;
246− while (xss.ctor !== 'Nil') {
250+ while (xss.ctor !== '[]') {
247 out = out.concat(s, toArray(xss._0));
251 out = out.concat(s, toArray(xss._0));
248 xss = xss._1;
252 xss = xss._1;
249 }
253 }
@@ -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+8−7
@@ -37,14 +37,14 @@ 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;
44 output.push(toString(v[k]));
44 output.push(toString(v[k]));
45 }
45 }
46 return "(" + output.join(",") + ")";
46 return "(" + output.join(",") + ")";
47− } else if (v.ctor === "Cons") {
47+ } else if (v.ctor === "::") {
48 var isStr = typeof v._0 === "string",
48 var isStr = typeof v._0 === "string",
49 start = isStr ? '"' : "[",
49 start = isStr ? '"' : "[",
50 end = isStr ? '"' : "]",
50 end = isStr ? '"' : "]",
@@ -52,18 +52,18 @@ Elm.Native.Show = function(elm) {
52 f = !isStr ? toString : showChar;
52 f = !isStr ? toString : showChar;
53 var output = start + f(v._0);
53 var output = start + f(v._0);
54 v = v._1;
54 v = v._1;
55− while (v.ctor === "Cons") {
55+ while (v.ctor === "::") {
56 output += sep + f(v._0);
56 output += sep + f(v._0);
57 v = v._1;
57 v = v._1;
58 }
58 }
59 return output + end;
59 return output + end;
60− } else if (v.ctor === "Nil") {
60+ } else if (v.ctor === "[]") {
61 return "[]";
61 return "[]";
62 } else if (v.ctor === "RBNode" || v.ctor === "RBEmpty") {
62 } else if (v.ctor === "RBNode" || v.ctor === "RBEmpty") {
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 === "Cons" && 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/Http.js+1−1
@@ -11,7 +11,7 @@ Elm.Native.Http = function(elm) {
11
11
12
12
13 function registerReq(queue,responses) { return function(req) {
13 function registerReq(queue,responses) { return function(req) {
14− if (req.url.ctor !== 'Nil') { sendReq(queue,responses,req); }
14+ if (req.url.ctor !== '[]') { sendReq(queue,responses,req); }
15 };
15 };
16 }
16 }
17
17
libraries/Native/Signal/Keyboard.js+2−2
@@ -26,7 +26,7 @@ Elm.Native.Keyboard = function(elm) {
26 });
26 });
27
27
28 function keySignal(f) {
28 function keySignal(f) {
29− var signal = A2( Signal.lift, f, keysDown );
29+ var signal = Signal.dropRepeats(A2(Signal.lift, f, keysDown));
30 keysDown.defaultNumberOfKids += 1;
30 keysDown.defaultNumberOfKids += 1;
31 signal.defaultNumberOfKids = 0;
31 signal.defaultNumberOfKids = 0;
32 return signal;
32 return signal;
@@ -35,7 +35,7 @@ Elm.Native.Keyboard = function(elm) {
35 function dir(up, down, left, right) {
35 function dir(up, down, left, right) {
36 function f(ks) {
36 function f(ks) {
37 var x = 0, y = 0;
37 var x = 0, y = 0;
38− while (ks.ctor == "Cons") {
38+ while (ks.ctor === "::") {
39 switch (ks._0) {
39 switch (ks._0) {
40 case left : --x; break;
40 case left : --x; break;
41 case right: ++x; break;
41 case right: ++x; break;
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/Text.js+1−1
@@ -71,7 +71,7 @@ Elm.Native.Text = function(elm) {
71 }
71 }
72 function size(px, text) { return addStyle('font-size', px + 'px', text) }
72 function size(px, text) { return addStyle('font-size', px + 'px', text) }
73 var header = addTag('h1');
73 var header = addTag('h1');
74− function height(h, text) { return addStyle('font-size', h+'em', text) }
74+ function height(h, text) { return addStyle('font-size', h+'px', text) }
75 function italic(text) { return addStyle('font-style', 'italic', text) }
75 function italic(text) { return addStyle('font-style', 'italic', text) }
76 var bold = addTag('b');
76 var bold = addTag('b');
77
77
libraries/Native/Utils.js+12−10
@@ -19,16 +19,18 @@ 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;
27
29
28− if (x.ctor === "Cons" || x.ctor === "Nil") {
30+ if (x.ctor === "::" || x.ctor === "[]") {
29 while (true) {
31 while (true) {
30− if (x.ctor === "Nil" && y.ctor === "Nil") return EQ;
32+ if (x.ctor === "[]" && y.ctor === "[]") return EQ;
31− if (x.ctor !== y.ctor) return x.ctor === 'Nil' ? LT : GT;
33+ if (x.ctor !== y.ctor) return x.ctor === '[]' ? LT : GT;
32 ord = cmp(x._0, y._0);
34 ord = cmp(x._0, y._0);
33 if (ord !== EQ) return ord;
35 if (ord !== EQ) return ord;
34 x = x._1;
36 x = x._1;
@@ -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+26−2
@@ -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 \"ems\". 1em is the normal height of text. 2ems is twice that height.
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/Collage.js+20−6
@@ -138,6 +138,7 @@ function renderForm(redo, ctx, form) {
138 if (x !== 0 || y !== 0) ctx.translate(x, y);
138 if (x !== 0 || y !== 0) ctx.translate(x, y);
139 if (theta !== 0) ctx.rotate(theta);
139 if (theta !== 0) ctx.rotate(theta);
140 if (scale !== 1) ctx.scale(scale,scale);
140 if (scale !== 1) ctx.scale(scale,scale);
141+ if (form.alpha !== 1) ctx.globalAlpha = ctx.globalAlpha * form.alpha;
141 ctx.beginPath();
142 ctx.beginPath();
142 var f = form.form;
143 var f = form.form;
143 switch(f.ctor) {
144 switch(f.ctor) {
@@ -198,6 +199,7 @@ function stepperHelp(list) {
198function stepper(forms) {
199function stepper(forms) {
199 var ps = [stepperHelp(forms)];
200 var ps = [stepperHelp(forms)];
200 var matrices = [];
201 var matrices = [];
202+ var alphas = [];
201 function peekNext() {
203 function peekNext() {
202 var len = ps.length;
204 var len = ps.length;
203 var formType = '';
205 var formType = '';
@@ -208,20 +210,30 @@ function stepper(forms) {
208 }
210 }
209 // assumes that there is a next element
211 // assumes that there is a next element
210 function next(ctx) {
212 function next(ctx) {
211− while (!ps[0].peekNext()) { ps.shift(); matrices.pop(); if (ctx) { ctx.restore(); } }
213+ while (!ps[0].peekNext()) {
214+ ps.shift();
215+ matrices.pop();
216+ alphas.shift();
217+ if (ctx) { ctx.restore(); }
218+ }
212 var out = ps[0].next();
219 var out = ps[0].next();
213 var f = out.form;
220 var f = out.form;
214 if (f.ctor === 'FGroup') {
221 if (f.ctor === 'FGroup') {
215 ps.unshift(stepperHelp(f._1));
222 ps.unshift(stepperHelp(f._1));
216− var m = A2( Matrix.multiply, f._0, formToMatrix(out));
223+ var m = A2(Matrix.multiply, f._0, formToMatrix(out));
217 ctx.save();
224 ctx.save();
218 ctx.transform(m[0], m[3], m[1], m[4], m[2], m[5]);
225 ctx.transform(m[0], m[3], m[1], m[4], m[2], m[5]);
219 matrices.push(m);
226 matrices.push(m);
227+
228+ var alpha = (alphas[0] || 1) * out.alpha;
229+ alphas.unshift(alpha);
230+ ctx.globalAlpha = alpha;
220 }
231 }
221 return out;
232 return out;
222 }
233 }
223 function transforms() { return matrices; }
234 function transforms() { return matrices; }
235+ function alpha() { return alphas[0] || 1; }
224− return { peekNext:peekNext, next:next, transforms:transforms };
236+ return { peekNext:peekNext, next:next, transforms:transforms, alpha:alpha };
225}
237}
226
238
227function makeCanvas(w,h) {
239function makeCanvas(w,h) {
@@ -274,7 +286,7 @@ function updateTracker(w,h,div) {
274 ++i;
286 ++i;
275 return transform(transforms, canvas.getContext('2d'));
287 return transform(transforms, canvas.getContext('2d'));
276 }
288 }
277− function element(matrices, form) {
289+ function element(matrices, alpha, form) {
278 var container = kids[i];
290 var container = kids[i];
279 if (!container || container.getContext) {
291 if (!container || container.getContext) {
280 container = newElement('div');
292 container = newElement('div');
@@ -291,6 +303,7 @@ function updateTracker(w,h,div) {
291
303
292 container.style.width = w + 'px';
304 container.style.width = w + 'px';
293 container.style.height = h + 'px';
305 container.style.height = h + 'px';
306+ container.style.opacity = alpha * form.alpha;
294
307
295 var elem = form.form._0;
308 var elem = form.form._0;
296 var node = container.firstChild;
309 var node = container.firstChild;
@@ -331,17 +344,18 @@ function update(div, _, model) {
331 while (formType = stpr.peekNext()) {
344 while (formType = stpr.peekNext()) {
332 if (ctx === null && formType !== 'FElement') {
345 if (ctx === null && formType !== 'FElement') {
333 ctx = tracker.getContext(stpr.transforms());
346 ctx = tracker.getContext(stpr.transforms());
347+ ctx.globalAlpha = stpr.alpha();
334 }
348 }
335 var form = stpr.next(ctx);
349 var form = stpr.next(ctx);
336 if (formType === 'FElement') {
350 if (formType === 'FElement') {
337− tracker.element(stpr.transforms(), form);
351+ tracker.element(stpr.transforms(), stpr.alpha(), form);
338 ctx = null;
352 ctx = null;
339 } else if (formType !== 'FGroup') {
353 } else if (formType !== 'FGroup') {
340 renderForm(function() { update(div, model, model); }, ctx, form);
354 renderForm(function() { update(div, model, model); }, ctx, form);
341 }
355 }
342 }
356 }
343 tracker.clearRest();
357 tracker.clearRest();
344− return div;
358+ return false;
345}
359}
346
360
347return { render:render, update:update };
361return { render:render, update:update };
runtime/Render/Element.js+97−73
@@ -12,14 +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;
29+ }
30+ if (props.hover.ctor !== '_Tuple0') {
31+ var overCount = 0;
32+ e.addEventListener('mouseover', function() {
33+ if (overCount++ > 0) return;
34+ props.hover(true);
35+ });
36+ e.addEventListener('mouseout', function(evt) {
37+ if (e.contains(evt.toElement || evt.relatedTarget)) return;
38+ overCount = 0;
39+ props.hover(false);
40+ });
23 }
41 }
24 return e;
42 return e;
25}
43}
@@ -64,11 +82,11 @@ function croppedImage(elem, w, h, src) {
64
82
65 var img = newElement('img');
83 var img = newElement('img');
66 img.onload = function() {
84 img.onload = function() {
67− var sw = w / elem._1, sh = h / elem._2;
85+ var sw = w / elem._1, sh = h / elem._2;
68− img.style.width = ((this.width * sw)|0) + 'px';
86+ img.style.width = ((this.width * sw)|0) + 'px';
69− img.style.height = ((this.height * sh)|0) + 'px';
87+ img.style.height = ((this.height * sh)|0) + 'px';
70− img.style.marginLeft = ((- pos._0 * sw)|0) + 'px';
88+ img.style.marginLeft = ((- pos._0 * sw)|0) + 'px';
71− img.style.marginTop = ((- pos._1 * sh)|0) + 'px';
89+ img.style.marginTop = ((- pos._1 * sh)|0) + 'px';
72 };
90 };
73 img.src = src;
91 img.src = src;
74 img.name = src;
92 img.name = src;
@@ -82,7 +100,7 @@ function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e;
82function flowWith(f, array) {
100function flowWith(f, array) {
83 var container = newElement('div');
101 var container = newElement('div');
84 for (var i = array.length; i--; ) {
102 for (var i = array.length; i--; ) {
85− container.appendChild(f(render(array[i])));
103+ container.appendChild(f(render(array[i])));
86 }
104 }
87 return container;
105 return container;
88}
106}
@@ -157,8 +175,8 @@ function update(node, curr, next) {
157 if (node.tagName === 'A') { node = node.firstChild; }
175 if (node.tagName === 'A') { node = node.firstChild; }
158 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);
159 if (curr.element.ctor !== next.element.ctor) {
177 if (curr.element.ctor !== next.element.ctor) {
160− node.parentNode.replaceChild(render(next),node);
178+ node.parentNode.replaceChild(render(next),node);
161− return true;
179+ return true;
162 }
180 }
163 var nextE = next.element, currE = curr.element;
181 var nextE = next.element, currE = curr.element;
164 switch(nextE.ctor) {
182 switch(nextE.ctor) {
@@ -167,61 +185,61 @@ function update(node, curr, next) {
167 if (nextE._0 !== currE._0) node.innerHTML = nextE._0;
185 if (nextE._0 !== currE._0) node.innerHTML = nextE._0;
168 break;
186 break;
169 case "Image":
187 case "Image":
170− if (nextE._0.ctor === 'Plain') {
188+ if (nextE._0.ctor === 'Plain') {
171− if (nextE._3 !== currE._3) node.src = nextE._3;
189+ if (nextE._3 !== currE._3) node.src = nextE._3;
172− } else if (!eq(nextE,currE) ||
190+ } else if (!eq(nextE,currE) ||
173− next.props.width !== curr.props.width ||
191+ next.props.width !== curr.props.width ||
174− next.props.height !== curr.props.height) {
192+ next.props.height !== curr.props.height) {
175− node.parentNode.replaceChild(render(next),node);
193+ node.parentNode.replaceChild(render(next),node);
176− return true;
194+ return true;
177− }
195+ }
178− break;
196+ break;
179 case "Flow":
197 case "Flow":
180 var arr = fromList(nextE._1);
198 var arr = fromList(nextE._1);
181 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; }
182− if (nextE._0.ctor !== currE._0.ctor) {
200+ if (nextE._0.ctor !== currE._0.ctor) {
183− node.parentNode.replaceChild(render(next),node);
201+ node.parentNode.replaceChild(render(next),node);
184− return true;
202+ return true;
185− }
203+ }
186− var nexts = fromList(nextE._1);
204+ var nexts = fromList(nextE._1);
187− var kids = node.childNodes;
205+ var kids = node.childNodes;
188− if (nexts.length !== kids.length) {
206+ if (nexts.length !== kids.length) {
189− node.parentNode.replaceChild(render(next),node);
207+ node.parentNode.replaceChild(render(next),node);
190− return true;
208+ return true;
191− }
209+ }
192− var currs = fromList(currE._1);
210+ var currs = fromList(currE._1);
193− var goDir = function(x) { return x; };
211+ var goDir = function(x) { return x; };
194− switch(nextE._0.ctor) {
212+ switch(nextE._0.ctor) {
195− case "DDown": case "DUp": goDir = goDown; break;
213+ case "DDown": case "DUp": goDir = goDown; break;
196− case "DRight": case "DLeft": goDir = goRight; break;
214+ case "DRight": case "DLeft": goDir = goRight; break;
197− case "DOut": case "DIn": goDir = goIn; break;
215+ case "DOut": case "DIn": goDir = goIn; break;
198− }
216+ }
199− for (var i = kids.length; i-- ;) {
217+ for (var i = kids.length; i-- ;) {
200− update(kids[i],currs[i],nexts[i]);
218+ update(kids[i],currs[i],nexts[i]);
201− goDir(kids[i]);
219+ goDir(kids[i]);
202− }
220+ }
203− break;
221+ break;
204 case "Container":
222 case "Container":
205− var inner = node.firstChild;
223+ var inner = node.firstChild;
206− if (!update(inner, currE._1, nextE._1)) {
224+ if (!update(inner, currE._1, nextE._1)) {
207− if (nextE._0.horizontal.ctor !== currE._0.horizontal.ctor) {
225+ if (nextE._0.horizontal.ctor !== currE._0.horizontal.ctor) {
208− inner.style.left = inner.style.right = 'none';
226+ inner.style.left = inner.style.right = 'none';
209− removeTransform(inner.style);
227+ removeTransform(inner.style);
210− }
228+ }
211− if (nextE._0.vertical.ctor !== currE._0.vertical.ctor) {
229+ if (nextE._0.vertical.ctor !== currE._0.vertical.ctor) {
212− inner.style.top = inner.style.bottom = 'none';
230+ inner.style.top = inner.style.bottom = 'none';
213− removeTransform(inner.style);
231+ removeTransform(inner.style);
214− }
232+ }
215− }
233+ }
216− 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);
217− break;
235+ break;
218 case "Custom":
236 case "Custom":
219− if (currE.type === nextE.type) {
237+ if (currE.type === nextE.type) {
220− var done = nextE.update(node, currE.model, nextE.model);
238+ var done = nextE.update(node, currE.model, nextE.model);
221− if (done) return;
239+ if (done) return;
222− } else {
240+ } else {
223− return node.parentNode.replaceChild(render(next), node);
241+ return node.parentNode.replaceChild(render(next), node);
224− }
242+ }
225 }
243 }
226 updateProps(node, curr, next);
244 updateProps(node, curr, next);
227}
245}
@@ -231,23 +249,29 @@ function updateProps(node, curr, next) {
231 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';
232 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';
233 if (props.opacity !== 1 && props.opacity !== currP.opacity) {
251 if (props.opacity !== 1 && props.opacity !== currP.opacity) {
234− e.style.opacity = props.opacity;
252+ e.style.opacity = props.opacity;
235 }
253 }
236 var nextColor = (props.color.ctor === 'Just' ?
254 var nextColor = (props.color.ctor === 'Just' ?
237− extract(props.color._0) : 'transparent');
255+ extract(props.color._0) : 'transparent');
238 if (e.style.backgroundColor !== nextColor) {
256 if (e.style.backgroundColor !== nextColor) {
239 e.style.backgroundColor = nextColor;
257 e.style.backgroundColor = nextColor;
240 }
258 }
241 if (props.tag !== currP.tag) { e.id = props.tag; }
259 if (props.tag !== currP.tag) { e.id = props.tag; }
242 if (props.href !== currP.href) {
260 if (props.href !== currP.href) {
243− if (currP.href === '') {
261+ if (currP.href === '') {
244− var a = newElement('a');
262+ var a = newElement('a');
245− 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';
246− a.appendChild(e);
271+ e.appendChild(a);
247− e.parentNode.replaceChild(a,e);
248− } else {
272+ } else {
249− node.parentNode.href = props.href;
273+ node.lastNode.href = props.href;
250− }
274+ }
251 }
275 }
252}
276}
253
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