on master help sign in
Merge remote-tracking branch 'evan/dev' into webgl

Merged by johnpmayer Conflicts: compiler/Parse/Expression.hs compiler/Parse/Helpers.hs compiler/SourceSyntax/Expression.hs compiler/Type/Constrain/Expression.hs

commit513141d44e9c8184bf7385551629b7659be31fd0 authorJohn P Mayer Jr <john.p.mayer.jr@gmail.com> dateTue 25 Feb 2014, 21:27 (13 years ago) parentc3462d21b098b9
70 files changed+1771−1438
Elm.cabal+9−8 Setup.hs+2−1 changelog.txt+28−3 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+54−48 compiler/Generate/JavaScript/Ports.hs+22−16 compiler/Generate/Noscript.hs−68 compiler/Metadata/Prelude.hs+3−3 compiler/Parse/Binop.hs+17−16 compiler/Parse/Expression.hs+67−66 compiler/Parse/Helpers.hs+16−12 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/Literal.hs+4−2 compiler/SourceSyntax/Location.hs−58 compiler/SourceSyntax/Module.hs+6−6 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+27−21 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+19−18 compiler/Transform/SortDefinitions.hs+18−17 compiler/Transform/Substitute.hs+7−5 compiler/Type/Constrain/Declaration.hs+23−23 compiler/Type/Constrain/Expression.hs+40−38 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/Debug.elm+17 libraries/Dict.elm+2−2 libraries/Either.elm+26−4 libraries/Graphics/Collage.elm+1−1 libraries/Graphics/Element.elm+7−4 libraries/Graphics/Input.elm+185−156 libraries/Http.elm+1−1 libraries/Json.elm+1−1 libraries/List.elm+2−2 libraries/Maybe.elm+21−3 libraries/Native/Debug.js+22 libraries/Native/Graphics/Input.js+363−299 libraries/Native/Regex.js+10−19 libraries/Native/Trampoline.js+4−2 libraries/Regex.elm+49−56 libraries/String.elm+5−1 libraries/Text.elm+1−1 libraries/Time.elm+1−1 libraries/elm_dependencies.json+2 runtime/Render/Collage.js+1 runtime/Render/Element.js+39−6 tests/Tests/Property.hs+17−16 tests/Tests/Property/Arbitrary.hs+91−76
Elm.cabal+9−8
@@ -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,
@@ -120,19 +120,19 @@ Executable elm
120120 Main-is: Compiler.hs
121121 ghc-options: -threaded -O2
122122 Hs-Source-Dirs: compiler
123− other-modules: SourceSyntax.Declaration,
123+ other-modules: SourceSyntax.Annotation,
124+ SourceSyntax.Declaration,
124125 SourceSyntax.Expression,
125126 SourceSyntax.Helpers,
126127 SourceSyntax.Literal,
127− SourceSyntax.Location,
128128 SourceSyntax.Module,
129129 SourceSyntax.Pattern,
130130 SourceSyntax.PrettyPrint,
131131 SourceSyntax.Type,
132+ SourceSyntax.Variable,
132133 Generate.JavaScript,
133134 Generate.JavaScript.Helpers,
134135 Generate.JavaScript.Ports,
135− Generate.Noscript,
136136 Generate.Markdown,
137137 Generate.Html,
138138 Generate.Cases,
@@ -202,15 +202,16 @@ Executable elm
202202Executable elm-doc
203203 Main-is: Docs.hs
204204 Hs-Source-Dirs: compiler
205− other-modules: SourceSyntax.Declaration,
205+ other-modules: SourceSyntax.Annotation,
206+ SourceSyntax.Declaration,
206207 SourceSyntax.Expression,
207208 SourceSyntax.Helpers,
208209 SourceSyntax.Literal,
209− SourceSyntax.Location,
210210 SourceSyntax.Module,
211211 SourceSyntax.Pattern,
212212 SourceSyntax.PrettyPrint,
213213 SourceSyntax.Type,
214+ SourceSyntax.Variable,
214215 Parse.Binop,
215216 Parse.Declaration,
216217 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+28−3
@@ -1,10 +1,35 @@
11
2+## next
3+
4+Breaking Changes:
5+
6+ * Overhaul Graphics.Input library (inspired by @seliopou and Jeff Smits)
7+ * Overhaul Regex library (inspired by Attila Gazso)
8+ * Change syntax for "import open List" to "import List (..)"
9+ * Improved JSON format for types generated by elm-doc
10+ * Remove problematic Mouse.isClicked signal
11+ * Revise the semantics of keepWhen and dropWhen to only update when
12+ the filtered signal changes (thanks Max New and Janis Voigtländer)
13+
14+Improvements:
15+
16+ * Add Trampoline library (thanks to @maxsnew and @timthelion)
17+ * Add Debug library (inspired by @timthelion)
18+ * Drastically improved performance on markdown parsing (thanks to @Dandandan)
19+ * Add Date.fromTime function
20+ * Use pointer-events to detect hovers on layered elements (thanks to @Xashili)
21+ * Fix bugs in Bitwise library
22+ * Fix bug when exporting Maybe values through ports
23+
224## 0.11
325
4− * Lazy and Lazy.Stream (thanks to Max New)
5− * sortBy, sortWith (thanks to Max Goldstein)
26+ * Ports, a new FFI that is more general and much nicer to use
27+ * Basic compiler tests (thanks to Max New)
28+
29+## 0.10.1
30+
31+ * sort, sortBy, sortWith (thanks to Max Goldstein)
632 * elm-repl
7− * Markdown interpolation
833 * Bitwise library
934 * Regex library
1035 * Improve Transform2D library (thanks to Michael Søndergaard)
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+54−48
@@ -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 $ ref x
5759 Literal lit -> return $ literal lit
5860
5961 Range lo hi ->
@@ -93,9 +95,9 @@ expression (L span expr) =
9395 Map.toList . Map.filter (not . null) $ Map.map tail fs
9496 visible fs = map (first prop) . Map.toList $ Map.map head fs
9597
96− Binop op e1 e2 -> binop span op e1 e2
98+ Binop op e1 e2 -> binop region op e1 e2
9799
98− Lambda p e@(L s _) ->
100+ Lambda p e@(A ann _) ->
99101 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
100102 body' <- expression body
101103 return $ case length args < 2 || length args > 9 of
@@ -104,13 +106,14 @@ expression (L span expr) =
104106 where
105107 depattern (args, body) pattern =
106108 case pattern of
107− PVar x -> return (args ++ [x], body)
109+ P.Var x -> return (args ++ [x], body)
108110 _ -> do arg <- Case.newVar
109− return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
111+ return ( args ++ [arg]
112+ , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))
110113
111114 (patterns, innerBody) = collect [p] e
112115
113− collect patterns lexpr@(L _ expr) =
116+ collect patterns lexpr@(A _ expr) =
114117 case expr of
115118 Lambda p e -> collect (p:patterns) e
116119 _ -> (patterns, lexpr)
@@ -127,7 +130,7 @@ expression (L span expr) =
127130 (func, args) = getArgs e1 [e2]
128131 getArgs func args =
129132 case func of
130− (L _ (App f arg)) -> getArgs f (arg : args)
133+ (A _ (App f arg)) -> getArgs f (arg : args)
131134 _ -> (func, args)
132135
133136 Let defs e ->
@@ -139,9 +142,9 @@ expression (L span expr) =
139142 MultiIf branches ->
140143 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
141144 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) ])
145+ (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
146+ (A _ (Literal (Boolean True)), _) -> safeIfs branches'
147+ _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
145148 where
146149 safeIfs branches = ifs (init branches) (snd (last branches))
147150 ifs branches finally = foldr iff finally branches
@@ -151,10 +154,12 @@ expression (L span expr) =
151154 do (tempVar,initialMatch) <- Case.toMatch cases
152155 (revisedMatch, stmt) <-
153156 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
157+ A _ (Var (V.Raw x)) ->
158+ return (Case.matchSubst [(tempVar,x)] initialMatch, [])
159+ _ ->
160+ do e' <- expression e
161+ return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
162+ match' <- match region revisedMatch
158163 return (function [] (stmt ++ match') `call` [])
159164
160165 ExplicitList es ->
@@ -187,28 +192,28 @@ expression (L span expr) =
187192 [ string name, Port.outgoing tipe, value' ]
188193
189194definition :: Def -> State Int [Statement ()]
190−definition (Definition pattern expr@(L span _) _) = do
195+definition (Definition pattern expr@(A region _) _) = do
191196 expr' <- expression expr
192197 let assign x = varDecl x expr'
193198 case pattern of
194− PVar x
199+ P.Var x
195200 | Help.isOp x ->
196201 let op = LBracket () (ref "_op") (string x) in
197202 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
198203 | otherwise ->
199204 return [ VarDeclStmt () [ assign x ] ]
200205
201− PRecord fields ->
206+ P.Record fields ->
202207 let setField f = varDecl f (dotSep ["$",f]) in
203208 return [ VarDeclStmt () (assign "$" : map setField fields) ]
204209
205− PData name patterns | vars /= Nothing ->
210+ P.Data name patterns | vars /= Nothing ->
206211 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
207212 where
208213 vars = getVars patterns
209214 getVars patterns =
210215 case patterns of
211− PVar x : rest -> (x:) `fmap` getVars rest
216+ P.Var x : rest -> (x:) `fmap` getVars rest
212217 [] -> Just []
213218 _ -> Nothing
214219
@@ -219,23 +224,23 @@ definition (Definition pattern expr@(L span _) _) = do
219224
220225 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
221226 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
222− exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
227+ exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
223228
224229 _ ->
225230 do defs' <- concat <$> mapM toDef vars
226231 return (VarDeclStmt () [assign "$"] : defs')
227232 where
228− vars = Set.toList $ Pattern.boundVars pattern
229− mkVar = L span . Var
230− toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
231− in definition $ Definition (PVar y) expr Nothing
233+ vars = P.boundVarList pattern
234+ mkVar = A region . rawVar
235+ toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
236+ in definition $ Definition (P.Var y) expr Nothing
232237
233−match :: SrcSpan -> Case.Match -> State Int [Statement ()]
234−match span mtch =
238+match :: Region -> Case.Match -> State Int [Statement ()]
239+match region mtch =
235240 case mtch of
236241 Case.Match name clauses mtch' ->
237− do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
238− mtch'' <- match span mtch'
242+ do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
243+ mtch'' <- match region mtch'
239244 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
240245 where
241246 isLiteral p = case p of
@@ -247,13 +252,13 @@ match span mtch =
247252 | otherwise = e
248253
249254 Case.Fail ->
250− return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
255+ return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
251256
252257 Case.Break -> return [BreakStmt () Nothing]
253258 Case.Other e ->
254259 do e' <- expression e
255260 return [ ret e' ]
256− Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
261+ Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
257262 where
258263 dropEnd acc [] = acc
259264 dropEnd acc (m:ms) =
@@ -261,9 +266,9 @@ match span mtch =
261266 Case.Other _ -> acc ++ [m]
262267 _ -> dropEnd (acc ++ [m]) ms
263268
264−clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
265−clause span variable (Case.Clause value vars mtch) =
266− (,) 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)
267272 where
268273 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
269274 (isChar, pattern) =
@@ -276,8 +281,8 @@ clause span variable (Case.Clause value vars mtch) =
276281 [] -> name
277282 is -> drop (last is + 1) name
278283
279−flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
280−flattenLets defs lexpr@(L _ expr) =
284+flattenLets :: [Def] -> Expr -> ([Def], Expr)
285+flattenLets defs lexpr@(A _ expr) =
281286 case expr of
282287 Let ds body -> flattenLets (defs ++ ds) body
283288 _ -> (defs, lexpr)
@@ -291,7 +296,8 @@ generate unsafeModule =
291296 thisModule = dotSep ("_elm" : names modul ++ ["values"])
292297 programStmts =
293298 concat
294− [ setup (Just "_elm") (names modul ++ ["values"])
299+ [ [ ExprStmt () $ string "use strict" ]
300+ , setup (Just "_elm") (names modul ++ ["values"])
295301 , [ IfSingleStmt () thisModule (ret thisModule) ]
296302 , [ internalImports (List.intercalate "." (names modul)) ]
297303 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
@@ -324,8 +330,8 @@ generate unsafeModule =
324330 Nothing -> tail . init $ List.inits path
325331 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
326332
327−binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
328−binop span op e1 e2 =
333+binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
334+binop region op e1 e2 =
329335 case op of
330336 "Basics.." ->
331337 do es <- mapM expression (e1 : collect [] e2)
@@ -338,7 +344,7 @@ binop span op e1 e2 =
338344 do e1' <- expression e1
339345 e2' <- expression e2
340346 return $ obj "_L.append" `call` [e1', e2']
341− "::" -> expression (L span (Data "::" [e1,e2]))
347+ "::" -> expression (A region (Data "::" [e1,e2]))
342348 _ ->
343349 do e1' <- expression e1
344350 e2' <- expression e2
@@ -348,7 +354,7 @@ binop span op e1 e2 =
348354 where
349355 collect es e =
350356 case e of
351− L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
357+ A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
352358 _ -> es ++ [e]
353359
354360 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
compiler/Generate/JavaScript/Ports.hs+22−16
@@ -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
@@ -114,14 +118,16 @@ out tipe x =
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+3−3
@@ -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
@@ -30,8 +30,8 @@ prelude = string : text ++ map (\n -> (n, Hiding [])) modules
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+67−66
@@ -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' <|> glShader' <|> braces (try range <|> ExplicitList <$> commaSep expr)
4848 where
4949 range = do
@@ -72,86 +72,87 @@ listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> co
7272 string "}}"
7373 return (span uid (length exprs), exprs ++ [e])
7474
75−parensTerm :: IParser LParseExpr
75+parensTerm :: IParser ParseExpr
7676parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
7777 where
7878 opFn = do
7979 (start, op, end) <- located anyOp
80− let loc = Location.at start end
81− return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
82− Binop op (loc $ Var "x") (loc $ Var "y")
80+ let loc = Annotation.at start end
81+ return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $
82+ Binop op (loc $ rawVar "x") (loc $ rawVar "y")
8383
8484 tupleFn = do
8585 let comma = char ',' <?> "comma ','"
8686 (start, commas, end) <- located (comma >> many (whitespace >> comma))
8787 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
88− loc = Location.at start end
88+ loc = Annotation.at start end
8989 return $ foldr (\x e -> loc $ Lambda x e)
90− (loc . tuple $ map (loc . Var) vars) (map PVar vars)
90+ (loc . tuple $ map (loc . rawVar) vars) (map P.Var vars)
9191
9292 parened = do
9393 (start, es, end) <- located (commaSep expr)
9494 return $ case es of
9595 [e] -> e
96− _ -> Location.at start end (tuple es)
96+ _ -> Annotation.at start end (tuple es)
9797
98−recordTerm :: IParser LParseExpr
98+recordTerm :: IParser ParseExpr
9999recordTerm = brackets $ choice [ misc, addLocation record ]
100− where field = do
101− label <- rLabel
102− patterns <- spacePrefix Pattern.term
103− padded equals
104− body <- expr
105− return (label, makeFunction patterns body)
100+ where
101+ field = do
102+ label <- rLabel
103+ patterns <- spacePrefix Pattern.term
104+ padded equals
105+ body <- expr
106+ return (label, makeFunction patterns body)
106107
107− record = Record <$> commaSep field
108+ record = Record <$> commaSep field
108109
109− change = do
110− lbl <- rLabel
111− padded (string "<-")
112− (,) lbl <$> expr
110+ change = do
111+ lbl <- rLabel
112+ padded (string "<-")
113+ (,) lbl <$> expr
113114
114− remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
115+ remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
115116
116− insert r = addLocation $ do
117− string "|" >> whitespace
118− Insert r <$> rLabel <*> (padded equals >> expr)
117+ insert r = addLocation $ do
118+ string "|" >> whitespace
119+ Insert r <$> rLabel <*> (padded equals >> expr)
119120
120− modify r = addLocation
121− (string "|" >> whitespace >> Modify r <$> commaSep1 change)
121+ modify r =
122+ addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)
122123
123− misc = try $ do
124− record <- addLocation (Var <$> rLabel)
125− opt <- padded (optionMaybe (remove record))
126− case opt of
127− Just e -> try (insert e) <|> return e
128− Nothing -> try (insert record) <|> try (modify record)
124+ misc = try $ do
125+ record <- addLocation (rawVar <$> rLabel)
126+ opt <- padded (optionMaybe (remove record))
127+ case opt of
128+ Just e -> try (insert e) <|> return e
129+ Nothing -> try (insert record) <|> try (modify record)
129130
130131
131−term :: IParser LParseExpr
132+term :: IParser ParseExpr
132133term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
133134 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
134135 <?> "basic term (4, x, 'c', etc.)"
135136
136137-------- Applications --------
137138
138−appExpr :: IParser LParseExpr
139+appExpr :: IParser ParseExpr
139140appExpr = do
140141 t <- term
141142 ts <- constrainedSpacePrefix term $ \str ->
142143 if null str then notFollowedBy (char '-') else return ()
143144 return $ case ts of
144145 [] -> t
145− _ -> foldl' (\f x -> Location.merge f x $ App f x) t ts
146+ _ -> foldl' (\f x -> Annotation.merge f x $ App f x) t ts
146147
147148-------- Normal Expressions --------
148149
149−binaryExpr :: IParser LParseExpr
150+binaryExpr :: IParser ParseExpr
150151binaryExpr = binops appExpr lastExpr anyOp
151152 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
152153 <|> lambdaExpr
153154
154−ifExpr :: IParser ParseExpr
155+ifExpr :: IParser ParseExpr'
155156ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
156157 where
157158 normal = do
@@ -161,13 +162,13 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
161162 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
162163 elseBranch <- expr
163164 return $ MultiIf [(bool, thenBranch),
164− (Location.sameAs elseBranch (Literal . Literal.Boolean $ True), elseBranch)]
165+ (Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]
165166 multiIf = MultiIf <$> spaceSep1 iff
166167 where iff = do string "|" ; whitespace
167168 b <- expr ; padded arrow
168169 (,) b <$> expr
169170
170−lambdaExpr :: IParser LParseExpr
171+lambdaExpr :: IParser ParseExpr
171172lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
172173 whitespace
173174 args <- spaceSep1 Pattern.term
@@ -178,14 +179,14 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
178179defSet :: IParser [ParseDef]
179180defSet = block (do d <- def ; whitespace ; return d)
180181
181−letExpr :: IParser ParseExpr
182+letExpr :: IParser ParseExpr'
182183letExpr = do
183184 reserved "let" ; whitespace
184185 defs <- defSet
185186 padded (reserved "in")
186187 Let defs <$> expr
187188
188−caseExpr :: IParser ParseExpr
189+caseExpr :: IParser ParseExpr'
189190caseExpr = do
190191 reserved "case"; e <- padded expr; reserved "of"; whitespace
191192 Case e <$> (with <|> without)
@@ -195,35 +196,35 @@ caseExpr = do
195196 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
196197 without = block (do c <- case_ ; whitespace ; return c)
197198
198−expr :: IParser LParseExpr
199+expr :: IParser ParseExpr
199200expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
200201 <|> lambdaExpr
201202 <|> binaryExpr
202203 <?> "an expression"
203204
204−defStart :: IParser [Pattern]
205+defStart :: IParser [P.Pattern]
205206defStart =
206207 choice [ do p1 <- try Pattern.term
207208 infics p1 <|> func p1
208− , func =<< (PVar <$> parens symOp)
209+ , func =<< (P.Var <$> parens symOp)
209210 , (:[]) <$> Pattern.expr
210211 ] <?> "the definition of a variable (x = ...)"
211212 where
212213 func pattern =
213214 case pattern of
214− PVar _ -> (pattern:) <$> spacePrefix Pattern.term
215+ P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
215216 _ -> do try (lookAhead (whitespace >> string "="))
216217 return [pattern]
217218
218219 infics p1 = do
219220 o:p <- try (whitespace >> anyOp)
220221 p2 <- (whitespace >> Pattern.term)
221− return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
222− else [ PVar (o:p), p1, p2 ]
222+ return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
223+ else [ P.Var (o:p), p1, p2 ]
223224
224−makeFunction :: [Pattern] -> LParseExpr -> LParseExpr
225−makeFunction args body@(L s _) =
226− foldr (\arg body' -> L s $ Lambda arg body') body args
225+makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr
226+makeFunction args body@(A ann _) =
227+ foldr (\arg body' -> A ann $ Lambda arg body') body args
227228
228229definition :: IParser ParseDef
229230definition = withPos $ do
compiler/Parse/Helpers.hs+16−12
@@ -14,12 +14,13 @@ import Text.Parsec hiding (newline,spaces,State)
1414import Text.Parsec.Indent
1515import qualified Text.Parsec.Token as T
1616
17+import SourceSyntax.Annotation as Annotation
18+import SourceSyntax.Declaration (Assoc)
19+import SourceSyntax.Expression
1720import SourceSyntax.Helpers as Help
1821import SourceSyntax.Literal as Literal
19−import SourceSyntax.Location as Location
20−import SourceSyntax.Expression
2122import SourceSyntax.PrettyPrint
22−import SourceSyntax.Declaration (Assoc)
23+import SourceSyntax.Variable as Variable
2324
2425reserveds = [ "if", "then", "else"
2526 , "case", "of"
@@ -171,7 +172,8 @@ betwixt a b c = do char a ; out <- c
171172 char b <?> "closing '" ++ [b] ++ "'" ; return out
172173
173174surround a z name p = do
174− char a ; v <- padded p
175+ char a
176+ v <- padded p
175177 char z <?> unwords ["closing", name, show z]
176178 return v
177179
@@ -184,10 +186,10 @@ parens = surround '(' ')' "paren"
184186brackets :: IParser a -> IParser a
185187brackets = surround '{' '}' "bracket"
186188
187−addLocation :: (Pretty a) => IParser a -> IParser (Location.Located a)
189+addLocation :: (Pretty a) => IParser a -> IParser (Annotation.Located a)
188190addLocation expr = do
189191 (start, e, end) <- located expr
190− return (Location.at start end e)
192+ return (Annotation.at start end e)
191193
192194located :: IParser a -> IParser (SourcePos, a, SourcePos)
193195located p = do
@@ -196,10 +198,10 @@ located p = do
196198 end <- getPosition
197199 return (start, e, end)
198200
199−accessible :: IParser LParseExpr -> IParser LParseExpr
201+accessible :: IParser ParseExpr -> IParser ParseExpr
200202accessible expr = do
201203 start <- getPosition
202− ce@(L _ e) <- expr
204+ ce@(A _ e) <- expr
203205 let rest f = do
204206 let dot = char '.' >> notFollowedBy (char '.')
205207 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
@@ -208,10 +210,12 @@ accessible expr = do
208210 Just _ -> accessible $ do
209211 v <- var <?> "field access (e.g. List.map)"
210212 end <- getPosition
211− return (Location.at start end (f v))
212− case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
213− | otherwise -> rest (Access ce)
214− _ -> rest (Access ce)
213+ return (Annotation.at start end (f v))
214+ case e of
215+ Var (Variable.Raw (c:cs))
216+ | isUpper c -> rest (\v -> rawVar (c:cs ++ '.':v))
217+ | otherwise -> rest (Access ce)
218+ _ -> rest (Access ce)
215219
216220
217221spaces :: 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,50 +11,55 @@ 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)
5761 | GLShader String String Literal.GLShaderTipe
62+ deriving (Show)
5863
5964
6065---- SPECIALIZED ASTs ----
@@ -63,81 +68,100 @@ data Expr' def
6368annotations and definitions, which is how they appear in source code and how
6469they are parsed.
6570-}
66−type ParseExpr = Expr' ParseDef
67−type LParseExpr = LExpr' ParseDef
71+type ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw
72+type ParseExpr' = GeneralExpr' Annotation.Region ParseDef Variable.Raw
6873
6974data ParseDef
70− = Def Pattern.Pattern LParseExpr
75+ = Def Pattern.Pattern ParseExpr
7176 | TypeAnnotation String SrcType.Type
72− deriving (Show)
77+ deriving (Show)
7378
7479{-| "Normal" expressions. When the compiler checks that type annotations and
7580ports are all paired with definitions in the appropriate order, it collapses
7681them into a Def that is easier to work with in later phases of compilation.
7782-}
78−type LExpr = LExpr' Def
79−type Expr = Expr' Def
83+type Expr = GeneralExpr Annotation.Region Def Variable.Raw
84+type Expr' = GeneralExpr' Annotation.Region Def Variable.Raw
8085
81−data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)
86+data Def = Definition Pattern.Pattern Expr (Maybe SrcType.Type)
8287 deriving (Show)
8388
8489
90+
8591---- UTILITIES ----
8692
87−tuple :: [LExpr' def] -> Expr' def
93+rawVar :: String -> GeneralExpr' ann def Variable.Raw
94+rawVar x = Var (Variable.Raw x)
95+
96+tuple :: [GeneralExpr ann def var] -> GeneralExpr' ann def var
8897tuple es = Data ("_Tuple" ++ show (length es)) es
8998
90−delist :: LExpr' def -> [LExpr' def]
91−delist (Location.L _ (Data "::" [h,t])) = h : delist t
99+delist :: GeneralExpr ann def var -> [GeneralExpr ann def var]
100+delist (Annotation.A _ (Data "::" [h,t])) = h : delist t
92101delist _ = []
93102
94103saveEnvName :: String
95104saveEnvName = "_save_the_environment!!!"
96105
97−dummyLet :: Pretty def => [def] -> LExpr' def
106+dummyLet :: (Pretty def) => [def] -> GeneralExpr Annotation.Region def Variable.Raw
98107dummyLet defs =
99− Location.none $ Let defs (Location.none $ Var saveEnvName)
108+ Annotation.none $ Let defs (Annotation.none $ rawVar saveEnvName)
100109
101−instance Pretty def => Show (Expr' def) where
102− show = render . pretty
103−
104−instance Pretty def => Pretty (Expr' def) where
110+instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where
105111 pretty expr =
106112 case expr of
107113 Literal lit -> pretty lit
108− Var x -> variable x
114+
115+ Var x -> pretty x
116+
109117 Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
118+
110119 ExplicitList es -> P.brackets (commaCat (map pretty es))
111− Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->
120+
121+ Binop "-" (Annotation.A _ (Literal (Literal.IntNum 0))) e ->
112122 P.text "-" <> prettyParens e
123+
113124 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
114− where op' = if Help.isOp op then op else "`" ++ op ++ "`"
125+ where
126+ op' = if Help.isOp op then op else "`" ++ op ++ "`"
127+
115128 Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
116129 where
117− (ps,body) = collectLambdas (Location.none $ Lambda p e)
130+ (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)
118131 args = P.sep (map Pattern.prettyParens ps)
132+
119133 App _ _ -> P.hang func 2 (P.sep args)
120− where func:args = map prettyParens (collectApps (Location.none expr))
121− MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
134+ where
135+ func:args = map prettyParens (collectApps (Annotation.A undefined expr))
136+
137+ MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
122138 where
123139 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
140+
124141 Let defs e ->
125142 P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
126143 , P.text "in" <+> pretty e ]
144+
127145 Case e pats ->
128146 P.hang pexpr 2 (P.vcat (map pretty' pats))
129147 where
130148 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
131149 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
150+
132151 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
133152 Data "[]" [] -> P.text "[]"
134153 Data name es
135154 | Help.isTuple name -> P.parens (commaCat (map pretty es))
136155 | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
156+
137157 Access e x -> prettyParens e <> P.text "." <> variable x
158+
138159 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
139− Insert (Location.L _ (Remove e y)) x v ->
140− P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
160+
161+ Insert (Annotation.A _ (Remove e y)) x v ->
162+ P.braces $ P.hsep [ pretty e, P.text "-", variable y, P.text "|"
163+ , variable x, P.equals, pretty v ]
164+
141165 Insert e x v ->
142166 P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
143167
@@ -178,21 +202,23 @@ instance Pretty Def where
178202 Nothing -> P.empty
179203 Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
180204
181−collectApps :: LExpr' def -> [LExpr' def]
182−collectApps lexpr@(Location.L _ expr) =
205+collectApps :: GeneralExpr ann def var -> [GeneralExpr ann def var]
206+collectApps annExpr@(Annotation.A _ expr) =
183207 case expr of
184208 App a b -> collectApps a ++ [b]
185− _ -> [lexpr]
209+ _ -> [annExpr]
186210
187−collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)
188−collectLambdas lexpr@(Location.L _ expr) =
211+collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)
212+collectLambdas lexpr@(Annotation.A _ expr) =
189213 case expr of
190− Lambda pattern body -> (pattern : ps, body')
191− where (ps, body') = collectLambdas body
214+ Lambda pattern body ->
215+ let (ps, body') = collectLambdas body
216+ in (pattern : ps, body')
217+
192218 _ -> ([], lexpr)
193219
194−prettyParens :: (Pretty def) => LExpr' def -> Doc
195−prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
220+prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc
221+prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)
196222 where
197223 needed =
198224 case expr of
compiler/SourceSyntax/Literal.hs+4−2
@@ -21,7 +21,8 @@ instance Pretty Literal where
2121 Str s -> PP.text . show $ s
2222 Boolean bool -> PP.text (show bool)
2323
24−data GLTipe = Int | Float | V3 | V4 | M4
24+data GLTipe = Int | Float | V3 | V4 | M4 | Texture
25+ deriving (Show)
2526
2627glTipeName :: GLTipe -> String
2728glTipeName Int = "Int"
@@ -29,10 +30,11 @@ glTipeName Float = "Float"
2930glTipeName V3 = "MJS.V3"
3031glTipeName V4 = "MJS.V4"
3132glTipeName M4 = "MJS.M4x4"
33+glTipeName Texture = "Graphics.WebGL.Texture"
3234
3335data GLShaderTipe = GLShaderTipe
3436 { attribute :: Map String GLTipe
3537 , uniform :: Map String GLTipe
3638 , varying :: Map String GLTipe
37− }
39+ } deriving (Show)
3840
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+6−6
@@ -7,7 +7,7 @@ import qualified Data.Map as Map
77import Control.Applicative ((<$>), (<*>))
88import Text.PrettyPrint as P
99
10−import SourceSyntax.Expression (LExpr)
10+import SourceSyntax.Expression (Expr)
1111import SourceSyntax.Declaration
1212import SourceSyntax.PrettyPrint
1313import SourceSyntax.Type
@@ -30,12 +30,12 @@ instance (Pretty def) => Pretty (Module def) where
3030 where
3131 prettyDecls = P.sep $ map pretty decls
3232
33− modul = P.text "module" <+> moduleName <+> where'
33+ modul = P.text "module" <+> moduleName <+> prettyExports <+> P.text "where"
3434 moduleName = P.text $ List.intercalate "." modNames
35− where' =
35+ prettyExports =
3636 case exports of
37− [] -> P.text "where"
38− _ -> P.parens (commaCat $ map P.text exports) <+> P.text "where"
37+ [] -> P.empty
38+ _ -> P.parens . commaCat $ map P.text exports
3939
4040 prettyImports = P.vcat $ map prettyImport imports
4141
@@ -72,7 +72,7 @@ data MetadataModule =
7272 , path :: FilePath
7373 , exports :: [String]
7474 , imports :: [(String, ImportMethod)]
75− , program :: LExpr
75+ , program :: Expr
7676 , types :: Map.Map String Type
7777 , fixities :: [(Assoc, Int, String)]
7878 , 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+27−21
@@ -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
@@ -96,8 +98,7 @@ type Env = Map.Map String String
9698
9799extend :: Env -> P.Pattern -> Env
98100extend env pattern = Map.union (Map.fromList (zip xs xs)) env
99− where xs = Set.toList (P.boundVars pattern)
100−
101+ where xs = P.boundVarList pattern
101102
102103replace :: String -> Env -> String -> Either String String
103104replace variable env v =
@@ -110,14 +111,18 @@ replace variable env v =
110111 msg = if null matches then "" else
111112 "\nClose matches include: " ++ List.intercalate ", " matches
112113
113−rename :: Env -> LExpr -> Either [Doc] LExpr
114−rename env (L s expr) =
114+-- TODO: Var.Raw -> Var.Canonical
115+rename :: Env -> Expr -> Either [Doc] Expr
116+rename env (A ann expr) =
115117 let rnm = rename env
116− 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+ ]
117122 format = Either.either throw return
118− renameType' env = renameType (format . replace "variable" env)
123+ renameType' environ = renameType (format . replace "variable" environ)
119124 in
120− L s <$>
125+ A ann <$>
121126 case expr of
122127 Literal _ -> return expr
123128
@@ -155,7 +160,8 @@ rename env (L s expr) =
155160 <*> rename env' body
156161 <*> T.traverse (renameType' env') mtipe
157162
158− Var x -> Var <$> format (replace "variable" env x)
163+ -- TODO: Raw -> Canonical
164+ Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)
159165
160166 Data name es -> Data name <$> mapM rnm es
161167
@@ -177,10 +183,10 @@ rename env (L s expr) =
177183renamePattern :: Env -> P.Pattern -> Either String P.Pattern
178184renamePattern env pattern =
179185 case pattern of
180− P.PVar _ -> return pattern
181− P.PLiteral _ -> return pattern
182− P.PRecord _ -> return pattern
183− P.PAnything -> return pattern
184− P.PAlias x p -> P.PAlias x <$> renamePattern env p
185− P.PData name ps -> P.PData <$> replace "pattern" env name
186− <*> mapM (renamePattern env) ps
186+ P.Var _ -> return pattern
187+ P.Literal _ -> return pattern
188+ P.Record _ -> return pattern
189+ P.Anything -> return pattern
190+ P.Alias x p -> P.Alias x <$> renamePattern env p
191+ P.Data name ps -> P.Data <$> replace "pattern" env name
192+ <*> 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+19−18
@@ -1,43 +1,44 @@
11{-# OPTIONS_GHC -Wall #-}
22module Transform.SafeNames (metadataModule) where
33
4−import Control.Arrow (first, (***))
5−import Data.List (intercalate)
6−
4+import Control.Arrow (first, (***))
5+import qualified Data.List as List
76import qualified Data.Set as Set
87
9−import qualified Parse.Helpers as PHelp
8+import qualified Parse.Helpers as PHelp
9+import SourceSyntax.Annotation
1010import SourceSyntax.Expression
1111import qualified SourceSyntax.Helpers as SHelp
12−import SourceSyntax.Location
1312import SourceSyntax.Module
14−import SourceSyntax.Pattern
13+import qualified SourceSyntax.Pattern as P
14+import qualified SourceSyntax.Variable as Variable
1515
1616var :: String -> String
17−var = intercalate "." . map (dereserve . deprime) . SHelp.splitDots
17+var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots
1818 where
1919 deprime = map (\c -> if c == '\'' then '$' else c)
2020 dereserve x = case Set.member x PHelp.jsReserveds of
2121 False -> x
2222 True -> "$" ++ x
2323
24−pattern :: Pattern -> Pattern
24+pattern :: P.Pattern -> P.Pattern
2525pattern pat =
2626 case pat of
27− PVar x -> PVar (var x)
28− PLiteral _ -> pat
29− PRecord fs -> PRecord (map var fs)
30− PAnything -> pat
31− PAlias x p -> PAlias (var x) (pattern p)
32− 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)
3333
34−expression :: LExpr -> LExpr
35−expression (L loc expr) =
34+-- TODO: should be "normal expression" -> "expression for JS generation"
35+expression :: Expr -> Expr
36+expression (A ann expr) =
3637 let f = expression in
37− L loc $
38+ A ann $
3839 case expr of
3940 Literal _ -> expr
40− Var x -> Var (var x)
41+ Var (Variable.Raw x) -> rawVar (var x)
4142 Range e1 e2 -> Range (f e1) (f e2)
4243 ExplicitList es -> ExplicitList (map f es)
4344 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)
@@ -105,11 +106,11 @@ reorder (L s expr) =
105106 bound (P.boundVars pattern)
106107 mapM free (ctors pattern)
107108
108− let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss
109+ let A _ let' = foldr (\ds bod -> A ann (Let ds bod)) body' defss
109110
110111 return let'
111112
112−bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)
113+bindingReorder :: (P.Pattern, Expr) -> State (Set.Set String) (P.Pattern, Expr)
113114bindingReorder (pattern,expr) =
114115 do expr' <- reorder expr
115116 bound (P.boundVars pattern)
compiler/Transform/Substitute.hs+7−5
@@ -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
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+40−38
@@ -1,36 +1,37 @@
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
1211import SourceSyntax.Literal as Lit
13−import SourceSyntax.Location as Loc
14−import SourceSyntax.Pattern (Pattern(PVar), boundVars)
12+import SourceSyntax.Pattern (Pattern, boundVars)
13+import SourceSyntax.Annotation as Ann
1514import SourceSyntax.Expression
16−import qualified SourceSyntax.Type as SrcT
15+import qualified SourceSyntax.Pattern as P
16+import qualified SourceSyntax.Type as ST
17+import qualified SourceSyntax.Variable as V
1718import Type.Type hiding (Descriptor(..))
1819import Type.Fragment
1920import qualified Type.Environment as Env
2021import qualified Type.Constrain.Literal as Literal
2122import qualified Type.Constrain.Pattern as Pattern
2223
23−constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
24−constrain env (L span expr) tipe =
24+constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
25+constrain env (A region expr) tipe =
2526 let list t = Env.get env Env.types "_List" <| t
26− and = L span . CAnd
27− true = L span CTrue
28− t1 === t2 = L span (CEqual t1 t2)
29− x <? t = L span (CInstance x t)
30− clet schemes c = L span (CLet schemes c)
27+ and = A region . CAnd
28+ true = A region CTrue
29+ t1 === t2 = A region (CEqual t1 t2)
30+ x <? t = A region (CInstance x t)
31+ clet schemes c = A region (CLet schemes c)
3132 in
3233 case expr of
33− Literal lit -> liftIO $ Literal.constrain env span lit tipe
34+ Literal lit -> liftIO $ Literal.constrain env region lit tipe
3435
3536 GLShader _uid _src gltipe ->
3637 exists $ \attr ->
@@ -42,16 +43,17 @@ constrain env (L span expr) tipe =
4243 attribute = makeRec Lit.attribute attr
4344 uniform = makeRec Lit.uniform unif
4445 varying = makeRec Lit.varying (TermN EmptyRecord1)
45− in return . L span $ CEqual tipe (shaderTipe attribute uniform varying)
46+ in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)
4647
47− Var name | name == saveEnvName -> return (L span CSaveEnv)
48− | otherwise -> return (name <? tipe)
48+ Var (V.Raw name)
49+ | name == saveEnvName -> return (A region CSaveEnv)
50+ | otherwise -> return (name <? tipe)
4951
5052 Range lo hi ->
51− exists $ \x -> do
52− clo <- constrain env lo x
53− chi <- constrain env hi x
54− return $ and [clo, chi, list x === tipe]
53+ existsNumber $ \n -> do
54+ clo <- constrain env lo n
55+ chi <- constrain env hi n
56+ return $ and [clo, chi, list n === tipe]
5557
5658 ExplicitList exprs ->
5759 exists $ \x -> do
@@ -68,7 +70,7 @@ constrain env (L span expr) tipe =
6870 Lambda p e ->
6971 exists $ \t1 ->
7072 exists $ \t2 -> do
71− fragment <- try span $ Pattern.constrain env p t1
73+ fragment <- try region $ Pattern.constrain env p t1
7274 c2 <- constrain env e t2
7375 let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
7476 (typeConstraint fragment /\ c2 ))
@@ -92,7 +94,7 @@ constrain env (L span expr) tipe =
9294 exists $ \t -> do
9395 ce <- constrain env exp t
9496 let branch (p,e) = do
95− fragment <- try span $ Pattern.constrain env p t
97+ fragment <- try region $ Pattern.constrain env p t
9698 clet [toScheme fragment] <$> constrain env e tipe
9799 and . (:) ce <$> mapM branch branches
98100
@@ -125,11 +127,11 @@ constrain env (L span expr) tipe =
125127 Modify e fields ->
126128 exists $ \t -> do
127129 oldVars <- forM fields $ \_ -> liftIO (var Flexible)
128− let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))
130+ let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))
129131 cOld <- ex oldVars <$> constrain env e (record oldFields t)
130132
131133 newVars <- forM fields $ \_ -> liftIO (var Flexible)
132− let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))
134+ let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))
133135 let cNew = tipe === record newFields t
134136
135137 cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
@@ -139,7 +141,7 @@ constrain env (L span expr) tipe =
139141 Record fields ->
140142 do vars <- forM fields $ \_ -> liftIO (var Flexible)
141143 cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
142− let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))
144+ let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))
143145 recordType = record fields' (TermN EmptyRecord1)
144146 return . ex vars . and $ tipe === recordType : cs
145147
@@ -171,14 +173,14 @@ constrainDef env info (Definition pattern expr maybeTipe) =
171173 do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.
172174 -- Currently, qs is always [].
173175 case (pattern, maybeTipe) of
174− (PVar name, Just tipe) -> do
176+ (P.Var name, Just tipe) -> do
175177 flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
176178 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
177179 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
178180 (vars, typ) <- Env.instantiateType env tipe Map.empty
179181 let scheme = Scheme { rigidQuantifiers = [],
180182 flexibleQuantifiers = flexiVars ++ vars,
181− constraint = Loc.noneNoDocs CTrue,
183+ constraint = Ann.noneNoDocs CTrue,
182184 header = Map.singleton name typ }
183185 c <- constrain env' expr typ
184186 return ( scheme : schemes
@@ -188,7 +190,7 @@ constrainDef env info (Definition pattern expr maybeTipe) =
188190 , c2
189191 , fl rigidVars c /\ c1 )
190192
191− (PVar name, Nothing) -> do
193+ (P.Var name, Nothing) -> do
192194 v <- liftIO $ var Flexible
193195 let tipe = VarN v
194196 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
@@ -204,19 +206,19 @@ constrainDef env info (Definition pattern expr maybeTipe) =
204206 _ -> error (show pattern)
205207
206208expandPattern :: Def -> [Def]
207−expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =
209+expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =
208210 case pattern of
209− PVar _ -> [def]
210− _ -> Definition (PVar x) lexpr maybeType : map toDef vars
211+ P.Var _ -> [def]
212+ _ -> Definition (P.Var x) lexpr maybeType : map toDef vars
211213 where
212− vars = Set.toList $ boundVars pattern
214+ vars = P.boundVarList pattern
213215 x = "$" ++ concat vars
214− mkVar = L s . Var
215− toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
216+ mkVar = A r . rawVar
217+ toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
216218
217−try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
218−try span computation = do
219+try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
220+try region computation = do
219221 result <- liftIO $ runErrorT computation
220222 case result of
221− Left err -> throwError [err span]
223+ Left err -> throwError [err region]
222224 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/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+2−2
@@ -31,8 +31,8 @@ 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
3838import String
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+185−156
@@ -1,199 +1,228 @@
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 ()
69
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.
10+clickableYogi : Element
11+clickableYogi = clickable clicks.handle () (image 40 40 "/yogi.jpg")
12+```
1213
13−# Buttons
14−@docs button, customButton, buttons, customButtons
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!
1517
16−# Fields
17−@docs field, password, email, fields, FieldState, emptyFieldState
18+# Creating Inputs
19+@docs Input, input
1820
19−# Checkboxes
20−@docs checkbox, checkboxes
21+# Basic Input Elements
22+Text fields come later.
23+@docs button, customButton, checkbox, dropDown
2124
22−# Drop Downs
23−@docs stringDropDown, dropDown
25+# Clicks and Hovers
26+@docs clickable, hoverable
2427
25−# Mouse Hover
26−@docs hoverable, hoverables
28+# Text Fields
29+@docs field, password, email, noContent, FieldContent, Selection, Direction
2730-}
2831
29−import Basics (String)
30−import Signal (Signal,lift,dropRepeats)
31−import Native.Graphics.Input
32−import List
32+import Signal (Signal)
3333import Graphics.Element (Element)
34−import Maybe (Maybe)
35−import JavaScript (JSString)
34+import Native.Graphics.Input
3635
37−id x = x
36+{-| This is the key abstraction of this library. An `Input` is a record
37+of two fields:
3838
39−{-| Create a group of buttons.
39+ 1. `signal` &mdash; all values coming to this input from &ldquo;the world&rdquo;
40+ 2. `handle` &mdash; a way to refer to this particular input and send it values
4041
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.
42+This will make more sense as you see more examples.
4743-}
48−buttons : a -> { events : Signal a,
49− button : a -> String -> Element }
50−buttons = Native.Graphics.Input.buttons
44+type Input a = { signal : Signal a, handle : Handle a }
45+
46+data Handle a = Handle
47+
48+{-| Create a new `Input`. You just give the initial value for the
49+input&rsquo;s `signal`.
5150
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.
51+Note for Advanced Users: creating an `Input` is an inherently imperative
52+action, so this is one of very few impure functions in Elm. That means
53+`(input ())` and `(input ())` are actually two different inputs with different
54+signals and handles. By design, Elm&rsquo;s impure functions can only be useful
55+as you build your signal graph at startup, so Elm is still pure at runtime.
5456-}
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.
57+input : a -> Input a
58+input = Native.Graphics.Input.input
59+
60+{-| Create a standard button. The following example begins making a basic
61+calculator:
62+
63+ data Keys = Number Int | Plus | Minus | Clear
64+
65+ keys : Input Keys
66+ keys = input Clear
67+
68+ calculator : Element
69+ calculator =
70+ flow right [ button keys.handle (Number 1) "1"
71+ , button keys.handle (Number 2) "2"
72+ , button keys.handle Plus "+"
73+ ]
74+
75+If the user presses the "+" button, `keys.signal` will update to `Plus`. If the
76+users presses "2", `keys.signal` will update to `(Number 2)`.
6977-}
70−customButtons : a -> { events : Signal a,
71− customButton : a -> Element -> Element -> Element -> Element }
72−customButtons = Native.Graphics.Input.customButtons
78+button : Handle a -> a -> String -> Element
79+button = Native.Graphics.Input.button
7380
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.
81+{-| Same as `button` but lets you customize buttons to look however you want.
82+
83+ click : Input ()
84+ click = input ()
85+
86+ prettyButton : Element
87+ prettyButton =
88+ customButton click.handle
89+ (image 100 40 "/button_up.jpg")
90+ (image 100 40 "/button_hover.jpg")
91+ (image 100 40 "/button_down.jpg")
7792-}
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+customButton : Handle a -> a -> Element -> Element -> Element -> Element
94+customButton = Native.Graphics.Input.customButton
95+
96+{-| Create a checkbox. The following example creates three synced checkboxes:
97+
98+ check : Input Bool
99+ check = input False
100+
101+ boxes : Bool -> Element
102+ boxes checked =
103+ let box = container 40 40 middle (checkbox check.handle id checked)
104+ in flow right [ box, box, box ]
105+
106+ main : Signal Element
107+ main = boxes <~ check.signal
93108-}
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.
109+checkbox : Handle a -> (Bool -> a) -> Bool -> Element
110+checkbox = Native.Graphics.Input.checkbox
111+
112+{-| Create a drop-down menu. The following drop-down lets you choose your
113+favorite British sport:
114+
115+ data Sport = Football | Cricket | Snooker
116+
117+ sport : Input Sport
118+ sport = input Nothing
119+
120+ sportDropDown : Element
121+ sportDropDown =
122+ dropDown sport.handle
123+ [ ("" , Nothing)
124+ , ("Football", Just Football)
125+ , ("Cricket" , Just Cricket)
126+ , ("Snooker" , Just Snooker)
127+ ]
128+
129+If the user selects "Football" from the drop down menue, `sport.signal`
130+will update to `Just Football`.
102131-}
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.
132+dropDown : Handle a -> [(String,a)] -> Element
133+dropDown = Native.Graphics.Input.dropDown
134+
135+{-| Detect mouse hovers over a specific `Element`. In the following example,
136+we will create a hoverable picture called `cat`.
137+
138+ hover : Input Bool
139+ hover = input False
140+
141+ cat : Element
142+ cat = image 30 30 "/cat.jpg"
143+ |> hoverable hover.handle id
144+
145+When the mouse hovers above the `cat` element, `hover.signal` will become
146+`True`. When the mouse leaves it, `hover.signal` will become `False`.
111147-}
112−hoverables : a -> { events : Signal a,
113− hoverable : (Bool -> a) -> Element -> Element }
114−hoverables = Native.Graphics.Input.hoverables
148+hoverable : Handle a -> (Bool -> a) -> Element -> Element
149+hoverable = Native.Graphics.Input.hoverable
115150
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)
151+{-| Detect mouse clicks on a specific `Element`. In the following example,
152+we will create a clickable picture called `cat`.
121153
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:
154+ data Picture = Cat | Hat
155+
156+ picture : Input Picture
157+ picture = input Cat
158+
159+ cat : Element
160+ cat = image 30 30 "/cat.jpg"
161+ |> clickable picture.handle Cat
162+
163+ hat : Element
164+ hat = image 30 30 "/hat.jpg"
165+ |> clickable picture.handle Hat
166+
167+When the user clicks on the `cat` element, `picture.signal` receives
168+an update containing the value `Cat`. When the user clicks on the `hat` element,
169+`picture.signal` receives an update containing the value `Hat`. This lets you
170+distinguish which element was clicked. In a more complex example, they could be
171+distinguished with IDs or more complex data structures.
172+-}
173+clickable : Handle a -> a -> Element -> Element
174+clickable = Native.Graphics.Input.clickable
126175
127− { string="She sells sea shells", selectionStart=3, selectionEnd=0 }
176+{-| Represents the current content of a text field. For example:
177+
178+ FieldContent "She sells sea shells" (Selection 0 3 Backward)
128179
129180This means the user highlighted the substring `"She"` backwards.
130181-}
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.
182+type FieldContent = { string:String, selection:Selection }
183+
184+{-| The selection within a text field. `start` is never greater than `end`:
185+
186+ Selection 0 0 Forward -- cursor precedes all characters
187+
188+ Selection 5 9 Backward -- highlighting characters starting after
189+ -- the 5th and ending after the 9th
144190-}
145−fields : a -> { events : Signal a,
146− field : (FieldState -> a) -> String -> FieldState -> Element }
147−fields = Native.Graphics.Input.fields
191+type Selection = { start:Int, end:Int, direction:Direction }
192+
193+{-| The direction of selection.-}
194+data Direction = Forward | Backward
148195
149−{-| The empty field state:
196+{-| A field with no content:
150197
151− { string="", selectionStart=0, selectionEnd=0 }
198+ FieldContent "" (Selection 0 0 Forward)
152199-}
153−emptyFieldState : FieldState
154−emptyFieldState = { string="", selectionStart=0, selectionEnd=0 }
200+noContent : FieldContent
201+noContent = FieldContent "" (Selection 0 0 Forward)
155202
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.
203+{-| Create a text field. The following example creates a time-varying element
204+called `nameField`. As the user types their name, the field will be updated
205+to match what they have entered.
206+
207+ name : Input FieldContent
208+ name = input noContent
209+
210+ nameField : Signal Element
211+ nameField = field name.handle (\content -> content) "Name" <~ nameContent
159212-}
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))
213+field : Handle a -> (FieldContent -> a) -> String -> FieldContent -> Element
214+field = Native.Graphics.Input.field
166215
167216{-| 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))
217+password : Handle a -> (FieldContent -> a) -> String -> FieldContent -> Element
218+password = Native.Graphics.Input.password
174219
175220{-| Same as `field` but it adds an annotation that this field is for email
176221addresses. This is helpful for auto-complete and for mobile users who may
177222get a custom keyboard with an `@` and `.com` button.
178223-}
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.
190−-}
191−dropDown : [(String,a)] -> (Signal Element, Signal a)
192−dropDown = Native.Graphics.Input.dropDown
224+email : Handle a -> (FieldContent -> a) -> String -> FieldContent -> Element
225+email = Native.Graphics.Input.email
193226
194−{-| Create a drop-down menu for selecting strings. The resulting
195−signal of strings represents the string that is currently selected.
196−-}
197−stringDropDown : [String] -> (Signal Element, Signal String)
198−stringDropDown strs =
199− dropDown (List.map (\s -> (s,s)) strs)
227+-- area : Handle a -> (FieldContent -> a) -> Handle b -> ((Int,Int) -> b) -> (Int,Int) -> String -> FieldContent -> Element
228+-- 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+2−2
@@ -10,7 +10,7 @@ list must have the same type.
1010@docs head, tail, last, filter, take, drop
1111
1212# Putting Lists Together
13−@docs concat, concatMap, join, intersperse, zip, zipWith
13+@docs concat, concatMap, join, intersperse, zip, zipWith, repeat
1414
1515# Taking Lists Apart
1616@docs partition, unzip
@@ -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/Native/Debug.jsnew file+22
@@ -0,0 +1,22 @@
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+ if (process && process.stdout) {
11+ process.stdout.write(tag + ': ' + show(value));
12+ } else {
13+ console.log(tag + ': ' + show(value));
14+ }
15+ return value;
16+ }
17+
18+ return elm.Native.Debug.values = {
19+ log: F2(log)
20+ };
21+
22+};
libraries/Native/Graphics/Input.js+363−299
@@ -1,303 +1,367 @@
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 Signal = Elm.Signal.make(elm);
12+ var newElement = Elm.Graphics.Element.make(elm).newElement;
13+ var JS = Elm.Native.JavaScript.make(elm);
14+ var Utils = Elm.Native.Utils.make(elm);
15+ var Tuple2 = Utils.Tuple2;
16+
17+ function input(initialValue) {
18+ var signal = Signal.constant(initialValue);
19+ return { _:{}, signal:signal, handle:signal };
20+ }
21+
22+ function renderDropDown(signal, values) {
23+ return function(_) {
24+ var entries = JS.fromList(values);
25+
26+ var drop = newNode('select');
27+ drop.style.border = '0 solid';
28+ drop.style.pointerEvents = 'auto';
29+ for (var i = 0; i < entries.length; ++i) {
30+ var option = newNode('option');
31+ var name = JS.fromString(entries[i]._0);
32+ option.value = name;
33+ option.innerHTML = name;
34+ drop.appendChild(option);
35+ }
36+ drop.addEventListener('change', function() {
37+ elm.notify(signal.id, entries[drop.selectedIndex]._1);
38+ });
39+
40+ var t = drop.cloneNode(true);
41+ t.style.visibility = "hidden";
42+
43+ elm.node.appendChild(t);
44+ var style = window.getComputedStyle(t, null);
45+ var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);
46+ var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);
47+ elm.node.removeChild(t);
48+ return drop;
49+ };
50+ }
51+
52+ function updateDropDown(node, oldModel, newModel) {
53+ }
54+
55+ function dropDown(signal, values) {
56+ return A3(newElement, 100, 24, {
57+ ctor: 'Custom',
58+ type: 'DropDown',
59+ render: renderDropDown(signal,values),
60+ update: updateDropDown,
61+ model: {}
62+ });
63+ }
64+
65+ function renderButton(model) {
66+ var node = newNode('button');
67+ node.style.display = 'block';
68+ node.style.pointerEvents = 'auto';
69+ node.elm_signal = model.signal;
70+ node.elm_value = model.value;
71+ function click() {
72+ elm.notify(node.elm_signal.id, node.elm_value);
73+ }
74+ node.addEventListener('click', click);
75+ node.innerHTML = model.text;
76+ return node;
77+ }
78+
79+ function updateButton(node, oldModel, newModel) {
80+ node.elm_signal = newModel.signal;
81+ node.elm_value = nemModel.value;
82+ var txt = newModel.text;
83+ if (oldModel.text !== txt) node.innerHTML = txt;
84+ }
85+
86+ function button(signal, value, text) {
87+ return A3(newElement, 100, 40, {
88+ ctor: 'Custom',
89+ type: 'Button',
90+ render: renderButton,
91+ update: updateButton,
92+ model: { signal:signal, value:value, text:JS.fromString(text) }
93+ });
94+ }
95+
96+ function renderCustomButton(model) {
97+ var btn = newNode('div');
98+ btn.style.pointerEvents = 'auto';
99+ btn.elm_signal = model.signal;
100+ btn.elm_value = model.value;
101+
102+ btn.elm_up = Render.render(model.up);
103+ btn.elm_hover = Render.render(model.hover);
104+ btn.elm_down = Render.render(model.down);
105+
106+ function replace(node) {
107+ if (node !== btn.firstChild) {
108+ btn.replaceChild(node, btn.firstChild);
109+ }
110+ }
111+ var overCount = 0;
112+ function over(e) {
113+ if (overCount++ > 0) return;
114+ replace(btn.elm_hover);
115+ }
116+ function out(e) {
117+ if (btn.contains(e.toElement || e.relatedTarget)) return;
118+ overCount = 0;
119+ replace(btn.elm_up);
120+ }
121+ function up() {
122+ replace(btn.elm_hover);
123+ elm.notify(btn.elm_signal.id, btn.elm_value);
124+ }
125+ function down() {
126+ replace(btn.elm_down);
127+ }
128+ btn.addEventListener('mouseover', over);
129+ btn.addEventListener('mouseout' , out);
130+ btn.addEventListener('mousedown', down);
131+ btn.addEventListener('mouseup' , up);
132+
133+ btn.appendChild(btn.elm_up);
134+
135+ var clicker = newNode('div');
136+ clicker.style.width = btn.elm_up.style.width;
137+ clicker.style.height = btn.elm_up.style.height;
138+ clicker.style.position = 'absolute';
139+ clicker.style.top = 0;
140+ btn.appendChild(clicker);
141+
142+ return btn;
143+ }
144+
145+ function updateCustomButton(node, oldModel, newModel) {
146+ var signal = newModel.signal;
147+ node.elm_up.elm_signal = signal;
148+ node.elm_hover.elm_signal = signal;
149+ node.elm_down.elm_signal = signal;
150+
151+ var value = newModel.value;
152+ node.elm_up.elm_value = value;
153+ node.elm_hover.elm_value = value;
154+ node.elm_down.elm_value = value;
155+
156+ Render.update(node.elm_up, oldModel.up, newModel.up)
157+ Render.update(node.elm_hover, oldModel.hover, newModel.hover)
158+ Render.update(node.elm_down, oldModel.down, newModel.down)
159+ }
160+
161+ function max3(a,b,c) {
162+ var ab = a > b ? a : b;
163+ return ab > c ? ab : c;
164+ }
165+
166+ function customButton(signal, value, up, hover, down) {
167+ return A3(newElement,
168+ max3(up.props.width, hover.props.width, down.props.width),
169+ max3(up.props.height, hover.props.height, down.props.height),
170+ { ctor: 'Custom',
171+ type: 'CustomButton',
172+ render: renderCustomButton,
173+ update: updateCustomButton,
174+ model: { signal:signal, value:value, up:up, hover:hover, down:down }
175+ });
176+ }
177+
178+ function renderCheckbox(model) {
179+ var node = newNode('input');
180+ node.type = 'checkbox';
181+ node.checked = model.checked;
182+ node.style.display = 'block';
183+ node.style.pointerEvents = 'auto';
184+ node.elm_signal = model.signal;
185+ node.elm_handler = model.handler;
186+ function change() {
187+ elm.notify(node.elm_signal.id, node.elm_handler(node.checked));
188+ }
189+ node.addEventListener('change', change);
190+ return node;
191+ }
192+
193+ function updateCheckbox(node, oldModel, newModel) {
194+ node.elm_signal = newModel.signal;
195+ node.elm_handler = newModel.handler;
196+ node.checked = newModel.checked;
197+ return true;
198+ }
199+
200+ function checkbox(signal, handler, checked) {
201+ return A3(newElement, 13, 13, {
202+ ctor: 'Custom',
203+ type: 'CheckBox',
204+ render: renderCheckbox,
205+ update: updateCheckbox,
206+ model: { signal:signal, handler:handler, checked:checked }
207+ });
208+ }
209+
210+ function setRange(node, start, end, dir) {
211+ if (node.parentNode) {
212+ node.setSelectionRange(start, end, dir);
213+ } else {
214+ setTimeout(function(){node.setSelectionRange(start, end, dir);}, 0);
215+ }
216+ }
217+
218+ function renderField(model) {
219+ var field = newNode('input');
220+ field.style.border = 'none';
221+ field.style.outline = 'none';
222+ field.style.backgroundColor = 'transparent';
223+ field.style.pointerEvents = 'auto';
224+
225+ field.type = model.type;
226+ field.placeholder = JS.fromString(model.placeHolder);
227+ field.value = JS.fromString(model.content.string);
228+ var selection = model.content.selection;
229+ var direction = selection.direction.ctor === 'Forward' ? 'forward' : 'backward';
230+ setRange(field, selection.start, selection.end, direction);
231+
232+ field.elm_signal = model.signal;
233+ field.elm_handler = model.handler;
234+ field.elm_old_value = field.value;
235+
236+ function keyUpdate(event) {
237+ var curr = field.value;
238+ var next = (curr.slice(0, field.selectionStart) +
239+ String.fromCharCode(event.keyCode) +
240+ curr.slice(field.selectionEnd));
241+ var pos = field.selectionEnd + 1;
242+ elm.notify(field.elm_signal.id, field.elm_handler({
243+ _:{},
244+ string: JS.toString(next),
245+ selection: {
246+ start: pos,
247+ end: pos,
248+ direction: { ctor:'Forward' }
249+ },
250+ }));
251+ event.preventDefault();
252+ }
253+
254+ function inputUpdate(event) {
255+ var curr = field.elm_old_value;
256+ var next = field.value;
257+ if (curr === next) {
258+ return;
259+ }
260+
261+ var direction = field.selectionDirection === 'forward' ? 'Forward' : 'Backward';
262+ var start = field.selectionStart;
263+ var end = field.selectionEnd;
264+ field.value = field.elm_old_value;
265+
266+ elm.notify(field.elm_signal.id, field.elm_handler({
267+ _:{},
268+ string: JS.toString(next),
269+ selection: {
270+ start: start,
271+ end: end,
272+ direction: { ctor: direction }
273+ },
274+ }));
275+ }
276+
277+ function mouseUpdate(event) {
278+ var direction = field.selectionDirection === 'forward' ? 'Forward' : 'Backward';
279+ elm.notify(field.elm_signal.id, field.elm_handler({
280+ _:{},
281+ string: field.value,
282+ selection: {
283+ start: field.selectionStart,
284+ end: field.selectionEnd,
285+ direction: { ctor: direction }
286+ },
287+ }));
288+ }
289+ function mousedown(event) {
290+ mouseUpdate(event);
291+ elm.node.addEventListener('mouseup', mouseup);
292+ }
293+ function mouseup(event) {
294+ mouseUpdate(event);
295+ elm.node.removeEventListener('mouseup', mouseup)
296+ }
297+ field.addEventListener('keypress', keyUpdate);
298+ field.addEventListener('input', inputUpdate);
299+ field.addEventListener('mousedown', mousedown);
300+
301+ return field;
302+ }
303+
304+ function updateField(field, oldModel, newModel) {
305+ field.elm_signal = newModel.signal;
306+ field.elm_handler = newModel.handler;
307+
308+ field.type = newModel.type;
309+ field.placeholder = JS.fromString(newModel.placeHolder);
310+ var value = JS.fromString(newModel.content.string);
311+ field.value = value;
312+ field.elm_old_value = value;
313+ var selection = newModel.content.selection;
314+ var direction = selection.direction.ctor === 'Forward' ? 'forward' : 'backward';
315+ setRange(field, selection.start, selection.end, direction);
316+ }
317+
318+ function mkField(type) {
319+ function field(signal, handler, placeHolder, content) {
320+ return A3(newElement, 200, 30, {
321+ ctor: 'Custom',
322+ type: type + 'Input',
323+ render: renderField,
324+ update: updateField,
325+ model: {
326+ signal:signal,
327+ handler:handler,
328+ placeHolder:placeHolder,
329+ content:content,
330+ type:type
331+ }
332+ });
333+ }
334+ return F4(field);
335+ }
336+
337+
338+ function hoverable(signal, handler, elem) {
339+ function onHover(bool) {
340+ elm.notify(signal.id, handler(bool));
341+ }
342+ var props = Utils.replace([['hover',onHover]], elem.props);
343+ return { props:props, element:elem.element };
344+ }
345+
346+ function clickable(signal, value, elem) {
347+ function onClick(bool) {
348+ elm.notify(signal.id, value);
349+ }
350+ var props = Utils.replace([['click',onClick]], elem.props);
351+ return { props:props, element:elem.element };
352+ }
353+
354+ return elm.Native.Graphics.Input.values = {
355+ input:input,
356+ button:F3(button),
357+ customButton:F5(customButton),
358+ checkbox:F3(checkbox),
359+ dropDown:F2(dropDown),
360+ field:mkField('text'),
361+ email:mkField('email'),
362+ password:mkField('password'),
363+ hoverable:F3(hoverable),
364+ clickable:F3(clickable)
365+ };
302366
303367};
libraries/Native/Regex.js+10−19
@@ -15,7 +15,7 @@ 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
@@ -23,10 +23,8 @@ Elm.Native.Regex.make = function(elm) {
2323 return re.test(JS.fromString(string));
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/Trampoline.js+4−2
@@ -5,7 +5,7 @@ Elm.Native.Trampoline.make = function(elm) {
55 if (elm.Native.Trampoline.values) return elm.Native.Trampoline.values;
66
77 // trampoline : Trampoline a -> a
8− trampoline = function(t) {
8+ function trampoline(t) {
99 var tramp = t;
1010 while(true) {
1111 switch(tramp.ctor) {
@@ -18,5 +18,7 @@ Elm.Native.Trampoline.make = function(elm) {
1818 }
1919 }
2020
21− return elm.Native.Trampoline.values = { trampoline: trampoline };
21+ return elm.Native.Trampoline.values = {
22+ trampoline:trampoline
23+ };
2224};
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/String.elm+5−1
@@ -103,6 +103,8 @@ foldr = Native.String.foldr
103103
104104 split "," "cat,dog,cow" == ["cat","dog","cow"]
105105 split "/" "home/evan/Desktop/" == ["home","evan","Desktop"]
106+
107+Use `Regex.split` if you need something more flexible.
106108-}
107109split : String -> String -> [String]
108110split = Native.String.split
@@ -231,7 +233,7 @@ any = Native.String.any
231233
232234 all isDigit "90210" == True
233235 all isDigit "R2-D2" == False
234− any isDigit "heart" == False
236+ all isDigit "heart" == False
235237-}
236238all : (Char -> Bool) -> String -> Bool
237239all = Native.String.all
@@ -241,6 +243,8 @@ all = Native.String.all
241243 contains "the" "theory" == True
242244 contains "hat" "theory" == False
243245 contains "THE" "theory" == False
246+
247+Use `Regex.contains` if you need something more flexible.
244248-}
245249contains : String -> String -> Bool
246250contains = Native.String.contains
libraries/Text.elm+1−1
@@ -16,7 +16,7 @@ module Text where
1616
1717-}
1818
19−import open Basics
19+import Basics (..)
2020import Color (Color)
2121import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)
2222import Maybe (Maybe)
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/elm_dependencies.json+2
@@ -11,6 +11,7 @@
1111 , "Char"
1212 , "Color"
1313 , "Date"
14+ , "Debug"
1415 , "Dict"
1516 , "Either"
1617 , "Graphics.Element"
@@ -34,6 +35,7 @@
3435 , "Text"
3536 , "Time"
3637 , "Touch"
38+ , "Trampoline"
3739 , "Transform2D"
3840 , "WebSocket"
3941 , "Window"
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+39−6
@@ -28,15 +28,30 @@ function setProps(props, e) {
2828 e.appendChild(a);
2929 }
3030 if (props.hover.ctor !== '_Tuple0') {
31− var overCount = 0;
31+ e.style.pointerEvents = 'auto';
32+ e.elm_hover_handler = props.hover;
33+ e.elm_hover_count = 0;
3234 e.addEventListener('mouseover', function() {
33− if (overCount++ > 0) return;
34− props.hover(true);
35+ if (e.elm_hover_count++ > 0) return;
36+ var handler = e.elm_hover_handler;
37+ if (handler !== null) {
38+ handler(true);
39+ }
3540 });
3641 e.addEventListener('mouseout', function(evt) {
3742 if (e.contains(evt.toElement || evt.relatedTarget)) return;
38− overCount = 0;
39− props.hover(false);
43+ e.elm_hover_count = 0;
44+ var handler = e.elm_hover_handler;
45+ if (handler !== null) {
46+ handler(false);
47+ }
48+ });
49+ }
50+ if (props.click.ctor !== '_Tuple0') {
51+ e.style.pointerEvents = 'auto';
52+ e.elm_click_handler = props.click;
53+ e.addEventListener('click', function() {
54+ e.elm_click_handler(Tuple0);
4055 });
4156 }
4257 return e;
@@ -99,6 +114,8 @@ function goDown(e) { return e }
99114function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e; }
100115function flowWith(f, array) {
101116 var container = newElement('div');
117+ if (f == goIn) container.style.pointerEvents = 'none';
118+
102119 for (var i = array.length; i--; ) {
103120 container.appendChild(f(render(array[i])));
104121 }
@@ -209,7 +226,9 @@ function update(node, curr, next) {
209226 case "RawHtml":
210227 // only markdown blocks have guids, so this must be a text block
211228 if (nextE.guid === null) {
212− node.innerHTML = nextE.html;
229+ if(currE.html.valueOf() !== nextE.html.valueOf()) {
230+ node.innerHTML = nextE.html;
231+ }
213232 break;
214233 }
215234 if (nextE.guid !== currE.guid) {
@@ -317,6 +336,20 @@ function updateProps(node, curr, next) {
317336 node.lastNode.href = props.href;
318337 }
319338 }
339+
340+ // update hover handlers
341+ if (props.hover.ctor !== '_Tuple0') {
342+ e.elm_hover_handler = props.hover;
343+ } else if (e.elm_hover_handler) {
344+ e.elm_hover_handler = null;
345+ }
346+
347+ // update click handlers
348+ if (props.click.ctor !== '_Tuple0') {
349+ e.elm_click_handler = props.click;
350+ } else if (e.elm_click_handler) {
351+ e.elm_click_handler = null;
352+ }
320353}
321354
322355return { render:render, update:update };
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