Elm 0.12.1.3 → 0.12.2
raw patch · 34 files changed
+1242/−567 lines, 34 filesdep +language-glsldep +scientificdep +yamlPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: language-glsl, scientific, yaml
API changes (from Hackage documentation)
- Elm.Internal.Dependencies: Mini :: [(Name, Version)] -> MiniDeps
- Elm.Internal.Dependencies: data MiniDeps
- Elm.Internal.Dependencies: instance Eq MiniDeps
- Elm.Internal.Dependencies: instance FromJSON MiniDeps
- Elm.Internal.Dependencies: instance Ord MiniDeps
- Elm.Internal.Dependencies: instance Show MiniDeps
- Elm.Internal.Dependencies: instance ToJSON MiniDeps
+ Elm.Internal.Dependencies: native :: Deps -> [String]
+ Elm.Internal.Utils: nameAndImports :: String -> Maybe (String, [String])
- Elm.Internal.Dependencies: Deps :: Name -> Version -> String -> String -> String -> String -> [String] -> Version -> [(Name, Version)] -> Deps
+ Elm.Internal.Dependencies: Deps :: Name -> Version -> String -> String -> String -> String -> [String] -> [String] -> Version -> [(Name, Version)] -> Deps
- Elm.Internal.Dependencies: get :: FromJSON b => Object -> Text -> [Char] -> Parser b
+ Elm.Internal.Dependencies: get :: FromJSON a => Object -> Text -> String -> Parser a
- Elm.Internal.Dependencies: withDeps :: (Deps -> a) -> FilePath -> ErrorT String IO a
+ Elm.Internal.Dependencies: withDeps :: FilePath -> (Deps -> ErrorT String IO a) -> ErrorT String IO a
Files
- Elm.cabal +21/−9
- compiler/Build/Dependencies.hs +64/−39
- compiler/Build/Flags.hs +7/−4
- compiler/Build/Print.hs +9/−1
- compiler/Build/Utils.hs +9/−0
- 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/−0
- compiler/SourceSyntax/Literal.hs +22/−0
- compiler/Transform/Canonicalize.hs +1/−0
- compiler/Transform/Expression.hs +1/−0
- compiler/Transform/SafeNames.hs +1/−0
- compiler/Transform/SortDefinitions.hs +2/−0
- compiler/Transform/Substitute.hs +1/−0
- compiler/Type/Constrain/Expression.hs +17/−0
- compiler/Type/ExtraChecks.hs +2/−3
- data/docs.json +266/−10
- data/elm-runtime.js +382/−167
- data/interfaces.data binary
- tests/compiler/CompilerTest.hs +11/−0
- tests/compiler/Tests/Compiler.hs +45/−0
- tests/compiler/Tests/Property.hs +55/−0
- tests/compiler/Tests/Property/Arbitrary.hs +128/−0
- tests/hs/CompilerTest.hs +0/−11
- tests/hs/LibTest.hs +0/−30
- tests/hs/Tests/Compiler.hs +0/−45
- tests/hs/Tests/Property.hs +0/−55
- tests/hs/Tests/Property/Arbitrary.hs +0/−128
- tests/libraries/LibraryTest.hs +49/−0
Elm.cabal view
@@ -1,5 +1,5 @@ Name: Elm-Version: 0.12.1.3+Version: 0.12.2 Synopsis: The Elm language module. Description: Elm aims to make client-side web-development more pleasant. It is a statically/strongly typed, functional reactive@@ -107,14 +107,17 @@ filepath, indents, language-ecmascript >=0.15 && < 1.0,+ language-glsl, mtl >= 2, pandoc >= 1.10, parsec >= 3.1.1, pretty,+ scientific, text, transformers >= 0.2, union-find,- unordered-containers+ unordered-containers,+ yaml Executable elm Main-is: Compiler.hs@@ -190,14 +193,17 @@ filepath, indents, language-ecmascript >=0.15 && < 1.0,+ language-glsl, mtl >= 2, pandoc >= 1.10, parsec >= 3.1.1,+ scientific, pretty, text, transformers >= 0.2, union-find,- unordered-containers+ unordered-containers,+ yaml Executable elm-doc Main-is: Docs.hs@@ -231,16 +237,19 @@ directory, filepath, indents,+ language-glsl, mtl >= 2, pandoc >= 1.10, parsec >= 3.1.1, pretty,+ scientific, text,- union-find+ union-find,+ yaml Test-Suite compiler-tests Type: exitcode-stdio-1.0- Hs-Source-Dirs: tests/hs, compiler+ Hs-Source-Dirs: tests/compiler, compiler Main-is: CompilerTest.hs other-modules: Tests.Compiler Tests.Property@@ -268,19 +277,22 @@ filepath, indents, language-ecmascript >=0.15 && < 1.0,+ language-glsl, mtl >= 2, pandoc >= 1.10, parsec >= 3.1.1, pretty,+ scientific, text, transformers >= 0.2, union-find,- unordered-containers+ unordered-containers,+ yaml -Test-Suite lib-tests+Test-Suite library-tests Type: exitcode-stdio-1.0- Hs-Source-Dirs: tests/hs- Main-is: LibTest.hs+ Hs-Source-Dirs: tests/libraries+ Main-is: LibraryTest.hs build-depends: base, directory, Elm,
compiler/Build/Dependencies.hs view
@@ -1,55 +1,57 @@ {-# OPTIONS_GHC -W #-}-module Build.Dependencies (getSortedDependencies, readDeps) where+module Build.Dependencies (Recipe(..), getBuildRecipe, readDeps) where -import Control.Applicative import Control.Monad.Error import qualified Control.Monad.State as State-import qualified Data.Aeson as Json-import qualified Data.ByteString.Lazy.Char8 as BSC import qualified Data.Graph as Graph import qualified Data.List as List import qualified Data.Map as Map-import qualified Data.Maybe as Maybe import qualified Data.Set as Set import System.Directory import System.FilePath as FP -import Build.Print (failure)- import qualified SourceSyntax.Module as Module import qualified Parse.Parse as Parse import qualified Elm.Internal.Paths as Path import qualified Elm.Internal.Name as N+import qualified Elm.Internal.Version as V import qualified Elm.Internal.Dependencies as Deps -getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [String]-getSortedDependencies srcDirs builtIns root =- do extras <- extraDependencies- let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras- result <- runErrorT $ readAllDeps allSrcDirs builtIns root- case result of- Right deps -> sortDeps deps- Left err -> failure err+data Recipe = Recipe+ { _elmFiles :: [FilePath]+ , _jsFiles :: [FilePath]+ } -extraDependencies :: IO (Maybe [FilePath])-extraDependencies =- do exists <- doesFileExist Path.dependencyFile- if not exists then return Nothing else Just <$> getPaths- where- getPaths = do- raw <- BSC.readFile Path.dependencyFile- case Json.eitherDecode raw of- Right (Deps.Mini deps) -> mapM validate deps- Left err ->- failure $ "Error reading the " ++ Path.dependencyFile ++ " file:\n" ++ err+getBuildRecipe :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO Recipe+getBuildRecipe srcDirs builtIns root =+ do directories <- getDependencies+ jsFiles <- nativeFiles ("." : directories)+ let allSrcDirs = srcDirs ++ directories+ nodes <- collectDependencies allSrcDirs builtIns root+ elmFiles <- sortElmFiles nodes+ return (Recipe elmFiles jsFiles) - validate (name,version) = do- let path = Path.dependencyDirectory </> toPath name version- exists <- doesDirectoryExist path- if exists then return path else failure (notFound name version)+-- | Based on the projects elm_dependencies.json, find all of the paths and+-- dependency information we might need.+getDependencies :: ErrorT String IO [FilePath]+getDependencies =+ do exists <- liftIO $ doesFileExist Path.dependencyFile+ if not exists then return [] else getPaths+ where+ getPaths :: ErrorT String IO [FilePath]+ getPaths =+ Deps.withDeps Path.dependencyFile $ \deps ->+ mapM getPath (Deps.dependencies deps) - toPath name version = N.toFilePath name </> show version+ getPath :: (N.Name, V.Version) -> ErrorT String IO FilePath+ getPath (name,version) = do+ let path = Path.dependencyDirectory </> N.toFilePath name </> show version+ exists <- liftIO $ doesDirectoryExist path+ if exists+ then return path+ else throwError (notFound name version) + notFound :: N.Name -> V.Version -> String notFound name version = unlines [ "Your " ++ Path.dependencyFile ++ " file says you depend on library"@@ -58,27 +60,50 @@ , "" , " elm-get install " ++ show name ++ " " ++ show version ] -type Deps = (FilePath, String, [String])+nativeFiles :: [FilePath] -> ErrorT String IO [FilePath]+nativeFiles directories =+ do exists <- liftIO $ doesFileExist Path.dependencyFile+ if not exists+ then return []+ else concat `fmap` mapM getNativeFiles directories+ where+ getNativeFiles dir =+ Deps.withDeps (dir </> Path.dependencyFile) $ \deps ->+ return (map (toPath dir) (Deps.native deps)) -sortDeps :: [Deps] -> IO [String]-sortDeps depends =+ toPath dir moduleName =+ dir </> joinPath (split moduleName) <.> "js"+ +split :: String -> [String]+split moduleName = go [] moduleName+ where+ go paths str =+ case break (=='.') str of+ (path, _:rest) -> go (paths ++ [path]) rest+ (path, []) -> paths ++ [path]++type DependencyNode = (FilePath, String, [String])++sortElmFiles :: [DependencyNode] -> ErrorT String IO [FilePath]+sortElmFiles depends = if null mistakes then return (concat sccs)- else failure $ msg ++ unlines (map show mistakes)+ else throwError $ msg ++ unlines (map show mistakes) where sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends mistakes = filter (\scc -> length scc > 1) sccs msg = "A cyclical module dependency or was detected in:\n" -readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]-readAllDeps srcDirs rawBuiltIns filePath =+collectDependencies :: [FilePath] -> Module.Interfaces -> FilePath+ -> ErrorT String IO [DependencyNode]+collectDependencies srcDirs rawBuiltIns filePath = State.evalStateT (go Nothing filePath) Set.empty where builtIns :: Set.Set String builtIns = Set.fromList $ Map.keys rawBuiltIns - go :: Maybe String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]+ go :: Maybe String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [DependencyNode] go parentModuleName filePath = do filePath' <- lift $ findSrcFile parentModuleName srcDirs filePath (moduleName, deps) <- lift $ readDeps filePath'@@ -93,9 +118,9 @@ readDeps path = do txt <- lift $ readFile path case Parse.dependencies txt of+ Right o -> return o Left err -> throwError $ msg ++ show err where msg = "Error resolving dependencies in " ++ path ++ ":\n"- Right o -> return o findSrcFile :: Maybe String -> [FilePath] -> FilePath -> ErrorT String IO FilePath findSrcFile parentModuleName dirs path =
compiler/Build/Flags.hs view
@@ -7,7 +7,8 @@ data Flags = Flags { make :: Bool , files :: [FilePath]- , runtime :: Maybe FilePath+ , set_runtime :: Maybe FilePath+ , get_runtime :: Bool , only_js :: Bool , print_types :: Bool , scripts :: [FilePath]@@ -28,8 +29,10 @@ &= help "Do not import Prelude by default, used only when compiling standard libraries." , scripts = [] &= typFile &= help "Load JavaScript files in generated HTML. Files will be included in the given order."- , runtime = Nothing &= typFile- &= help "Specify a custom location for Elm's runtime system."+ , set_runtime = Nothing &= typFile+ &= help "Specify a custom location for Elm's runtime system."+ , get_runtime = False+ &= help "Print the absolute path to the default Elm runtime." , cache_dir = "cache" &= typFile &= help "Directory for files cached to make builds faster. Defaults to cache/ directory." , build_dir = "build" &= typFile@@ -37,7 +40,7 @@ , src_dir = ["."] &= typFile &= help "Additional source directories besides project root. Searched when using --make" , print_types = False- &= help "Print out infered types of top-level definitions."+ &= help "Print out inferred types of top-level definitions." } &= help "Compile Elm programs to HTML, CSS, and JavaScript." &= helpArg [explicit, name "help", name "h"] &= versionArg [explicit, name "version", name "v", summary (show Version.elmVersion)]
compiler/Build/Print.hs view
@@ -5,6 +5,7 @@ import qualified Data.Map as Map import qualified Data.List as List+import qualified SourceSyntax.Type as T import qualified SourceSyntax.Module as M import qualified SourceSyntax.PrettyPrint as Pretty import qualified Type.Alias as Alias@@ -18,6 +19,11 @@ interfaceTypes interfaces iface = types interfaces (M.iTypes iface) (M.iAliases iface) (M.iImports iface) +types :: Map.Map k M.ModuleInterface+ -> Map.Map String T.Type+ -> [M.Alias]+ -> [(String, M.ImportMethod)]+ -> IO () types interfaces types' aliases imports = do putStrLn "" mapM_ printType (Map.toList types')@@ -35,4 +41,6 @@ mapM_ print (List.intersperse (P.text " ") errs) failure :: String -> IO a-failure msg = hPutStrLn stderr msg >> exitFailure+failure msg =+ do hPutStrLn stderr msg+ exitFailure
compiler/Build/Utils.hs view
@@ -1,10 +1,12 @@ {-# OPTIONS_GHC -W #-} module Build.Utils where +import Control.Monad.Error import System.Directory (doesFileExist) import System.Environment (getEnv) import System.FilePath ((</>), replaceExtension) import qualified Build.Flags as Flag+import qualified Build.Print as Print import qualified Paths_Elm as This buildPath :: Flag.Flags -> FilePath -> String -> FilePath@@ -33,3 +35,10 @@ else do env <- getEnv "ELM_HOME" return (env </> name)++run :: ErrorT String IO a -> IO a+run command = do+ either <- runErrorT command+ case either of+ Left err -> Print.failure err+ Right result -> return result
compiler/Compiler.hs view
@@ -1,16 +1,17 @@ {-# OPTIONS_GHC -W #-} module Main where -import Control.Monad (foldM)+import Control.Monad (foldM, when) import qualified Data.Maybe as Maybe import Text.Blaze.Html.Renderer.String (renderHtml) import qualified Data.ByteString.Lazy.Char8 as BS import qualified System.Console.CmdArgs as CmdArgs import System.Directory+import System.Exit (exitSuccess) import System.FilePath import GHC.Conc -import Build.Dependencies (getSortedDependencies)+import Build.Dependencies (getBuildRecipe, Recipe(..)) import qualified Generate.Html as Html import qualified Metadata.Prelude as Prelude import qualified Build.Utils as Utils@@ -24,7 +25,10 @@ compileArgs :: Flag.Flags -> IO () compileArgs flags =- case Flag.files flags of+ do when (Flag.get_runtime flags) $ + do putStrLn Path.runtime+ exitSuccess+ case Flag.files flags of [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help" fs -> mapM_ (build flags) fs @@ -33,13 +37,15 @@ do let noPrelude = Flag.no_prelude flags builtIns <- Prelude.interfaces noPrelude - files <- if Flag.make flags- then getSortedDependencies (Flag.src_dir flags) builtIns rootFile- else return [rootFile]+ (Recipe elmFiles jsFiles) <-+ if Flag.make flags+ then Utils.run (getBuildRecipe (Flag.src_dir flags) builtIns rootFile)+ else return (Recipe [rootFile] []) - moduleName <- File.build flags builtIns files+ moduleName <- File.build flags builtIns elmFiles - js <- foldM appendToOutput BS.empty files+ let elmos = map (Utils.elmo flags) elmFiles+ js <- foldM appendToOutput BS.empty (elmos ++ jsFiles) (extension, code) <- if Flag.only_js flags@@ -56,12 +62,12 @@ where appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString appendToOutput js filePath = do- src <- BS.readFile (Utils.elmo flags filePath)+ src <- BS.readFile filePath return (BS.append src js) sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ] makeHtml js moduleName = ("html", BS.pack $ renderHtml html) where- rtsPath = Maybe.fromMaybe Path.runtime (Flag.runtime flags)+ rtsPath = Maybe.fromMaybe Path.runtime (Flag.set_runtime flags) html = Html.generate rtsPath (takeBaseName rootFile) (sources js) moduleName ""
compiler/Elm/Internal/Dependencies.hs view
@@ -2,10 +2,13 @@ module Elm.Internal.Dependencies where import Control.Applicative+import Control.Arrow (first) import Control.Monad.Error import qualified Control.Exception as E import Data.Aeson+import Data.Aeson.Types (Parser) import Data.Aeson.Encode.Pretty+import Data.Maybe (fromMaybe) import qualified Data.List as List import qualified Data.ByteString.Lazy as BS import qualified Data.HashMap.Strict as Map@@ -23,33 +26,28 @@ , license :: String , repo :: String , exposed :: [String]+ , native :: [String] , elmVersion :: V.Version , dependencies :: [(N.Name,V.Version)] } deriving (Show, Eq, Ord) -data MiniDeps = Mini [(N.Name,V.Version)]- deriving (Show, Eq, Ord)--instance ToJSON MiniDeps where- toJSON (Mini m) = toJSON m--instance FromJSON MiniDeps where- parseJSON (Object obj) = Mini <$> getDependencies obj- parseJSON _ = mzero- instance ToJSON Deps where- toJSON d = object [- "version" .= version d,- "summary" .= summary d,- "description" .= description d,- "license" .= license d,- "repository" .= repo d,- "exposed-modules" .= exposed d,- "elm-version" .= elmVersion d,- "dependencies" .= (jsonDeps . dependencies $ d)- ]- where jsonDeps = Map.fromList . map (mapFst (T.pack . show))- mapFst f (a,b) = (f a, b)+ toJSON d =+ object $+ [ "version" .= version d+ , "summary" .= summary d+ , "description" .= description d+ , "license" .= license d+ , "repository" .= repo d+ , "exposed-modules" .= exposed d+ , "elm-version" .= elmVersion d+ , "dependencies" .= (jsonDeps . dependencies $ d)+ ] ++ nativeModules+ where+ jsonDeps = Map.fromList . map (first (T.pack . show))+ nativeModules+ | null (native d) = []+ | otherwise = [ "native-modules" .= native d ] instance FromJSON Deps where parseJSON (Object obj) =@@ -69,15 +67,18 @@ Right nm -> return nm exposed <- get obj "exposed-modules" "a list of modules exposed to users"+ + native <- fromMaybe [] <$> (obj .:? "native-modules") elmVersion <- get obj "elm-version" "the version of the Elm compiler you are using" deps <- getDependencies obj - return $ Deps name version summary desc license repo exposed elmVersion deps+ return $ Deps name version summary desc license repo exposed native elmVersion deps parseJSON _ = mzero +getDependencies :: Object -> Parser [(N.Name, V.Version)] getDependencies obj = toDeps =<< get obj "dependencies" "a listing of your project's dependencies" where@@ -88,7 +89,7 @@ (Nothing, _) -> fail $ N.errorMsg f (_, Nothing) -> fail $ "invalid version number " ++ v -+get :: FromJSON a => Object -> T.Text -> String -> Parser a get obj field desc = do maybe <- obj .:? field case maybe of@@ -117,12 +118,12 @@ \like <https://github.com/USER/PROJECT.git> where USER is your GitHub name\n\ \and PROJECT is the repo you want to upload." -withDeps :: (Deps -> a) -> FilePath -> ErrorT String IO a-withDeps handle path =+withDeps :: FilePath -> (Deps -> ErrorT String IO a) -> ErrorT String IO a+withDeps path handle = do json <- readPath case eitherDecode json of Left err -> throwError $ "Error reading file " ++ path ++ ":\n " ++ err- Right ds -> return (handle ds)+ Right ds -> handle ds where readPath :: ErrorT String IO BS.ByteString readPath = do@@ -136,19 +137,20 @@ " <https://github.com/evancz/automaton/blob/master/elm_dependencies.json>" depsAt :: FilePath -> ErrorT String IO Deps-depsAt = withDeps id+depsAt filePath = withDeps filePath return -- | Encode dependencies in a canonical JSON format prettyJSON :: Deps -> BS.ByteString prettyJSON = encodePretty' config where config = defConfig { confCompare = order }- order = keyOrder [ "name",- "version",- "summary",- "description",- "license",- "repo",- "exposed-modules",- "elm-version",- "dependencies"+ order = keyOrder [ "name"+ , "version"+ , "summary"+ , "description"+ , "license"+ , "repo"+ , "exposed-modules"+ , "native-modules"+ , "elm-version"+ , "dependencies" ]
compiler/Elm/Internal/Utils.hs view
@@ -1,11 +1,12 @@ {- | This module exports functions for compiling Elm to JS. -} -module Elm.Internal.Utils (compile, moduleName) where +module Elm.Internal.Utils (compile, moduleName, nameAndImports) where import qualified Data.List as List import qualified Generate.JavaScript as JS import qualified Build.Source as Source -import qualified Parse.Module as Parser +import Parse.Module (getModuleName) +import Parse.Parse (dependencies) import qualified SourceSyntax.Module as M import qualified Text.PrettyPrint as P import qualified Metadata.Prelude as Prelude @@ -25,4 +26,10 @@ -- |This function extracts the module name of a given source program. moduleName :: String -> Maybe String -moduleName = Parser.getModuleName+moduleName = getModuleName + +-- |This function extracts the module name and imported modules from a given +-- source program. +nameAndImports :: String -> Maybe (String, [String]) +nameAndImports src = + either (const Nothing) Just (dependencies src)
compiler/Generate/JavaScript.hs view
@@ -34,10 +34,11 @@ internalImports :: String -> Statement () internalImports name =- VarDeclStmt () + VarDeclStmt () [ varDecl "_N" (obj "Elm.Native") , include "_U" "_N.Utils" , include "_L" "_N.List"+ , include "_A" "_N.Array" , include "_E" "_N.Error" , varDecl "$moduleName" (string name) ]@@ -179,6 +180,9 @@ pad = "<div style=\"height:0;width:0;\"> </div>" md = pad ++ MD.toHtml doc ++ pad + GLShader _uid src _tipe ->+ return $ ObjectLit () [(PropString () "src", literal (Str src))]+ PortIn name tipe -> return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
compiler/Generate/JavaScript/Ports.hs view
@@ -38,7 +38,7 @@ Data "Json.Value" [] -> obj "Native.Json.fromJS" <| x- + Data ctor [] | ctor == "Int" -> from JSNumber | ctor == "Float" -> from JSNumber@@ -55,9 +55,13 @@ | ctor == "_List" -> check x JSArray (obj "_L.fromArray" <| array)- where- array = DotRef () x (var "map") <| incoming t + | ctor == "Array.Array" ->+ check x JSArray (obj "_A.fromJSArray" <| array)++ where+ array = DotRef () x (var "map") <| incoming t+ Data ctor ts | Help.isTuple ctor -> check x JSArray tuple where@@ -67,10 +71,10 @@ , inc t (BracketRef () x (IntLit () n))) Data _ _ ->- error "bad ADT got to port generation code"+ error "bad ADT got to incoming port generation code" Record _ (Just _) ->- error "bad record got to port generation code"+ error "bad record got to incoming port generation code" Record fields Nothing -> check x (JSObject (map fst fields)) object@@ -117,16 +121,19 @@ | ctor == "_List" -> DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t + | ctor == "Array.Array" ->+ DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t+ Data ctor ts | Help.isTuple ctor -> let convert n t = out t $ DotRef () x $ var ('_':show n) in ArrayLit () $ zipWith convert [0..] ts- + Data _ _ ->- error "bad ADT got to port generation code"+ error "bad ADT got to outgoing port generation code" Record _ (Just _) ->- error "bad record got to port generation code"+ error "bad record got to outgoing port generation code" Record fields Nothing -> ObjectLit () keys
compiler/Parse/Expression.hs view
@@ -44,7 +44,7 @@ -------- Complex Terms -------- listTerm :: IParser ParseExpr'-listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)+listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> commaSep expr) where range = do lo <- expr@@ -56,6 +56,12 @@ let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos) (rawText, exprs) <- markdown (interpolation uid) return (Markdown uid (filter (/='\r') rawText) exprs)++ glShader' = do+ pos <- getPosition+ let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)+ (rawSrc, tipe) <- glShader+ return $ GLShader uid (filter (/='\r') rawSrc) tipe span uid index = "<span id=\"md-" ++ uid ++ "-" ++ show index ++ "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"
compiler/Parse/Helpers.hs view
@@ -8,6 +8,8 @@ import Data.Char (isUpper) import qualified Data.Set as Set import qualified Data.Map as Map+import qualified Language.GLSL.Parser as GLP+import Language.GLSL.Syntax as GLS import Text.Parsec hiding (newline,spaces,State) import Text.Parsec.Indent import qualified Text.Parsec.Token as T@@ -16,6 +18,7 @@ import SourceSyntax.Declaration (Assoc) import SourceSyntax.Expression import SourceSyntax.Helpers as Help+import SourceSyntax.Literal as Literal import SourceSyntax.PrettyPrint import SourceSyntax.Variable as Variable @@ -308,15 +311,61 @@ False -> (:) <$> anyChar <*> go markdown :: ([a] -> IParser (String, [a])) -> IParser (String, [a])-markdown interpolation = try (string "[markdown|") >> closeMarkdown (++ "") []+markdown interpolation =+ do try (string "[markdown|")+ closeMarkdown id [] where- closeMarkdown md stuff =+ closeMarkdown markdownBuilder stuff = choice [ do try (string "|]")- return (md "", stuff)- , (\(m,s) -> closeMarkdown (md . (m ++)) s) =<< interpolation stuff+ return (markdownBuilder "", stuff)+ , do (markdown,stuff') <- interpolation stuff+ closeMarkdown (markdownBuilder . (markdown++)) stuff' , do c <- anyChar- closeMarkdown (md . ([c]++)) stuff+ closeMarkdown (markdownBuilder . (c:)) stuff ]++glShader :: IParser (String, Literal.GLShaderTipe)+glShader =+ do try (string "[glShader|")+ rawSrc <- closeShader id+ case glSource rawSrc of+ Left err -> parserFail . show $ err+ Right tipe -> return (rawSrc, tipe)+ where+ closeShader builder = choice+ [ do try (string "|]")+ return (builder "")+ , do c <- anyChar+ closeShader (builder . (c:))+ ]++glSource :: String -> Either ParseError Literal.GLShaderTipe+glSource src =+ case GLP.parse src of+ Right (TranslationUnit decls) ->+ Right . foldr addGLinput emptyDecls . join . map extractGLinputs $ decls+ Left e -> Left e+ where + emptyDecls = Literal.GLShaderTipe Map.empty Map.empty Map.empty+ addGLinput (qual,tipe,name) glDecls = case qual of+ Attribute -> glDecls { attribute = Map.insert name tipe $ attribute glDecls }+ Uniform -> glDecls { uniform = Map.insert name tipe $ uniform glDecls }+ Varying -> glDecls { varying = Map.insert name tipe $ varying glDecls }+ _ -> error "Should never happen due to below filter"+ extractGLinputs decl = case decl of+ Declaration (InitDeclaration (TypeDeclarator (FullType (Just (TypeQualSto qual)) (TypeSpec _prec (TypeSpecNoPrecision tipe _mexpr1)))) [InitDecl name _mexpr2 _mexpr3]) ->+ if elem qual [Attribute, Varying, Uniform] + then case tipe of + GLS.Int -> return (qual,Literal.Int,name)+ GLS.Float -> return (qual,Literal.Float,name)+ GLS.Vec2 -> return (qual,V2,name)+ GLS.Vec3 -> return (qual,V3,name) + GLS.Vec4 -> return (qual,V4,name)+ GLS.Mat4 -> return (qual,M4,name)+ GLS.Sampler2D -> return (qual,Texture,name)+ _ -> []+ else []+ _ -> [] --str :: IParser String str = expecting "String" $ do
compiler/SourceSyntax/Expression.hs view
@@ -58,6 +58,7 @@ -- for type checking and code gen only | PortIn String SrcType.Type | PortOut String SrcType.Type (GeneralExpr ann def var)+ | GLShader String String Literal.GLShaderTipe deriving (Show) @@ -177,6 +178,8 @@ field (x,e) = variable x <+> P.equals <+> pretty e Markdown _ _ _ -> P.text "[markdown| ... |]"++ GLShader _ _ _ -> P.text "[glShader| ... |]" PortIn name _ -> P.text $ "<port:" ++ name ++ ">"
compiler/SourceSyntax/Literal.hs view
@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wall #-} module SourceSyntax.Literal where +import Data.Map (Map) import SourceSyntax.PrettyPrint import qualified Text.PrettyPrint as PP @@ -19,3 +20,24 @@ Chr c -> PP.text . show $ c Str s -> PP.text . show $ s Boolean bool -> PP.text (show bool)++data GLTipe = Int | Float | V2 | V3 | V4 | M4 | Texture+ deriving (Show)++glTipeName :: GLTipe -> String+glTipeName glTipe =+ case glTipe of+ Int -> "Int"+ Float -> "Float"+ V2 -> "Math.Vector2.Vec2"+ V3 -> "Math.Vector3.Vec3"+ V4 -> "Math.Vector4.Vec4"+ M4 -> "Math.Matrix4.Mat4"+ Texture -> "Graphics.WebGL.Texture"++data GLShaderTipe = GLShaderTipe+ { attribute :: Map String GLTipe+ , uniform :: Map String GLTipe+ , varying :: Map String GLTipe+ } deriving (Show)+
compiler/Transform/Canonicalize.hs view
@@ -178,6 +178,7 @@ PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal + GLShader _ _ _ -> return expr renamePattern :: Env -> P.Pattern -> Either String P.Pattern renamePattern env pattern =
compiler/Transform/Expression.hs view
@@ -49,6 +49,7 @@ Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields Markdown uid md es -> Markdown uid md <$> mapM go es Let defs body -> Let <$> defsTransform defs <*> go body+ GLShader uid src gltipe -> return $ GLShader uid src gltipe PortIn name st -> do portInCheck name st return $ PortIn name st
compiler/Transform/SafeNames.hs view
@@ -54,6 +54,7 @@ Modify r fs -> Modify (f r) (map (var *** f) fs) Record fs -> Record (map (var *** f) fs) Markdown uid md es -> Markdown uid md (map f es)+ GLShader _ _ _ -> expr PortIn name st -> PortIn name st PortOut name st signal -> PortOut name st (f signal)
compiler/Transform/SortDefinitions.hs view
@@ -84,6 +84,8 @@ Markdown uid md es -> Markdown uid md <$> mapM reorder es + GLShader _ _ _ -> return expr+ PortOut name st signal -> PortOut name st <$> reorder signal PortIn name st -> return $ PortIn name st
compiler/Transform/Substitute.hs view
@@ -40,5 +40,6 @@ Record fs -> Record (map (second f) fs) Literal _ -> expr Markdown uid md es -> Markdown uid md (map f es)+ GLShader _ _ _ -> expr PortIn name st -> PortIn name st PortOut name st signal -> PortOut name st (f signal)
compiler/Type/Constrain/Expression.hs view
@@ -8,6 +8,7 @@ import qualified Data.Map as Map import qualified Text.PrettyPrint as PP +import SourceSyntax.Literal as Lit import SourceSyntax.Annotation as Ann import SourceSyntax.Expression import qualified SourceSyntax.Pattern as P@@ -30,6 +31,22 @@ in case expr of Literal lit -> liftIO $ Literal.constrain env region lit tipe++ GLShader _uid _src gltipe -> + exists $ \attr -> + exists $ \unif -> + let + shaderTipe a u v = Env.get env Env.types "Graphics.WebGL.Shader" <| a <| u <| v+ glTipe = Env.get env Env.types . Lit.glTipeName+ makeRec accessor baseRec = + let decls = accessor gltipe+ in if Map.size decls == 0+ then baseRec+ else record (Map.map (\t -> [glTipe t]) decls) baseRec+ attribute = makeRec Lit.attribute attr+ uniform = makeRec Lit.uniform unif+ varying = makeRec Lit.varying (TermN EmptyRecord1)+ in return . A region $ CEqual tipe (shaderTipe attribute uniform varying) Var (V.Raw name) | name == saveEnvName -> return (A region CSaveEnv)
compiler/Type/ExtraChecks.hs view
@@ -60,8 +60,7 @@ | otherwise -> err' True "an unsupported type" where primitives =- ["Int","Float","String","Bool","Maybe.Maybe","_List","Json.Value"]-+ ["Int","Float","String","Bool","Maybe.Maybe","_List","Array.Array","Json.Value"] validConstructor = ctor `elem` primitives || Help.isTuple ctor @@ -102,7 +101,7 @@ , txt [ "It contains ", kind, ":\n" ] , (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n" , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]- , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Tuples," ]+ , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples," ] , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ] ] ++ if couldBeAlias then aliasWarning else []
data/docs.json view
@@ -2576,17 +2576,17 @@ }, { "name": "Color",- "document": "Library for working with colors. Includes\n[RGB](https://en.wikipedia.org/wiki/RGB_color_model) and\n[HSV](http://en.wikipedia.org/wiki/HSL_and_HSV) creation, gradients, and\nbuilt-in names.\n\n# Creation\n@docs rgb, rgba, hsv, hsva, greyscale, grayscale\n\n# From Other Colors\n@docs complement\n\n# Gradients\n@docs linear, radial\n\n# Built-in Colors\nThese colors come from the [Tango\npalette](http://tango.freedesktop.org/Tango_Icon_Theme_Guidelines)\nwhich provides aesthetically reasonable defaults for colors. Each color also\ncomes with a light and dark version.\n\n### Standard\n@docs red, orange, yellow, green, blue, purple, brown\n\n### Light\n@docs lightRed, lightOrange, lightYellow, lightGreen, lightBlue, lightPurple,\n lightBrown\n\n### Dark\n@docs darkRed, darkOrange, darkYellow, darkGreen, darkBlue, darkPurple,\n darkBrown\n\n### Eight Shades of Grey\nThese colors are a compatible series of shades of grey, fitting nicely\nwith the Tango palette.\n@docs white, lightGrey, grey, darkGrey, lightCharcoal, charcoal, darkCharcoal, black\n\nThese are identical to the *grey* versions. It seems the spelling is regional, but\nthat has never helped me remember which one I should be writing.\n@docs lightGray, gray, darkGray",+ "document": "Library for working with colors. Includes\n[RGB](https://en.wikipedia.org/wiki/RGB_color_model) and\n[HSL](http://en.wikipedia.org/wiki/HSL_and_HSV) creation, gradients, and\nbuilt-in names.\n\n# Creation\n@docs rgb, rgba, hsl, hsla, greyscale, grayscale, complement\n\n# Gradients\n@docs linear, radial\n\n# Extracting Colors\n@docs toRgb, toHsl\n\n# Built-in Colors\nThese colors come from the [Tango\npalette](http://tango.freedesktop.org/Tango_Icon_Theme_Guidelines)\nwhich provides aesthetically reasonable defaults for colors. Each color also\ncomes with a light and dark version.\n\n### Standard\n@docs red, orange, yellow, green, blue, purple, brown\n\n### Light\n@docs lightRed, lightOrange, lightYellow, lightGreen, lightBlue, lightPurple, lightBrown\n\n### Dark\n@docs darkRed, darkOrange, darkYellow, darkGreen, darkBlue, darkPurple, darkBrown\n\n### Eight Shades of Grey\nThese colors are a compatible series of shades of grey, fitting nicely\nwith the Tango palette.\n@docs white, lightGrey, grey, darkGrey, lightCharcoal, charcoal, darkCharcoal, black\n\nThese are identical to the *grey* versions. It seems the spelling is regional, but\nthat has never helped me remember which one I should be writing.\n@docs lightGray, gray, darkGray", "aliases": [], "datatypes": [ { "name": "Color", "comment": "",- "raw": "data Color = Color Int Int Int Float",+ "raw": "data Color\n = RGBA Int Int Int Float\n | HSLA Float Float Float Float", "typeVariables": [], "constructors": [ {- "name": "Color",+ "name": "RGBA", "type": { "tag": "function", "args": [@@ -2617,6 +2617,39 @@ "args": [] } }+ },+ {+ "name": "HSLA",+ "type": {+ "tag": "function",+ "args": [+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ },+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ },+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ },+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ }+ ],+ "result": {+ "tag": "adt",+ "name": "Color",+ "args": []+ }+ } } ] },@@ -2816,7 +2849,7 @@ }, { "name": "complement",- "comment": "Produce a “complementary color”.\nThe two colors will accent each other.",+ "comment": "Produce a “complementary color”. The two colors will\naccent each other. This is the same as rotating the hue by 180°.", "raw": "complement : Color -\u003e Color", "type": { "tag": "function",@@ -2935,6 +2968,31 @@ } }, {+ "name": "fmod",+ "comment": "",+ "raw": "fmod : Float -\u003e Int -\u003e Float",+ "type": {+ "tag": "function",+ "args": [+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ },+ {+ "tag": "adt",+ "name": "Int",+ "args": []+ }+ ],+ "result": {+ "tag": "adt",+ "name": "Float",+ "args": []+ }+ }+ },+ { "name": "gray", "comment": "", "raw": "gray : Color",@@ -3005,9 +3063,9 @@ } }, {- "name": "hsv",- "comment": "Create [HSV colors](http://en.wikipedia.org/wiki/HSL_and_HSV). This is very\nconvenient for creating colors that cycle and shift. Hue is an angle and should\nbe given in standard Elm angles (radians).",- "raw": "hsv : Float -\u003e Float -\u003e Float -\u003e Color",+ "name": "hsl",+ "comment": "Create [HSL colors](http://en.wikipedia.org/wiki/HSL_and_HSV). This gives\nyou access to colors more like a color wheel, where all hues are aranged in a\ncircle that you specify with standard Elm angles (radians).\n\n red = hsl (degrees 0) 1 0.5\n green = hsl (degrees 120) 1 0.5\n blue = hsl (degrees 240) 1 0.5\n\n pastelRed = hsl (degrees 0) 0.7 0.7\n\nTo cycle through all colors, just cycle through degrees. The saturation level\nis how vibrant the color is, like a dial between grey and bright colors. The\nlightness level is a dial between white and black.",+ "raw": "hsl : Float -\u003e Float -\u003e Float -\u003e Color", "type": { "tag": "function", "args": [@@ -3035,9 +3093,9 @@ } }, {- "name": "hsva",- "comment": "Create [HSV colors](http://en.wikipedia.org/wiki/HSL_and_HSV)\nwith an alpha component for transparency.",- "raw": "hsva : Float -\u003e Float -\u003e Float -\u003e Float -\u003e Color",+ "name": "hslToRgb",+ "comment": "",+ "raw": "hslToRgb : Float -\u003e Float -\u003e Float -\u003e (Float,Float,Float)", "type": { "tag": "function", "args": [@@ -3055,11 +3113,57 @@ "tag": "adt", "name": "Float", "args": []+ }+ ],+ "result": {+ "tag": "adt",+ "name": "_Tuple3",+ "args": [+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ },+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ },+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ }+ ]+ }+ }+ },+ {+ "name": "hsla",+ "comment": "Create [HSL colors](http://en.wikipedia.org/wiki/HSL_and_HSV)\nwith an alpha component for transparency.",+ "raw": "hsla : Float -\u003e Float -\u003e Float -\u003e Float -\u003e Color",+ "type": {+ "tag": "function",+ "args": [+ {+ "tag": "adt",+ "name": "Float",+ "args": [] }, { "tag": "adt", "name": "Float", "args": []+ },+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ },+ {+ "tag": "adt",+ "name": "Float",+ "args": [] } ], "result": {@@ -3368,6 +3472,52 @@ } }, {+ "name": "rgbToHsl",+ "comment": "",+ "raw": "rgbToHsl : Int -\u003e Int -\u003e Int -\u003e (Float,Float,Float)",+ "type": {+ "tag": "function",+ "args": [+ {+ "tag": "adt",+ "name": "Int",+ "args": []+ },+ {+ "tag": "adt",+ "name": "Int",+ "args": []+ },+ {+ "tag": "adt",+ "name": "Int",+ "args": []+ }+ ],+ "result": {+ "tag": "adt",+ "name": "_Tuple3",+ "args": [+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ },+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ },+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ }+ ]+ }+ }+ },+ { "name": "rgba", "comment": "Create RGB colors with an alpha component for transparency.\nThe alpha component is specified with numbers between 0 and 1.", "raw": "rgba : Int -\u003e Int -\u003e Int -\u003e Float -\u003e Color",@@ -3399,6 +3549,112 @@ "tag": "adt", "name": "Color", "args": []+ }+ }+ },+ {+ "name": "toHsl",+ "comment": "Extract the the components of a color in the HSL format.",+ "raw": "toHsl : Color -\u003e { hue:Float, saturation:Float, lightness:Float, alpha:Float }",+ "type": {+ "tag": "function",+ "args": [+ {+ "tag": "adt",+ "name": "Color",+ "args": []+ }+ ],+ "result": {+ "tag": "record",+ "fields": [+ [+ "hue",+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ }+ ],+ [+ "saturation",+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ }+ ],+ [+ "lightness",+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ }+ ],+ [+ "alpha",+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ }+ ]+ ],+ "extension": null+ }+ }+ },+ {+ "name": "toRgb",+ "comment": "Extract the the components of a color in the RGB format.",+ "raw": "toRgb : Color -\u003e { red:Int, green:Int, blue:Int, alpha:Float }",+ "type": {+ "tag": "function",+ "args": [+ {+ "tag": "adt",+ "name": "Color",+ "args": []+ }+ ],+ "result": {+ "tag": "record",+ "fields": [+ [+ "red",+ {+ "tag": "adt",+ "name": "Int",+ "args": []+ }+ ],+ [+ "green",+ {+ "tag": "adt",+ "name": "Int",+ "args": []+ }+ ],+ [+ "blue",+ {+ "tag": "adt",+ "name": "Int",+ "args": []+ }+ ],+ [+ "alpha",+ {+ "tag": "adt",+ "name": "Float",+ "args": []+ }+ ]+ ],+ "extension": null } } },
data/elm-runtime.js view
@@ -243,10 +243,16 @@ // Maps a function over the elements with their index as first argument. function indexedMap(f, a) {+ return indexedMap_(f, a, 0);+ }++ function indexedMap_(f, a, from) { var newA = { ctor:"_Array", height:a.height, table:new Array(a.table) }; if (a.height > 0) { newA.lengths = a.lengths; } for (var i = 0; i < a.table.length; i++) {- newA.table[i] = a.height == 0 ? A2(f, i, a.table[i]) : indexedMap(f, a.table[i]);+ newA.table[i] = a.height == 0 ? A2(f, from + i, a.table[i])+ : indexedMap_( f, a.table[i]+ , i == 0 ? 0 : a.lengths[i - 1]); } return newA; }@@ -721,7 +727,7 @@ complement: not, shiftLeft : F2(sll), shiftRightArithmatic: F2(sra),- shiftRightLogical : F2(srl),+ shiftRightLogical : F2(srl) }; };@@ -763,69 +769,25 @@ var Utils = Elm.Native.Utils.make(elm); function toCss(c) {- return (c._3 === 1)- ? ('rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')')- : ('rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')');- }-- function complement(rgb) {- var hsv = toHSV(rgb);- hsv.hue = (hsv.hue + 180) % 360;- return toRGB(hsv);- }-- function hsva(h,s,v,a) {- var degree = A2(Utils.mod, h * 180 / Math.PI, 360);- var clr = toRGB({hue:degree, saturation:s, value:v});- clr._3 = a;- return clr;- }-- function hsv(h,s,v) {- var degree = A2(Utils.mod, h * 180 / Math.PI, 360);- return toRGB({hue:degree, saturation:s, value:v});- }-- function toHSV(rgb) {- var hsv = {};- var r = rgb._0 / 255.0, g = rgb._1 / 255.0, b = rgb._2 / 255.0;- var M = Math.max(r,g,b);- var m = Math.min(r,g,b);- var c = M - m;-- var h = 0;- if (c === 0) { h = 0; }- else if (M === r) { h = ((g - b) / c) % 6; }- else if (M === g) { h = ((b - r) / c) + 2; }- else if (M === b) { h = ((r - g) / c) + 4; }- h *= 60;-- return { value : M, hue : h, saturation : (M === 0 ? 0 : c / M) };- }-- function between(lo,hi,x) { return lo <= x && x < hi; }- function norm(n) { return Math.round(n*255); }-- function toRGB(hsv) {- var c = hsv.value * hsv.saturation;- var hue = hsv.hue / 60;- var x = c * (1 - Math.abs((hue % 2) - 1));- var r = 0, g = 0, b = 0;- if (between(0,1,hue)) { r = c; g = x; b = 0; }- else if (between(1,2,hue)) { r = x; g = c; b = 0; }- else if (between(2,3,hue)) { r = 0; g = c; b = x; }- else if (between(3,4,hue)) { r = 0; g = x; b = c; }- else if (between(4,5,hue)) { r = x; g = 0; b = c; }- else if (between(5,6,hue)) { r = c; g = 0; b = x; }-- var m = hsv.value - c;- return { ctor:"Color", _0:norm(r+m), _1:norm(g+m), _2:norm(b+m), _3:1 };+ var format = '';+ var colors = '';+ if (c.ctor === 'RGBA') {+ format = 'rgb';+ colors = c._0 + ', ' + c._1 + ', ' + c._2;+ } else {+ format = 'hsl';+ colors = (c._0 * 180 / Math.PI) + ', ' ++ (c._1 * 100) + '%, ' ++ (c._2 * 100) + '%';+ }+ if (c._3 === 1) {+ return format + '(' + colors + ')';+ } else {+ return format + 'a(' + colors + ', ' + c._3 + ')';+ } } return elm.Native.Color.values = {- hsva:F4(hsva),- hsv:F3(hsv),- complement:complement, toCss:toCss }; @@ -893,8 +855,6 @@ elm.Native.Error = elm.Native.Error || {}; if (elm.Native.Error.values) return elm.Native.Error.values; - var fromString = Elm.Native.JavaScript.make(elm).fromString;- function indent(lines) { var msg = ''; for (var i = 0; i < lines.length; ++i) {@@ -915,10 +875,11 @@ throw new Error('Runtime error in module ' + moduleName + ' (' + span + '):' + msg); } - function raise(str) { throw new Error(fromString(str)); }+ function raise(str) { throw new Error(str); } return elm.Native.Error.values = { Case: Case, If: If, raise: raise }; };+ function F2(fun) { function wrapper(a) { return function(b) { return fun(a,b) } } wrapper.arity = 2;@@ -1168,7 +1129,7 @@ toString : F2(toString), fromString : fromString, fromJS : fromJS,- toJS : toJS,+ toJS : toJS }; };@@ -1463,6 +1424,16 @@ return fromArray(out); } + /*+ * Only to be used internally; do some side effects for each elem+ */+ function each(action, xs) {+ while(xs.ctor !== '[]') {+ action(xs._0);+ xs = xs._1;+ }+ }+ Elm.Native.List.values = { Nil:Nil, Cons:Cons,@@ -1502,7 +1473,9 @@ drop:F2(drop), repeat:F2(repeat), - join:F2(join)+ join:F2(join),++ each:each }; return elm.Native.List.values = Elm.Native.List.values; @@ -1635,7 +1608,7 @@ match: result[0], submatches: List.fromArray(subs), index: result.index,- number: number,+ number: number }); } return List.fromArray(out);@@ -1690,7 +1663,7 @@ contains: F2(contains), find: F3(find), replace: F4(replace),- split: F3(split),+ split: F3(split) }; }; Elm.Native.Show = {};@@ -1923,7 +1896,7 @@ } function words(str) {- return List.fromArray(str.split(/\s+/g));+ return List.fromArray(str.trim().split(/\s+/g)); } function lines(str) { return List.fromArray(str.split(/\r\n|\r|\n/g));@@ -2059,7 +2032,7 @@ toInt: toInt, toFloat: toFloat, toList: toList,- fromList: fromList,+ fromList: fromList }; }; Elm.Native.Text = {};@@ -2187,7 +2160,7 @@ html : Utils.makeText(text), align: align, guid : null,- args : [],+ args : [] }; var pos = A2(Utils.htmlHeight, 0, raw); return A3(Element.newElement, pos._0, pos._1, raw);@@ -2200,7 +2173,7 @@ html: text, align: null, guid: guid,- args: [],+ args: [] }; var pos = A2(Utils.htmlHeight, 0, raw); return A3(Element.newElement, pos._0, pos._1, raw);@@ -2226,7 +2199,7 @@ markdown : markdown, toTypefaces:toTypefaces,- toLine:toLine,+ toLine:toLine }; }; Elm.Native.Trampoline = {};@@ -2370,8 +2343,17 @@ var c = 0; for (var i in x) { ++c;- stack.push({ 'x': x[i], 'y': y[i] });+ if (i in y) {+ if (i !== 'ctor') {+ stack.push({ 'x': x[i], 'y': y[i] });+ }+ } else {+ return false;+ } }+ if ('ctor' in x) {+ stack.push({'x': x.ctor, 'y': y.ctor});+ } if (c !== Object.keys(y).length) { return false; };@@ -2908,7 +2890,7 @@ start: start, end: end, direction: { ctor: direction }- },+ } })); } @@ -3808,6 +3790,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Array"; var Basics = Elm.Basics.make(_elm);@@ -3905,6 +3888,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Basics"; var Native = Native || {};@@ -4099,6 +4083,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Bitwise"; var Native = Native || {};@@ -4129,6 +4114,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Char"; var Native = Native || {};@@ -4167,11 +4153,10 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Color"; var Basics = Elm.Basics.make(_elm);- var Native = Native || {};- Native.Color = Elm.Native.Color.make(_elm); var _op = {}; var Radial = F5(function (a, b,@@ -4195,177 +4180,373 @@ ,_2: c}; }); var linear = Linear;- var hsv = Native.Color.hsv;- var hsva = Native.Color.hsva;- var complement = Native.Color.complement;- var greyscale = function (p) {- return A3(hsv,0,0,1 - p);- };+ var fmod = F2(function (f,n) {+ return function () {+ var integer = Basics.floor(f);+ return Basics.toFloat(A2(Basics.mod,+ integer,+ n)) + f - Basics.toFloat(integer);+ }();+ });+ var rgbToHsl = F3(function (red,+ green,+ blue) {+ return function () {+ var b = Basics.toFloat(blue) / 255;+ var g = Basics.toFloat(green) / 255;+ var r = Basics.toFloat(red) / 255;+ var cMax = A2(Basics.max,+ A2(Basics.max,r,g),+ b);+ var cMin = A2(Basics.min,+ A2(Basics.min,r,g),+ b);+ var c = cMax - cMin;+ var lightness = (cMax + cMin) / 2;+ var saturation = _U.eq(lightness,+ 0) ? 0 : c / (1 - Basics.abs(2 * lightness - 1));+ var hue = Basics.degrees(60) * (_U.eq(cMax,+ r) ? A2(fmod,+ (g - b) / c,+ 6) : _U.eq(cMax,+ g) ? (b - r) / c + 2 : _U.eq(cMax,+ b) ? (r - g) / c + 4 : _E.If($moduleName,+ "between lines 140 and 142"));+ return {ctor: "_Tuple3"+ ,_0: hue+ ,_1: saturation+ ,_2: lightness};+ }();+ });+ var hslToRgb = F3(function (hue,+ saturation,+ lightness) {+ return function () {+ var hue$ = hue / Basics.degrees(60);+ var chroma = (1 - Basics.abs(2 * lightness - 1)) * saturation;+ var x = chroma * (1 - Basics.abs(A2(fmod,+ hue$,+ 2) - 1));+ var $ = _U.cmp(hue$,+ 0) < 0 ? {ctor: "_Tuple3"+ ,_0: 0+ ,_1: 0+ ,_2: 0} : _U.cmp(hue$,+ 1) < 0 ? {ctor: "_Tuple3"+ ,_0: chroma+ ,_1: x+ ,_2: 0} : _U.cmp(hue$,+ 2) < 0 ? {ctor: "_Tuple3"+ ,_0: x+ ,_1: chroma+ ,_2: 0} : _U.cmp(hue$,+ 3) < 0 ? {ctor: "_Tuple3"+ ,_0: 0+ ,_1: chroma+ ,_2: x} : _U.cmp(hue$,+ 4) < 0 ? {ctor: "_Tuple3"+ ,_0: 0+ ,_1: x+ ,_2: chroma} : _U.cmp(hue$,+ 5) < 0 ? {ctor: "_Tuple3"+ ,_0: x+ ,_1: 0+ ,_2: chroma} : _U.cmp(hue$,+ 6) < 0 ? {ctor: "_Tuple3"+ ,_0: chroma+ ,_1: 0+ ,_2: x} : {ctor: "_Tuple3"+ ,_0: 0+ ,_1: 0+ ,_2: 0},+ r = $._0,+ g = $._1,+ b = $._2;+ var m = lightness - chroma / 2;+ return {ctor: "_Tuple3"+ ,_0: r + m+ ,_1: g + m+ ,_2: b + m};+ }();+ });+ var HSLA = F4(function (a,+ b,+ c,+ d) {+ return {ctor: "HSLA"+ ,_0: a+ ,_1: b+ ,_2: c+ ,_3: d};+ });+ var hsla = F4(function (hue,+ saturation,+ lightness,+ alpha) {+ return A4(HSLA,+ hue - Basics.toFloat(Basics.floor(hue / (2 * Basics.pi))),+ saturation,+ lightness,+ alpha);+ });+ var hsl = F3(function (hue,+ saturation,+ lightness) {+ return A4(hsla,+ hue,+ saturation,+ lightness,+ 1);+ }); var grayscale = function (p) {- return A3(hsv,0,0,1 - p);+ return A4(HSLA,0,0,1 - p,1); };- var Color = F4(function (a,+ var greyscale = function (p) {+ return A4(HSLA,0,0,1 - p,1);+ };+ var RGBA = F4(function (a, b, c, d) {- return {ctor: "Color"+ return {ctor: "RGBA" ,_0: a ,_1: b ,_2: c ,_3: d}; });- var rgba = Color;+ var rgba = RGBA; var rgb = F3(function (r,g,b) {- return A4(Color,r,g,b,1);+ return A4(RGBA,r,g,b,1); });- var lightRed = A4(Color,+ var complement = function (color) {+ return function () {+ switch (color.ctor)+ {case "HSLA": return A4(hsla,+ color._0 + Basics.degrees(180),+ color._1,+ color._2,+ color._3);+ case "RGBA":+ return function () {+ var $ = A3(rgbToHsl,+ color._0,+ color._1,+ color._2),+ h = $._0,+ s = $._1,+ l = $._2;+ return A4(hsla,+ h + Basics.degrees(180),+ s,+ l,+ color._3);+ }();}+ _E.Case($moduleName,+ "between lines 95 and 101");+ }();+ };+ var toHsl = function (color) {+ return function () {+ switch (color.ctor)+ {case "HSLA": return {_: {}+ ,alpha: color._3+ ,hue: color._0+ ,lightness: color._2+ ,saturation: color._1};+ case "RGBA":+ return function () {+ var $ = A3(rgbToHsl,+ color._0,+ color._1,+ color._2),+ h = $._0,+ s = $._1,+ l = $._2;+ return {_: {}+ ,alpha: color._3+ ,hue: h+ ,lightness: l+ ,saturation: s};+ }();}+ _E.Case($moduleName,+ "between lines 104 and 111");+ }();+ };+ var toRgb = function (color) {+ return function () {+ switch (color.ctor)+ {case "HSLA":+ return function () {+ var $ = A3(hslToRgb,+ color._0,+ color._1,+ color._2),+ r = $._0,+ g = $._1,+ b = $._2;+ return {_: {}+ ,alpha: color._3+ ,blue: Basics.round(255 * b)+ ,green: Basics.round(255 * g)+ ,red: Basics.round(255 * r)};+ }();+ case "RGBA": return {_: {}+ ,alpha: color._3+ ,blue: color._2+ ,green: color._1+ ,red: color._0};}+ _E.Case($moduleName,+ "between lines 114 and 122");+ }();+ };+ var lightRed = A4(RGBA, 239, 41, 41, 1);- var red = A4(Color,204,0,0,1);- var darkRed = A4(Color,+ var red = A4(RGBA,204,0,0,1);+ var darkRed = A4(RGBA, 164, 0, 0, 1);- var lightOrange = A4(Color,+ var lightOrange = A4(RGBA, 252, 175, 62, 1);- var orange = A4(Color,+ var orange = A4(RGBA, 245, 121, 0, 1);- var darkOrange = A4(Color,+ var darkOrange = A4(RGBA, 206, 92, 0, 1);- var lightYellow = A4(Color,+ var lightYellow = A4(RGBA, 255, 233, 79, 1);- var yellow = A4(Color,+ var yellow = A4(RGBA, 237, 212, 0, 1);- var darkYellow = A4(Color,+ var darkYellow = A4(RGBA, 196, 160, 0, 1);- var lightGreen = A4(Color,+ var lightGreen = A4(RGBA, 138, 226, 52, 1);- var green = A4(Color,+ var green = A4(RGBA, 115, 210, 22, 1);- var darkGreen = A4(Color,+ var darkGreen = A4(RGBA, 78, 154, 6, 1);- var lightBlue = A4(Color,+ var lightBlue = A4(RGBA, 114, 159, 207, 1);- var blue = A4(Color,+ var blue = A4(RGBA, 52, 101, 164, 1);- var darkBlue = A4(Color,+ var darkBlue = A4(RGBA, 32, 74, 135, 1);- var lightPurple = A4(Color,+ var lightPurple = A4(RGBA, 173, 127, 168, 1);- var purple = A4(Color,+ var purple = A4(RGBA, 117, 80, 123, 1);- var darkPurple = A4(Color,+ var darkPurple = A4(RGBA, 92, 53, 102, 1);- var lightBrown = A4(Color,+ var lightBrown = A4(RGBA, 233, 185, 110, 1);- var brown = A4(Color,+ var brown = A4(RGBA, 193, 125, 17, 1);- var darkBrown = A4(Color,+ var darkBrown = A4(RGBA, 143, 89, 2, 1);- var black = A4(Color,0,0,0,1);- var white = A4(Color,+ var black = A4(RGBA,0,0,0,1);+ var white = A4(RGBA, 255, 255, 255, 1);- var lightGrey = A4(Color,+ var lightGrey = A4(RGBA, 238, 238, 236, 1);- var grey = A4(Color,+ var grey = A4(RGBA, 211, 215, 207, 1);- var darkGrey = A4(Color,+ var darkGrey = A4(RGBA, 186, 189, 182, 1);- var lightGray = A4(Color,+ var lightGray = A4(RGBA, 238, 238, 236, 1);- var gray = A4(Color,+ var gray = A4(RGBA, 211, 215, 207, 1);- var darkGray = A4(Color,+ var darkGray = A4(RGBA, 186, 189, 182, 1);- var lightCharcoal = A4(Color,+ var lightCharcoal = A4(RGBA, 136, 138, 133, 1);- var charcoal = A4(Color,+ var charcoal = A4(RGBA, 85, 87, 83, 1);- var darkCharcoal = A4(Color,+ var darkCharcoal = A4(RGBA, 46, 52, 54,@@ -4373,6 +4554,18 @@ _elm.Color.values = {_op: _op ,rgba: rgba ,rgb: rgb+ ,hsla: hsla+ ,hsl: hsl+ ,grayscale: grayscale+ ,greyscale: greyscale+ ,complement: complement+ ,toHsl: toHsl+ ,toRgb: toRgb+ ,fmod: fmod+ ,rgbToHsl: rgbToHsl+ ,hslToRgb: hslToRgb+ ,linear: linear+ ,radial: radial ,lightRed: lightRed ,red: red ,darkRed: darkRed@@ -4405,14 +4598,8 @@ ,lightCharcoal: lightCharcoal ,charcoal: charcoal ,darkCharcoal: darkCharcoal- ,grayscale: grayscale- ,greyscale: greyscale- ,complement: complement- ,hsva: hsva- ,hsv: hsv- ,linear: linear- ,radial: radial- ,Color: Color+ ,RGBA: RGBA+ ,HSLA: HSLA ,Linear: Linear ,Radial: Radial}; return _elm.Color.values;@@ -4425,6 +4612,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Date"; var Maybe = Elm.Maybe.make(_elm);@@ -4503,6 +4691,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Debug"; var Native = Native || {};@@ -4521,6 +4710,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Dict"; var Basics = Elm.Basics.make(_elm);@@ -5550,6 +5740,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Either"; var List = Elm.List.make(_elm);@@ -5677,6 +5868,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Http"; var Native = Native || {};@@ -5746,6 +5938,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Json"; var Dict = Elm.Dict.make(_elm);@@ -5801,6 +5994,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Keyboard"; var Native = Native || {};@@ -5846,6 +6040,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "List"; var Basics = Elm.Basics.make(_elm);@@ -6044,6 +6239,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Maybe"; var Basics = Elm.Basics.make(_elm);@@ -6105,6 +6301,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Mouse"; var Native = Native || {};@@ -6132,6 +6329,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Random"; var Native = Native || {};@@ -6155,6 +6353,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Regex"; var Maybe = Elm.Maybe.make(_elm);@@ -6206,6 +6405,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Set"; var Dict = Elm.Dict.make(_elm);@@ -6310,6 +6510,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Signal"; var Basics = Elm.Basics.make(_elm);@@ -6415,6 +6616,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "String"; var Maybe = Elm.Maybe.make(_elm);@@ -6516,6 +6718,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Text"; var Basics = Elm.Basics.make(_elm);@@ -6609,6 +6812,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Time"; var Basics = Elm.Basics.make(_elm);@@ -6663,6 +6867,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Touch"; var Native = Native || {};@@ -6700,6 +6905,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Trampoline"; var Native = Native || {};@@ -6727,6 +6933,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Transform2D"; var Native = Native || {};@@ -6794,6 +7001,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "WebSocket"; var Basics = Elm.Basics.make(_elm);@@ -6814,6 +7022,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Window"; var Native = Native || {};@@ -6839,6 +7048,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Graphics.Collage"; var Basics = Elm.Basics.make(_elm);@@ -7182,6 +7392,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Graphics.Element"; var Basics = Elm.Basics.make(_elm);@@ -7733,6 +7944,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Graphics.Input"; var Graphics = Graphics || {};@@ -7779,6 +7991,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "Graphics.Input.Field"; var Color = Elm.Color.make(_elm);@@ -7900,6 +8113,7 @@ var _N = Elm.Native, _U = _N.Utils.make(_elm), _L = _N.List.make(_elm),+ _A = _N.Array.make(_elm), _E = _N.Error.make(_elm), $moduleName = "JavaScript.Experimental"; var Json = Elm.Json.make(_elm);@@ -8263,7 +8477,7 @@ var Transform = Elm.Transform2D.make({}); var Utils = ElmRuntime.use(ElmRuntime.Render.Utils); var newElement = Utils.newElement,- extract = Utils.extract, fromList = Utils.fromList,+ colorToCss = Utils.colorToCss, fromList = Utils.fromList, fromString = Utils.fromString, addTransform = Utils.addTransform; function trace(ctx, path) {@@ -8328,7 +8542,7 @@ ctx.lineJoin = join === 'Smooth' ? 'round' : join === 'Sharp' ? 'miter' : 'bevel'; ctx.miterLimit = style.join._0 || 10;- ctx.strokeStyle = extract(style.color);+ ctx.strokeStyle = colorToCss(style.color); return line(ctx, style, path); } @@ -8354,7 +8568,7 @@ var len = stops.length; for (var i = 0; i < len; ++i) { var stop = stops[i];- g.addColorStop(stop._0, extract(stop._1));+ g.addColorStop(stop._0, colorToCss(stop._1)); } return g; }@@ -8363,7 +8577,7 @@ trace(ctx, path); var sty = style.ctor; ctx.fillStyle =- sty === 'Solid' ? extract(style._0) :+ sty === 'Solid' ? colorToCss(style._0) : sty === 'Texture' ? texture(redo, ctx, style._0) : gradient(ctx, style._0); ctx.scale(1,-1); ctx.fill();@@ -8616,7 +8830,7 @@ 'use strict'; var Utils = ElmRuntime.use(ElmRuntime.Render.Utils);-var newElement = Utils.newElement, extract = Utils.extract,+var newElement = Utils.newElement, colorToCss = Utils.colorToCss, addTransform = Utils.addTransform, removeTransform = Utils.removeTransform, fromList = Utils.fromList, eq = Utils.eq; @@ -8631,7 +8845,7 @@ e.style.opacity = props.opacity; } if (props.color.ctor === 'Just') {- e.style.backgroundColor = extract(props.color._0);+ e.style.backgroundColor = colorToCss(props.color._0); } if (props.tag !== '') { e.id = props.tag; } if (props.href !== '') {@@ -8756,29 +8970,37 @@ return e; } -function goIn(e) { e.style.position = 'absolute'; return e; }+function goOut(e) { e.style.position = 'absolute'; return e; } function goDown(e) { return e } function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e; }-function flowWith(f, array) {- var container = newElement('div');- if (f == goIn) container.style.pointerEvents = 'none'; - for (var i = array.length; i--; ) {- container.appendChild(f(render(array[i])));- }- return container;+var directionTable = {+ DUp : goDown,+ DDown : goDown,+ DLeft : goRight,+ DRight : goRight,+ DIn : goOut,+ DOut : goOut+};+function needsReversal(dir) {+ return dir == 'DUp' || dir == 'DLeft' || dir == 'DIn'; } function flow(dir,elist) { var array = fromList(elist);- switch(dir.ctor) {- case "DDown": array.reverse();- case "DUp": return flowWith(goDown,array);- case "DRight": array.reverse();- case "DLeft": return flowWith(goRight,array);- case "DOut": array.reverse();- case "DIn": return flowWith(goIn,array);+ var container = newElement('div');+ var goDir = directionTable[dir];+ if (goDir == goOut) {+ container.style.pointerEvents = 'none'; }+ if (needsReversal(dir)) {+ array.reverse();+ }+ var len = array.length;+ for (var i = 0; i < len; ++i) {+ container.appendChild(goDir(render(array[i])));+ }+ return container; } function toPos(pos) {@@ -8858,7 +9080,7 @@ var elem = e.element; switch(elem.ctor) { case 'Image': return image(e.props, elem);- case 'Flow': return flow(elem._0, elem._1);+ case 'Flow': return flow(elem._0.ctor, elem._1); case 'Container': return container(elem._0, elem._1); case 'Spacer': return newElement('div'); case 'RawHtml': return rawHtml(elem);@@ -8934,14 +9156,12 @@ return true; } var currs = fromList(currE._1);- var goDir = function(x) { return x; };- switch(nextE._0.ctor) {- case "DDown": case "DUp": goDir = goDown; break;- case "DRight": case "DLeft": goDir = goRight; break;- case "DOut": case "DIn": goDir = goIn; break;- }- for (var i = kids.length; i-- ;) {- update(kids[i],currs[i],nexts[i]);+ var dir = nextE._0.ctor;+ var goDir = directionTable[dir];+ var toReverse = needsReversal(dir);+ var len = kids.length;+ for (var i = len; i-- ;) {+ update(kids[toReverse ? len - i - 1 : i],currs[i],nexts[i]); goDir(kids[i]); } break;@@ -8977,7 +9197,7 @@ e.style.opacity = props.opacity; } var nextColor = (props.color.ctor === 'Just' ?- extract(props.color._0) : '');+ colorToCss(props.color._0) : ''); if (e.style.backgroundColor !== nextColor) { e.style.backgroundColor = (nextColor === '' ? 'transparent' : nextColor); }@@ -9034,11 +9254,6 @@ container.appendChild(elem); } - function extract(c) {- if (c._3 === 1) { return 'rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')'; }- return 'rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')';- }- function addTransform(style, trans) { style.transform = trans; style.msTransform = trans;@@ -9058,8 +9273,8 @@ var List = Elm.Native.List.make({}); return {addTo:addTo,- newElement:newElement,- extract : extract,+ newElement: newElement,+ colorToCss: Elm.Native.Color.make({}).toCss, fromList: List.toArray, fromString: function(s) { return s; }, toString: function(s) { return s; },
data/interfaces.data view
binary file changed (122006 → 122647 bytes)
+ tests/compiler/CompilerTest.hs view
@@ -0,0 +1,11 @@+module Main where++import Test.Framework++import Tests.Compiler+import Tests.Property++main :: IO () +main = defaultMain [ compilerTests+ , propertyTests+ ]
+ tests/compiler/Tests/Compiler.hs view
@@ -0,0 +1,45 @@+module Tests.Compiler (compilerTests)+ where++import Data.Functor ((<$>))+import Data.Traversable (traverse)+import System.FilePath ((</>))+import System.FilePath.Find (find, (==?), extension)+import Test.Framework+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion, assertFailure, assertBool)+import Text.Parsec (ParseError)++import Elm.Internal.Utils as Elm++compilerTests :: Test+compilerTests = buildTest $ do+ goods <- mkTests goodCompile =<< getElms "good"+ bads <- mkTests badCompile =<< getElms "bad"+ return $ testGroup "Compile Tests"+ [+ testGroup "Good Tests" goods+ , testGroup "Bad Tests" bads+ ]++ where getElms :: FilePath -> IO [FilePath]+ getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)++ mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]+ mkTests h = traverse setupTest+ where setupTest f = testCase f . mkCompileTest h <$> readFile f++ testsDir = "tests" </> "test-files"++goodCompile :: Either String String -> Assertion+goodCompile (Left err) = assertFailure err+goodCompile (Right _) = assertBool "" True++badCompile :: Either String String -> Assertion+badCompile (Left _) = assertBool "" True+badCompile (Right _) = assertFailure "Compilation succeeded but should have failed"+ +mkCompileTest :: ((Either String String) -> Assertion) -- ^ Handler+ -> String -- ^ File Contents+ -> Assertion+mkCompileTest handle = handle . Elm.compile
+ tests/compiler/Tests/Property.hs view
@@ -0,0 +1,55 @@+module Tests.Property where++import Control.Applicative ((<*))+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit (assert)+import Test.QuickCheck+import Text.Parsec.Combinator (eof)+import Text.PrettyPrint as P++import SourceSyntax.Literal as Lit+import qualified SourceSyntax.Pattern as P+import SourceSyntax.PrettyPrint (Pretty, pretty)+import Parse.Helpers (IParser, iParse)+import Parse.Literal (literal)+import qualified Parse.Pattern as Pat (expr)+import qualified Parse.Type as Type (expr)+import Tests.Property.Arbitrary++propertyTests :: Test+propertyTests =+ testGroup "Parse/Print Agreement Tests"+ [+ testCase "Long Pattern test" $ assert (prop_parse_print Pat.expr longPat)+ , testProperty "Literal test" $ prop_parse_print literal+ , testProperty "Pattern test" $ prop_parse_print Pat.expr+ , testProperty "Type test" $ prop_parse_print Type.expr+ ]++ where+ -- This test was autogenerated from the Pattern test and should be+ -- left in all its ugly glory.+ longPat = P.Data "I" [ P.Literal (Lit.Chr '+')+ , P.Record+ [ "q7yclkcm7k_ikstrczv_"+ , "wQRv6gKsvvkjw4b5F"+ ,"c9'eFfhk9FTvsMnwF_D"+ ,"yqxhEkHvRFwZ"+ ,"o"+ ,"nbUlCn3y3NnkVoxhW"+ ,"iJ0MNy3KZ_lrs"+ ,"ug"+ ,"sHHsX"+ ,"mRKs9d"+ ,"o2KiCX5'ZRzHJfRi8" ]+ , P.Var "su'BrrbPUK6I33Eq"+ ]++prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool+prop_parse_print p x =+ either (const False) (== x) . parse_print p $ x++parse_print :: (Pretty a) => IParser a -> a -> Either String a+parse_print p = either (Left . show) Right . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty
+ tests/compiler/Tests/Property/Arbitrary.hs view
@@ -0,0 +1,128 @@+{-# OPTIONS_GHC -W -fno-warn-orphans #-}+module Tests.Property.Arbitrary where++import Control.Applicative ((<$>), (<*>), pure)+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen++import qualified Data.Set as Set+import qualified Parse.Helpers (reserveds)++import qualified SourceSyntax.Literal as L+import qualified SourceSyntax.Pattern as P+import qualified SourceSyntax.Type as T++instance Arbitrary L.Literal where+ arbitrary =+ oneof+ [ L.IntNum <$> arbitrary+ , L.FloatNum <$> (arbitrary `suchThat` noE)+ , L.Chr <$> arbitrary+ -- This is too permissive+ , L.Str <$> arbitrary+ -- Booleans aren't actually source syntax + -- , Boolean <$> arbitrary+ ]++ shrink lit =+ case lit of+ L.IntNum n -> L.IntNum <$> shrink n+ L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)+ L.Chr c -> L.Chr <$> shrink c+ L.Str s -> L.Str <$> shrink s+ L.Boolean b -> L.Boolean <$> shrink b++noE :: Double -> Bool+noE = notElem 'e' . show++genVector :: Int -> (Int -> Gen a) -> Gen [a]+genVector n generator = do+ len <- choose (0,n)+ let m = n `div` (len + 1)+ vectorOf len $ generator m++instance Arbitrary P.Pattern where+ arbitrary = sized pat+ where+ pat :: Int -> Gen P.Pattern+ pat n =+ oneof+ [ pure P.Anything+ , P.Var <$> lowVar+ , P.Record <$> (listOf1 lowVar)+ , P.Literal <$> arbitrary+ , P.Alias <$> lowVar <*> pat (n-1)+ , P.Data <$> capVar <*> genVector n pat+ ]++ shrink pat =+ case pat of+ P.Anything -> []+ P.Var v -> P.Var <$> shrinkWHead v+ P.Literal l -> P.Literal <$> shrink l+ P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)+ P.Data s ps -> ps ++ (P.Data <$> shrinkWHead s <*> shrink ps)+ P.Record fs ->+ P.Record <$> filter (all notNull) (filter notNull (shrink fs))+ where+ notNull = not . null++shrinkWHead :: Arbitrary a => [a] -> [[a]]+shrinkWHead [] = error "Should be nonempty"+shrinkWHead (x:xs) = (x:) <$> shrink xs++instance Arbitrary T.Type where+ arbitrary = sized tipe+ where+ tipe :: Int -> Gen T.Type+ tipe n =+ let depthTipe = tipe =<< choose (0,n)+ field = (,) <$> lowVar <*> depthTipe+ fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)+ fields1 = (:) <$> field <*> fields+ in+ oneof+ [ T.Lambda <$> depthTipe <*> depthTipe+ , T.Var <$> lowVar+ , T.Data <$> capVar <*> genVector n tipe+ , T.Record <$> fields <*> pure Nothing+ , T.Record <$> fields1 <*> (Just <$> lowVar)+ ]++ shrink tipe =+ case tipe of+ T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)+ T.Var _ -> []+ T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)+ T.Record fs t -> map snd fs ++ record+ where+ record =+ case t of+ Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing+ Just _ ->+ do fields <- filter (not . null) $ shrinkList shrinkField fs+ return $ T.Record fields t++ shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t++lowVar :: Gen String+lowVar = notReserved $ (:) <$> lower <*> listOf varLetter+ where+ lower = elements ['a'..'z']++capVar :: Gen String+capVar = notReserved $ (:) <$> upper <*> listOf varLetter+ where+ upper = elements ['A'..'Z']++varLetter :: Gen Char+varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']++notReserved :: Gen String -> Gen String+notReserved = flip exceptFor Parse.Helpers.reserveds++exceptFor :: (Ord a) => Gen a -> [a] -> Gen a+exceptFor g xs = g `suchThat` notAnX+ where+ notAnX = flip Set.notMember xset+ xset = Set.fromList xs
− tests/hs/CompilerTest.hs
@@ -1,11 +0,0 @@-module Main where--import Test.Framework--import Tests.Compiler-import Tests.Property--main :: IO () -main = defaultMain [ compilerTests- , propertyTests- ]
− tests/hs/LibTest.hs
@@ -1,30 +0,0 @@-module Main where--import Control.Monad (unless)-import Data.List (isInfixOf)-import System.Directory-import System.Exit-import System.FilePath-import System.Process--import Elm.Internal.Paths as Elm--main :: IO ()-main = do- top <- getCurrentDirectory- let ioScript s = top</>"IO"</>s- runCmd "git submodule update --init"- out <- readProcess "npm" ["ls", "--parseable"] ""- unless ("jsdom" `isInfixOf` out) $ runCmd "npm install jsdom"- setCurrentDirectory $ top</>"tests"</>"elm"- 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"]- runCmd $ unwords ["cat ", ioScript "prescript.js", Elm.runtime, "build"</>"Test.js", ioScript "handler.js", "> exe.js"]- exitWith =<< waitForProcess =<< (runCommand "node exe.js")- where runCmd cmd = do- putStrLn cmd- exitCode <- waitForProcess =<< runCommand cmd- case exitCode of- ExitSuccess -> return ()- ExitFailure _ -> error "something went wrong"--
− tests/hs/Tests/Compiler.hs
@@ -1,45 +0,0 @@-module Tests.Compiler (compilerTests)- where--import Data.Functor ((<$>))-import Data.Traversable (traverse)-import System.FilePath ((</>))-import System.FilePath.Find (find, (==?), extension)-import Test.Framework-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (Assertion, assertFailure, assertBool)-import Text.Parsec (ParseError)--import Elm.Internal.Utils as Elm--compilerTests :: Test-compilerTests = buildTest $ do- goods <- mkTests goodCompile =<< getElms "good"- bads <- mkTests badCompile =<< getElms "bad"- return $ testGroup "Compile Tests"- [- testGroup "Good Tests" goods- , testGroup "Bad Tests" bads- ]-- where getElms :: FilePath -> IO [FilePath]- getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)-- mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]- mkTests h = traverse setupTest- where setupTest f = testCase f . mkCompileTest h <$> readFile f-- testsDir = "tests" </> "test-files"--goodCompile :: Either String String -> Assertion-goodCompile (Left err) = assertFailure err-goodCompile (Right _) = assertBool "" True--badCompile :: Either String String -> Assertion-badCompile (Left _) = assertBool "" True-badCompile (Right _) = assertFailure "Compilation succeeded but should have failed"- -mkCompileTest :: ((Either String String) -> Assertion) -- ^ Handler- -> String -- ^ File Contents- -> Assertion-mkCompileTest handle = handle . Elm.compile
− tests/hs/Tests/Property.hs
@@ -1,55 +0,0 @@-module Tests.Property where--import Control.Applicative ((<*))-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.HUnit (assert)-import Test.QuickCheck-import Text.Parsec.Combinator (eof)-import Text.PrettyPrint as P--import SourceSyntax.Literal as Lit-import qualified SourceSyntax.Pattern as P-import SourceSyntax.PrettyPrint (Pretty, pretty)-import Parse.Helpers (IParser, iParse)-import Parse.Literal (literal)-import qualified Parse.Pattern as Pat (expr)-import qualified Parse.Type as Type (expr)-import Tests.Property.Arbitrary--propertyTests :: Test-propertyTests =- testGroup "Parse/Print Agreement Tests"- [- testCase "Long Pattern test" $ assert (prop_parse_print Pat.expr longPat)- , testProperty "Literal test" $ prop_parse_print literal- , testProperty "Pattern test" $ prop_parse_print Pat.expr- , testProperty "Type test" $ prop_parse_print Type.expr- ]-- where- -- This test was autogenerated from the Pattern test and should be- -- left in all its ugly glory.- longPat = P.Data "I" [ P.Literal (Lit.Chr '+')- , P.Record- [ "q7yclkcm7k_ikstrczv_"- , "wQRv6gKsvvkjw4b5F"- ,"c9'eFfhk9FTvsMnwF_D"- ,"yqxhEkHvRFwZ"- ,"o"- ,"nbUlCn3y3NnkVoxhW"- ,"iJ0MNy3KZ_lrs"- ,"ug"- ,"sHHsX"- ,"mRKs9d"- ,"o2KiCX5'ZRzHJfRi8" ]- , P.Var "su'BrrbPUK6I33Eq"- ]--prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool-prop_parse_print p x =- either (const False) (== x) . parse_print p $ x--parse_print :: (Pretty a) => IParser a -> a -> Either String a-parse_print p = either (Left . show) Right . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty
− tests/hs/Tests/Property/Arbitrary.hs
@@ -1,128 +0,0 @@-{-# OPTIONS_GHC -W -fno-warn-orphans #-}-module Tests.Property.Arbitrary where--import Control.Applicative ((<$>), (<*>), pure)-import Test.QuickCheck.Arbitrary-import Test.QuickCheck.Gen--import qualified Data.Set as Set-import qualified Parse.Helpers (reserveds)--import qualified SourceSyntax.Literal as L-import qualified SourceSyntax.Pattern as P-import qualified SourceSyntax.Type as T--instance Arbitrary L.Literal where- arbitrary =- oneof- [ L.IntNum <$> arbitrary- , L.FloatNum <$> (arbitrary `suchThat` noE)- , L.Chr <$> arbitrary- -- This is too permissive- , L.Str <$> arbitrary- -- Booleans aren't actually source syntax - -- , Boolean <$> arbitrary- ]-- shrink lit =- case lit of- L.IntNum n -> L.IntNum <$> shrink n- L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)- L.Chr c -> L.Chr <$> shrink c- L.Str s -> L.Str <$> shrink s- L.Boolean b -> L.Boolean <$> shrink b--noE :: Double -> Bool-noE = notElem 'e' . show--genVector :: Int -> (Int -> Gen a) -> Gen [a]-genVector n generator = do- len <- choose (0,n)- let m = n `div` (len + 1)- vectorOf len $ generator m--instance Arbitrary P.Pattern where- arbitrary = sized pat- where- pat :: Int -> Gen P.Pattern- pat n =- oneof- [ pure P.Anything- , P.Var <$> lowVar- , P.Record <$> (listOf1 lowVar)- , P.Literal <$> arbitrary- , P.Alias <$> lowVar <*> pat (n-1)- , P.Data <$> capVar <*> genVector n pat- ]-- shrink pat =- case pat of- P.Anything -> []- P.Var v -> P.Var <$> shrinkWHead v- P.Literal l -> P.Literal <$> shrink l- P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)- P.Data s ps -> ps ++ (P.Data <$> shrinkWHead s <*> shrink ps)- P.Record fs ->- P.Record <$> filter (all notNull) (filter notNull (shrink fs))- where- notNull = not . null--shrinkWHead :: Arbitrary a => [a] -> [[a]]-shrinkWHead [] = error "Should be nonempty"-shrinkWHead (x:xs) = (x:) <$> shrink xs--instance Arbitrary T.Type where- arbitrary = sized tipe- where- tipe :: Int -> Gen T.Type- tipe n =- let depthTipe = tipe =<< choose (0,n)- field = (,) <$> lowVar <*> depthTipe- fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)- fields1 = (:) <$> field <*> fields- in- oneof- [ T.Lambda <$> depthTipe <*> depthTipe- , T.Var <$> lowVar- , T.Data <$> capVar <*> genVector n tipe- , T.Record <$> fields <*> pure Nothing- , T.Record <$> fields1 <*> (Just <$> lowVar)- ]-- shrink tipe =- case tipe of- T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)- T.Var _ -> []- T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)- T.Record fs t -> map snd fs ++ record- where- record =- case t of- Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing- Just _ ->- do fields <- filter (not . null) $ shrinkList shrinkField fs- return $ T.Record fields t-- shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t--lowVar :: Gen String-lowVar = notReserved $ (:) <$> lower <*> listOf varLetter- where- lower = elements ['a'..'z']--capVar :: Gen String-capVar = notReserved $ (:) <$> upper <*> listOf varLetter- where- upper = elements ['A'..'Z']--varLetter :: Gen Char-varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']--notReserved :: Gen String -> Gen String-notReserved = flip exceptFor Parse.Helpers.reserveds--exceptFor :: (Ord a) => Gen a -> [a] -> Gen a-exceptFor g xs = g `suchThat` notAnX- where- notAnX = flip Set.notMember xset- xset = Set.fromList xs
+ tests/libraries/LibraryTest.hs view
@@ -0,0 +1,49 @@+module Main where++import Control.Monad (unless)+import Data.List (isInfixOf)+import System.Directory+import System.Exit+import System.FilePath+import System.Process++import Elm.Internal.Paths as Elm++main :: IO ()+main = do+ top <- getCurrentDirectory++ -- setup submodules and npm+ runCmd "git" ["submodule", "update", "--init"]+ out <- readProcess "npm" ["ls", "--parseable"] ""+ unless ("jsdom" `isInfixOf` out) $ runCmd "npm" ["install","jsdom"]++ -- setup actual library tests+ setCurrentDirectory $ top </> "tests" </> "libraries"+ let localCompiler = joinPath [ top, "dist", "build", "elm", "elm" ]+ runCmd localCompiler [ "--make"+ , "--only-js"+ , "--src-dir=" ++ top </> "automaton"+ , "--src-dir=" ++ top </> "IO"+ , "--src-dir=" ++ top </> "Elm-Test"+ , "Test.elm"+ ]++ -- run tests+ let ioScript s = top </> "IO" </> s+ files = [ ioScript "prescript.js"+ , Elm.runtime+ , "build" </> "Test.js"+ , ioScript "handler.js"+ ]+ exe <- readProcess "cat" files ""+ writeFile "exe.js" exe+ exitWith =<< waitForProcess =<< (runCommand "node exe.js")++runCmd :: String -> [String] -> IO ()+runCmd cmd args = do+ putStrLn (cmd ++ " " ++ unwords args)+ (exitCode, _stdout, stderr) <- readProcessWithExitCode cmd args ""+ case exitCode of+ ExitSuccess -> return ()+ ExitFailure _ -> error stderr