on master help sign in
Merge branch 'master' into stable
commit3ecb9fd8eaf689c284d97f1ec393b066ea5c5c02 authorEvan Czaplicki <info@elm-lang.org> dateThu 15 May 2014, 22:24 (12 years ago) parent8506512d35d6c8
74 files changed+885−372
.gitignore+4−4 .travis.yml+31−3 Elm.cabal+21−9 compiler/Build/Dependencies.hs+67−42 compiler/Build/Flags.hs+7−4 compiler/Build/Print.hs+9−1 compiler/Build/Utils.hs+9 compiler/Compiler.hs+16−10 compiler/Elm/Internal/Dependencies.hs+39−37 compiler/Elm/Internal/Utils.hs+10−3 compiler/Generate/JavaScript.hs+5−1 compiler/Generate/JavaScript/Ports.hs+15−8 compiler/Parse/Expression.hs+7−1 compiler/Parse/Helpers.hs+54−5 compiler/SourceSyntax/Expression.hs+3 compiler/SourceSyntax/Literal.hs+22 compiler/Transform/Canonicalize.hs+1 compiler/Transform/Expression.hs+1 compiler/Transform/SafeNames.hs+1 compiler/Transform/SortDefinitions.hs+2 compiler/Transform/Substitute.hs+1 compiler/Type/Constrain/Expression.hs+17 compiler/Type/ExtraChecks.hs+2−3 libraries/Color.elm+186−88 libraries/Native/Array.js+7−1 libraries/Native/Bitwise.js+1−1 libraries/Native/Color.js+16−60 libraries/Native/Error.js+2−4 libraries/Native/Graphics/Input.js+1−1 libraries/Native/Json.js+1−1 libraries/Native/List.js+13−1 libraries/Native/Regex.js+2−2 libraries/Native/String.js+2−2 libraries/Native/Text.js+3−3 libraries/Native/Utils.js+10−1 runtime/Render/Collage.js+4−4 runtime/Render/Element.js+33−27 runtime/Render/Utils.js+2−7 tests/hs/CompilerTest.hs → tests/compiler/CompilerTest.hs tests/hs/Tests/Compiler.hs → tests/compiler/Tests/Compiler.hs tests/hs/Tests/Property.hs → tests/compiler/Tests/Property.hs tests/hs/Tests/Property/Arbitrary.hs → tests/compiler/Tests/Property/Arbitrary.hs tests/hs/test-files/bad/BBTArgs → tests/compiler/test-files/bad/BBTArgs tests/hs/test-files/bad/InfiniteType.elm → tests/compiler/test-files/bad/InfiniteType.elm tests/hs/test-files/bad/NonElementMain.elm → tests/compiler/test-files/bad/NonElementMain.elm tests/hs/test-files/bad/Strings/ExtraClose.elm → tests/compiler/test-files/bad/Strings/ExtraClose.elm tests/hs/test-files/good/AliasSubstitution.elm → tests/compiler/test-files/good/AliasSubstitution.elm tests/compiler/test-files/good/Box.elm+89 tests/compiler/test-files/good/Crate.elm+85 tests/hs/test-files/good/NoExpressions.elm → tests/compiler/test-files/good/NoExpressions.elm tests/hs/test-files/good/Otherwise.elm → tests/compiler/test-files/good/Otherwise.elm tests/hs/test-files/good/Ports.elm → tests/compiler/test-files/good/Ports.elm tests/hs/test-files/good/QuotesAndComments.elm → tests/compiler/test-files/good/QuotesAndComments.elm tests/hs/test-files/good/Soundness/Apply.elm → tests/compiler/test-files/good/Soundness/Apply.elm tests/hs/test-files/good/Soundness/ApplyAnnotated.elm → tests/compiler/test-files/good/Soundness/ApplyAnnotated.elm tests/hs/test-files/good/Soundness/Id.elm → tests/compiler/test-files/good/Soundness/Id.elm tests/hs/test-files/good/Soundness/IdAnnotated.elm → tests/compiler/test-files/good/Soundness/IdAnnotated.elm tests/hs/test-files/good/Soundness/TrickyId.elm → tests/compiler/test-files/good/Soundness/TrickyId.elm tests/hs/test-files/good/Soundness/TrickyIdAnnotated.elm → tests/compiler/test-files/good/Soundness/TrickyIdAnnotated.elm tests/hs/test-files/good/Strings/Multiline.elm → tests/compiler/test-files/good/Strings/Multiline.elm tests/hs/test-files/good/Strings/MultilineNormal.elm → tests/compiler/test-files/good/Strings/MultilineNormal.elm tests/hs/test-files/good/Unify/LockedVars.elm → tests/compiler/test-files/good/Unify/LockedVars.elm tests/hs/test-files/good/Unify/NonHomogeneousRecords.elm → tests/compiler/test-files/good/Unify/NonHomogeneousRecords.elm tests/compiler/test-files/good/woodCrate.JPG tests/hs/LibTest.hs−30 tests/libraries/LibraryTest.hs+49 tests/elm/Test.elm → tests/libraries/Test.elm+10−7 tests/elm/Test/Array.elm → tests/libraries/Test/Array.elm+2−1 tests/elm/Test/Dict.elm → tests/libraries/Test/Dict.elm tests/libraries/Test/Equality.elm+23 tests/elm/Test/List.elm → tests/libraries/Test/List.elm tests/elm/Test/Set.elm → tests/libraries/Test/Set.elm tests/elm/Test/String.elm → tests/libraries/Test/String.elm tests/elm/Test/Trampoline.elm → tests/libraries/Test/Trampoline.elm
.gitignore+4−4
@@ -10,8 +10,8 @@ cabal-dev
1010data
1111*/ElmFiles/*
1212.DS_Store
13+build
14+cache
1315*~
14−tests/elm/build/
15−tests/elm/cache/
16−tests/elm/exe.js
17−node_modules/
16+exe.js
17+node_modules/
.travis.yml+31−3
@@ -1,3 +1,31 @@
1−language: haskell
2−ghc:
3− - 7.6
1+# Based on https://github.com/hvr/multi-ghc-travis and https://github.com/ekmett/lens/blob/master/.travis.yml
2+
3+# NB: don't set `language: haskell` here
4+
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+21−9
@@ -1,5 +1,5 @@
11Name: Elm
2−Version: 0.12.1.3
2+Version: 0.12.2
33Synopsis: The Elm language module.
44Description: Elm aims to make client-side web-development more pleasant.
55 It is a statically/strongly typed, functional reactive
@@ -107,14 +107,17 @@ Library
107107 filepath,
108108 indents,
109109 language-ecmascript >=0.15 && < 1.0,
110+ language-glsl,
110111 mtl >= 2,
111112 pandoc >= 1.10,
112113 parsec >= 3.1.1,
113114 pretty,
115+ scientific,
114116 text,
115117 transformers >= 0.2,
116118 union-find,
117− unordered-containers
119+ unordered-containers,
120+ yaml
118121
119122Executable elm
120123 Main-is: Compiler.hs
@@ -190,14 +193,17 @@ Executable elm
190193 filepath,
191194 indents,
192195 language-ecmascript >=0.15 && < 1.0,
196+ language-glsl,
193197 mtl >= 2,
194198 pandoc >= 1.10,
195199 parsec >= 3.1.1,
200+ scientific,
196201 pretty,
197202 text,
198203 transformers >= 0.2,
199204 union-find,
200− unordered-containers
205+ unordered-containers,
206+ yaml
201207
202208Executable elm-doc
203209 Main-is: Docs.hs
@@ -231,16 +237,19 @@ Executable elm-doc
231237 directory,
232238 filepath,
233239 indents,
240+ language-glsl,
234241 mtl >= 2,
235242 pandoc >= 1.10,
236243 parsec >= 3.1.1,
237244 pretty,
245+ scientific,
238246 text,
239− union-find
247+ union-find,
248+ yaml
240249
241250Test-Suite compiler-tests
242251 Type: exitcode-stdio-1.0
243− Hs-Source-Dirs: tests/hs, compiler
252+ Hs-Source-Dirs: tests/compiler, compiler
244253 Main-is: CompilerTest.hs
245254 other-modules: Tests.Compiler
246255 Tests.Property
@@ -268,19 +277,22 @@ Test-Suite compiler-tests
268277 filepath,
269278 indents,
270279 language-ecmascript >=0.15 && < 1.0,
280+ language-glsl,
271281 mtl >= 2,
272282 pandoc >= 1.10,
273283 parsec >= 3.1.1,
274284 pretty,
285+ scientific,
275286 text,
276287 transformers >= 0.2,
277288 union-find,
278− unordered-containers
289+ unordered-containers,
290+ yaml
279291
280−Test-Suite lib-tests
292+Test-Suite library-tests
281293 Type: exitcode-stdio-1.0
282− Hs-Source-Dirs: tests/hs
283− Main-is: LibTest.hs
294+ Hs-Source-Dirs: tests/libraries
295+ Main-is: LibraryTest.hs
284296 build-depends: base,
285297 directory,
286298 Elm,
compiler/Build/Dependencies.hs+67−42
@@ -1,55 +1,57 @@
11{-# OPTIONS_GHC -W #-}
2−module Build.Dependencies (getSortedDependencies, readDeps) where
2+module Build.Dependencies (Recipe(..), getBuildRecipe, readDeps) where
33
4−import Control.Applicative
54import Control.Monad.Error
65import qualified Control.Monad.State as State
7−import qualified Data.Aeson as Json
8−import qualified Data.ByteString.Lazy.Char8 as BSC
96import qualified Data.Graph as Graph
107import qualified Data.List as List
118import qualified Data.Map as Map
12−import qualified Data.Maybe as Maybe
139import qualified Data.Set as Set
1410import System.Directory
1511import System.FilePath as FP
1612
17−import Build.Print (failure)
18−
1913import qualified SourceSyntax.Module as Module
2014import qualified Parse.Parse as Parse
2115import qualified Elm.Internal.Paths as Path
2216import qualified Elm.Internal.Name as N
17+import qualified Elm.Internal.Version as V
2318import qualified Elm.Internal.Dependencies as Deps
2419
25−getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [String]
26−getSortedDependencies srcDirs builtIns root =
27− do extras <- extraDependencies
28− let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras
29− result <- runErrorT $ readAllDeps allSrcDirs builtIns root
30− case result of
31− Right deps -> sortDeps deps
32− Left err -> failure err
33−
34−extraDependencies :: IO (Maybe [FilePath])
35−extraDependencies =
36− do exists <- doesFileExist Path.dependencyFile
37− if not exists then return Nothing else Just <$> getPaths
20+data Recipe = Recipe
21+ { _elmFiles :: [FilePath]
22+ , _jsFiles :: [FilePath]
23+ }
24+
25+getBuildRecipe :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO Recipe
26+getBuildRecipe srcDirs builtIns root =
27+ do directories <- getDependencies
28+ jsFiles <- nativeFiles ("." : directories)
29+ let allSrcDirs = srcDirs ++ directories
30+ nodes <- collectDependencies allSrcDirs builtIns root
31+ elmFiles <- sortElmFiles nodes
32+ return (Recipe elmFiles jsFiles)
33+
34+-- | Based on the projects elm_dependencies.json, find all of the paths and
35+-- dependency information we might need.
36+getDependencies :: ErrorT String IO [FilePath]
37+getDependencies =
38+ do exists <- liftIO $ doesFileExist Path.dependencyFile
39+ if not exists then return [] else getPaths
3840 where
39− getPaths = do
40− raw <- BSC.readFile Path.dependencyFile
41− case Json.eitherDecode raw of
42− Right (Deps.Mini deps) -> mapM validate deps
43− Left err ->
44− failure $ "Error reading the " ++ Path.dependencyFile ++ " file:\n" ++ err
45−
46− validate (name,version) = do
47− let path = Path.dependencyDirectory </> toPath name version
48− exists <- doesDirectoryExist path
49− if exists then return path else failure (notFound name version)
50−
51− toPath name version = N.toFilePath name </> show version
52−
41+ getPaths :: ErrorT String IO [FilePath]
42+ getPaths =
43+ Deps.withDeps Path.dependencyFile $ \deps ->
44+ mapM getPath (Deps.dependencies deps)
45+
46+ getPath :: (N.Name, V.Version) -> ErrorT String IO FilePath
47+ getPath (name,version) = do
48+ let path = Path.dependencyDirectory </> N.toFilePath name </> show version
49+ exists <- liftIO $ doesDirectoryExist path
50+ if exists
51+ then return path
52+ else throwError (notFound name version)
53+
54+ notFound :: N.Name -> V.Version -> String
5355 notFound name version =
5456 unlines
5557 [ "Your " ++ Path.dependencyFile ++ " file says you depend on library"
@@ -58,27 +60,50 @@ extraDependencies =
5860 , ""
5961 , " elm-get install " ++ show name ++ " " ++ show version ]
6062
61−type Deps = (FilePath, String, [String])
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+
85+type DependencyNode = (FilePath, String, [String])
6286
63−sortDeps :: [Deps] -> IO [String]
64−sortDeps depends =
87+sortElmFiles :: [DependencyNode] -> ErrorT String IO [FilePath]
88+sortElmFiles depends =
6589 if null mistakes
6690 then return (concat sccs)
67− else failure $ msg ++ unlines (map show mistakes)
91+ else throwError $ msg ++ unlines (map show mistakes)
6892 where
6993 sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends
7094
7195 mistakes = filter (\scc -> length scc > 1) sccs
7296 msg = "A cyclical module dependency or was detected in:\n"
7397
74−readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
75−readAllDeps srcDirs rawBuiltIns filePath =
98+collectDependencies :: [FilePath] -> Module.Interfaces -> FilePath
99+ -> ErrorT String IO [DependencyNode]
100+collectDependencies srcDirs rawBuiltIns filePath =
76101 State.evalStateT (go Nothing filePath) Set.empty
77102 where
78103 builtIns :: Set.Set String
79104 builtIns = Set.fromList $ Map.keys rawBuiltIns
80105
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]
82107 go parentModuleName filePath = do
83108 filePath' <- lift $ findSrcFile parentModuleName srcDirs filePath
84109 (moduleName, deps) <- lift $ readDeps filePath'
@@ -93,9 +118,9 @@ readDeps :: FilePath -> ErrorT String IO (String, [String])
93118readDeps path = do
94119 txt <- lift $ readFile path
95120 case Parse.dependencies txt of
121+ Right o -> return o
96122 Left err -> throwError $ msg ++ show err
97123 where msg = "Error resolving dependencies in " ++ path ++ ":\n"
98− Right o -> return o
99124
100125findSrcFile :: Maybe String -> [FilePath] -> FilePath -> ErrorT String IO FilePath
101126findSrcFile parentModuleName dirs path =
compiler/Build/Flags.hs+7−4
@@ -7,7 +7,8 @@ import System.Console.CmdArgs
77data Flags = Flags
88 { make :: Bool
99 , files :: [FilePath]
10− , runtime :: Maybe FilePath
10+ , set_runtime :: Maybe FilePath
11+ , get_runtime :: Bool
1112 , only_js :: Bool
1213 , print_types :: Bool
1314 , scripts :: [FilePath]
@@ -28,8 +29,10 @@ flags = Flags
2829 &= help "Do not import Prelude by default, used only when compiling standard libraries."
2930 , scripts = [] &= typFile
3031 &= help "Load JavaScript files in generated HTML. Files will be included in the given order."
31− , runtime = Nothing &= typFile
32− &= help "Specify a custom location for Elm's runtime system."
32+ , set_runtime = Nothing &= typFile
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."
3336 , cache_dir = "cache" &= typFile
3437 &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."
3538 , build_dir = "build" &= typFile
@@ -37,7 +40,7 @@ flags = Flags
3740 , src_dir = ["."] &= typFile
3841 &= help "Additional source directories besides project root. Searched when using --make"
3942 , print_types = False
40− &= help "Print out infered types of top-level definitions."
43+ &= help "Print out inferred types of top-level definitions."
4144 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."
4245 &= helpArg [explicit, name "help", name "h"]
4346 &= versionArg [explicit, name "version", name "v", summary (show Version.elmVersion)]
compiler/Build/Print.hs+9−1
@@ -5,6 +5,7 @@ import System.Exit (exitFailure)
55
66import qualified Data.Map as Map
77import qualified Data.List as List
8+import qualified SourceSyntax.Type as T
89import qualified SourceSyntax.Module as M
910import qualified SourceSyntax.PrettyPrint as Pretty
1011import qualified Type.Alias as Alias
@@ -18,6 +19,11 @@ interfaceTypes :: Map.Map String M.ModuleInterface -> M.ModuleInterface -> IO ()
1819interfaceTypes interfaces iface =
1920 types interfaces (M.iTypes iface) (M.iAliases iface) (M.iImports iface)
2021
22+types :: Map.Map k M.ModuleInterface
23+ -> Map.Map String T.Type
24+ -> [M.Alias]
25+ -> [(String, M.ImportMethod)]
26+ -> IO ()
2127types interfaces types' aliases imports =
2228 do putStrLn ""
2329 mapM_ printType (Map.toList types')
@@ -35,4 +41,6 @@ errors errs =
3541 mapM_ print (List.intersperse (P.text " ") errs)
3642
3743failure :: String -> IO a
38−failure msg = hPutStrLn stderr msg >> exitFailure
44+failure msg =
45+ do hPutStrLn stderr msg
46+ exitFailure
compiler/Build/Utils.hs+9
@@ -1,10 +1,12 @@
11{-# OPTIONS_GHC -W #-}
22module Build.Utils where
33
4+import Control.Monad.Error
45import System.Directory (doesFileExist)
56import System.Environment (getEnv)
67import System.FilePath ((</>), replaceExtension)
78import qualified Build.Flags as Flag
9+import qualified Build.Print as Print
810import qualified Paths_Elm as This
911
1012buildPath :: Flag.Flags -> FilePath -> String -> FilePath
@@ -33,3 +35,10 @@ getDataFile name = do
3335 else do
3436 env <- getEnv "ELM_HOME"
3537 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 @@
11{-# OPTIONS_GHC -W #-}
22module Main where
33
4−import Control.Monad (foldM)
4+import Control.Monad (foldM, when)
55import qualified Data.Maybe as Maybe
66import Text.Blaze.Html.Renderer.String (renderHtml)
77import qualified Data.ByteString.Lazy.Char8 as BS
88import qualified System.Console.CmdArgs as CmdArgs
99import System.Directory
10+import System.Exit (exitSuccess)
1011import System.FilePath
1112import GHC.Conc
1213
13−import Build.Dependencies (getSortedDependencies)
14+import Build.Dependencies (getBuildRecipe, Recipe(..))
1415import qualified Generate.Html as Html
1516import qualified Metadata.Prelude as Prelude
1617import qualified Build.Utils as Utils
@@ -24,7 +25,10 @@ main = do setNumCapabilities =<< getNumProcessors
2425
2526compileArgs :: Flag.Flags -> IO ()
2627compileArgs flags =
27− case Flag.files flags of
28+ do when (Flag.get_runtime flags) $
29+ do putStrLn Path.runtime
30+ exitSuccess
31+ case Flag.files flags of
2832 [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
2933 fs -> mapM_ (build flags) fs
3034
@@ -33,13 +37,15 @@ build flags rootFile =
3337 do let noPrelude = Flag.no_prelude flags
3438 builtIns <- Prelude.interfaces noPrelude
3539
36− files <- if Flag.make flags
37− then getSortedDependencies (Flag.src_dir flags) builtIns rootFile
38− else return [rootFile]
40+ (Recipe elmFiles jsFiles) <-
41+ if Flag.make flags
42+ then Utils.run (getBuildRecipe (Flag.src_dir flags) builtIns rootFile)
43+ else return (Recipe [rootFile] [])
3944
40− moduleName <- File.build flags builtIns files
45+ moduleName <- File.build flags builtIns elmFiles
4146
42− js <- foldM appendToOutput BS.empty files
47+ let elmos = map (Utils.elmo flags) elmFiles
48+ js <- foldM appendToOutput BS.empty (elmos ++ jsFiles)
4349
4450 (extension, code) <-
4551 if Flag.only_js flags
@@ -56,12 +62,12 @@ build flags rootFile =
5662 where
5763 appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString
5864 appendToOutput js filePath = do
59− src <- BS.readFile (Utils.elmo flags filePath)
65+ src <- BS.readFile filePath
6066 return (BS.append src js)
6167
6268 sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ]
6369
6470 makeHtml js moduleName = ("html", BS.pack $ renderHtml html)
6571 where
66− rtsPath = Maybe.fromMaybe Path.runtime (Flag.runtime flags)
72+ rtsPath = Maybe.fromMaybe Path.runtime (Flag.set_runtime flags)
6773 html = Html.generate rtsPath (takeBaseName rootFile) (sources js) moduleName ""
compiler/Elm/Internal/Dependencies.hs+39−37
@@ -2,10 +2,13 @@
22module Elm.Internal.Dependencies where
33
44import Control.Applicative
5+import Control.Arrow (first)
56import Control.Monad.Error
67import qualified Control.Exception as E
78import Data.Aeson
9+import Data.Aeson.Types (Parser)
810import Data.Aeson.Encode.Pretty
11+import Data.Maybe (fromMaybe)
912import qualified Data.List as List
1013import qualified Data.ByteString.Lazy as BS
1114import qualified Data.HashMap.Strict as Map
@@ -23,33 +26,28 @@ data Deps = Deps
2326 , license :: String
2427 , repo :: String
2528 , exposed :: [String]
29+ , native :: [String]
2630 , elmVersion :: V.Version
2731 , dependencies :: [(N.Name,V.Version)]
2832 } deriving (Show, Eq, Ord)
2933
30−data MiniDeps = Mini [(N.Name,V.Version)]
31− deriving (Show, Eq, Ord)
32−
33−instance ToJSON MiniDeps where
34− toJSON (Mini m) = toJSON m
35−
36−instance FromJSON MiniDeps where
37− parseJSON (Object obj) = Mini <$> getDependencies obj
38− parseJSON _ = mzero
39−
4034instance ToJSON Deps where
41− toJSON d = object [
42− "version" .= version d,
43− "summary" .= summary d,
44− "description" .= description d,
45− "license" .= license d,
46− "repository" .= repo d,
47− "exposed-modules" .= exposed d,
48− "elm-version" .= elmVersion d,
49− "dependencies" .= (jsonDeps . dependencies $ d)
50− ]
51− where jsonDeps = Map.fromList . map (mapFst (T.pack . show))
52− mapFst f (a,b) = (f a, b)
35+ toJSON d =
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 ]
5351
5452instance FromJSON Deps where
5553 parseJSON (Object obj) =
@@ -69,15 +67,18 @@ instance FromJSON Deps where
6967 Right nm -> return nm
7068
7169 exposed <- get obj "exposed-modules" "a list of modules exposed to users"
70+
71+ native <- fromMaybe [] <$> (obj .:? "native-modules")
7272
7373 elmVersion <- get obj "elm-version" "the version of the Elm compiler you are using"
7474
7575 deps <- getDependencies obj
7676
77− return $ Deps name version summary desc license repo exposed elmVersion deps
77+ return $ Deps name version summary desc license repo exposed native elmVersion deps
7878
7979 parseJSON _ = mzero
8080
81+getDependencies :: Object -> Parser [(N.Name, V.Version)]
8182getDependencies obj =
8283 toDeps =<< get obj "dependencies" "a listing of your project's dependencies"
8384 where
@@ -88,7 +89,7 @@ getDependencies obj =
8889 (Nothing, _) -> fail $ N.errorMsg f
8990 (_, Nothing) -> fail $ "invalid version number " ++ v
9091
91−
92+get :: FromJSON a => Object -> T.Text -> String -> Parser a
9293get obj field desc =
9394 do maybe <- obj .:? field
9495 case maybe of
@@ -117,12 +118,12 @@ repoToName repo
117118 \like <https://github.com/USER/PROJECT.git> where USER is your GitHub name\n\
118119 \and PROJECT is the repo you want to upload."
119120
120−withDeps :: (Deps -> a) -> FilePath -> ErrorT String IO a
121−withDeps handle path =
121+withDeps :: FilePath -> (Deps -> ErrorT String IO a) -> ErrorT String IO a
122+withDeps path handle =
122123 do json <- readPath
123124 case eitherDecode json of
124125 Left err -> throwError $ "Error reading file " ++ path ++ ":\n " ++ err
125− Right ds -> return (handle ds)
126+ Right ds -> handle ds
126127 where
127128 readPath :: ErrorT String IO BS.ByteString
128129 readPath = do
@@ -136,19 +137,20 @@ withDeps handle path =
136137 " <https://github.com/evancz/automaton/blob/master/elm_dependencies.json>"
137138
138139depsAt :: FilePath -> ErrorT String IO Deps
139−depsAt = withDeps id
140+depsAt filePath = withDeps filePath return
140141
141142-- | Encode dependencies in a canonical JSON format
142143prettyJSON :: Deps -> BS.ByteString
143144prettyJSON = encodePretty' config
144145 where config = defConfig { confCompare = order }
145− order = keyOrder [ "name",
146− "version",
147− "summary",
148− "description",
149− "license",
150− "repo",
151− "exposed-modules",
152− "elm-version",
153− "dependencies"
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"
154156 ]
compiler/Elm/Internal/Utils.hs+10−3
@@ -1,11 +1,12 @@
11{- | This module exports functions for compiling Elm to JS.
22-}
3−module Elm.Internal.Utils (compile, moduleName) where
3+module Elm.Internal.Utils (compile, moduleName, nameAndImports) where
44
55import qualified Data.List as List
66import qualified Generate.JavaScript as JS
77import qualified Build.Source as Source
8−import qualified Parse.Module as Parser
8+import Parse.Module (getModuleName)
9+import Parse.Parse (dependencies)
910import qualified SourceSyntax.Module as M
1011import qualified Text.PrettyPrint as P
1112import qualified Metadata.Prelude as Prelude
@@ -25,4 +26,10 @@ interfaces = unsafePerformIO $ Prelude.interfaces False
2526
2627-- |This function extracts the module name of a given source program.
2728moduleName :: 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 =
3434
3535internalImports :: String -> Statement ()
3636internalImports name =
37− VarDeclStmt ()
37+ VarDeclStmt ()
3838 [ varDecl "_N" (obj "Elm.Native")
3939 , include "_U" "_N.Utils"
4040 , include "_L" "_N.List"
41+ , include "_A" "_N.Array"
4142 , include "_E" "_N.Error"
4243 , varDecl "$moduleName" (string name)
4344 ]
@@ -179,6 +180,9 @@ expression (A region expr) =
179180 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
180181 md = pad ++ MD.toHtml doc ++ pad
181182
183+ GLShader _uid src _tipe ->
184+ return $ ObjectLit () [(PropString () "src", literal (Str src))]
185+
182186 PortIn name tipe ->
183187 return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
184188
compiler/Generate/JavaScript/Ports.hs+15−8
@@ -38,7 +38,7 @@ inc tipe x =
3838
3939 Data "Json.Value" [] ->
4040 obj "Native.Json.fromJS" <| x
41−
41+
4242 Data ctor []
4343 | ctor == "Int" -> from JSNumber
4444 | ctor == "Float" -> from JSNumber
@@ -55,8 +55,12 @@ inc tipe x =
5555
5656 | ctor == "_List" ->
5757 check x JSArray (obj "_L.fromArray" <| array)
58− where
59− array = DotRef () x (var "map") <| incoming t
58+
59+ | ctor == "Array.Array" ->
60+ check x JSArray (obj "_A.fromJSArray" <| array)
61+
62+ where
63+ array = DotRef () x (var "map") <| incoming t
6064
6165 Data ctor ts
6266 | Help.isTuple ctor -> check x JSArray tuple
@@ -67,10 +71,10 @@ inc tipe x =
6771 , inc t (BracketRef () x (IntLit () n)))
6872
6973 Data _ _ ->
70− error "bad ADT got to port generation code"
74+ error "bad ADT got to incoming port generation code"
7175
7276 Record _ (Just _) ->
73− error "bad record got to port generation code"
77+ error "bad record got to incoming port generation code"
7478
7579 Record fields Nothing ->
7680 check x (JSObject (map fst fields)) object
@@ -117,16 +121,19 @@ out tipe x =
117121 | ctor == "_List" ->
118122 DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t
119123
124+ | ctor == "Array.Array" ->
125+ DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t
126+
120127 Data ctor ts
121128 | Help.isTuple ctor ->
122129 let convert n t = out t $ DotRef () x $ var ('_':show n)
123130 in ArrayLit () $ zipWith convert [0..] ts
124−
131+
125132 Data _ _ ->
126− error "bad ADT got to port generation code"
133+ error "bad ADT got to outgoing port generation code"
127134
128135 Record _ (Just _) ->
129− error "bad record got to port generation code"
136+ error "bad record got to outgoing port generation code"
130137
131138 Record fields Nothing ->
132139 ObjectLit () keys
compiler/Parse/Expression.hs+7−1
@@ -44,7 +44,7 @@ negative = do
4444-------- Complex Terms --------
4545
4646listTerm :: IParser ParseExpr'
47−listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
47+listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> commaSep expr)
4848 where
4949 range = do
5050 lo <- expr
@@ -57,6 +57,12 @@ listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
5757 (rawText, exprs) <- markdown (interpolation uid)
5858 return (Markdown uid (filter (/='\r') rawText) exprs)
5959
60+ glShader' = do
61+ pos <- getPosition
62+ let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
63+ (rawSrc, tipe) <- glShader
64+ return $ GLShader uid (filter (/='\r') rawSrc) tipe
65+
6066 span uid index =
6167 "<span id=\"md-" ++ uid ++ "-" ++ show index ++ "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"
6268
compiler/Parse/Helpers.hs+54−5
@@ -8,6 +8,8 @@ import Control.Monad.State
88import Data.Char (isUpper)
99import qualified Data.Set as Set
1010import qualified Data.Map as Map
11+import qualified Language.GLSL.Parser as GLP
12+import Language.GLSL.Syntax as GLS
1113import Text.Parsec hiding (newline,spaces,State)
1214import Text.Parsec.Indent
1315import qualified Text.Parsec.Token as T
@@ -16,6 +18,7 @@ import SourceSyntax.Annotation as Annotation
1618import SourceSyntax.Declaration (Assoc)
1719import SourceSyntax.Expression
1820import SourceSyntax.Helpers as Help
21+import SourceSyntax.Literal as Literal
1922import SourceSyntax.PrettyPrint
2023import SourceSyntax.Variable as Variable
2124
@@ -308,16 +311,62 @@ anyUntilPos pos = go
308311 False -> (:) <$> anyChar <*> go
309312
310313markdown :: ([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 []
312317 where
313− closeMarkdown md stuff =
318+ closeMarkdown markdownBuilder stuff =
314319 choice [ do try (string "|]")
315− return (md "", stuff)
316− , (\(m,s) -> closeMarkdown (md . (m ++)) s) =<< interpolation stuff
320+ return (markdownBuilder "", stuff)
321+ , do (markdown,stuff') <- interpolation stuff
322+ closeMarkdown (markdownBuilder . (markdown++)) stuff'
317323 , do c <- anyChar
318− closeMarkdown (md . ([c]++)) stuff
324+ closeMarkdown (markdownBuilder . (c:)) stuff
319325 ]
320326
327+glShader :: IParser (String, Literal.GLShaderTipe)
328+glShader =
329+ do try (string "[glShader|")
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+
321370--str :: IParser String
322371str = expecting "String" $ do
323372 s <- choice [ multiStr, singleStr ]
compiler/SourceSyntax/Expression.hs+3
@@ -58,6 +58,7 @@ data GeneralExpr' ann def var
5858 -- for type checking and code gen only
5959 | PortIn String SrcType.Type
6060 | PortOut String SrcType.Type (GeneralExpr ann def var)
61+ | GLShader String String Literal.GLShaderTipe
6162 deriving (Show)
6263
6364
@@ -178,6 +179,8 @@ instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where
178179
179180 Markdown _ _ _ -> P.text "[markdown| ... |]"
180181
182+ GLShader _ _ _ -> P.text "[glShader| ... |]"
183+
181184 PortIn name _ -> P.text $ "<port:" ++ name ++ ">"
182185
183186 PortOut _ _ signal -> pretty signal
compiler/SourceSyntax/Literal.hs+22
@@ -1,6 +1,7 @@
11{-# OPTIONS_GHC -Wall #-}
22module SourceSyntax.Literal where
33
4+import Data.Map (Map)
45import SourceSyntax.PrettyPrint
56import qualified Text.PrettyPrint as PP
67
@@ -19,3 +20,24 @@ instance Pretty Literal where
1920 Chr c -> PP.text . show $ c
2021 Str s -> PP.text . show $ s
2122 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) =
178178
179179 PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
180180
181+ GLShader _ _ _ -> return expr
181182
182183renamePattern :: Env -> P.Pattern -> Either String P.Pattern
183184renamePattern env pattern =
compiler/Transform/Expression.hs+1
@@ -49,6 +49,7 @@ crawl portInCheck portOutCheck defsTransform = go
4949 Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields
5050 Markdown uid md es -> Markdown uid md <$> mapM go es
5151 Let defs body -> Let <$> defsTransform defs <*> go body
52+ GLShader uid src gltipe -> return $ GLShader uid src gltipe
5253 PortIn name st ->
5354 do portInCheck name st
5455 return $ PortIn name st
compiler/Transform/SafeNames.hs+1
@@ -54,6 +54,7 @@ expression (A ann expr) =
5454 Modify r fs -> Modify (f r) (map (var *** f) fs)
5555 Record fs -> Record (map (var *** f) fs)
5656 Markdown uid md es -> Markdown uid md (map f es)
57+ GLShader _ _ _ -> expr
5758 PortIn name st -> PortIn name st
5859 PortOut name st signal -> PortOut name st (f signal)
5960
compiler/Transform/SortDefinitions.hs+2
@@ -84,6 +84,8 @@ reorder (A ann expr) =
8484
8585 Markdown uid md es -> Markdown uid md <$> mapM reorder es
8686
87+ GLShader _ _ _ -> return expr
88+
8789 PortOut name st signal -> PortOut name st <$> reorder signal
8890
8991 PortIn name st -> return $ PortIn name st
compiler/Transform/Substitute.hs+1
@@ -40,5 +40,6 @@ subst old new expr =
4040 Record fs -> Record (map (second f) fs)
4141 Literal _ -> expr
4242 Markdown uid md es -> Markdown uid md (map f es)
43+ GLShader _ _ _ -> expr
4344 PortIn name st -> PortIn name st
4445 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
88import qualified Data.Map as Map
99import qualified Text.PrettyPrint as PP
1010
11+import SourceSyntax.Literal as Lit
1112import SourceSyntax.Annotation as Ann
1213import SourceSyntax.Expression
1314import qualified SourceSyntax.Pattern as P
@@ -31,6 +32,22 @@ constrain env (A region expr) tipe =
3132 case expr of
3233 Literal lit -> liftIO $ Literal.constrain env region lit tipe
3334
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+
3451 Var (V.Raw name)
3552 | name == saveEnvName -> return (A region CSaveEnv)
3653 | otherwise -> return (name <? tipe)
compiler/Type/ExtraChecks.hs+2−3
@@ -60,8 +60,7 @@ portTypes rules expr =
6060 | otherwise -> err' True "an unsupported type"
6161 where
6262 primitives =
63− ["Int","Float","String","Bool","Maybe.Maybe","_List","Json.Value"]
64−
63+ ["Int","Float","String","Bool","Maybe.Maybe","_List","Array.Array","Json.Value"]
6564 validConstructor =
6665 ctor `elem` primitives || Help.isTuple ctor
6766
@@ -102,7 +101,7 @@ portTypes rules expr =
102101 , txt [ "It contains ", kind, ":\n" ]
103102 , (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"
104103 , 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," ]
106105 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
107106 ] ++ if couldBeAlias then aliasWarning else []
108107
libraries/Color.elm+186−88
@@ -2,18 +2,18 @@ module Color where
22
33{-| Library for working with colors. Includes
44[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
66built-in names.
77
88# Creation
9−@docs rgb, rgba, hsv, hsva, greyscale, grayscale
10−
11−# From Other Colors
12−@docs complement
9+@docs rgb, rgba, hsl, hsla, greyscale, grayscale, complement
1310
1411# Gradients
1512@docs linear, radial
1613
14+# Extracting Colors
15+@docs toRgb, toHsl
16+
1717# Built-in Colors
1818These colors come from the [Tango
1919palette](http://tango.freedesktop.org/Tango_Icon_Theme_Guidelines)
@@ -24,12 +24,10 @@ comes with a light and dark version.
2424@docs red, orange, yellow, green, blue, purple, brown
2525
2626### Light
27−@docs lightRed, lightOrange, lightYellow, lightGreen, lightBlue, lightPurple,
28− lightBrown
27+@docs lightRed, lightOrange, lightYellow, lightGreen, lightBlue, lightPurple, lightBrown
2928
3029### Dark
31−@docs darkRed, darkOrange, darkYellow, darkGreen, darkBlue, darkPurple,
32− darkBrown
30+@docs darkRed, darkOrange, darkYellow, darkGreen, darkBlue, darkPurple, darkBrown
3331
3432### Eight Shades of Grey
3533These 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.
4240
4341-}
4442
45−import Native.Color
46−import Basics ((-))
43+import Basics (..)
4744
48−data Color = Color Int Int Int Float
45+data Color
46+ = RGBA Int Int Int Float
47+ | HSLA Float Float Float Float
4948
5049{-| Create RGB colors with an alpha component for transparency.
5150The alpha component is specified with numbers between 0 and 1. -}
5251rgba : Int -> Int -> Int -> Float -> Color
53−rgba = Color
52+rgba = RGBA
5453
5554{-| Create RGB colors from numbers between 0 and 255 inclusive. -}
5655rgb : 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
58198
59199lightRed : Color
60−lightRed = Color 239 41 41 1
200+lightRed = RGBA 239 41 41 1
61201red : Color
62−red = Color 204 0 0 1
202+red = RGBA 204 0 0 1
63203darkRed : Color
64−darkRed = Color 164 0 0 1
204+darkRed = RGBA 164 0 0 1
65205
66206lightOrange : Color
67−lightOrange = Color 252 175 62 1
207+lightOrange = RGBA 252 175 62 1
68208orange : Color
69−orange = Color 245 121 0 1
209+orange = RGBA 245 121 0 1
70210darkOrange : Color
71−darkOrange = Color 206 92 0 1
211+darkOrange = RGBA 206 92 0 1
72212
73213lightYellow : Color
74−lightYellow = Color 255 233 79 1
214+lightYellow = RGBA 255 233 79 1
75215yellow : Color
76−yellow = Color 237 212 0 1
216+yellow = RGBA 237 212 0 1
77217darkYellow : Color
78−darkYellow = Color 196 160 0 1
218+darkYellow = RGBA 196 160 0 1
79219
80220lightGreen : Color
81−lightGreen = Color 138 226 52 1
221+lightGreen = RGBA 138 226 52 1
82222green : Color
83−green = Color 115 210 22 1
223+green = RGBA 115 210 22 1
84224darkGreen : Color
85−darkGreen = Color 78 154 6 1
225+darkGreen = RGBA 78 154 6 1
86226
87227lightBlue : Color
88−lightBlue = Color 114 159 207 1
228+lightBlue = RGBA 114 159 207 1
89229blue : Color
90−blue = Color 52 101 164 1
230+blue = RGBA 52 101 164 1
91231darkBlue : Color
92−darkBlue = Color 32 74 135 1
232+darkBlue = RGBA 32 74 135 1
93233
94234lightPurple : Color
95−lightPurple = Color 173 127 168 1
235+lightPurple = RGBA 173 127 168 1
96236purple : Color
97−purple = Color 117 80 123 1
237+purple = RGBA 117 80 123 1
98238darkPurple : Color
99−darkPurple = Color 92 53 102 1
239+darkPurple = RGBA 92 53 102 1
100240
101241lightBrown : Color
102−lightBrown = Color 233 185 110 1
242+lightBrown = RGBA 233 185 110 1
103243brown : Color
104−brown = Color 193 125 17 1
244+brown = RGBA 193 125 17 1
105245darkBrown : Color
106−darkBrown = Color 143 89 2 1
246+darkBrown = RGBA 143 89 2 1
107247
108248black : Color
109−black = Color 0 0 0 1
249+black = RGBA 0 0 0 1
110250white : Color
111−white = Color 255 255 255 1
251+white = RGBA 255 255 255 1
112252
113253lightGrey : Color
114−lightGrey = Color 238 238 236 1
254+lightGrey = RGBA 238 238 236 1
115255grey : Color
116−grey = Color 211 215 207 1
256+grey = RGBA 211 215 207 1
117257darkGrey : Color
118−darkGrey = Color 186 189 182 1
258+darkGrey = RGBA 186 189 182 1
119259
120260lightGray : Color
121−lightGray = Color 238 238 236 1
261+lightGray = RGBA 238 238 236 1
122262gray : Color
123−gray = Color 211 215 207 1
263+gray = RGBA 211 215 207 1
124264darkGray : Color
125−darkGray = Color 186 189 182 1
265+darkGray = RGBA 186 189 182 1
126266
127267lightCharcoal : Color
128−lightCharcoal = Color 136 138 133 1
268+lightCharcoal = RGBA 136 138 133 1
129269charcoal : Color
130−charcoal = Color 85 87 83 1
270+charcoal = RGBA 85 87 83 1
131271darkCharcoal : Color
132−darkCharcoal = Color 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
272+darkCharcoal = RGBA 46 52 54 1
libraries/Native/Array.js+7−1
@@ -240,10 +240,16 @@ Elm.Native.Array.make = function(elm) {
240240
241241 // Maps a function over the elements with their index as first argument.
242242 function indexedMap(f, a) {
243+ return indexedMap_(f, a, 0);
244+ }
245+
246+ function indexedMap_(f, a, from) {
243247 var newA = { ctor:"_Array", height:a.height, table:new Array(a.table) };
244248 if (a.height > 0) { newA.lengths = a.lengths; }
245249 for (var i = 0; i < a.table.length; i++) {
246− newA.table[i] = a.height == 0 ? A2(f, i, a.table[i]) : indexedMap(f, a.table[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]);
247253 }
248254 return newA;
249255 }
libraries/Native/Bitwise.js+1−1
@@ -19,7 +19,7 @@ Elm.Native.Bitwise.make = function(elm) {
1919 complement: not,
2020 shiftLeft : F2(sll),
2121 shiftRightArithmatic: F2(sra),
22− shiftRightLogical : F2(srl),
22+ shiftRightLogical : F2(srl)
2323 };
2424
2525};
libraries/Native/Color.js+16−60
@@ -7,69 +7,25 @@ Elm.Native.Color.make = function(elm) {
77 var Utils = Elm.Native.Utils.make(elm);
88
99 function toCss(c) {
10− return (c._3 === 1)
11− ? ('rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')')
12− : ('rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')');
13− }
14−
15− function complement(rgb) {
16− var hsv = toHSV(rgb);
17− hsv.hue = (hsv.hue + 180) % 360;
18− return toRGB(hsv);
19− }
20−
21− function hsva(h,s,v,a) {
22− var degree = A2(Utils.mod, h * 180 / Math.PI, 360);
23− var clr = toRGB({hue:degree, saturation:s, value:v});
24− clr._3 = a;
25− return clr;
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 };
10+ var format = '';
11+ var colors = '';
12+ if (c.ctor === 'RGBA') {
13+ format = 'rgb';
14+ colors = c._0 + ', ' + c._1 + ', ' + c._2;
15+ } else {
16+ format = 'hsl';
17+ colors = (c._0 * 180 / Math.PI) + ', ' +
18+ (c._1 * 100) + '%, ' +
19+ (c._2 * 100) + '%';
20+ }
21+ if (c._3 === 1) {
22+ return format + '(' + colors + ')';
23+ } else {
24+ return format + 'a(' + colors + ', ' + c._3 + ')';
25+ }
6726 }
6827
6928 return elm.Native.Color.values = {
70− hsva:F4(hsva),
71− hsv:F3(hsv),
72− complement:complement,
7329 toCss:toCss
7430 };
7531
libraries/Native/Error.js+2−4
@@ -4,8 +4,6 @@ Elm.Native.Error.make = function(elm) {
44 elm.Native.Error = elm.Native.Error || {};
55 if (elm.Native.Error.values) return elm.Native.Error.values;
66
7− var fromString = Elm.Native.JavaScript.make(elm).fromString;
8−
97 function indent(lines) {
108 var msg = '';
119 for (var i = 0; i < lines.length; ++i) {
@@ -26,7 +24,7 @@ Elm.Native.Error.make = function(elm) {
2624 throw new Error('Runtime error in module ' + moduleName + ' (' + span + '):' + msg);
2725 }
2826
29− function raise(str) { throw new Error(fromString(str)); }
27+ function raise(str) { throw new Error(str); }
3028
3129 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) {
286286 start: start,
287287 end: end,
288288 direction: { ctor: direction }
289− },
289+ }
290290 }));
291291 }
292292
libraries/Native/Json.js+1−1
@@ -79,7 +79,7 @@ Elm.Native.Json.make = function(elm) {
7979 toString : F2(toString),
8080 fromString : fromString,
8181 fromJS : fromJS,
82− toJS : toJS,
82+ toJS : toJS
8383 };
8484
8585};
libraries/Native/List.js+13−1
@@ -289,6 +289,16 @@ Elm.Native.List.make = function(elm) {
289289 return fromArray(out);
290290 }
291291
292+ /*
293+ * Only to be used internally; do some side effects for each elem
294+ */
295+ function each(action, xs) {
296+ while(xs.ctor !== '[]') {
297+ action(xs._0);
298+ xs = xs._1;
299+ }
300+ }
301+
292302 Elm.Native.List.values = {
293303 Nil:Nil,
294304 Cons:Cons,
@@ -328,7 +338,9 @@ Elm.Native.List.make = function(elm) {
328338 drop:F2(drop),
329339 repeat:F2(repeat),
330340
331− join:F2(join)
341+ join:F2(join),
342+
343+ each:each
332344 };
333345 return elm.Native.List.values = Elm.Native.List.values;
334346
libraries/Native/Regex.js+2−2
@@ -43,7 +43,7 @@ Elm.Native.Regex.make = function(elm) {
4343 match: result[0],
4444 submatches: List.fromArray(subs),
4545 index: result.index,
46− number: number,
46+ number: number
4747 });
4848 }
4949 return List.fromArray(out);
@@ -98,6 +98,6 @@ Elm.Native.Regex.make = function(elm) {
9898 contains: F2(contains),
9999 find: F3(find),
100100 replace: F4(replace),
101− split: F3(split),
101+ split: F3(split)
102102 };
103103};
libraries/Native/String.js+2−2
@@ -111,7 +111,7 @@ Elm.Native.String.make = function(elm) {
111111 }
112112
113113 function words(str) {
114− return List.fromArray(str.split(/\s+/g));
114+ return List.fromArray(str.trim().split(/\s+/g));
115115 }
116116 function lines(str) {
117117 return List.fromArray(str.split(/\r\n|\r|\n/g));
@@ -247,6 +247,6 @@ Elm.Native.String.make = function(elm) {
247247 toInt: toInt,
248248 toFloat: toFloat,
249249 toList: toList,
250− fromList: fromList,
250+ fromList: fromList
251251 };
252252};
libraries/Native/Text.js+3−3
@@ -123,7 +123,7 @@ Elm.Native.Text.make = function(elm) {
123123 html : Utils.makeText(text),
124124 align: align,
125125 guid : null,
126− args : [],
126+ args : []
127127 };
128128 var pos = A2(Utils.htmlHeight, 0, raw);
129129 return A3(Element.newElement, pos._0, pos._1, raw);
@@ -136,7 +136,7 @@ Elm.Native.Text.make = function(elm) {
136136 html: text,
137137 align: null,
138138 guid: guid,
139− args: [],
139+ args: []
140140 };
141141 var pos = A2(Utils.htmlHeight, 0, raw);
142142 return A3(Element.newElement, pos._0, pos._1, raw);
@@ -162,6 +162,6 @@ Elm.Native.Text.make = function(elm) {
162162 markdown : markdown,
163163
164164 toTypefaces:toTypefaces,
165− toLine:toLine,
165+ toLine:toLine
166166 };
167167};
libraries/Native/Utils.js+10−1
@@ -16,7 +16,16 @@ Elm.Native.Utils.make = function(elm) {
1616 var c = 0;
1717 for (var i in x) {
1818 ++c;
19− stack.push({ 'x': x[i], 'y': y[i] });
19+ if (i in y) {
20+ if (i !== 'ctor') {
21+ stack.push({ 'x': x[i], 'y': y[i] });
22+ }
23+ } else {
24+ return false;
25+ }
26+ }
27+ if ('ctor' in x) {
28+ stack.push({'x': x.ctor, 'y': y.ctor});
2029 }
2130 if (c !== Object.keys(y).length) {
2231 return false;
runtime/Render/Collage.js+4−4
@@ -5,7 +5,7 @@ var Render = ElmRuntime.use(ElmRuntime.Render.Element);
55var Transform = Elm.Transform2D.make({});
66var Utils = ElmRuntime.use(ElmRuntime.Render.Utils);
77var newElement = Utils.newElement,
8− extract = Utils.extract, fromList = Utils.fromList,
8+ colorToCss = Utils.colorToCss, fromList = Utils.fromList,
99 fromString = Utils.fromString, addTransform = Utils.addTransform;
1010
1111function trace(ctx, path) {
@@ -70,7 +70,7 @@ function drawLine(ctx, style, path) {
7070 ctx.lineJoin = join === 'Smooth' ? 'round' :
7171 join === 'Sharp' ? 'miter' : 'bevel';
7272 ctx.miterLimit = style.join._0 || 10;
73− ctx.strokeStyle = extract(style.color);
73+ ctx.strokeStyle = colorToCss(style.color);
7474 return line(ctx, style, path);
7575}
7676
@@ -96,7 +96,7 @@ function gradient(ctx, grad) {
9696 var len = stops.length;
9797 for (var i = 0; i < len; ++i) {
9898 var stop = stops[i];
99− g.addColorStop(stop._0, extract(stop._1));
99+ g.addColorStop(stop._0, colorToCss(stop._1));
100100 }
101101 return g;
102102}
@@ -105,7 +105,7 @@ function drawShape(redo, ctx, style, path) {
105105 trace(ctx, path);
106106 var sty = style.ctor;
107107 ctx.fillStyle =
108− sty === 'Solid' ? extract(style._0) :
108+ sty === 'Solid' ? colorToCss(style._0) :
109109 sty === 'Texture' ? texture(redo, ctx, style._0) : gradient(ctx, style._0);
110110 ctx.scale(1,-1);
111111 ctx.fill();
runtime/Render/Element.js+33−27
@@ -3,7 +3,7 @@ ElmRuntime.Render.Element = function() {
33'use strict';
44
55var Utils = ElmRuntime.use(ElmRuntime.Render.Utils);
6−var newElement = Utils.newElement, extract = Utils.extract,
6+var newElement = Utils.newElement, colorToCss = Utils.colorToCss,
77 addTransform = Utils.addTransform, removeTransform = Utils.removeTransform,
88 fromList = Utils.fromList, eq = Utils.eq;
99
@@ -18,7 +18,7 @@ function setProps(elem, e) {
1818 e.style.opacity = props.opacity;
1919 }
2020 if (props.color.ctor === 'Just') {
21− e.style.backgroundColor = extract(props.color._0);
21+ e.style.backgroundColor = colorToCss(props.color._0);
2222 }
2323 if (props.tag !== '') { e.id = props.tag; }
2424 if (props.href !== '') {
@@ -143,29 +143,37 @@ function croppedImage(elem, w, h, src) {
143143 return e;
144144}
145145
146−function goIn(e) { e.style.position = 'absolute'; return e; }
146+function goOut(e) { e.style.position = 'absolute'; return e; }
147147function goDown(e) { return e }
148148function 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';
152149
153− for (var i = array.length; i--; ) {
154− container.appendChild(f(render(array[i])));
155− }
156− return container;
150+var directionTable = {
151+ DUp : goDown,
152+ DDown : goDown,
153+ DLeft : goRight,
154+ DRight : goRight,
155+ DIn : goOut,
156+ DOut : goOut
157+};
158+function needsReversal(dir) {
159+ return dir == 'DUp' || dir == 'DLeft' || dir == 'DIn';
157160}
158161
159162function flow(dir,elist) {
160163 var array = fromList(elist);
161− switch(dir.ctor) {
162− case "DDown": array.reverse();
163− case "DUp": return flowWith(goDown,array);
164− case "DRight": array.reverse();
165− case "DLeft": return flowWith(goRight,array);
166− case "DOut": array.reverse();
167− case "DIn": return flowWith(goIn,array);
164+ var container = newElement('div');
165+ var goDir = directionTable[dir];
166+ if (goDir == goOut) {
167+ container.style.pointerEvents = 'none';
168168 }
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;
169177}
170178
171179function toPos(pos) {
@@ -245,7 +253,7 @@ function makeElement(e) {
245253 var elem = e.element;
246254 switch(elem.ctor) {
247255 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);
249257 case 'Container': return container(elem._0, elem._1);
250258 case 'Spacer': return newElement('div');
251259 case 'RawHtml': return rawHtml(elem);
@@ -321,14 +329,12 @@ function update(node, curr, next) {
321329 return true;
322330 }
323331 var currs = fromList(currE._1);
324− var goDir = function(x) { return x; };
325− switch(nextE._0.ctor) {
326− case "DDown": case "DUp": goDir = goDown; break;
327− case "DRight": case "DLeft": goDir = goRight; break;
328− case "DOut": case "DIn": goDir = goIn; break;
329− }
330− for (var i = kids.length; i-- ;) {
331− update(kids[i],currs[i],nexts[i]);
332+ var dir = nextE._0.ctor;
333+ var goDir = directionTable[dir];
334+ var toReverse = needsReversal(dir);
335+ var len = kids.length;
336+ for (var i = len; i-- ;) {
337+ update(kids[toReverse ? len - i - 1 : i],currs[i],nexts[i]);
332338 goDir(kids[i]);
333339 }
334340 break;
@@ -364,7 +370,7 @@ function updateProps(node, curr, next) {
364370 e.style.opacity = props.opacity;
365371 }
366372 var nextColor = (props.color.ctor === 'Just' ?
367− extract(props.color._0) : '');
373+ colorToCss(props.color._0) : '');
368374 if (e.style.backgroundColor !== nextColor) {
369375 e.style.backgroundColor = (nextColor === '' ? 'transparent' : nextColor);
370376 }
runtime/Render/Utils.js+2−7
@@ -10,11 +10,6 @@ ElmRuntime.Render.Utils = function() {
1010 container.appendChild(elem);
1111 }
1212
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−
1813 function addTransform(style, trans) {
1914 style.transform = trans;
2015 style.msTransform = trans;
@@ -34,8 +29,8 @@ ElmRuntime.Render.Utils = function() {
3429 var List = Elm.Native.List.make({});
3530
3631 return {addTo:addTo,
37− newElement:newElement,
38− extract : extract,
32+ newElement: newElement,
33+ colorToCss: Elm.Native.Color.make({}).toCss,
3934 fromList: List.toArray,
4035 fromString: function(s) { return s; },
4136 toString: function(s) { return s; },
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/hs/LibTest.hsdeleted−30
@@ -1,30 +0,0 @@
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− let ioScript s = top</>"IO"</>s
16− runCmd "git submodule update --init"
17− out <- readProcess "npm" ["ls", "--parseable"] ""
18− unless ("jsdom" `isInfixOf` out) $ runCmd "npm install jsdom"
19− setCurrentDirectory $ top</>"tests"</>"elm"
20− 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"]
21− runCmd $ unwords ["cat ", ioScript "prescript.js", Elm.runtime, "build"</>"Test.js", ioScript "handler.js", "> exe.js"]
22− exitWith =<< waitForProcess =<< (runCommand "node exe.js")
23− where runCmd cmd = do
24− putStrLn cmd
25− exitCode <- waitForProcess =<< runCommand cmd
26− case exitCode of
27− ExitSuccess -> return ()
28− ExitFailure _ -> error "something went wrong"
29−
30−
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+10−7
@@ -11,19 +11,22 @@ import IO.Runner as Run
1111
1212import Test.Array as Array
1313import Test.Dict as Dict
14+import Test.Equality as Equality
1415import Test.List as List
1516import Test.Set as Set
1617import Test.String as String
1718import Test.Trampoline as Trampoline
1819
1920tests : Test
20−tests = suite "Elm Standard Library Tests" [ List.tests,
21− String.tests,
22− Trampoline.tests,
23− Array.tests,
24− Dict.tests,
25− Set.tests
26− ]
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
28+ , Trampoline.tests
29+ ]
2730
2831console : IO ()
2932console = runDisplay tests
tests/elm/Test/Array.elm → tests/libraries/Test/Array.elmrenamed+2−1
@@ -46,7 +46,8 @@ tests =
4646 ]
4747 mappingAndFoldingTests = suite "Mapping and Folding"
4848 [ test "map" <| assertEqual (Array.fromList [1,2,3]) (Array.map sqrt (Array.fromList [1,4,9]))
49− , test "indexedMap" <| assertEqual (Array.fromList [0,5,10]) (Array.indexedMap (*) (Array.fromList [5,5,5]))
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)))
5051 , test "foldl" <| assertEqual [3,2,1] (Array.foldl (::) [] (Array.fromList [1,2,3]))
5152 , test "foldr 1" <| assertEqual 15 (Array.foldr (+) 0 (Array.repeat 3 5))
5253 , test "foldr 2" <| assertEqual [1,2,3] (Array.foldr (::) [] (Array.fromList [1,2,3]))
tests/elm/Test/Dict.elm → tests/libraries/Test/Dict.elmrenamed

The content is the same.

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/elm/Test/List.elm → tests/libraries/Test/List.elmrenamed

The content is the same.

tests/elm/Test/Set.elm → tests/libraries/Test/Set.elmrenamed

The content is the same.

tests/elm/Test/String.elm → tests/libraries/Test/String.elmrenamed

The content is the same.

tests/elm/Test/Trampoline.elm → tests/libraries/Test/Trampoline.elmrenamed

The content is the same.