on master help sign in
Merge branch 'dev'
commitb65bf8ccc91cd8d29ad79276faa7c7ddb316a9c6 authorEvan Czaplicki <info@elm-lang.org> dateFri 21 Mar 2014, 15:29 (13 years ago) parenta5ee99d92af8a4
94 files changed+2514−1973
Elm.cabal+14−13 Setup.hs+2−1 changelog.txt → changelog.md+31−3 compiler/Build/Dependencies.hs+30−22 compiler/Build/Source.hs+1−2 compiler/Build/Utils.hs+14 compiler/Docs.hs+42−18 compiler/Elm/Internal/Paths.hs+5−4 compiler/Generate/Cases.hs+32−31 compiler/Generate/JavaScript.hs+63−54 compiler/Generate/JavaScript/Ports.hs+23−17 compiler/Generate/Noscript.hs−68 compiler/Metadata/Prelude.hs+7−7 compiler/Parse/Binop.hs+17−16 compiler/Parse/Expression.hs+69−68 compiler/Parse/Helpers.hs+22−18 compiler/Parse/Literal.hs+30−12 compiler/Parse/Module.hs+15−10 compiler/Parse/Pattern.hs+29−27 compiler/SourceSyntax/Annotation.hs+74 compiler/SourceSyntax/Declaration.hs+2−2 compiler/SourceSyntax/Expression.hs+88−62 compiler/SourceSyntax/Helpers.hs+9 compiler/SourceSyntax/Location.hs−58 compiler/SourceSyntax/Module.hs+33−3 compiler/SourceSyntax/Pattern.hs+30−26 compiler/SourceSyntax/PrettyPrint.hs+5 compiler/SourceSyntax/Type.hs+3−6 compiler/SourceSyntax/Variable.hs+11 compiler/Transform/Canonicalize.hs+30−22 compiler/Transform/Check.hs+4−5 compiler/Transform/Declaration.hs+1−1 compiler/Transform/Definition.hs+1−1 compiler/Transform/Expression.hs+15−13 compiler/Transform/SafeNames.hs+21−16 compiler/Transform/SortDefinitions.hs+18−17 compiler/Transform/Substitute.hs+8−6 compiler/Type/Constrain/Declaration.hs+23−23 compiler/Type/Constrain/Expression.hs+38−37 compiler/Type/Constrain/Literal.hs+5−4 compiler/Type/Constrain/Pattern.hs+17−18 compiler/Type/ExtraChecks.hs+39−36 compiler/Type/Fragment.hs+12−13 compiler/Type/Inference.hs+1−1 compiler/Type/Solve.hs+19−19 compiler/Type/State.hs+12−20 compiler/Type/Type.hs+19−12 compiler/Type/Unify.hs+15−15 libraries/Automaton.elm.hidden−123 libraries/AutomatonV2.elm.hidden−149 libraries/Basics.elm+27 libraries/Date.elm+5−1 libraries/Debug.elm+17 libraries/Dict.elm+3−4 libraries/Either.elm+26−4 libraries/Graphics/Collage.elm+1−1 libraries/Graphics/Element.elm+7−4 libraries/Graphics/Input.elm+146−167 libraries/Graphics/Input/Field.elm+170 libraries/Http.elm+1−1 libraries/Json.elm+1−1 libraries/List.elm+1−1 libraries/Maybe.elm+21−3 libraries/Mouse.elm+1−6 libraries/Native/Basics.js+3 libraries/Native/Bitwise.js+6−6 libraries/Native/Color.js+9−2 libraries/Native/Date.js+1 libraries/Native/Debug.js+24 libraries/Native/Graphics/Input.js+403−299 libraries/Native/Regex.js+11−20 libraries/Native/Show.js−3 libraries/Native/Signal/Http.js+52−49 libraries/Native/Signal/Mouse.js+2−6 libraries/Native/Signal/Signal.js−9 libraries/Native/String.js+3−2 libraries/Native/Text.js+58−42 libraries/Native/Trampoline.js+24 libraries/Native/Utils.js+6−8 libraries/Prelude.elm−8 libraries/Regex.elm+49−56 libraries/Signal.elm+7−2 libraries/String.elm+33−6 libraries/Text.elm+157−45 libraries/Time.elm+1−1 libraries/Trampoline.elm+49 libraries/elm_dependencies.json+6−3 runtime/HotSwap.js+2−2 runtime/Init.js+1−1 runtime/Render/Collage.js+1 runtime/Render/Element.js+71−18 server/elm-server.cabal+1−1 tests/Tests/Property.hs+17−16 tests/Tests/Property/Arbitrary.hs+91−76
Elm.cabal+14−13
@@ -1,5 +1,5 @@
11Name: Elm
2−Version: 0.11
2+Version: 0.12
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
@@ -14,7 +14,7 @@ License-file: LICENSE
1414
1515Author: Evan Czaplicki
1616Maintainer: info@elm-lang.org
17−Copyright: Copyright: (c) 2011-2013 Evan Czaplicki
17+Copyright: Copyright: (c) 2011-2014 Evan Czaplicki
1818
1919Category: Compiler, Language
2020
@@ -37,19 +37,19 @@ Library
3737 Elm.Internal.Utils,
3838 Elm.Internal.Version
3939 Hs-Source-Dirs: compiler
40− other-modules: SourceSyntax.Declaration,
40+ other-modules: SourceSyntax.Annotation,
41+ SourceSyntax.Declaration,
4142 SourceSyntax.Expression,
4243 SourceSyntax.Helpers,
4344 SourceSyntax.Literal,
44− SourceSyntax.Location,
4545 SourceSyntax.Module,
4646 SourceSyntax.Pattern,
4747 SourceSyntax.PrettyPrint,
4848 SourceSyntax.Type,
49+ SourceSyntax.Variable,
4950 Generate.JavaScript,
5051 Generate.JavaScript.Helpers,
5152 Generate.JavaScript.Ports,
52− Generate.Noscript,
5353 Generate.Markdown,
5454 Generate.Html,
5555 Generate.Cases,
@@ -97,7 +97,7 @@ Library
9797 Build-depends: aeson,
9898 base >=4.2 && <5,
9999 binary >= 0.6.4.0,
100− blaze-html == 0.5.* || == 0.6.*,
100+ blaze-html >= 0.5 && < 0.8,
101101 blaze-markup,
102102 bytestring,
103103 cmdargs,
@@ -119,19 +119,19 @@ Executable elm
119119 Main-is: Compiler.hs
120120 ghc-options: -threaded -O2
121121 Hs-Source-Dirs: compiler
122− other-modules: SourceSyntax.Declaration,
122+ other-modules: SourceSyntax.Annotation,
123+ SourceSyntax.Declaration,
123124 SourceSyntax.Expression,
124125 SourceSyntax.Helpers,
125126 SourceSyntax.Literal,
126− SourceSyntax.Location,
127127 SourceSyntax.Module,
128128 SourceSyntax.Pattern,
129129 SourceSyntax.PrettyPrint,
130130 SourceSyntax.Type,
131+ SourceSyntax.Variable,
131132 Generate.JavaScript,
132133 Generate.JavaScript.Helpers,
133134 Generate.JavaScript.Ports,
134− Generate.Noscript,
135135 Generate.Markdown,
136136 Generate.Html,
137137 Generate.Cases,
@@ -179,8 +179,8 @@ Executable elm
179179 Build-depends: aeson,
180180 base >=4.2 && <5,
181181 binary >= 0.6.4.0,
182− blaze-html == 0.5.* || == 0.6.*,
183− blaze-markup == 0.5.1.*,
182+ blaze-html >= 0.5 && < 0.8,
183+ blaze-markup,
184184 bytestring,
185185 cmdargs,
186186 containers >= 0.3,
@@ -200,15 +200,16 @@ Executable elm
200200Executable elm-doc
201201 Main-is: Docs.hs
202202 Hs-Source-Dirs: compiler
203− other-modules: SourceSyntax.Declaration,
203+ other-modules: SourceSyntax.Annotation,
204+ SourceSyntax.Declaration,
204205 SourceSyntax.Expression,
205206 SourceSyntax.Helpers,
206207 SourceSyntax.Literal,
207− SourceSyntax.Location,
208208 SourceSyntax.Module,
209209 SourceSyntax.Pattern,
210210 SourceSyntax.PrettyPrint,
211211 SourceSyntax.Type,
212+ SourceSyntax.Variable,
212213 Parse.Binop,
213214 Parse.Declaration,
214215 Parse.Expression,
Setup.hs+2−1
@@ -148,7 +148,8 @@ buildRuntime :: LocalBuildInfo -> [FilePath] -> IO ()
148148buildRuntime lbi elmos = do
149149 createDirectoryIfMissing True (rtsDir lbi)
150150 let rts' = rts lbi
151− writeFile rts' "var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
151+ writeFile rts' "'use strict';\n\
152+ \var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
152153 \var ElmRuntime = {}; ElmRuntime.Render = {};\n"
153154 mapM_ (appendTo rts') =<< getFiles ".js" "libraries"
154155 mapM_ (appendTo rts') elmos
changelog.txt → changelog.mdrenamed+31−3
@@ -1,10 +1,38 @@
11
2+## 0.12
3+
4+#### Breaking Changes:
5+
6+ * Overhaul Graphics.Input library (inspired by Spiros Eliopoulos and Jeff Smitts)
7+ * Overhaul Text library to accomodate new Graphics.Input.Field
8+ library and make the API more consistent overall
9+ * Overhaul Regex library (inspired by Attila Gazso)
10+ * Change syntax for "import open List" to "import List (..)"
11+ * Improved JSON format for types generated by elm-doc
12+ * Remove problematic Mouse.isClicked signal
13+ * Revise the semantics of keepWhen and dropWhen to only update when
14+ the filtered signal changes (thanks Max New and Janis Voigtländer)
15+
16+#### Improvements:
17+
18+ * Add Graphics.Input.Field for customizable text fields
19+ * Add Trampoline library (thanks to @maxsnew and @timthelion)
20+ * Add Debug library (inspired by @timthelion)
21+ * Drastically improved performance on markdown parsing (thanks to @Dandandan)
22+ * Add Date.fromTime function
23+ * Use pointer-events to detect hovers on layered elements (thanks to @Xashili)
24+ * Fix bugs in Bitwise library
25+ * Fix bug when exporting Maybe values through ports
26+
227## 0.11
328
4− * Lazy and Lazy.Stream (thanks to Max New)
5− * sortBy, sortWith (thanks to Max Goldstein)
29+ * Ports, a new FFI that is more general and much nicer to use
30+ * Basic compiler tests (thanks to Max New)
31+
32+## 0.10.1
33+
34+ * sort, sortBy, sortWith (thanks to Max Goldstein)
635 * elm-repl
7− * Markdown interpolation
836 * Bitwise library
937 * Regex library
1038 * Improve Transform2D library (thanks to Michael Søndergaard)
compiler/Build/Dependencies.hs+30−22
@@ -29,10 +29,7 @@ getSortedDependencies srcDirs builtIns root =
2929 result <- runErrorT $ readAllDeps allSrcDirs builtIns root
3030 case result of
3131 Right deps -> sortDeps deps
32− Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg
33− where msg = "\nYou may need to create a " ++
34− Path.dependencyFile ++
35− " file if you\nare trying to use a 3rd party library."
32+ Left err -> failure err
3633
3734extraDependencies :: IO (Maybe [FilePath])
3835extraDependencies =
@@ -75,20 +72,22 @@ sortDeps depends =
7572 msg = "A cyclical module dependency or was detected in:\n"
7673
7774readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
78−readAllDeps srcDirs builtIns root =
79− do let ifaces = (Set.fromList . Map.keys) builtIns
80− State.evalStateT (go ifaces root) Set.empty
75+readAllDeps srcDirs rawBuiltIns filePath =
76+ State.evalStateT (go Nothing filePath) Set.empty
8177 where
82− go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
83− go builtIns root = do
84− root' <- lift $ findSrcFile srcDirs root
85− (name, deps) <- lift $ readDeps root'
78+ builtIns :: Set.Set String
79+ builtIns = Set.fromList $ Map.keys rawBuiltIns
80+
81+ go :: Maybe String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
82+ go parentModuleName filePath = do
83+ filePath' <- lift $ findSrcFile parentModuleName srcDirs filePath
84+ (moduleName, deps) <- lift $ readDeps filePath'
8685 seen <- State.get
8786 let realDeps = Set.difference (Set.fromList deps) builtIns
8887 newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
89− State.put (Set.insert name (Set.union newDeps seen))
90− rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
91− return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
88+ State.put (Set.insert moduleName (Set.union newDeps seen))
89+ rest <- mapM (go (Just moduleName) . toFilePath) (Set.toList newDeps)
90+ return ((makeRelative "." filePath', moduleName, Set.toList realDeps) : concat rest)
9291
9392readDeps :: FilePath -> ErrorT String IO (String, [String])
9493readDeps path = do
@@ -98,15 +97,10 @@ readDeps path = do
9897 where msg = "Error resolving dependencies in " ++ path ++ ":\n"
9998 Right o -> return o
10099
101−findSrcFile :: [FilePath] -> FilePath -> ErrorT String IO FilePath
102−findSrcFile dirs path = foldr tryDir notFound dirs
100+findSrcFile :: Maybe String -> [FilePath] -> FilePath -> ErrorT String IO FilePath
101+findSrcFile parentModuleName dirs path =
102+ foldr tryDir notFound dirs
103103 where
104− notFound = throwError $ unlines
105− [ "Could not find file: " ++ path
106− , " If it is not in the root directory of your project, use"
107− , " --src-dir to declare additional locations for source files."
108− , " If it is part of a 3rd party library, it needs to be declared"
109− , " as a dependency in the " ++ Path.dependencyFile ++ " file." ]
110104 tryDir dir next = do
111105 let path' = dir </> path
112106 exists <- liftIO $ doesFileExist path'
@@ -114,6 +108,20 @@ findSrcFile dirs path = foldr tryDir notFound dirs
114108 then return path'
115109 else next
116110
111+ parentModuleName' =
112+ case parentModuleName of
113+ Just name -> "module '" ++ name ++ "'"
114+ Nothing -> "the main module"
115+
116+ notFound = throwError $ unlines
117+ [ "When finding the imports declared in " ++ parentModuleName' ++ ", could not find file: " ++ path
118+ , " If you created this module, but it is in a subdirectory that does not"
119+ , " exactly match the module name, you may need to use the --src-dir flag."
120+ , ""
121+ , " If it is part of a 3rd party library, it needs to be declared"
122+ , " as a dependency in your project's " ++ Path.dependencyFile ++ " file."
123+ ]
124+
117125isNative :: String -> Bool
118126isNative name = List.isPrefixOf "Native." name
119127
compiler/Build/Source.hs+1−2
@@ -2,7 +2,6 @@
22module Build.Source (build) where
33
44import qualified Data.Map as Map
5−import qualified Data.Set as Set
65import System.FilePath as FP
76import Text.PrettyPrint (Doc)
87
@@ -33,7 +32,7 @@ build noPrelude interfaces source =
3332
3433 let exports'
3534 | null exs =
36− let get = Set.toList . Pattern.boundVars in
35+ let get = Pattern.boundVarList in
3736 concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++
3837 concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++
3938 [ name | TypeAlias name _ (Type.Record _ _) <- decls ]
compiler/Build/Utils.hs+14
@@ -1,8 +1,11 @@
11{-# OPTIONS_GHC -W #-}
22module Build.Utils where
33
4+import System.Directory (doesFileExist)
5+import System.Environment (getEnv)
46import System.FilePath ((</>), replaceExtension)
57import qualified Build.Flags as Flag
8+import qualified Paths_Elm as This
69
710buildPath :: Flag.Flags -> FilePath -> String -> FilePath
811buildPath flags filePath ext =
@@ -19,3 +22,14 @@ elmo flags filePath =
1922elmi :: Flag.Flags -> FilePath -> FilePath
2023elmi flags filePath =
2124 cachePath flags filePath "elmi"
25+
26+-- |The absolute path to a data file
27+getDataFile :: FilePath -> IO FilePath
28+getDataFile name = do
29+ path <- This.getDataFileName name
30+ exists <- doesFileExist path
31+ if exists
32+ then return path
33+ else do
34+ env <- getEnv "ELM_HOME"
35+ return (env </> name)
compiler/Docs.hs+42−18
@@ -8,6 +8,7 @@ import System.Exit
88import System.IO
99
1010import Control.Applicative ((<$>))
11+import Control.Arrow (second)
1112import Data.Aeson
1213import Data.Aeson.Encode.Pretty
1314import qualified Data.List as List
@@ -15,8 +16,8 @@ import qualified Data.Map as Map
1516import qualified Data.ByteString.Lazy as BS
1617import qualified Data.Text as Text
1718
18−import SourceSyntax.Helpers (isSymbol)
19−import SourceSyntax.Type (Type(..))
19+import qualified SourceSyntax.Helpers as Help
20+import qualified SourceSyntax.Type as T
2021import qualified SourceSyntax.Expression as E
2122import qualified SourceSyntax.Declaration as D
2223
@@ -30,20 +31,24 @@ data Flags = Flags
3031 { files :: [FilePath] }
3132 deriving (Data,Typeable,Show,Eq)
3233
34+defaultFlags :: Flags
3335defaultFlags = Flags
3436 { files = def &= args &= typ "FILES"
3537 } &= help "Generate documentation for Elm"
3638 &= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
3739
40+main :: IO ()
3841main = do
3942 flags <- cmdArgs defaultFlags
40− mapM parseFile (files flags)
43+ mapM_ parseFile (files flags)
4144
45+config :: Config
4246config = Config { confIndent = 2, confCompare = keyOrder keys }
4347 where
44− keys = ["name","document","comment","raw","aliases","datatypes"
48+ keys = ["tag","name","document","comment","raw","aliases","datatypes"
4549 ,"values","typeVariables","type","constructors"]
4650
51+parseFile :: FilePath -> IO ()
4752parseFile path = do
4853 source <- readFile path
4954 case iParse docs source of
@@ -69,6 +74,7 @@ docComment = do
6974 let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
7075 return $ dropWhile (==' ') (reverse reversed)
7176
77+moduleDocs :: IParser (String, [String], String)
7278moduleDocs = do
7379 optional freshLine
7480 (names,exports) <- moduleDef
@@ -121,7 +127,7 @@ collect infixes types aliases adts things =
121127 where
122128 nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
123129 addDefaultInfix name pairs
124− | all isSymbol name = addInfix (D.L, 9 :: Int) pairs
130+ | all Help.isSymbol name = addInfix (D.L, 9 :: Int) pairs
125131 | otherwise = pairs
126132
127133 customOps = Map.intersectionWith addInfix infixes types
@@ -138,7 +144,7 @@ collect infixes types aliases adts things =
138144 let fields = ["typeVariables" .= vars, "type" .= tipe ]
139145 in collect infixes types (insert name fields aliases) adts rest
140146 D.Datatype name vars ctors ->
141− let tipe = Data name (map Var vars)
147+ let tipe = T.Data name (map T.Var vars)
142148 fields = ["typeVariables" .= vars
143149 , "constructors" .= map (ctorToJson tipe) ctors ]
144150 in collect infixes types aliases (insert name fields adts) rest
@@ -147,17 +153,35 @@ collect infixes types aliases adts things =
147153 obj name fields =
148154 [ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
149155
150−instance ToJSON Type where
151− toJSON tipe =
152− case tipe of
153− Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
154− Var x -> toJSON x
155− Data name ts -> toJSON (toJSON name : map toJSON ts)
156− Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
157− where fields' = case ext of
158− Nothing -> fields
159− Just x -> ("_", Var x) : fields
160−
156+instance ToJSON T.Type where
157+ toJSON tipe =
158+ object $
159+ case tipe of
160+ T.Lambda _ _ ->
161+ let tipes = T.collectLambdas tipe in
162+ [ "tag" .= ("function" :: Text.Text)
163+ , "args" .= toJSON (init tipes)
164+ , "result" .= toJSON (last tipes)
165+ ]
166+
167+ T.Var x ->
168+ [ "tag" .= ("var" :: Text.Text)
169+ , "name" .= toJSON x
170+ ]
171+
172+ T.Data name ts ->
173+ [ "tag" .= ("adt" :: Text.Text)
174+ , "name" .= toJSON name
175+ , "args" .= map toJSON ts
176+ ]
177+
178+ T.Record fields ext ->
179+ [ "tag" .= ("record" :: Text.Text)
180+ , "fields" .= toJSON (map (toJSON . second toJSON) fields)
181+ , "extension" .= toJSON ext
182+ ]
183+
184+ctorToJson :: T.Type -> (String, [T.Type]) -> Value
161185ctorToJson tipe (ctor, tipes) =
162186 object [ "name" .= ctor
163− , "type" .= foldr Lambda tipe tipes ]
187+ , "type" .= foldr T.Lambda tipe tipes ]
compiler/Elm/Internal/Paths.hs+5−4
@@ -1,7 +1,8 @@
1+{-# OPTIONS_GHC -Wall #-}
12module Elm.Internal.Paths where
23
3−import System.IO.Unsafe
4−import qualified Paths_Elm as This
4+import Build.Utils (getDataFile)
5+import System.IO.Unsafe (unsafePerformIO)
56
67-- |Name of directory for all of a project's dependencies.
78dependencyDirectory :: FilePath
@@ -15,9 +16,9 @@ dependencyFile = "elm_dependencies.json"
1516{-# NOINLINE runtime #-}
1617-- |The absolute path to Elm's runtime system.
1718runtime :: FilePath
18−runtime = unsafePerformIO $ This.getDataFileName "elm-runtime.js"
19+runtime = unsafePerformIO $ getDataFile "elm-runtime.js"
1920
2021{-# NOINLINE docs #-}
2122-- |The absolute path to Elm's core library documentation.
2223docs :: FilePath
23−docs = unsafePerformIO $ This.getDataFileName "docs.json"
24+docs = unsafePerformIO $ getDataFile "docs.json"
compiler/Generate/Cases.hs+32−31
@@ -6,14 +6,15 @@ import Control.Monad.State
66import Data.List (groupBy,sortBy)
77import Data.Maybe (fromMaybe)
88
9−import SourceSyntax.Location
10−import SourceSyntax.Literal
11−import SourceSyntax.Pattern
9+import SourceSyntax.Annotation
1210import SourceSyntax.Expression
11+import SourceSyntax.Literal
12+import qualified SourceSyntax.Pattern as P
13+import qualified SourceSyntax.Variable as V
1314import Transform.Substitute
1415
1516
16−toMatch :: [(Pattern, LExpr)] -> State Int (String, Match)
17+toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)
1718toMatch patterns = do
1819 v <- newVar
1920 (,) v <$> match [v] (map (first (:[])) patterns) Fail
@@ -27,7 +28,7 @@ data Match
2728 = Match String [Clause] Match
2829 | Break
2930 | Fail
30− | Other LExpr
31+ | Other Expr
3132 | Seq [Match]
3233 deriving Show
3334
@@ -39,8 +40,8 @@ matchSubst :: [(String,String)] -> Match -> Match
3940matchSubst _ Break = Break
4041matchSubst _ Fail = Fail
4142matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
42−matchSubst pairs (Other (L s e)) =
43− Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
43+matchSubst pairs (Other (A a e)) =
44+ Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs
4445matchSubst pairs (Match n cs m) =
4546 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
4647 where varSubst v = fromMaybe v (lookup v pairs)
@@ -49,13 +50,13 @@ matchSubst pairs (Match n cs m) =
4950
5051isCon (p:_, _) =
5152 case p of
52− PData _ _ -> True
53− PLiteral _ -> True
54− _ -> False
53+ P.Data _ _ -> True
54+ P.Literal _ -> True
55+ _ -> False
5556
5657isVar p = not (isCon p)
5758
58−match :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
59+match :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
5960match [] [] def = return def
6061match [] [([],e)] Fail = return $ Other e
6162match [] [([],e)] Break = return $ Other e
@@ -67,46 +68,46 @@ match vs@(v:_) cs def
6768 where
6869 cs' = map (dealias v) cs
6970
70−dealias v c@(p:ps, L s e) =
71+dealias v c@(p:ps, A a e) =
7172 case p of
72− PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)
73+ P.Alias x pattern -> (pattern:ps, A a $ subst x (rawVar v) e)
7374 _ -> c
7475
75−matchVar :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
76+matchVar :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
7677matchVar (v:vs) cs def = match vs (map subVar cs) def
7778 where
78− subVar (p:ps, (L s e)) = (ps, L s $ subOnePattern p e)
79+ subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)
7980 where
8081 subOnePattern pattern e =
8182 case pattern of
82− PVar x -> subst x (Var v) e
83− PAnything -> e
84− PRecord fs ->
85− foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
83+ P.Var x -> subst x (rawVar v) e
84+ P.Anything -> e
85+ P.Record fs ->
86+ foldr (\x -> subst x (Access (A a (rawVar v)) x)) e fs
8687
87−matchCon :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
88+matchCon :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
8889matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
8990 where
9091 css = groupBy eq (sortBy cmp cs)
9192
9293 cmp (p1:_,_) (p2:_,_) =
9394 case (p1,p2) of
94− (PData n1 _, PData n2 _) -> compare n1 n2
95+ (P.Data n1 _, P.Data n2 _) -> compare n1 n2
9596 _ -> compare p1 p2
9697
9798 eq (p1:_,_) (p2:_,_) =
9899 case (p1,p2) of
99− (PData n1 _, PData n2 _) -> n1 == n2
100+ (P.Data n1 _, P.Data n2 _) -> n1 == n2
100101 _ -> p1 == p2
101102
102103 toClause cs =
103104 case head cs of
104− (PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
105− (PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
105+ (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
106+ (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
106107
107108matchClause :: Either String Literal
108109 -> [String]
109− -> [([Pattern],LExpr)]
110+ -> [([P.Pattern],Expr)]
110111 -> Match
111112 -> State Int Clause
112113matchClause c (_:vs) cs def =
@@ -116,14 +117,14 @@ matchClause c (_:vs) cs def =
116117
117118 flatten (p:ps, e) =
118119 case p of
119− PData _ ps' -> (ps' ++ ps, e)
120− PLiteral _ -> (ps, e)
120+ P.Data _ ps' -> (ps' ++ ps, e)
121+ P.Literal _ -> (ps, e)
121122
122123 getVars =
123124 case head cs of
124− (PData _ ps : _, _) -> forM ps (const newVar)
125− (PLiteral _ : _, _) -> return []
125+ (P.Data _ ps : _, _) -> forM ps (const newVar)
126+ (P.Literal _ : _, _) -> return []
126127
127−matchMix :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
128+matchMix :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
128129matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
129− where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
130+ where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
compiler/Generate/JavaScript.hs+63−54
@@ -1,25 +1,27 @@
11{-# OPTIONS_GHC -W #-}
22module Generate.JavaScript (generate) where
33
4−import Control.Arrow (first,(***))
54import Control.Applicative ((<$>),(<*>))
5+import Control.Arrow (first,(***))
66import Control.Monad.State
77import qualified Data.List as List
88import qualified Data.Map as Map
99import qualified Data.Set as Set
10+import Language.ECMAScript3.PrettyPrint
11+import Language.ECMAScript3.Syntax
1012
1113import Generate.JavaScript.Helpers
1214import qualified Generate.Cases as Case
1315import qualified Generate.JavaScript.Ports as Port
1416import qualified Generate.Markdown as MD
17+import SourceSyntax.Annotation
18+import SourceSyntax.Expression
1519import qualified SourceSyntax.Helpers as Help
1620import SourceSyntax.Literal
17−import SourceSyntax.Pattern as Pattern
18−import SourceSyntax.Location
19−import SourceSyntax.Expression
2021import SourceSyntax.Module
21−import Language.ECMAScript3.Syntax
22−import Language.ECMAScript3.PrettyPrint
22+import qualified SourceSyntax.Pattern as P
23+import SourceSyntax.PrettyPrint (renderPretty)
24+import qualified SourceSyntax.Variable as V
2325import qualified Transform.SafeNames as MakeSafe
2426
2527varDecl :: String -> Expression () -> VarDecl ()
@@ -50,10 +52,10 @@ literal lit =
5052 FloatNum n -> NumLit () n
5153 Boolean b -> BoolLit () b
5254
53−expression :: LExpr -> State Int (Expression ())
54−expression (L span expr) =
55+expression :: Expr -> State Int (Expression ())
56+expression (A region expr) =
5557 case expr of
56− Var x -> return $ ref x
58+ Var (V.Raw x) -> return $ obj x
5759 Literal lit -> return $ literal lit
5860
5961 Range lo hi ->
@@ -85,17 +87,16 @@ expression (L span expr) =
8587 do fields' <- forM fields $ \(f,e) -> do
8688 (,) f <$> expression e
8789 let fieldMap = List.foldl' combine Map.empty fields'
88− return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
90+ return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
8991 where
9092 combine r (k,v) = Map.insertWith (++) k [v] r
91− prop = PropId () . var
9293 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
9394 Map.toList . Map.filter (not . null) $ Map.map tail fs
9495 visible fs = map (first prop) . Map.toList $ Map.map head fs
9596
96− Binop op e1 e2 -> binop span op e1 e2
97+ Binop op e1 e2 -> binop region op e1 e2
9798
98− Lambda p e@(L s _) ->
99+ Lambda p e@(A ann _) ->
99100 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
100101 body' <- expression body
101102 return $ case length args < 2 || length args > 9 of
@@ -104,13 +105,14 @@ expression (L span expr) =
104105 where
105106 depattern (args, body) pattern =
106107 case pattern of
107− PVar x -> return (args ++ [x], body)
108+ P.Var x -> return (args ++ [x], body)
108109 _ -> do arg <- Case.newVar
109− return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
110+ return ( args ++ [arg]
111+ , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))
110112
111113 (patterns, innerBody) = collect [p] e
112114
113− collect patterns lexpr@(L _ expr) =
115+ collect patterns lexpr@(A _ expr) =
114116 case expr of
115117 Lambda p e -> collect (p:patterns) e
116118 _ -> (patterns, lexpr)
@@ -127,7 +129,7 @@ expression (L span expr) =
127129 (func, args) = getArgs e1 [e2]
128130 getArgs func args =
129131 case func of
130− (L _ (App f arg)) -> getArgs f (arg : args)
132+ (A _ (App f arg)) -> getArgs f (arg : args)
131133 _ -> (func, args)
132134
133135 Let defs e ->
@@ -139,9 +141,9 @@ expression (L span expr) =
139141 MultiIf branches ->
140142 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
141143 return $ case last branches of
142− (L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
143− (L _ (Literal (Boolean True)), _) -> safeIfs branches'
144− _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
144+ (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
145+ (A _ (Literal (Boolean True)), _) -> safeIfs branches'
146+ _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
145147 where
146148 safeIfs branches = ifs (init branches) (snd (last branches))
147149 ifs branches finally = foldr iff finally branches
@@ -151,10 +153,12 @@ expression (L span expr) =
151153 do (tempVar,initialMatch) <- Case.toMatch cases
152154 (revisedMatch, stmt) <-
153155 case e of
154− L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
155− _ -> do e' <- expression e
156− return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
157− match' <- match span revisedMatch
156+ A _ (Var (V.Raw x)) ->
157+ return (Case.matchSubst [(tempVar,x)] initialMatch, [])
158+ _ ->
159+ do e' <- expression e
160+ return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
161+ match' <- match region revisedMatch
158162 return (function [] (stmt ++ match') `call` [])
159163
160164 ExplicitList es ->
@@ -184,28 +188,28 @@ expression (L span expr) =
184188 [ string name, Port.outgoing tipe, value' ]
185189
186190definition :: Def -> State Int [Statement ()]
187−definition (Definition pattern expr@(L span _) _) = do
191+definition (Definition pattern expr@(A region _) _) = do
188192 expr' <- expression expr
189193 let assign x = varDecl x expr'
190194 case pattern of
191− PVar x
195+ P.Var x
192196 | Help.isOp x ->
193197 let op = LBracket () (ref "_op") (string x) in
194198 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
195199 | otherwise ->
196200 return [ VarDeclStmt () [ assign x ] ]
197201
198− PRecord fields ->
202+ P.Record fields ->
199203 let setField f = varDecl f (dotSep ["$",f]) in
200204 return [ VarDeclStmt () (assign "$" : map setField fields) ]
201205
202− PData name patterns | vars /= Nothing ->
206+ P.Data name patterns | vars /= Nothing ->
203207 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
204208 where
205209 vars = getVars patterns
206210 getVars patterns =
207211 case patterns of
208− PVar x : rest -> (x:) `fmap` getVars rest
212+ P.Var x : rest -> (x:) `fmap` getVars rest
209213 [] -> Just []
210214 _ -> Nothing
211215
@@ -216,41 +220,45 @@ definition (Definition pattern expr@(L span _) _) = do
216220
217221 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
218222 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
219− exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
223+ exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
220224
221225 _ ->
222226 do defs' <- concat <$> mapM toDef vars
223227 return (VarDeclStmt () [assign "$"] : defs')
224228 where
225− vars = Set.toList $ Pattern.boundVars pattern
226− mkVar = L span . Var
227− toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
228− in definition $ Definition (PVar y) expr Nothing
229+ vars = P.boundVarList pattern
230+ mkVar = A region . rawVar
231+ toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
232+ in definition $ Definition (P.Var y) expr Nothing
229233
230−match :: SrcSpan -> Case.Match -> State Int [Statement ()]
231−match span mtch =
234+match :: Region -> Case.Match -> State Int [Statement ()]
235+match region mtch =
232236 case mtch of
233237 Case.Match name clauses mtch' ->
234− do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
235− mtch'' <- match span mtch'
238+ do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
239+ mtch'' <- match region mtch'
236240 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
237241 where
238242 isLiteral p = case p of
239243 Case.Clause (Right _) _ _ -> True
240244 _ -> False
241− access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
245+
246+ access name
247+ | any isLiteral clauses = obj name
248+ | otherwise = dotSep (split name ++ ["ctor"])
249+
242250 format isChars e
243251 | or isChars = InfixExpr () OpAdd e (string "")
244252 | otherwise = e
245253
246254 Case.Fail ->
247− return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
255+ return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
248256
249257 Case.Break -> return [BreakStmt () Nothing]
250258 Case.Other e ->
251259 do e' <- expression e
252260 return [ ret e' ]
253− Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
261+ Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
254262 where
255263 dropEnd acc [] = acc
256264 dropEnd acc (m:ms) =
@@ -258,9 +266,9 @@ match span mtch =
258266 Case.Other _ -> acc ++ [m]
259267 _ -> dropEnd (acc ++ [m]) ms
260268
261−clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
262−clause span variable (Case.Clause value vars mtch) =
263− (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
269+clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
270+clause region variable (Case.Clause value vars mtch) =
271+ (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
264272 where
265273 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
266274 (isChar, pattern) =
@@ -273,8 +281,8 @@ clause span variable (Case.Clause value vars mtch) =
273281 [] -> name
274282 is -> drop (last is + 1) name
275283
276−flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
277−flattenLets defs lexpr@(L _ expr) =
284+flattenLets :: [Def] -> Expr -> ([Def], Expr)
285+flattenLets defs lexpr@(A _ expr) =
278286 case expr of
279287 Let ds body -> flattenLets (defs ++ ds) body
280288 _ -> (defs, lexpr)
@@ -288,7 +296,8 @@ generate unsafeModule =
288296 thisModule = dotSep ("_elm" : names modul ++ ["values"])
289297 programStmts =
290298 concat
291− [ setup (Just "_elm") (names modul ++ ["values"])
299+ [ [ ExprStmt () $ string "use strict" ]
300+ , setup (Just "_elm") (names modul ++ ["values"])
292301 , [ IfSingleStmt () thisModule (ret thisModule) ]
293302 , [ internalImports (List.intercalate "." (names modul)) ]
294303 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
@@ -301,7 +310,7 @@ generate unsafeModule =
301310 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
302311 where
303312 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
304− entry x = (PropId () (var x), ref x)
313+ entry x = (prop x, ref x)
305314
306315 assign path expr =
307316 case path of
@@ -311,7 +320,7 @@ generate unsafeModule =
311320
312321 jsImport modul = setup Nothing path ++ [ include ]
313322 where
314− path = split modul
323+ path = Help.splitDots modul
315324 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
316325
317326 setup namespace path = map create paths
@@ -321,8 +330,8 @@ generate unsafeModule =
321330 Nothing -> tail . init $ List.inits path
322331 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
323332
324−binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
325−binop span op e1 e2 =
333+binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
334+binop region op e1 e2 =
326335 case op of
327336 "Basics.." ->
328337 do es <- mapM expression (e1 : collect [] e2)
@@ -335,7 +344,7 @@ binop span op e1 e2 =
335344 do e1' <- expression e1
336345 e2' <- expression e2
337346 return $ obj "_L.append" `call` [e1', e2']
338− "::" -> expression (L span (Data "::" [e1,e2]))
347+ "::" -> expression (A region (Data "::" [e1,e2]))
339348 _ ->
340349 do e1' <- expression e1
341350 e2' <- expression e2
@@ -345,13 +354,13 @@ binop span op e1 e2 =
345354 where
346355 collect es e =
347356 case e of
348− L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
357+ A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
349358 _ -> es ++ [e]
350359
351360 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
352361 | otherwise = dotSep parts
353362 where
354− parts = split op
363+ parts = Help.splitDots op
355364 operator = last parts
356365
357366 opDict = Map.fromList (infixOps ++ specialOps)
compiler/Generate/JavaScript/Ports.hs+23−17
@@ -32,7 +32,7 @@ incoming tipe =
3232
3333inc :: Type -> Expression () -> Expression ()
3434inc tipe x =
35− case tipe of
35+ case tipe of
3636 Lambda _ _ -> error "functions should not be allowed through input ports"
3737 Var _ -> error "type variables should not be allowed through input ports"
3838 Data ctor []
@@ -58,22 +58,26 @@ inc tipe x =
5858 where
5959 array = DotRef () x (var "map") <| incoming t
6060
61− Data ctor ts | Help.isTuple ctor -> check x JSArray tuple
61+ Data ctor ts
62+ | Help.isTuple ctor -> check x JSArray tuple
6263 where
63− tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values
64+ tuple = ObjectLit () $ (prop "ctor", string ctor) : values
6465 values = zipWith convert [0..] ts
65− convert n t = ( PropId () $ var ('_':show n)
66+ convert n t = ( prop ('_':show n)
6667 , inc t (BracketRef () x (IntLit () n)))
6768
68− Data _ _ -> error "bad ADT got to port generation code"
69+ Data _ _ ->
70+ error "bad ADT got to port generation code"
6971
70− Record _ (Just _) -> error "bad record got to port generation code"
72+ Record _ (Just _) ->
73+ error "bad record got to port generation code"
7174
72− Record fields Nothing -> check x (JSObject (map fst fields)) object
75+ Record fields Nothing ->
76+ check x (JSObject (map fst fields)) object
7377 where
74− object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys
78+ object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
7579 keys = map convert fields
76− convert (f,t) = (PropId () (var f), inc t (DotRef () x (var f)))
80+ convert (f,t) = (prop f, inc t (DotRef () x (var f)))
7781
7882outgoing tipe =
7983 case tipe of
@@ -109,19 +113,21 @@ out tipe x =
109113 | ctor == "Maybe.Maybe" ->
110114 CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
111115 (NullLit ())
112− (DotRef () x (var "_0"))
116+ (out t (DotRef () x (var "_0")))
113117
114118 | ctor == "_List" ->
115119 DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t
116120
117− Data ctor ts | Help.isTuple ctor ->
118− ArrayLit () $ zipWith convert [0..] ts
119− where
120− convert n t = out t $ DotRef () x $ var ('_':show n)
121−
122− Data _ _ -> error "bad ADT got to port generation code"
121+ Data ctor ts
122+ | Help.isTuple ctor ->
123+ let convert n t = out t $ DotRef () x $ var ('_':show n)
124+ in ArrayLit () $ zipWith convert [0..] ts
125+
126+ Data _ _ ->
127+ error "bad ADT got to port generation code"
123128
124− Record _ (Just _) -> error "bad record got to port generation code"
129+ Record _ (Just _) ->
130+ error "bad record got to port generation code"
125131
126132 Record fields Nothing ->
127133 ObjectLit () keys
compiler/Generate/Noscript.hsdeleted−68
@@ -1,68 +0,0 @@
1−module Generate.Noscript (noscript) where
2−
3−import Data.List (isInfixOf)
4−import qualified SourceSyntax.Declaration as D
5−import SourceSyntax.Expression
6−import SourceSyntax.Literal
7−import SourceSyntax.Location
8−import SourceSyntax.Module
9−import qualified Generate.Markdown as MD
10−
11−noscript :: Extract def => Module def -> String
12−noscript modul = concat (extract modul)
13−
14−class Extract a where
15− extract :: a -> [String]
16−
17−instance Extract def => Extract (Module def) where
18− extract (Module _ _ _ stmts) =
19− map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)
20−
21−instance Extract def => Extract (D.Declaration' port def) where
22− extract (D.Definition d) = extract d
23− extract _ = []
24−
25−instance Extract Def where
26− extract (Definition _ e _) = extract e
27−
28−instance Extract e => Extract (Located e) where
29− extract (L _ e) = extract e
30−
31−instance Extract def => Extract (Expr' def) where
32− extract expr =
33− let f = extract in
34− case expr of
35− Literal (Str s) -> [s]
36− Binop op e1 e2 -> case (op, f e1, f e2) of
37− ("++", [s1], [s2]) -> [s1 ++ s2]
38− (_ , ss1 , ss2 ) -> ss1 ++ ss2
39− Lambda v e -> f e
40− App (L _ (App (L _ (App (L _ (Var func)) w)) h)) src
41− | "image" `isInfixOf` func -> extractImage src
42− App (L _ (App (L _ (Var func)) src)) txt
43− | "link" `isInfixOf` func -> extractLink src txt
44− App (L _ (Var func)) e
45− | "header" `isInfixOf` func -> tag "h1" e
46− | "bold" `isInfixOf` func -> tag "b" e
47− | "italic" `isInfixOf` func -> tag "i" e
48− | "monospace" `isInfixOf` func -> tag "code" e
49− App e1 e2 -> f e1 ++ f e2
50− Let defs e -> concatMap extract defs ++ f e
51− Var _ -> []
52− Case e cases -> concatMap (f . snd) cases
53− Data _ es -> concatMap f es
54− MultiIf es -> concatMap (f . snd) es
55− Markdown _ md _ -> [ MD.toHtml md ]
56− _ -> []
57−
58−extractLink src txt =
59− case (extract src, extract txt) of
60− ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]
61− ( ss1, ss2) -> ss1 ++ ss2
62−
63−extractImage src =
64− case extract src of
65− [s] -> ["<img src=\"" ++ s ++ "\">"]
66− ss -> ss
67−
68−tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)
compiler/Metadata/Prelude.hs+7−7
@@ -3,11 +3,11 @@ module Metadata.Prelude (interfaces, add) where
33
44import qualified Data.Map as Map
55import qualified Control.Exception as E
6−import qualified Paths_Elm as Path
76import System.Exit
87import System.IO
98import SourceSyntax.Module
109import qualified Build.Interface as Interface
10+import Build.Utils (getDataFile)
1111
1212add :: Bool -> Module def -> Module def
1313add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls
@@ -20,18 +20,18 @@ add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) d
2020 Just _ -> []
2121
2222prelude :: [(String, ImportMethod)]
23−prelude = string : text ++ map (\n -> (n, Hiding [])) modules
23+prelude = string ++ text ++ map (\n -> (n, Hiding [])) modules
2424 where
2525 text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]
26− string = ("String", As "String")
27− modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"
28− , "Graphics.Element", "Color", "Graphics.Collage", "Native.Ports" ]
26+ string = map ((,) "String") [ As "String", Importing ["show"] ]
27+ modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Color"
28+ , "Graphics.Element", "Graphics.Collage", "Native.Ports" ]
2929
3030interfaces :: Bool -> IO Interfaces
3131interfaces noPrelude =
3232 if noPrelude
33− then return $ Map.empty
34− else safeReadDocs =<< Path.getDataFileName "interfaces.data"
33+ then return Map.empty
34+ else safeReadDocs =<< getDataFile "interfaces.data"
3535
3636safeReadDocs :: FilePath -> IO Interfaces
3737safeReadDocs name =
compiler/Parse/Binop.hs+17−16
@@ -1,10 +1,11 @@
1+{-# OPTIONS_GHC -W #-}
12module Parse.Binop (binops, OpTable) where
23
34import Control.Applicative ((<$>))
4−import Data.List (intercalate)
5+import qualified Data.List as List
56import qualified Data.Map as Map
67
7−import SourceSyntax.Location (merge)
8+import SourceSyntax.Annotation (merge)
89import qualified SourceSyntax.Expression as E
910import SourceSyntax.Declaration (Assoc(..))
1011import Text.Parsec
@@ -16,13 +17,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table
1617opAssoc :: OpTable -> String -> Assoc
1718opAssoc table op = snd $ Map.findWithDefault (9,L) op table
1819
19−hasLevel :: OpTable -> Int -> (String, E.LParseExpr) -> Bool
20+hasLevel :: OpTable -> Int -> (String, E.ParseExpr) -> Bool
2021hasLevel table n (op,_) = opLevel table op == n
2122
22−binops :: IParser E.LParseExpr
23− -> IParser E.LParseExpr
23+binops :: IParser E.ParseExpr
24+ -> IParser E.ParseExpr
2425 -> IParser String
25− -> IParser E.LParseExpr
26+ -> IParser E.ParseExpr
2627binops term last anyOp =
2728 do e <- term
2829 table <- getState
@@ -38,9 +39,9 @@ binops term last anyOp =
3839
3940split :: OpTable
4041 -> Int
41− -> E.LParseExpr
42− -> [(String, E.LParseExpr)]
43− -> IParser E.LParseExpr
42+ -> E.ParseExpr
43+ -> [(String, E.ParseExpr)]
44+ -> IParser E.ParseExpr
4445split _ _ e [] = return e
4546split table n e eops = do
4647 assoc <- getAssoc table n eops
@@ -49,26 +50,26 @@ split table n e eops = do
4950 case assoc of R -> joinR es ops
5051 _ -> joinL es ops
5152
52−splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)]
53− -> [IParser E.LParseExpr]
53+splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]
54+ -> [IParser E.ParseExpr]
5455splitLevel table n e eops =
5556 case break (hasLevel table n) eops of
56− (lops, (op,e'):rops) ->
57+ (lops, (_op,e'):rops) ->
5758 split table (n+1) e lops : splitLevel table n e' rops
5859 (lops, []) -> [ split table (n+1) e lops ]
5960
60−joinL :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
61+joinL :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
6162joinL [e] [] = return e
6263joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops
6364joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."
6465
65−joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
66+joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
6667joinR [e] [] = return e
6768joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
6869 return (merge a e (E.Binop op a e))
6970joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
7071
71−getAssoc :: OpTable -> Int -> [(String,E.LParseExpr)] -> IParser Assoc
72+getAssoc :: OpTable -> Int -> [(String,E.ParseExpr)] -> IParser Assoc
7273getAssoc table n eops
7374 | all (==L) assocs = return L
7475 | all (==R) assocs = return R
@@ -79,5 +80,5 @@ getAssoc table n eops
7980 assocs = map (opAssoc table . fst) levelOps
8081 msg problem =
8182 concat [ "Conflicting " ++ problem ++ " for binary operators ("
82− , intercalate ", " (map fst eops), "). "
83+ , List.intercalate ", " (map fst eops), "). "
8384 , "Consider adding parentheses to disambiguate." ]
compiler/Parse/Expression.hs+69−68
@@ -5,45 +5,45 @@ import Data.List (foldl')
55import Text.Parsec hiding (newline,spaces)
66import Text.Parsec.Indent
77
8+import Parse.Binop
89import Parse.Helpers
10+import Parse.Literal
911import qualified Parse.Pattern as Pattern
1012import qualified Parse.Type as Type
11−import Parse.Binop
12−import Parse.Literal
1313
14−import SourceSyntax.Location as Location
15−import SourceSyntax.Pattern hiding (tuple,list)
16−import qualified SourceSyntax.Literal as Literal
14+import SourceSyntax.Annotation as Annotation
15+import qualified SourceSyntax.Pattern as P
16+import qualified SourceSyntax.Literal as L
1717import SourceSyntax.Expression
1818
1919
2020-------- Basic Terms --------
2121
22−varTerm :: IParser ParseExpr
22+varTerm :: IParser ParseExpr'
2323varTerm = toVar <$> var <?> "variable"
2424
25−toVar :: String -> ParseExpr
26−toVar v = case v of "True" -> Literal (Literal.Boolean True)
27− "False" -> Literal (Literal.Boolean False)
28− _ -> Var v
25+toVar :: String -> ParseExpr'
26+toVar v = case v of "True" -> Literal (L.Boolean True)
27+ "False" -> Literal (L.Boolean False)
28+ _ -> rawVar v
2929
30−accessor :: IParser ParseExpr
30+accessor :: IParser ParseExpr'
3131accessor = do
3232 (start, lbl, end) <- located (try (string "." >> rLabel))
33− let loc e = Location.at start end e
34− return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
33+ let loc e = Annotation.at start end e
34+ return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))
3535
36−negative :: IParser ParseExpr
36+negative :: IParser ParseExpr'
3737negative = do
3838 (start, nTerm, end) <-
3939 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
40− let loc e = Location.at start end e
41− return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)
40+ let loc e = Annotation.at start end e
41+ return (Binop "-" (loc $ Literal (L.IntNum 0)) nTerm)
4242
4343
4444-------- Complex Terms --------
4545
46−listTerm :: IParser ParseExpr
46+listTerm :: IParser ParseExpr'
4747listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
4848 where
4949 range = do
@@ -60,92 +60,93 @@ listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
6060 span uid index =
6161 "<span id=\"md-" ++ uid ++ "-" ++ show index ++ "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"
6262
63− interpolation uid md exprs = do
63+ interpolation uid exprs = do
6464 try (string "{{")
6565 e <- padded expr
6666 string "}}"
67− return (md ++ span uid (length exprs), exprs ++ [e])
67+ return (span uid (length exprs), exprs ++ [e])
6868
69−parensTerm :: IParser LParseExpr
69+parensTerm :: IParser ParseExpr
7070parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
7171 where
7272 opFn = do
7373 (start, op, end) <- located anyOp
74− let loc = Location.at start end
75− return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
76− Binop op (loc $ Var "x") (loc $ Var "y")
74+ let loc = Annotation.at start end
75+ return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $
76+ Binop op (loc $ rawVar "x") (loc $ rawVar "y")
7777
7878 tupleFn = do
7979 let comma = char ',' <?> "comma ','"
8080 (start, commas, end) <- located (comma >> many (whitespace >> comma))
8181 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
82− loc = Location.at start end
82+ loc = Annotation.at start end
8383 return $ foldr (\x e -> loc $ Lambda x e)
84− (loc . tuple $ map (loc . Var) vars) (map PVar vars)
84+ (loc . tuple $ map (loc . rawVar) vars) (map P.Var vars)
8585
8686 parened = do
8787 (start, es, end) <- located (commaSep expr)
8888 return $ case es of
8989 [e] -> e
90− _ -> Location.at start end (tuple es)
90+ _ -> Annotation.at start end (tuple es)
9191
92−recordTerm :: IParser LParseExpr
92+recordTerm :: IParser ParseExpr
9393recordTerm = brackets $ choice [ misc, addLocation record ]
94− where field = do
95− label <- rLabel
96− patterns <- spacePrefix Pattern.term
97− padded equals
98− body <- expr
99− return (label, makeFunction patterns body)
94+ where
95+ field = do
96+ label <- rLabel
97+ patterns <- spacePrefix Pattern.term
98+ padded equals
99+ body <- expr
100+ return (label, makeFunction patterns body)
100101
101− record = Record <$> commaSep field
102+ record = Record <$> commaSep field
102103
103− change = do
104− lbl <- rLabel
105− padded (string "<-")
106− (,) lbl <$> expr
104+ change = do
105+ lbl <- rLabel
106+ padded (string "<-")
107+ (,) lbl <$> expr
107108
108− remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
109+ remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
109110
110− insert r = addLocation $ do
111− string "|" >> whitespace
112− Insert r <$> rLabel <*> (padded equals >> expr)
111+ insert r = addLocation $ do
112+ string "|" >> whitespace
113+ Insert r <$> rLabel <*> (padded equals >> expr)
113114
114− modify r = addLocation
115− (string "|" >> whitespace >> Modify r <$> commaSep1 change)
115+ modify r =
116+ addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)
116117
117− misc = try $ do
118− record <- addLocation (Var <$> rLabel)
119− opt <- padded (optionMaybe (remove record))
120− case opt of
121− Just e -> try (insert e) <|> return e
122− Nothing -> try (insert record) <|> try (modify record)
118+ misc = try $ do
119+ record <- addLocation (rawVar <$> rLabel)
120+ opt <- padded (optionMaybe (remove record))
121+ case opt of
122+ Just e -> try (insert e) <|> return e
123+ Nothing -> try (insert record) <|> try (modify record)
123124
124125
125−term :: IParser LParseExpr
126+term :: IParser ParseExpr
126127term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
127128 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
128129 <?> "basic term (4, x, 'c', etc.)"
129130
130131-------- Applications --------
131132
132−appExpr :: IParser LParseExpr
133+appExpr :: IParser ParseExpr
133134appExpr = do
134135 t <- term
135136 ts <- constrainedSpacePrefix term $ \str ->
136137 if null str then notFollowedBy (char '-') else return ()
137138 return $ case ts of
138139 [] -> t
139− _ -> foldl' (\f x -> Location.merge f x $ App f x) t ts
140+ _ -> foldl' (\f x -> Annotation.merge f x $ App f x) t ts
140141
141142-------- Normal Expressions --------
142143
143−binaryExpr :: IParser LParseExpr
144+binaryExpr :: IParser ParseExpr
144145binaryExpr = binops appExpr lastExpr anyOp
145146 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
146147 <|> lambdaExpr
147148
148−ifExpr :: IParser ParseExpr
149+ifExpr :: IParser ParseExpr'
149150ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
150151 where
151152 normal = do
@@ -155,13 +156,13 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
155156 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
156157 elseBranch <- expr
157158 return $ MultiIf [(bool, thenBranch),
158− (Location.sameAs elseBranch (Literal . Literal.Boolean $ True), elseBranch)]
159+ (Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]
159160 multiIf = MultiIf <$> spaceSep1 iff
160161 where iff = do string "|" ; whitespace
161162 b <- expr ; padded arrow
162163 (,) b <$> expr
163164
164−lambdaExpr :: IParser LParseExpr
165+lambdaExpr :: IParser ParseExpr
165166lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
166167 whitespace
167168 args <- spaceSep1 Pattern.term
@@ -172,14 +173,14 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
172173defSet :: IParser [ParseDef]
173174defSet = block (do d <- def ; whitespace ; return d)
174175
175−letExpr :: IParser ParseExpr
176+letExpr :: IParser ParseExpr'
176177letExpr = do
177178 reserved "let" ; whitespace
178179 defs <- defSet
179180 padded (reserved "in")
180181 Let defs <$> expr
181182
182−caseExpr :: IParser ParseExpr
183+caseExpr :: IParser ParseExpr'
183184caseExpr = do
184185 reserved "case"; e <- padded expr; reserved "of"; whitespace
185186 Case e <$> (with <|> without)
@@ -189,35 +190,35 @@ caseExpr = do
189190 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
190191 without = block (do c <- case_ ; whitespace ; return c)
191192
192−expr :: IParser LParseExpr
193+expr :: IParser ParseExpr
193194expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
194195 <|> lambdaExpr
195196 <|> binaryExpr
196197 <?> "an expression"
197198
198−defStart :: IParser [Pattern]
199+defStart :: IParser [P.Pattern]
199200defStart =
200201 choice [ do p1 <- try Pattern.term
201202 infics p1 <|> func p1
202− , func =<< (PVar <$> parens symOp)
203+ , func =<< (P.Var <$> parens symOp)
203204 , (:[]) <$> Pattern.expr
204205 ] <?> "the definition of a variable (x = ...)"
205206 where
206207 func pattern =
207208 case pattern of
208− PVar _ -> (pattern:) <$> spacePrefix Pattern.term
209+ P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
209210 _ -> do try (lookAhead (whitespace >> string "="))
210211 return [pattern]
211212
212213 infics p1 = do
213214 o:p <- try (whitespace >> anyOp)
214215 p2 <- (whitespace >> Pattern.term)
215− return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
216− else [ PVar (o:p), p1, p2 ]
216+ return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
217+ else [ P.Var (o:p), p1, p2 ]
217218
218−makeFunction :: [Pattern] -> LParseExpr -> LParseExpr
219−makeFunction args body@(L s _) =
220− foldr (\arg body' -> L s $ Lambda arg body') body args
219+makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr
220+makeFunction args body@(A ann _) =
221+ foldr (\arg body' -> A ann $ Lambda arg body') body args
221222
222223definition :: IParser ParseDef
223224definition = withPos $ do
compiler/Parse/Helpers.hs+22−18
@@ -12,11 +12,12 @@ import Text.Parsec hiding (newline,spaces,State)
1212import Text.Parsec.Indent
1313import qualified Text.Parsec.Token as T
1414
15−import SourceSyntax.Helpers as Help
16−import SourceSyntax.Location as Location
15+import SourceSyntax.Annotation as Annotation
16+import SourceSyntax.Declaration (Assoc)
1717import SourceSyntax.Expression
18+import SourceSyntax.Helpers as Help
1819import SourceSyntax.PrettyPrint
19−import SourceSyntax.Declaration (Assoc)
20+import SourceSyntax.Variable as Variable
2021
2122reserveds = [ "if", "then", "else"
2223 , "case", "of"
@@ -168,7 +169,8 @@ betwixt a b c = do char a ; out <- c
168169 char b <?> "closing '" ++ [b] ++ "'" ; return out
169170
170171surround a z name p = do
171− char a ; v <- padded p
172+ char a
173+ v <- padded p
172174 char z <?> unwords ["closing", name, show z]
173175 return v
174176
@@ -181,10 +183,10 @@ parens = surround '(' ')' "paren"
181183brackets :: IParser a -> IParser a
182184brackets = surround '{' '}' "bracket"
183185
184−addLocation :: (Pretty a) => IParser a -> IParser (Location.Located a)
186+addLocation :: (Pretty a) => IParser a -> IParser (Annotation.Located a)
185187addLocation expr = do
186188 (start, e, end) <- located expr
187− return (Location.at start end e)
189+ return (Annotation.at start end e)
188190
189191located :: IParser a -> IParser (SourcePos, a, SourcePos)
190192located p = do
@@ -193,10 +195,10 @@ located p = do
193195 end <- getPosition
194196 return (start, e, end)
195197
196−accessible :: IParser LParseExpr -> IParser LParseExpr
198+accessible :: IParser ParseExpr -> IParser ParseExpr
197199accessible expr = do
198200 start <- getPosition
199− ce@(L _ e) <- expr
201+ ce@(A _ e) <- expr
200202 let rest f = do
201203 let dot = char '.' >> notFollowedBy (char '.')
202204 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
@@ -205,10 +207,12 @@ accessible expr = do
205207 Just _ -> accessible $ do
206208 v <- var <?> "field access (e.g. List.map)"
207209 end <- getPosition
208− return (Location.at start end (f v))
209− case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
210− | otherwise -> rest (Access ce)
211− _ -> rest (Access ce)
210+ return (Annotation.at start end (f v))
211+ case e of
212+ Var (Variable.Raw (c:cs))
213+ | isUpper c -> rest (\v -> rawVar (c:cs ++ '.':v))
214+ | otherwise -> rest (Access ce)
215+ _ -> rest (Access ce)
212216
213217
214218spaces :: IParser String
@@ -268,7 +272,7 @@ ignoreUntil end = go
268272 ignore p = const () <$> p
269273 filler = choice [ try (ignore chr) <|> ignore str
270274 , ignore multiComment
271− , ignore (markdown (\_ _ -> mzero))
275+ , ignore (markdown (\_ -> mzero))
272276 , ignore anyChar
273277 ]
274278 go = choice [ Just <$> end
@@ -301,15 +305,15 @@ anyUntilPos pos = go
301305 True -> return []
302306 False -> (:) <$> anyChar <*> go
303307
304−markdown :: (String -> [a] -> IParser (String, [a])) -> IParser (String, [a])
305−markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []
308+markdown :: ([a] -> IParser (String, [a])) -> IParser (String, [a])
309+markdown interpolation = try (string "[markdown|") >> closeMarkdown (++ "") []
306310 where
307311 closeMarkdown md stuff =
308312 choice [ do try (string "|]")
309− return (md, stuff)
310− , uncurry closeMarkdown =<< interpolation md stuff
313+ return (md "", stuff)
314+ , (\(m,s) -> closeMarkdown (md . (m ++)) s) =<< interpolation stuff
311315 , do c <- anyChar
312− closeMarkdown (md ++ [c]) stuff
316+ closeMarkdown (md . ([c]++)) stuff
313317 ]
314318
315319--str :: IParser String
compiler/Parse/Literal.hs+30−12
@@ -1,4 +1,4 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1+{-# OPTIONS_GHC -W #-}
22module Parse.Literal (literal) where
33
44import Control.Applicative ((<$>))
@@ -7,16 +7,34 @@ import Parse.Helpers
77import SourceSyntax.Literal
88
99literal :: IParser Literal
10−literal = num <|> (Str <$> str) <|> (Chr <$> chr)
10+literal = num <|> (Str <$> str) <|> (Chr <$> chr) <?> "literal"
1111
1212num :: IParser Literal
13−num = fmap toLit (preNum <?> "number")
14− where toLit n | '.' `elem` n = FloatNum (read n)
15− | otherwise = IntNum (read n)
16− preNum = concat <$> sequence [ option "" minus, many1 digit, option "" postNum ]
17− postNum = do try $ lookAhead (string "." >> digit)
18− string "."
19− ('.':) <$> many1 digit
20− minus = try $ do string "-"
21− lookAhead digit
22− return "-"
13+num = toLit <$> (number <?> "number")
14+ where
15+ toLit n
16+ | any (`elem` ".eE") n = FloatNum (read n)
17+ | otherwise = IntNum (read n)
18+
19+ number = concat <$> sequence
20+ [ option "" minus
21+ , many1 digit
22+ , option "" decimals
23+ , option "" exponent ]
24+
25+ minus = try $ do
26+ string "-"
27+ lookAhead digit
28+ return "-"
29+
30+ decimals = do
31+ try $ lookAhead (string "." >> digit)
32+ string "."
33+ n <- many1 digit
34+ return ('.' : n)
35+
36+ exponent = do
37+ string "e" <|> string "E"
38+ op <- option "" (string "+" <|> string "-")
39+ n <- many1 digit
40+ return ('e' : op ++ n)
compiler/Parse/Module.hs+15−10
@@ -8,7 +8,7 @@ import Parse.Helpers
88import SourceSyntax.Module (ImportMethod(..), Imports)
99
1010varList :: IParser [String]
11−varList = parens $ commaSep1 (var <|> parens symOp)
11+varList = commaSep1 (var <|> parens symOp)
1212
1313getModuleName :: String -> Maybe String
1414getModuleName source =
@@ -27,7 +27,7 @@ moduleDef = do
2727 whitespace
2828 names <- dotSep1 capVar <?> "name of module"
2929 whitespace
30− exports <- option [] varList
30+ exports <- option [] (parens varList)
3131 whitespace <?> "reserved word 'where'"
3232 reserved "where"
3333 return (names, exports)
@@ -38,17 +38,22 @@ imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
3838import' :: IParser (String, ImportMethod)
3939import' =
4040 do reserved "import"
41− whitespace
42− open <- optionMaybe (reserved "open")
4341 whitespace
4442 name <- intercalate "." <$> dotSep1 capVar
45− case open of
46− Just _ -> return (name, Hiding [])
47− Nothing -> let how = try (whitespace >> (as' <|> importing'))
48− in (,) name <$> option (As name) how
43+ (,) name <$> option (As name) method
4944 where
45+ method :: IParser ImportMethod
46+ method = try $ do whitespace
47+ as' <|> importing'
48+
5049 as' :: IParser ImportMethod
51− as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
50+ as' = do
51+ reserved "as"
52+ whitespace
53+ As <$> capVar <?> "alias for module"
5254
5355 importing' :: IParser ImportMethod
54− importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"
56+ importing' =
57+ parens (choice [ const (Hiding []) <$> string ".."
58+ , Importing <$> varList
59+ ] <?> "listing of imported values (x,y,z)")
compiler/Parse/Pattern.hs+29−27
@@ -3,57 +3,59 @@ module Parse.Pattern (term, expr) where
33
44import Control.Applicative ((<$>))
55import Data.Char (isUpper)
6−import Data.List (intercalate)
6+import qualified Data.List as List
77import Text.Parsec hiding (newline,spaces,State)
88
99import Parse.Helpers
1010import Parse.Literal
1111import SourceSyntax.Literal
12−import SourceSyntax.Pattern hiding (tuple, list)
13−import qualified SourceSyntax.Pattern as Pattern
12+import qualified SourceSyntax.Pattern as P
1413
15−basic :: IParser Pattern
14+basic :: IParser P.Pattern
1615basic = choice
17− [ char '_' >> return PAnything
16+ [ char '_' >> return P.Anything
1817 , do v <- var
1918 return $ case v of
20− "True" -> PLiteral (Boolean True)
21− "False" -> PLiteral (Boolean False)
22− c:_ | isUpper c -> PData v []
23− _ -> PVar v
24− , PLiteral <$> literal
19+ "True" -> P.Literal (Boolean True)
20+ "False" -> P.Literal (Boolean False)
21+ c:_ | isUpper c -> P.Data v []
22+ _ -> P.Var v
23+ , P.Literal <$> literal
2524 ]
2625
27−asPattern :: Pattern -> IParser Pattern
26+asPattern :: P.Pattern -> IParser P.Pattern
2827asPattern pattern = do
2928 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
3029 return $ case var of
31− Just v -> PAlias v pattern
30+ Just v -> P.Alias v pattern
3231 Nothing -> pattern
3332
34−record :: IParser Pattern
35−record = PRecord <$> brackets (commaSep1 lowVar)
33+record :: IParser P.Pattern
34+record = P.Record <$> brackets (commaSep1 lowVar)
3635
37−tuple :: IParser Pattern
38−tuple = do ps <- parens (commaSep expr)
39− return $ case ps of { [p] -> p; _ -> Pattern.tuple ps }
36+tuple :: IParser P.Pattern
37+tuple = do
38+ ps <- parens (commaSep expr)
39+ return $ case ps of
40+ [p] -> p
41+ _ -> P.tuple ps
4042
41−list :: IParser Pattern
42−list = Pattern.list <$> braces (commaSep expr)
43+list :: IParser P.Pattern
44+list = P.list <$> braces (commaSep expr)
4345
44−term :: IParser Pattern
46+term :: IParser P.Pattern
4547term =
4648 (choice [ record, tuple, list, basic ]) <?> "pattern"
4749
48−patternConstructor :: IParser Pattern
50+patternConstructor :: IParser P.Pattern
4951patternConstructor = do
50− v <- intercalate "." <$> dotSep1 capVar
52+ v <- List.intercalate "." <$> dotSep1 capVar
5153 case v of
52− "True" -> return $ PLiteral (Boolean True)
53− "False" -> return $ PLiteral (Boolean False)
54− _ -> PData v <$> spacePrefix term
54+ "True" -> return $ P.Literal (Boolean True)
55+ "False" -> return $ P.Literal (Boolean False)
56+ _ -> P.Data v <$> spacePrefix term
5557
56−expr :: IParser Pattern
58+expr :: IParser P.Pattern
5759expr = do
5860 patterns <- consSep1 (patternConstructor <|> term)
59− asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
61+ asPattern (foldr1 P.cons patterns) <?> "pattern"
compiler/SourceSyntax/Annotation.hsnew file+74
@@ -0,0 +1,74 @@
1+{-# OPTIONS_GHC -W #-}
2+module SourceSyntax.Annotation where
3+
4+import qualified Text.Parsec.Pos as Parsec
5+import qualified Text.PrettyPrint as P
6+import SourceSyntax.PrettyPrint
7+
8+data Annotated annotation expr = A annotation expr
9+ deriving (Show)
10+
11+data Region
12+ = Span Position Position P.Doc
13+ | None P.Doc
14+ deriving (Show)
15+
16+data Position = Position
17+ { line :: Int
18+ , column :: Int
19+ } deriving (Show)
20+
21+type Located expr = Annotated Region expr
22+
23+none e = A (None (pretty e)) e
24+noneNoDocs e = A (None P.empty) e
25+
26+at :: (Pretty expr) => Parsec.SourcePos -> Parsec.SourcePos -> expr
27+ -> Annotated Region expr
28+at start end e =
29+ A (Span (position start) (position end) (pretty e)) e
30+ where
31+ position loc = Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)
32+
33+merge (A s1 _) (A s2 _) e =
34+ A (span (pretty e)) e
35+ where
36+ span = case (s1,s2) of
37+ (Span start _ _, Span _ end _) -> Span start end
38+ (Span start end _, _) -> Span start end
39+ (_, Span start end _) -> Span start end
40+ (_, _) -> None
41+
42+mergeOldDocs (A s1 _) (A s2 _) e =
43+ A span e
44+ where
45+ span = case (s1,s2) of
46+ (Span start _ d1, Span _ end d2) ->
47+ Span start end (P.vcat [d1, P.text "\n", d2])
48+
49+ (Span _ _ _, _) -> s1
50+ (_, Span _ _ _) -> s2
51+ (_, _) -> None P.empty
52+
53+sameAs :: Annotated a expr -> expr' -> Annotated a expr'
54+sameAs (A annotation _) expr = A annotation expr
55+
56+getRegionDocs region =
57+ case region of
58+ Span _ _ doc -> doc
59+ None doc -> doc
60+
61+instance Pretty Region where
62+ pretty span =
63+ case span of
64+ None _ -> P.empty
65+ Span start end _ ->
66+ P.text $
67+ case line start == line end of
68+ False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
69+ True -> "on line " ++ show (line end) ++ ", column " ++
70+ show (column start) ++ " to " ++ show (column end)
71+
72+instance Pretty e => Pretty (Annotated a e) where
73+ pretty (A _ e) = pretty e
74+
compiler/SourceSyntax/Declaration.hs+2−2
@@ -20,11 +20,11 @@ data Assoc = L | N | R
2020
2121data ParsePort
2222 = PPAnnotation String T.Type
23− | PPDef String Expr.LParseExpr
23+ | PPDef String Expr.ParseExpr
2424 deriving (Show)
2525
2626data Port
27− = Out String Expr.LExpr T.Type
27+ = Out String Expr.Expr T.Type
2828 | In String T.Type
2929 deriving (Show)
3030
compiler/SourceSyntax/Expression.hs+88−62
@@ -11,49 +11,54 @@ module SourceSyntax.Expression where
1111import SourceSyntax.PrettyPrint
1212import Text.PrettyPrint as P
1313import qualified SourceSyntax.Helpers as Help
14−import qualified SourceSyntax.Location as Location
14+import qualified SourceSyntax.Annotation as Annotation
1515import qualified SourceSyntax.Pattern as Pattern
1616import qualified SourceSyntax.Type as SrcType
1717import qualified SourceSyntax.Literal as Literal
18+import qualified SourceSyntax.Variable as Variable
1819
1920---- GENERAL AST ----
2021
21−{-| This is a located expression, meaning it is tagged with info about where it
22−came from in the source code. Expr' is defined in terms of LExpr' so that the
23−location information does not need to be an extra field on every constructor.
24−-}
25−type LExpr' def = Location.Located (Expr' def)
26−
2722{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
2823"type holes" that allow us to enrich the AST with additional information as we
29−move through the compilation process. The type holes let us show these
30−structural changes in the types. The only type hole right now is:
24+move through the compilation process. The type holes are used to represent:
25+
26+ ann: Annotations for arbitrary expressions. Allows you to add information
27+ to the AST like position in source code or inferred types.
28+
29+ def: Definition style. The source syntax separates type annotations and
30+ definitions, but after parsing we check that they are well formed and
31+ collapse them.
3132
32− def: Parsing allows two kinds of definitions (type annotations or definitions),
33− but later checks will see that they are well formed and combine them.
33+ var: Representation of variables. Starts as strings, but is later enriched
34+ with information about what module a variable came from.
3435
3536-}
36−data Expr' def
37+type GeneralExpr annotation definition variable =
38+ Annotation.Annotated annotation (GeneralExpr' annotation definition variable)
39+
40+data GeneralExpr' ann def var
3741 = Literal Literal.Literal
38− | Var String
39− | Range (LExpr' def) (LExpr' def)
40− | ExplicitList [LExpr' def]
41− | Binop String (LExpr' def) (LExpr' def)
42− | Lambda Pattern.Pattern (LExpr' def)
43− | App (LExpr' def) (LExpr' def)
44− | MultiIf [(LExpr' def,LExpr' def)]
45− | Let [def] (LExpr' def)
46− | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
47− | Data String [LExpr' def]
48− | Access (LExpr' def) String
49− | Remove (LExpr' def) String
50− | Insert (LExpr' def) String (LExpr' def)
51− | Modify (LExpr' def) [(String, LExpr' def)]
52− | Record [(String, LExpr' def)]
53− | Markdown String String [LExpr' def]
42+ | Var var
43+ | Range (GeneralExpr ann def var) (GeneralExpr ann def var)
44+ | ExplicitList [GeneralExpr ann def var]
45+ | Binop String (GeneralExpr ann def var) (GeneralExpr ann def var)
46+ | Lambda Pattern.Pattern (GeneralExpr ann def var)
47+ | App (GeneralExpr ann def var) (GeneralExpr ann def var)
48+ | MultiIf [(GeneralExpr ann def var,GeneralExpr ann def var)]
49+ | Let [def] (GeneralExpr ann def var)
50+ | Case (GeneralExpr ann def var) [(Pattern.Pattern, GeneralExpr ann def var)]
51+ | Data String [GeneralExpr ann def var]
52+ | Access (GeneralExpr ann def var) String
53+ | Remove (GeneralExpr ann def var) String
54+ | Insert (GeneralExpr ann def var) String (GeneralExpr ann def var)
55+ | Modify (GeneralExpr ann def var) [(String, GeneralExpr ann def var)]
56+ | Record [(String, GeneralExpr ann def var)]
57+ | Markdown String String [GeneralExpr ann def var]
5458 -- for type checking and code gen only
5559 | PortIn String SrcType.Type
56− | PortOut String SrcType.Type (LExpr' def)
60+ | PortOut String SrcType.Type (GeneralExpr ann def var)
61+ deriving (Show)
5762
5863
5964---- SPECIALIZED ASTs ----
@@ -62,81 +67,100 @@ data Expr' def
6267annotations and definitions, which is how they appear in source code and how
6368they are parsed.
6469-}
65−type ParseExpr = Expr' ParseDef
66−type LParseExpr = LExpr' ParseDef
70+type ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw
71+type ParseExpr' = GeneralExpr' Annotation.Region ParseDef Variable.Raw
6772
6873data ParseDef
69− = Def Pattern.Pattern LParseExpr
74+ = Def Pattern.Pattern ParseExpr
7075 | TypeAnnotation String SrcType.Type
71− deriving (Show)
76+ deriving (Show)
7277
7378{-| "Normal" expressions. When the compiler checks that type annotations and
7479ports are all paired with definitions in the appropriate order, it collapses
7580them into a Def that is easier to work with in later phases of compilation.
7681-}
77−type LExpr = LExpr' Def
78−type Expr = Expr' Def
82+type Expr = GeneralExpr Annotation.Region Def Variable.Raw
83+type Expr' = GeneralExpr' Annotation.Region Def Variable.Raw
7984
80−data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)
85+data Def = Definition Pattern.Pattern Expr (Maybe SrcType.Type)
8186 deriving (Show)
8287
8388
89+
8490---- UTILITIES ----
8591
86−tuple :: [LExpr' def] -> Expr' def
92+rawVar :: String -> GeneralExpr' ann def Variable.Raw
93+rawVar x = Var (Variable.Raw x)
94+
95+tuple :: [GeneralExpr ann def var] -> GeneralExpr' ann def var
8796tuple es = Data ("_Tuple" ++ show (length es)) es
8897
89−delist :: LExpr' def -> [LExpr' def]
90−delist (Location.L _ (Data "::" [h,t])) = h : delist t
98+delist :: GeneralExpr ann def var -> [GeneralExpr ann def var]
99+delist (Annotation.A _ (Data "::" [h,t])) = h : delist t
91100delist _ = []
92101
93102saveEnvName :: String
94103saveEnvName = "_save_the_environment!!!"
95104
96−dummyLet :: Pretty def => [def] -> LExpr' def
105+dummyLet :: (Pretty def) => [def] -> GeneralExpr Annotation.Region def Variable.Raw
97106dummyLet defs =
98− Location.none $ Let defs (Location.none $ Var saveEnvName)
107+ Annotation.none $ Let defs (Annotation.none $ rawVar saveEnvName)
99108
100−instance Pretty def => Show (Expr' def) where
101− show = render . pretty
102−
103−instance Pretty def => Pretty (Expr' def) where
109+instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where
104110 pretty expr =
105111 case expr of
106112 Literal lit -> pretty lit
107− Var x -> variable x
113+
114+ Var x -> pretty x
115+
108116 Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
117+
109118 ExplicitList es -> P.brackets (commaCat (map pretty es))
110− Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->
119+
120+ Binop "-" (Annotation.A _ (Literal (Literal.IntNum 0))) e ->
111121 P.text "-" <> prettyParens e
122+
112123 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
113− where op' = if Help.isOp op then op else "`" ++ op ++ "`"
124+ where
125+ op' = if Help.isOp op then op else "`" ++ op ++ "`"
126+
114127 Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
115128 where
116− (ps,body) = collectLambdas (Location.none $ Lambda p e)
129+ (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)
117130 args = P.sep (map Pattern.prettyParens ps)
131+
118132 App _ _ -> P.hang func 2 (P.sep args)
119− where func:args = map prettyParens (collectApps (Location.none expr))
120− MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
133+ where
134+ func:args = map prettyParens (collectApps (Annotation.A undefined expr))
135+
136+ MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
121137 where
122138 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
139+
123140 Let defs e ->
124141 P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
125142 , P.text "in" <+> pretty e ]
143+
126144 Case e pats ->
127145 P.hang pexpr 2 (P.vcat (map pretty' pats))
128146 where
129147 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
130148 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
149+
131150 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
132151 Data "[]" [] -> P.text "[]"
133152 Data name es
134153 | Help.isTuple name -> P.parens (commaCat (map pretty es))
135154 | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
155+
136156 Access e x -> prettyParens e <> P.text "." <> variable x
157+
137158 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
138− Insert (Location.L _ (Remove e y)) x v ->
139− P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
159+
160+ Insert (Annotation.A _ (Remove e y)) x v ->
161+ P.braces $ P.hsep [ pretty e, P.text "-", variable y, P.text "|"
162+ , variable x, P.equals, pretty v ]
163+
140164 Insert e x v ->
141165 P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
142166
@@ -175,21 +199,23 @@ instance Pretty Def where
175199 Nothing -> P.empty
176200 Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
177201
178−collectApps :: LExpr' def -> [LExpr' def]
179−collectApps lexpr@(Location.L _ expr) =
202+collectApps :: GeneralExpr ann def var -> [GeneralExpr ann def var]
203+collectApps annExpr@(Annotation.A _ expr) =
180204 case expr of
181205 App a b -> collectApps a ++ [b]
182− _ -> [lexpr]
206+ _ -> [annExpr]
183207
184−collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)
185−collectLambdas lexpr@(Location.L _ expr) =
208+collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)
209+collectLambdas lexpr@(Annotation.A _ expr) =
186210 case expr of
187− Lambda pattern body -> (pattern : ps, body')
188− where (ps, body') = collectLambdas body
211+ Lambda pattern body ->
212+ let (ps, body') = collectLambdas body
213+ in (pattern : ps, body')
214+
189215 _ -> ([], lexpr)
190216
191−prettyParens :: (Pretty def) => LExpr' def -> Doc
192−prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
217+prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc
218+prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)
193219 where
194220 needed =
195221 case expr of
compiler/SourceSyntax/Helpers.hs+9
@@ -3,6 +3,15 @@ module SourceSyntax.Helpers where
33
44import qualified Data.Char as Char
55
6+splitDots :: String -> [String]
7+splitDots = go []
8+ where
9+ go vars str =
10+ case break (=='.') str of
11+ (x,_:rest) | isOp x -> vars ++ [x ++ '.' : rest]
12+ | otherwise -> go (vars ++ [x]) rest
13+ (x,[]) -> vars ++ [x]
14+
615brkt :: String -> String
716brkt s = "{ " ++ s ++ " }"
817
compiler/SourceSyntax/Location.hsdeleted−58
@@ -1,58 +0,0 @@
1−module SourceSyntax.Location where
2−
3−import Text.PrettyPrint
4−import SourceSyntax.PrettyPrint
5−import qualified Text.Parsec.Pos as Parsec
6−
7−data SrcPos = Pos { line :: Int, column :: Int }
8− deriving (Eq, Ord)
9−
10−data SrcSpan = Span SrcPos SrcPos String | NoSpan String
11− deriving (Eq, Ord)
12−
13−data Located e = L SrcSpan e
14− deriving (Eq, Ord)
15−
16−none e = L (NoSpan (render $ pretty e)) e
17−noneNoDocs = L (NoSpan "")
18−
19−at start end e = L (Span (Pos (Parsec.sourceLine start) (Parsec.sourceColumn start))
20− (Pos (Parsec.sourceLine end ) (Parsec.sourceColumn end ))
21− (render $ pretty e)) e
22−
23−merge (L s1 _) (L s2 _) e = L (span (render $ pretty e)) e
24− where span = case (s1,s2) of
25− (Span start _ _, Span _ end _) -> Span start end
26− (Span start end _, _) -> Span start end
27− (_, Span start end _) -> Span start end
28− (_, _) -> NoSpan
29−
30−mergeOldDocs (L s1 _) (L s2 _) e = L span e
31− where span = case (s1,s2) of
32− (Span start _ d1, Span _ end d2) -> Span start end (d1 ++ "\n\n" ++ d2)
33− (Span _ _ _, _) -> s1
34− (_, Span _ _ _) -> s2
35− (_, _) -> NoSpan ""
36−
37−sameAs (L s _) = L s
38−
39−
40−instance Show SrcPos where
41− show (Pos r c) = show r ++ "," ++ show c
42−
43−instance Show SrcSpan where
44− show span =
45− case span of
46− NoSpan _ -> ""
47− Span start end _ ->
48− case line start == line end of
49− False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
50− True -> "on line " ++ show (line end) ++ ", column " ++
51− show (column start) ++ " to " ++ show (column end)
52−
53−instance Show e => Show (Located e) where
54− show (L _ e) = show e
55−
56−instance Pretty a => Pretty (Located a) where
57− pretty (L _ e) = pretty e
58−
compiler/SourceSyntax/Module.hs+33−3
@@ -1,12 +1,15 @@
1−{-# OPTIONS_GHC -Wall #-}
1+{-# OPTIONS_GHC -W #-}
22module SourceSyntax.Module where
33
44import Data.Binary
5+import qualified Data.List as List
56import qualified Data.Map as Map
67import Control.Applicative ((<$>), (<*>))
8+import Text.PrettyPrint as P
79
8−import SourceSyntax.Expression (LExpr)
10+import SourceSyntax.Expression (Expr)
911import SourceSyntax.Declaration
12+import SourceSyntax.PrettyPrint
1013import SourceSyntax.Type
1114
1215import qualified Elm.Internal.Version as Version
@@ -21,6 +24,33 @@ type Imports = [(String, ImportMethod)]
2124data ImportMethod = As String | Importing [String] | Hiding [String]
2225 deriving (Eq, Ord, Show)
2326
27+instance (Pretty def) => Pretty (Module def) where
28+ pretty (Module modNames exports imports decls) =
29+ P.vcat [modul, P.text "", prettyImports, P.text "", prettyDecls]
30+ where
31+ prettyDecls = P.sep $ map pretty decls
32+
33+ modul = P.text "module" <+> moduleName <+> prettyExports <+> P.text "where"
34+ moduleName = P.text $ List.intercalate "." modNames
35+ prettyExports =
36+ case exports of
37+ [] -> P.empty
38+ _ -> P.parens . commaCat $ map P.text exports
39+
40+ prettyImports = P.vcat $ map prettyImport imports
41+
42+ prettyImport (name, method) =
43+ P.text "import" <+>
44+ case method of
45+ As alias ->
46+ P.text $ name ++ (if name == alias then "" else " as " ++ alias)
47+
48+ Importing values ->
49+ P.text name <+> P.parens (commaCat (map P.text values))
50+
51+ Hiding [] -> P.text ("open " ++ name)
52+ Hiding _ -> error "invalid import declaration"
53+
2454instance Binary ImportMethod where
2555 put method =
2656 let put' n info = putWord8 n >> put info in
@@ -42,7 +72,7 @@ data MetadataModule =
4272 , path :: FilePath
4373 , exports :: [String]
4474 , imports :: [(String, ImportMethod)]
45− , program :: LExpr
75+ , program :: Expr
4676 , types :: Map.Map String Type
4777 , fixities :: [(Assoc, Int, String)]
4878 , aliases :: [Alias]
compiler/SourceSyntax/Pattern.hs+30−26
@@ -7,50 +7,54 @@ import Text.PrettyPrint as PP
77import qualified Data.Set as Set
88import SourceSyntax.Literal as Literal
99
10−data Pattern = PData String [Pattern]
11− | PRecord [String]
12− | PAlias String Pattern
13− | PVar String
14− | PAnything
15− | PLiteral Literal.Literal
16− deriving (Eq, Ord, Show)
10+data Pattern
11+ = Data String [Pattern]
12+ | Record [String]
13+ | Alias String Pattern
14+ | Var String
15+ | Anything
16+ | Literal Literal.Literal
17+ deriving (Eq, Ord, Show)
1718
1819cons :: Pattern -> Pattern -> Pattern
19−cons h t = PData "::" [h,t]
20+cons h t = Data "::" [h,t]
2021
2122nil :: Pattern
22−nil = PData "[]" []
23+nil = Data "[]" []
2324
2425list :: [Pattern] -> Pattern
2526list = foldr cons nil
2627
2728tuple :: [Pattern] -> Pattern
28−tuple es = PData ("_Tuple" ++ show (length es)) es
29+tuple es = Data ("_Tuple" ++ show (length es)) es
30+
31+boundVarList :: Pattern -> [String]
32+boundVarList = Set.toList . boundVars
2933
3034boundVars :: Pattern -> Set.Set String
3135boundVars pattern =
3236 case pattern of
33− PVar x -> Set.singleton x
34− PAlias x p -> Set.insert x (boundVars p)
35− PData _ ps -> Set.unions (map boundVars ps)
36− PRecord fields -> Set.fromList fields
37− PAnything -> Set.empty
38− PLiteral _ -> Set.empty
37+ Var x -> Set.singleton x
38+ Alias x p -> Set.insert x (boundVars p)
39+ Data _ ps -> Set.unions (map boundVars ps)
40+ Record fields -> Set.fromList fields
41+ Anything -> Set.empty
42+ Literal _ -> Set.empty
3943
4044
4145instance Pretty Pattern where
4246 pretty pattern =
4347 case pattern of
44− PVar x -> variable x
45− PLiteral lit -> pretty lit
46− PRecord fs -> PP.braces (commaCat $ map variable fs)
47− PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x
48− PAnything -> PP.text "_"
49− PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
48+ Var x -> variable x
49+ Literal lit -> pretty lit
50+ Record fs -> PP.braces (commaCat $ map variable fs)
51+ Alias x p -> prettyParens p <+> PP.text "as" <+> variable x
52+ Anything -> PP.text "_"
53+ Data "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
5054 where isCons = case hd of
51− PData "::" _ -> True
55+ Data "::" _ -> True
5256 _ -> False
53− PData name ps ->
57+ Data name ps ->
5458 if Help.isTuple name then
5559 PP.parens . commaCat $ map pretty ps
5660 else hsep (PP.text name : map prettyParens ps)
@@ -60,6 +64,6 @@ prettyParens pattern = parensIf needsThem (pretty pattern)
6064 where
6165 needsThem =
6266 case pattern of
63− PData name (_:_) | not (Help.isTuple name) -> True
64− PAlias _ _ -> True
67+ Data name (_:_) | not (Help.isTuple name) -> True
68+ Alias _ _ -> True
6569 _ -> False
compiler/SourceSyntax/PrettyPrint.hs+5
@@ -10,11 +10,16 @@ class Pretty a where
1010instance Pretty () where
1111 pretty () = empty
1212
13+renderPretty :: (Pretty a) => a -> String
14+renderPretty e = render (pretty e)
15+
1316commaCat docs = cat (punctuate comma docs)
1417commaSep docs = sep (punctuate comma docs)
1518
19+parensIf :: Bool -> Doc -> Doc
1620parensIf bool doc = if bool then parens doc else doc
1721
22+variable :: String -> Doc
1823variable x =
1924 if Help.isOp x then parens (text x)
2025 else text (reprime x)
compiler/SourceSyntax/Type.hs+3−6
@@ -1,18 +1,18 @@
11{-# OPTIONS_GHC -W #-}
22module SourceSyntax.Type where
33
4+import Control.Applicative ((<$>), (<*>))
45import Data.Binary
56import qualified Data.Map as Map
6−import qualified SourceSyntax.Helpers as Help
7−import Control.Applicative ((<$>), (<*>))
87import SourceSyntax.PrettyPrint
8+import qualified SourceSyntax.Helpers as Help
99import Text.PrettyPrint as P
1010
1111data Type = Lambda Type Type
1212 | Var String
1313 | Data String [Type]
1414 | Record [(String,Type)] (Maybe String)
15− deriving (Eq)
15+ deriving (Eq,Show)
1616
1717fieldMap :: [(String,a)] -> Map.Map String [a]
1818fieldMap fields =
@@ -27,9 +27,6 @@ listOf t = Data "_List" [t]
2727tupleOf :: [Type] -> Type
2828tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
2929
30−instance Show Type where
31− show = render . pretty
32−
3330instance Pretty Type where
3431 pretty tipe =
3532 case tipe of
compiler/SourceSyntax/Variable.hsnew file+11
@@ -0,0 +1,11 @@
1+
2+module SourceSyntax.Variable where
3+
4+import qualified Text.PrettyPrint as P
5+import SourceSyntax.PrettyPrint
6+
7+newtype Raw = Raw String
8+ deriving (Eq,Ord,Show)
9+
10+instance Pretty Raw where
11+ pretty (Raw var) = variable var
compiler/Transform/Canonicalize.hs+30−22
@@ -1,19 +1,21 @@
1−{-# OPTIONS_GHC -W #-}
1+{-# OPTIONS_GHC -Wall #-}
22module Transform.Canonicalize (interface, metadataModule) where
33
44import Control.Arrow ((***))
55import Control.Applicative (Applicative,(<$>),(<*>))
66import Control.Monad.Identity
7−import qualified Data.Traversable as T
7+import qualified Data.Either as Either
8+import qualified Data.List as List
89import qualified Data.Map as Map
910import qualified Data.Set as Set
10−import qualified Data.List as List
11−import qualified Data.Either as Either
12−import SourceSyntax.Module
11+import qualified Data.Traversable as T
12+import SourceSyntax.Annotation as A
1313import SourceSyntax.Expression
14−import SourceSyntax.Location as Loc
14+import SourceSyntax.Module
15+import SourceSyntax.PrettyPrint (pretty)
1516import qualified SourceSyntax.Pattern as P
1617import qualified SourceSyntax.Type as Type
18+import qualified SourceSyntax.Variable as Var
1719import Text.PrettyPrint as P
1820
1921interface :: String -> ModuleInterface -> ModuleInterface
@@ -55,7 +57,9 @@ metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
5557metadataModule ifaces modul =
5658 do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
5759 [] -> Right ()
58− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
60+ missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ++
61+ "\n You may need to compile with the --make flag to detect modules you have written."
62+ ]
5963 program' <- rename initialEnv (program modul)
6064 aliases' <- mapM (three3 renameType') (aliases modul)
6165 datatypes' <- mapM (three3 (mapM (two2 (mapM renameType')))) (datatypes modul)
@@ -94,8 +98,7 @@ type Env = Map.Map String String
9498
9599extend :: Env -> P.Pattern -> Env
96100extend env pattern = Map.union (Map.fromList (zip xs xs)) env
97− where xs = Set.toList (P.boundVars pattern)
98−
101+ where xs = P.boundVarList pattern
99102
100103replace :: String -> Env -> String -> Either String String
101104replace variable env v =
@@ -108,14 +111,18 @@ replace variable env v =
108111 msg = if null matches then "" else
109112 "\nClose matches include: " ++ List.intercalate ", " matches
110113
111−rename :: Env -> LExpr -> Either [Doc] LExpr
112−rename env (L s expr) =
114+-- TODO: Var.Raw -> Var.Canonical
115+rename :: Env -> Expr -> Either [Doc] Expr
116+rename env (A ann expr) =
113117 let rnm = rename env
114− throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
118+ throw err = Left [ P.vcat [ P.text "Error" <+> pretty ann <> P.colon
119+ , P.text err
120+ ]
121+ ]
115122 format = Either.either throw return
116− renameType' env = renameType (format . replace "variable" env)
123+ renameType' environ = renameType (format . replace "variable" environ)
117124 in
118− L s <$>
125+ A ann <$>
119126 case expr of
120127 Literal _ -> return expr
121128
@@ -153,7 +160,8 @@ rename env (L s expr) =
153160 <*> rename env' body
154161 <*> T.traverse (renameType' env') mtipe
155162
156− Var x -> Var <$> format (replace "variable" env x)
163+ -- TODO: Raw -> Canonical
164+ Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)
157165
158166 Data name es -> Data name <$> mapM rnm es
159167
@@ -174,10 +182,10 @@ rename env (L s expr) =
174182renamePattern :: Env -> P.Pattern -> Either String P.Pattern
175183renamePattern env pattern =
176184 case pattern of
177− P.PVar _ -> return pattern
178− P.PLiteral _ -> return pattern
179− P.PRecord _ -> return pattern
180− P.PAnything -> return pattern
181− P.PAlias x p -> P.PAlias x <$> renamePattern env p
182− P.PData name ps -> P.PData <$> replace "pattern" env name
183− <*> mapM (renamePattern env) ps
185+ P.Var _ -> return pattern
186+ P.Literal _ -> return pattern
187+ P.Record _ -> return pattern
188+ P.Anything -> return pattern
189+ P.Alias x p -> P.Alias x <$> renamePattern env p
190+ P.Data name ps -> P.Data <$> replace "pattern" env name
191+ <*> mapM (renamePattern env) ps
compiler/Transform/Check.hs+4−5
@@ -32,7 +32,7 @@ dupErr err x =
3232
3333duplicates :: [D.Declaration] -> [String]
3434duplicates decls =
35− map msg (dups (portNames ++ concatMap getNames defPatterns)) ++
35+ map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
3636 case mapM exprDups (portExprs ++ defExprs) of
3737 Left name -> [msg name]
3838 Right _ -> []
@@ -50,14 +50,13 @@ duplicates decls =
5050 D.Out name expr _ -> (name, [expr])
5151 D.In name _ -> (name, [])
5252
53− getNames = Set.toList . Pattern.boundVars
54−
55− exprDups :: E.LExpr -> Either String E.LExpr
53+ exprDups :: E.Expr -> Either String E.Expr
5654 exprDups expr = Expr.crawlLet defsDups expr
5755
5856 defsDups :: [E.Def] -> Either String [E.Def]
5957 defsDups defs =
60− case dups $ concatMap (\(E.Definition name _ _) -> getNames name) defs of
58+ let varsIn (E.Definition pattern _ _) = Pattern.boundVarList pattern in
59+ case dups $ concatMap varsIn defs of
6160 [] -> Right defs
6261 name:_ -> Left name
6362
compiler/Transform/Declaration.hs+1−1
@@ -42,7 +42,7 @@ combineAnnotations = go
4242
4343 TypeAnnotation name tipe ->
4444 case defRest of
45− D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->
45+ D.Definition (Def pat@(P.Var name') expr) : rest | name == name' ->
4646 do expr' <- exprCombineAnnotations expr
4747 let def' = E.Definition pat expr' (Just tipe)
4848 (:) (D.Definition def') <$> go rest
compiler/Transform/Definition.hs+1−1
@@ -16,7 +16,7 @@ combineAnnotations = go
1616
1717 go defs =
1818 case defs of
19− TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' ->
19+ TypeAnnotation name tipe : Def pat@(P.Var name') expr : rest | name == name' ->
2020 do expr' <- exprCombineAnnotations expr
2121 let def = Definition pat expr' (Just tipe)
2222 (:) def <$> go rest
compiler/Transform/Expression.hs+15−13
@@ -2,17 +2,19 @@
22module Transform.Expression (crawlLet, checkPorts) where
33
44import Control.Applicative ((<$>),(<*>))
5+import SourceSyntax.Annotation ( Annotated(A) )
56import SourceSyntax.Expression
6−import SourceSyntax.Location
7−import qualified SourceSyntax.Type as ST
7+import SourceSyntax.Type (Type)
88
9−crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')
9+crawlLet :: ([def] -> Either a [def'])
10+ -> GeneralExpr ann def var
11+ -> Either a (GeneralExpr ann def' var)
1012crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
1113
12−checkPorts :: (String -> ST.Type -> Either a ())
13− -> (String -> ST.Type -> Either a ())
14− -> LExpr
15− -> Either a LExpr
14+checkPorts :: (String -> Type -> Either a ())
15+ -> (String -> Type -> Either a ())
16+ -> Expr
17+ -> Either a Expr
1618checkPorts inCheck outCheck expr =
1719 crawl inCheck outCheck (mapM checkDef) expr
1820 where
@@ -20,15 +22,15 @@ checkPorts inCheck outCheck expr =
2022 do _ <- checkPorts inCheck outCheck body
2123 return def
2224
23−crawl :: (String -> ST.Type -> Either a ())
24− -> (String -> ST.Type -> Either a ())
25+crawl :: (String -> Type -> Either a ())
26+ -> (String -> Type -> Either a ())
2527 -> ([def] -> Either a [def'])
26− -> LExpr' def
27− -> Either a (LExpr' def')
28+ -> GeneralExpr ann def var
29+ -> Either a (GeneralExpr ann def' var)
2830crawl portInCheck portOutCheck defsTransform = go
2931 where
30− go (L srcSpan expr) =
31− L srcSpan <$>
32+ go (A srcSpan expr) =
33+ A srcSpan <$>
3234 case expr of
3335 Var x -> return (Var x)
3436 Lambda p e -> Lambda p <$> go e
compiler/Transform/SafeNames.hs+21−16
@@ -2,38 +2,43 @@
22module Transform.SafeNames (metadataModule) where
33
44import Control.Arrow (first, (***))
5−import SourceSyntax.Expression
6−import SourceSyntax.Location
7−import SourceSyntax.Module
8−import SourceSyntax.Pattern
5+import qualified Data.List as List
96import qualified Data.Set as Set
7+
108import qualified Parse.Helpers as PHelp
9+import SourceSyntax.Annotation
10+import SourceSyntax.Expression
11+import qualified SourceSyntax.Helpers as SHelp
12+import SourceSyntax.Module
13+import qualified SourceSyntax.Pattern as P
14+import qualified SourceSyntax.Variable as Variable
1115
1216var :: String -> String
13−var = dereserve . deprime
17+var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots
1418 where
1519 deprime = map (\c -> if c == '\'' then '$' else c)
1620 dereserve x = case Set.member x PHelp.jsReserveds of
1721 False -> x
1822 True -> "$" ++ x
1923
20−pattern :: Pattern -> Pattern
24+pattern :: P.Pattern -> P.Pattern
2125pattern pat =
2226 case pat of
23− PVar x -> PVar (var x)
24− PLiteral _ -> pat
25− PRecord fs -> PRecord (map var fs)
26− PAnything -> pat
27− PAlias x p -> PAlias (var x) (pattern p)
28− PData name ps -> PData name (map pattern ps)
27+ P.Var x -> P.Var (var x)
28+ P.Literal _ -> pat
29+ P.Record fs -> P.Record (map var fs)
30+ P.Anything -> pat
31+ P.Alias x p -> P.Alias (var x) (pattern p)
32+ P.Data name ps -> P.Data name (map pattern ps)
2933
30−expression :: LExpr -> LExpr
31−expression (L loc expr) =
34+-- TODO: should be "normal expression" -> "expression for JS generation"
35+expression :: Expr -> Expr
36+expression (A ann expr) =
3237 let f = expression in
33− L loc $
38+ A ann $
3439 case expr of
3540 Literal _ -> expr
36− Var x -> Var (var x)
41+ Var (Variable.Raw x) -> rawVar (var x)
3742 Range e1 e2 -> Range (f e1) (f e2)
3843 ExplicitList es -> ExplicitList (map f es)
3944 Binop op e1 e2 -> Binop op (f e1) (f e2)
compiler/Transform/SortDefinitions.hs+18−17
@@ -3,23 +3,24 @@ module Transform.SortDefinitions (sortDefs) where
33
44import Control.Monad.State
55import Control.Applicative ((<$>),(<*>))
6+import qualified Data.Graph as Graph
67import qualified Data.Map as Map
8+import qualified Data.Maybe as Maybe
9+import qualified Data.Set as Set
10+import SourceSyntax.Annotation
711import SourceSyntax.Expression
8−import SourceSyntax.Location
912import qualified SourceSyntax.Pattern as P
10−import qualified Data.Graph as Graph
11−import qualified Data.Set as Set
12−import qualified Data.Maybe as Maybe
13+import qualified SourceSyntax.Variable as V
1314
1415ctors :: P.Pattern -> [String]
1516ctors pattern =
1617 case pattern of
17− P.PVar _ -> []
18− P.PAlias _ p -> ctors p
19− P.PData ctor ps -> ctor : concatMap ctors ps
20− P.PRecord _ -> []
21− P.PAnything -> []
22− P.PLiteral _ -> []
18+ P.Var _ -> []
19+ P.Alias _ p -> ctors p
20+ P.Data ctor ps -> ctor : concatMap ctors ps
21+ P.Record _ -> []
22+ P.Anything -> []
23+ P.Literal _ -> []
2324
2425free :: String -> State (Set.Set String) ()
2526free x = modify (Set.insert x)
@@ -27,15 +28,15 @@ free x = modify (Set.insert x)
2728bound :: Set.Set String -> State (Set.Set String) ()
2829bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
2930
30−sortDefs :: LExpr -> LExpr
31+sortDefs :: Expr -> Expr
3132sortDefs expr = evalState (reorder expr) Set.empty
3233
33−reorder :: LExpr -> State (Set.Set String) LExpr
34−reorder (L s expr) =
35− L s <$>
34+reorder :: Expr -> State (Set.Set String) Expr
35+reorder (A ann expr) =
36+ A ann <$>
3637 case expr of
3738 -- Be careful adding and restricting freeVars
38− Var x -> free x >> return expr
39+ Var (V.Raw x) -> free x >> return expr
3940
4041 Lambda p e ->
4142 uncurry Lambda <$> bindingReorder (p,e)
@@ -103,11 +104,11 @@ reorder (L s expr) =
103104 bound (P.boundVars pattern)
104105 mapM free (ctors pattern)
105106
106− let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss
107+ let A _ let' = foldr (\ds bod -> A ann (Let ds bod)) body' defss
107108
108109 return let'
109110
110−bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)
111+bindingReorder :: (P.Pattern, Expr) -> State (Set.Set String) (P.Pattern, Expr)
111112bindingReorder (pattern,expr) =
112113 do expr' <- reorder expr
113114 bound (P.boundVars pattern)
compiler/Transform/Substitute.hs+8−6
@@ -2,14 +2,16 @@
22module Transform.Substitute (subst) where
33
44import Control.Arrow (second, (***))
5+import qualified Data.Set as Set
6+
7+import SourceSyntax.Annotation
58import SourceSyntax.Expression
6−import SourceSyntax.Location
79import qualified SourceSyntax.Pattern as Pattern
8−import qualified Data.Set as Set
10+import qualified SourceSyntax.Variable as V
911
10−subst :: String -> Expr -> Expr -> Expr
12+subst :: String -> Expr' -> Expr' -> Expr'
1113subst old new expr =
12− let f (L s e) = L s (subst old new e) in
14+ let f (A a e) = A a (subst old new e) in
1315 case expr of
1416 Range e1 e2 -> Range (f e1) (f e2)
1517 ExplicitList es -> ExplicitList (map f es)
@@ -28,7 +30,7 @@ subst old new expr =
2830 anyShadow =
2931 any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]
3032
31− Var x -> if x == old then new else expr
33+ Var (V.Raw x) -> if x == old then new else expr
3234 Case e cases -> Case (f e) $ map (second f) cases
3335 Data name es -> Data name (map f es)
3436 Access e x -> Access (f e) x
@@ -39,4 +41,4 @@ subst old new expr =
3941 Literal _ -> expr
4042 Markdown uid md es -> Markdown uid md (map f es)
4143 PortIn name st -> PortIn name st
42− PortOut name st signal -> PortOut name st (f signal)
44+ PortOut name st signal -> PortOut name st (f signal)
compiler/Type/Constrain/Declaration.hs+23−23
@@ -1,62 +1,62 @@
11{-# OPTIONS_GHC -Wall #-}
22module Type.Constrain.Declaration where
33
4−import SourceSyntax.Declaration
4+import qualified SourceSyntax.Annotation as A
5+import qualified SourceSyntax.Declaration as D
56import qualified SourceSyntax.Expression as E
6−import qualified SourceSyntax.Location as L
77import qualified SourceSyntax.Pattern as P
88import qualified SourceSyntax.Type as T
99
10−toExpr :: [Declaration] -> [E.Def]
10+toExpr :: [D.Declaration] -> [E.Def]
1111toExpr = concatMap toDefs
1212
13−toDefs :: Declaration -> [E.Def]
13+toDefs :: D.Declaration -> [E.Def]
1414toDefs decl =
1515 case decl of
16− Definition def -> [def]
16+ D.Definition def -> [def]
1717
18− Datatype name tvars constructors -> concatMap toDefs' constructors
18+ D.Datatype name tvars constructors -> concatMap toDefs' constructors
1919 where
2020 toDefs' (ctor, tipes) =
2121 let vars = take (length tipes) arguments
2222 tbody = T.Data name $ map T.Var tvars
23− body = L.none . E.Data ctor $ map (L.none . E.Var) vars
23+ body = A.none . E.Data ctor $ map (A.none . E.rawVar) vars
2424 in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
2525
26− TypeAlias name _ tipe@(T.Record fields ext) ->
26+ D.TypeAlias name _ tipe@(T.Record fields ext) ->
2727 [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
2828 where
2929 args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
3030
31− var = L.none . E.Var
31+ var = A.none . E.rawVar
3232 vars = take (length args) arguments
3333
3434 efields = zip (map fst fields) (map var vars)
3535 record = case ext of
36− Nothing -> L.none $ E.Record efields
37− Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields
36+ Nothing -> A.none $ E.Record efields
37+ Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
3838
3939 -- Type aliases must be added to an extended equality dictionary,
4040 -- but they do not require any basic constraints.
41− TypeAlias _ _ _ -> []
41+ D.TypeAlias _ _ _ -> []
4242
43− Port port ->
43+ D.Port port ->
4444 case port of
45− Out name expr@(L.L s _) tipe ->
46− [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
47− In name tipe ->
48− [ definition name (L.none $ E.PortIn name tipe) tipe ]
45+ D.Out name expr@(A.A s _) tipe ->
46+ [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
47+ D.In name tipe ->
48+ [ definition name (A.none $ E.PortIn name tipe) tipe ]
4949
5050 -- no constraints are needed for fixity declarations
51− Fixity _ _ _ -> []
51+ D.Fixity _ _ _ -> []
5252
5353
5454arguments :: [String]
5555arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
5656
57−buildFunction :: E.LExpr -> [String] -> E.LExpr
58−buildFunction body@(L.L s _) vars =
59− foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)
57+buildFunction :: E.Expr -> [String] -> E.Expr
58+buildFunction body@(A.A s _) vars =
59+ foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
6060
61−definition :: String -> E.LExpr -> T.Type -> E.Def
62−definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)
61+definition :: String -> E.Expr -> T.Type -> E.Def
62+definition name expr tipe = E.Definition (P.Var name) expr (Just tipe)
compiler/Type/Constrain/Expression.hs+38−37
@@ -1,44 +1,45 @@
11{-# OPTIONS_GHC -W #-}
22module Type.Constrain.Expression where
33
4−import qualified Data.List as List
5−import qualified Data.Map as Map
6−import qualified Data.Set as Set
74import Control.Applicative ((<$>))
85import qualified Control.Monad as Monad
96import Control.Monad.Error
7+import qualified Data.List as List
8+import qualified Data.Map as Map
109import qualified Text.PrettyPrint as PP
1110
12−import SourceSyntax.Location as Loc
13−import SourceSyntax.Pattern (Pattern(PVar), boundVars)
11+import SourceSyntax.Annotation as Ann
1412import SourceSyntax.Expression
15−import qualified SourceSyntax.Type as SrcT
13+import qualified SourceSyntax.Pattern as P
14+import qualified SourceSyntax.Type as ST
15+import qualified SourceSyntax.Variable as V
1616import Type.Type hiding (Descriptor(..))
1717import Type.Fragment
1818import qualified Type.Environment as Env
1919import qualified Type.Constrain.Literal as Literal
2020import qualified Type.Constrain.Pattern as Pattern
2121
22−constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
23−constrain env (L span expr) tipe =
22+constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
23+constrain env (A region expr) tipe =
2424 let list t = Env.get env Env.types "_List" <| t
25− and = L span . CAnd
26− true = L span CTrue
27− t1 === t2 = L span (CEqual t1 t2)
28− x <? t = L span (CInstance x t)
29− clet schemes c = L span (CLet schemes c)
25+ and = A region . CAnd
26+ true = A region CTrue
27+ t1 === t2 = A region (CEqual t1 t2)
28+ x <? t = A region (CInstance x t)
29+ clet schemes c = A region (CLet schemes c)
3030 in
3131 case expr of
32− Literal lit -> liftIO $ Literal.constrain env span lit tipe
32+ Literal lit -> liftIO $ Literal.constrain env region lit tipe
3333
34− Var name | name == saveEnvName -> return (L span CSaveEnv)
35− | otherwise -> return (name <? tipe)
34+ Var (V.Raw name)
35+ | name == saveEnvName -> return (A region CSaveEnv)
36+ | otherwise -> return (name <? tipe)
3637
3738 Range lo hi ->
38− exists $ \x -> do
39− clo <- constrain env lo x
40− chi <- constrain env hi x
41− return $ and [clo, chi, list x === tipe]
39+ existsNumber $ \n -> do
40+ clo <- constrain env lo n
41+ chi <- constrain env hi n
42+ return $ and [clo, chi, list n === tipe]
4243
4344 ExplicitList exprs ->
4445 exists $ \x -> do
@@ -55,7 +56,7 @@ constrain env (L span expr) tipe =
5556 Lambda p e ->
5657 exists $ \t1 ->
5758 exists $ \t2 -> do
58− fragment <- try span $ Pattern.constrain env p t1
59+ fragment <- try region $ Pattern.constrain env p t1
5960 c2 <- constrain env e t2
6061 let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
6162 (typeConstraint fragment /\ c2 ))
@@ -79,7 +80,7 @@ constrain env (L span expr) tipe =
7980 exists $ \t -> do
8081 ce <- constrain env exp t
8182 let branch (p,e) = do
82− fragment <- try span $ Pattern.constrain env p t
83+ fragment <- try region $ Pattern.constrain env p t
8384 clet [toScheme fragment] <$> constrain env e tipe
8485 and . (:) ce <$> mapM branch branches
8586
@@ -112,11 +113,11 @@ constrain env (L span expr) tipe =
112113 Modify e fields ->
113114 exists $ \t -> do
114115 oldVars <- forM fields $ \_ -> liftIO (var Flexible)
115− let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))
116+ let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))
116117 cOld <- ex oldVars <$> constrain env e (record oldFields t)
117118
118119 newVars <- forM fields $ \_ -> liftIO (var Flexible)
119− let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))
120+ let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))
120121 let cNew = tipe === record newFields t
121122
122123 cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
@@ -126,7 +127,7 @@ constrain env (L span expr) tipe =
126127 Record fields ->
127128 do vars <- forM fields $ \_ -> liftIO (var Flexible)
128129 cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
129− let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))
130+ let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))
130131 recordType = record fields' (TermN EmptyRecord1)
131132 return . ex vars . and $ tipe === recordType : cs
132133
@@ -158,14 +159,14 @@ constrainDef env info (Definition pattern expr maybeTipe) =
158159 do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.
159160 -- Currently, qs is always [].
160161 case (pattern, maybeTipe) of
161− (PVar name, Just tipe) -> do
162+ (P.Var name, Just tipe) -> do
162163 flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
163164 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
164165 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
165166 (vars, typ) <- Env.instantiateType env tipe Map.empty
166167 let scheme = Scheme { rigidQuantifiers = [],
167168 flexibleQuantifiers = flexiVars ++ vars,
168− constraint = Loc.noneNoDocs CTrue,
169+ constraint = Ann.noneNoDocs CTrue,
169170 header = Map.singleton name typ }
170171 c <- constrain env' expr typ
171172 return ( scheme : schemes
@@ -175,7 +176,7 @@ constrainDef env info (Definition pattern expr maybeTipe) =
175176 , c2
176177 , fl rigidVars c /\ c1 )
177178
178− (PVar name, Nothing) -> do
179+ (P.Var name, Nothing) -> do
179180 v <- liftIO $ var Flexible
180181 let tipe = VarN v
181182 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
@@ -191,19 +192,19 @@ constrainDef env info (Definition pattern expr maybeTipe) =
191192 _ -> error (show pattern)
192193
193194expandPattern :: Def -> [Def]
194−expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =
195+expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =
195196 case pattern of
196− PVar _ -> [def]
197− _ -> Definition (PVar x) lexpr maybeType : map toDef vars
197+ P.Var _ -> [def]
198+ _ -> Definition (P.Var x) lexpr maybeType : map toDef vars
198199 where
199− vars = Set.toList $ boundVars pattern
200+ vars = P.boundVarList pattern
200201 x = "$" ++ concat vars
201− mkVar = L s . Var
202− toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
202+ mkVar = A r . rawVar
203+ toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
203204
204−try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
205−try span computation = do
205+try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
206+try region computation = do
206207 result <- liftIO $ runErrorT computation
207208 case result of
208− Left err -> throwError [err span]
209+ Left err -> throwError [err region]
209210 Right value -> return value
compiler/Type/Constrain/Literal.hs+5−4
@@ -1,14 +1,15 @@
1+{-# OPTIONS_GHC -W #-}
12module Type.Constrain.Literal where
23
4+import SourceSyntax.Annotation
35import SourceSyntax.Literal
4−import SourceSyntax.Location
56import Type.Type
67import Type.Environment as Env
78
8−constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint
9−constrain env span literal tipe =
9+constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint
10+constrain env region literal tipe =
1011 do tipe' <- litType
11− return . L span $ CEqual tipe tipe'
12+ return . A region $ CEqual tipe tipe'
1213 where
1314 prim name = return (Env.get env Env.types name)
1415
compiler/Type/Constrain/Pattern.hs+17−18
@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -W #-}
12{-# LANGUAGE FlexibleInstances #-}
23module Type.Constrain.Pattern where
34
@@ -8,31 +9,29 @@ import Control.Monad.Error
89import qualified Data.Map as Map
910import qualified Text.PrettyPrint as PP
1011
11−import SourceSyntax.Pattern
12−import SourceSyntax.Location
13−import SourceSyntax.PrettyPrint
14−import Text.PrettyPrint (render)
15−import qualified SourceSyntax.Location as Loc
12+import qualified SourceSyntax.Annotation as A
13+import qualified SourceSyntax.Pattern as P
14+import SourceSyntax.PrettyPrint (pretty)
1615import Type.Type
1716import Type.Fragment
1817import Type.Environment as Env
1918import qualified Type.Constrain.Literal as Literal
2019
2120
22−constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment
21+constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment
2322constrain env pattern tipe =
24− let span = Loc.NoSpan (render $ pretty pattern)
25− t1 === t2 = Loc.L span (CEqual t1 t2)
26− x <? t = Loc.L span (CInstance x t)
23+ let region = A.None (pretty pattern)
24+ t1 === t2 = A.A region (CEqual t1 t2)
25+ x <? t = A.A region (CInstance x t)
2726 in
2827 case pattern of
29− PAnything -> return emptyFragment
28+ P.Anything -> return emptyFragment
3029
31− PLiteral lit -> do
32− c <- liftIO $ Literal.constrain env span lit tipe
30+ P.Literal lit -> do
31+ c <- liftIO $ Literal.constrain env region lit tipe
3332 return $ emptyFragment { typeConstraint = c }
3433
35− PVar name -> do
34+ P.Var name -> do
3635 v <- liftIO $ var Flexible
3736 return $ Fragment {
3837 typeEnv = Map.singleton name (VarN v),
@@ -40,14 +39,14 @@ constrain env pattern tipe =
4039 typeConstraint = VarN v === tipe
4140 }
4241
43− PAlias name p -> do
42+ P.Alias name p -> do
4443 fragment <- constrain env p tipe
4544 return $ fragment {
4645 typeEnv = Map.insert name tipe (typeEnv fragment),
4746 typeConstraint = name <? tipe /\ typeConstraint fragment
4847 }
4948
50− PData name patterns -> do
49+ P.Data name patterns -> do
5150 (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
5251 let msg = concat [ "Constructor '", name, "' expects ", show kind
5352 , " argument", if kind == 1 then "" else "s"
@@ -63,7 +62,7 @@ constrain env pattern tipe =
6362 vars = cvars ++ vars fragment
6463 }
6564
66− PRecord fields -> do
65+ P.Record fields -> do
6766 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
6867 let tenv = Map.fromList (map (second VarN) pairs)
6968 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
@@ -73,8 +72,8 @@ constrain env pattern tipe =
7372 typeConstraint = c
7473 }
7574
76−instance Error (SrcSpan -> PP.Doc) where
75+instance Error (A.Region -> PP.Doc) where
7776 noMsg _ = PP.empty
7877 strMsg str span =
7978 PP.vcat [ PP.text $ "Type error " ++ show span
80− , PP.text str ]
79+ , PP.text str ]
compiler/Type/ExtraChecks.hs+39−36
@@ -1,32 +1,35 @@
11{-# OPTIONS_GHC -W #-}
2+
3+{-| This module contains checks to be run *after* type inference has completed
4+successfully. At that point we still need to do occurs checks and ensure that
5+`main` has an acceptable type.
6+-}
27module Type.ExtraChecks (mainType, occurs, portTypes) where
3−-- This module contains checks to be run *after* type inference has
4−-- completed successfully. At that point we still need to do occurs
5−-- checks and ensure that `main` has an acceptable type.
68
79import Control.Applicative ((<$>),(<*>))
810import Control.Monad.State
911import qualified Data.List as List
1012import qualified Data.Map as Map
13+import qualified Data.Traversable as Traverse
1114import qualified Data.UnionFind.IO as UF
12−import Type.Type ( Variable, structure, Term1(..), toSrcType )
13−import qualified Type.State as TS
14−import qualified Type.Alias as Alias
1515import Text.PrettyPrint as P
16−import SourceSyntax.PrettyPrint (pretty)
17−import qualified SourceSyntax.Helpers as Help
18−import qualified SourceSyntax.Type as T
16+
17+import qualified SourceSyntax.Annotation as A
1918import qualified SourceSyntax.Expression as E
20−import qualified SourceSyntax.Location as L
19+import qualified SourceSyntax.Helpers as Help
20+import qualified SourceSyntax.PrettyPrint as SPP
21+import qualified SourceSyntax.Type as ST
2122import qualified Transform.Expression as Expr
22−import qualified Data.Traversable as Traverse
23+import qualified Type.Type as TT
24+import qualified Type.State as TS
25+import qualified Type.Alias as Alias
2326
2427throw err = Left [ P.vcat err ]
2528
26−mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))
27−mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
29+mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))
30+mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env
2831 where
29− mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)
32+ mainCheck :: Alias.Rules -> Map.Map String ST.Type -> Either [P.Doc] (Map.Map String ST.Type)
3033 mainCheck rules env =
3134 case Map.lookup "main" env of
3235 Nothing -> Right env
@@ -37,40 +40,40 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
3740 acceptable = [ "Graphics.Element.Element"
3841 , "Signal.Signal Graphics.Element.Element" ]
3942
40− tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType
43+ tipe = SPP.renderPretty $ Alias.canonicalRealias (fst rules) mainType
4144 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
4245 , P.text "Instead 'main' has type:\n"
43− , P.nest 4 . pretty $ Alias.realias rules mainType
46+ , P.nest 4 . SPP.pretty $ Alias.realias rules mainType
4447 , P.text " " ]
4548
4649data Direction = In | Out
4750
48−portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
51+portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()
4952portTypes rules expr =
5053 const () <$> Expr.checkPorts (check In) (check Out) expr
5154 where
5255 check = isValid True False False
5356 isValid isTopLevel seenFunc seenSignal direction name tipe =
5457 case tipe of
55− T.Data ctor ts
58+ ST.Data ctor ts
5659 | isJs ctor || isElm ctor -> mapM_ valid ts
5760 | ctor == "Signal.Signal" -> handleSignal ts
5861 | otherwise -> err' True "an unsupported type"
5962
60− T.Var _ -> err "free type variables"
63+ ST.Var _ -> err "free type variables"
6164
62− T.Lambda _ _ ->
65+ ST.Lambda _ _ ->
6366 case direction of
6467 In -> err "functions"
6568 Out | seenFunc -> err "higher-order functions"
6669 | seenSignal -> err "signals that contain functions"
6770 | otherwise ->
68− forM_ (T.collectLambdas tipe)
71+ forM_ (ST.collectLambdas tipe)
6972 (isValid' True seenSignal direction name)
7073
71− T.Record _ (Just _) -> err "extended records with free type variables"
74+ ST.Record _ (Just _) -> err "extended records with free type variables"
7275
73− T.Record fields Nothing ->
76+ ST.Record fields Nothing ->
7477 mapM_ (\(k,v) -> (,) k <$> valid v) fields
7578
7679 where
@@ -100,7 +103,7 @@ portTypes rules expr =
100103 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
101104 , " through port '", name, "' is invalid." ]
102105 , txt [ "It contains ", kind, ":\n" ]
103− , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
106+ , (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"
104107 , txt [ "Acceptable values for ", dir "incoming" "outgoing"
105108 , " ports include JavaScript values and" ]
106109 , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
@@ -112,37 +115,37 @@ portTypes rules expr =
112115 , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]
113116 ]
114117
115−occurs :: (String, Variable) -> StateT TS.SolverState IO ()
118+occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
116119occurs (name, variable) =
117120 do vars <- liftIO $ infiniteVars [] variable
118121 case vars of
119122 [] -> return ()
120123 var:_ -> do
121124 desc <- liftIO $ UF.descriptor var
122− case structure desc of
125+ case TT.structure desc of
123126 Nothing ->
124127 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
125128 Just _ ->
126− do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
129+ do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
127130 var' <- liftIO $ UF.fresh desc
128− TS.addError (L.NoSpan name) (Just msg) var var'
131+ TS.addError (A.None (P.text name)) (Just msg) var var'
129132 where
130133 msg = "Infinite types are not allowed"
131134 fallback _ = return $ P.text msg
132135
133− infiniteVars :: [Variable] -> Variable -> IO [Variable]
134− infiniteVars seen var =
136+ infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
137+ infiniteVars seen var =
135138 let go = infiniteVars (var:seen) in
136139 if var `elem` seen
137140 then return [var]
138141 else do
139142 desc <- UF.descriptor var
140− case structure desc of
143+ case TT.structure desc of
141144 Nothing -> return []
142145 Just struct ->
143146 case struct of
144− App1 a b -> (++) <$> go a <*> go b
145− Fun1 a b -> (++) <$> go a <*> go b
146− Var1 a -> go a
147− EmptyRecord1 -> return []
148− Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
147+ TT.App1 a b -> (++) <$> go a <*> go b
148+ TT.Fun1 a b -> (++) <$> go a <*> go b
149+ TT.Var1 a -> go a
150+ TT.EmptyRecord1 -> return []
151+ TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
compiler/Type/Fragment.hs+12−13
@@ -5,24 +5,23 @@ import qualified Data.Map as Map
55
66import Type.Type
77import SourceSyntax.Pattern
8−import SourceSyntax.Location (noneNoDocs)
8+import SourceSyntax.Annotation (noneNoDocs)
99
10−data Fragment = Fragment {
11− typeEnv :: Map.Map String Type,
12− vars :: [Variable],
13− typeConstraint :: TypeConstraint
14−} deriving Show
10+data Fragment = Fragment
11+ { typeEnv :: Map.Map String Type
12+ , vars :: [Variable]
13+ , typeConstraint :: TypeConstraint
14+ } deriving Show
1515
1616emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
1717
18−joinFragment f1 f2 = Fragment {
19− typeEnv = Map.union (typeEnv f1) (typeEnv f2),
20− vars = vars f1 ++ vars f2,
21− typeConstraint = typeConstraint f1 /\ typeConstraint f2
22−}
18+joinFragment f1 f2 = Fragment
19+ { typeEnv = Map.union (typeEnv f1) (typeEnv f2)
20+ , vars = vars f1 ++ vars f2
21+ , typeConstraint = typeConstraint f1 /\ typeConstraint f2
22+ }
2323
2424joinFragments = List.foldl' (flip joinFragment) emptyFragment
2525
26−
2726toScheme fragment =
28− Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)
27+ Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)
compiler/Type/Inference.hs+1−1
@@ -9,7 +9,7 @@ import qualified Type.Constrain.Expression as TcExpr
99import qualified Type.Solve as Solve
1010
1111import SourceSyntax.Module as Module
12−import SourceSyntax.Location (noneNoDocs)
12+import SourceSyntax.Annotation (noneNoDocs)
1313import SourceSyntax.Type (Type)
1414import Text.PrettyPrint
1515import qualified Type.State as TS
compiler/Type/Solve.hs+19−19
@@ -3,15 +3,15 @@ module Type.Solve (solve) where
33
44import Control.Monad
55import Control.Monad.State
6−import qualified Data.UnionFind.IO as UF
6+import qualified Data.List as List
77import qualified Data.Map as Map
88import qualified Data.Traversable as Traversable
9−import qualified Data.List as List
9+import qualified Data.UnionFind.IO as UF
1010import Type.Type
1111import Type.Unify
1212import qualified Type.ExtraChecks as Check
1313import qualified Type.State as TS
14−import SourceSyntax.Location (Located(L), SrcSpan)
14+import qualified SourceSyntax.Annotation as A
1515
1616
1717-- | Every variable has rank less than or equal to the maxRank of the pool.
@@ -96,7 +96,7 @@ adjustRank youngMark visitedMark groupRank variable =
9696
9797
9898solve :: TypeConstraint -> StateT TS.SolverState IO ()
99−solve (L span constraint) =
99+solve (A.A region constraint) =
100100 case constraint of
101101 CTrue -> return ()
102102
@@ -105,11 +105,11 @@ solve (L span constraint) =
105105 CEqual term1 term2 -> do
106106 t1 <- TS.flatten term1
107107 t2 <- TS.flatten term2
108− unify span t1 t2
108+ unify region t1 t2
109109
110110 CAnd cs -> mapM_ solve cs
111111
112− CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do
112+ CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do
113113 oldEnv <- TS.getEnv
114114 mapM TS.introduce fqs
115115 solve constraint'
@@ -117,7 +117,7 @@ solve (L span constraint) =
117117
118118 CLet schemes constraint' -> do
119119 oldEnv <- TS.getEnv
120− headers <- Map.unions `fmap` mapM (solveScheme span) schemes
120+ headers <- Map.unions `fmap` mapM (solveScheme region) schemes
121121 TS.modifyEnv $ \env -> Map.union headers env
122122 solve constraint'
123123 mapM Check.occurs $ Map.toList headers
@@ -134,10 +134,10 @@ solve (L span constraint) =
134134 error ("Could not find '" ++ name ++ "' when solving type constraints.")
135135
136136 t <- TS.flatten term
137− unify span freshCopy t
137+ unify region freshCopy t
138138
139−solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
140−solveScheme span scheme =
139+solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
140+solveScheme region scheme =
141141 case scheme of
142142 Scheme [] [] constraint header -> do
143143 solve constraint
@@ -154,39 +154,39 @@ solveScheme span scheme =
154154 header' <- Traversable.traverse TS.flatten header
155155 solve constraint
156156
157− allDistinct span rigidQuantifiers
157+ allDistinct region rigidQuantifiers
158158 youngPool <- TS.getPool
159159 TS.switchToPool oldPool
160160 generalize youngPool
161− mapM (isGeneric span) rigidQuantifiers
161+ mapM (isGeneric region) rigidQuantifiers
162162 return header'
163163
164164
165165-- Checks that all of the given variables belong to distinct equivalence classes.
166166-- Also checks that their structure is Nothing, so they represent a variable, not
167167-- a more complex term.
168−allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()
169−allDistinct span vars = do
168+allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
169+allDistinct region vars = do
170170 seen <- TS.uniqueMark
171171 let check var = do
172172 desc <- liftIO $ UF.descriptor var
173173 case structure desc of
174− Just _ -> TS.addError span (Just msg) var var
174+ Just _ -> TS.addError region (Just msg) var var
175175 where msg = "Cannot generalize something that is not a type variable."
176176
177177 Nothing -> do
178178 if mark desc == seen
179179 then let msg = "Duplicate variable during generalization."
180− in TS.addError span (Just msg) var var
180+ in TS.addError region (Just msg) var var
181181 else return ()
182182 liftIO $ UF.setDescriptor var (desc { mark = seen })
183183 mapM_ check vars
184184
185185-- Check that a variable has rank == noRank, meaning that it can be generalized.
186−isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()
187−isGeneric span var = do
186+isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()
187+isGeneric region var = do
188188 desc <- liftIO $ UF.descriptor var
189189 if rank desc == noRank
190190 then return ()
191191 else let msg = "Unable to generalize a type variable. It is not unranked."
192− in TS.addError span (Just msg) var var
192+ in TS.addError region (Just msg) var var
compiler/Type/State.hs+12−20
@@ -1,16 +1,17 @@
11{-# OPTIONS_GHC -W #-}
22module Type.State where
33
4−import Type.Type
5−import qualified Data.Map as Map
6−import qualified Data.UnionFind.IO as UF
7−import Control.Monad.State
84import Control.Applicative ((<$>),(<*>), Applicative)
5+import Control.Monad.State
6+import qualified Data.Map as Map
97import qualified Data.Traversable as Traversable
10−import Text.PrettyPrint as P
8+import qualified Data.UnionFind.IO as UF
9+
10+import qualified SourceSyntax.Annotation as A
1111import SourceSyntax.PrettyPrint
12−import SourceSyntax.Location
12+import Text.PrettyPrint as P
1313import qualified Type.Alias as Alias
14+import Type.Type
1415
1516-- Pool
1617-- Holds a bunch of variables
@@ -46,7 +47,7 @@ initialState = SS {
4647modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
4748modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
4849
49−addError span hint t1 t2 =
50+addError region hint t1 t2 =
5051 modify $ \state -> state { sErrors = makeError : sErrors state }
5152 where
5253 makeError rules = do
@@ -54,24 +55,15 @@ addError span hint t1 t2 =
5455 t1' <- prettiest <$> toSrcType t1
5556 t2' <- prettiest <$> toSrcType t2
5657 return . P.vcat $
57− [ P.text $ "Type error" ++ location ++ ":"
58+ [ P.text "Type error" <+> pretty region <> P.colon
5859 , maybe P.empty P.text hint
59− , display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg }
60+ , P.text ""
61+ , P.nest 8 $ A.getRegionDocs region
62+ , P.text ""
6063 , P.text " Expected Type:" <+> t1'
6164 , P.text " Actual Type:" <+> t2'
6265 ]
6366
64− location = case span of
65− NoSpan _ -> ""
66− Span p1 p2 _ ->
67− if line p1 == line p2 then " on line " ++ show (line p1)
68− else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
69−
70− display msg =
71− P.vcat [ P.text $ concatMap ("\n "++) (lines msg)
72− , P.text " " ]
73−
74−
7567switchToPool pool = modifyPool (\_ -> pool)
7668
7769getPool :: StateT SolverState IO Pool
compiler/Type/Type.hs+19−12
@@ -11,7 +11,7 @@ import Control.Applicative ((<$>),(<*>))
1111import Control.Monad.State
1212import Control.Monad.Error
1313import Data.Traversable (traverse)
14−import SourceSyntax.Location
14+import SourceSyntax.Annotation
1515import SourceSyntax.Helpers (isTuple)
1616import qualified SourceSyntax.Type as Src
1717
@@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
6262infixl 8 /\
6363
6464(/\) :: Constraint a b -> Constraint a b -> Constraint a b
65−a@(L _ c1) /\ b@(L _ c2) =
65+a@(A _ c1) /\ b@(A _ c2) =
6666 case (c1, c2) of
6767 (CTrue, _) -> b
6868 (_, CTrue) -> a
@@ -128,17 +128,24 @@ structuredVar structure = UF.fresh $ Descriptor {
128128
129129-- ex qs constraint == exists qs. constraint
130130ex :: [Variable] -> TypeConstraint -> TypeConstraint
131−ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s CTrue)
131+ex fqs constraint@(A ann _) =
132+ A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)
132133
133134-- fl qs constraint == forall qs. constraint
134135fl :: [Variable] -> TypeConstraint -> TypeConstraint
135−fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)
136+fl rqs constraint@(A ann _) =
137+ A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)
136138
137139exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
138140exists f = do
139141 v <- liftIO $ var Flexible
140142 ex [v] <$> f (VarN v)
141143
144+existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
145+existsNumber f = do
146+ v <- liftIO $ var (Is Number)
147+ ex [v] <$> f (VarN v)
148+
142149
143150instance Show a => Show (UF.Point a) where
144151 show point = unsafePerformIO $ fmap show (UF.descriptor point)
@@ -148,8 +155,8 @@ instance PrettyType a => PrettyType (UF.Point a) where
148155 pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
149156
150157
151−instance PrettyType a => PrettyType (Located a) where
152− pretty when (L _ e) = pretty when e
158+instance PrettyType t => PrettyType (Annotated a t) where
159+ pretty when (A _ e) = pretty when e
153160
154161
155162instance PrettyType a => PrettyType (Term1 a) where
@@ -212,12 +219,12 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
212219 CAnd cs ->
213220 P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
214221
215− CLet [Scheme [] fqs constraint header] (L _ CTrue) | Map.null header ->
222+ CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header ->
216223 P.sep [ binder, pretty Never c ]
217224 where
218− mergeExists vs (L _ c) =
225+ mergeExists vs (A _ c) =
219226 case c of
220− CLet [Scheme [] fqs' c' _] (L _ CTrue) -> mergeExists (vs ++ fqs') c'
227+ CLet [Scheme [] fqs' c' _] (A _ CTrue) -> mergeExists (vs ++ fqs') c'
221228 _ -> (vs, c)
222229
223230 (fqs', c) = mergeExists fqs constraint
@@ -233,7 +240,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
233240 P.text name <+> P.text "<" <+> prty tipe
234241
235242instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
236− pretty _ (Scheme rqs fqs (L _ constraint) headers) =
243+ pretty _ (Scheme rqs fqs (A _ constraint) headers) =
237244 P.sep [ forall, cs, headers' ]
238245 where
239246 prty = pretty Never
@@ -297,8 +304,8 @@ class Crawl t where
297304 -> t
298305 -> StateT CrawlState IO t
299306
300−instance Crawl a => Crawl (Located a) where
301− crawl nextState (L s e) = L s <$> crawl nextState e
307+instance Crawl e => Crawl (Annotated a e) where
308+ crawl nextState (A ann e) = A ann <$> crawl nextState e
302309
303310instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
304311 crawl nextState constraint =
compiler/Type/Unify.hs+15−15
@@ -1,27 +1,27 @@
11{-# OPTIONS_GHC -W #-}
22module Type.Unify (unify) where
33
4−import Type.Type
5−import qualified Data.UnionFind.IO as UF
4+import Control.Monad.State
65import qualified Data.Map as Map
76import qualified Data.Maybe as Maybe
7+import qualified Data.UnionFind.IO as UF
8+import qualified SourceSyntax.Annotation as A
89import qualified Type.State as TS
9−import Control.Monad.State
10−import SourceSyntax.Location
10+import Type.Type
1111import Type.PrettyPrint
1212import Text.PrettyPrint (render)
1313
14−unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
15−unify span variable1 variable2 = do
14+unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
15+unify region variable1 variable2 = do
1616 equivalent <- liftIO $ UF.equivalent variable1 variable2
1717 if equivalent then return ()
18− else actuallyUnify span variable1 variable2
18+ else actuallyUnify region variable1 variable2
1919
20−actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
21−actuallyUnify span variable1 variable2 = do
20+actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
21+actuallyUnify region variable1 variable2 = do
2222 desc1 <- liftIO $ UF.descriptor variable1
2323 desc2 <- liftIO $ UF.descriptor variable2
24− let unify' = unify span
24+ let unify' = unify region
2525
2626 name' :: Maybe String
2727 name' = case (name desc1, name desc2) of
@@ -79,11 +79,11 @@ actuallyUnify span variable1 variable2 = do
7979
8080 unifyNumber svar name
8181 | name `elem` ["Int","Float","number"] = flexAndUnify svar
82− | otherwise = TS.addError span (Just hint) variable1 variable2
82+ | otherwise = TS.addError region (Just hint) variable1 variable2
8383 where hint = "A number must be an Int or Float."
8484
8585 comparableError maybe =
86− TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
86+ TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
8787 where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
8888
8989 unifyComparable var name
@@ -110,7 +110,7 @@ actuallyUnify span variable1 variable2 = do
110110 List _ -> flexAndUnify varSuper
111111 _ -> comparableError Nothing
112112
113− rigidError variable = TS.addError span (Just hint) variable1 variable2
113+ rigidError variable = TS.addError region (Just hint) variable1 variable2
114114 where
115115 var = "'" ++ render (pretty Never variable) ++ "'"
116116 hint = "Cannot unify rigid type variable " ++ var ++
@@ -141,7 +141,7 @@ actuallyUnify span variable1 variable2 = do
141141
142142 (Rigid, _, _, _) -> rigidError variable1
143143 (_, Rigid, _, _) -> rigidError variable2
144− _ -> TS.addError span Nothing variable1 variable2
144+ _ -> TS.addError region Nothing variable1 variable2
145145
146146 case (structure desc1, structure desc2) of
147147 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
@@ -196,5 +196,5 @@ actuallyUnify span variable1 variable2 = do
196196 eat (_:xs) (_:ys) = eat xs ys
197197 eat xs _ = xs
198198
199− _ -> TS.addError span Nothing variable1 variable2
199+ _ -> TS.addError region Nothing variable1 variable2
200200
libraries/Automaton.elm.hiddendeleted−123
@@ -1,123 +0,0 @@
1−module Automaton ( pure, state, hiddenState, run, step
2− , (<<<), (>>>), combine, count, average
3− ) where
4−
5−{-| This library is a way to package up dynamic behavior. It makes it easier to
6−dynamically create dynamic components. See the [original release
7−notes](http://elm-lang.org/blog/announce/0.5.0.elm) on this library to get a feel for how
8−it can be used.
9−
10−# Create
11−@docs pure, state, hiddenState
12−
13−# Evaluate
14−@docs run, step
15−
16−# Combine
17−@docs (>>>), (<<<), combine
18−
19−# Common Automatons
20−@docs count, average
21−-}
22−
23−import open Basics
24−import Signal (lift,foldp,Signal)
25−import open List
26−import Maybe (Just, Nothing)
27−
28−data Automaton a b = Step (a -> (Automaton a b, b))
29−
30−{-| Run an automaton on a given signal. The automaton steps forward whenever the
31−input signal updates.
32−-}
33−run : Automaton a b -> b -> Signal a -> Signal b
34−run auto base inputs =
35− let step a (Step f, _) = f a
36− in lift (\(x,y) -> y) (foldp step (auto,base) inputs)
37−
38−{-| Step an automaton forward once with a given input. -}
39−step : a -> Automaton a b -> (Automaton a b, b)
40−step a (Step f) = f a
41−
42−{-| Compose two automatons, chaining them together. -}
43−(>>>) : Automaton a b -> Automaton b c -> Automaton a c
44−f >>> g =
45− Step (\a -> let (f', b) = step a f
46− (g', c) = step b g
47− in (f' >>> g', c))
48−
49−{-| Compose two automatons, chaining them together. -}
50−(<<<) : Automaton b c -> Automaton a b -> Automaton a c
51−g <<< f = f >>> g
52−
53−{-| Combine a list of automatons into a single automaton that produces a
54−list.
55−-}
56−combine : [Automaton a b] -> Automaton a [b]
57−combine autos =
58− Step (\a -> let (autos', bs) = unzip (map (step a) autos)
59− in (combine autos', bs))
60−
61−{-| Create an automaton with no memory. It just applies the given function to
62−every input.
63−-}
64−pure : (a -> b) -> Automaton a b
65−pure f = Step (\x -> (pure f, f x))
66−
67−
68−{-| Create an automaton with state. Requires an initial state and a step
69−function to step the state forward. For example, an automaton that counted
70−how many steps it has taken would look like this:
71−
72− count = Automaton a Int
73− count = state 0 (\\_ c -> c+1)
74−
75−It is a stateful automaton. The initial state is zero, and the step function
76−increments the state on every step.
77−-}
78−state : b -> (a -> b -> b) -> Automaton a b
79−state s f = Step (\x -> let s' = f x s
80− in (state s' f, s'))
81−
82−{-| Create an automaton with hidden state. Requires an initial state and a
83−step function to step the state forward and produce an output.
84−-}
85−hiddenState : s -> (a -> s -> (s,b)) -> Automaton a b
86−hiddenState s f = Step (\x -> let (s',out) = f x s
87− in (hiddenState s' f, out))
88−
89−{-| Count the number of steps taken. -}
90−count : Automaton a Int
91−count = state 0 (\_ c -> c + 1)
92−
93−type Queue t = ([t],[t])
94−empty = ([],[])
95−enqueue x (en,de) = (x::en, de)
96−dequeue q = case q of
97− ([],[]) -> Nothing
98− (en,[]) -> dequeue ([], reverse en)
99− (en,hd::tl) -> Just (hd, (en,tl))
100−
101−{-| Computes the running average of the last `n` inputs. -}
102−average : Int -> Automaton Float Float
103−average k =
104− let step n (ns,len,sum) =
105− if len == k then stepFull n (ns,len,sum)
106− else ((enqueue n ns, len+1, sum+n), (sum+n) / (toFloat len+1))
107− stepFull n (ns,len,sum) =
108− case dequeue ns of
109− Nothing -> ((ns,len,sum), 0)
110− Just (m,ns') -> let sum' = sum + n - m
111− in ((enqueue n ns', len, sum'), sum' / toFloat len)
112− in hiddenState (empty,0,0) step
113−
114−
115−{-- TODO(evancz): See the following papers for ideas on how to make this
116−library faster and better:
117−
118−- Functional Reactive Programming, Continued
119−- Causal commutative arrows and their optimization
120−
121−Speeding things up is a really low priority. Language features and
122−libraries with nice APIs and are way more important!
123−--}
libraries/AutomatonV2.elm.hiddendeleted−149
@@ -1,149 +0,0 @@
1−module AutomatonV2 where
2−{-| This library is a way to package up dynamic behavior. It makes it easier to
3−dynamically create dynamic components. See the [original release
4−notes](/blog/announce/version-0.5.0.elm) on this library to get a feel for how
5−it can be used.
6−-}
7−
8−import open Basics
9−import Signal (lift,foldp,Signal)
10−import open List
11−import Maybe (Just, Nothing)
12−
13−data Automaton input output = Pure (input -> output)
14− | Stateful state (input -> state -> (output,state))
15−
16−-- The basics
17−
18−-- AFRP name: arr
19−pure: (i -> o) -> Automaton i o
20−pure = Pure
21−
22−-- AFRP name: >>>
23−andThen: Automaton i inter -> Automaton inter o -> Automaton i o
24−andThen first second =
25− case first of
26− Pure f -> case second of -- f is the function from first
27− Pure s -> Pure (s . f) -- s is the function from second
28− Stateful b s -> Stateful b (\i -> s (f i)) -- b is the base state from second
29− Stateful fb f -> case second of -- fb is the base state from first
30− Pure s -> Stateful fb (\i st -> -- sb is the base state from second
31− let (inter, st') = f i st -- i is the input
32− in (s inter, st')) -- st is the input state
33− Stateful sb s -> Stateful (fb, sb) (\i (fst, sst) -> -- inter is the intermediate value
34− let (inter, fst') = f i fst -- st' is the new state
35− (o, sst') = s inter sst -- fst and sst are the state of first and second
36− in (o, (fst', sst'))) -- ect...
37−
38−-- AFRP name: first
39−extendDown: Automaton i o -> Automaton (i,extra) (o,extra)
40−extendDown auto = case auto of
41− Pure fun -> Pure (\(i,extra) -> (fun i, extra))
42− Stateful base fun -> Stateful base (\(i,extra) s -> (fun i s, extra))
43−
44−-- AFRP name: loop
45−loop: s -> Automaton (i,s) (o,s) -> Automaton i o
46−loop base auto = case auto of
47− Pure fun -> Stateful base (curry fun)
48− Stateful base2 fun -> -- fun: (i, s) -> s2 -> ((o, s), s2)
49− let newFun = (\i (s,s2) ->
50− let ((o, s'), s2') = fun (i, s) s2
51− in (o, (s', s2'))) -- newFun: i -> (s, s2) -> (o, (s, s2))
52− in Stateful (base, base2) newFun
53−
54−-- Run an automaton on a given signal
55−run: Automaton i o -> o -> Signal i -> Signal o
56−run auto baseOut input = case auto of
57− Pure fun -> lift fun input
58− Stateful base fun -> lift fst
59− (foldp (\i (o, s) -> fun i s)
60− (baseOut, base) input)
61−
62−
63−-- Other frequently used functions/operators
64−
65−-- Create an automaton with state. Requires an initial state and a step
66−-- function to step the state forward. For example, an automaton that counted
67−-- how many steps it has taken would look like this:
68−--
69−-- count = Automaton a Int
70−-- count = state 0 (\\_ c -> c+1)
71−--
72−-- It is a stateful automaton. The initial state is zero, and the step function
73−-- increments the state on every step.
74−state : s -> (i -> s -> s) -> Automaton i s
75−state base fun = loop base (pure (\(i,s) ->
76− let s' = fun i s
77− in (s',s')))
78−
79−-- Create an automaton with hidden state. Requires an initial state and a
80−-- step function to step the state forward and produce an output.
81−hiddenState : s -> (i -> s -> (s,o)) -> Automaton i o
82−hiddenState base fun = loop base (pure (\(i,s) ->
83− let (o,s') = fun i s
84− in (s',o)))
85−
86−-- AFRP name: second
87−extendUp: Automaton i o -> Automaton (extra,i) (extra,o)
88−extendUp auto =
89− let swap (a, b) = (b, a)
90− in pure swap `andThen` extendDown auto `andThen` pure swap
91−
92−-- (parallel composition)
93−pair: Automaton i1 o1 -> Automaton i2 o2 -> Automaton (i1,i2) (o1,o2)
94−pair f g = extendDown f `andThen` extendUp g
95−
96−branch : Automaton i o1 -> Automaton i o2 -> Automaton i (o1,o2)
97−branch f g =
98− let double = pure (\i -> (i,i))
99− in double `andThen` pair f g
100−
101−combi: Automaton i o -> Automaton i [o] -> Automaton i [o]
102−combi a1 a2 = (a1 `branch` a2) `andThen` pure (uncurry (::))
103−
104−-- Combine a list of automatons into a single automaton that produces a list.
105−combine : [Automaton i o] -> Automaton i [o]
106−combine autos =
107− let l = length autos
108− in if l == 0
109− then pure (\_ -> [])
110− else foldr combi (last autos `andThen` pure (\a -> [a])) (take (l-1) autos)
111−
112−
113−-- Examples of automata
114−
115−-- Count the number of steps taken.
116−count : Automaton a Int
117−count = state 0 (\_ c -> c + 1)
118−
119−type Queue t = ([t],[t])
120−empty = ([],[])
121−enqueue x (en,de) = (x::en, de)
122−dequeue q = case q of
123− ([],[]) -> Nothing
124− (en,[]) -> dequeue ([], reverse en)
125− (en,hd::tl) -> Just (hd, (en,tl))
126−
127−-- Computes the running average of the last `n` inputs.
128−average : Int -> Automaton Float Float
129−average k =
130− let step n (ns,len,sum) =
131− if len == k then stepFull n (ns,len,sum)
132− else ((enqueue n ns, len+1, sum+n), (sum+n) / (toFloat len+1))
133− stepFull n (ns,len,sum) =
134− case dequeue ns of
135− Nothing -> ((ns,len,sum), 0)
136− Just (m,ns') -> let sum' = sum + n - m
137− in ((enqueue n ns', len, sum'), sum' / toFloat len)
138− in hiddenState (empty,0,0) step
139−
140−
141−{-- TODO(evancz): See the following papers for ideas on how to make this
142−library faster and better:
143−
144−- Functional Reactive Programming, Continued -- took some inspirations from this paper (Apanatshka)
145−- Causal commutative arrows and their optimization
146−
147−Speeding things up is a really low priority. Language features and
148−libraries with nice APIs and are way more important!
149−--}
libraries/Basics.elm+27
@@ -39,6 +39,9 @@ which happen to be radians.
3939# Polar Coordinates
4040@docs toPolar, fromPolar
4141
42+# Floating Point Checks
43+@docs isNaN, isInfinite
44+
4245# Tuples
4346@docs fst, snd
4447
@@ -271,6 +274,30 @@ ceiling = Native.Basics.ceiling
271274toFloat : Int -> Float
272275toFloat = Native.Basics.toFloat
273276
277+{- | Determines whether a float is an undefined or unrepresentable number.
278+NaN stands for *not a number* and it is [a standardized part of floating point
279+numbers](http://en.wikipedia.org/wiki/NaN).
280+
281+ isNaN (0/0) == True
282+ isNaN (sqrt -1) == True
283+ isNaN (1/0) == False -- infinity is a number
284+ isNaN 1 == False
285+-}
286+isNaN : Float -> Bool
287+isNaN = Native.Basics.isNaN
288+
289+{- | Determines whether a float is positive or negative infinity.
290+
291+ isInfinite (0/0) == False
292+ isInfinite (sqrt -1) == False
293+ isInfinite (1/0) == True
294+ isInfinite 1 == False
295+
296+Notice that NaN is not infinite! For float `n` to be finite implies that
297+`not (isInfinite n || isNaN n)` evaluates to `True`.
298+-}
299+isInfinite : Float -> Bool
300+isInfinite = Native.Basics.isInfinite
274301
275302-- Function Helpers
276303
libraries/Date.elm+5−1
@@ -5,7 +5,7 @@ module Date where
55issues with internationalization or locale formatting.
66
77# Conversions
8−@docs read, toTime
8+@docs read, toTime, fromTime
99
1010# Extractions
1111@docs year, month, Month, day, dayOfWeek, Day, hour, minute, second
@@ -36,6 +36,10 @@ read = Native.Date.read
3636toTime : Date -> Time
3737toTime = Native.Date.toTime
3838
39+{-| Take a UNIX time and convert it to a `Date` -}
40+fromTime : Time -> Date
41+fromTime = Native.Date.fromTime
42+
3943{-| Extract the year of a given date. Given the date 23 June 1990 at 11:45AM
4044this returns the integer `1990`. -}
4145year : Date -> Int
libraries/Debug.elmnew file+17
@@ -0,0 +1,17 @@
1+module Debug where
2+{-| This library is for investigating bugs or performance problems. It should
3+*not* be used in production code.
4+-}
5+
6+import Native.Debug
7+
8+{-| Log a tagged value on the developer console, and then return the value.
9+
10+ 1 + log "number" 1 -- equals 2, logs "number: 1"
11+ length (log "start" []) -- equals 0, logs "start: []"
12+
13+Notice that `log` is not a pure function! It should *only* be used for
14+investigating bugs or performance problems.
15+-}
16+log : String -> a -> a
17+log = Native.Debug.log
libraries/Dict.elm+3−4
@@ -31,11 +31,10 @@ Insert, remove, and query operations all take *O(log n)* time.
3131-}
3232
3333
34−import open Basics
35−import open Maybe
34+import Basics (..)
35+import Maybe (..)
3636import Native.Error
3737import List
38−import String
3938import Native.Utils
4039
4140-- BBlack and NBlack should only be used during the deletion
@@ -197,7 +196,7 @@ lessBlackTree t = case t of
197196
198197reportRemBug : String -> NColor -> String -> String -> a
199198reportRemBug msg c lgot rgot =
200− Native.Error.raise . String.concat <| [
199+ Native.Error.raise <| List.concat [
201200 "Internal red-black tree invariant violated, expected ",
202201 msg,
203202 "and got",
libraries/Either.elm+26−4
@@ -26,28 +26,50 @@ data Either a b = Left a | Right b
2626
2727{-| Apply the first function to a `Left` and the second function to a `Right`.
2828This allows the extraction of a value from an `Either`.
29+
30+ either (\n -> n + 1) sqrt (Left 4) == 5
31+ either (\n -> n + 1) sqrt (Right 4) == 2
32+
33+ map : (a -> b) -> Either err a -> Either err b
34+ map f e = either Left (\x -> Right (f x)) e
2935-}
3036either : (a -> c) -> (b -> c) -> Either a b -> c
3137either f g e = case e of { Left x -> f x ; Right y -> g y }
3238
33−{-| True if the value is a `Left`. -}
39+{-| True if the value is a `Left`.
40+
41+ isLeft (Left "Cat") == True
42+ isLeft (Right 1123) == False
43+-}
3444isLeft : Either a b -> Bool
3545isLeft e = case e of { Left _ -> True ; _ -> False }
3646
37−{-| True if the value is a `Right`. -}
47+{-| True if the value is a `Right`.
48+
49+ isRight (Left "Cat") == False
50+ isRight (Right 1123) == True
51+-}
3852isRight : Either a b -> Bool
3953isRight e = case e of { Right _ -> True ; _ -> False }
4054
41−{-| Keep only the values held in `Left` values. -}
55+{-| Keep only the values held in `Left` values.
56+
57+ lefts [Left 3, Right 'a', Left 5, Right "eight"] == [3,5]
58+-}
4259lefts : [Either a b] -> [a]
4360lefts es = List.foldr consLeft [] es
4461
45−{-| Keep only the values held in `Right` values. -}
62+{-| Keep only the values held in `Right` values.
63+
64+ rights [Left 3, Right 'a', Left 5, Right 'b'] == ['a','b']
65+-}
4666rights : [Either a b] -> [b]
4767rights es = List.foldr consRight [] es
4868
4969{-| Split into two lists, lefts on the left and rights on the right. So we
5070have the equivalence: `(partition es == (lefts es, rights es))`
71+
72+ partition [Left 3, Right 'a', Left 5, Right 'b'] == ([3,5],['a','b'])
5173-}
5274partition : [Either a b] -> ([a],[b])
5375partition es = List.foldr consEither ([],[]) es
libraries/Graphics/Collage.elm+1−1
@@ -30,7 +30,7 @@ it as a single unit.
3030
3131-}
3232
33−import open Basics
33+import Basics (..)
3434import List
3535import Either (Either, Left, Right)
3636import Transform2D (Transform2D, identity)
libraries/Graphics/Element.elm+7−4
@@ -37,12 +37,12 @@ If you need more precision, you can create custom positions.
3737 midRightAt, topLeftAt, topRightAt, bottomLeftAt, bottomRightAt
3838-}
3939
40−import open Basics
40+import Basics (..)
4141import Native.Utils
4242import JavaScript as JS
4343import JavaScript (JSString)
4444import List as List
45−import open Color
45+import Color (..)
4646import Maybe (Maybe, Just, Nothing)
4747
4848type Properties = {
@@ -53,7 +53,8 @@ type Properties = {
5353 color : Maybe Color,
5454 href : JSString,
5555 tag : JSString,
56− hover : ()
56+ hover : (),
57+ click : ()
5758 }
5859
5960type Element = { props : Properties, element : ElementPrim }
@@ -128,7 +129,9 @@ link href e = let p = e.props in
128129
129130emptyStr = JS.fromString ""
130131newElement w h e =
131− { props = Properties (Native.Utils.guid ()) w h 1 Nothing emptyStr emptyStr (), element = e }
132+ { props = Properties (Native.Utils.guid ()) w h 1 Nothing emptyStr emptyStr () ()
133+ , element = e
134+ }
132135
133136data ElementPrim
134137 = Image ImageStyle Int Int JSString
libraries/Graphics/Input.elm+146−167
@@ -1,199 +1,178 @@
11module Graphics.Input where
2−
32{-| This module is for creating standard input widgets such as buttons and
4−text boxes. In general, functions in this library return a signal representing
5−events from the user.
3+text fields. All functions in this library follow a general pattern in which
4+you create an `Input` that many elements can report to:
5+
6+```haskell
7+clicks : Input ()
8+clicks = input ()
9+
10+clickableYogi : Element
11+clickableYogi = clickable clicks.handle () (image 40 40 "/yogi.jpg")
12+```
613
7−The simplest inputs are *one-way inputs*, meaning the user can update
8−them, but the programmer cannot. If you need to update an input from
9−within the program you want the slightly more complex *two-way inputs*.
10−This document will always show the one-way inputs first, *then* the
11−two-way inputs.
14+Whenever the user clicks on the resulting `clickableYogi` element, it sends an
15+update to the `clicks` input. You will see this pattern again and again in
16+examples in this library, so just read on to get a better idea of how it works!
1217
13−# Buttons
14−@docs button, customButton, buttons, customButtons
18+# Creating Inputs
19+@docs Input, input
1520
16−# Fields
17−@docs field, password, email, fields, FieldState, emptyFieldState
21+# Basic Input Elements
1822
19−# Checkboxes
20−@docs checkbox, checkboxes
23+To learn about text fields, see the
24+[`Graphics.Input.Field`](Graphics-Input-Field) library.
2125
22−# Drop Downs
23−@docs stringDropDown, dropDown
26+@docs button, customButton, checkbox, dropDown
27+
28+# Clicks and Hovers
29+@docs clickable, hoverable
2430
25−# Mouse Hover
26−@docs hoverable, hoverables
2731-}
2832
29−import Basics (String)
30−import Signal (Signal,lift,dropRepeats)
31−import Native.Graphics.Input
32−import List
33+import Signal (Signal)
3334import Graphics.Element (Element)
34−import Maybe (Maybe)
35−import JavaScript (JSString)
35+import Native.Graphics.Input
3636
37−id x = x
37+{-| This is the key abstraction of this library. An `Input` is a record
38+of two fields:
3839
39−{-| Create a group of buttons.
40+ 1. `signal` &mdash; all values coming to this input from &ldquo;the world&rdquo;
41+ 2. `handle` &mdash; a way to refer to this particular input and send it values
4042
41− * The first argument is the default value of the `events` signal.
42− * The `events` signal represents all of the activity in this group
43− of buttons.
44− * The `button` function creates a button
45− with the given name, like &ldquo;Submit&rdquo; or &ldquo;Cancel&rdquo;.
46− The `a` value is sent to `events` whenever the button is pressed.
43+This will make more sense as you see more examples.
4744-}
48−buttons : a -> { events : Signal a,
49− button : a -> String -> Element }
50−buttons = Native.Graphics.Input.buttons
45+type Input a = { signal : Signal a, handle : Handle a }
5146
52−{-| Create a button with a given label. The result is an `Element` and
53−a signal of units. This signal triggers whenever the button is pressed.
54−-}
55−button : String -> (Element, Signal ())
56−button txt =
57− let pool = buttons ()
58− in (pool.button () txt, pool.events)
59−
60−{-| Create a group of custom buttons.
61−
62− * The first argument is the default value of the `events` signal.
63− * The `events` signal represents all of the activity in this group
64− of custom buttons.
65− * The `customButton` function creates a button with three different visual
66− states, one for up, hovering, and down. The resulting button has dimensions
67− large enough to fit all three possible `Elements`.
68− The `a` value is sent to `events` whenever the button is pressed.
69−-}
70−customButtons : a -> { events : Signal a,
71− customButton : a -> Element -> Element -> Element -> Element }
72−customButtons = Native.Graphics.Input.customButtons
47+data Handle a = Handle
7348
74−{-| Create a button with custom states for up, hovering, and down
75−(given in that order). The result is an `Element` and a signal of
76−units. This signal triggers whenever the button is pressed.
77−-}
78−customButton : Element -> Element -> Element -> (Element, Signal ())
79−customButton up hover down =
80− let pool = customButtons ()
81− in (pool.customButton () up hover down, pool.events)
82−
83−{-| Create a group of checkboxes.
84−
85− * The first argument is the default value of the `events` signal.
86− * The `events` signal represents all of the activity in this group
87− of checkboxes.
88− * The `checkbox` function creates a
89− checkbox with a given state. The `(Bool -> a)` function is used
90− when the checkbox is modified. It takes the new state and turns
91− it into a value that can be sent to `events`. For example, this
92− lets you add an ID to distinguish between checkboxes.
93−-}
94−checkboxes : a -> { events : Signal a,
95− checkbox : (Bool -> a) -> Bool -> Element }
96−checkboxes = Native.Graphics.Input.checkboxes
97−
98−{-| Create a checkbox with a given start state. Unlike `button`, this
99−result is a *signal* of elements. That is because a checkbox has state
100−that updates based on user input. The boolean signal represents the
101−current state of the checkbox.
102−-}
103−checkbox : Bool -> (Signal Element, Signal Bool)
104−checkbox b =
105− let cbs = checkboxes b
106− in (lift (cbs.checkbox id) cbs.events, cbs.events)
107−
108−{-| Detect when the mouse is hovering over some elements. This
109−allows you to create and destroy elements dynamically and still
110−detect hover information.
49+{-| This creates a new `Input`. You provide a single argument that will serve
50+as the initial value of the input&rsquo;s `signal`. For example:
51+
52+ numbers : Input Int
53+ numbers = input 42
54+
55+The initial value of `numbers.signal` is 42, and you will be able
56+to pipe updates to the input using `numbers.handle`.
57+
58+Note: This is an inherently impure function. Specifically, `(input ())` and
59+`(input ())` are actually two different inputs with different signals and handles.
11160-}
112−hoverables : a -> { events : Signal a,
113− hoverable : (Bool -> a) -> Element -> Element }
114−hoverables = Native.Graphics.Input.hoverables
61+input : a -> Input a
62+input = Native.Graphics.Input.input
11563
116−{-| Detect when the mouse is hovering over a specific `Element`. -}
117−hoverable : Element -> (Element, Signal Bool)
118−hoverable elem =
119− let pool = hoverables False
120− in (pool.hoverable id elem, pool.events)
64+{-| Create a standard button. The following example begins making a basic
65+calculator:
12166
122−{-| Represents the current state of a text field. The `string` represents the
123−characters filling the text field. The `selectionStart` and `selectionEnd`
124−values represent what the user has selected with their mouse or keyboard.
125−For example:
67+ data Keys = Number Int | Plus | Minus | Clear
12668
127− { string="She sells sea shells", selectionStart=3, selectionEnd=0 }
69+ keys : Input Keys
70+ keys = input Clear
12871
129−This means the user highlighted the substring `"She"` backwards.
130−-}
131−type FieldState = { string:String, selectionStart:Int, selectionEnd:Int }
132−
133−{-| Create a group of text input fields.
134−
135− * The first argument is the default value of the `events` signal.
136− * The `events` signal represents all of the activity in this group
137− of text fields.
138− * The `field` function creates a
139− field with the given ghost text and initial field state.
140− When the field is modified, the `(FieldState -> a)` function
141− takes the new state and turns
142− it into a value that can be sent to `events`. For example, this
143− lets you add an ID to distinguish between input fields.
72+ calculator : Element
73+ calculator =
74+ flow right [ button keys.handle (Number 1) "1"
75+ , button keys.handle (Number 2) "2"
76+ , button keys.handle Plus "+"
77+ ]
78+
79+If the user presses the "+" button, `keys.signal` will update to `Plus`. If the
80+users presses "2", `keys.signal` will update to `(Number 2)`.
14481-}
145−fields : a -> { events : Signal a,
146− field : (FieldState -> a) -> String -> FieldState -> Element }
147−fields = Native.Graphics.Input.fields
82+button : Handle a -> a -> String -> Element
83+button = Native.Graphics.Input.button
14884
149−{-| The empty field state:
85+{-| Same as `button` but lets you customize buttons to look however you want.
15086
151− { string="", selectionStart=0, selectionEnd=0 }
152−-}
153−emptyFieldState : FieldState
154−emptyFieldState = { string="", selectionStart=0, selectionEnd=0 }
87+ click : Input ()
88+ click = input ()
15589
156−{-| Create a field with the given default text. The output is an element
157−that updates to match the user input and a signal of strings representing
158−the content of the field.
90+ prettyButton : Element
91+ prettyButton =
92+ customButton click.handle
93+ (image 100 40 "/button_up.jpg")
94+ (image 100 40 "/button_hover.jpg")
95+ (image 100 40 "/button_down.jpg")
15996-}
160−field : String -> (Signal Element, Signal String)
161−field placeHolder =
162− let tfs = fields emptyFieldState
163− changes = dropRepeats tfs.events
164− in (lift (tfs.field id placeHolder) changes,
165− dropRepeats (lift .string changes))
166−
167−{-| Same as `field` but the UI element blocks out each characters. -}
168−password : String -> (Signal Element, Signal String)
169−password placeHolder =
170− let tfs = Native.Graphics.Input.passwords emptyFieldState
171− changes = dropRepeats tfs.events
172− in (lift (tfs.field id placeHolder) changes,
173− dropRepeats (lift .string changes))
174−
175−{-| Same as `field` but it adds an annotation that this field is for email
176−addresses. This is helpful for auto-complete and for mobile users who may
177−get a custom keyboard with an `@` and `.com` button.
97+customButton : Handle a -> a -> Element -> Element -> Element -> Element
98+customButton = Native.Graphics.Input.customButton
99+
100+{-| Create a checkbox. The following example creates three synced checkboxes:
101+
102+ check : Input Bool
103+ check = input False
104+
105+ boxes : Bool -> Element
106+ boxes checked =
107+ let box = container 40 40 middle (checkbox check.handle id checked)
108+ in flow right [ box, box, box ]
109+
110+ main : Signal Element
111+ main = boxes <~ check.signal
178112-}
179−email : String -> (Signal Element, Signal String)
180−email placeHolder =
181− let tfs = Native.Graphics.Input.emails emptyFieldState
182− changes = dropRepeats tfs.events
183− in (lift (tfs.field id placeHolder) changes,
184− dropRepeats (lift .string changes))
185−
186−{-| Create a drop-down menu. When the user selects a string,
187−the current state of the drop-down is set to the associated
188−value. This lets you avoid manually mapping the string onto
189−functions and values.
113+checkbox : Handle a -> (Bool -> a) -> Bool -> Element
114+checkbox = Native.Graphics.Input.checkbox
115+
116+{-| Create a drop-down menu. The following drop-down lets you choose your
117+favorite British sport:
118+
119+ data Sport = Football | Cricket | Snooker
120+
121+ sport : Input (Maybe Sport)
122+ sport = input Nothing
123+
124+ sportDropDown : Element
125+ sportDropDown =
126+ dropDown sport.handle
127+ [ ("" , Nothing)
128+ , ("Football", Just Football)
129+ , ("Cricket" , Just Cricket)
130+ , ("Snooker" , Just Snooker)
131+ ]
132+
133+If the user selects "Football" from the drop down menue, `sport.signal`
134+will update to `Just Football`.
190135-}
191−dropDown : [(String,a)] -> (Signal Element, Signal a)
136+dropDown : Handle a -> [(String,a)] -> Element
192137dropDown = Native.Graphics.Input.dropDown
193138
194−{-| Create a drop-down menu for selecting strings. The resulting
195−signal of strings represents the string that is currently selected.
139+{-| Detect mouse hovers over a specific `Element`. In the following example,
140+we will create a hoverable picture called `cat`.
141+
142+ hover : Input Bool
143+ hover = input False
144+
145+ cat : Element
146+ cat = image 30 30 "/cat.jpg"
147+ |> hoverable hover.handle id
148+
149+When the mouse hovers above the `cat` element, `hover.signal` will become
150+`True`. When the mouse leaves it, `hover.signal` will become `False`.
151+-}
152+hoverable : Handle a -> (Bool -> a) -> Element -> Element
153+hoverable = Native.Graphics.Input.hoverable
154+
155+{-| Detect mouse clicks on a specific `Element`. In the following example,
156+we will create a clickable picture called `cat`.
157+
158+ data Picture = Cat | Hat
159+
160+ picture : Input Picture
161+ picture = input Cat
162+
163+ cat : Element
164+ cat = image 30 30 "/cat.jpg"
165+ |> clickable picture.handle Cat
166+
167+ hat : Element
168+ hat = image 30 30 "/hat.jpg"
169+ |> clickable picture.handle Hat
170+
171+When the user clicks on the `cat` element, `picture.signal` receives
172+an update containing the value `Cat`. When the user clicks on the `hat` element,
173+`picture.signal` receives an update containing the value `Hat`. This lets you
174+distinguish which element was clicked. In a more complex example, they could be
175+distinguished with IDs or more complex data structures.
196176-}
197−stringDropDown : [String] -> (Signal Element, Signal String)
198−stringDropDown strs =
199− dropDown (List.map (\s -> (s,s)) strs)
177+clickable : Handle a -> a -> Element -> Element
178+clickable = Native.Graphics.Input.clickable
libraries/Graphics/Input/Field.elmnew file+170
@@ -0,0 +1,170 @@
1+module Graphics.Input.Field where
2+{-| This library provides an API for creating and updating text fields.
3+Text fields use exactly the same approach as [`Graphics.Input`](Graphics-Input)
4+for modelling user input, allowing you to keep track of new events and update
5+text fields programmatically.
6+
7+# Create Fields
8+@docs field, password, email
9+
10+# Field Content
11+@docs Content, Selection, Direction, noContent
12+
13+# Field Style
14+@docs Style, Outline, noOutline, Highlight, noHighlight, Dimensions, uniformly
15+-}
16+
17+import Color (Color)
18+import Color
19+import Graphics.Element (Element)
20+import Graphics.Input (Input, Handle)
21+import Native.Graphics.Input
22+import Text
23+
24+{-| Create uniform dimensions:
25+
26+ uniformly 4 == { left=4, right=4, top=4, bottom=4 }
27+
28+The following example creates an outline where the left, right, top, and bottom
29+edges all have width 1:
30+
31+ Outline grey (uniformly 1) 4
32+-}
33+uniformly : Int -> Dimensions
34+uniformly n = Dimensions n n n n
35+
36+{-| For setting dimensions of a fields padding or border. The left, right, top,
37+and bottom may all have different sizes. The following example creates
38+dimensions such that the left and right are twice as wide as the top and bottom:
39+
40+ myDimensions : Int -> Dimensions
41+ myDimensions n = { left = 2 * n, right = 2 * n, top = n, bottom = n }
42+-}
43+type Dimensions = { left:Int, right:Int, top:Int, bottom:Int }
44+
45+{-| A field can have a outline around it. This lets you set its color, width,
46+and radius. The radius allows you to round the corners of your field. Set the
47+width to zero to make it invisible. Here is an example outline that is grey
48+and thin with slightly rounded corners:
49+
50+ { color = grey, width = uniformly 1, radius = 4 }
51+-}
52+type Outline = { color:Color, width:Dimensions, radius:Int }
53+
54+{-| An outline with zero width, so you cannot see it. -}
55+noOutline : Outline
56+noOutline = Outline Color.grey (uniformly 0) 0
57+
58+{-| When a field has focus, it has a blue highlight around it by default. The
59+`Highlight` lets you set the `color` and `width` of this highlight. Set the
60+`width` to zero to turn the highlight off. Here is an example highlight that
61+is blue and thin:
62+
63+ { color = blue, width = 1 }
64+-}
65+type Highlight = { color:Color, width:Int }
66+
67+{-| An highlight with zero width, so you cannot see it. -}
68+noHighlight : Highlight
69+noHighlight = Highlight Color.blue 0
70+
71+{-| Describe the style of a text box. `style` describes the style of the text
72+itself using [`Text.Style`](/Text#Style). `outline` describes the glowing blue
73+outline that shows up when the field has focus. `outline` describes the line
74+surrounding the text field, and `padding` adds whitespace between the `outline`
75+and the text.
76+
77+The width and height of the text box *includes* the `padding` and `outline`.
78+Say we have a text box that is 40 pixels tall. It has a uniform outline of
79+1 pixel and a uniform padding of 5 pixels. Both of these must be subtracted
80+from the total height to determine how much room there is for text. The
81+`padding` and `outline` appear on the top and bottom, so there will be 28
82+vertical pixels remaining for the text (40 - 1 - 5 - 5 - 1).
83+-}
84+type Style =
85+ { padding : Dimensions
86+ , outline : Outline
87+ , highlight : Highlight
88+ , style : Text.Style
89+ }
90+
91+{-| The default style for a text field. The outline is `Color.grey` with width
92+1 and radius 2. The highlight is `Color.blue` with width 1, and the default
93+text color is black.
94+-}
95+defaultStyle : Style
96+defaultStyle =
97+ { padding = uniformly 4
98+ , outline = Outline Color.grey (uniformly 1) 2
99+ , highlight = Highlight Color.blue 1
100+ , style = Text.defaultStyle
101+ }
102+
103+{-| Represents the current content of a text field. For example:
104+
105+ content = Content "She sells sea shells" (Selection 0 3 Backward)
106+
107+This means the user highlighted the substring `"She"` backwards. The value of
108+`content.string` is `"She sells sea shells"`.
109+-}
110+type Content = { string:String, selection:Selection }
111+
112+{-| The selection within a text field. `start` is never greater than `end`:
113+
114+ Selection 0 0 Forward -- cursor precedes all characters
115+
116+ Selection 5 9 Backward -- highlighting characters starting after
117+ -- the 5th and ending after the 9th
118+-}
119+type Selection = { start:Int, end:Int, direction:Direction }
120+
121+{-| The direction of selection. When the user highlights a selection in a text
122+field, they must do it in a particular direction. This determines which end of
123+the selection moves when they change the selection by pressing Shift-Left or
124+Shift-Right.
125+-}
126+data Direction = Forward | Backward
127+
128+{-| A field with no content:
129+
130+ Content "" (Selection 0 0 Forward)
131+-}
132+noContent : Content
133+noContent = Content "" (Selection 0 0 Forward)
134+
135+{-| Create a text field. The following example creates a time-varying element
136+called `nameField`. As the user types their name, the field will be updated
137+to match what they have entered.
138+
139+ name : Input Content
140+ name = input noContent
141+
142+ nameField : Signal Element
143+ nameField = field defaultStyle name.handle id "Name" <~ name.signal
144+
145+When we use the `field` function, we first give it a visual style. This is
146+the first argument so that it is easier to define your own custom field
147+(`myField = field myStyle`). The next two arguments are a `Handle` and a
148+handler function that processes or augments events before sending them along
149+to the associated `Input`. In the example above we use the `id` function to
150+pass events along unchanged to the `name` `Input`. We then provide the
151+place-holder message to use when no input has been provided yet. Finally,
152+we give the current `Content` of the field. This argument is last because
153+it is most likely to change frequently, making function composition easier.
154+-}
155+field : Style -> Handle a -> (Content -> a) -> String -> Content -> Element
156+field = Native.Graphics.Input.field
157+
158+{-| Same as `field` but the UI element blocks out each characters. -}
159+password : Style -> Handle a -> (Content -> a) -> String -> Content -> Element
160+password = Native.Graphics.Input.password
161+
162+{-| Same as `field` but it adds an annotation that this field is for email
163+addresses. This is helpful for auto-complete and for mobile users who may
164+get a custom keyboard with an `@` and `.com` button.
165+-}
166+email : Style -> Handle a -> (Content -> a) -> String -> Content -> Element
167+email = Native.Graphics.Input.email
168+
169+-- area : Handle a -> (Content -> a) -> Handle b -> ((Int,Int) -> b) -> (Int,Int) -> String -> Content -> Element
170+-- area = Native.Graphics.Input.area
libraries/Http.elm+1−1
@@ -14,7 +14,7 @@ you have very strict latency requirements.
1414@docs Response
1515-}
1616
17−import open Signal
17+import Signal (..)
1818import Native.Http
1919
2020{-| The datatype for responses. Success contains only the returned message.
libraries/Json.elm+1−1
@@ -17,7 +17,7 @@ module Json where
1717
1818-}
1919
20−import open Basics
20+import Basics (..)
2121import Dict
2222import Maybe (Maybe)
2323import JavaScript as JS
libraries/List.elm+1−1
@@ -25,7 +25,7 @@ list must have the same type.
2525@docs sort, sortBy, sortWith
2626-}
2727
28−import open Basics
28+import Basics (..)
2929import Native.List
3030
3131{-| Add an element to the front of a list `(1 :: [2,3] == [1,2,3])` -}
libraries/Maybe.elm+21−3
@@ -21,27 +21,45 @@ numbers).
2121-}
2222data Maybe a = Just a | Nothing
2323
24−{-| Apply a function to the contents of a `Maybe`.
25−Return default when given `Nothing`.
24+{-| Provide a default value and a function to extract the contents of a `Maybe`.
25+When given `Nothing` you get the default, when given a `Just` you apply the
26+function to the associated value.
27+
28+ isPositive : Maybe Int -> Bool
29+ isPositive maybeInt = maybe False (\n -> n > 0) maybeInt
30+
31+ map : (a -> b) -> Maybe a -> Maybe b
32+ map f m = maybe Nothing (\x -> Just (f x)) m
2633-}
2734maybe : b -> (a -> b) -> Maybe a -> b
2835maybe b f m = case m of
2936 Just v -> f v
3037 Nothing -> b
3138
32−{-| Check if constructed with `Just`.
39+{-| Check if a maybe happens to be a `Just`.
40+
41+ isJust (Just 42) == True
42+ isJust (Just []) == True
43+ isJust Nothing == False
3344-}
3445isJust : Maybe a -> Bool
3546isJust = maybe False (\_ -> True)
3647
3748{-| Check if constructed with `Nothing`.
49+
50+ isNothing (Just 42) == False
51+ isNothing (Just []) == False
52+ isNothing Nothing == True
3853-}
3954isNothing : Maybe a -> Bool
4055isNothing = not . isJust
4156
57+cons : Maybe a -> [a] -> [a]
4258cons mx xs = maybe xs (\x -> x :: xs) mx
4359
4460{-| Filters out Nothings and extracts the remaining values.
61+
62+ justs [Just 0, Nothing, Just 5, Just 7] == [0,5,7]
4563-}
4664justs : [Maybe a] -> [a]
4765justs = foldr cons []
libraries/Mouse.elm+1−6
@@ -7,7 +7,7 @@ module Mouse where
77@docs position, x, y
88
99# Button Status
10−@docs isDown, clicks, isClicked
10+@docs isDown, clicks
1111
1212-}
1313
@@ -31,11 +31,6 @@ True when the button is down, and false otherwise. -}
3131isDown : Signal Bool
3232isDown = Native.Mouse.isDown
3333
34−{-| True immediately after the left mouse-button has been clicked,
35−and false otherwise. -}
36−isClicked : Signal Bool
37−isClicked = Native.Mouse.isClicked
38−
3934{-| Always equal to unit. Event triggers on every mouse click. -}
4035clicks : Signal ()
4136clicks = Native.Mouse.clicks
libraries/Native/Basics.js+3
@@ -19,6 +19,7 @@ Elm.Native.Basics.make = function(elm) {
1919 return Utils.cmp(n,lo) < 0 ? lo : Utils.cmp(n,hi) > 0 ? hi : n; }
2020 function xor(a,b) { return a !== b; }
2121 function not(b) { return !b; }
22+ function isInfinite(n) { return n === Infinity || n === -Infinity }
2223
2324 function truncate(n) { return n|0; }
2425
@@ -53,6 +54,8 @@ Elm.Native.Basics.make = function(elm) {
5354 floor:Math.floor,
5455 round:Math.round,
5556 toFloat:function(x) { return x; },
57+ isNaN:isNaN,
58+ isInfinite:isInfinite
5659 };
5760
5861 return elm.Native.Basics.values = basics;
libraries/Native/Bitwise.js+6−6
@@ -13,13 +13,13 @@ Elm.Native.Bitwise.make = function(elm) {
1313 function srl(a,offset) { return a >>> offset; }
1414
1515 return elm.Native.Bitwise.values = {
16− and: A2(and),
17− or : A2(or ),
18− xor: A2(xor),
16+ and: F2(and),
17+ or : F2(or ),
18+ xor: F2(xor),
1919 complement: not,
20− shiftLeft : A2(sll),
21− shiftRightArithmatic: A2(sra),
22− shiftRightLogical : A2(srl),
20+ shiftLeft : F2(sll),
21+ shiftRightArithmatic: F2(sra),
22+ shiftRightLogical : F2(srl),
2323 };
2424
2525};
libraries/Native/Color.js+9−2
@@ -6,6 +6,12 @@ Elm.Native.Color.make = function(elm) {
66
77 var Utils = Elm.Native.Utils.make(elm);
88
9+ 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+
915 function complement(rgb) {
1016 var hsv = toHSV(rgb);
1117 hsv.hue = (hsv.hue + 180) % 360;
@@ -63,7 +69,8 @@ Elm.Native.Color.make = function(elm) {
6369 return elm.Native.Color.values = {
6470 hsva:F4(hsva),
6571 hsv:F3(hsv),
66− complement:complement
72+ complement:complement,
73+ toCss:toCss
6774 };
6875
69−};
76+};
libraries/Native/Date.js+1
@@ -27,6 +27,7 @@ Elm.Native.Date.make = function(elm) {
2727 minute : function(d) { return d.getMinutes(); },
2828 second : function(d) { return d.getSeconds(); },
2929 toTime : function(d) { return d.getTime(); },
30+ fromTime: function(t) { return new window.Date(t); },
3031 dayOfWeek : function(d) { return { ctor:dayTable[d.getDay()] }; }
3132 };
3233
libraries/Native/Debug.jsnew file+24
@@ -0,0 +1,24 @@
1+Elm.Native.Debug = {};
2+Elm.Native.Debug.make = function(elm) {
3+ elm.Native = elm.Native || {};
4+ elm.Native.Debug = elm.Native.Debug || {};
5+ if (elm.Native.Debug.values) return elm.Native.Debug.values;
6+
7+ var show = Elm.Native.Show.make(elm).show;
8+
9+ function log(tag,value) {
10+ var msg = tag + ': ' + show(value);
11+ var process = process || {};
12+ if (process.stdout) {
13+ process.stdout.write(msg);
14+ } else {
15+ console.log(msg);
16+ }
17+ return value;
18+ }
19+
20+ return elm.Native.Debug.values = {
21+ log: F2(log)
22+ };
23+
24+};
libraries/Native/Graphics/Input.js+403−299
@@ -1,303 +1,407 @@
11Elm.Native.Graphics.Input = {};
22Elm.Native.Graphics.Input.make = function(elm) {
3−
4− elm.Native = elm.Native || {};
5− elm.Native.Graphics = elm.Native.Graphics || {};
6− elm.Native.Graphics.Input = elm.Native.Graphics.Input || {};
7− if (elm.Native.Graphics.Input.values) return elm.Native.Graphics.Input.values;
8−
9− var Render = ElmRuntime.use(ElmRuntime.Render.Element);
10− var newNode = ElmRuntime.use(ElmRuntime.Render.Utils).newElement;
11−
12− var Signal = Elm.Signal.make(elm);
13− var newElement = Elm.Graphics.Element.make(elm).newElement;
14− var JS = Elm.Native.JavaScript.make(elm);
15− var Utils = Elm.Native.Utils.make(elm);
16− var Tuple2 = Utils.Tuple2;
17−
18− function dropDown(values) {
19− var entries = JS.fromList(values);
20− var events = Signal.constant(entries[0]._1);
21−
22− var drop = newNode('select');
23− drop.style.border = '0 solid';
24− for (var i = 0; i < entries.length; ++i) {
25− var option = newNode('option');
26− var name = JS.fromString(entries[i]._0);
27− option.value = name;
28− option.innerHTML = name;
29− drop.appendChild(option);
30− }
31− drop.addEventListener('change', function() {
32− elm.notify(events.id, entries[drop.selectedIndex]._1);
33− });
34−
35− var t = drop.cloneNode(true);
36− t.style.visibility = "hidden";
37−
38− elm.node.appendChild(t);
39− var style = window.getComputedStyle(t, null);
40− var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);
41− var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);
42− elm.node.removeChild(t);
43−
44− var element = A3(newElement, w, h, {
45− ctor: 'Custom',
46− type: 'DropDown',
47− render: function render(model) { return drop; },
48− update: function update(node, oldModel, newModel) {},
49− model: {}
50− });
51−
52− return Tuple2(Signal.constant(element), events);
53− }
54−
55− function buttons(defaultValue) {
56− var events = Signal.constant(defaultValue);
57−
58− function render(model) {
59− var b = newNode('button');
60− b.style.display = 'block';
61− b.elmEvent = model.event;
62− function click() { elm.notify(events.id, b.elmEvent); }
63− b.addEventListener('click', click);
64− b.innerHTML = model.text;
65− return b;
66− }
67−
68− function update(node, oldModel, newModel) {
69− node.elmEvent = newModel.event;
70− var txt = newModel.text;
71− if (oldModel.text !== txt) node.innerHTML = txt;
72− }
73−
74− function button(evnt, txt) {
75− return A3(newElement, 100, 40, {
76− ctor: 'Custom',
77− type: 'Button',
78− render: render,
79− update: update,
80− model: { event:evnt, text:JS.fromString(txt) }
81− });
82− }
83−
84− return { _:{}, button:F2(button), events:events };
85− }
86−
87− function customButtons(defaultValue) {
88− var events = Signal.constant(defaultValue);
89−
90− function render(model) {
91− var btn = newNode('div');
92− btn.elmEvent = model.event;
93−
94− btn.elmUp = Render.render(model.up);
95− btn.elmHover = Render.render(model.hover);
96− btn.elmDown = Render.render(model.down);
97−
98− function replace(node) {
99− if (node !== btn.firstChild) btn.replaceChild(node, btn.firstChild);
100− }
101− var overCount = 0;
102− function over(e) {
103− if (overCount++ > 0) return;
104− replace(btn.elmHover);
105− }
106− function out(e) {
107− if (btn.contains(e.toElement || e.relatedTarget)) return;
108− overCount = 0;
109− replace(btn.elmUp);
110− }
111− function up() {
112− replace(btn.elmHover);
113− elm.notify(events.id, btn.elmEvent);
114− }
115− function down() { replace(btn.elmDown); }
116− btn.addEventListener('mouseover', over);
117− btn.addEventListener('mouseout' , out);
118− btn.addEventListener('mousedown', down);
119− btn.addEventListener('mouseup' , up);
120−
121− btn.appendChild(btn.elmUp);
122−
123− var clicker = newNode('div');
124− clicker.style.width = btn.elmUp.style.width;
125− clicker.style.height = btn.elmUp.style.height;
126− clicker.style.position = 'absolute';
127− clicker.style.top = 0;
128− btn.appendChild(clicker);
129−
130− return btn;
131− }
132−
133− function update(node, oldModel, newModel) {
134− node.elmEvent = newModel.event;
135− Render.update(node.elmUp, oldModel.up, newModel.up)
136− Render.update(node.elmHover, oldModel.hover, newModel.hover)
137− Render.update(node.elmDown, oldModel.down, newModel.down)
138− }
139−
140− function button(evnt, up, hover, down) {
141− return A3(newElement,
142− Math.max(up.props.width, hover.props.width, down.props.width),
143− Math.max(up.props.height, hover.props.height, down.props.height),
144− { ctor: 'Custom',
145− type: 'CustomButton',
146− render: render,
147− update: update,
148− model: { event:evnt, up:up, hover:hover, down:down }
149− });
150− }
151−
152− return { _:{}, customButton:F4(button), events:events };
153− }
154−
155−
156− function hoverables(defaultValue) {
157− var events = Signal.constant(defaultValue);
158− function hoverable(handler, elem) {
159− function onHover(bool) {
160− elm.notify(events.id, handler(bool));
161− }
162− var props = Utils.replace([['hover',onHover]], elem.props);
163− return { props:props, element:elem.element };
164− }
165− return { _:{}, hoverable:F2(hoverable), events:events };
166− }
167−
168−
169− function checkboxes(defaultValue) {
170− var events = Signal.constant(defaultValue);
171−
172− function render(model) {
173− var b = newNode('input');
174− b.type = 'checkbox';
175− b.checked = model.checked;
176− b.style.display = 'block';
177− b.elmHandler = model.handler;
178− function change() { elm.notify(events.id, b.elmHandler(b.checked)); }
179− b.addEventListener('change', change);
180− return b;
181− }
182−
183− function update(node, oldModel, newModel) {
184− node.elmHandler = newModel.handler;
185− node.checked = newModel.checked;
186− return true;
187− }
188−
189− function box(handler, checked) {
190− return A3(newElement, 13, 13, {
191− ctor: 'Custom',
192− type: 'CheckBox',
193− render: render,
194− update: update,
195− model: { checked:checked, handler:handler }
196− });
197− }
198−
199− return { _:{}, checkbox:F2(box), events:events };
200− }
201−
202− function setRange(node, start, end, dir) {
203− if (node.parentNode) {
204− node.setSelectionRange(start, end, dir);
205− } else {
206− setTimeout(function(){node.setSelectionRange(start, end, dir);}, 0);
207− }
208− }
209−
210− function mkTextPool(type) { return function fields(defaultValue) {
211− var events = Signal.constant(defaultValue);
212−
213− var state = null;
214−
215− function render(model) {
216− var field = newNode('input');
217− field.elmHandler = model.handler;
218−
219− field.id = 'test';
220− field.type = type;
221− field.placeholder = JS.fromString(model.placeHolder);
222− field.value = JS.fromString(model.state.string);
223− setRange(field, model.state.selectionStart, model.state.selectionEnd, 'forward');
224− field.style.border = 'none';
225− state = model.state;
226−
227− function update() {
228− var start = field.selectionStart,
229− end = field.selectionEnd;
230− if (field.selectionDirection === 'backward') {
231− start = end;
232− end = field.selectionStart;
233− }
234− state = { _:{},
235− string:JS.toString(field.value),
236− selectionStart:start,
237− selectionEnd:end };
238− elm.notify(events.id, field.elmHandler(state));
239− }
240− function mousedown() {
241− update();
242− elm.node.addEventListener('mouseup', mouseup);
243− }
244− function mouseup() {
245− update();
246− elm.node.removeEventListener('mouseup', mouseup)
247− }
248− field.addEventListener('keyup', update);
249− field.addEventListener('mousedown', mousedown);
250−
251− return field;
252− }
253−
254− function update(node, oldModel, newModel) {
255− node.elmHandler = newModel.handler;
256− if (state === newModel.state) return;
257− var newStr = JS.fromString(newModel.state.string);
258− if (node.value !== newStr) node.value = newStr;
259−
260− var start = newModel.state.selectionStart;
261− var end = newModel.state.selectionEnd;
262− var direction = 'forward';
263− if (end < start) {
264− start = end;
265− end = newModel.state.selectionStart;
266− direction = 'backward';
267− }
268−
269− if (node.selectionStart !== start
270− || node.selectionEnd !== end
271− || node.selectionDirection !== direction) {
272− setRange(node, start, end, direction);
273− }
274− }
275−
276− function field(handler, placeHolder, state) {
277− return A3(newElement, 200, 30,
278− { ctor: 'Custom',
279− type: type + 'Input',
280− render: render,
281− update: update,
282− model: { handler:handler,
283− placeHolder:placeHolder,
284− state:state }
285− });
286− }
287−
288− return { _:{}, field:F3(field), events:events };
289− }
290− }
291−
292− return elm.Native.Graphics.Input.values = {
293− buttons:buttons,
294− customButtons:customButtons,
295− hoverables:hoverables,
296− checkboxes:checkboxes,
297− fields:mkTextPool('text'),
298− emails:mkTextPool('email'),
299− passwords:mkTextPool('password'),
300− dropDown:dropDown
301− };
3+ elm.Native = elm.Native || {};
4+ elm.Native.Graphics = elm.Native.Graphics || {};
5+ elm.Native.Graphics.Input = elm.Native.Graphics.Input || {};
6+ if (elm.Native.Graphics.Input.values) return elm.Native.Graphics.Input.values;
7+
8+ var Render = ElmRuntime.use(ElmRuntime.Render.Element);
9+ var newNode = ElmRuntime.use(ElmRuntime.Render.Utils).newElement;
10+
11+ var toCss = Elm.Native.Color.make(elm).toCss;
12+ var Text = Elm.Native.Text.make(elm);
13+ var Signal = Elm.Signal.make(elm);
14+ var newElement = Elm.Graphics.Element.make(elm).newElement;
15+ var JS = Elm.Native.JavaScript.make(elm);
16+ var Utils = Elm.Native.Utils.make(elm);
17+ var Tuple2 = Utils.Tuple2;
18+
19+ function input(initialValue) {
20+ var signal = Signal.constant(initialValue);
21+ return { _:{}, signal:signal, handle:signal };
22+ }
23+
24+ function renderDropDown(signal, values) {
25+ return function(_) {
26+ var entries = JS.fromList(values);
27+
28+ var drop = newNode('select');
29+ drop.style.border = '0 solid';
30+ drop.style.pointerEvents = 'auto';
31+ for (var i = 0; i < entries.length; ++i) {
32+ var option = newNode('option');
33+ var name = JS.fromString(entries[i]._0);
34+ option.value = name;
35+ option.innerHTML = name;
36+ drop.appendChild(option);
37+ }
38+ drop.addEventListener('change', function() {
39+ elm.notify(signal.id, entries[drop.selectedIndex]._1);
40+ });
41+
42+ var t = drop.cloneNode(true);
43+ t.style.visibility = "hidden";
44+
45+ elm.node.appendChild(t);
46+ var style = window.getComputedStyle(t, null);
47+ var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);
48+ var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);
49+ elm.node.removeChild(t);
50+ return drop;
51+ };
52+ }
53+
54+ function updateDropDown(node, oldModel, newModel) {
55+ }
56+
57+ function dropDown(signal, values) {
58+ return A3(newElement, 100, 24, {
59+ ctor: 'Custom',
60+ type: 'DropDown',
61+ render: renderDropDown(signal,values),
62+ update: updateDropDown,
63+ model: {}
64+ });
65+ }
66+
67+ function renderButton(model) {
68+ var node = newNode('button');
69+ node.style.display = 'block';
70+ node.style.pointerEvents = 'auto';
71+ node.elm_signal = model.signal;
72+ node.elm_value = model.value;
73+ function click() {
74+ elm.notify(node.elm_signal.id, node.elm_value);
75+ }
76+ node.addEventListener('click', click);
77+ node.innerHTML = model.text;
78+ return node;
79+ }
80+
81+ function updateButton(node, oldModel, newModel) {
82+ node.elm_signal = newModel.signal;
83+ node.elm_value = newModel.value;
84+ var txt = newModel.text;
85+ if (oldModel.text !== txt) node.innerHTML = txt;
86+ }
87+
88+ function button(signal, value, text) {
89+ return A3(newElement, 100, 40, {
90+ ctor: 'Custom',
91+ type: 'Button',
92+ render: renderButton,
93+ update: updateButton,
94+ model: { signal:signal, value:value, text:JS.fromString(text) }
95+ });
96+ }
97+
98+ function renderCustomButton(model) {
99+ var btn = newNode('div');
100+ btn.style.pointerEvents = 'auto';
101+ btn.elm_signal = model.signal;
102+ btn.elm_value = model.value;
103+
104+ btn.elm_up = Render.render(model.up);
105+ btn.elm_hover = Render.render(model.hover);
106+ btn.elm_down = Render.render(model.down);
107+
108+ function replace(node) {
109+ if (node !== btn.firstChild) {
110+ btn.replaceChild(node, btn.firstChild);
111+ }
112+ }
113+ var overCount = 0;
114+ function over(e) {
115+ if (overCount++ > 0) return;
116+ replace(btn.elm_hover);
117+ }
118+ function out(e) {
119+ if (btn.contains(e.toElement || e.relatedTarget)) return;
120+ overCount = 0;
121+ replace(btn.elm_up);
122+ }
123+ function up() {
124+ replace(btn.elm_hover);
125+ elm.notify(btn.elm_signal.id, btn.elm_value);
126+ }
127+ function down() {
128+ replace(btn.elm_down);
129+ }
130+ btn.addEventListener('mouseover', over);
131+ btn.addEventListener('mouseout' , out);
132+ btn.addEventListener('mousedown', down);
133+ btn.addEventListener('mouseup' , up);
134+
135+ btn.appendChild(btn.elm_up);
136+
137+ var clicker = newNode('div');
138+ clicker.style.width = btn.elm_up.style.width;
139+ clicker.style.height = btn.elm_up.style.height;
140+ clicker.style.position = 'absolute';
141+ clicker.style.top = 0;
142+ btn.appendChild(clicker);
143+
144+ return btn;
145+ }
146+
147+ function updateCustomButton(node, oldModel, newModel) {
148+ var signal = newModel.signal;
149+ node.elm_up.elm_signal = signal;
150+ node.elm_hover.elm_signal = signal;
151+ node.elm_down.elm_signal = signal;
152+
153+ var value = newModel.value;
154+ node.elm_up.elm_value = value;
155+ node.elm_hover.elm_value = value;
156+ node.elm_down.elm_value = value;
157+
158+ Render.update(node.elm_up, oldModel.up, newModel.up)
159+ Render.update(node.elm_hover, oldModel.hover, newModel.hover)
160+ Render.update(node.elm_down, oldModel.down, newModel.down)
161+ }
162+
163+ function max3(a,b,c) {
164+ var ab = a > b ? a : b;
165+ return ab > c ? ab : c;
166+ }
167+
168+ function customButton(signal, value, up, hover, down) {
169+ return A3(newElement,
170+ max3(up.props.width, hover.props.width, down.props.width),
171+ max3(up.props.height, hover.props.height, down.props.height),
172+ { ctor: 'Custom',
173+ type: 'CustomButton',
174+ render: renderCustomButton,
175+ update: updateCustomButton,
176+ model: { signal:signal, value:value, up:up, hover:hover, down:down }
177+ });
178+ }
179+
180+ function renderCheckbox(model) {
181+ var node = newNode('input');
182+ node.type = 'checkbox';
183+ node.checked = model.checked;
184+ node.style.display = 'block';
185+ node.style.pointerEvents = 'auto';
186+ node.elm_signal = model.signal;
187+ node.elm_handler = model.handler;
188+ function change() {
189+ elm.notify(node.elm_signal.id, node.elm_handler(node.checked));
190+ }
191+ node.addEventListener('change', change);
192+ return node;
193+ }
194+
195+ function updateCheckbox(node, oldModel, newModel) {
196+ node.elm_signal = newModel.signal;
197+ node.elm_handler = newModel.handler;
198+ node.checked = newModel.checked;
199+ return true;
200+ }
201+
202+ function checkbox(signal, handler, checked) {
203+ return A3(newElement, 13, 13, {
204+ ctor: 'Custom',
205+ type: 'CheckBox',
206+ render: renderCheckbox,
207+ update: updateCheckbox,
208+ model: { signal:signal, handler:handler, checked:checked }
209+ });
210+ }
211+
212+ function setRange(node, start, end, dir) {
213+ if (node.parentNode) {
214+ node.setSelectionRange(start, end, dir);
215+ } else {
216+ setTimeout(function(){node.setSelectionRange(start, end, dir);}, 0);
217+ }
218+ }
219+
220+ function updateIfNeeded(css, attribute, latestAttribute) {
221+ if (css[attribute] !== latestAttribute) {
222+ css[attribute] = latestAttribute;
223+ }
224+ }
225+ function cssDimensions(dimensions) {
226+ return dimensions.top + 'px ' +
227+ dimensions.right + 'px ' +
228+ dimensions.bottom + 'px ' +
229+ dimensions.left + 'px';
230+ }
231+ function updateFieldStyle(css, style) {
232+ updateIfNeeded(css, 'padding', cssDimensions(style.padding));
233+
234+ var outline = style.outline;
235+ updateIfNeeded(css, 'border-width', cssDimensions(outline.width));
236+ updateIfNeeded(css, 'border-color', toCss(outline.color));
237+ updateIfNeeded(css, 'border-radius', outline.radius + 'px');
238+
239+ var highlight = style.highlight;
240+ if (highlight.width === 0) {
241+ css.outline = 'none';
242+ } else {
243+ updateIfNeeded(css, 'outline-width', highlight.width + 'px');
244+ updateIfNeeded(css, 'outline-color', toCss(highlight.color));
245+ }
246+
247+ var textStyle = style.style;
248+ updateIfNeeded(css, 'color', toCss(textStyle.color));
249+ if (textStyle.typeface.ctor !== '[]') {
250+ updateIfNeeded(css, 'font-family', Text.toTypefaces(textStyle.typeface));
251+ }
252+ if (textStyle.height.ctor !== "Nothing") {
253+ updateIfNeeded(css, 'font-size', textStyle.height._0 + 'px');
254+ }
255+ updateIfNeeded(css, 'font-weight', textStyle.bold ? 'bold' : 'normal');
256+ updateIfNeeded(css, 'font-style', textStyle.italic ? 'italic' : 'normal');
257+ if (textStyle.line.ctor !== 'Nothing') {
258+ updateIfNeeded(css, 'text-decoration', Text.toLine(textStyle.line._0));
259+ }
260+ }
261+
262+ function renderField(model) {
263+ var field = newNode('input');
264+ updateFieldStyle(field.style, model.style);
265+ field.style.borderStyle = 'solid';
266+ field.style.pointerEvents = 'auto';
267+
268+ field.type = model.type;
269+ field.placeholder = JS.fromString(model.placeHolder);
270+ field.value = JS.fromString(model.content.string);
271+
272+ field.elm_signal = model.signal;
273+ field.elm_handler = model.handler;
274+ field.elm_old_value = field.value;
275+
276+ function inputUpdate(event) {
277+ var curr = field.elm_old_value;
278+ var next = field.value;
279+ if (curr === next) {
280+ return;
281+ }
282+
283+ var direction = field.selectionDirection === 'forward' ? 'Forward' : 'Backward';
284+ var start = field.selectionStart;
285+ var end = field.selectionEnd;
286+ field.value = field.elm_old_value;
287+
288+ elm.notify(field.elm_signal.id, field.elm_handler({
289+ _:{},
290+ string: JS.toString(next),
291+ selection: {
292+ _:{},
293+ start: start,
294+ end: end,
295+ direction: { ctor: direction }
296+ },
297+ }));
298+ }
299+
300+ function mouseUpdate(event) {
301+ var direction = field.selectionDirection === 'forward' ? 'Forward' : 'Backward';
302+ elm.notify(field.elm_signal.id, field.elm_handler({
303+ _:{},
304+ string: field.value,
305+ selection: {
306+ _:{},
307+ start: field.selectionStart,
308+ end: field.selectionEnd,
309+ direction: { ctor: direction }
310+ },
311+ }));
312+ }
313+ function mousedown(event) {
314+ mouseUpdate(event);
315+ elm.node.addEventListener('mouseup', mouseup);
316+ }
317+ function mouseup(event) {
318+ mouseUpdate(event);
319+ elm.node.removeEventListener('mouseup', mouseup)
320+ }
321+ field.addEventListener('input', inputUpdate);
322+ field.addEventListener('mousedown', mousedown);
323+ field.addEventListener('focus', function() {
324+ field.elm_hasFocus = true;
325+ });
326+ field.addEventListener('blur', function() {
327+ field.elm_hasFocus = false;
328+ });
329+
330+ return field;
331+ }
332+
333+ function updateField(field, oldModel, newModel) {
334+ if (oldModel.style !== newModel.style) {
335+ updateFieldStyle(field.style, newModel.style);
336+ }
337+ field.elm_signal = newModel.signal;
338+ field.elm_handler = newModel.handler;
339+
340+ field.type = newModel.type;
341+ field.placeholder = JS.fromString(newModel.placeHolder);
342+ var value = JS.fromString(newModel.content.string);
343+ field.value = value;
344+ field.elm_old_value = value;
345+ if (field.elm_hasFocus) {
346+ var selection = newModel.content.selection;
347+ var direction = selection.direction.ctor === 'Forward' ? 'forward' : 'backward';
348+ setRange(field, selection.start, selection.end, direction);
349+ }
350+ }
351+
352+ function mkField(type) {
353+ function field(style, signal, handler, placeHolder, content) {
354+ var padding = style.padding;
355+ var outline = style.outline.width;
356+ var adjustWidth = padding.left + padding.right + outline.left + outline.right;
357+ var adjustHeight = padding.top + padding.bottom + outline.top + outline.bottom;
358+ return A3(newElement, 200, 30, {
359+ ctor: 'Custom',
360+ type: type + 'Field',
361+ adjustWidth: adjustWidth,
362+ adjustHeight: adjustHeight,
363+ render: renderField,
364+ update: updateField,
365+ model: {
366+ signal:signal,
367+ handler:handler,
368+ placeHolder:placeHolder,
369+ content:content,
370+ style:style,
371+ type:type
372+ }
373+ });
374+ }
375+ return F5(field);
376+ }
377+
378+ function hoverable(signal, handler, elem) {
379+ function onHover(bool) {
380+ elm.notify(signal.id, handler(bool));
381+ }
382+ var props = Utils.replace([['hover',onHover]], elem.props);
383+ return { props:props, element:elem.element };
384+ }
385+
386+ function clickable(signal, value, elem) {
387+ function onClick(bool) {
388+ elm.notify(signal.id, value);
389+ }
390+ var props = Utils.replace([['click',onClick]], elem.props);
391+ return { props:props, element:elem.element };
392+ }
393+
394+ return elm.Native.Graphics.Input.values = {
395+ input:input,
396+ button:F3(button),
397+ customButton:F5(customButton),
398+ checkbox:F3(checkbox),
399+ dropDown:F2(dropDown),
400+ field:mkField('text'),
401+ email:mkField('email'),
402+ password:mkField('password'),
403+ hoverable:F3(hoverable),
404+ clickable:F3(clickable)
405+ };
302406
303407};
libraries/Native/Regex.js+11−20
@@ -15,18 +15,16 @@ Elm.Native.Regex.make = function(elm) {
1515 function caseInsensitive(re) {
1616 return new RegExp(re.source, 'gi');
1717 }
18− function pattern(raw) {
18+ function regex(raw) {
1919 return new RegExp(raw, 'g');
2020 }
2121
2222 function contains(re, string) {
23− return re.test(JS.fromString(string));
23+ return JS.fromString(string).match(re) !== null;
2424 }
2525
26− function findAll(re, string) {
27− return find(Infinity, re, string);
28− }
2926 function find(n, re, str) {
27+ n = n.ctor === "All" ? Infinity : n._0;
3028 var out = [];
3129 var number = 0;
3230 var string = JS.fromString(str);
@@ -51,10 +49,8 @@ Elm.Native.Regex.make = function(elm) {
5149 return JS.toList(out);
5250 }
5351
54− function replaceAll(re, replacer, string) {
55− return replace(Infinity, re, replacer, string);
56− }
5752 function replace(n, re, replacer, string) {
53+ n = n.ctor === "All" ? Infinity : n._0;
5854 var count = 0;
5955 function jsReplacer(match) {
6056 if (count++ > n) return match;
@@ -77,10 +73,10 @@ Elm.Native.Regex.make = function(elm) {
7773 return string.replace(re, jsReplacer);
7874 }
7975
80− function split(re, string) {
81− return JS.toList(JS.fromString(string).split(re));
82− }
83− function splitN(n, re, str) {
76+ function split(n, re, str) {
77+ if (n === Infinity) {
78+ return JS.toList(JS.fromString(string).split(re));
79+ }
8480 var string = JS.fromString(str);
8581 var result;
8682 var out = [];
@@ -95,18 +91,13 @@ Elm.Native.Regex.make = function(elm) {
9591 }
9692
9793 return Elm.Native.Regex.values = {
98− pattern: pattern,
94+ regex: regex,
9995 caseInsensitive: caseInsensitive,
10096 escape: escape,
10197
10298 contains: F2(contains),
103− findAll: F2(findAll),
10499 find: F3(find),
105−
106− replaceAll: F3(replaceAll),
107100 replace: F4(replace),
108−
109− split: F2(split),
110− splitN: F3(splitN),
101+ split: F3(split),
111102 };
112−};
103+};
libraries/Native/Show.js−3
@@ -6,10 +6,7 @@ Elm.Native.Show.make = function(elm) {
66
77 var NList = Elm.Native.List.make(elm);
88 var List = Elm.List.make(elm);
9− var Maybe = Elm.Maybe.make(elm);
10− var JS = Elm.JavaScript.make(elm);
119 var Dict = Elm.Dict.make(elm);
12− var Json = Elm.Json.make(elm);
1310 var Tuple2 = Elm.Native.Utils.make(elm).Tuple2;
1411
1512 var toString = function(v) {
libraries/Native/Signal/Http.js+52−49
@@ -1,61 +1,64 @@
11Elm.Native.Http = {};
22Elm.Native.Http.make = function(elm) {
33
4− elm.Native = elm.Native || {};
5− elm.Native.Http = elm.Native.Http || {};
6− if (elm.Native.Http.values) return elm.Native.Http.values;
4+ elm.Native = elm.Native || {};
5+ elm.Native.Http = elm.Native.Http || {};
6+ if (elm.Native.Http.values) return elm.Native.Http.values;
77
8+ var JS = Elm.JavaScript.make(elm);
9+ var List = Elm.List.make(elm);
10+ var Signal = Elm.Signal.make(elm);
811
9− var JS = Elm.JavaScript.make(elm);
10− var List = Elm.List.make(elm);
11− var Signal = Elm.Signal.make(elm);
12+ function registerReq(queue,responses) {
13+ return function(req) {
14+ if (req.url.length > 0) {
15+ sendReq(queue,responses,req);
16+ }
17+ };
18+ }
1219
20+ function updateQueue(queue,responses) {
21+ if (queue.length > 0) {
22+ elm.notify(responses.id, queue[0].value);
23+ if (queue[0].value.ctor !== 'Waiting') {
24+ queue.shift();
25+ setTimeout(function() { updateQueue(queue,responses); }, 0);
26+ }
27+ }
28+ }
1329
14− function registerReq(queue,responses) { return function(req) {
15− if (req.url.ctor !== '[]') { sendReq(queue,responses,req); }
16− };
17− }
30+ function sendReq(queue,responses,req) {
31+ var response = { value: { ctor:'Waiting' } };
32+ queue.push(response);
1833
19− function updateQueue(queue,responses) {
20− if (queue.length > 0) {
21− elm.notify(responses.id, queue[0].value);
22− if (queue[0].value.ctor !== 'Waiting') {
23− queue.shift();
24− setTimeout(function() { updateQueue(queue,responses); }, 0);
25− }
26− }
27− }
28−
29− function sendReq(queue,responses,req) {
30− var response = { value: { ctor:'Waiting' } };
31− queue.push(response);
32−
33− var request = null;
34− if (window.ActiveXObject) { request = new ActiveXObject("Microsoft.XMLHTTP"); }
35− if (window.XMLHttpRequest) { request = new XMLHttpRequest(); }
36− request.onreadystatechange = function(e) {
37− if (request.readyState === 4) {
38− response.value = (request.status >= 200 && request.status < 300 ?
39− { ctor:'Success', _0:JS.toString(request.responseText) } :
40− { ctor:'Failure', _0:request.status, _1:JS.toString(request.statusText) });
41− setTimeout(function() { updateQueue(queue,responses); }, 0);
42− }
43− };
44− request.open(JS.fromString(req.verb), JS.fromString(req.url), true);
45− function setHeader(pair) {
46− request.setRequestHeader( JS.fromString(pair._0), JS.fromString(pair._1) );
47− }
48− List.map(setHeader)(req.headers);
49− request.send(JS.fromString(req.body));
50− }
34+ var request = (window.ActiveXObject
35+ ? new ActiveXObject("Microsoft.XMLHTTP")
36+ : new XMLHttpRequest());
5137
52− function send(requests) {
53− var responses = Signal.constant(elm.Http.values.Waiting);
54− var sender = A2( Signal.lift, registerReq([],responses), requests );
55− function f(x) { return function(y) { return x; } }
56− return A3( Signal.lift2, f, responses, sender );
57− }
38+ request.onreadystatechange = function(e) {
39+ if (request.readyState === 4) {
40+ response.value = (request.status >= 200 && request.status < 300 ?
41+ { ctor:'Success', _0:JS.toString(request.responseText) } :
42+ { ctor:'Failure', _0:request.status, _1:JS.toString(request.statusText) });
43+ setTimeout(function() { updateQueue(queue,responses); }, 0);
44+ }
45+ };
46+ request.open(JS.fromString(req.verb), JS.fromString(req.url), true);
47+ function setHeader(pair) {
48+ request.setRequestHeader( JS.fromString(pair._0), JS.fromString(pair._1) );
49+ }
50+ List.map(setHeader)(req.headers);
51+ request.send(JS.fromString(req.body));
52+ }
5853
59− return elm.Native.Http.values = {send:send};
54+ function send(requests) {
55+ var responses = Signal.constant(elm.Http.values.Waiting);
56+ var sender = A2( Signal.lift, registerReq([],responses), requests );
57+ function f(x) { return function(y) { return x; } }
58+ return A3( Signal.lift2, f, responses, sender );
59+ }
6060
61+ return elm.Native.Http.values = {
62+ send:send
63+ };
6164};
libraries/Native/Signal/Mouse.js+2−6
@@ -20,15 +20,12 @@ Elm.Native.Mouse.make = function(elm) {
2020 y.defaultNumberOfKids = 0;
2121
2222 var isDown = Signal.constant(false);
23− var isClicked = Signal.constant(false);
2423 var clicks = Signal.constant(Utils.Tuple0);
2524
2625 var node = elm.display === ElmRuntime.Display.FULLSCREEN ? document : elm.node;
2726
28− elm.addListener([isClicked.id, clicks.id], node, 'click', function click() {
29− elm.notify(isClicked.id, true);
27+ elm.addListener([clicks.id], node, 'click', function click() {
3028 elm.notify(clicks.id, Utils.Tuple0);
31− elm.notify(isClicked.id, false);
3229 });
3330 elm.addListener([isDown.id], node, 'mousedown', function down() {
3431 elm.notify(isDown.id, true);
@@ -44,8 +41,7 @@ Elm.Native.Mouse.make = function(elm) {
4441 position: position,
4542 x:x,
4643 y:y,
47− isClicked: isClicked,
4844 isDown: isDown,
4945 clicks: clicks
5046 };
51−};
47+};
libraries/Native/Signal/Signal.js−9
@@ -127,12 +127,6 @@ Elm.Native.Signal.make = function(elm) {
127127 input.kids.push(this);
128128 }
129129
130− function dropWhen(s1,b,s2) {
131− var pairs = lift2( F2(function(x,y){return {x:x,y:y};}), s1, s2 );
132− var dropped = new DropIf(function(p){return p.x;},{x:true,y:b},pairs);
133− return lift(function(p){return p.y;}, dropped);
134− }
135−
136130 function timestamp(a) {
137131 function update() { return Utils.Tuple2(Date.now(), a.value); }
138132 return new LiftN(update, [a]);
@@ -225,9 +219,6 @@ Elm.Native.Signal.make = function(elm) {
225219 keepIf : F3(function(pred,base,sig) {
226220 return new DropIf(function(x) {return !pred(x);},base,sig); }),
227221 dropIf : F3(function(pred,base,sig) { return new DropIf(pred,base,sig); }),
228− keepWhen : F3(function(s1,b,s2) {
229− return dropWhen(lift(function(b){return !b;},s1), b, s2); }),
230− dropWhen : F3(dropWhen),
231222 dropRepeats : function(s) { return new DropRepeats(s);},
232223 sampleOn : F2(sampleOn),
233224 timestamp : timestamp
libraries/Native/String.js+3−2
@@ -144,7 +144,8 @@ Elm.Native.String.make = function(elm) {
144144 return str.indexOf(sub) === 0;
145145 }
146146 function endsWith(sub, str) {
147− return str.lastIndexOf(sub) === str.length - sub.length;
147+ return str.length >= sub.length &&
148+ str.lastIndexOf(sub) === str.length - sub.length;
148149 }
149150 function indexes(sub, str) {
150151 var subLen = sub.length;
@@ -248,4 +249,4 @@ Elm.Native.String.make = function(elm) {
248249 toList: toList,
249250 fromList: fromList,
250251 };
251−};
252+};
libraries/Native/Text.js+58−42
@@ -4,11 +4,10 @@ Elm.Native.Text.make = function(elm) {
44 elm.Native.Text = elm.Native.Text || {};
55 if (elm.Native.Text.values) return elm.Native.Text.values;
66
7− var JS = Elm.JavaScript.make(elm);
8− var Utils = Elm.Native.Utils.make(elm);
9− var Color = Elm.Native.Color.make(elm);
7+ var toCss = Elm.Native.Color.make(elm).toCss;
108 var Element = Elm.Graphics.Element.make(elm);
11− var show = Elm.Native.Show.make(elm).show;
9+ var List = Elm.Native.List.make(elm);
10+ var Utils = Elm.Native.Utils.make(elm);
1211
1312 function makeSpaces(s) {
1413 if (s.length == 0) { return s; }
@@ -51,13 +50,51 @@ Elm.Native.Text.make = function(elm) {
5150 return arr.join('<br/>');
5251 }
5352
54− function toText(str) { return Utils.txt(properEscape(JS.fromString(str))); }
53+ function toText(str) { return Utils.txt(properEscape(str)); }
54+
55+ // conversions from Elm values to CSS
56+ function toTypefaces(list) {
57+ var typefaces = List.toArray(list);
58+ for (var i = typefaces.length; i--; ) {
59+ var typeface = typefaces[i];
60+ if (typeface.indexOf(' ') > -1) {
61+ typefaces[i] = "'" + typeface + "'";
62+ }
63+ }
64+ return typefaces.join(',');
65+ }
66+ function toLine(line) {
67+ var ctor = line.ctor;
68+ return ctor === 'Under' ? 'underline' :
69+ ctor === 'Over' ? 'overline' : 'line-through';
70+ }
5571
72+ // setting styles of Text
73+ function style(style, text) {
74+ var newText = '<span style="color:' + toCss(style.color) + ';'
75+ if (style.typeface.ctor !== '[]') {
76+ newText += 'font-family:' + toTypefaces(style.typeface) + ';'
77+ }
78+ if (style.height.ctor !== "Nothing") {
79+ newText += 'font-size:' + style.height._0 + 'px;';
80+ }
81+ if (style.bold) {
82+ newText += 'font-weight:bold;';
83+ }
84+ if (style.italic) {
85+ newText += 'font-style:italic;';
86+ }
87+ if (style.line.ctor !== 'Nothing') {
88+ newText += 'text-decoration:' + toLine(style.line._0) + ';';
89+ }
90+ newText += '">' + Utils.makeText(text) + '</span>'
91+ return Utils.txt(newText);
92+ }
5693 function height(px, text) {
5794 return { style: 'font-size:' + px + 'px;', text:text }
5895 }
59− function typeface(name, text) {
60− return { style: 'font-family:' + name + ';', text:text }
96+ function typeface(names, text) {
97+ return { style: 'font-family:' + toTypefaces(names) + ';', text:text }
6198 }
6299 function monospace(text) {
63100 return { style: 'font-family:monospace;', text:text }
@@ -71,25 +108,16 @@ Elm.Native.Text.make = function(elm) {
71108 function link(href, text) {
72109 return { href: toText(href), text:text };
73110 }
74− function underline(text) {
75− return { line: ' underline', text:text };
76− }
77− function overline(text) {
78− return { line: ' overline', text:text };
79− }
80− function strikeThrough(text) {
81− return { line: ' line-through', text:text };
111+ function line(line, text) {
112+ return { style: 'text-decoration:' + toLine(line) + ';', text:text };
82113 }
83114
84− function color(c, text) {
85− var color = (c._3 === 1)
86− ? ('rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')')
87− : ('rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')');
88− return { style: 'color:' + color + ';', text:text };
115+ function color(color, text) {
116+ return { style: 'color:' + toCss(color) + ';', text:text };
89117 }
90118
91− function position(align) {
92− function create(text) {
119+ function block(align) {
120+ return function(text) {
93121 var raw = {
94122 ctor :'RawHtml',
95123 html : Utils.makeText(text),
@@ -100,7 +128,6 @@ Elm.Native.Text.make = function(elm) {
100128 var pos = A2(Utils.htmlHeight, 0, raw);
101129 return A3(Element.newElement, pos._0, pos._1, raw);
102130 }
103− return create;
104131 }
105132
106133 function markdown(text, guid) {
@@ -115,36 +142,25 @@ Elm.Native.Text.make = function(elm) {
115142 return A3(Element.newElement, pos._0, pos._1, raw);
116143 }
117144
118− var text = position('left');
119− function asText(v) {
120− return text(monospace(toText(show(v))));
121− }
122−
123− function plainText(v) {
124− return text(toText(v));
125− }
126−
127145 return elm.Native.Text.values = {
128146 toText: toText,
129147
130148 height : F2(height),
131149 italic : italic,
132150 bold : bold,
133− underline : underline,
134− overline : overline,
135− strikeThrough : strikeThrough,
151+ line : F2(line),
136152 monospace : monospace,
137153 typeface : F2(typeface),
138154 color : F2(color),
139155 link : F2(link),
140156
141− justified : position('justify'),
142− centered : position('center'),
143− righted : position('right'),
144− text : text,
145− plainText : plainText,
146− markdown : markdown,
157+ leftAligned : block('left'),
158+ rightAligned : block('right'),
159+ centered : block('center'),
160+ justified : block('justify'),
161+ markdown : markdown,
147162
148− asText : asText,
163+ toTypefaces:toTypefaces,
164+ toLine:toLine,
149165 };
150166};
libraries/Native/Trampoline.jsnew file+24
@@ -0,0 +1,24 @@
1+Elm.Native.Trampoline = {};
2+Elm.Native.Trampoline.make = function(elm) {
3+ elm.Native = elm.Native || {};
4+ elm.Native.Trampoline = elm.Native.Trampoline || {};
5+ if (elm.Native.Trampoline.values) return elm.Native.Trampoline.values;
6+
7+ // trampoline : Trampoline a -> a
8+ function trampoline(t) {
9+ var tramp = t;
10+ while(true) {
11+ switch(tramp.ctor) {
12+ case "Done":
13+ return tramp._0;
14+ case "Continue":
15+ tramp = tramp._0({ctor: "_Tuple0"});
16+ continue;
17+ }
18+ }
19+ }
20+
21+ return elm.Native.Trampoline.values = {
22+ trampoline:trampoline
23+ };
24+};
libraries/Native/Utils.js+6−8
@@ -9,7 +9,12 @@ Elm.Native.Utils.make = function(elm) {
99 if (x === y) return true;
1010 if (typeof x === "object") {
1111 var c = 0;
12− for (var i in x) { ++c; if (!eq(x[i],y[i])) return false; }
12+ for (var i in x) {
13+ ++c;
14+ if (!eq(x[i],y[i])) {
15+ return false;
16+ }
17+ }
1318 return c === Object.keys(y).length;
1419 }
1520 if (typeof x === 'function') {
@@ -76,14 +81,8 @@ Elm.Native.Utils.make = function(elm) {
7681
7782 function makeText(text) {
7883 var style = '';
79− var line = '';
8084 var href = '';
8185 while (true) {
82− if (text.line) {
83− line += text.line;
84− text = text.text;
85− continue;
86− }
8786 if (text.style) {
8887 style += text.style;
8988 text = text.text;
@@ -95,7 +94,6 @@ Elm.Native.Utils.make = function(elm) {
9594 continue;
9695 }
9796 if (href) text = '<a href="' + href + '">' + text + '</a>';
98− if (line) style += 'text-decoration:' + line + ';';
9997 if (style) text = '<span style="' + style + '">' + text + '</span>';
10098 return text;
10199 }
libraries/Prelude.elmdeleted−8
@@ -1,8 +0,0 @@
1−module Prelude where
2−{-| Everything that is automatically imported -}
3−
4−import Native.Show
5−
6−-- Convert almost any value to its string representation.
7−show : a -> String
8−show = Native.Show.show
libraries/Regex.elm+49−56
@@ -3,16 +3,17 @@ module Regex where
33same kind of regular expressions accepted by JavaScript](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions).
44
55# Create
6−@docs pattern, caseInsensitive, escape
6+@docs regex, escape, caseInsensitive
77
8−# Match
9−@docs Match
8+# Helpful Data Structures
109
11−# Find and Replace
12−@docs contains, find, findAll, replace, replaceAll
10+These data structures are needed to help define functions like [`find`](#find)
11+and [`replace`](#replace).
1312
14−# Split
15−@docs split, splitN
13+@docs HowMany, Match
14+
15+# Use
16+@docs contains, find, replace, split
1617
1718-}
1819
@@ -21,31 +22,35 @@ import Native.Regex
2122
2223data Regex = Regex
2324
24−{-| Escape all special characters. So `pattern (escape "$$$")`
25−will match exactly `"$$$"` even though `$` is a special character.
25+{-| Escape strings to be regular expressions, making all special characters
26+safe. So `regex (escape "^a+")` will match exactly `"^a+"` instead of a series
27+of `a`&rsquo;s that start at the beginning of the line.
2628-}
2729escape : String -> String
2830escape = Native.Regex.escape
2931
3032{-| Create a Regex that matches patterns [as specified in JavaScript](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions#Writing_a_Regular_Expression_Pattern).
31−Be careful to escape backslashes properly!
33+
34+Be careful to escape backslashes properly! For example, `"\w"` is escaping the
35+letter `w` which is probably not what you want. You probably want `"\\w"`
36+instead, which escapes the backslash.
3237-}
33−pattern : String -> Regex
34−pattern = Native.Regex.pattern
38+regex : String -> Regex
39+regex = Native.Regex.regex
3540
3641
37−{-| Make a pattern case insensitive -}
42+{-| Make a regex case insensitive -}
3843caseInsensitive : Regex -> Regex
3944caseInsensitive = Native.Regex.caseInsensitive
4045
4146{-| Check to see if a Regex is contained in a string.
4247
4348```haskell
44− contains (pattern "123") "12345" == True
45− contains (pattern "b+") "aabbcc" == True
49+ contains (regex "123") "12345" == True
50+ contains (regex "b+") "aabbcc" == True
4651
47− contains (pattern "789") "12345" == False
48− contains (pattern "z+") "aabbcc" == False
52+ contains (regex "789") "12345" == False
53+ contains (regex "z+") "aabbcc" == False
4954```
5055-}
5156contains : Regex -> String -> Bool
@@ -55,79 +60,67 @@ contains = Native.Regex.contains
5560Here are details on each field:
5661
5762 * `match` &mdash; the full string of the match.
58− * `submatches` &mdash; a pattern might have [subpatterns, surrounded by
63+ * `submatches` &mdash; a regex might have [subpatterns, surrounded by
5964 parentheses](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions#Using_Parenthesized_Substring_Matches).
6065 If there are N subpatterns, there will be N elements in the `submatches` list.
6166 Each submatch in this list is a `Maybe` because not all subpatterns may trigger.
62− For example, `(pattern "(a+)|(b+)")` will either match many `a`&rsquo;s or
67+ For example, `(regex "(a+)|(b+)")` will either match many `a`&rsquo;s or
6368 many `b`&rsquo;s, but never both.
6469 * `index` &mdash; the index of the match in the original string.
6570 * `number` &mdash; if you find many matches, you can think of each one
6671 as being labeled with a `number` starting at one. So the first time you
6772 find a match, that is match `number` one. Second time is match `number` two.
68− This is useful when paired with `replaceAll` if replacement is dependent on how
73+ This is useful when paired with `replace All` if replacement is dependent on how
6974 many times a pattern has appeared before.
7075-}
7176type Match = { match : String, submatches : [Maybe String], index : Int, number : Int }
7277
73−{-| Find all of the matches in a string:
78+{-| `HowMany` is used to specify how many matches you want to make. So
79+`replace All` would replace every match, but `replace (AtMost 2)` would
80+replace at most two matches (i.e. zero, one, two, but never three or more).
81+-}
82+data HowMany = All | AtMost Int
83+
84+{-| Find matches in a string:
7485
7586```haskell
76− words = findAll (pattern "\\w+") "hello world"
87+ findTwoCommas = find (AtMost 2) (regex ",")
7788
78− map .match words == ["hello","world"]
79− map .index words == [0,6]
89+ -- map .index (findTwoCommas "a,b,c,d,e") == [1,3]
90+ -- map .index (findTwoCommas "a b c d e") == []
8091
81− places = findAll (pattern "[oi]n a (\\w+)") "I am on a boat in a lake."
92+ places = find All (regex "[oi]n a (\\w+)") "I am on a boat in a lake."
8293
83− map .match places== ["on a boat", "in a lake"]
84− map .submatches places == [ [Just "boat"], [Just "lake"] ]
94+ -- map .match places == ["on a boat", "in a lake"]
95+ -- map .submatches places == [ [Just "boat"], [Just "lake"] ]
8596```
8697-}
87−findAll : Regex -> String -> [Match]
88−findAll = Native.Regex.findAll
89−
90−{-| Same as `findAll`, but `find` will quit searching after the *n<sup>th</sup>* match.
91−That means the resulting list has maximum length N, but *it can be shorter*
92−if there are not that many matches in the given string.
93−-}
94−find : Int -> Regex -> String -> [Match]
98+find : HowMany -> Regex -> String -> [Match]
9599find = Native.Regex.find
96100
97−{-| Replace all matches. The function from `Match` to `String` lets
101+{-| Replace matches. The function from `Match` to `String` lets
98102you use the details of a specific match when making replacements.
99103
100104```haskell
101− devowel = replaceAll (pattern "[aeiou]") (\_ -> "")
105+ devowel = replace All (regex "[aeiou]") (\_ -> "")
102106
103− devowel "The quick brown fox" == "Th qck brwn fx"
107+ -- devowel "The quick brown fox" == "Th qck brwn fx"
104108
105− reverseWords = replaceAll (pattern "\\w+") (\{match} -> String.reverse match)
109+ reverseWords = replace All (regex "\\w+") (\{match} -> String.reverse match)
106110
107− reverseWords "deliver mined parts" == "reviled denim strap"
111+ -- reverseWords "deliver mined parts" == "reviled denim strap"
108112```
109113-}
110−replaceAll : Regex -> (Match -> String) -> String -> String
111−replaceAll = Native.Regex.replaceAll
112−
113−{-| Same as `replaceAll`, but `replace` will quit after the *n<sup>th</sup>* match.-}
114−replace : Int -> Regex -> (Match -> String) -> String -> String
114+replace : HowMany -> Regex -> (Match -> String) -> String -> String
115115replace = Native.Regex.replace
116116
117117{-| Split a string, using the regex as the separator.
118118
119119```haskell
120− split (pattern " *, *") "a ,b, c,d" == ["a","b","c","d"]
121−```
122−-}
123−split : Regex -> String -> [String]
124−split = Native.Regex.split
120+ split (AtMost 1) (regex ",") "tom,99,90,85" == ["tom","99,90,85"]
125121
126−{-| Same as `split` but stops after the *n<sup>th</sup>* match.
127−
128−```haskell
129− splitN 1 (pattern ": *") "tom: 99,90,85" == ["tom","99,90,85"]
122+ split All (regex ",") "a,b,c,d" == ["a","b","c","d"]
130123```
131124-}
132−splitN : Int -> Regex -> String -> [String]
133−splitN = Native.Regex.splitN
125+split : HowMany -> Regex -> String -> [String]
126+split = Native.Regex.split
libraries/Signal.elm+7−2
@@ -32,6 +32,10 @@ the [`Time`](/docs/Signal/Time.elm) library.
3232import Native.Signal
3333import List (foldr)
3434
35+import Basics (fst, snd, not)
36+import Native.Error
37+import Maybe as M
38+
3539data Signal a = Signal
3640
3741{-| Create a constant signal that never changes. -}
@@ -122,7 +126,8 @@ Until the first signal becomes false again, all events will be propagated. Elm
122126does not allow undefined signals, so a base case must be provided in case the
123127first signal is not true initially. -}
124128keepWhen : Signal Bool -> a -> Signal a -> Signal a
125−keepWhen = Native.Signal.keepWhen
129+keepWhen bs def sig =
130+ snd <~ (keepIf fst (False, def) ((,) <~ (sampleOn sig bs) ~ sig))
126131
127132{-| Drop events when the first signal is true. When the first signal becomes
128133false, the most recent value of the second signal will be propagated. Until the
@@ -130,7 +135,7 @@ first signal becomes true again, all events will be propagated. Elm does not
130135allow undefined signals, s oa base case must be provided in case the first
131136signal is true initially. -}
132137dropWhen : Signal Bool -> a -> Signal a -> Signal a
133−dropWhen = Native.Signal.dropWhen
138+dropWhen bs = keepWhen (not <~ bs)
134139
135140{-| Drop updates that repeat the current value of the signal.
136141
libraries/String.elm+33−6
@@ -15,7 +15,7 @@ are enclosed in `"double quotes"`. Strings are *not* lists of characters.
1515@docs contains, startsWith, endsWith, indexes, indices
1616
1717# Conversions
18−@docs toInt, toFloat, toList, fromList
18+@docs show, toInt, toFloat, toList, fromList
1919
2020# Formatting
2121Cosmetic operations such as padding with extra characters or trimming whitespace.
@@ -28,10 +28,15 @@ Cosmetic operations such as padding with extra characters or trimming whitespace
2828@docs map, filter, foldl, foldr, any, all
2929-}
3030
31+import Native.Show
3132import Native.String
3233import Maybe (Maybe)
3334
34−{-| Check if a string is empty `(isEmpty "" == True)` -}
35+{-| Check if a string is empty.
36+
37+ isEmpty "" == True
38+ isEmpty "the world" == False
39+-}
3540isEmpty : String -> Bool
3641isEmpty = Native.String.isEmpty
3742
@@ -63,7 +68,11 @@ append = Native.String.append
6368concat : [String] -> String
6469concat = Native.String.concat
6570
66−{-| Get the length of a string `(length "innumerable" == 11)` -}
71+{-| Get the length of a string.
72+
73+ length "innumerable" == 11
74+
75+-}
6776length : String -> Int
6877length = Native.String.length
6978
@@ -81,7 +90,10 @@ map = Native.String.map
8190filter : (Char -> Bool) -> String -> String
8291filter = Native.String.filter
8392
84−{-| Reverse a string. `(reverse "stressed" == "desserts")` -}
93+{-| Reverse a string.
94+
95+ reverse "stressed" == "desserts"
96+-}
8597reverse : String -> String
8698reverse = Native.String.reverse
8799
@@ -103,6 +115,8 @@ foldr = Native.String.foldr
103115
104116 split "," "cat,dog,cow" == ["cat","dog","cow"]
105117 split "/" "home/evan/Desktop/" == ["home","evan","Desktop"]
118+
119+Use `Regex.split` if you need something more flexible.
106120-}
107121split : String -> String -> [String]
108122split = Native.String.split
@@ -115,7 +129,10 @@ split = Native.String.split
115129join : String -> [String] -> String
116130join = Native.String.join
117131
118−{-| Repeat a string N times `(repeat 3 "ha" == "hahaha")` -}
132+{-| Repeat a string N times.
133+
134+ repeat 3 "ha" == "hahaha"
135+-}
119136repeat : Int -> String -> String
120137repeat = Native.String.repeat
121138
@@ -231,7 +248,7 @@ any = Native.String.any
231248
232249 all isDigit "90210" == True
233250 all isDigit "R2-D2" == False
234− any isDigit "heart" == False
251+ all isDigit "heart" == False
235252-}
236253all : (Char -> Bool) -> String -> Bool
237254all = Native.String.all
@@ -241,6 +258,8 @@ all = Native.String.all
241258 contains "the" "theory" == True
242259 contains "hat" "theory" == False
243260 contains "THE" "theory" == False
261+
262+Use `Regex.contains` if you need something more flexible.
244263-}
245264contains : String -> String -> Bool
246265contains = Native.String.contains
@@ -274,6 +293,14 @@ indexes = Native.String.indexes
274293indices : String -> String -> [Int]
275294indices = Native.String.indexes
276295
296+{-| Turn any kind of value into a string.
297+
298+ show 42 == "42"
299+ show [1,2] == "[1,2]"
300+-}
301+show : a -> String
302+show = Native.Show.show
303+
277304{-| Try to convert a string into an int, failing on improperly formatted strings.
278305
279306 toInt "123" == Just 123
libraries/Text.elm+157−45
@@ -1,99 +1,210 @@
11module Text where
2−
3−{-| Functions for displaying text
2+{-| A library for styling and displaying text. Whlie the `String` library
3+focuses on representing and manipulating strings of character strings, the
4+`Text` library focuses on how those strings should look on screen. It lets
5+you make text bold or italic, set the typeface, set the text size, etc.
46
57# Creating Text
68@docs toText
79
810# Creating Elements
9−@docs plainText, asText, text, centered, justified, righted
1011
11−# Formatting
12−@docs color, typeface, height, link
12+Each of the following functions places `Text` into a box. The function you use
13+determines the alignment of the text.
14+
15+@docs leftAligned, rightAligned, centered, justified
16+
17+# Links and Style
18+@docs link, Style, style, defaultStyle, Line
19+
20+# Convenience Functions
21+
22+There are two convenience functions for creating an `Element` which can be
23+useful when debugging or prototyping:
1324
14−# Simple Formatting
15−@docs monospace, bold, italic, underline, overline, strikeThrough
25+@docs plainText, asText
26+
27+There are also a bunch of functions to set parts of a `Style` individually:
28+
29+@docs typeface, monospace, height, color, bold, italic, line
1630
1731-}
1832
19−import open Basics
20−import Color (Color)
33+import Basics (..)
34+import String
35+import Color (Color, black)
2136import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)
22−import Maybe (Maybe)
37+import Maybe (Maybe, Nothing)
2338import JavaScript (JSString)
39+import Native.Show
2440import Native.Text
2541
2642data Text = Text
2743
28−{-| Convert a string into text which can be styled and displayed. -}
44+{-| Styles for lines on text. This allows you to add an underline, an overline,
45+or a strike out text:
46+
47+ line Under (toText "underline")
48+ line Over (toText "overline")
49+ line Through (toText "strike out")
50+-}
51+data Line = Under | Over | Through
52+
53+{-| Representation of all the ways you can style `Text`. If the `typeface` list
54+is empty or the `height` is `Nothing`, the users will fall back on their
55+browser's default settings. The following `Style` is black, 16 pixel tall,
56+underlined, and Times New Roman (assuming that typeface is available on the
57+user's computer):
58+
59+ { typeface = [ "Times New Roman", "serif" ]
60+ , height = Just 16
61+ , color = black
62+ , bold = False
63+ , italic = False
64+ , line = Just Under
65+ }
66+-}
67+type Style =
68+ { typeface : [String]
69+ , height : Maybe Float
70+ , color : Color
71+ , bold : Bool
72+ , italic : Bool
73+ , line : Maybe Line
74+ }
75+
76+{-| Plain black text. It uses the browsers default typeface and text height.
77+No decorations are used:
78+
79+ { typeface = []
80+ , height = Nothing
81+ , color = black
82+ , bold = False
83+ , italic = False
84+ , line = Nothing
85+ }
86+-}
87+defaultStyle : Style
88+defaultStyle =
89+ { typeface = []
90+ , height = Nothing
91+ , color = black
92+ , bold = False
93+ , italic = False
94+ , line = Nothing
95+ }
96+
97+{-| Convert a string into text which can be styled and displayed. To show the
98+string `"Hello World!"` on screen in italics, you could say:
99+
100+ main = leftAligned (italic (toText "Hello World!"))
101+-}
29102toText : String -> Text
30103toText = Native.Text.toText
31104
32−{-| Set the typeface of some text. The first argument should be a comma
33−separated listing of the desired typefaces:
105+{-| Set the style of some text. For example, if you design a `Style` called
106+`footerStyle` that is specifically for the bottom of your page, you could apply
107+it to text like this:
108+
109+ style footerStyle (toText "the old prince / 2007")
110+-}
111+style : Style -> Text -> Text
112+style = Native.Text.style
113+
114+{-| Provide a list of prefered typefaces for some text.
34115
35− "helvetica, arial, sans-serif"
116+ ["helvetica","arial","sans-serif"]
36117
37−Works the same as the CSS font-family property.
118+Not every browser has access to the same typefaces, so rendering will use the
119+first typeface in the list that is found on the user's computer. If there are
120+no matches, it will use their default typeface. This works the same as the CSS
121+font-family property.
38122-}
39−typeface : String -> Text -> Text
123+typeface : [String] -> Text -> Text
40124typeface = Native.Text.typeface
41125
42−{-| Switch to a monospace typeface. Good for code snippets. -}
126+{-| Switch to a monospace typeface. Good for code snippets.
127+
128+ monospace (toText "foldl (+) 0 [1,2,3]")
129+-}
43130monospace : Text -> Text
44131monospace = Native.Text.monospace
45132
46−{-| Create a link. -}
133+{-| Create a link by providing a URL and the text of the link:
134+
135+ link "http://elm-lang.org" (toText "Elm Website")
136+-}
47137link : String -> Text -> Text
48138link = Native.Text.link
49139
50−{-| Set the height of text in pixels. -}
140+{-| Set the height of some text:
141+
142+ height 40 (toText "Title")
143+-}
51144height : Float -> Text -> Text
52145height = Native.Text.height
53146
54−{-| Set the color of a string. -}
147+{-| Set the color of some text:
148+
149+ color red (toText "Red")
150+-}
55151color : Color -> Text -> Text
56152color = Native.Text.color
57153
58−{-| Make a string bold. -}
154+{-| Make text bold:
155+
156+ toText "sometimes you want " ++ bold (toText "emphasis")
157+-}
59158bold : Text -> Text
60159bold = Native.Text.bold
61160
62−{-| Italicize a string. -}
161+{-| Make text italic:
162+
163+ toText "make it " ++ italic (toText "important")
164+-}
63165italic : Text -> Text
64166italic = Native.Text.italic
65167
66−{-| Draw a line above a string. -}
67−overline : Text -> Text
68−overline = Native.Text.overline
168+{-| Put lines on text:
69169
70−{-| Underline a string. -}
71−underline : Text -> Text
72−underline = Native.Text.underline
170+ line Under (toText "underlined")
171+ line Over (toText "overlined")
172+ line Through (toText "strike out")
173+-}
174+line : Line -> Text -> Text
175+line = Native.Text.line
73176
74−{-| Draw a line through a string. -}
75−strikeThrough : Text -> Text
76−strikeThrough = Native.Text.strikeThrough
177+{-| `Text` is aligned along the left side of the text block. This is sometimes
178+known as *ragged right*.
179+-}
180+leftAligned : Text -> Element
181+leftAligned = Native.Text.leftAligned
77182
78−{-| Display justified, styled text. -}
79−justified : Text -> Element
80−justified = Native.Text.justified
183+{-| `Text` is aligned along the right side of the text block. This is sometimes
184+known as *ragged left*.
185+-}
186+rightAligned : Text -> Element
187+rightAligned = Native.Text.rightAligned
81188
82−{-| Display centered, styled text. -}
189+{-| `Text` is centered in the text block. There is equal spacing on either side
190+of a line of text.
191+-}
83192centered : Text -> Element
84193centered = Native.Text.centered
85194
86−{-| Display right justified, styled text. -}
87−righted : Text -> Element
88−righted = Native.Text.righted
195+{-| `Text` is aligned along the left and right sides of the text block. Word
196+spacing is adjusted to make this possible.
197+-}
198+justified : Text -> Element
199+justified = Native.Text.justified
89200
90−{-| Display styled text. -}
91−text : Text -> Element
92−text = Native.Text.text
201+{-| Display a string with no styling:
93202
94−{-| Display a plain string. -}
203+ plainText string = leftAligned (toText string)
204+-}
95205plainText : String -> Element
96−plainText = Native.Text.plainText
206+plainText str =
207+ leftAligned (toText str)
97208
98209{-| for internal use only -}
99210markdown : Element
@@ -102,9 +213,10 @@ markdown = Native.Text.markdown
102213{-| Convert anything to its textual representation and make it displayable in
103214the browser:
104215
105− asText == text . monospace . show
216+ asText value = text (monospace (show value))
106217
107218Excellent for debugging.
108219-}
109220asText : a -> Element
110−asText = Native.Text.asText
221+asText value =
222+ leftAligned (monospace (toText (Native.Show.show value)))
libraries/Time.elm+1−1
@@ -14,7 +14,7 @@ module Time where
1414
1515-}
1616
17−import open Basics
17+import Basics (..)
1818import Native.Time
1919import Signal (Signal)
2020
libraries/Trampoline.elmnew file+49
@@ -0,0 +1,49 @@
1+module Trampoline where
2+{-| A [trampoline](http://en.wikipedia.org/wiki/Tail-recursive_function#Through_trampolining)
3+makes it possible to recursively call a function without growing the stack.
4+
5+Popular JavaScript implementations do not perform any tail-call elimination, so
6+recursive functions can cause a stack overflow if they go to deep. Trampolines
7+permit unbounded recursion despite limitations in JavaScript.
8+
9+This strategy may create many intermediate closures, which is very expensive in
10+JavaScript, so use this library only when it is essential that you recurse deeply.
11+
12+# Trampolines
13+@docs trampoline, Trampoline
14+-}
15+
16+import Native.Trampoline
17+
18+{-| A way to build computations that may be deeply recursive. We will take an
19+example of a tail-recursive function and rewrite it in a way that lets us use
20+a trampoline:
21+
22+ length : [a] -> Int
23+ length list = length' 0 list
24+
25+ length' : Int -> [a] -> Int
26+ length' accum list =
27+ case list of
28+ [] -> accum
29+ hd::tl -> length' (accum+1) tl
30+
31+This finds the length of a list, but if the list is too long, it may cause a
32+stack overflow. We can rewrite it as follows:
33+
34+ length : [a] -> Int
35+ length list = trampoline (length' 0 list)
36+
37+ length' : Int -> [a] -> Trampoline Int
38+ length' accum list =
39+ case list of
40+ [] -> Done accum
41+ hd::tl -> Continue (\() -> length' (accum+1) tl)
42+
43+Now it uses a trampoline and can recurse without growing the stack!
44+-}
45+data Trampoline a = Done a | Continue (() -> Trampoline a)
46+
47+{-| Evaluate a trampolined value in constant space. -}
48+trampoline : Trampoline a -> a
49+trampoline = Native.Trampoline.trampoline
libraries/elm_dependencies.json+6−3
@@ -1,9 +1,9 @@
1−{ "version": "0.11"
1+{ "version": "0.12"
22, "summary": "Elm's standard libraries"
3−, "description": "The full set of standard libraries for Elm. This library is pegged to the version number of the compiler, so if you are using Elm 0.11, you should be using version 0.11 of the standard libraries."
3+, "description": "The full set of standard libraries for Elm. This library is pegged to the version number of the compiler, so if you are using Elm 0.12, you should be using version 0.12 of the standard libraries."
44, "license": "BSD3"
55, "repository": "http://github.com/evancz/Elm.git"
6−, "elm-version": "0.11"
6+, "elm-version": "0.12"
77, "dependencies": {}
88, "exposed-modules":
99 [ "Basics"
@@ -11,11 +11,13 @@
1111 , "Char"
1212 , "Color"
1313 , "Date"
14+ , "Debug"
1415 , "Dict"
1516 , "Either"
1617 , "Graphics.Element"
1718 , "Graphics.Collage"
1819 , "Graphics.Input"
20+ , "Graphics.Input.Field"
1921 , "Http"
2022 , "JavaScript"
2123 , "JavaScript.Experimental"
@@ -32,6 +34,7 @@
3234 , "Text"
3335 , "Time"
3436 , "Touch"
37+ , "Trampoline"
3538 , "Transform2D"
3639 , "WebSocket"
3740 , "Window"
runtime/HotSwap.js+2−2
@@ -5,8 +5,8 @@
55// structure.
66ElmRuntime.swap = function(from, to) {
77 function similar(nodeOld,nodeNew) {
8− idOkay = nodeOld.id === nodeNew.id;
9− lengthOkay = nodeOld.kids.length === nodeNew.kids.length;
8+ var idOkay = nodeOld.id === nodeNew.id;
9+ var lengthOkay = nodeOld.kids.length === nodeNew.kids.length;
1010 return idOkay && lengthOkay;
1111 }
1212 function swap(nodeOld,nodeNew) {
runtime/Init.js+1−1
@@ -91,7 +91,7 @@ function init(display, container, module, ports, moduleToReplace) {
9191 checkPorts(elm);
9292 } catch(e) {
9393 var directions = "<br/>&nbsp; &nbsp; Open the developer console for more details."
94− Module.main = Elm.Text.make(elm).text('<code>' + e.message + directions + '</code>');
94+ Module.main = Elm.Text.make(elm).leftAligned('<code>' + e.message + directions + '</code>');
9595 reportAnyErrors = function() { throw e; }
9696 }
9797 inputs = ElmRuntime.filterDeadInputs(inputs);
runtime/Render/Collage.js+1
@@ -254,6 +254,7 @@ function makeCanvas(w,h) {
254254function render(model) {
255255 var div = newElement('div');
256256 div.style.overflow = 'hidden';
257+ div.style.position = 'relative';
257258 update(div, model, model);
258259 return div;
259260}
runtime/Render/Element.js+71−18
@@ -7,10 +7,16 @@ var newElement = Utils.newElement, extract = Utils.extract,
77 addTransform = Utils.addTransform, removeTransform = Utils.removeTransform,
88 fromList = Utils.fromList, eq = Utils.eq;
99
10−function setProps(props, e) {
11− e.style.width = (props.width |0) + 'px';
12− e.style.height = (props.height|0) + 'px';
13− if (props.opacity !== 1) { e.style.opacity = props.opacity; }
10+function setProps(elem, e) {
11+ var props = elem.props;
12+ var element = elem.element;
13+ var width = props.width - (element.adjustWidth || 0);
14+ var height = props.height - (element.adjustHeight || 0);
15+ e.style.width = (width |0) + 'px';
16+ e.style.height = (height|0) + 'px';
17+ if (props.opacity !== 1) {
18+ e.style.opacity = props.opacity;
19+ }
1420 if (props.color.ctor === 'Just') {
1521 e.style.backgroundColor = extract(props.color._0);
1622 }
@@ -28,15 +34,30 @@ function setProps(props, e) {
2834 e.appendChild(a);
2935 }
3036 if (props.hover.ctor !== '_Tuple0') {
31− var overCount = 0;
37+ e.style.pointerEvents = 'auto';
38+ e.elm_hover_handler = props.hover;
39+ e.elm_hover_count = 0;
3240 e.addEventListener('mouseover', function() {
33− if (overCount++ > 0) return;
34− props.hover(true);
41+ if (e.elm_hover_count++ > 0) return;
42+ var handler = e.elm_hover_handler;
43+ if (handler !== null) {
44+ handler(true);
45+ }
3546 });
3647 e.addEventListener('mouseout', function(evt) {
3748 if (e.contains(evt.toElement || evt.relatedTarget)) return;
38− overCount = 0;
39− props.hover(false);
49+ e.elm_hover_count = 0;
50+ var handler = e.elm_hover_handler;
51+ if (handler !== null) {
52+ handler(false);
53+ }
54+ });
55+ }
56+ if (props.click.ctor !== '_Tuple0') {
57+ e.style.pointerEvents = 'auto';
58+ e.elm_click_handler = props.click;
59+ e.addEventListener('click', function() {
60+ e.elm_click_handler(Tuple0);
4061 });
4162 }
4263 return e;
@@ -99,6 +120,8 @@ function goDown(e) { return e }
99120function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e; }
100121function flowWith(f, array) {
101122 var container = newElement('div');
123+ if (f == goIn) container.style.pointerEvents = 'none';
124+
102125 for (var i = array.length; i--; ) {
103126 container.appendChild(f(render(array[i])));
104127 }
@@ -126,7 +149,12 @@ function toPos(pos) {
126149
127150// must clear right, left, top, bottom, and transform
128151// before calling this function
129−function setPos(pos,w,h,e) {
152+function setPos(pos,elem,e) {
153+ var element = elem.element;
154+ var props = elem.props;
155+ var w = props.width + (element.adjustWidth ? element.adjustWidth : 0);
156+ var h = props.height + (element.adjustHeight ? element.adjustHeight : 0);
157+
130158 e.style.position = 'absolute';
131159 e.style.margin = 'auto';
132160 var transform = '';
@@ -146,7 +174,7 @@ function setPos(pos,w,h,e) {
146174
147175function container(pos,elem) {
148176 var e = render(elem);
149− setPos(pos, elem.props.width, elem.props.height, e);
177+ setPos(pos, elem, e);
150178 var div = newElement('div');
151179 div.style.position = 'relative';
152180 div.style.overflow = 'hidden';
@@ -183,7 +211,7 @@ function rawHtml(elem) {
183211 return div;
184212}
185213
186−function render(elem) { return setProps(elem.props, makeElement(elem)); }
214+function render(elem) { return setProps(elem, makeElement(elem)); }
187215function makeElement(e) {
188216 var elem = e.element;
189217 switch(elem.ctor) {
@@ -209,7 +237,9 @@ function update(node, curr, next) {
209237 case "RawHtml":
210238 // only markdown blocks have guids, so this must be a text block
211239 if (nextE.guid === null) {
212− node.innerHTML = nextE.html;
240+ if(currE.html.valueOf() !== nextE.html.valueOf()) {
241+ node.innerHTML = nextE.html;
242+ }
213243 break;
214244 }
215245 if (nextE.guid !== currE.guid) {
@@ -275,7 +305,7 @@ function update(node, curr, next) {
275305 break;
276306 case "Container":
277307 update(node.firstChild, currE._1, nextE._1);
278− setPos(nextE._0, nextE._1.props.width, nextE._1.props.height, node.firstChild);
308+ setPos(nextE._0, nextE._1, node.firstChild);
279309 break;
280310 case "Custom":
281311 if (currE.type === nextE.type) {
@@ -289,10 +319,19 @@ function update(node, curr, next) {
289319}
290320
291321function updateProps(node, curr, next) {
292− var props = next.props, currP = curr.props, e = node;
293− if (props.width !== currP.width) e.style.width = (props.width |0) + 'px';
294− if (props.height !== currP.height) e.style.height = (props.height|0) + 'px';
295− if (props.opacity !== 1 && props.opacity !== currP.opacity) {
322+ var props = next.props;
323+ var currP = curr.props;
324+ var e = node;
325+ var element = next.element;
326+ var width = props.width - (element.adjustWidth || 0);
327+ var height = props.height - (element.adjustHeight || 0);
328+ if (width !== currP.width) {
329+ e.style.width = (width|0) + 'px';
330+ }
331+ if (height !== currP.height) {
332+ e.style.height = (height|0) + 'px';
333+ }
334+ if (props.opacity !== currP.opacity) {
296335 e.style.opacity = props.opacity;
297336 }
298337 var nextColor = (props.color.ctor === 'Just' ?
@@ -317,6 +356,20 @@ function updateProps(node, curr, next) {
317356 node.lastNode.href = props.href;
318357 }
319358 }
359+
360+ // update hover handlers
361+ if (props.hover.ctor !== '_Tuple0') {
362+ e.elm_hover_handler = props.hover;
363+ } else if (e.elm_hover_handler) {
364+ e.elm_hover_handler = null;
365+ }
366+
367+ // update click handlers
368+ if (props.click.ctor !== '_Tuple0') {
369+ e.elm_click_handler = props.click;
370+ } else if (e.elm_click_handler) {
371+ e.elm_click_handler = null;
372+ }
320373}
321374
322375return { render:render, update:update };
server/elm-server.cabal+1−1
@@ -10,7 +10,7 @@ License-file: LICENSE
1010
1111Author: Evan Czaplicki
1212Maintainer: info@elm-lang.org
13−Copyright: Copyright: (c) 2011-2013 Evan Czaplicki
13+Copyright: Copyright: (c) 2011-2014 Evan Czaplicki
1414
1515Category: Compiler, Language
1616
tests/Tests/Property.hs+17−16
@@ -10,7 +10,7 @@ import Text.Parsec.Combinator (eof)
1010import Text.PrettyPrint as P
1111
1212import SourceSyntax.Literal as Lit
13−import SourceSyntax.Pattern as Pat
13+import qualified SourceSyntax.Pattern as P
1414import SourceSyntax.PrettyPrint (Pretty, pretty)
1515import Parse.Helpers (IParser, iParse)
1616import Parse.Literal (literal)
@@ -31,24 +31,25 @@ propertyTests =
3131 where
3232 -- This test was autogenerated from the Pattern test and should be
3333 -- left in all its ugly glory.
34− longPat = Pat.PData "I" [ Pat.PLiteral (Lit.Chr '+')
35− , Pat.PRecord [
36− "q7yclkcm7k_ikstrczv_"
37− , "wQRv6gKsvvkjw4b5F"
38− ,"c9'eFfhk9FTvsMnwF_D"
39− ,"yqxhEkHvRFwZ"
40− ,"o"
41− ,"nbUlCn3y3NnkVoxhW"
42− ,"iJ0MNy3KZ_lrs"
43− ,"ug"
44− ,"sHHsX"
45− ,"mRKs9d"
46− ,"o2KiCX5'ZRzHJfRi8" ]
47− , Pat.PVar "su'BrrbPUK6I33Eq" ]
34+ longPat = P.Data "I" [ P.Literal (Lit.Chr '+')
35+ , P.Record
36+ [ "q7yclkcm7k_ikstrczv_"
37+ , "wQRv6gKsvvkjw4b5F"
38+ ,"c9'eFfhk9FTvsMnwF_D"
39+ ,"yqxhEkHvRFwZ"
40+ ,"o"
41+ ,"nbUlCn3y3NnkVoxhW"
42+ ,"iJ0MNy3KZ_lrs"
43+ ,"ug"
44+ ,"sHHsX"
45+ ,"mRKs9d"
46+ ,"o2KiCX5'ZRzHJfRi8" ]
47+ , P.Var "su'BrrbPUK6I33Eq"
48+ ]
4849
4950prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool
5051prop_parse_print p x =
5152 either (const False) (== x) . parse_print p $ x
5253
5354parse_print :: (Pretty a) => IParser a -> a -> Either String a
54−parse_print p = either (Left . show) (Right) . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty
55+parse_print p = either (Left . show) Right . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty
tests/Tests/Property/Arbitrary.hs+91−76
@@ -8,98 +8,112 @@ import Test.QuickCheck.Gen
88import qualified Data.Set as Set
99import qualified Parse.Helpers (reserveds)
1010
11−import SourceSyntax.Literal
12−import SourceSyntax.Pattern
13−import SourceSyntax.Type hiding (listOf)
14−
15−instance Arbitrary Literal where
16− arbitrary = oneof [ IntNum <$> arbitrary
17− , FloatNum <$> (arbitrary `suchThat` noE)
18− , Chr <$> arbitrary
19− -- This is too permissive
20− , Str <$> arbitrary
21− -- Booleans aren't actually source syntax
22− -- , Boolean <$> arbitrary
23− ]
24− shrink l = case l of
25− IntNum n -> IntNum <$> shrink n
26− FloatNum f -> FloatNum <$> (filter noE . shrink $ f)
27− Chr c -> Chr <$> shrink c
28− Str s -> Str <$> shrink s
29− Boolean b -> Boolean <$> shrink b
11+import qualified SourceSyntax.Literal as L
12+import qualified SourceSyntax.Pattern as P
13+import qualified SourceSyntax.Type as T
14+
15+instance Arbitrary L.Literal where
16+ arbitrary =
17+ oneof
18+ [ L.IntNum <$> arbitrary
19+ , L.FloatNum <$> (arbitrary `suchThat` noE)
20+ , L.Chr <$> arbitrary
21+ -- This is too permissive
22+ , L.Str <$> arbitrary
23+ -- Booleans aren't actually source syntax
24+ -- , Boolean <$> arbitrary
25+ ]
26+
27+ shrink lit =
28+ case lit of
29+ L.IntNum n -> L.IntNum <$> shrink n
30+ L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)
31+ L.Chr c -> L.Chr <$> shrink c
32+ L.Str s -> L.Str <$> shrink s
33+ L.Boolean b -> L.Boolean <$> shrink b
3034
3135noE :: Double -> Bool
3236noE = notElem 'e' . show
3337
38+genVector :: Int -> (Int -> Gen a) -> Gen [a]
39+genVector n generator = do
40+ len <- choose (0,n)
41+ let m = n `div` (len + 1)
42+ vectorOf len $ generator m
3443
35−instance Arbitrary Pattern where
44+instance Arbitrary P.Pattern where
3645 arbitrary = sized pat
37− where pat :: Int -> Gen Pattern
38− pat n = oneof [ pure PAnything
39− , PVar <$> lowVar
40− , PRecord <$> (listOf1 lowVar)
41− , PLiteral <$> arbitrary
42− , PAlias <$> lowVar <*> pat (n-1)
43− , PData <$> capVar <*> sizedPats
44− ]
45− where sizedPats = do
46− len <- choose (0,n)
47− let m = n `div` (len + 1)
48− vectorOf len $ pat m
49−
50− shrink pat = case pat of
51− PAnything -> []
52− PVar v -> PVar <$> shrinkWHead v
53− PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)
54− PLiteral l -> PLiteral <$> shrink l
55− PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
56− PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
46+ where
47+ pat :: Int -> Gen P.Pattern
48+ pat n =
49+ oneof
50+ [ pure P.Anything
51+ , P.Var <$> lowVar
52+ , P.Record <$> (listOf1 lowVar)
53+ , P.Literal <$> arbitrary
54+ , P.Alias <$> lowVar <*> pat (n-1)
55+ , P.Data <$> capVar <*> genVector n pat
56+ ]
57+
58+ shrink pat =
59+ case pat of
60+ P.Anything -> []
61+ P.Var v -> P.Var <$> shrinkWHead v
62+ P.Literal l -> P.Literal <$> shrink l
63+ P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)
64+ P.Data s ps -> ps ++ (P.Data <$> shrinkWHead s <*> shrink ps)
65+ P.Record fs ->
66+ P.Record <$> filter (all notNull) (filter notNull (shrink fs))
67+ where
68+ notNull = not . null
5769
5870shrinkWHead :: Arbitrary a => [a] -> [[a]]
5971shrinkWHead [] = error "Should be nonempty"
6072shrinkWHead (x:xs) = (x:) <$> shrink xs
6173
62−instance Arbitrary Type where
74+instance Arbitrary T.Type where
6375 arbitrary = sized tipe
64− where tipe :: Int -> Gen Type
65− tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
66− , Var <$> lowVar
67− , Data <$> capVar <*> depthTipes
68− , Record <$> fields <*> pure Nothing
69− , Record <$> fields1 <*> (Just <$> lowVar)
70− ]
71− where depthTipe = choose (0,n) >>= tipe
72− depthTipes = do
73− len <- choose (0,n)
74− let m = n `div` (len + 1)
75− vectorOf len $ tipe m
76−
77− field = (,) <$> lowVar <*> depthTipe
78− fields = do
79− len <- choose (0,n)
80− let m = n `div` (len + 1)
81− vectorOf len $ (,) <$> lowVar <*> tipe m
82− fields1 = (:) <$> field <*> fields
83−
84− shrink tipe = case tipe of
85− Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t)
86− Var _ -> []
87− Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts)
88− Record fs t -> map snd fs ++ case t of
89− Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing
90− Just _ ->
91− do
92− fields <- filter (not . null) $ shrinkList shrinkField fs
93− return $ Record fields t
94− where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
76+ where
77+ tipe :: Int -> Gen T.Type
78+ tipe n =
79+ let depthTipe = tipe =<< choose (0,n)
80+ field = (,) <$> lowVar <*> depthTipe
81+ fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)
82+ fields1 = (:) <$> field <*> fields
83+ in
84+ oneof
85+ [ T.Lambda <$> depthTipe <*> depthTipe
86+ , T.Var <$> lowVar
87+ , T.Data <$> capVar <*> genVector n tipe
88+ , T.Record <$> fields <*> pure Nothing
89+ , T.Record <$> fields1 <*> (Just <$> lowVar)
90+ ]
91+
92+ shrink tipe =
93+ case tipe of
94+ T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)
95+ T.Var _ -> []
96+ T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)
97+ T.Record fs t -> map snd fs ++ record
98+ where
99+ record =
100+ case t of
101+ Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing
102+ Just _ ->
103+ do fields <- filter (not . null) $ shrinkList shrinkField fs
104+ return $ T.Record fields t
105+
106+ shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
95107
96108lowVar :: Gen String
97109lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
98− where lower = elements ['a'..'z']
110+ where
111+ lower = elements ['a'..'z']
99112
100113capVar :: Gen String
101114capVar = notReserved $ (:) <$> upper <*> listOf varLetter
102− where upper = elements ['A'..'Z']
115+ where
116+ upper = elements ['A'..'Z']
103117
104118varLetter :: Gen Char
105119varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
@@ -109,5 +123,6 @@ notReserved = flip exceptFor Parse.Helpers.reserveds
109123
110124exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
111125exceptFor g xs = g `suchThat` notAnX
112− where notAnX = flip Set.notMember xset
113− xset = Set.fromList xs
126+ where
127+ notAnX = flip Set.notMember xset
128+ xset = Set.fromList xs