on master help sign in
Merge branch 'master' into debugger
94fb30cEvan Czaplicki
.gitignore+4−4
@@ -10,8 +10,8 @@ cabal-dev
10data
10data
11*/ElmFiles/*
11*/ElmFiles/*
12.DS_Store
12.DS_Store
13+build
14+cache
13*~
15*~
14−tests/elm/build/
15−tests/elm/cache/
16−tests/elm/exe.js
16+exe.js
17−node_modules/
17+node_modules/
.travis.yml+31−3
@@ -1,3 +1,31 @@
1+# Based on https://github.com/hvr/multi-ghc-travis and https://github.com/ekmett/lens/blob/master/.travis.yml
2+
1−language: haskell
3+# NB: don't set `language: haskell` here
2−ghc:
4+
3− - 7.6
5+# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.
6+env:
7+ - GHCVER=7.6.3
8+ - GHCVER=7.8.2
9+
10+# Note: the distinction between `before_install` and `install` is not important.
11+before_install:
12+ - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
13+ - travis_retry sudo apt-get update
14+ - travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy alex # see note about happy/alex
15+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:$PATH
16+ - cabal update
17+ # Update happy when building with GHC 7.8 or head
18+ - |
19+ if [ $GHCVER = "head" ] || [ $GHCVER = "7.8.2" ]; then
20+ cabal install happy alex
21+ export PATH=$HOME/.cabal/bin:$PATH
22+ fi
23+
24+install:
25+ - cabal install --only-dependencies --enable-tests --enable-benchmarks
26+
27+# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
28+script:
29+ - cabal configure --enable-tests
30+ - cabal build
31+ - cabal test
Elm.cabal+31−19
@@ -1,5 +1,5 @@
1Name: Elm
1Name: Elm
2−Version: 0.12
2+Version: 0.12.3
3Synopsis: The Elm language module.
3Synopsis: The Elm language module.
4Description: Elm aims to make client-side web-development more pleasant.
4Description: Elm aims to make client-side web-development more pleasant.
5 It is a statically/strongly typed, functional reactive
5 It is a statically/strongly typed, functional reactive
@@ -27,7 +27,7 @@ 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/elm-lang/Elm.git
31
31
32Library
32Library
33 exposed-modules: Elm.Internal.Dependencies,
33 exposed-modules: Elm.Internal.Dependencies,
@@ -95,6 +95,7 @@ Library
95 Paths_Elm
95 Paths_Elm
96
96
97 Build-depends: aeson,
97 Build-depends: aeson,
98+ aeson-pretty,
98 base >=4.2 && <5,
99 base >=4.2 && <5,
99 binary >= 0.7.0.0,
100 binary >= 0.7.0.0,
100 blaze-html >= 0.5 && < 0.8,
101 blaze-html >= 0.5 && < 0.8,
@@ -106,14 +107,17 @@ Library
106 filepath,
107 filepath,
107 indents,
108 indents,
108 language-ecmascript >=0.15 && < 1.0,
109 language-ecmascript >=0.15 && < 1.0,
110+ language-glsl >= 0.0.2,
109 mtl >= 2,
111 mtl >= 2,
110 pandoc >= 1.10,
112 pandoc >= 1.10,
111 parsec >= 3.1.1,
113 parsec >= 3.1.1,
112 pretty,
114 pretty,
115+ scientific,
113 text,
116 text,
114 transformers >= 0.2,
117 transformers >= 0.2,
115 union-find,
118 union-find,
116− unordered-containers
119+ unordered-containers,
120+ yaml
117
121
118Executable elm
122Executable elm
119 Main-is: Compiler.hs
123 Main-is: Compiler.hs
@@ -177,6 +181,7 @@ Executable elm
177 Paths_Elm
181 Paths_Elm
178
182
179 Build-depends: aeson,
183 Build-depends: aeson,
184+ aeson-pretty,
180 base >=4.2 && <5,
185 base >=4.2 && <5,
181 binary >= 0.7.0.0,
186 binary >= 0.7.0.0,
182 blaze-html >= 0.5 && < 0.8,
187 blaze-html >= 0.5 && < 0.8,
@@ -188,14 +193,17 @@ Executable elm
188 filepath,
193 filepath,
189 indents,
194 indents,
190 language-ecmascript >=0.15 && < 1.0,
195 language-ecmascript >=0.15 && < 1.0,
196+ language-glsl >= 0.0.2,
191 mtl >= 2,
197 mtl >= 2,
192 pandoc >= 1.10,
198 pandoc >= 1.10,
193 parsec >= 3.1.1,
199 parsec >= 3.1.1,
200+ scientific,
194 pretty,
201 pretty,
195 text,
202 text,
196 transformers >= 0.2,
203 transformers >= 0.2,
197 union-find,
204 union-find,
198− unordered-containers
205+ unordered-containers,
206+ yaml
199
207
200Executable elm-doc
208Executable elm-doc
201 Main-is: Docs.hs
209 Main-is: Docs.hs
@@ -229,16 +237,19 @@ Executable elm-doc
229 directory,
237 directory,
230 filepath,
238 filepath,
231 indents,
239 indents,
240+ language-glsl >= 0.0.2,
232 mtl >= 2,
241 mtl >= 2,
233 pandoc >= 1.10,
242 pandoc >= 1.10,
234 parsec >= 3.1.1,
243 parsec >= 3.1.1,
235 pretty,
244 pretty,
245+ scientific,
236 text,
246 text,
237− union-find
247+ union-find,
248+ yaml
238
249
239Test-Suite compiler-tests
250Test-Suite compiler-tests
240 Type: exitcode-stdio-1.0
251 Type: exitcode-stdio-1.0
241− Hs-Source-Dirs: tests/hs, compiler
252+ Hs-Source-Dirs: tests/compiler, compiler
242 Main-is: CompilerTest.hs
253 Main-is: CompilerTest.hs
243 other-modules: Tests.Compiler
254 other-modules: Tests.Compiler
244 Tests.Property
255 Tests.Property
@@ -246,43 +257,44 @@ Test-Suite compiler-tests
246 SourceSyntax.Helpers
257 SourceSyntax.Helpers
247 SourceSyntax.Literal
258 SourceSyntax.Literal
248 SourceSyntax.PrettyPrint
259 SourceSyntax.PrettyPrint
249− build-depends: base,
250− directory,
251− Elm,
252− test-framework,
260+ build-depends: test-framework,
253 test-framework-hunit,
261 test-framework-hunit,
254 test-framework-quickcheck2 >= 0.3,
262 test-framework-quickcheck2 >= 0.3,
255 HUnit,
263 HUnit,
256− pretty,
257 QuickCheck >= 2 && < 3,
264 QuickCheck >= 2 && < 3,
258− filemanip,
259 aeson,
265 aeson,
266+ aeson-pretty,
260 base >=4.2 && <5,
267 base >=4.2 && <5,
261 binary >= 0.7.0.0,
268 binary >= 0.7.0.0,
262− blaze-html == 0.5.* || == 0.6.*,
269+ blaze-html,
263− blaze-markup == 0.5.1.*,
270+ blaze-markup,
264 bytestring,
271 bytestring,
265 cmdargs,
272 cmdargs,
266 containers >= 0.3,
273 containers >= 0.3,
267 directory,
274 directory,
275+ Elm,
276+ filemanip,
268 filepath,
277 filepath,
269 indents,
278 indents,
270 language-ecmascript >=0.15 && < 1.0,
279 language-ecmascript >=0.15 && < 1.0,
280+ language-glsl >= 0.0.2,
271 mtl >= 2,
281 mtl >= 2,
272 pandoc >= 1.10,
282 pandoc >= 1.10,
273 parsec >= 3.1.1,
283 parsec >= 3.1.1,
274 pretty,
284 pretty,
285+ scientific,
275 text,
286 text,
276 transformers >= 0.2,
287 transformers >= 0.2,
277 union-find,
288 union-find,
278− unordered-containers
289+ unordered-containers,
290+ yaml
279
291
280−Test-Suite lib-tests
292+Test-Suite library-tests
281 Type: exitcode-stdio-1.0
293 Type: exitcode-stdio-1.0
282− Hs-Source-Dirs: tests/hs
294+ Hs-Source-Dirs: tests/libraries
283− Main-is: LibTest.hs
295+ Main-is: LibraryTest.hs
284 build-depends: base,
296 build-depends: base,
285 directory,
297 directory,
286 Elm,
298 Elm,
287 filepath,
299 filepath,
288− process >= 1.2
300+ process
changelog.md+8−6
@@ -1,5 +1,12 @@
1
1
2−## 0.13
2+## 0.12.1
3+
4+## Improvements:
5+
6+ * New Array library (thanks entirely to @Xashili)
7+ * Json.Value can flow through ports
8+ * Improve speed and stack usage in List library (thanks to @maxsnew)
9+ * Add Dict.filter and Dict.partition (thanks to @hdgarrood)
3
10
4#### Breaking Changes:
11#### Breaking Changes:
5
12
@@ -7,11 +14,6 @@
7 * Revamp JavaScript.Experimental library to have slightly better names
14 * Revamp JavaScript.Experimental library to have slightly better names
8 * Remove JavaScript library which was made redundant by ports
15 * Remove JavaScript library which was made redundant by ports
9
16
10−## Improvements:
11−
12− * Json.Value can flow through ports, so you can bring in values even
13− if they don't conform to a consistent type.
14−
15## 0.12
17## 0.12
16
18
17#### Breaking Changes:
19#### Breaking Changes:
compiler/Build/Dependencies.hs+67−42
@@ -1,55 +1,57 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2−module Build.Dependencies (getSortedDependencies, readDeps) where
2+module Build.Dependencies (Recipe(..), getBuildRecipe, readDeps) where
3
3
4−import Control.Applicative
5import Control.Monad.Error
4import Control.Monad.Error
6import qualified Control.Monad.State as State
5import qualified Control.Monad.State as State
7−import qualified Data.Aeson as Json
8−import qualified Data.ByteString.Lazy.Char8 as BSC
9import qualified Data.Graph as Graph
6import qualified Data.Graph as Graph
10import qualified Data.List as List
7import qualified Data.List as List
11import qualified Data.Map as Map
8import qualified Data.Map as Map
12−import qualified Data.Maybe as Maybe
13import qualified Data.Set as Set
9import qualified Data.Set as Set
14import System.Directory
10import System.Directory
15import System.FilePath as FP
11import System.FilePath as FP
16
12
17−import Build.Print (failure)
18−
19import qualified SourceSyntax.Module as Module
13import qualified SourceSyntax.Module as Module
20import qualified Parse.Parse as Parse
14import qualified Parse.Parse as Parse
21import qualified Elm.Internal.Paths as Path
15import qualified Elm.Internal.Paths as Path
22import qualified Elm.Internal.Name as N
16import qualified Elm.Internal.Name as N
17+import qualified Elm.Internal.Version as V
23import qualified Elm.Internal.Dependencies as Deps
18import qualified Elm.Internal.Dependencies as Deps
24
19
20+data Recipe = Recipe
21+ { _elmFiles :: [FilePath]
22+ , _jsFiles :: [FilePath]
23+ }
24+
25−getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [String]
25+getBuildRecipe :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO Recipe
26−getSortedDependencies srcDirs builtIns root =
26+getBuildRecipe srcDirs builtIns root =
27− do extras <- extraDependencies
27+ do directories <- getDependencies
28+ jsFiles <- nativeFiles ("." : directories)
28− let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras
29+ let allSrcDirs = srcDirs ++ directories
29− result <- runErrorT $ readAllDeps allSrcDirs builtIns root
30+ nodes <- collectDependencies allSrcDirs builtIns root
30− case result of
31+ elmFiles <- sortElmFiles nodes
31− Right deps -> sortDeps deps
32+ return (Recipe elmFiles jsFiles)
32− Left err -> failure err
33+
33−
34+-- | Based on the projects elm_dependencies.json, find all of the paths and
34−extraDependencies :: IO (Maybe [FilePath])
35+-- dependency information we might need.
35−extraDependencies =
36+getDependencies :: ErrorT String IO [FilePath]
37+getDependencies =
36− do exists <- doesFileExist Path.dependencyFile
38+ do exists <- liftIO $ doesFileExist Path.dependencyFile
37− if not exists then return Nothing else Just <$> getPaths
39+ if not exists then return [] else getPaths
38 where
40 where
39− getPaths = do
41+ getPaths :: ErrorT String IO [FilePath]
40− raw <- BSC.readFile Path.dependencyFile
42+ getPaths =
41− case Json.eitherDecode raw of
43+ Deps.withDeps Path.dependencyFile $ \deps ->
42− Right (Deps.Mini deps) -> mapM validate deps
44+ mapM getPath (Deps.dependencies deps)
43− Left err ->
45+
44− failure $ "Error reading the " ++ Path.dependencyFile ++ " file:\n" ++ err
46+ getPath :: (N.Name, V.Version) -> ErrorT String IO FilePath
45−
46− validate (name,version) = do
47+ getPath (name,version) = do
47− let path = Path.dependencyDirectory </> toPath name version
48+ let path = Path.dependencyDirectory </> N.toFilePath name </> show version
48− exists <- doesDirectoryExist path
49+ exists <- liftIO $ doesDirectoryExist path
50+ if exists
51+ then return path
49− if exists then return path else failure (notFound name version)
52+ else throwError (notFound name version)
50−
53+
51− toPath name version = N.toFilePath name </> show version
54+ notFound :: N.Name -> V.Version -> String
52−
53 notFound name version =
55 notFound name version =
54 unlines
56 unlines
55 [ "Your " ++ Path.dependencyFile ++ " file says you depend on library"
57 [ "Your " ++ Path.dependencyFile ++ " file says you depend on library"
@@ -58,27 +60,50 @@ extraDependencies =
58 , ""
60 , ""
59 , " elm-get install " ++ show name ++ " " ++ show version ]
61 , " elm-get install " ++ show name ++ " " ++ show version ]
60
62
63+nativeFiles :: [FilePath] -> ErrorT String IO [FilePath]
64+nativeFiles directories =
65+ do exists <- liftIO $ doesFileExist Path.dependencyFile
66+ if not exists
67+ then return []
68+ else concat `fmap` mapM getNativeFiles directories
69+ where
70+ getNativeFiles dir =
71+ Deps.withDeps (dir </> Path.dependencyFile) $ \deps ->
72+ return (map (toPath dir) (Deps.native deps))
73+
74+ toPath dir moduleName =
75+ dir </> joinPath (split moduleName) <.> "js"
76+
77+split :: String -> [String]
78+split moduleName = go [] moduleName
79+ where
80+ go paths str =
81+ case break (=='.') str of
82+ (path, _:rest) -> go (paths ++ [path]) rest
83+ (path, []) -> paths ++ [path]
84+
61−type Deps = (FilePath, String, [String])
85+type DependencyNode = (FilePath, String, [String])
62
86
63−sortDeps :: [Deps] -> IO [String]
87+sortElmFiles :: [DependencyNode] -> ErrorT String IO [FilePath]
64−sortDeps depends =
88+sortElmFiles depends =
65 if null mistakes
89 if null mistakes
66 then return (concat sccs)
90 then return (concat sccs)
67− else failure $ msg ++ unlines (map show mistakes)
91+ else throwError $ msg ++ unlines (map show mistakes)
68 where
92 where
69 sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends
93 sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends
70
94
71 mistakes = filter (\scc -> length scc > 1) sccs
95 mistakes = filter (\scc -> length scc > 1) sccs
72 msg = "A cyclical module dependency or was detected in:\n"
96 msg = "A cyclical module dependency or was detected in:\n"
73
97
74−readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
98+collectDependencies :: [FilePath] -> Module.Interfaces -> FilePath
99+ -> ErrorT String IO [DependencyNode]
75−readAllDeps srcDirs rawBuiltIns filePath =
100+collectDependencies srcDirs rawBuiltIns filePath =
76 State.evalStateT (go Nothing filePath) Set.empty
101 State.evalStateT (go Nothing filePath) Set.empty
77 where
102 where
78 builtIns :: Set.Set String
103 builtIns :: Set.Set String
79 builtIns = Set.fromList $ Map.keys rawBuiltIns
104 builtIns = Set.fromList $ Map.keys rawBuiltIns
80
105
81− go :: Maybe String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
106+ go :: Maybe String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [DependencyNode]
82 go parentModuleName filePath = do
107 go parentModuleName filePath = do
83 filePath' <- lift $ findSrcFile parentModuleName srcDirs filePath
108 filePath' <- lift $ findSrcFile parentModuleName srcDirs filePath
84 (moduleName, deps) <- lift $ readDeps filePath'
109 (moduleName, deps) <- lift $ readDeps filePath'
@@ -93,9 +118,9 @@ readDeps :: FilePath -> ErrorT String IO (String, [String])
93readDeps path = do
118readDeps path = do
94 txt <- lift $ readFile path
119 txt <- lift $ readFile path
95 case Parse.dependencies txt of
120 case Parse.dependencies txt of
121+ Right o -> return o
96 Left err -> throwError $ msg ++ show err
122 Left err -> throwError $ msg ++ show err
97 where msg = "Error resolving dependencies in " ++ path ++ ":\n"
123 where msg = "Error resolving dependencies in " ++ path ++ ":\n"
98− Right o -> return o
99
124
100findSrcFile :: Maybe String -> [FilePath] -> FilePath -> ErrorT String IO FilePath
125findSrcFile :: Maybe String -> [FilePath] -> FilePath -> ErrorT String IO FilePath
101findSrcFile parentModuleName dirs path =
126findSrcFile parentModuleName dirs path =
compiler/Build/Flags.hs+7−4
@@ -7,7 +7,8 @@ import System.Console.CmdArgs
7data Flags = Flags
7data Flags = Flags
8 { make :: Bool
8 { make :: Bool
9 , files :: [FilePath]
9 , files :: [FilePath]
10− , runtime :: Maybe FilePath
10+ , set_runtime :: Maybe FilePath
11+ , get_runtime :: Bool
11 , only_js :: Bool
12 , only_js :: Bool
12 , print_types :: Bool
13 , print_types :: Bool
13 , scripts :: [FilePath]
14 , scripts :: [FilePath]
@@ -28,8 +29,10 @@ flags = Flags
28 &= help "Do not import Prelude by default, used only when compiling standard libraries."
29 &= help "Do not import Prelude by default, used only when compiling standard libraries."
29 , scripts = [] &= typFile
30 , scripts = [] &= typFile
30 &= help "Load JavaScript files in generated HTML. Files will be included in the given order."
31 &= help "Load JavaScript files in generated HTML. Files will be included in the given order."
31− , runtime = Nothing &= typFile
32+ , set_runtime = Nothing &= typFile
32− &= help "Specify a custom location for Elm's runtime system."
33+ &= help "Specify a custom location for Elm's runtime system."
34+ , get_runtime = False
35+ &= help "Print the absolute path to the default Elm runtime."
33 , cache_dir = "cache" &= typFile
36 , cache_dir = "cache" &= typFile
34 &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."
37 &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."
35 , build_dir = "build" &= typFile
38 , build_dir = "build" &= typFile
@@ -37,7 +40,7 @@ flags = Flags
37 , src_dir = ["."] &= typFile
40 , src_dir = ["."] &= typFile
38 &= help "Additional source directories besides project root. Searched when using --make"
41 &= help "Additional source directories besides project root. Searched when using --make"
39 , print_types = False
42 , print_types = False
40− &= help "Print out infered types of top-level definitions."
43+ &= help "Print out inferred types of top-level definitions."
41 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."
44 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."
42 &= helpArg [explicit, name "help", name "h"]
45 &= helpArg [explicit, name "help", name "h"]
43 &= versionArg [explicit, name "version", name "v", summary (show Version.elmVersion)]
46 &= versionArg [explicit, name "version", name "v", summary (show Version.elmVersion)]
compiler/Build/Print.hs+9−1
@@ -5,6 +5,7 @@ import System.Exit (exitFailure)
5
5
6import qualified Data.Map as Map
6import qualified Data.Map as Map
7import qualified Data.List as List
7import qualified Data.List as List
8+import qualified SourceSyntax.Type as T
8import qualified SourceSyntax.Module as M
9import qualified SourceSyntax.Module as M
9import qualified SourceSyntax.PrettyPrint as Pretty
10import qualified SourceSyntax.PrettyPrint as Pretty
10import qualified Type.Alias as Alias
11import qualified Type.Alias as Alias
@@ -18,6 +19,11 @@ interfaceTypes :: Map.Map String M.ModuleInterface -> M.ModuleInterface -> IO ()
18interfaceTypes interfaces iface =
19interfaceTypes interfaces iface =
19 types interfaces (M.iTypes iface) (M.iAliases iface) (M.iImports iface)
20 types interfaces (M.iTypes iface) (M.iAliases iface) (M.iImports iface)
20
21
22+types :: Map.Map k M.ModuleInterface
23+ -> Map.Map String T.Type
24+ -> [M.Alias]
25+ -> [(String, M.ImportMethod)]
26+ -> IO ()
21types interfaces types' aliases imports =
27types interfaces types' aliases imports =
22 do putStrLn ""
28 do putStrLn ""
23 mapM_ printType (Map.toList types')
29 mapM_ printType (Map.toList types')
@@ -35,4 +41,6 @@ errors errs =
35 mapM_ print (List.intersperse (P.text " ") errs)
41 mapM_ print (List.intersperse (P.text " ") errs)
36
42
37failure :: String -> IO a
43failure :: String -> IO a
44+failure msg =
38−failure msg = hPutStrLn stderr msg >> exitFailure
45+ do hPutStrLn stderr msg
46+ exitFailure
compiler/Build/Utils.hs+9
@@ -1,10 +1,12 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module Build.Utils where
2module Build.Utils where
3
3
4+import Control.Monad.Error
4import System.Directory (doesFileExist)
5import System.Directory (doesFileExist)
5import System.Environment (getEnv)
6import System.Environment (getEnv)
6import System.FilePath ((</>), replaceExtension)
7import System.FilePath ((</>), replaceExtension)
7import qualified Build.Flags as Flag
8import qualified Build.Flags as Flag
9+import qualified Build.Print as Print
8import qualified Paths_Elm as This
10import qualified Paths_Elm as This
9
11
10buildPath :: Flag.Flags -> FilePath -> String -> FilePath
12buildPath :: Flag.Flags -> FilePath -> String -> FilePath
@@ -33,3 +35,10 @@ getDataFile name = do
33 else do
35 else do
34 env <- getEnv "ELM_HOME"
36 env <- getEnv "ELM_HOME"
35 return (env </> name)
37 return (env </> name)
38+
39+run :: ErrorT String IO a -> IO a
40+run command = do
41+ either <- runErrorT command
42+ case either of
43+ Left err -> Print.failure err
44+ Right result -> return result
compiler/Compiler.hs+16−10
@@ -1,16 +1,17 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module Main where
2module Main where
3
3
4−import Control.Monad (foldM)
4+import Control.Monad (foldM, when)
5import qualified Data.Maybe as Maybe
5import qualified Data.Maybe as Maybe
6import Text.Blaze.Html.Renderer.String (renderHtml)
6import Text.Blaze.Html.Renderer.String (renderHtml)
7import qualified Data.ByteString.Lazy.Char8 as BS
7import qualified Data.ByteString.Lazy.Char8 as BS
8import qualified System.Console.CmdArgs as CmdArgs
8import qualified System.Console.CmdArgs as CmdArgs
9import System.Directory
9import System.Directory
10+import System.Exit (exitSuccess)
10import System.FilePath
11import System.FilePath
11import GHC.Conc
12import GHC.Conc
12
13
13−import Build.Dependencies (getSortedDependencies)
14+import Build.Dependencies (getBuildRecipe, Recipe(..))
14import qualified Generate.Html as Html
15import qualified Generate.Html as Html
15import qualified Metadata.Prelude as Prelude
16import qualified Metadata.Prelude as Prelude
16import qualified Build.Utils as Utils
17import qualified Build.Utils as Utils
@@ -24,7 +25,10 @@ main = do setNumCapabilities =<< getNumProcessors
24
25
25compileArgs :: Flag.Flags -> IO ()
26compileArgs :: Flag.Flags -> IO ()
26compileArgs flags =
27compileArgs flags =
28+ do when (Flag.get_runtime flags) $
29+ do putStrLn Path.runtime
30+ exitSuccess
27− case Flag.files flags of
31+ case Flag.files flags of
28 [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
32 [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
29 fs -> mapM_ (build flags) fs
33 fs -> mapM_ (build flags) fs
30
34
@@ -33,13 +37,15 @@ build flags rootFile =
33 do let noPrelude = Flag.no_prelude flags
37 do let noPrelude = Flag.no_prelude flags
34 builtIns <- Prelude.interfaces noPrelude
38 builtIns <- Prelude.interfaces noPrelude
35
39
40+ (Recipe elmFiles jsFiles) <-
36− files <- if Flag.make flags
41+ if Flag.make flags
37− then getSortedDependencies (Flag.src_dir flags) builtIns rootFile
42+ then Utils.run (getBuildRecipe (Flag.src_dir flags) builtIns rootFile)
38− else return [rootFile]
43+ else return (Recipe [rootFile] [])
39
44
40− moduleName <- File.build flags builtIns files
45+ moduleName <- File.build flags builtIns elmFiles
41
46
47+ let elmos = map (Utils.elmo flags) elmFiles
42− js <- foldM appendToOutput BS.empty files
48+ js <- foldM appendToOutput BS.empty (elmos ++ jsFiles)
43
49
44 (extension, code) <-
50 (extension, code) <-
45 if Flag.only_js flags
51 if Flag.only_js flags
@@ -56,12 +62,12 @@ build flags rootFile =
56 where
62 where
57 appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString
63 appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString
58 appendToOutput js filePath = do
64 appendToOutput js filePath = do
59− src <- BS.readFile (Utils.elmo flags filePath)
65+ src <- BS.readFile filePath
60 return (BS.append src js)
66 return (BS.append src js)
61
67
62 sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ]
68 sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ]
63
69
64 makeHtml js moduleName = ("html", BS.pack $ renderHtml html)
70 makeHtml js moduleName = ("html", BS.pack $ renderHtml html)
65 where
71 where
66− rtsPath = Maybe.fromMaybe Path.runtime (Flag.runtime flags)
72+ rtsPath = Maybe.fromMaybe Path.runtime (Flag.set_runtime flags)
67 html = Html.generate rtsPath (takeBaseName rootFile) (sources js) moduleName ""
73 html = Html.generate rtsPath (takeBaseName rootFile) (sources js) moduleName ""
compiler/Elm/Internal/Dependencies.hs+54−15
@@ -2,12 +2,18 @@
2module Elm.Internal.Dependencies where
2module Elm.Internal.Dependencies where
3
3
4import Control.Applicative
4import Control.Applicative
5+import Control.Arrow (first)
5import Control.Monad.Error
6import Control.Monad.Error
6import qualified Control.Exception as E
7import qualified Control.Exception as E
7import Data.Aeson
8import Data.Aeson
9+import Data.Aeson.Types (Parser)
10+import Data.Aeson.Encode.Pretty
11+import Data.Maybe (fromMaybe)
8import qualified Data.List as List
12import qualified Data.List as List
9import qualified Data.ByteString.Lazy as BS
13import qualified Data.ByteString.Lazy as BS
10import qualified Data.HashMap.Strict as Map
14import qualified Data.HashMap.Strict as Map
15+import qualified Data.Text as T
16+
11import qualified Elm.Internal.Name as N
17import qualified Elm.Internal.Name as N
12import qualified Elm.Internal.Version as V
18import qualified Elm.Internal.Version as V
13import qualified Elm.Internal.Paths as Path
19import qualified Elm.Internal.Paths as Path
@@ -20,15 +26,28 @@ data Deps = Deps
20 , license :: String
26 , license :: String
21 , repo :: String
27 , repo :: String
22 , exposed :: [String]
28 , exposed :: [String]
29+ , native :: [String]
23 , elmVersion :: V.Version
30 , elmVersion :: V.Version
24 , dependencies :: [(N.Name,V.Version)]
31 , dependencies :: [(N.Name,V.Version)]
25− } deriving Show
32+ } deriving (Show, Eq, Ord)
26−
33+
27−data MiniDeps = Mini [(N.Name,V.Version)]
28−
29−instance FromJSON MiniDeps where
34+instance ToJSON Deps where
30− parseJSON (Object obj) = Mini <$> getDependencies obj
35+ toJSON d =
31− parseJSON _ = mzero
36+ object $
37+ [ "version" .= version d
38+ , "summary" .= summary d
39+ , "description" .= description d
40+ , "license" .= license d
41+ , "repository" .= repo d
42+ , "exposed-modules" .= exposed d
43+ , "elm-version" .= elmVersion d
44+ , "dependencies" .= (jsonDeps . dependencies $ d)
45+ ] ++ nativeModules
46+ where
47+ jsonDeps = Map.fromList . map (first (T.pack . show))
48+ nativeModules
49+ | null (native d) = []
50+ | otherwise = [ "native-modules" .= native d ]
32
51
33instance FromJSON Deps where
52instance FromJSON Deps where
34 parseJSON (Object obj) =
53 parseJSON (Object obj) =
@@ -48,15 +67,18 @@ instance FromJSON Deps where
48 Right nm -> return nm
67 Right nm -> return nm
49
68
50 exposed <- get obj "exposed-modules" "a list of modules exposed to users"
69 exposed <- get obj "exposed-modules" "a list of modules exposed to users"
70+
71+ native <- fromMaybe [] <$> (obj .:? "native-modules")
51
72
52 elmVersion <- get obj "elm-version" "the version of the Elm compiler you are using"
73 elmVersion <- get obj "elm-version" "the version of the Elm compiler you are using"
53
74
54 deps <- getDependencies obj
75 deps <- getDependencies obj
55
76
56− return $ Deps name version summary desc license repo exposed elmVersion deps
77+ return $ Deps name version summary desc license repo exposed native elmVersion deps
57
78
58 parseJSON _ = mzero
79 parseJSON _ = mzero
59
80
81+getDependencies :: Object -> Parser [(N.Name, V.Version)]
60getDependencies obj =
82getDependencies obj =
61 toDeps =<< get obj "dependencies" "a listing of your project's dependencies"
83 toDeps =<< get obj "dependencies" "a listing of your project's dependencies"
62 where
84 where
@@ -67,7 +89,7 @@ getDependencies obj =
67 (Nothing, _) -> fail $ N.errorMsg f
89 (Nothing, _) -> fail $ N.errorMsg f
68 (_, Nothing) -> fail $ "invalid version number " ++ v
90 (_, Nothing) -> fail $ "invalid version number " ++ v
69
91
70−
92+get :: FromJSON a => Object -> T.Text -> String -> Parser a
71get obj field desc =
93get obj field desc =
72 do maybe <- obj .:? field
94 do maybe <- obj .:? field
73 case maybe of
95 case maybe of
@@ -96,12 +118,12 @@ repoToName repo
96 \like <https://github.com/USER/PROJECT.git> where USER is your GitHub name\n\
118 \like <https://github.com/USER/PROJECT.git> where USER is your GitHub name\n\
97 \and PROJECT is the repo you want to upload."
119 \and PROJECT is the repo you want to upload."
98
120
99−withDeps :: (Deps -> a) -> FilePath -> ErrorT String IO a
121+withDeps :: FilePath -> (Deps -> ErrorT String IO a) -> ErrorT String IO a
100−withDeps handle path =
122+withDeps path handle =
101 do json <- readPath
123 do json <- readPath
102 case eitherDecode json of
124 case eitherDecode json of
103 Left err -> throwError $ "Error reading file " ++ path ++ ":\n " ++ err
125 Left err -> throwError $ "Error reading file " ++ path ++ ":\n " ++ err
104− Right ds -> return (handle ds)
126+ Right ds -> handle ds
105 where
127 where
106 readPath :: ErrorT String IO BS.ByteString
128 readPath :: ErrorT String IO BS.ByteString
107 readPath = do
129 readPath = do
@@ -110,8 +132,25 @@ withDeps handle path =
110 case result of
132 case result of
111 Right bytes -> return bytes
133 Right bytes -> return bytes
112 Left _ -> throwError $
134 Left _ -> throwError $
113− "could not find file " ++ path ++
135+ "could not find " ++ path ++ " file. You may need to create one.\n" ++
114− "\n You may need to create a dependency file for your project."
136+ " For an example of how to fill in the dependencies file, check out\n" ++
137+ " <https://github.com/evancz/automaton/blob/master/elm_dependencies.json>"
115
138
116depsAt :: FilePath -> ErrorT String IO Deps
139depsAt :: FilePath -> ErrorT String IO Deps
117−depsAt = withDeps id
140+depsAt filePath = withDeps filePath return
141+
142+-- | Encode dependencies in a canonical JSON format
143+prettyJSON :: Deps -> BS.ByteString
144+prettyJSON = encodePretty' config
145+ where config = defConfig { confCompare = order }
146+ order = keyOrder [ "name"
147+ , "version"
148+ , "summary"
149+ , "description"
150+ , "license"
151+ , "repo"
152+ , "exposed-modules"
153+ , "native-modules"
154+ , "elm-version"
155+ , "dependencies"
156+ ]
compiler/Elm/Internal/Name.hs+2−2
@@ -10,7 +10,7 @@ import qualified Data.Maybe as Maybe
10import Data.Typeable
10import Data.Typeable
11
11
12data Name = Name { user :: String, project :: String }
12data Name = Name { user :: String, project :: String }
13− deriving (Typeable,Eq)
13+ deriving (Typeable,Eq, Ord)
14
14
15instance Binary Name where
15instance Binary Name where
16 get = Name <$> get <*> get
16 get = Name <$> get <*> get
@@ -48,4 +48,4 @@ errorMsg string =
48 unlines
48 unlines
49 [ "Dependency file has an invalid name: " ++ string
49 [ "Dependency file has an invalid name: " ++ string
50 , "Must have format user/project and match a public github project."
50 , "Must have format user/project and match a public github project."
51− ]
51+ ]
compiler/Elm/Internal/Utils.hs+10−3
@@ -1,11 +1,12 @@
1{- | This module exports functions for compiling Elm to JS.
1{- | This module exports functions for compiling Elm to JS.
2-}
2-}
3−module Elm.Internal.Utils (compile, moduleName) where
3+module Elm.Internal.Utils (compile, moduleName, nameAndImports) where
4
4
5import qualified Data.List as List
5import qualified Data.List as List
6import qualified Generate.JavaScript as JS
6import qualified Generate.JavaScript as JS
7import qualified Build.Source as Source
7import qualified Build.Source as Source
8−import qualified Parse.Module as Parser
8+import Parse.Module (getModuleName)
9+import Parse.Parse (dependencies)
9import qualified SourceSyntax.Module as M
10import qualified SourceSyntax.Module as M
10import qualified Text.PrettyPrint as P
11import qualified Text.PrettyPrint as P
11import qualified Metadata.Prelude as Prelude
12import qualified Metadata.Prelude as Prelude
@@ -25,4 +26,10 @@ interfaces = unsafePerformIO $ Prelude.interfaces False
25
26
26-- |This function extracts the module name of a given source program.
27-- |This function extracts the module name of a given source program.
27moduleName :: String -> Maybe String
28moduleName :: String -> Maybe String
28−moduleName = Parser.getModuleName
29+moduleName = getModuleName
30+
31+-- |This function extracts the module name and imported modules from a given
32+-- source program.
33+nameAndImports :: String -> Maybe (String, [String])
34+nameAndImports src =
35+ either (const Nothing) Just (dependencies src)
compiler/Generate/JavaScript.hs+5−1
@@ -34,10 +34,11 @@ include alias moduleName =
34
34
35internalImports :: String -> Statement ()
35internalImports :: String -> Statement ()
36internalImports name =
36internalImports name =
37− VarDeclStmt ()
37+ VarDeclStmt ()
38 [ varDecl "_N" (obj "Elm.Native")
38 [ varDecl "_N" (obj "Elm.Native")
39 , include "_U" "_N.Utils"
39 , include "_U" "_N.Utils"
40 , include "_L" "_N.List"
40 , include "_L" "_N.List"
41+ , include "_A" "_N.Array"
41 , include "_E" "_N.Error"
42 , include "_E" "_N.Error"
42 , varDecl "$moduleName" (string name)
43 , varDecl "$moduleName" (string name)
43 ]
44 ]
@@ -179,6 +180,9 @@ expression (A region expr) =
179 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
180 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
180 md = pad ++ MD.toHtml doc ++ pad
181 md = pad ++ MD.toHtml doc ++ pad
181
182
183+ GLShader _uid src _tipe ->
184+ return $ ObjectLit () [(PropString () "src", literal (Str src))]
185+
182 PortIn name tipe ->
186 PortIn name tipe ->
183 return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
187 return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
184
188
compiler/Generate/JavaScript/Ports.hs+16−9
@@ -20,7 +20,7 @@ check x jsType continue =
20 JSNumber -> [typeof "number"]
20 JSNumber -> [typeof "number"]
21 JSBoolean -> [typeof "boolean"]
21 JSBoolean -> [typeof "boolean"]
22 JSString -> [typeof "string", instanceof "String"]
22 JSString -> [typeof "string", instanceof "String"]
23− JSArray -> [instanceof "Array"]
23+ JSArray -> [(obj "_U.isJSArray" <|)]
24 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]
24 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]
25
25
26incoming :: Type -> Expression ()
26incoming :: Type -> Expression ()
@@ -38,7 +38,7 @@ inc tipe x =
38
38
39 Data "Json.Value" [] ->
39 Data "Json.Value" [] ->
40 obj "Native.Json.fromJS" <| x
40 obj "Native.Json.fromJS" <| x
41−
41+
42 Data ctor []
42 Data ctor []
43 | ctor == "Int" -> from JSNumber
43 | ctor == "Int" -> from JSNumber
44 | ctor == "Float" -> from JSNumber
44 | ctor == "Float" -> from JSNumber
@@ -55,8 +55,12 @@ inc tipe x =
55
55
56 | ctor == "_List" ->
56 | ctor == "_List" ->
57 check x JSArray (obj "_L.fromArray" <| array)
57 check x JSArray (obj "_L.fromArray" <| array)
58+
59+ | ctor == "Array.Array" ->
60+ check x JSArray (obj "_A.fromJSArray" <| array)
61+
58− where
62+ where
59− array = DotRef () x (var "map") <| incoming t
63+ array = DotRef () x (var "map") <| incoming t
60
64
61 Data ctor ts
65 Data ctor ts
62 | Help.isTuple ctor -> check x JSArray tuple
66 | Help.isTuple ctor -> check x JSArray tuple
@@ -67,10 +71,10 @@ inc tipe x =
67 , inc t (BracketRef () x (IntLit () n)))
71 , inc t (BracketRef () x (IntLit () n)))
68
72
69 Data _ _ ->
73 Data _ _ ->
70− error "bad ADT got to port generation code"
74+ error "bad ADT got to incoming port generation code"
71
75
72 Record _ (Just _) ->
76 Record _ (Just _) ->
73− error "bad record got to port generation code"
77+ error "bad record got to incoming port generation code"
74
78
75 Record fields Nothing ->
79 Record fields Nothing ->
76 check x (JSObject (map fst fields)) object
80 check x (JSObject (map fst fields)) object
@@ -117,16 +121,19 @@ out tipe x =
117 | ctor == "_List" ->
121 | ctor == "_List" ->
118 DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t
122 DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t
119
123
124+ | ctor == "Array.Array" ->
125+ DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t
126+
120 Data ctor ts
127 Data ctor ts
121 | Help.isTuple ctor ->
128 | Help.isTuple ctor ->
122 let convert n t = out t $ DotRef () x $ var ('_':show n)
129 let convert n t = out t $ DotRef () x $ var ('_':show n)
123 in ArrayLit () $ zipWith convert [0..] ts
130 in ArrayLit () $ zipWith convert [0..] ts
124−
131+
125 Data _ _ ->
132 Data _ _ ->
126− error "bad ADT got to port generation code"
133+ error "bad ADT got to outgoing port generation code"
127
134
128 Record _ (Just _) ->
135 Record _ (Just _) ->
129− error "bad record got to port generation code"
136+ error "bad record got to outgoing port generation code"
130
137
131 Record fields Nothing ->
138 Record fields Nothing ->
132 ObjectLit () keys
139 ObjectLit () keys
compiler/Parse/Expression.hs+11−4
@@ -6,7 +6,7 @@ import Text.Parsec hiding (newline,spaces)
6import Text.Parsec.Indent
6import Text.Parsec.Indent
7
7
8import Parse.Binop
8import Parse.Binop
9−import Parse.Helpers
9+import Parse.Helpers as Help
10import Parse.Literal
10import Parse.Literal
11import qualified Parse.Pattern as Pattern
11import qualified Parse.Pattern as Pattern
12import qualified Parse.Type as Type
12import qualified Parse.Type as Type
@@ -44,7 +44,7 @@ negative = do
44-------- Complex Terms --------
44-------- Complex Terms --------
45
45
46listTerm :: IParser ParseExpr'
46listTerm :: IParser ParseExpr'
47−listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
47+listTerm = markdown' <|> shader' <|> braces (try range <|> ExplicitList <$> commaSep expr)
48 where
48 where
49 range = do
49 range = do
50 lo <- expr
50 lo <- expr
@@ -54,11 +54,18 @@ listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
54 markdown' = do
54 markdown' = do
55 pos <- getPosition
55 pos <- getPosition
56 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
56 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
57− (rawText, exprs) <- markdown (interpolation uid)
57+ (rawText, exprs) <- Help.markdown (interpolation uid)
58 return (Markdown uid (filter (/='\r') rawText) exprs)
58 return (Markdown uid (filter (/='\r') rawText) exprs)
59
59
60+ shader' = do
61+ pos <- getPosition
62+ let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
63+ (rawSrc, tipe) <- Help.shader
64+ return $ GLShader uid (filter (/='\r') rawSrc) tipe
65+
60 span uid index =
66 span uid index =
67+ "<span id=\"md-" ++ uid ++ "-" ++ show index ++
61− "<span id=\"md-" ++ uid ++ "-" ++ show index ++ "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"
68+ "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"
62
69
63 interpolation uid exprs = do
70 interpolation uid exprs = do
64 try (string "{{")
71 try (string "{{")
compiler/Parse/Helpers.hs+54−5
@@ -8,6 +8,8 @@ import Control.Monad.State
8import Data.Char (isUpper)
8import Data.Char (isUpper)
9import qualified Data.Set as Set
9import qualified Data.Set as Set
10import qualified Data.Map as Map
10import qualified Data.Map as Map
11+import qualified Language.GLSL.Parser as GLP
12+import Language.GLSL.Syntax as GLS
11import Text.Parsec hiding (newline,spaces,State)
13import Text.Parsec hiding (newline,spaces,State)
12import Text.Parsec.Indent
14import Text.Parsec.Indent
13import qualified Text.Parsec.Token as T
15import qualified Text.Parsec.Token as T
@@ -16,6 +18,7 @@ import SourceSyntax.Annotation as Annotation
16import SourceSyntax.Declaration (Assoc)
18import SourceSyntax.Declaration (Assoc)
17import SourceSyntax.Expression
19import SourceSyntax.Expression
18import SourceSyntax.Helpers as Help
20import SourceSyntax.Helpers as Help
21+import SourceSyntax.Literal as Literal
19import SourceSyntax.PrettyPrint
22import SourceSyntax.PrettyPrint
20import SourceSyntax.Variable as Variable
23import SourceSyntax.Variable as Variable
21
24
@@ -308,16 +311,62 @@ anyUntilPos pos = go
308 False -> (:) <$> anyChar <*> go
311 False -> (:) <$> anyChar <*> go
309
312
310markdown :: ([a] -> IParser (String, [a])) -> IParser (String, [a])
313markdown :: ([a] -> IParser (String, [a])) -> IParser (String, [a])
311−markdown interpolation = try (string "[markdown|") >> closeMarkdown (++ "") []
314+markdown interpolation =
315+ do try (string "[markdown|")
316+ closeMarkdown id []
312 where
317 where
313− closeMarkdown md stuff =
318+ closeMarkdown markdownBuilder stuff =
314 choice [ do try (string "|]")
319 choice [ do try (string "|]")
315− return (md "", stuff)
320+ return (markdownBuilder "", stuff)
321+ , do (markdown,stuff') <- interpolation stuff
316− , (\(m,s) -> closeMarkdown (md . (m ++)) s) =<< interpolation stuff
322+ closeMarkdown (markdownBuilder . (markdown++)) stuff'
317 , do c <- anyChar
323 , do c <- anyChar
318− closeMarkdown (md . ([c]++)) stuff
324+ closeMarkdown (markdownBuilder . (c:)) stuff
319 ]
325 ]
320
326
327+shader :: IParser (String, Literal.GLShaderTipe)
328+shader =
329+ do try (string "[glsl|")
330+ rawSrc <- closeShader id
331+ case glSource rawSrc of
332+ Left err -> parserFail . show $ err
333+ Right tipe -> return (rawSrc, tipe)
334+ where
335+ closeShader builder = choice
336+ [ do try (string "|]")
337+ return (builder "")
338+ , do c <- anyChar
339+ closeShader (builder . (c:))
340+ ]
341+
342+glSource :: String -> Either ParseError Literal.GLShaderTipe
343+glSource src =
344+ case GLP.parse src of
345+ Right (TranslationUnit decls) ->
346+ Right . foldr addGLinput emptyDecls . join . map extractGLinputs $ decls
347+ Left e -> Left e
348+ where
349+ emptyDecls = Literal.GLShaderTipe Map.empty Map.empty Map.empty
350+ addGLinput (qual,tipe,name) glDecls = case qual of
351+ Attribute -> glDecls { attribute = Map.insert name tipe $ attribute glDecls }
352+ Uniform -> glDecls { uniform = Map.insert name tipe $ uniform glDecls }
353+ Varying -> glDecls { varying = Map.insert name tipe $ varying glDecls }
354+ _ -> error "Should never happen due to below filter"
355+ extractGLinputs decl = case decl of
356+ Declaration (InitDeclaration (TypeDeclarator (FullType (Just (TypeQualSto qual)) (TypeSpec _prec (TypeSpecNoPrecision tipe _mexpr1)))) [InitDecl name _mexpr2 _mexpr3]) ->
357+ if elem qual [Attribute, Varying, Uniform]
358+ then case tipe of
359+ GLS.Int -> return (qual,Literal.Int,name)
360+ GLS.Float -> return (qual,Literal.Float,name)
361+ GLS.Vec2 -> return (qual,V2,name)
362+ GLS.Vec3 -> return (qual,V3,name)
363+ GLS.Vec4 -> return (qual,V4,name)
364+ GLS.Mat4 -> return (qual,M4,name)
365+ GLS.Sampler2D -> return (qual,Texture,name)
366+ _ -> []
367+ else []
368+ _ -> []
369+
321--str :: IParser String
370--str :: IParser String
322str = expecting "String" $ do
371str = expecting "String" $ do
323 s <- choice [ multiStr, singleStr ]
372 s <- choice [ multiStr, singleStr ]
compiler/SourceSyntax/Expression.hs+3
@@ -58,6 +58,7 @@ data GeneralExpr' ann def var
58 -- for type checking and code gen only
58 -- for type checking and code gen only
59 | PortIn String SrcType.Type
59 | PortIn String SrcType.Type
60 | PortOut String SrcType.Type (GeneralExpr ann def var)
60 | PortOut String SrcType.Type (GeneralExpr ann def var)
61+ | GLShader String String Literal.GLShaderTipe
61 deriving (Show)
62 deriving (Show)
62
63
63
64
@@ -178,6 +179,8 @@ instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where
178
179
179 Markdown _ _ _ -> P.text "[markdown| ... |]"
180 Markdown _ _ _ -> P.text "[markdown| ... |]"
180
181
182+ GLShader _ _ _ -> P.text "[glShader| ... |]"
183+
181 PortIn name _ -> P.text $ "<port:" ++ name ++ ">"
184 PortIn name _ -> P.text $ "<port:" ++ name ++ ">"
182
185
183 PortOut _ _ signal -> pretty signal
186 PortOut _ _ signal -> pretty signal
compiler/SourceSyntax/Literal.hs+22
@@ -1,6 +1,7 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module SourceSyntax.Literal where
2module SourceSyntax.Literal where
3
3
4+import Data.Map (Map)
4import SourceSyntax.PrettyPrint
5import SourceSyntax.PrettyPrint
5import qualified Text.PrettyPrint as PP
6import qualified Text.PrettyPrint as PP
6
7
@@ -19,3 +20,24 @@ instance Pretty Literal where
19 Chr c -> PP.text . show $ c
20 Chr c -> PP.text . show $ c
20 Str s -> PP.text . show $ s
21 Str s -> PP.text . show $ s
21 Boolean bool -> PP.text (show bool)
22 Boolean bool -> PP.text (show bool)
23+
24+data GLTipe = Int | Float | V2 | V3 | V4 | M4 | Texture
25+ deriving (Show)
26+
27+glTipeName :: GLTipe -> String
28+glTipeName glTipe =
29+ case glTipe of
30+ Int -> "Int"
31+ Float -> "Float"
32+ V2 -> "Math.Vector2.Vec2"
33+ V3 -> "Math.Vector3.Vec3"
34+ V4 -> "Math.Vector4.Vec4"
35+ M4 -> "Math.Matrix4.Mat4"
36+ Texture -> "Graphics.WebGL.Texture"
37+
38+data GLShaderTipe = GLShaderTipe
39+ { attribute :: Map String GLTipe
40+ , uniform :: Map String GLTipe
41+ , varying :: Map String GLTipe
42+ } deriving (Show)
43+
compiler/Transform/Canonicalize.hs+1
@@ -178,6 +178,7 @@ rename env (A ann expr) =
178
178
179 PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
179 PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
180
180
181+ GLShader _ _ _ -> return expr
181
182
182renamePattern :: Env -> P.Pattern -> Either String P.Pattern
183renamePattern :: Env -> P.Pattern -> Either String P.Pattern
183renamePattern env pattern =
184renamePattern env pattern =
compiler/Transform/Expression.hs+1
@@ -49,6 +49,7 @@ crawl portInCheck portOutCheck defsTransform = go
49 Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields
49 Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields
50 Markdown uid md es -> Markdown uid md <$> mapM go es
50 Markdown uid md es -> Markdown uid md <$> mapM go es
51 Let defs body -> Let <$> defsTransform defs <*> go body
51 Let defs body -> Let <$> defsTransform defs <*> go body
52+ GLShader uid src gltipe -> return $ GLShader uid src gltipe
52 PortIn name st ->
53 PortIn name st ->
53 do portInCheck name st
54 do portInCheck name st
54 return $ PortIn name st
55 return $ PortIn name st
compiler/Transform/SafeNames.hs+1
@@ -54,6 +54,7 @@ expression (A ann expr) =
54 Modify r fs -> Modify (f r) (map (var *** f) fs)
54 Modify r fs -> Modify (f r) (map (var *** f) fs)
55 Record fs -> Record (map (var *** f) fs)
55 Record fs -> Record (map (var *** f) fs)
56 Markdown uid md es -> Markdown uid md (map f es)
56 Markdown uid md es -> Markdown uid md (map f es)
57+ GLShader _ _ _ -> expr
57 PortIn name st -> PortIn name st
58 PortIn name st -> PortIn name st
58 PortOut name st signal -> PortOut name st (f signal)
59 PortOut name st signal -> PortOut name st (f signal)
59
60
compiler/Transform/SortDefinitions.hs+2
@@ -84,6 +84,8 @@ reorder (A ann expr) =
84
84
85 Markdown uid md es -> Markdown uid md <$> mapM reorder es
85 Markdown uid md es -> Markdown uid md <$> mapM reorder es
86
86
87+ GLShader _ _ _ -> return expr
88+
87 PortOut name st signal -> PortOut name st <$> reorder signal
89 PortOut name st signal -> PortOut name st <$> reorder signal
88
90
89 PortIn name st -> return $ PortIn name st
91 PortIn name st -> return $ PortIn name st
compiler/Transform/Substitute.hs+1
@@ -40,5 +40,6 @@ subst old new expr =
40 Record fs -> Record (map (second f) fs)
40 Record fs -> Record (map (second f) fs)
41 Literal _ -> expr
41 Literal _ -> expr
42 Markdown uid md es -> Markdown uid md (map f es)
42 Markdown uid md es -> Markdown uid md (map f es)
43+ GLShader _ _ _ -> expr
43 PortIn name st -> PortIn name st
44 PortIn name st -> PortIn name st
44 PortOut name st signal -> PortOut name st (f signal)
45 PortOut name st signal -> PortOut name st (f signal)
compiler/Type/Constrain/Expression.hs+17
@@ -8,6 +8,7 @@ import qualified Data.List as List
8import qualified Data.Map as Map
8import qualified Data.Map as Map
9import qualified Text.PrettyPrint as PP
9import qualified Text.PrettyPrint as PP
10
10
11+import SourceSyntax.Literal as Lit
11import SourceSyntax.Annotation as Ann
12import SourceSyntax.Annotation as Ann
12import SourceSyntax.Expression
13import SourceSyntax.Expression
13import qualified SourceSyntax.Pattern as P
14import qualified SourceSyntax.Pattern as P
@@ -31,6 +32,22 @@ constrain env (A region expr) tipe =
31 case expr of
32 case expr of
32 Literal lit -> liftIO $ Literal.constrain env region lit tipe
33 Literal lit -> liftIO $ Literal.constrain env region lit tipe
33
34
35+ GLShader _uid _src gltipe ->
36+ exists $ \attr ->
37+ exists $ \unif ->
38+ let
39+ shaderTipe a u v = Env.get env Env.types "Graphics.WebGL.Shader" <| a <| u <| v
40+ glTipe = Env.get env Env.types . Lit.glTipeName
41+ makeRec accessor baseRec =
42+ let decls = accessor gltipe
43+ in if Map.size decls == 0
44+ then baseRec
45+ else record (Map.map (\t -> [glTipe t]) decls) baseRec
46+ attribute = makeRec Lit.attribute attr
47+ uniform = makeRec Lit.uniform unif
48+ varying = makeRec Lit.varying (TermN EmptyRecord1)
49+ in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)
50+
34 Var (V.Raw name)
51 Var (V.Raw name)
35 | name == saveEnvName -> return (A region CSaveEnv)
52 | name == saveEnvName -> return (A region CSaveEnv)
36 | otherwise -> return (name <? tipe)
53 | otherwise -> return (name <? tipe)
compiler/Type/ExtraChecks.hs+2−3
@@ -60,8 +60,7 @@ portTypes rules expr =
60 | otherwise -> err' True "an unsupported type"
60 | otherwise -> err' True "an unsupported type"
61 where
61 where
62 primitives =
62 primitives =
63− ["Int","Float","String","Bool","Maybe.Maybe","_List","Json.Value"]
63+ ["Int","Float","String","Bool","Maybe.Maybe","_List","Array.Array","Json.Value"]
64−
65 validConstructor =
64 validConstructor =
66 ctor `elem` primitives || Help.isTuple ctor
65 ctor `elem` primitives || Help.isTuple ctor
67
66
@@ -102,7 +101,7 @@ portTypes rules expr =
102 , txt [ "It contains ", kind, ":\n" ]
101 , txt [ "It contains ", kind, ":\n" ]
103 , (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"
102 , (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"
104 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
103 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
105− , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Tuples," ]
104+ , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples," ]
106 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
105 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
107 ] ++ if couldBeAlias then aliasWarning else []
106 ] ++ if couldBeAlias then aliasWarning else []
108
107
compiler/Type/Unify.hs+5−1
@@ -86,6 +86,10 @@ actuallyUnify region variable1 variable2 = do
86 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
86 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
87 where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
87 where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
88
88
89+ appendableError maybe =
90+ TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
91+ where msg = "An appendable must be of type String, List, or Text."
92+
89 unifyComparable var name
93 unifyComparable var name
90 | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var
94 | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var
91 | otherwise = comparableError Nothing
95 | otherwise = comparableError Nothing
@@ -108,7 +112,7 @@ actuallyUnify region variable1 variable2 = do
108 do struct <- liftIO $ collectApps varFlex
112 do struct <- liftIO $ collectApps varFlex
109 case struct of
113 case struct of
110 List _ -> flexAndUnify varSuper
114 List _ -> flexAndUnify varSuper
111− _ -> comparableError Nothing
115+ _ -> appendableError Nothing
112
116
113 rigidError variable = TS.addError region (Just hint) variable1 variable2
117 rigidError variable = TS.addError region (Just hint) variable1 variable2
114 where
118 where
libraries/Array.elmnew file+198
@@ -0,0 +1,198 @@
1+module Array where
2+
3+{-| A library for fast immutable arrays. The elements in an array must have the
4+same type. The arrays are implemented in Relaxed Radix Balanced-Trees for fast
5+reads, updates, and appends.
6+
7+# Creating Arrays
8+@docs empty, repeat, initialize, fromList
9+
10+# Basics
11+@docs length, push, append
12+
13+# Get and Set
14+@docs get, getOrElse, getOrFail, set
15+
16+# Taking Arrays Apart
17+@docs slice, toList, toIndexedList
18+
19+# Mapping and Folding
20+@docs map, indexedMap, foldl, foldr
21+-}
22+
23+import Native.Array
24+import Basics (..)
25+import Maybe (..)
26+import List
27+
28+data Array a = Array
29+
30+{-| Initialize an array. `initialize n f` creates an array of length `n` with
31+the element at index `i` initialized to the result of `(f i)`.
32+
33+ initialize 4 id == fromList [0,1,2,3]
34+ initialize 4 (\n -> n*n) == fromList [0,1,4,9]
35+ initialize 4 (always 0) == fromList [0,0,0,0]
36+-}
37+initialize : Int -> (Int -> a) -> Array a
38+initialize = Native.Array.initialize
39+
40+{-| Creates an array with a given length, filled with a default element.
41+
42+ repeat 5 0 == fromList [0,0,0,0,0]
43+ repeat 3 "cat" == fromList ["cat","cat","cat"]
44+
45+Notice that `repeat 3 x` is the same as `initialize 3 (always x)`.
46+-}
47+repeat : Int -> a -> Array a
48+repeat n e = initialize n (always e)
49+
50+{-| Create an array from a list. -}
51+fromList : [a] -> Array a
52+fromList = Native.Array.fromList
53+
54+{-| Create a list of elements from an array.
55+
56+ toList (fromList [3,5,8]) == [3,5,8]
57+-}
58+toList : Array a -> [a]
59+toList = Native.Array.toList
60+
61+-- TODO: make this a native function.
62+{-| Create an indexed list from an array. Each element of the array will be
63+paired with its index.
64+
65+ toIndexedList (fromList ["cat","dog"]) == [(0,"cat"), (1,"dog")]
66+-}
67+toIndexedList : Array a -> [(Int, a)]
68+toIndexedList array =
69+ List.zip [ 0 .. Native.Array.length array - 1 ] (Native.Array.toList array)
70+
71+{-| Apply a function on every element in an array.
72+
73+ map sqrt (fromList [1,4,9]) == fromList [1,2,3]
74+-}
75+map : (a -> b) -> Array a -> Array b
76+map = Native.Array.map
77+
78+{-| Apply a function on every element with its index as first argument.
79+
80+ indexedMap (*) (fromList [5,5,5]) == fromList [0,5,10]
81+-}
82+indexedMap : (Int -> a -> b) -> Array a -> Array b
83+indexedMap = Native.Array.indexedMap
84+
85+{-| Reduce an array from the left. Read `foldl` as &ldquo;fold from the left&rdquo;.
86+
87+ foldl (::) [] (fromList [1,2,3]) == [3,2,1]
88+-}
89+foldl : (a -> b -> b) -> b -> Array a -> b
90+foldl = Native.Array.foldl
91+
92+{-| Reduce an array from the right. Read `foldr` as &ldquo;fold from the right&rdquo;.
93+
94+ foldr (+) 0 (repeat 3 5) == 15
95+-}
96+foldr : (a -> b -> b) -> b -> Array a -> b
97+foldr = Native.Array.foldr
98+
99+{-| Keep only elements that satisfy the predicate:
100+
101+ filter isEven (fromList [1..6]) == (fromList [2,4,6])
102+-}
103+filter : (a -> Bool) -> Array a -> Array a
104+filter isOkay arr =
105+ let update x xs = if isOkay x then Native.Array.push x xs else xs
106+ in
107+ Native.Array.foldl update Native.Array.empty arr
108+
109+{-| Return an empty array.
110+
111+ length empty == 0
112+-}
113+empty : Array a
114+empty = Native.Array.empty
115+
116+{-| Push an element to the end of an array.
117+
118+ push 3 (fromList [1,2]) == fromList [1,2,3]
119+-}
120+push : a -> Array a -> Array a
121+push = Native.Array.push
122+
123+{-| Get the element at a particular index.
124+
125+ getOrFail 0 (A.fromList [0,1,2]) == 0
126+
127+Warning: this function will result in a runtime error if the index is not found,
128+so it is best to use `get` or `getOrElse` unless you are sure the index will be
129+found.
130+-}
131+getOrFail : Int -> Array a -> a
132+getOrFail = Native.Array.get
133+
134+{-| Return Just the element at the index or Nothing if the index is out of range.
135+
136+ get 0 (fromList [0,1,2]) == Just 0
137+ get 2 (fromList [0,1,2]) == Just 2
138+ get 5 (fromList [0,1,2]) == Nothing
139+ get -1 (fromList [0,1,2]) == Nothing
140+-}
141+get : Int -> Array a -> Maybe a
142+get i array =
143+ if 0 <= i && i < Native.Array.length array
144+ then Just (Native.Array.get i array)
145+ else Nothing
146+
147+{-| Get the element at the index. Or if the index is out of range, a default
148+value is returned.
149+
150+ getOrElse 0 2 (fromList [0,1,2]) == 2
151+ getOrElse 0 5 (fromList [0,1,2]) == 0
152+-}
153+getOrElse : a -> Int -> Array a -> a
154+getOrElse default i array =
155+ if 0 <= i && i < Native.Array.length array
156+ then Native.Array.get i array
157+ else default
158+
159+{-| Set the element at a particular index. Returns an updated array.
160+If the index is out of range, the array is unaltered.
161+
162+ set 1 7 (fromList [1,2,3]) == fromList [1,7,3]
163+-}
164+set : Int -> a -> Array a -> Array a
165+set = Native.Array.set
166+
167+{-| Get a sub-section of an array: `(slice start end array)`. The `start` is a
168+zero-based index where we will start our slice. The `end` is a zero-based index
169+that indicates the end of the slice. The slice extracts up to but not including
170+`end`.
171+
172+ slice 0 3 (fromList [0,1,2,3,4]) == fromList [0,1,2]
173+ slice 1 4 (fromList [0,1,2,3,4]) == fromList [1,2,3]
174+
175+Both the `start` and `end` indexes can be negative, indicating an offset from
176+the end of the array.
177+
178+ slice 1 -1 (fromList [0,1,2,3,4]) == fromList [1,2,3]
179+ slice -2 5 (fromList [0,1,2,3,4]) == fromList [3,4]
180+
181+This makes it pretty easy to `pop` the last element off of an array: `slice 0 -1 array`
182+-}
183+slice : Int -> Int -> Array a -> Array a
184+slice = Native.Array.slice
185+
186+{-| Return the length of an array.
187+
188+ length (fromList [1,2,3]) == 3
189+-}
190+length : Array a -> Int
191+length = Native.Array.length
192+
193+{-| Append two arrays to a new one.
194+
195+ append (array 2 42) (array 3 81) == fromList [42,42,81,81,81]
196+-}
197+append : Array a -> Array a -> Array a
198+append = Native.Array.append
libraries/Color.elm+186−88
@@ -2,18 +2,18 @@ module Color where
2
2
3{-| Library for working with colors. Includes
3{-| Library for working with colors. Includes
4[RGB](https://en.wikipedia.org/wiki/RGB_color_model) and
4[RGB](https://en.wikipedia.org/wiki/RGB_color_model) and
5−[HSV](http://en.wikipedia.org/wiki/HSL_and_HSV) creation, gradients, and
5+[HSL](http://en.wikipedia.org/wiki/HSL_and_HSV) creation, gradients, and
6built-in names.
6built-in names.
7
7
8# Creation
8# Creation
9−@docs rgb, rgba, hsv, hsva, greyscale, grayscale
9+@docs rgb, rgba, hsl, hsla, greyscale, grayscale, complement
10−
11−# From Other Colors
12−@docs complement
13
10
14# Gradients
11# Gradients
15@docs linear, radial
12@docs linear, radial
16
13
14+# Extracting Colors
15+@docs toRgb, toHsl
16+
17# Built-in Colors
17# Built-in Colors
18These colors come from the [Tango
18These colors come from the [Tango
19palette](http://tango.freedesktop.org/Tango_Icon_Theme_Guidelines)
19palette](http://tango.freedesktop.org/Tango_Icon_Theme_Guidelines)
@@ -24,12 +24,10 @@ comes with a light and dark version.
24@docs red, orange, yellow, green, blue, purple, brown
24@docs red, orange, yellow, green, blue, purple, brown
25
25
26### Light
26### Light
27−@docs lightRed, lightOrange, lightYellow, lightGreen, lightBlue, lightPurple,
27+@docs lightRed, lightOrange, lightYellow, lightGreen, lightBlue, lightPurple, lightBrown
28− lightBrown
29
28
30### Dark
29### Dark
31−@docs darkRed, darkOrange, darkYellow, darkGreen, darkBlue, darkPurple,
30+@docs darkRed, darkOrange, darkYellow, darkGreen, darkBlue, darkPurple, darkBrown
32− darkBrown
33
31
34### Eight Shades of Grey
32### Eight Shades of Grey
35These colors are a compatible series of shades of grey, fitting nicely
33These colors are a compatible series of shades of grey, fitting nicely
@@ -42,133 +40,233 @@ that has never helped me remember which one I should be writing.
42
40
43-}
41-}
44
42
45−import Native.Color
46−import Basics ((-))
43+import Basics (..)
47
44
45+data Color
48−data Color = Color Int Int Int Float
46+ = RGBA Int Int Int Float
47+ | HSLA Float Float Float Float
49
48
50{-| Create RGB colors with an alpha component for transparency.
49{-| Create RGB colors with an alpha component for transparency.
51The alpha component is specified with numbers between 0 and 1. -}
50The alpha component is specified with numbers between 0 and 1. -}
52rgba : Int -> Int -> Int -> Float -> Color
51rgba : Int -> Int -> Int -> Float -> Color
53−rgba = Color
52+rgba = RGBA
54
53
55{-| Create RGB colors from numbers between 0 and 255 inclusive. -}
54{-| Create RGB colors from numbers between 0 and 255 inclusive. -}
56rgb : Int -> Int -> Int -> Color
55rgb : Int -> Int -> Int -> Color
57−rgb r g b = Color r g b 1
56+rgb r g b = RGBA r g b 1
57+
58+{-| Create [HSL colors](http://en.wikipedia.org/wiki/HSL_and_HSV)
59+with an alpha component for transparency.
60+-}
61+hsla : Float -> Float -> Float -> Float -> Color
62+hsla hue saturation lightness alpha =
63+ HSLA (hue - toFloat (floor (hue / (2*pi)))) saturation lightness alpha
64+
65+{-| Create [HSL colors](http://en.wikipedia.org/wiki/HSL_and_HSV). This gives
66+you access to colors more like a color wheel, where all hues are aranged in a
67+circle that you specify with standard Elm angles (radians).
68+
69+ red = hsl (degrees 0) 1 0.5
70+ green = hsl (degrees 120) 1 0.5
71+ blue = hsl (degrees 240) 1 0.5
72+
73+ pastelRed = hsl (degrees 0) 0.7 0.7
74+
75+To cycle through all colors, just cycle through degrees. The saturation level
76+is how vibrant the color is, like a dial between grey and bright colors. The
77+lightness level is a dial between white and black.
78+-}
79+hsl : Float -> Float -> Float -> Color
80+hsl hue saturation lightness =
81+ hsla hue saturation lightness 1
82+
83+{-| Produce a gray based on the input. 0 is white, 1 is black. -}
84+grayscale : Float -> Color
85+grayscale p = HSLA 0 0 (1-p) 1
86+
87+greyscale : Float -> Color
88+greyscale p = HSLA 0 0 (1-p) 1
89+
90+{-| Produce a &ldquo;complementary color&rdquo;. The two colors will
91+accent each other. This is the same as rotating the hue by 180&deg;.
92+-}
93+complement : Color -> Color
94+complement color =
95+ case color of
96+ HSLA h s l a -> hsla (h + degrees 180) s l a
97+ RGBA r g b a -> let (h,s,l) = rgbToHsl r g b
98+ in hsla (h + degrees 180) s l a
99+
100+{-| Extract the the components of a color in the HSL format.
101+-}
102+toHsl : Color -> { hue:Float, saturation:Float, lightness:Float, alpha:Float }
103+toHsl color =
104+ case color of
105+ HSLA h s l a -> { hue=h, saturation=s, lightness=l, alpha=a }
106+ RGBA r g b a ->
107+ let (h,s,l) = rgbToHsl r g b
108+ in { hue=h, saturation=s, lightness=l, alpha=a }
109+
110+{-| Extract the the components of a color in the RGB format.
111+-}
112+toRgb : Color -> { red:Int, green:Int, blue:Int, alpha:Float }
113+toRgb color =
114+ case color of
115+ RGBA r g b a -> { red=r, green=g, blue=b, alpha=a }
116+ HSLA h s l a ->
117+ let (r,g,b) = hslToRgb h s l
118+ in { red = round (255 * r)
119+ , green = round (255 * g)
120+ , blue = round (255 * b)
121+ , alpha = a
122+ }
123+
124+fmod : Float -> Int -> Float
125+fmod f n =
126+ let integer = floor f
127+ in toFloat (integer `mod` n) + f - toFloat integer
128+
129+rgbToHsl : Int -> Int -> Int -> (Float,Float,Float)
130+rgbToHsl red green blue =
131+ let r = toFloat red / 255
132+ g = toFloat green / 255
133+ b = toFloat blue / 255
134+
135+ cMax = max (max r g) b
136+ cMin = min (min r g) b
137+
138+ c = cMax - cMin
139+
140+ hue = degrees 60 * if | cMax == r -> ((g - b) / c) `fmod` 6
141+ | cMax == g -> ((b - r) / c) + 2
142+ | cMax == b -> ((r - g) / c) + 4
143+
144+ lightness = (cMax + cMin) / 2
145+
146+ saturation =
147+ if lightness == 0
148+ then 0
149+ else c / (1 - abs (2 * lightness - 1))
150+ in
151+ (hue, saturation, lightness)
152+
153+hslToRgb : Float -> Float -> Float -> (Float,Float,Float)
154+hslToRgb hue saturation lightness =
155+ let chroma = (1 - abs (2 * lightness - 1)) * saturation
156+ hue' = hue / degrees 60
157+
158+ x = chroma * (1 - abs (fmod hue' 2 - 1))
159+
160+ (r,g,b) = if | hue' < 0 -> (0, 0, 0)
161+ | hue' < 1 -> (chroma, x, 0)
162+ | hue' < 2 -> (x, chroma, 0)
163+ | hue' < 3 -> (0, chroma, x)
164+ | hue' < 4 -> (0, x, chroma)
165+ | hue' < 5 -> (x, 0, chroma)
166+ | hue' < 6 -> (chroma, 0, x)
167+ | otherwise -> (0, 0, 0)
168+
169+ m = lightness - chroma / 2
170+ in
171+ (r + m, g + m, b + m)
172+
173+--toV3 : Color -> V3
174+
175+--toV4 : Color -> V4
176+
177+data Gradient
178+ = Linear (Float,Float) (Float,Float) [(Float,Color)]
179+ | Radial (Float,Float) Float (Float,Float) Float [(Float,Color)]
180+
181+{-| Create a linear gradient. Takes a start and end point and then a series of
182+&ldquo;color stops&rdquo; that indicate how to interpolate between the start and
183+end points. See [this example](/edit/examples/Elements/LinearGradient.elm) for a
184+more visual explanation. -}
185+linear : (number, number) -> (number, number) -> [(Float,Color)] -> Gradient
186+linear = Linear
187+
188+{-| Create a radial gradient. First takes a start point and inner radius. Then
189+takes an end point and outer radius. It then takes a series of &ldquo;color
190+stops&rdquo; that indicate how to interpolate between the inner and outer
191+circles. See [this example](/edit/examples/Elements/RadialGradient.elm) for a
192+more visual explanation. -}
193+radial : (number,number) -> number -> (number,number) -> number -> [(Float,Color)] -> Gradient
194+radial = Radial
195+
196+
197+-- BUILT-IN COLORS
58
198
59lightRed : Color
199lightRed : Color
60−lightRed = Color 239 41 41 1
200+lightRed = RGBA 239 41 41 1
61red : Color
201red : Color
62−red = Color 204 0 0 1
202+red = RGBA 204 0 0 1
63darkRed : Color
203darkRed : Color
64−darkRed = Color 164 0 0 1
204+darkRed = RGBA 164 0 0 1
65
205
66lightOrange : Color
206lightOrange : Color
67−lightOrange = Color 252 175 62 1
207+lightOrange = RGBA 252 175 62 1
68orange : Color
208orange : Color
69−orange = Color 245 121 0 1
209+orange = RGBA 245 121 0 1
70darkOrange : Color
210darkOrange : Color
71−darkOrange = Color 206 92 0 1
211+darkOrange = RGBA 206 92 0 1
72
212
73lightYellow : Color
213lightYellow : Color
74−lightYellow = Color 255 233 79 1
214+lightYellow = RGBA 255 233 79 1
75yellow : Color
215yellow : Color
76−yellow = Color 237 212 0 1
216+yellow = RGBA 237 212 0 1
77darkYellow : Color
217darkYellow : Color
78−darkYellow = Color 196 160 0 1
218+darkYellow = RGBA 196 160 0 1
79
219
80lightGreen : Color
220lightGreen : Color
81−lightGreen = Color 138 226 52 1
221+lightGreen = RGBA 138 226 52 1
82green : Color
222green : Color
83−green = Color 115 210 22 1
223+green = RGBA 115 210 22 1
84darkGreen : Color
224darkGreen : Color
85−darkGreen = Color 78 154 6 1
225+darkGreen = RGBA 78 154 6 1
86
226
87lightBlue : Color
227lightBlue : Color
88−lightBlue = Color 114 159 207 1
228+lightBlue = RGBA 114 159 207 1
89blue : Color
229blue : Color
90−blue = Color 52 101 164 1
230+blue = RGBA 52 101 164 1
91darkBlue : Color
231darkBlue : Color
92−darkBlue = Color 32 74 135 1
232+darkBlue = RGBA 32 74 135 1
93
233
94lightPurple : Color
234lightPurple : Color
95−lightPurple = Color 173 127 168 1
235+lightPurple = RGBA 173 127 168 1
96purple : Color
236purple : Color
97−purple = Color 117 80 123 1
237+purple = RGBA 117 80 123 1
98darkPurple : Color
238darkPurple : Color
99−darkPurple = Color 92 53 102 1
239+darkPurple = RGBA 92 53 102 1
100
240
101lightBrown : Color
241lightBrown : Color
102−lightBrown = Color 233 185 110 1
242+lightBrown = RGBA 233 185 110 1
103brown : Color
243brown : Color
104−brown = Color 193 125 17 1
244+brown = RGBA 193 125 17 1
105darkBrown : Color
245darkBrown : Color
106−darkBrown = Color 143 89 2 1
246+darkBrown = RGBA 143 89 2 1
107
247
108black : Color
248black : Color
109−black = Color 0 0 0 1
249+black = RGBA 0 0 0 1
110white : Color
250white : Color
111−white = Color 255 255 255 1
251+white = RGBA 255 255 255 1
112
252
113lightGrey : Color
253lightGrey : Color
114−lightGrey = Color 238 238 236 1
254+lightGrey = RGBA 238 238 236 1
115grey : Color
255grey : Color
116−grey = Color 211 215 207 1
256+grey = RGBA 211 215 207 1
117darkGrey : Color
257darkGrey : Color
118−darkGrey = Color 186 189 182 1
258+darkGrey = RGBA 186 189 182 1
119
259
120lightGray : Color
260lightGray : Color
121−lightGray = Color 238 238 236 1
261+lightGray = RGBA 238 238 236 1
122gray : Color
262gray : Color
123−gray = Color 211 215 207 1
263+gray = RGBA 211 215 207 1
124darkGray : Color
264darkGray : Color
125−darkGray = Color 186 189 182 1
265+darkGray = RGBA 186 189 182 1
126
266
127lightCharcoal : Color
267lightCharcoal : Color
128−lightCharcoal = Color 136 138 133 1
268+lightCharcoal = RGBA 136 138 133 1
129charcoal : Color
269charcoal : Color
130−charcoal = Color 85 87 83 1
270+charcoal = RGBA 85 87 83 1
131darkCharcoal : Color
271darkCharcoal : Color
132−darkCharcoal = Color 46 52 54 1
272+darkCharcoal = RGBA 46 52 54 1
133−
134−{-| Produce a gray based on the input. 0 is white, 1 is black. -}
135−grayscale : Float -> Color
136−grayscale p = hsv 0 0 (1-p)
137−
138−greyscale : Float -> Color
139−greyscale p = hsv 0 0 (1-p)
140−
141−{-| Produce a &ldquo;complementary color&rdquo;.
142−The two colors will accent each other. -}
143−complement : Color -> Color
144−complement = Native.Color.complement
145−
146−{-| Create [HSV colors](http://en.wikipedia.org/wiki/HSL_and_HSV)
147−with an alpha component for transparency. -}
148−hsva : Float -> Float -> Float -> Float -> Color
149−hsva = Native.Color.hsva
150−
151−{-| Create [HSV colors](http://en.wikipedia.org/wiki/HSL_and_HSV). This is very
152−convenient for creating colors that cycle and shift. Hue is an angle and should
153−be given in standard Elm angles (radians). -}
154−hsv : Float -> Float -> Float -> Color
155−hsv = Native.Color.hsv
156−
157−data Gradient
158− = Linear (Float,Float) (Float,Float) [(Float,Color)]
159− | Radial (Float,Float) Float (Float,Float) Float [(Float,Color)]
160−
161−{-| Create a linear gradient. Takes a start and end point and then a series of
162−&ldquo;color stops&rdquo; that indicate how to interpolate between the start and
163−end points. See [this example](/edit/examples/Elements/LinearGradient.elm) for a
164−more visual explanation. -}
165−linear : (number, number) -> (number, number) -> [(Float,Color)] -> Gradient
166−linear = Linear
167−
168−{-| Create a radial gradient. First takes a start point and inner radius. Then
169−takes an end point and outer radius. It then takes a series of &ldquo;color
170−stops&rdquo; that indicate how to interpolate between the inner and outer
171−circles. See [this example](/edit/examples/Elements/RadialGradient.elm) for a
172−more visual explanation. -}
173−radial : (number,number) -> number -> (number,number) -> number -> [(Float,Color)] -> Gradient
174−radial = Radial
libraries/Dict.elm+76−18
@@ -1,6 +1,8 @@
1module Dict (empty,singleton,insert,update
1module Dict (empty,singleton,insert,update
2− ,lookup,findWithDefault
2+ ,get,getOrElse,getOrFail
3 ,remove,member
3 ,remove,member
4+ ,filter
5+ ,partition
4 ,foldl,foldr,map
6 ,foldl,foldr,map
5 ,union,intersect,diff
7 ,union,intersect,diff
6 ,keys,values
8 ,keys,values
@@ -17,7 +19,7 @@ Insert, remove, and query operations all take *O(log n)* time.
17@docs empty, singleton, insert, update, remove
19@docs empty, singleton, insert, update, remove
18
20
19# Query
21# Query
20−@docs member, lookup, findWithDefault
22+@docs member, get, getOrElse, getOrFail
21
23
22# Combine
24# Combine
23@docs union, intersect, diff
25@docs union, intersect, diff
@@ -26,7 +28,7 @@ Insert, remove, and query operations all take *O(log n)* time.
26@docs keys, values, toList, fromList
28@docs keys, values, toList, fromList
27
29
28# Transform
30# Transform
29−@docs map, foldl, foldr
31+@docs map, foldl, foldr, filter, partition
30
32
31-}
33-}
32
34
@@ -84,33 +86,74 @@ max t =
84 RBNode _ _ _ _ r -> max r
86 RBNode _ _ _ _ r -> max r
85 RBEmpty _ -> Native.Error.raise "(max Empty) is not defined"
87 RBEmpty _ -> Native.Error.raise "(max Empty) is not defined"
86
88
87−{-| Lookup the value associated with a key. -}
89+{-| Get the value associated with a key. If the key is not found, return
90+`Nothing`. This is useful when you are not sure if a key will be in the
91+dictionary.
92+
93+ animals = fromList [ ("Tom", Cat), ("Jerry", Mouse) ]
94+
95+ get "Tom" animals == Just Cat
96+ get "Mouse" animals == Just Mouse
97+ get "Spike" animals == Nothing
98+
99+The `getOrElse` and `getOrFail` are built-in ways to handle common ways of
100+using the resulting `Maybe`.
101+-}
88−lookup : comparable -> Dict comparable v -> Maybe v
102+get : comparable -> Dict comparable v -> Maybe v
89−lookup k t =
103+get k t =
90 case t of
104 case t of
91 RBEmpty LBlack -> Nothing
105 RBEmpty LBlack -> Nothing
92 RBNode _ k' v l r ->
106 RBNode _ k' v l r ->
93 case Native.Utils.compare k k' of
107 case Native.Utils.compare k k' of
94− LT -> lookup k l
108+ LT -> get k l
95 EQ -> Just v
109 EQ -> Just v
96− GT -> lookup k r
110+ GT -> get k r
111+
112+{-| Get the value associated with a key. If the key is not found,
113+return a default value.
97
114
98−{-| Find the value associated with a key. If the key is not found,
115+ animals = fromList [ ("Tom", Cat), ("Jerry", Mouse) ]
99−return the default value. -}
116+
117+ getOrElse Dog "Tom" animals == Cat
118+ getOrElse Dog "Mouse" animals == Mouse
119+ getOrElse Dog "Spike" animals == Dog
120+-}
100−findWithDefault : v -> comparable -> Dict comparable v -> v
121+getOrElse : v -> comparable -> Dict comparable v -> v
101−findWithDefault base k t =
122+getOrElse base k t =
102 case t of
123 case t of
103 RBEmpty LBlack -> base
124 RBEmpty LBlack -> base
104 RBNode _ k' v l r ->
125 RBNode _ k' v l r ->
105 case Native.Utils.compare k k' of
126 case Native.Utils.compare k k' of
106− LT -> findWithDefault base k l
127+ LT -> getOrElse base k l
107 EQ -> v
128 EQ -> v
108− GT -> findWithDefault base k r
129+ GT -> getOrElse base k r
130+
131+{-| Get the value associated with a key.
132+
133+ animals = fromList [ ("Tom", Cat), ("Jerry", Mouse) ]
134+
135+ getOrFail "Tom" animals == Cat
136+ getOrFail "Mouse" animals == Mouse
137+ getOrFail "Spike" animals == -- Runtime Error!
138+
139+Warning: this function will result in a runtime error if the key is not found,
140+so it is best to use `get` or `getOrElse` unless you are sure the key will be
141+found.
142+-}
143+getOrFail : comparable -> Dict comparable v -> v
144+getOrFail k t =
145+ case t of
146+ RBEmpty LBlack -> Native.Error.raise "key not found when using 'getOrFail'"
147+ RBNode _ k' v l r ->
148+ case Native.Utils.compare k k' of
149+ LT -> getOrFail k l
150+ EQ -> v
151+ GT -> getOrFail k r
109
152
110{-| Determine if a key is in a dictionary. -}
153{-| Determine if a key is in a dictionary. -}
111member : comparable -> Dict comparable v -> Bool
154member : comparable -> Dict comparable v -> Bool
112-- Does t contain k?
155-- Does t contain k?
113−member k t = isJust <| lookup k t
156+member k t = isJust <| get k t
114
157
115ensureBlackRoot : Dict k v -> Dict k v
158ensureBlackRoot : Dict k v -> Dict k v
116ensureBlackRoot t =
159ensureBlackRoot t =
@@ -327,9 +370,7 @@ union t1 t2 = foldl insert t2 t1
327{-| Keep a key-value pair when its key appears in the second dictionary.
370{-| Keep a key-value pair when its key appears in the second dictionary.
328Preference is given to values in the first dictionary. -}
371Preference is given to values in the first dictionary. -}
329intersect : Dict comparable v -> Dict comparable v -> Dict comparable v
372intersect : Dict comparable v -> Dict comparable v -> Dict comparable v
330−intersect t1 t2 =
373+intersect t1 t2 = filter (\k _ -> k `member` t2) t1
331− let combine k v t = if k `member` t2 then insert k v t else t
332− in foldl combine empty t1
333
374
334{-| Keep a key-value pair when its key does not appear in the second dictionary.
375{-| Keep a key-value pair when its key does not appear in the second dictionary.
335Preference is given to the first dictionary. -}
376Preference is given to the first dictionary. -}
@@ -351,3 +392,20 @@ toList t = foldr (\k v acc -> (k,v) :: acc) [] t
351{-| Convert an association list into a dictionary. -}
392{-| Convert an association list into a dictionary. -}
352fromList : [(comparable,v)] -> Dict comparable v
393fromList : [(comparable,v)] -> Dict comparable v
353fromList assocs = List.foldl (\(k,v) d -> insert k v d) empty assocs
394fromList assocs = List.foldl (\(k,v) d -> insert k v d) empty assocs
395+
396+{-| Keep a key-value pair when it satisfies a predicate. -}
397+filter : (comparable -> v -> Bool) -> Dict comparable v -> Dict comparable v
398+filter p dict =
399+ let add k v t = if p k v then insert k v t else t
400+ in foldl add empty dict
401+
402+{-| Partition a dictionary according to a predicate. The first dictionary
403+contains all key-value pairs which satisfy the predicate, and the second
404+contains the rest.
405+-}
406+partition : (comparable -> v -> Bool) -> Dict comparable v -> (Dict comparable v, Dict comparable v)
407+partition p dict =
408+ let add k v (t1, t2) = if p k v
409+ then (insert k v t1, t2)
410+ else (t1, insert k v t2)
411+ in foldl add (empty, empty) dict
libraries/Graphics/Input.elm+1−1
@@ -89,7 +89,7 @@ button = Native.Graphics.Input.button
89
89
90 prettyButton : Element
90 prettyButton : Element
91 prettyButton =
91 prettyButton =
92− customButton click.handle
92+ customButton click.handle ()
93 (image 100 40 "/button_up.jpg")
93 (image 100 40 "/button_up.jpg")
94 (image 100 40 "/button_hover.jpg")
94 (image 100 40 "/button_hover.jpg")
95 (image 100 40 "/button_down.jpg")
95 (image 100 40 "/button_down.jpg")
libraries/List.elm+52−15
@@ -23,6 +23,15 @@ list must have the same type.
23
23
24# Sorting
24# Sorting
25@docs sort, sortBy, sortWith
25@docs sort, sortBy, sortWith
26+
27+# Additional Zips
28+@docs zip3, zip4, zip5, zipWith3, zipWith4, zipWith5
29+
30+If you can think of a legitimate use of `zipN` or `zipWithN` where `N` is 6 or
31+more, please let us know on [the
32+list](https://groups.google.com/forum/#!forum/elm-discuss). The current
33+sentiment is that it is already quite error prone once you get to 4 and
34+possibly should be approached another way.
26-}
35-}
27
36
28import Basics (..)
37import Basics (..)
@@ -163,13 +172,19 @@ maximum = foldl1 max
163minimum : [comparable] -> comparable
172minimum : [comparable] -> comparable
164minimum = foldl1 min
173minimum = foldl1 min
165
174
166−{-| Split a list based on the predicate. -}
175+{-| Partition a list based on a predicate. The first list contains all values
176+that satisfy the predicate, and the second list contains all the value that do
177+not.
178+
179+ partition (\x -> x < 3) [0..5] == ([0,1,2], [3,4,5])
180+ partition isEven [0..5] == ([0,2,4], [1,3,5])
181+-}
167partition : (a -> Bool) -> [a] -> ([a],[a])
182partition : (a -> Bool) -> [a] -> ([a],[a])
168−partition pred lst =
183+partition pred =
169− case lst of
184+ let step x (ts, fs) = if pred x
170− [] -> ([],[])
185+ then (x::ts, fs)
171− x::xs -> let (bs,cs) = partition pred xs in
186+ else (ts, x::fs)
172− if pred x then (x::bs,cs) else (bs,x::cs)
187+ in foldr step ([],[])
173
188
174{-| Combine two lists, combining them into tuples pairwise.
189{-| Combine two lists, combining them into tuples pairwise.
175If one list is longer, the extra elements are dropped.
190If one list is longer, the extra elements are dropped.
@@ -180,6 +195,15 @@ If one list is longer, the extra elements are dropped.
180zip : [a] -> [b] -> [(a,b)]
195zip : [a] -> [b] -> [(a,b)]
181zip = Native.List.zip
196zip = Native.List.zip
182
197
198+zip3 : [a] -> [b] -> [c] -> [(a,b,c)]
199+zip3 = Native.List.zipWith3 (,,)
200+
201+zip4 : [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
202+zip4 = Native.List.zipWith4 (,,,)
203+
204+zip5 : [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
205+zip5 = Native.List.zipWith5 (,,,,)
206+
183{-| Combine two lists, combining them with the given function.
207{-| Combine two lists, combining them with the given function.
184If one list is longer, the extra elements are dropped.
208If one list is longer, the extra elements are dropped.
185
209
@@ -188,12 +212,23 @@ If one list is longer, the extra elements are dropped.
188zipWith : (a -> b -> c) -> [a] -> [b] -> [c]
212zipWith : (a -> b -> c) -> [a] -> [b] -> [c]
189zipWith = Native.List.zipWith
213zipWith = Native.List.zipWith
190
214
215+zipWith3 : (a -> b -> c -> x) -> [a] -> [b] -> [c] -> [x]
216+zipWith3 = Native.List.zipWith3
217+
218+zipWith4 : (a -> b -> c -> d -> x) -> [a] -> [b] -> [c] -> [d] -> [x]
219+zipWith4 = Native.List.zipWith4
220+
221+zipWith5 : (a -> b -> c -> d -> e -> x) -> [a] -> [b] -> [c] -> [d] -> [e] -> [x]
222+zipWith5 = Native.List.zipWith5
223+
191−{-| Decompose a list of tuples. -}
224+{-| Decompose a list of tuples.
225+
226+ unzip [(0, True), (17, False), (1337, True)] == ([0,17,1337], [True,False,True])
227+-}
192unzip : [(a,b)] -> ([a],[b])
228unzip : [(a,b)] -> ([a],[b])
193−unzip pairs =
229+unzip =
194− case pairs of
230+ let step (x,y) (xs, ys) = (x::xs, y::ys)
195− [] -> ([],[])
231+ in foldr step ([], [])
196− (x,y)::ps -> let (xs,ys) = (unzip ps) in (x::xs,y::ys)
197
232
198{-| Places the given value between all of the lists in the second
233{-| Places the given value between all of the lists in the second
199argument and concatenates the result.
234argument and concatenates the result.
@@ -209,10 +244,12 @@ join = Native.List.join
209-}
244-}
210intersperse : a -> [a] -> [a]
245intersperse : a -> [a] -> [a]
211intersperse sep xs =
246intersperse sep xs =
212− case xs of
247+ case xs of
213− a::b::cs -> a :: sep :: intersperse sep (b::cs)
248+ [] -> []
214− [a] -> [a]
249+ hd::tl ->
215− [] -> []
250+ let step x rest = sep :: x :: rest
251+ spersed = foldr step [] tl
252+ in hd :: spersed
216
253
217{-| Take the first n members of a list: `(take 2 [1,2,3,4] == [1,2])` -}
254{-| Take the first n members of a list: `(take 2 [1,2,3,4] == [1,2])` -}
218take : Int -> [a] -> [a]
255take : Int -> [a] -> [a]
libraries/Native/Array.jsnew file+643
@@ -0,0 +1,643 @@
1+Elm.Native.Array = {};
2+Elm.Native.Array.make = function(elm) {
3+ elm.Native = elm.Native || {};
4+ elm.Native.Array = elm.Native.Array || {};
5+ if (elm.Native.Array.values) return elm.Native.Array.values;
6+ if ('values' in Elm.Native.Array)
7+ return elm.Native.Array.values = Elm.Native.Array.values;
8+
9+ var List = Elm.Native.List.make(elm);
10+
11+ // A RRB-Tree has two distinct data types.
12+ // Leaf -> "height" is always 0
13+ // "table" is an array of elements
14+ // Node -> "height" is always greater than 0
15+ // "table" is an array of child nodes
16+ // "lengths" is an array of accumulated lengths of the child nodes
17+
18+ // M is the maximal table size. 32 seems fast. E is the allowed increase
19+ // of search steps when concatting to find an index. Lower values will
20+ // decrease balancing, but will increase search steps.
21+ var M = 32;
22+ var E = 2;
23+
24+ // An empty array.
25+ var empty = { ctor:"_Array", height:0, table:new Array() };
26+
27+ function get(i, array) {
28+ if (i < 0 || i >= length(array)) {
29+ throw new Error("Index " + i + " is out of range. Check the length of " +
30+ "your array first or use getMaybe or getWithDefault.");
31+ }
32+ return unsafeGet(i, array);
33+ }
34+
35+ function unsafeGet(i, array) {
36+ for (var x = array.height; x > 0; x--) {
37+ var slot = i >> (x * 5);
38+ if (slot > 0) {
39+ while (array.lengths[slot - 1] > i) { slot--; }
40+ i -= array.lengths[slot - 1];
41+ }
42+ array = array.table[slot];
43+ }
44+ return array.table[i];
45+ }
46+
47+ // Sets the value at the index i. Only the nodes leading to i will get
48+ // copied and updated.
49+ function set(i, item, array) {
50+ if (i < 0 || length(array) <= i) {
51+ return array;
52+ }
53+ return unsafeSet(i, item, array);
54+ }
55+
56+ function unsafeSet(i, item, array) {
57+ array = nodeCopy(array);
58+
59+ if (array.height == 0) {
60+ array.table[i] = item;
61+ } else {
62+ var slot = getSlot(i, array);
63+ if (slot > 0) {
64+ i -= array.lengths[slot - 1];
65+ }
66+ array.table[slot] = unsafeSet(i, item, array.table[slot]);
67+ }
68+ return array;
69+ }
70+
71+ function initialize(len, f) {
72+ if (len == 0) { return empty; }
73+ var h = Math.floor(Math.log(len)/Math.log(M));
74+ return initialize_(f, h, 0, len);
75+ }
76+
77+ function initialize_(f, h, from, to) {
78+ if (h == 0) {
79+ var table = new Array((to - from) % (M + 1));
80+ for (var i = 0; i < table.length; i++) {
81+ table[i] = f(from + i);
82+ }
83+ return { ctor:"_Array", height:0, table:table };
84+ }
85+
86+ var step = Math.pow(M, h);
87+ var table = new Array(Math.ceil((to - from) / step));
88+ var lengths = new Array(table.length);
89+ for (var i = 0; i < table.length; i++) {
90+ table[i] = initialize_( f, h - 1, from + (i * step)
91+ , Math.min(from + ((i + 1) * step), to));
92+ lengths[i] = length(table[i]) + (i > 0 ? lengths[i-1] : 0);
93+ }
94+ return { ctor:"_Array", height:h, table:table, lengths:lengths };
95+ }
96+
97+ function fromList(list) {
98+ if (list == List.Nil) { return empty; }
99+
100+ // Allocate M sized blocks (table) and write list elements to it.
101+ var table = new Array(M);
102+ var nodes = new Array();
103+ var i = 0;
104+
105+ while (list.ctor !== '[]') {
106+ table[i] = list._0;
107+ list = list._1;
108+ i++;
109+
110+ // table is full, so we can push a leaf containing it into the
111+ // next node.
112+ if (i == M) {
113+ fromListPush({ ctor:"_Array", height:0, table:table }
114+ , nodes);
115+ table = new Array(M);
116+ i = 0;
117+ }
118+ }
119+
120+ // Maybe there is something left on the table.
121+ if (i > 0) {
122+ fromListPush({ ctor:"_Array", height:0, table:table.splice(0,i) }
123+ , nodes);
124+ }
125+
126+ // Go through all of the nodes and eventually push them into higher nodes.
127+ for (var h = 0; h < nodes.length - 1; h++) {
128+ if (nodes[h].table.length > 0) {
129+ fromListPush(nodes[h], nodes);
130+ }
131+ }
132+
133+ var head = nodes[nodes.length - 1];
134+ if (head.height > 0 && head.table.length == 1) {
135+ return head.table[0];
136+ } else {
137+ return head;
138+ }
139+ }
140+
141+ // Push a node into a higher node as a child.
142+ function fromListPush(toPush, nodes) {
143+ var h = toPush.height;
144+
145+ // Maybe the node on this height does not exist.
146+ if (nodes.length == h) {
147+ nodes.push({ ctor:"_Array", height:h + 1
148+ , table:new Array()
149+ , lengths:new Array() });
150+ }
151+
152+ nodes[h].table.push(toPush);
153+ var len = length(toPush);
154+ if (nodes[h].lengths.length > 0) {
155+ len += nodes[h].lengths[nodes[h].lengths.length - 1];
156+ }
157+ nodes[h].lengths.push(len);
158+
159+ if (nodes[h].table.length == M) {
160+ fromListPush(nodes[h], nodes);
161+ nodes[h] = { ctor:"_Array", height:h + 1
162+ , table:new Array()
163+ , lengths:new Array() };
164+ }
165+ }
166+
167+ // Pushes an item via push_ to the bottom right of a tree.
168+ function push(item, a) {
169+ var pushed = push_(item, a);
170+ if (pushed !== null) {
171+ return pushed;
172+ }
173+
174+ var newTree = create(item, a.height);
175+ return siblise(a, newTree);
176+ }
177+
178+ // Recursively tries to push an item to the bottom-right most
179+ // tree possible. If there is no space left for the item,
180+ // null will be returned.
181+ function push_(item, a) {
182+ // Handle resursion stop at leaf level.
183+ if (a.height == 0) {
184+ if (a.table.length < M) {
185+ var newA = { ctor:"_Array", height:0, table:a.table.slice() };
186+ newA.table.push(item);
187+ return newA;
188+ } else {
189+ return null;
190+ }
191+ }
192+
193+ // Recursively push
194+ var pushed = push_(item, botRight(a));
195+
196+ // There was space in the bottom right tree, so the slot will
197+ // be updated.
198+ if (pushed != null) {
199+ var newA = nodeCopy(a);
200+ newA.table[newA.table.length - 1] = pushed;
201+ newA.lengths[newA.lengths.length - 1]++;
202+ return newA
203+ }
204+
205+ // When there was no space left, check if there is space left
206+ // for a new slot with a tree which contains only the item
207+ // at the bottom.
208+ if (a.table.length < M) {
209+ var newSlot = create(item, a.height - 1);
210+ var newA = nodeCopy(a);
211+ newA.table.push(newSlot);
212+ newA.lengths.push(newA.lengths[newA.lengths.length - 1] + length(newSlot));
213+ return newA
214+ } else {
215+ return null;
216+ }
217+ }
218+
219+ // Converts an array into a list of elements.
220+ function toList(a) {
221+ return toList_(List.Nil, a);
222+ }
223+
224+ function toList_(list, a) {
225+ for (var i = a.table.length - 1; i >= 0; i--) {
226+ list = a.height == 0 ? List.Cons(a.table[i], list) : toList_(list, a.table[i]);
227+ }
228+ return list;
229+ }
230+
231+ // Maps a function over the elements of an array.
232+ function map(f, a) {
233+ var newA = { ctor:"_Array", height:a.height, table:new Array(a.table) };
234+ if (a.height > 0) { newA.lengths = a.lengths; }
235+ for (var i = 0; i < a.table.length; i++) {
236+ newA.table[i] = a.height == 0 ? f(a.table[i]) : map(f, a.table[i]);
237+ }
238+ return newA;
239+ }
240+
241+ // Maps a function over the elements with their index as first argument.
242+ function indexedMap(f, a) {
243+ return indexedMap_(f, a, 0);
244+ }
245+
246+ function indexedMap_(f, a, from) {
247+ var newA = { ctor:"_Array", height:a.height, table:new Array(a.table) };
248+ if (a.height > 0) { newA.lengths = a.lengths; }
249+ for (var i = 0; i < a.table.length; i++) {
250+ newA.table[i] = a.height == 0 ? A2(f, from + i, a.table[i])
251+ : indexedMap_( f, a.table[i]
252+ , i == 0 ? 0 : a.lengths[i - 1]);
253+ }
254+ return newA;
255+ }
256+
257+ function foldl(f, b, a) {
258+ for (var i = 0; i < a.table.length; i++) {
259+ b = A2(f, a.height == 0 ? a.table[i] : foldl(f, b, a.table[i]), b);
260+ }
261+ return b;
262+ }
263+
264+ function foldr(f, b, a) {
265+ for (var i = a.table.length; i--; ) {
266+ b = A2(f, a.height == 0 ? a.table[i] : foldr(f, b, a.table[i]), b);
267+ }
268+ return b;
269+ }
270+
271+ // TODO: currently, it slices the right, then the left. This can be
272+ // optimized.
273+ function slice(from, to, a) {
274+ if (from < 0) { from += length(a); }
275+ if (to < 0) { to += length(a); }
276+ return sliceLeft(from, sliceRight(to, a));
277+ }
278+
279+ function sliceRight(to, a) {
280+ if (to == length(a)) {
281+ return a;
282+ }
283+
284+ // Handle leaf level.
285+ if (a.height == 0) {
286+ var newA = { ctor:"_Array", height:0 };
287+ newA.table = a.table.slice(0, to);
288+ return newA;
289+ }
290+
291+ // Slice the right recursively.
292+ var right = getSlot(to, a);
293+ var sliced = sliceRight(to - (right > 0 ? a.lengths[right - 1] : 0), a.table[right]);
294+
295+ // Maybe the a node is not even needed, as sliced contains the whole slice.
296+ if (right == 0) {
297+ return sliced;
298+ }
299+
300+ // Create new node.
301+ var newA = { ctor:"_Array", height:a.height
302+ , table:a.table.slice(0, right + 1)
303+ , lengths:a.lengths.slice(0, right + 1) };
304+ newA.table[right] = sliced;
305+ newA.lengths[right] = length(sliced) + (right > 0 ? newA.lengths[right - 1] : 0);
306+ return newA;
307+ }
308+
309+ function sliceLeft(from, a) {
310+ if (from == 0) {
311+ return a;
312+ }
313+
314+ // Handle leaf level.
315+ if (a.height == 0) {
316+ var newA = { ctor:"_Array", height:0 };
317+ newA.table = a.table.slice(from, a.table.length + 1);
318+ return newA;
319+ }
320+
321+ // Slice the left recursively.
322+ var left = getSlot(from, a);
323+ var sliced = sliceLeft(from - (left > 0 ? a.lengths[left - 1] : 0), a.table[left]);
324+
325+ // Maybe the a node is not even needed, as sliced contains the whole slice.
326+ if (left == a.table.length - 1) {
327+ return sliced;
328+ }
329+
330+ // Create new node.
331+ var newA = { ctor:"_Array", height:a.height
332+ , table:a.table.slice(left, a.table.length + 1)
333+ , lengths:new Array(a.table.length - left) };
334+ newA.table[left] = sliced;
335+ var len = 0;
336+ for (var i = 0; i < newA.table.length; i++) {
337+ len += length(newA.table[i]);
338+ newA.lengths[i] = len;
339+ }
340+
341+ return newA;
342+ }
343+
344+ // Appends two trees.
345+ // TODO: Add support for appending trees of different sizes. Current
346+ // behavior will just rise the lower tree and then append them.
347+ function append(a,b) {
348+ if (b.height > a.height) { return append(parentise(a, b.height), b); }
349+ if (a.height > b.height) { return append(a, parentise(b, a.height)); }
350+ if (a.height == 0) { return append(parentise(a, 1), parentise(b, 1)); }
351+
352+ var c = append_(a, b);
353+ if (c[1].table.length > 0) {
354+ return siblise(c[0], c[1]);
355+ } else {
356+ return c[0];
357+ }
358+ }
359+
360+ // Returns an array of two nodes. The second node _may_ be empty. This case
361+ // needs to be handled by the function, that called append_. May be only
362+ // called for trees with an minimal height of 1.
363+ function append_(a, b) {
364+ if (a.height == 1) {
365+ // Check if balancing is needed and return based on that.
366+ var toRemove = calcToRemove(a, b);
367+ if (toRemove <= E) {
368+ return [a,b];
369+ }
370+
371+ return shuffle(a, b, toRemove);
372+ }
373+
374+ var appended = append_(botRight(a), botLeft(b));
375+ a = nodeCopy(a), b = nodeCopy(b);
376+
377+ // Adjust the bottom right side of the new tree.
378+ a.table[a.table.length - 1] = appended[0];
379+ a.lengths[a.lengths.length - 1] = length(appended[0])
380+ a.lengths[a.lengths.length - 1] += a.lengths.length > 1 ? a.lengths[a.lengths.length - 2] : 0;
381+
382+ // Adjust the bottom left side of the new tree.
383+ if (appended[1].table.length > 0) {
384+ b.table[0] = appended[1];
385+ b.lengths[0] = length(appended[1]);
386+ for (var i = 1, len = length(b.table[0]); i < b.lengths.length; i++) {
387+ len += length(b.table[i]);
388+ b.lengths[i] = len;
389+ }
390+ } else {
391+ b.table.shift();
392+ for (var i = 1; i < b.lengths.length; i++) {
393+ b.lengths[i] = b.lengths[i] - b.lengths[0];
394+ }
395+ b.lengths.shift();
396+ }
397+
398+ // Check if balancing is needed and return based on that.
399+ var toRemove = calcToRemove(a, b);
400+ if (toRemove <= E || b.table.length == 0) {
401+ return [a,b];
402+ }
403+
404+ return shuffle(a, b, toRemove);
405+ }
406+
407+ // Returns the extra search steps for E. Refer to the paper.
408+ function calcToRemove(a, b) {
409+ var subLengths = 0;
410+ for (var i = 0; i < a.table.length; i++) {
411+ subLengths += a.table[i].table.length;
412+ }
413+ for (var i = 0; i < b.table.length; i++) {
414+ subLengths += b.table[i].table.length;
415+ }
416+
417+ var toRemove = a.table.length + b.table.length
418+ return toRemove - (Math.floor((subLengths - 1) / M) + 1);
419+ }
420+
421+ // get2, set2 and saveSlot are helpers for accessing elements over two arrays.
422+ function get2(a, b, index) {
423+ return index < a.length ? a[index] : b[index - a.length];
424+ }
425+
426+ function set2(a, b, index, value) {
427+ if (index < a.length) {
428+ a[index] = value;
429+ } else {
430+ b[index - a.length] = value;
431+ }
432+ }
433+
434+ function saveSlot(a, b, index, slot) {
435+ set2(a.table, b.table, index, slot);
436+
437+ var l = (index == 0 || index == a.lengths.length) ?
438+ 0 : get2(a.lengths, a.lengths, index - 1);
439+ set2(a.lengths, b.lengths, index, l + length(slot));
440+ }
441+
442+ // Creates a node or leaf with a given length at their arrays for perfomance.
443+ // Is only used by shuffle.
444+ function createNode(h, length) {
445+ if (length < 0) { length = 0; }
446+ var a = { ctor:"_Array", height:h, table:new Array(length) };
447+ if (h > 0) {
448+ a.lengths = new Array(length);
449+ }
450+ return a;
451+ }
452+
453+ // Returns an array of two balanced nodes.
454+ function shuffle(a, b, toRemove) {
455+ var newA = createNode(a.height, Math.min(M, a.table.length + b.table.length - toRemove));
456+ var newB = createNode(a.height, newA.table.length - (a.table.length + b.table.length - toRemove));
457+
458+ // Skip the slots with size M. More precise: copy the slot references
459+ // to the new node
460+ var read = 0;
461+ while (get2(a.table, b.table, read).table.length % M == 0) {
462+ set2(newA.table, newB.table, read, get2(a.table, b.table, read));
463+ set2(newA.lengths, newB.lengths, read, get2(a.lengths, b.lengths, read));
464+ read++;
465+ }
466+
467+ // Pulling items from left to right, caching in a slot before writing
468+ // it into the new nodes.
469+ var write = read;
470+ var slot = new createNode(a.height - 1, 0);
471+ var from = 0;
472+
473+ // If the current slot is still containing data, then there will be at
474+ // least one more write, so we do not break this loop yet.
475+ while (read - write - (slot.table.length > 0 ? 1 : 0) < toRemove) {
476+ // Find out the max possible items for copying.
477+ var source = get2(a.table, b.table, read);
478+ var to = Math.min(M - slot.table.length, source.table.length)
479+
480+ // Copy and adjust size table.
481+ slot.table = slot.table.concat(source.table.slice(from, to));
482+ if (slot.height > 0) {
483+ var len = slot.lengths.length;
484+ for (var i = len; i < len + to - from; i++) {
485+ slot.lengths[i] = length(slot.table[i]);
486+ slot.lengths[i] += (i > 0 ? slot.lengths[i - 1] : 0);
487+ }
488+ }
489+
490+ from += to;
491+
492+ // Only proceed to next slots[i] if the current one was
493+ // fully copied.
494+ if (source.table.length <= to) {
495+ read++; from = 0;
496+ }
497+
498+ // Only create a new slot if the current one is filled up.
499+ if (slot.table.length == M) {
500+ saveSlot(newA, newB, write, slot);
501+ slot = createNode(a.height - 1,0);
502+ write++;
503+ }
504+ }
505+
506+ // Cleanup after the loop. Copy the last slot into the new nodes.
507+ if (slot.table.length > 0) {
508+ saveSlot(newA, newB, write, slot);
509+ write++;
510+ }
511+
512+ // Shift the untouched slots to the left
513+ while (read < a.table.length + b.table.length ) {
514+ saveSlot(newA, newB, write, get2(a.table, b.table, read));
515+ read++; write++;
516+ }
517+
518+ return [newA, newB];
519+ }
520+
521+ // Navigation functions
522+ function botRight(a) { return a.table[a.table.length - 1]; }
523+ function botLeft(a) { return a.table[0]; }
524+
525+ // Copies a node for updating. Note that you should not use this if
526+ // only updating only one of "table" or "lengths" for performance reasons.
527+ function nodeCopy(a) {
528+ var newA = { ctor:"_Array", height:a.height
529+ , table:a.table.slice() };
530+ if (a.height > 0) { newA.lengths = a.lengths.slice(); }
531+ return newA;
532+ }
533+
534+ // Returns how many items are in the tree.
535+ function length(array) {
536+ if (array.height == 0) {
537+ return array.table.length;
538+ } else {
539+ return array.lengths[array.lengths.length - 1];
540+ }
541+ }
542+
543+ // Calculates in which slot of "table" the item probably is, then
544+ // find the exact slot via forward searching in "lengths". Returns the index.
545+ function getSlot(i, a) {
546+ var slot = i >> (5 * a.height);
547+ while (a.lengths[slot - 1] > i) { slot--; }
548+ return slot;
549+ }
550+
551+ // Recursively creates a tree with a given height containing
552+ // only the given item.
553+ function create(item, h) {
554+ if (h == 0) {
555+ return { ctor:"_Array", height:0
556+ , table:[item] };
557+ } else {
558+ return { ctor:"_Array", height:h
559+ , table:[create(item, h - 1)]
560+ , lengths:[1] };
561+ }
562+ }
563+
564+ // Recursively creates a tree that contains the given tree.
565+ function parentise(tree, h) {
566+ if (h == tree.height) {
567+ return tree;
568+ } else {
569+ return { ctor:"_Array", height:h
570+ , table:[parentise(tree, h - 1)]
571+ , lengths:[length(tree)] };
572+ }
573+ }
574+
575+ // Emphasizes blood brotherhood beneath two trees.
576+ function siblise(a, b) {
577+ return { ctor:"_Array", height:a.height + 1
578+ , table:[a, b]
579+ , lengths:[length(a), length(a) + length(b)] };
580+ }
581+
582+ function toJSArray(a) {
583+ var jsArray = new Array(length(a));
584+ toJSArray_(jsArray, 0, a);
585+ return jsArray;
586+ }
587+
588+ function toJSArray_(jsArray, i, a) {
589+ for (var t = 0; t < a.table.length; t++) {
590+ if (a.height == 0) {
591+ jsArray[i + t] = a.table[t];
592+ } else {
593+ var inc = t == 0 ? 0 : a.lengths[t - 1];
594+ toJSArray_(jsArray, i + inc, a.table[t]);
595+ }
596+ }
597+ }
598+
599+ function fromJSArray(jsArray) {
600+ if (jsArray.length == 0) { return empty; }
601+ var h = Math.floor(Math.log(jsArray.length) / Math.log(M));
602+ return fromJSArray_(jsArray, h, 0, jsArray.length);
603+ }
604+
605+ function fromJSArray_(jsArray, h, from, to) {
606+ if (h == 0) {
607+ return { ctor:"_Array", height:0
608+ , table:jsArray.slice(from, to) };
609+ }
610+
611+ var step = Math.pow(M, h);
612+ var table = new Array(Math.ceil((to - from) / step));
613+ var lengths = new Array(table.length);
614+ for (var i = 0; i < table.length; i++) {
615+ table[i] = fromJSArray_( jsArray, h - 1, from + (i * step)
616+ , Math.min(from + ((i + 1) * step), to));
617+ lengths[i] = length(table[i]) + (i > 0 ? lengths[i-1] : 0);
618+ }
619+ return { ctor:"_Array", height:h, table:table, lengths:lengths };
620+ }
621+
622+ Elm.Native.Array.values = {
623+ empty:empty,
624+ fromList:fromList,
625+ toList:toList,
626+ initialize:F2(initialize),
627+ append:F2(append),
628+ push:F2(push),
629+ slice:F3(slice),
630+ get:F2(get),
631+ set:F3(set),
632+ map:F2(map),
633+ indexedMap:F2(indexedMap),
634+ foldl:F3(foldl),
635+ foldr:F3(foldr),
636+ length:length,
637+
638+ toJSArray:toJSArray,
639+ fromJSArray:fromJSArray
640+ };
641+
642+ return elm.Native.Array.values = Elm.Native.Array.values;
643+}
libraries/Native/Bitwise.js+1−1
@@ -19,7 +19,7 @@ Elm.Native.Bitwise.make = function(elm) {
19 complement: not,
19 complement: not,
20 shiftLeft : F2(sll),
20 shiftLeft : F2(sll),
21 shiftRightArithmatic: F2(sra),
21 shiftRightArithmatic: F2(sra),
22− shiftRightLogical : F2(srl),
22+ shiftRightLogical : F2(srl)
23 };
23 };
24
24
25};
25};
libraries/Native/Color.js+16−60
@@ -7,69 +7,25 @@ Elm.Native.Color.make = function(elm) {
7 var Utils = Elm.Native.Utils.make(elm);
7 var Utils = Elm.Native.Utils.make(elm);
8
8
9 function toCss(c) {
9 function toCss(c) {
10− return (c._3 === 1)
10+ var format = '';
11− ? ('rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')')
11+ var colors = '';
12− : ('rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')');
12+ if (c.ctor === 'RGBA') {
13− }
13+ format = 'rgb';
14−
14+ colors = c._0 + ', ' + c._1 + ', ' + c._2;
15− function complement(rgb) {
15+ } else {
16− var hsv = toHSV(rgb);
16+ format = 'hsl';
17− hsv.hue = (hsv.hue + 180) % 360;
17+ colors = (c._0 * 180 / Math.PI) + ', ' +
18− return toRGB(hsv);
18+ (c._1 * 100) + '%, ' +
19− }
19+ (c._2 * 100) + '%';
20−
20+ }
21− function hsva(h,s,v,a) {
21+ if (c._3 === 1) {
22− var degree = A2(Utils.mod, h * 180 / Math.PI, 360);
22+ return format + '(' + colors + ')';
23− var clr = toRGB({hue:degree, saturation:s, value:v});
23+ } else {
24− clr._3 = a;
24+ return format + 'a(' + colors + ', ' + c._3 + ')';
25− return clr;
25+ }
26− }
27−
28− function hsv(h,s,v) {
29− var degree = A2(Utils.mod, h * 180 / Math.PI, 360);
30− return toRGB({hue:degree, saturation:s, value:v});
31− }
32−
33− function toHSV(rgb) {
34− var hsv = {};
35− var r = rgb._0 / 255.0, g = rgb._1 / 255.0, b = rgb._2 / 255.0;
36− var M = Math.max(r,g,b);
37− var m = Math.min(r,g,b);
38− var c = M - m;
39−
40− var h = 0;
41− if (c === 0) { h = 0; }
42− else if (M === r) { h = ((g - b) / c) % 6; }
43− else if (M === g) { h = ((b - r) / c) + 2; }
44− else if (M === b) { h = ((r - g) / c) + 4; }
45− h *= 60;
46−
47− return { value : M, hue : h, saturation : (M === 0 ? 0 : c / M) };
48− }
49−
50− function between(lo,hi,x) { return lo <= x && x < hi; }
51− function norm(n) { return Math.round(n*255); }
52−
53− function toRGB(hsv) {
54− var c = hsv.value * hsv.saturation;
55− var hue = hsv.hue / 60;
56− var x = c * (1 - Math.abs((hue % 2) - 1));
57− var r = 0, g = 0, b = 0;
58− if (between(0,1,hue)) { r = c; g = x; b = 0; }
59− else if (between(1,2,hue)) { r = x; g = c; b = 0; }
60− else if (between(2,3,hue)) { r = 0; g = c; b = x; }
61− else if (between(3,4,hue)) { r = 0; g = x; b = c; }
62− else if (between(4,5,hue)) { r = x; g = 0; b = c; }
63− else if (between(5,6,hue)) { r = c; g = 0; b = x; }
64−
65− var m = hsv.value - c;
66− return { ctor:"Color", _0:norm(r+m), _1:norm(g+m), _2:norm(b+m), _3:1 };
67 }
26 }
68
27
69 return elm.Native.Color.values = {
28 return elm.Native.Color.values = {
70− hsva:F4(hsva),
71− hsv:F3(hsv),
72− complement:complement,
73 toCss:toCss
29 toCss:toCss
74 };
30 };
75
31
libraries/Native/Error.js+2−4
@@ -4,8 +4,6 @@ Elm.Native.Error.make = function(elm) {
4 elm.Native.Error = elm.Native.Error || {};
4 elm.Native.Error = elm.Native.Error || {};
5 if (elm.Native.Error.values) return elm.Native.Error.values;
5 if (elm.Native.Error.values) return elm.Native.Error.values;
6
6
7− var fromString = Elm.Native.JavaScript.make(elm).fromString;
8−
9 function indent(lines) {
7 function indent(lines) {
10 var msg = '';
8 var msg = '';
11 for (var i = 0; i < lines.length; ++i) {
9 for (var i = 0; i < lines.length; ++i) {
@@ -26,7 +24,7 @@ Elm.Native.Error.make = function(elm) {
26 throw new Error('Runtime error in module ' + moduleName + ' (' + span + '):' + msg);
24 throw new Error('Runtime error in module ' + moduleName + ' (' + span + '):' + msg);
27 }
25 }
28
26
29− function raise(str) { throw new Error(fromString(str)); }
27+ function raise(str) { throw new Error(str); }
30
28
31 return elm.Native.Error.values = { Case: Case, If: If, raise: raise };
29 return elm.Native.Error.values = { Case: Case, If: If, raise: raise };
32−};
30+};
libraries/Native/Graphics/Input.js+1−1
@@ -286,7 +286,7 @@ Elm.Native.Graphics.Input.make = function(elm) {
286 start: start,
286 start: start,
287 end: end,
287 end: end,
288 direction: { ctor: direction }
288 direction: { ctor: direction }
289− },
289+ }
290 }));
290 }));
291 }
291 }
292
292
libraries/Native/Json.js+1−1
@@ -79,7 +79,7 @@ Elm.Native.Json.make = function(elm) {
79 toString : F2(toString),
79 toString : F2(toString),
80 fromString : fromString,
80 fromString : fromString,
81 fromJS : fromJS,
81 fromJS : fromJS,
82− toJS : toJS,
82+ toJS : toJS
83 };
83 };
84
84
85};
85};
libraries/Native/List.js+65−5
@@ -199,6 +199,16 @@ Elm.Native.List.make = function(elm) {
199 return false;
199 return false;
200 }
200 }
201
201
202+ function zip(xs, ys) {
203+ var arr = [];
204+ while (xs.ctor !== '[]' && ys.ctor !== '[]') {
205+ arr.push(Utils.Tuple2(xs._0, ys._0));
206+ xs = xs._1;
207+ ys = ys._1;
208+ }
209+ return fromArray(arr);
210+ }
211+
202 function zipWith(f, xs, ys) {
212 function zipWith(f, xs, ys) {
203 var arr = [];
213 var arr = [];
204 while (xs.ctor !== '[]' && ys.ctor !== '[]') {
214 while (xs.ctor !== '[]' && ys.ctor !== '[]') {
@@ -209,12 +219,47 @@ Elm.Native.List.make = function(elm) {
209 return fromArray(arr);
219 return fromArray(arr);
210 }
220 }
211
221
212− function zip(xs, ys) {
222+ function zipWith3(f, xs, ys, zs) {
213 var arr = [];
223 var arr = [];
214− while (xs.ctor !== '[]' && ys.ctor !== '[]') {
224+ while (xs.ctor !== '[]' && ys.ctor !== '[]' && zs.ctor !== '[]') {
215− arr.push(Utils.Tuple2(xs._0, ys._0));
225+ arr.push(A3(f, xs._0, ys._0, zs._0));
226+ xs = xs._1;
227+ ys = ys._1;
228+ zs = zs._1;
229+ }
230+ return fromArray(arr);
231+ }
232+
233+ function zipWith4(f, ws, xs, ys, zs) {
234+ var arr = [];
235+ while ( ws.ctor !== '[]'
236+ && xs.ctor !== '[]'
237+ && ys.ctor !== '[]'
238+ && zs.ctor !== '[]')
239+ {
240+ arr.push(A4(f, ws._0, xs._0, ys._0, zs._0));
241+ ws = ws._1;
242+ xs = xs._1;
243+ ys = ys._1;
244+ zs = zs._1;
245+ }
246+ return fromArray(arr);
247+ }
248+
249+ function zipWith5(f, vs, ws, xs, ys, zs) {
250+ var arr = [];
251+ while ( vs.ctor !== '[]'
252+ && ws.ctor !== '[]'
253+ && xs.ctor !== '[]'
254+ && ys.ctor !== '[]'
255+ && zs.ctor !== '[]')
256+ {
257+ arr.push(A5(f, vs._0, ws._0, xs._0, ys._0, zs._0));
258+ vs = vs._1;
259+ ws = ws._1;
216 xs = xs._1;
260 xs = xs._1;
217 ys = ys._1;
261 ys = ys._1;
262+ zs = zs._1;
218 }
263 }
219 return fromArray(arr);
264 return fromArray(arr);
220 }
265 }
@@ -289,6 +334,16 @@ Elm.Native.List.make = function(elm) {
289 return fromArray(out);
334 return fromArray(out);
290 }
335 }
291
336
337+ /*
338+ * Only to be used internally; do some side effects for each elem
339+ */
340+ function each(action, xs) {
341+ while(xs.ctor !== '[]') {
342+ action(xs._0);
343+ xs = xs._1;
344+ }
345+ }
346+
292 Elm.Native.List.values = {
347 Elm.Native.List.values = {
293 Nil:Nil,
348 Nil:Nil,
294 Cons:Cons,
349 Cons:Cons,
@@ -318,7 +373,10 @@ Elm.Native.List.make = function(elm) {
318
373
319 all:F2(all),
374 all:F2(all),
320 any:F2(any),
375 any:F2(any),
321− zipWith:F3(zipWith),
376+ zipWith :F3(zipWith ),
377+ zipWith3:F4(zipWith3),
378+ zipWith4:F5(zipWith4),
379+ zipWith5:F6(zipWith5),
322 zip:F2(zip),
380 zip:F2(zip),
323 sort:sort,
381 sort:sort,
324 sortBy:F2(sortBy),
382 sortBy:F2(sortBy),
@@ -328,7 +386,9 @@ Elm.Native.List.make = function(elm) {
328 drop:F2(drop),
386 drop:F2(drop),
329 repeat:F2(repeat),
387 repeat:F2(repeat),
330
388
331− join:F2(join)
389+ join:F2(join),
390+
391+ each:each
332 };
392 };
333 return elm.Native.List.values = Elm.Native.List.values;
393 return elm.Native.List.values = Elm.Native.List.values;
334
394
libraries/Native/Regex.js+2−2
@@ -43,7 +43,7 @@ Elm.Native.Regex.make = function(elm) {
43 match: result[0],
43 match: result[0],
44 submatches: List.fromArray(subs),
44 submatches: List.fromArray(subs),
45 index: result.index,
45 index: result.index,
46− number: number,
46+ number: number
47 });
47 });
48 }
48 }
49 return List.fromArray(out);
49 return List.fromArray(out);
@@ -98,6 +98,6 @@ Elm.Native.Regex.make = function(elm) {
98 contains: F2(contains),
98 contains: F2(contains),
99 find: F3(find),
99 find: F3(find),
100 replace: F4(replace),
100 replace: F4(replace),
101− split: F3(split),
101+ split: F3(split)
102 };
102 };
103};
103};
libraries/Native/Show.js+4
@@ -5,6 +5,7 @@ Elm.Native.Show.make = function(elm) {
5 if (elm.Native.Show.values) return elm.Native.Show.values;
5 if (elm.Native.Show.values) return elm.Native.Show.values;
6
6
7 var NList = Elm.Native.List.make(elm);
7 var NList = Elm.Native.List.make(elm);
8+ var Array = Elm.Array.make(elm);
8 var List = Elm.List.make(elm);
9 var List = Elm.List.make(elm);
9 var Dict = Elm.Dict.make(elm);
10 var Dict = Elm.Dict.make(elm);
10 var Tuple2 = Elm.Native.Utils.make(elm).Tuple2;
11 var Tuple2 = Elm.Native.Utils.make(elm).Tuple2;
@@ -43,6 +44,9 @@ Elm.Native.Show.make = function(elm) {
43 output.push(toString(v[k]));
44 output.push(toString(v[k]));
44 }
45 }
45 return "(" + output.join(",") + ")";
46 return "(" + output.join(",") + ")";
47+ } else if (v.ctor === "_Array") {
48+ var list = Array.toList(v);
49+ return "Array.fromList " + toString(list);
46 } else if (v.ctor === "::") {
50 } else if (v.ctor === "::") {
47 var output = '[' + toString(v._0);
51 var output = '[' + toString(v._0);
48 v = v._1;
52 v = v._1;
libraries/Native/String.js+4−4
@@ -73,7 +73,7 @@ Elm.Native.String.make = function(elm) {
73 return result;
73 return result;
74 }
74 }
75
75
76− function sub(start, end, str) {
76+ function slice(start, end, str) {
77 return str.slice(start,end);
77 return str.slice(start,end);
78 }
78 }
79 function left(n, str) {
79 function left(n, str) {
@@ -111,7 +111,7 @@ Elm.Native.String.make = function(elm) {
111 }
111 }
112
112
113 function words(str) {
113 function words(str) {
114− return List.fromArray(str.split(/\s+/g));
114+ return List.fromArray(str.trim().split(/\s+/g));
115 }
115 }
116 function lines(str) {
116 function lines(str) {
117 return List.fromArray(str.split(/\r\n|\r|\n/g));
117 return List.fromArray(str.split(/\r\n|\r|\n/g));
@@ -216,7 +216,7 @@ Elm.Native.String.make = function(elm) {
216 join: F2(join),
216 join: F2(join),
217 repeat: F2(repeat),
217 repeat: F2(repeat),
218
218
219− sub: F3(sub),
219+ slice: F3(slice),
220 left: F2(left),
220 left: F2(left),
221 right: F2(right),
221 right: F2(right),
222 dropLeft: F2(dropLeft),
222 dropLeft: F2(dropLeft),
@@ -247,6 +247,6 @@ Elm.Native.String.make = function(elm) {
247 toInt: toInt,
247 toInt: toInt,
248 toFloat: toFloat,
248 toFloat: toFloat,
249 toList: toList,
249 toList: toList,
250− fromList: fromList,
250+ fromList: fromList
251 };
251 };
252};
252};
libraries/Native/Text.js+3−3
@@ -123,7 +123,7 @@ Elm.Native.Text.make = function(elm) {
123 html : Utils.makeText(text),
123 html : Utils.makeText(text),
124 align: align,
124 align: align,
125 guid : null,
125 guid : null,
126− args : [],
126+ args : []
127 };
127 };
128 var pos = A2(Utils.htmlHeight, 0, raw);
128 var pos = A2(Utils.htmlHeight, 0, raw);
129 return A3(Element.newElement, pos._0, pos._1, raw);
129 return A3(Element.newElement, pos._0, pos._1, raw);
@@ -136,7 +136,7 @@ Elm.Native.Text.make = function(elm) {
136 html: text,
136 html: text,
137 align: null,
137 align: null,
138 guid: guid,
138 guid: guid,
139− args: [],
139+ args: []
140 };
140 };
141 var pos = A2(Utils.htmlHeight, 0, raw);
141 var pos = A2(Utils.htmlHeight, 0, raw);
142 return A3(Element.newElement, pos._0, pos._1, raw);
142 return A3(Element.newElement, pos._0, pos._1, raw);
@@ -162,6 +162,6 @@ Elm.Native.Text.make = function(elm) {
162 markdown : markdown,
162 markdown : markdown,
163
163
164 toTypefaces:toTypefaces,
164 toTypefaces:toTypefaces,
165− toLine:toLine,
165+ toLine:toLine
166 };
166 };
167};
167};
libraries/Native/Utils.js+35−14
@@ -5,23 +5,39 @@ Elm.Native.Utils.make = function(elm) {
5 elm.Native.Utils = elm.Native.Utils || {};
5 elm.Native.Utils = elm.Native.Utils || {};
6 if (elm.Native.Utils.values) return elm.Native.Utils.values;
6 if (elm.Native.Utils.values) return elm.Native.Utils.values;
7
7
8− function eq(x,y) {
8+ function eq(l,r) {
9− if (x === y) return true;
9+ var stack = [{'x': l, 'y': r}]
10+ while (stack.length > 0) {
11+ var front = stack.pop();
12+ var x = front.x;
13+ var y = front.y;
14+ if (x === y) continue;
10− if (typeof x === "object") {
15+ if (typeof x === "object") {
11− var c = 0;
16+ var c = 0;
12− for (var i in x) {
17+ for (var i in x) {
13− ++c;
18+ ++c;
14− if (!eq(x[i],y[i])) {
19+ if (i in y) {
20+ if (i !== 'ctor') {
21+ stack.push({ 'x': x[i], 'y': y[i] });
22+ }
23+ } else {
15− return false;
24+ return false;
25+ }
26+ }
27+ if ('ctor' in x) {
28+ stack.push({'x': x.ctor, 'y': y.ctor});
16 }
29 }
30+ if (c !== Object.keys(y).length) {
31+ return false;
32+ };
33+ } else if (typeof x === 'function') {
34+ throw new Error('Equality error: general function equality is ' +
35+ 'undecidable, and therefore, unsupported');
36+ } else {
37+ return false;
17 }
38 }
18− return c === Object.keys(y).length;
19 }
39 }
20− if (typeof x === 'function') {
21− throw new Error('Equality error: general function equality is ' +
22− 'undecidable, and therefore, unsupported');
23− }
24− return x === y;
40+ return true;
25 }
41 }
26
42
27 // code in Generate/JavaScript.hs depends on the particular
43 // code in Generate/JavaScript.hs depends on the particular
@@ -210,6 +226,10 @@ Elm.Native.Utils.make = function(elm) {
210 return Tuple2(posx, posy);
226 return Tuple2(posx, posy);
211 }
227 }
212
228
229+ function isJSArray(a) {
230+ return a instanceof Array;
231+ }
232+
213 return elm.Native.Utils.values = {
233 return elm.Native.Utils.values = {
214 eq:eq,
234 eq:eq,
215 cmp:cmp,
235 cmp:cmp,
@@ -229,6 +249,7 @@ Elm.Native.Utils.make = function(elm) {
229 mod : F2(mod),
249 mod : F2(mod),
230 htmlHeight: F2(htmlHeight),
250 htmlHeight: F2(htmlHeight),
231 getXY: getXY,
251 getXY: getXY,
252+ isJSArray: isJSArray,
232 toFloat: function(x) { return +x; }
253 toFloat: function(x) { return +x; }
233 };
254 };
234};
255};
libraries/Set.elm+11−1
@@ -2,6 +2,7 @@
2module Set (empty,singleton,insert,remove
2module Set (empty,singleton,insert,remove
3 ,member
3 ,member
4 ,foldl,foldr,map
4 ,foldl,foldr,map
5+ ,filter,partition
5 ,union,intersect,diff
6 ,union,intersect,diff
6 ,toList,fromList
7 ,toList,fromList
7 ) where
8 ) where
@@ -25,7 +26,7 @@ Insert, remove, and query operations all take *O(log n)* time.
25@docs toList, fromList
26@docs toList, fromList
26
27
27# Transform
28# Transform
28−@docs map, foldl, foldr
29+@docs map, foldl, foldr, filter, partition
29
30
30-}
31-}
31
32
@@ -88,3 +89,12 @@ foldr f b s = Dict.foldr (\k _ b -> f k b) b s
88{-| Map a function onto a set, creating a new set with no duplicates. -}
89{-| Map a function onto a set, creating a new set with no duplicates. -}
89map : (comparable -> comparable') -> Set comparable -> Set comparable'
90map : (comparable -> comparable') -> Set comparable -> Set comparable'
90map f s = fromList (List.map f (toList s))
91map f s = fromList (List.map f (toList s))
92+
93+{-| Create a new set consisting only of elements which satisfy a predicate. -}
94+filter : (comparable -> Bool) -> Set comparable -> Set comparable
95+filter p set = Dict.filter (\k _ -> p k) set
96+
97+{-| Create two new sets; the first consisting of elements which satisfy a
98+predicate, the second consisting of elements which do not. -}
99+partition : (comparable -> Bool) -> Set comparable -> (Set comparable, Set comparable)
100+partition p set = Dict.partition (\k _ -> p k) set
libraries/Signal.elm−3
@@ -31,10 +31,7 @@ the `Time` library.
31
31
32import Native.Signal
32import Native.Signal
33import List (foldr)
33import List (foldr)
34−
35import Basics (fst, snd, not)
34import Basics (fst, snd, not)
36−import Native.Error
37−import Maybe as M
38
35
39data Signal a = Signal
36data Signal a = Signal
40
37
libraries/String.elm+8−8
@@ -6,10 +6,10 @@ are enclosed in `"double quotes"`. Strings are *not* lists of characters.
6@docs isEmpty, length, reverse, repeat
6@docs isEmpty, length, reverse, repeat
7
7
8# Building and Splitting
8# Building and Splitting
9−@docs cons, uncons, append, concat, split, join, words, lines
9+@docs cons, uncons, append, concat, split, join, words, lines
10
10
11# Get Substrings
11# Get Substrings
12−@docs sub, left, right, dropLeft, dropRight
12+@docs slice, left, right, dropLeft, dropRight
13
13
14# Check for Substrings
14# Check for Substrings
15@docs contains, startsWith, endsWith, indexes, indices
15@docs contains, startsWith, endsWith, indexes, indices
@@ -139,13 +139,13 @@ repeat = Native.String.repeat
139{-| Take a substring given a start and end index. Negative indexes
139{-| Take a substring given a start and end index. Negative indexes
140are taken starting from the *end* of the list.
140are taken starting from the *end* of the list.
141
141
142− sub 7 9 "snakes on a plane!" == "on"
142+ slice 7 9 "snakes on a plane!" == "on"
143− sub 0 6 "snakes on a plane!" == "snakes"
143+ slice 0 6 "snakes on a plane!" == "snakes"
144− sub 0 -7 "snakes on a plane!" == "snakes on a"
144+ slice 0 -7 "snakes on a plane!" == "snakes on a"
145− sub -6 -1 "snakes on a plane!" == "plane"
145+ slice -6 -1 "snakes on a plane!" == "plane"
146-}
146-}
147−sub : Int -> Int -> String -> String
147+slice : Int -> Int -> String -> String
148−sub = Native.String.sub
148+slice = Native.String.slice
149
149
150{-| Take N characters from the left side of a string. -}
150{-| Take N characters from the left side of a string. -}
151left : Int -> String -> String
151left : Int -> String -> String
libraries/elm_dependencies.json+6−5
@@ -1,12 +1,13 @@
1−{ "version": "0.12"
1+{ "version": "0.12.3"
2, "summary": "Elm's standard libraries"
2, "summary": "Elm's standard libraries"
3−, "description": "The full set of standard libraries for Elm. This library is pegged to the version number of the compiler, so if you are using Elm 0.12, you should be using version 0.12 of the standard libraries."
3+, "description": "The full set of standard libraries for Elm. This library is pegged to the version number of the compiler, so if you are using Elm 0.12.3, you should be using version 0.12.3 of the standard libraries."
4, "license": "BSD3"
4, "license": "BSD3"
5−, "repository": "http://github.com/evancz/Elm.git"
5+, "repository": "http://github.com/elm-lang/Elm.git"
6−, "elm-version": "0.12"
6+, "elm-version": "0.12.3"
7, "dependencies": {}
7, "dependencies": {}
8, "exposed-modules":
8, "exposed-modules":
9+ [ "Array"
9− [ "Basics"
10+ , "Basics"
10 , "Bitwise"
11 , "Bitwise"
11 , "Char"
12 , "Char"
12 , "Color"
13 , "Color"
runtime/Render/Collage.js+4−4
@@ -5,7 +5,7 @@ var Render = ElmRuntime.use(ElmRuntime.Render.Element);
5var Transform = Elm.Transform2D.make({});
5var Transform = Elm.Transform2D.make({});
6var Utils = ElmRuntime.use(ElmRuntime.Render.Utils);
6var Utils = ElmRuntime.use(ElmRuntime.Render.Utils);
7var newElement = Utils.newElement,
7var newElement = Utils.newElement,
8− extract = Utils.extract, fromList = Utils.fromList,
8+ colorToCss = Utils.colorToCss, fromList = Utils.fromList,
9 fromString = Utils.fromString, addTransform = Utils.addTransform;
9 fromString = Utils.fromString, addTransform = Utils.addTransform;
10
10
11function trace(ctx, path) {
11function trace(ctx, path) {
@@ -70,7 +70,7 @@ function drawLine(ctx, style, path) {
70 ctx.lineJoin = join === 'Smooth' ? 'round' :
70 ctx.lineJoin = join === 'Smooth' ? 'round' :
71 join === 'Sharp' ? 'miter' : 'bevel';
71 join === 'Sharp' ? 'miter' : 'bevel';
72 ctx.miterLimit = style.join._0 || 10;
72 ctx.miterLimit = style.join._0 || 10;
73− ctx.strokeStyle = extract(style.color);
73+ ctx.strokeStyle = colorToCss(style.color);
74 return line(ctx, style, path);
74 return line(ctx, style, path);
75}
75}
76
76
@@ -96,7 +96,7 @@ function gradient(ctx, grad) {
96 var len = stops.length;
96 var len = stops.length;
97 for (var i = 0; i < len; ++i) {
97 for (var i = 0; i < len; ++i) {
98 var stop = stops[i];
98 var stop = stops[i];
99− g.addColorStop(stop._0, extract(stop._1));
99+ g.addColorStop(stop._0, colorToCss(stop._1));
100 }
100 }
101 return g;
101 return g;
102}
102}
@@ -105,7 +105,7 @@ function drawShape(redo, ctx, style, path) {
105 trace(ctx, path);
105 trace(ctx, path);
106 var sty = style.ctor;
106 var sty = style.ctor;
107 ctx.fillStyle =
107 ctx.fillStyle =
108− sty === 'Solid' ? extract(style._0) :
108+ sty === 'Solid' ? colorToCss(style._0) :
109 sty === 'Texture' ? texture(redo, ctx, style._0) : gradient(ctx, style._0);
109 sty === 'Texture' ? texture(redo, ctx, style._0) : gradient(ctx, style._0);
110 ctx.scale(1,-1);
110 ctx.scale(1,-1);
111 ctx.fill();
111 ctx.fill();
runtime/Render/Element.js+33−27
@@ -3,7 +3,7 @@ ElmRuntime.Render.Element = function() {
3'use strict';
3'use strict';
4
4
5var Utils = ElmRuntime.use(ElmRuntime.Render.Utils);
5var Utils = ElmRuntime.use(ElmRuntime.Render.Utils);
6−var newElement = Utils.newElement, extract = Utils.extract,
6+var newElement = Utils.newElement, colorToCss = Utils.colorToCss,
7 addTransform = Utils.addTransform, removeTransform = Utils.removeTransform,
7 addTransform = Utils.addTransform, removeTransform = Utils.removeTransform,
8 fromList = Utils.fromList, eq = Utils.eq;
8 fromList = Utils.fromList, eq = Utils.eq;
9
9
@@ -18,7 +18,7 @@ function setProps(elem, e) {
18 e.style.opacity = props.opacity;
18 e.style.opacity = props.opacity;
19 }
19 }
20 if (props.color.ctor === 'Just') {
20 if (props.color.ctor === 'Just') {
21− e.style.backgroundColor = extract(props.color._0);
21+ e.style.backgroundColor = colorToCss(props.color._0);
22 }
22 }
23 if (props.tag !== '') { e.id = props.tag; }
23 if (props.tag !== '') { e.id = props.tag; }
24 if (props.href !== '') {
24 if (props.href !== '') {
@@ -143,29 +143,37 @@ function croppedImage(elem, w, h, src) {
143 return e;
143 return e;
144}
144}
145
145
146−function goIn(e) { e.style.position = 'absolute'; return e; }
146+function goOut(e) { e.style.position = 'absolute'; return e; }
147function goDown(e) { return e }
147function goDown(e) { return e }
148function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e; }
148function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e; }
149−function flowWith(f, array) {
150− var container = newElement('div');
151− if (f == goIn) container.style.pointerEvents = 'none';
152
149
153− for (var i = array.length; i--; ) {
150+var directionTable = {
154− container.appendChild(f(render(array[i])));
151+ DUp : goDown,
152+ DDown : goDown,
153+ DLeft : goRight,
154+ DRight : goRight,
155+ DIn : goOut,
156+ DOut : goOut
155− }
157+};
156− return container;
158+function needsReversal(dir) {
159+ return dir == 'DUp' || dir == 'DLeft' || dir == 'DIn';
157}
160}
158
161
159function flow(dir,elist) {
162function flow(dir,elist) {
160 var array = fromList(elist);
163 var array = fromList(elist);
161− switch(dir.ctor) {
164+ var container = newElement('div');
162− case "DDown": array.reverse();
165+ var goDir = directionTable[dir];
163− case "DUp": return flowWith(goDown,array);
166+ if (goDir == goOut) {
164− case "DRight": array.reverse();
167+ container.style.pointerEvents = 'none';
165− case "DLeft": return flowWith(goRight,array);
166− case "DOut": array.reverse();
167− case "DIn": return flowWith(goIn,array);
168 }
168 }
169+ if (needsReversal(dir)) {
170+ array.reverse();
171+ }
172+ var len = array.length;
173+ for (var i = 0; i < len; ++i) {
174+ container.appendChild(goDir(render(array[i])));
175+ }
176+ return container;
169}
177}
170
178
171function toPos(pos) {
179function toPos(pos) {
@@ -245,7 +253,7 @@ function makeElement(e) {
245 var elem = e.element;
253 var elem = e.element;
246 switch(elem.ctor) {
254 switch(elem.ctor) {
247 case 'Image': return image(e.props, elem);
255 case 'Image': return image(e.props, elem);
248− case 'Flow': return flow(elem._0, elem._1);
256+ case 'Flow': return flow(elem._0.ctor, elem._1);
249 case 'Container': return container(elem._0, elem._1);
257 case 'Container': return container(elem._0, elem._1);
250 case 'Spacer': return newElement('div');
258 case 'Spacer': return newElement('div');
251 case 'RawHtml': return rawHtml(elem);
259 case 'RawHtml': return rawHtml(elem);
@@ -321,14 +329,12 @@ function update(node, curr, next) {
321 return true;
329 return true;
322 }
330 }
323 var currs = fromList(currE._1);
331 var currs = fromList(currE._1);
324− var goDir = function(x) { return x; };
325− switch(nextE._0.ctor) {
332+ var dir = nextE._0.ctor;
326− case "DDown": case "DUp": goDir = goDown; break;
333+ var goDir = directionTable[dir];
327− case "DRight": case "DLeft": goDir = goRight; break;
334+ var toReverse = needsReversal(dir);
328− case "DOut": case "DIn": goDir = goIn; break;
335+ var len = kids.length;
329− }
330− for (var i = kids.length; i-- ;) {
336+ for (var i = len; i-- ;) {
331− update(kids[i],currs[i],nexts[i]);
337+ update(kids[toReverse ? len - i - 1 : i],currs[i],nexts[i]);
332 goDir(kids[i]);
338 goDir(kids[i]);
333 }
339 }
334 break;
340 break;
@@ -364,7 +370,7 @@ function updateProps(node, curr, next) {
364 e.style.opacity = props.opacity;
370 e.style.opacity = props.opacity;
365 }
371 }
366 var nextColor = (props.color.ctor === 'Just' ?
372 var nextColor = (props.color.ctor === 'Just' ?
367− extract(props.color._0) : '');
373+ colorToCss(props.color._0) : '');
368 if (e.style.backgroundColor !== nextColor) {
374 if (e.style.backgroundColor !== nextColor) {
369 e.style.backgroundColor = (nextColor === '' ? 'transparent' : nextColor);
375 e.style.backgroundColor = (nextColor === '' ? 'transparent' : nextColor);
370 }
376 }
runtime/Render/Utils.js+2−7
@@ -10,11 +10,6 @@ ElmRuntime.Render.Utils = function() {
10 container.appendChild(elem);
10 container.appendChild(elem);
11 }
11 }
12
12
13− function extract(c) {
14− if (c._3 === 1) { return 'rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')'; }
15− return 'rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')';
16− }
17−
18 function addTransform(style, trans) {
13 function addTransform(style, trans) {
19 style.transform = trans;
14 style.transform = trans;
20 style.msTransform = trans;
15 style.msTransform = trans;
@@ -34,8 +29,8 @@ ElmRuntime.Render.Utils = function() {
34 var List = Elm.Native.List.make({});
29 var List = Elm.Native.List.make({});
35
30
36 return {addTo:addTo,
31 return {addTo:addTo,
37− newElement:newElement,
32+ newElement: newElement,
38− extract : extract,
33+ colorToCss: Elm.Native.Color.make({}).toCss,
39 fromList: List.toArray,
34 fromList: List.toArray,
40 fromString: function(s) { return s; },
35 fromString: function(s) { return s; },
41 toString: function(s) { return s; },
36 toString: function(s) { return s; },
server/LICENSEdeleted−30
@@ -1,30 +0,0 @@
1−Copyright (c)2012-2014, Evan Czaplicki
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
10−
11− * Redistributions in binary form must reproduce the above
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of Evan Czaplicki nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
server/Server.hsdeleted−127
@@ -1,127 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
3−module Main where
4−
5−import Control.Applicative ((<$>),(<|>))
6−import Control.Monad (guard)
7−import Control.Monad.Trans (MonadIO(liftIO))
8−import qualified Data.ByteString as BS
9−import qualified Data.ByteString.Char8 as BSC
10−import qualified Data.HashMap.Strict as Map
11−import qualified Data.Version as Version
12−import System.Console.CmdArgs
13−import System.Directory
14−import System.Exit
15−import System.FilePath
16−import System.Process
17−import System.IO (hGetContents, Handle)
18−
19−import Paths_elm_server (version)
20−import qualified Elm.Internal.Paths as Elm
21−import Snap.Core
22−import Snap.Http.Server
23−import Snap.Util.FileServe
24−
25−data Flags = Flags
26− { port :: Int
27− , runtime :: Maybe FilePath
28− } deriving (Data,Typeable,Show,Eq)
29−
30−flags :: Flags
31−flags = Flags
32− { port = 8000 &= help "set the port of the server"
33− , runtime = Nothing &= typFile
34− &= help "Specify a custom location for Elm's runtime system."
35− } &= help "Quickly reload Elm projects in your browser. Just refresh to recompile.\n\
36− \It serves static files and freshly recompiled Elm files."
37− &= helpArg [explicit, name "help", name "h"]
38− &= versionArg [ explicit, name "version", name "v"
39− , summary (Version.showVersion version)
40− ]
41− &= summary ("Elm Server " ++ Version.showVersion version ++
42− ", (c) Evan Czaplicki 2011-2014")
43−
44−
45−config :: Config Snap a
46−config = setAccessLog ConfigNoLog (setErrorLog ConfigNoLog defaultConfig)
47−
48−-- | Set up the server.
49−main :: IO ()
50−main = do
51− cargs <- cmdArgs flags
52− putStrLn $ "Elm Server " ++ Version.showVersion version ++
53− ": Just refresh a page to recompile it!"
54− httpServe (setPort (port cargs) config) $
55− serveRuntime (maybe Elm.runtime id (runtime cargs))
56− <|> serveElm
57− <|> serveDirectoryWith directoryConfig "."
58−
59−directoryConfig :: MonadSnap m => DirectoryConfig m
60−directoryConfig =
61− fancyDirectoryConfig
62− { indexGenerator = defaultIndexGenerator defaultMimeTypes indexStyle
63− , mimeTypes = Map.insert ".elm" "text/html" defaultMimeTypes
64− }
65−
66−indexStyle :: BS.ByteString
67−indexStyle =
68− "body { margin:0; font-family:sans-serif; background:rgb(245,245,245);\
69− \ font-family: calibri, verdana, helvetica, arial; }\
70− \div.header { padding: 40px 50px; font-size: 24px; }\
71− \div.content { padding: 0 40px }\
72− \div.footer { display:none; }\
73− \table { width:100%; border-collapse:collapse; }\
74− \td { padding: 6px 10px; }\
75− \tr:nth-child(odd) { background:rgb(216,221,225); }\
76− \td { font-family:monospace }\
77− \th { background:rgb(90,99,120); color:white; text-align:left;\
78− \ padding:10px; font-weight:normal; }"
79−
80−runtimeName :: String
81−runtimeName = "elm-runtime.js"
82−
83−serveRuntime :: FilePath -> Snap ()
84−serveRuntime runtimePath =
85− do file <- BSC.unpack . rqPathInfo <$> getRequest
86− guard (file == runtimeName)
87− serveFileAs "application/javascript" runtimePath
88−
89−serveElm :: Snap ()
90−serveElm =
91− do file <- BSC.unpack . rqPathInfo <$> getRequest
92− exists <- liftIO $ doesFileExist file
93− guard (exists && takeExtension file == ".elm")
94− onSuccess (compile file) (serve file)
95− where
96− compile file =
97− let elmArgs = [ "--make", "--runtime=" ++ runtimeName, file ]
98− in createProcess $ (proc "elm" elmArgs) { std_out = CreatePipe }
99−
100− serve file =
101− serveFileAs "text/html; charset=UTF-8" ("build" </> replaceExtension file "html")
102−
103−failure :: String -> Snap ()
104−failure msg =
105− do modifyResponse $ setResponseStatus 404 "Not found"
106− writeBS $ BSC.pack msg
107−
108−onSuccess :: IO (t, Maybe Handle, t1, ProcessHandle) -> Snap () -> Snap ()
109−onSuccess action success =
110− do (_, stdout, _, handle) <- liftIO action
111− exitCode <- liftIO $ waitForProcess handle
112− case (exitCode, stdout) of
113− (ExitFailure 127, _) ->
114− failure "Error: elm compiler not found in your path."
115−
116− (ExitFailure _, Just out) ->
117− failure =<< liftIO (hGetContents out)
118−
119− (ExitFailure _, Nothing) ->
120− failure "See command line for error message."
121−
122− (ExitSuccess, _) -> success
123−
124−{--
125−pageTitle :: String -> String
126−pageTitle = dropExtension . takeBaseName
127−--}
server/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
server/elm-server.cabaldeleted−41
@@ -1,41 +0,0 @@
1−Name: elm-server
2−Version: 0.11
3−Synopsis: Server for developing Elm projects
4−Description: Provides a standalone Snap server that serves static files.
5− For Elm files, it recompiles them and serves them as HTML,
6− so you can just refresh to see the new version.
7−
8−Homepage: http://elm-lang.org
9−
10−License: BSD3
11−License-file: LICENSE
12−
13−Author: Evan Czaplicki
14−Maintainer: info@elm-lang.org
15−Copyright: Copyright: (c) 2011-2014 Evan Czaplicki
16−
17−Category: Compiler, Language
18−
19−Build-type: Simple
20−
21−--Extra-source-files: README.md
22−Cabal-version: >=1.8
23−
24−source-repository head
25− type: git
26− location: git://github.com/evancz/Elm.git
27−
28−Executable elm-server
29− Main-is: Server.hs
30− Build-depends: base >=4.2 && <5,
31− bytestring,
32− cmdargs,
33− containers >= 0.3,
34− directory,
35− filepath,
36− Elm >= 0.11,
37− snap-core,
38− snap-server,
39− mtl,
40− process,
41− unordered-containers
tests/hs/CompilerTest.hs → tests/compiler/CompilerTest.hsrenamed

The content is the same.

tests/hs/Tests/Compiler.hs → tests/compiler/Tests/Compiler.hsrenamed

The content is the same.

tests/hs/Tests/Property.hs → tests/compiler/Tests/Property.hsrenamed

The content is the same.

tests/hs/Tests/Property/Arbitrary.hs → tests/compiler/Tests/Property/Arbitrary.hsrenamed

The content is the same.

tests/hs/test-files/bad/BBTArgs → tests/compiler/test-files/bad/BBTArgsrenamed

The content is the same.

tests/hs/test-files/bad/InfiniteType.elm → tests/compiler/test-files/bad/InfiniteType.elmrenamed

The content is the same.

tests/hs/test-files/bad/NonElementMain.elm → tests/compiler/test-files/bad/NonElementMain.elmrenamed

The content is the same.

tests/hs/test-files/bad/Strings/ExtraClose.elm → tests/compiler/test-files/bad/Strings/ExtraClose.elmrenamed

The content is the same.

tests/hs/test-files/good/AliasSubstitution.elm → tests/compiler/test-files/good/AliasSubstitution.elmrenamed

The content is the same.

tests/compiler/test-files/good/Box.elmnew file+89
@@ -0,0 +1,89 @@
1+
2+module Box where
3+
4+import Math.Vector3 (..)
5+import Math.Matrix4 (..)
6+import Graphics.WebGL (Triangle, zipTriangle, Shader, Model, model, webgl)
7+import Window(dimensions)
8+
9+-- Create a cube in which each point has a color
10+
11+type ColorPoint = { color:Vec3, point:Vec3 }
12+
13+face : Color -> Vec3 -> Vec3 -> Vec3 -> Vec3 -> [Triangle ColorPoint]
14+face color a b c d =
15+ let toV3 color =
16+ let c = toRgb color
17+ in v3 (toFloat c.red / 255) (toFloat c.green / 255) (toFloat c.blue / 255)
18+ p = ColorPoint (toV3 color)
19+ in
20+ [ (p a, p b, p c), (p c, p d, p a) ]
21+
22+cube : [Triangle ColorPoint]
23+cube =
24+ let rft = v3 1 1 1 -- right, front, top
25+ lft = v3 -1 1 1 -- left, front, top
26+ lbt = v3 -1 -1 1
27+ rbt = v3 1 -1 1
28+ rbb = v3 1 -1 -1
29+ rfb = v3 1 1 -1
30+ lfb = v3 -1 1 -1
31+ lbb = v3 -1 -1 -1
32+ in
33+ concat [ face green rft rfb rbb rbt -- right
34+ , face blue rft rfb lfb lft -- front
35+ , face purple lft lfb lbb lbt -- left
36+ , face orange rbt rbb lbb lbt -- back
37+ ]
38+
39+-- Create the scene
40+
41+main : Signal Element
42+main = webgl (400,400) <~ lift scene angle
43+
44+angle : Signal Float
45+angle = foldp (\dt theta -> theta + dt / 5000) 0 (fps 25)
46+
47+scene : Float -> [Model]
48+scene angle =
49+ [ model vertexShader fragmentShader cube (uniforms angle) ]
50+
51+uniforms : Float -> { rotation:Mat4, perspective:Mat4, camera:Mat4, shade:Float }
52+uniforms t =
53+ { rotation = mul (makeRotate (3*t) (v3 0 1 0)) (makeRotate (2*t) (v3 1 0 0))
54+ , perspective = makePerspective 45 1 0.01 100
55+ , camera = makeLookAt (v3 0 0 5) (v3 0 0 0) (v3 0 1 0)
56+ , shade = 0.8
57+ }
58+
59+-- Shaders
60+
61+vertexShader : Shader { attr | point:Vec3, color:Vec3 }
62+ { unif | rotation:Mat4, perspective:Mat4, camera:Mat4 }
63+ { vcolor:Vec3 }
64+vertexShader = [glShader|
65+
66+attribute vec3 point;
67+attribute vec3 color;
68+uniform mat4 perspective;
69+uniform mat4 camera;
70+uniform mat4 rotation;
71+varying vec3 vcolor;
72+void main () {
73+ gl_Position = perspective * camera * rotation * vec4(point, 1.0);
74+ vcolor = color;
75+}
76+
77+|]
78+
79+fragmentShader : Shader {} { u | shade:Float } { vcolor:Vec3 }
80+fragmentShader = [glShader|
81+
82+precision mediump float;
83+uniform float shade;
84+varying vec3 vcolor;
85+void main () {
86+ gl_FragColor = shade * vec4(vcolor, 1.0);
87+}
88+
89+|]
tests/compiler/test-files/good/Crate.elmnew file+85
@@ -0,0 +1,85 @@
1+
2+module Crate where
3+
4+import Http (..)
5+import Math.Vector2 (Vec2)
6+import Math.Vector3 (..)
7+import Math.Matrix4 (..)
8+import Graphics.WebGL (..)
9+
10+-- Define the mesh for a crate
11+crate : [Triangle { pos:Vec3, coord:Vec3 }]
12+crate = concatMap rotatedFace [ (0,0), (90,0), (180,0), (270,0), (0,90), (0,-90) ]
13+
14+rotatedFace : (Float,Float) -> [Triangle { pos:Vec3, coord:Vec3 }]
15+rotatedFace (angleX,angleY) =
16+ let x = makeRotate (degrees angleX) (v3 1 0 0)
17+ y = makeRotate (degrees angleY) (v3 0 1 0)
18+ t = x `mul` y `mul` makeTranslate (v3 0 0 1)
19+ in
20+ map (mapTriangle (\x -> {x | pos <- mulVec3 t x.pos })) face
21+
22+face : [Triangle { pos:Vec3, coord:Vec3 }]
23+face =
24+ let topLeft = { pos = v3 -1 1 0, coord = v3 0 1 0 }
25+ topRight = { pos = v3 1 1 0, coord = v3 1 1 0 }
26+ bottomLeft = { pos = v3 -1 -1 0, coord = v3 0 0 0 }
27+ bottomRight = { pos = v3 1 -1 0, coord = v3 1 0 0 }
28+ in
29+ [ (topLeft,topRight,bottomLeft), (bottomLeft,topRight,bottomRight) ]
30+
31+-- View
32+view : Float -> Mat4
33+view angle =
34+ foldr1 mul [ perspective
35+ , camera
36+ , makeRotate (3*angle) (v3 0 1 0)
37+ , makeRotate (2*angle) (v3 1 0 0)
38+ ]
39+
40+perspective : Mat4
41+perspective = makePerspective 45 1 0.01 100
42+
43+camera : Mat4
44+camera = makeLookAt (v3 0 0 5) (v3 0 0 0) (v3 0 1 0)
45+
46+-- Putting it together
47+main : Signal Element
48+main = webgl (400,400) <~ lift2 scene (loadTex "woodCrate.jpg") (view <~ angle)
49+
50+angle : Signal Float
51+angle = foldp (\dt theta -> theta + dt / 10000) 0 (fps 25)
52+
53+scene : Response Texture -> Mat4 -> [Model]
54+scene response view =
55+ case response of
56+ Waiting -> []
57+ Failure _ _ -> []
58+ Success tex -> [model vertexShader fragmentShader crate { crate = tex, view = view }]
59+
60+-- Shaders
61+vertexShader : Shader { pos:Vec3, coord:Vec3 } { u | view:Mat4 } { vcoord:Vec2 }
62+vertexShader = [glShader|
63+
64+attribute vec3 pos;
65+attribute vec3 coord;
66+uniform mat4 view;
67+varying vec2 vcoord;
68+void main () {
69+ gl_Position = view * vec4(pos, 1.0);
70+ vcoord = coord.xy;
71+}
72+
73+|]
74+
75+fragmentShader : Shader {} { u | crate:Texture } { vcoord:Vec2 }
76+fragmentShader = [glShader|
77+
78+precision mediump float;
79+uniform sampler2D crate;
80+varying vec2 vcoord;
81+void main () {
82+ gl_FragColor = texture2D(crate, vcoord);
83+}
84+
85+|]
tests/hs/test-files/good/NoExpressions.elm → tests/compiler/test-files/good/NoExpressions.elmrenamed

The content is the same.

tests/hs/test-files/good/Otherwise.elm → tests/compiler/test-files/good/Otherwise.elmrenamed

The content is the same.

tests/hs/test-files/good/Ports.elm → tests/compiler/test-files/good/Ports.elmrenamed

The content is the same.

tests/hs/test-files/good/QuotesAndComments.elm → tests/compiler/test-files/good/QuotesAndComments.elmrenamed

The content is the same.

tests/hs/test-files/good/Soundness/Apply.elm → tests/compiler/test-files/good/Soundness/Apply.elmrenamed

The content is the same.

tests/hs/test-files/good/Soundness/ApplyAnnotated.elm → tests/compiler/test-files/good/Soundness/ApplyAnnotated.elmrenamed

The content is the same.

tests/hs/test-files/good/Soundness/Id.elm → tests/compiler/test-files/good/Soundness/Id.elmrenamed

The content is the same.

tests/hs/test-files/good/Soundness/IdAnnotated.elm → tests/compiler/test-files/good/Soundness/IdAnnotated.elmrenamed

The content is the same.

tests/hs/test-files/good/Soundness/TrickyId.elm → tests/compiler/test-files/good/Soundness/TrickyId.elmrenamed

The content is the same.

tests/hs/test-files/good/Soundness/TrickyIdAnnotated.elm → tests/compiler/test-files/good/Soundness/TrickyIdAnnotated.elmrenamed

The content is the same.

tests/hs/test-files/good/Strings/Multiline.elm → tests/compiler/test-files/good/Strings/Multiline.elmrenamed

The content is the same.

tests/hs/test-files/good/Strings/MultilineNormal.elm → tests/compiler/test-files/good/Strings/MultilineNormal.elmrenamed

The content is the same.

tests/hs/test-files/good/Unify/LockedVars.elm → tests/compiler/test-files/good/Unify/LockedVars.elmrenamed

The content is the same.

tests/hs/test-files/good/Unify/NonHomogeneousRecords.elm → tests/compiler/test-files/good/Unify/NonHomogeneousRecords.elmrenamed

The content is the same.

tests/compiler/test-files/good/woodCrate.JPGnew file

Binary file not shown.

tests/elm/Test/String.elmdeleted−26
@@ -1,26 +0,0 @@
1−module Test.String (tests) where
2−
3−import List
4−import String (..)
5−
6−import ElmTest.Assertion (..)
7−import ElmTest.Test (..)
8−
9−tests : [Test]
10−tests =
11− let isEmptyTests = [test "empty is empty" <| assert <| isEmpty "",
12− test "not empty" <| assert <| not . isEmpty <| "the world"]
13− lengthTest = test "length of innumerable" <| assertEqual 11 (length "innumerable")
14− reverseTest = test "reverse test" <| assertEqual "desserts" (reverse "stressed")
15− repeatTest = test "repeat test" <| assertEqual "hahaha" (repeat 3 "ha")
16− unconsTests = [test "nonempty uncons" <| assertEqual (Just ('a',"bc")) (uncons "abc"),
17− test "empty uncons" <| assertEqual Nothing (uncons "")]
18− appendTest = test "append test" <| assertEqual "butterfly" (append "butter" "fly")
19− concatTest = test "concat test" <| assertEqual "nevertheless" (concat ["never","the","less"])
20− splitTests = [test "split commas" <| assertEqual ["cat","dog","cow"] (split "," "cat,dog,cow"),
21− test "split slashes"<| assertEqual ["home","evan","Desktop", ""] (split "/" "home/evan/Desktop/")]
22− joinTests = [test "join spaces" <| assertEqual "cat dog cow" (join " " ["cat","dog","cow"]),
23− test "join slashes" <| assertEqual "home/evan/Desktop" (join "/" ["home","evan","Desktop"])]
24−
25− endsWithTest = test "endsWith Check" (assert <| endsWith "h" "th")
26− in List.concat [isEmptyTests, [lengthTest, reverseTest, repeatTest], unconsTests, [appendTest, concatTest], splitTests, joinTests, [endsWithTest]]
tests/hs/LibTest.hsdeleted−27
@@ -1,27 +0,0 @@
1−module Main where
2−
3−import System.Directory
4−import System.Exit
5−import System.FilePath
6−import System.Process
7−
8−import Elm.Internal.Paths as Elm
9−
10−main :: IO ()
11−main = do
12− top <- getCurrentDirectory
13− let ioScript s = top</>"IO"</>s
14− runCmd "git submodule init"
15− runCmd "npm install jsdom"
16− setCurrentDirectory $ top</>"tests"</>"elm"
17− runCmd $ concat [top</>"dist"</>"build"</>"elm"</>"elm --make --only-js --src-dir=" , top</>"automaton", " --src-dir=", top</>"IO", " --src-dir=", top</>"Elm-Test", " Test.elm"]
18− runCmd $ unwords ["cat ", ioScript "prescript.js", Elm.runtime, "build"</>"Test.js", ioScript "handler.js", "> exe.js"]
19− exitWith =<< waitForProcess =<< (runCommand "node exe.js")
20− where runCmd cmd = do
21− putStrLn cmd
22− exitCode <- waitForProcess =<< runCommand cmd
23− case exitCode of
24− ExitSuccess -> return ()
25− ExitFailure _ -> error "something went wrong"
26−
27−
tests/libraries/LibraryTest.hsnew file+49
@@ -0,0 +1,49 @@
1+module Main where
2+
3+import Control.Monad (unless)
4+import Data.List (isInfixOf)
5+import System.Directory
6+import System.Exit
7+import System.FilePath
8+import System.Process
9+
10+import Elm.Internal.Paths as Elm
11+
12+main :: IO ()
13+main = do
14+ top <- getCurrentDirectory
15+
16+ -- setup submodules and npm
17+ runCmd "git" ["submodule", "update", "--init"]
18+ out <- readProcess "npm" ["ls", "--parseable"] ""
19+ unless ("jsdom" `isInfixOf` out) $ runCmd "npm" ["install","jsdom"]
20+
21+ -- setup actual library tests
22+ setCurrentDirectory $ top </> "tests" </> "libraries"
23+ let localCompiler = joinPath [ top, "dist", "build", "elm", "elm" ]
24+ runCmd localCompiler [ "--make"
25+ , "--only-js"
26+ , "--src-dir=" ++ top </> "automaton"
27+ , "--src-dir=" ++ top </> "IO"
28+ , "--src-dir=" ++ top </> "Elm-Test"
29+ , "Test.elm"
30+ ]
31+
32+ -- run tests
33+ let ioScript s = top </> "IO" </> s
34+ files = [ ioScript "prescript.js"
35+ , Elm.runtime
36+ , "build" </> "Test.js"
37+ , ioScript "handler.js"
38+ ]
39+ exe <- readProcess "cat" files ""
40+ writeFile "exe.js" exe
41+ exitWith =<< waitForProcess =<< (runCommand "node exe.js")
42+
43+runCmd :: String -> [String] -> IO ()
44+runCmd cmd args = do
45+ putStrLn (cmd ++ " " ++ unwords args)
46+ (exitCode, _stdout, stderr) <- readProcessWithExitCode cmd args ""
47+ case exitCode of
48+ ExitSuccess -> return ()
49+ ExitFailure _ -> error stderr
tests/elm/Test.elm → tests/libraries/Test.elmrenamed+16−3
@@ -9,11 +9,24 @@ import IO.IO (..)
9import IO.Runner (Request, Response)
9import IO.Runner (Request, Response)
10import IO.Runner as Run
10import IO.Runner as Run
11
11
12+import Test.Array as Array
13+import Test.Dict as Dict
14+import Test.Equality as Equality
15+import Test.List as List
16+import Test.Set as Set
12import Test.String as String
17import Test.String as String
13import Test.Trampoline as Trampoline
18import Test.Trampoline as Trampoline
14−
19+
15−tests : [Test]
20+tests : Test
21+tests = suite "Elm Standard Library Tests"
22+ [ Array.tests
23+ , Dict.tests
24+ , Equality.tests
25+ , List.tests
26+ , Set.tests
27+ , String.tests
16−tests = String.tests ++ Trampoline.tests
28+ , Trampoline.tests
29+ ]
17
30
18console : IO ()
31console : IO ()
19console = runDisplay tests
32console = runDisplay tests
tests/libraries/Test/Array.elmnew file+63
@@ -0,0 +1,63 @@
1+module Test.Array (tests) where
2+
3+import List
4+import Array
5+import Native.Array
6+
7+import ElmTest.Assertion (..)
8+import ElmTest.Test (..)
9+
10+tests : Test
11+tests =
12+ let creationTests = suite "Creation"
13+ [ test "empty" <| assertEqual Array.empty (Array.fromList [])
14+ , test "initialize" <| assertEqual (Array.initialize 4 id) (Array.fromList [0,1,2,3])
15+ , test "initialize 2" <| assertEqual (Array.initialize 4 (\n -> n*n)) (Array.fromList [0,1,4,9])
16+ , test "initialize 3" <| assertEqual (Array.initialize 4 (always 0)) (Array.fromList [0,0,0,0])
17+ , test "initialize Empty" <| assertEqual (Array.initialize 0 id) Array.empty
18+ , test "initialize 4" <| assertEqual (Array.initialize 2 (always 0)) (Array.fromList [0,0])
19+ , test "repeat" <| assertEqual (Array.repeat 5 40) (Array.fromList [40,40,40,40,40])
20+ , test "repeat 2" <| assertEqual (Array.repeat 5 0) (Array.fromList [0,0,0,0,0])
21+ , test "repeat 3" <| assertEqual (Array.repeat 3 "cat") (Array.fromList ["cat","cat","cat"])
22+ , test "fromList" <| assertEqual (Array.fromList []) Array.empty
23+ ]
24+ basicsTests = suite "Basics"
25+ [ test "length" <| assertEqual 3 (Array.length (Array.fromList [1,2,3]))
26+ , test "length - Long" <| assertEqual 10000 (Array.length (Array.repeat 10000 0))
27+ , test "push" <| assertEqual (Array.fromList [1,2,3]) (Array.push 3 (Array.fromList [1,2]))
28+ , test "append" <| assertEqual [42,42,81,81,81] (Array.toList (Array.append (Array.repeat 2 42) (Array.repeat 3 81)))
29+ ]
30+ getAndSetTests = suite "Get and Set"
31+ [ test "get" <| assertEqual (Just 2) (Array.get 1 (Array.fromList [3,2,1]))
32+ , test "get 2" <| assertEqual Nothing (Array.get 5 (Array.fromList [3,2,1]))
33+ , test "get 3" <| assertEqual Nothing (Array.get -1 (Array.fromList [3,2,1]))
34+ , test "getOrElse 1" <| assertEqual 1 (Array.getOrElse 0 2 (Array.fromList [3,2,1]))
35+ , test "getOrElse 2" <| assertEqual 0 (Array.getOrElse 0 5 (Array.fromList [3,2,1]))
36+ , test "getOrFail" <| assertEqual 1 (Array.getOrFail 2 (Array.fromList [3,2,1]))
37+ , test "set" <| assertEqual (Array.fromList [1,7,3]) (Array.set 1 7 (Array.fromList [1,2,3]))
38+ ]
39+ takingArraysApartTests = suite "Taking Arrays Apart"
40+ [ test "toList" <| assertEqual [3,5,8] (Array.toList (Array.fromList [3,5,8]))
41+ , test "toIndexedList" <| assertEqual [(0,"cat"), (1,"dog")] (Array.toIndexedList (Array.fromList ["cat","dog"]))
42+ , test "slice 1" <| assertEqual (Array.fromList [0,1,2]) (Array.slice 0 3 (Array.fromList [0,1,2,3,4]))
43+ , test "slice 2" <| assertEqual (Array.fromList [1,2,3]) (Array.slice 1 4 (Array.fromList [0,1,2,3,4]))
44+ , test "slice 3" <| assertEqual (Array.fromList [1,2,3]) (Array.slice 1 -1 (Array.fromList [0,1,2,3,4]))
45+ , test "slice 4" <| assertEqual (Array.fromList [2]) (Array.slice -3 -2 (Array.fromList [0,1,2,3,4]))
46+ ]
47+ mappingAndFoldingTests = suite "Mapping and Folding"
48+ [ test "map" <| assertEqual (Array.fromList [1,2,3]) (Array.map sqrt (Array.fromList [1,4,9]))
49+ , test "indexedMap 1" <| assertEqual (Array.fromList [0,5,10]) (Array.indexedMap (*) (Array.fromList [5,5,5]))
50+ , test "indexedMap 2" <| assertEqual [0..99] (Array.toList (Array.indexedMap always (Array.repeat 100 0)))
51+ , test "foldl" <| assertEqual [3,2,1] (Array.foldl (::) [] (Array.fromList [1,2,3]))
52+ , test "foldr 1" <| assertEqual 15 (Array.foldr (+) 0 (Array.repeat 3 5))
53+ , test "foldr 2" <| assertEqual [1,2,3] (Array.foldr (::) [] (Array.fromList [1,2,3]))
54+ , test "filter" <| assertEqual (Array.fromList [2,4,6]) (Array.filter (\x -> x `mod` 2 == 0) (Array.fromList [1..6]))
55+ ]
56+ nativeTests = suite "Conversion to JS Arrays"
57+ [ test "jsArrays" <| assertEqual (Array.fromList [1..1100]) (Native.Array.fromJSArray (Native.Array.toJSArray (Array.fromList [1..1100])))
58+ ]
59+ in
60+ suite "Array"
61+ [ creationTests, basicsTests, getAndSetTests
62+ , takingArraysApartTests, mappingAndFoldingTests, nativeTests
63+ ]
tests/libraries/Test/Dict.elmnew file+26
@@ -0,0 +1,26 @@
1+module Test.Dict (tests) where
2+
3+import Dict
4+import List
5+
6+import ElmTest.Assertion (..)
7+import ElmTest.Test (..)
8+
9+animals : Dict.Dict String String
10+animals = Dict.fromList [ ("Tom", "cat"), ("Jerry", "mouse") ]
11+
12+tests : Test
13+tests =
14+ let getTests =
15+ [ test "get 1" <| assertEqual (Just "cat") (Dict.get "Tom" animals)
16+ , test "get 2" <| assertEqual Nothing (Dict.get "Spike" animals)
17+ , test "getOrElse 1" <| assertEqual "mouse" (Dict.getOrElse "dog" "Jerry" animals)
18+ , test "getOrElse 2" <| assertEqual "dog" (Dict.getOrElse "dog" "Spike" animals)
19+ , test "getOrFail" <| assertEqual "cat" (Dict.getOrFail "Tom" animals)
20+ ]
21+ filterTests =
22+ [ test "filter" <| assertEqual (Dict.singleton "Tom" "cat") (Dict.filter (\k v -> k == "Tom") animals)
23+ , test "partition" <| assertEqual (Dict.singleton "Tom" "cat", Dict.singleton "Jerry" "mouse") (Dict.partition (\k v -> k == "Tom") animals)
24+ ]
25+ in
26+ suite "Dict Tests" <| List.concat [ getTests, filterTests ]
tests/libraries/Test/Equality.elmnew file+23
@@ -0,0 +1,23 @@
1+module Test.Equality (tests) where
2+
3+import ElmTest.Assertion (..)
4+import ElmTest.Test (..)
5+
6+data Different = A String
7+ | B [Int]
8+
9+tests : Test
10+tests =
11+ let diffTests = suite "ADT equality"
12+ [ test "As eq" <| assert (A "a" == A "a")
13+ , test "Bs eq" <| assert (B [1] == B [1])
14+ , test "A left neq" <| assert . not <| (A "a" == B [1])
15+ , test "A left neq" <| assert . not <| (B [1] == A "a")
16+ ]
17+ recordTests = suite "Record equality"
18+ [ test "empty same" <| assert ({} == {})
19+ , test "ctor same" <| assert ({ctor = Just 3} == {ctor = Just 3})
20+ , test "ctor diff" . assert . not <| ({ctor = Just 3} == {ctor = Nothing})
21+ ]
22+ in
23+ suite "Equality Tests" [diffTests, recordTests]
tests/libraries/Test/List.elmnew file+38
@@ -0,0 +1,38 @@
1+module Test.List (tests) where
2+
3+import List
4+
5+import ElmTest.Assertion (..)
6+import ElmTest.Test (..)
7+
8+tests : Test
9+tests =
10+ let partitionTests =
11+ let p1 = id
12+ p2 x = x < 3
13+ isEven n = n `mod` 2 == 0
14+ in suite "partition Tests" [ test "simple partition" <| assertEqual ([True],[False]) (List.partition p1 [False, True]),
15+ test "order check" <| assertEqual ([2,1], [5,6]) (List.partition p2 [2,5,6,1]),
16+ test "partition doc check 1" <| assertEqual ([0,1,2], [3,4,5]) (partition p2 [0..5]),
17+ test "partition doc check 2" <| assertEqual ([0,2,4], [1,3,5]) (partition isEven [0..5]),
18+ let n = 100000
19+ ts = repeat n True
20+ fs = repeat n False
21+ in test "partition stress test" <| assertEqual (ts, fs) (partition p1 (fs++ts))
22+ ]
23+ unzipTests = suite "unzip Tests" [
24+ test "unzip doc check" <| assertEqual ([0,17,1337],[True,False,True]) (unzip [(0, True), (17, False), (1337, True)]),
25+ let n = 100000
26+ ts = repeat n True
27+ fs = repeat n False
28+ in test "unzip stress test" <| assertEqual (ts, fs) (unzip (zip ts fs))
29+ ]
30+ intersperseTests = suite "intersperse Tests" [
31+ test "intersperse doc check" <| assertEqual ["turtles","on","turtles","on","turtles"] (intersperse "on" ["turtles","turtles","turtles"]),
32+ let n = 100000
33+ ts = repeat n True
34+ fs = repeat n False
35+ in test "intersperse stress test" <| assertEqual (tail . List.concat <| zipWith (\x y -> [x,y]) fs ts)
36+ (intersperse False ts)
37+ ]
38+ in suite "List Tests" [partitionTests, unzipTests, intersperseTests]
tests/libraries/Test/Set.elmnew file+27
@@ -0,0 +1,27 @@
1+module Test.Set (tests) where
2+
3+import Set
4+import Set (Set)
5+import List
6+
7+import ElmTest.Assertion (..)
8+import ElmTest.Test (..)
9+
10+set : Set Int
11+set = Set.fromList [1..100]
12+
13+setPart1 : Set Int
14+setPart1 = Set.fromList [1..50]
15+
16+setPart2 : Set Int
17+setPart2 = Set.fromList [51..100]
18+
19+pred : Int -> Bool
20+pred x = x <= 50
21+
22+tests : Test
23+tests =
24+ let
25+ filterTests = suite "filter Tests" [test "Simple filter" <| assertEqual setPart1 <| Set.filter pred set]
26+ partitionTests = suite "partition Tests" [test "Simple partition" <| assertEqual (setPart1, setPart2) <| Set.partition pred set]
27+ in suite "Set Tests" [partitionTests, filterTests]
tests/libraries/Test/String.elmnew file+37
@@ -0,0 +1,37 @@
1+module Test.String (tests) where
2+
3+import List
4+import String (..)
5+
6+import ElmTest.Assertion (..)
7+import ElmTest.Test (..)
8+
9+tests : Test
10+tests =
11+ let simpleTests = suite "Simple Stuff"
12+ [ test "is empty" <| assert (isEmpty "")
13+ , test "is not empty" <| assert (not (isEmpty ("the world")))
14+ , test "length" <| assertEqual 11 (length "innumerable")
15+ , test "endsWith" (assert <| endsWith "ship" "spaceship")
16+ , test "reverse" <| assertEqual "desserts" (reverse "stressed")
17+ , test "repeat" <| assertEqual "hahaha" (repeat 3 "ha")
18+ ]
19+
20+ combiningTests = suite "Combining Strings"
21+ [ test "uncons non-empty" <| assertEqual (Just ('a',"bc")) (uncons "abc")
22+ , test "uncons empty" <| assertEqual Nothing (uncons "")
23+ , test "append 1" <| assertEqual "butterfly" (append "butter" "fly")
24+ , test "append 2" <| assertEqual "butter" (append "butter" "")
25+ , test "append 3" <| assertEqual "butter" (append "" "butter")
26+ , test "concat" <| assertEqual "nevertheless" (concat ["never","the","less"])
27+ , test "split commas" <| assertEqual ["cat","dog","cow"] (split "," "cat,dog,cow")
28+ , test "split slashes"<| assertEqual ["home","steve","Desktop", ""] (split "/" "home/steve/Desktop/")
29+ , test "join spaces" <| assertEqual "cat dog cow" (join " " ["cat","dog","cow"])
30+ , test "join slashes" <| assertEqual "home/steve/Desktop" (join "/" ["home","steve","Desktop"])
31+ , test "slice 1" <| assertEqual "c" (slice 2 3 "abcd")
32+ , test "slice 2" <| assertEqual "abc" (slice 0 3 "abcd")
33+ , test "slice 3" <| assertEqual "abc" (slice 0 -1 "abcd")
34+ , test "slice 4" <| assertEqual "cd" (slice -2 4 "abcd")
35+ ]
36+ in
37+ suite "String" [ simpleTests, combiningTests ]
tests/elm/Test/Trampoline.elm → tests/libraries/Test/Trampoline.elmrenamed+3−3
@@ -21,9 +21,9 @@ goodSum n =
21 _ -> Continue (\_ -> sumT (x-1) (acc+x))
21 _ -> Continue (\_ -> sumT (x-1) (acc+x))
22 in trampoline <| sumT n 0
22 in trampoline <| sumT n 0
23
23
24−tests : [Test]
24+tests : Test
25tests =
25tests =
26 let mkLoopCheck n = test ("Equivalent Loop Check #"++ show n) (assertEqual (badSum n) (goodSum n))
26 let mkLoopCheck n = test ("Equivalent Loop Check #"++ show n) (assertEqual (badSum n) (goodSum n))
27− loopChecks = map mkLoopCheck [0..25]
27+ loopChecks = suite "Equivalent to untrampolined Tests" <| map mkLoopCheck [0..25]
28 noStackOverflow = test "Trampoline Deep Recursion Test" (assertEqual 500000500000 (goodSum 1000000))
28 noStackOverflow = test "Trampoline Deep Recursion Test" (assertEqual 500000500000 (goodSum 1000000))
29− in noStackOverflow :: loopChecks
29+ in suite "Trampoline Tests" [noStackOverflow, loopChecks]