on master help sign in
Merge remote-tracking branch 'evan/dev' into webgl
513141dJohn P Mayer Jr
Elm.cabal+9−8
@@ -37,19 +37,19 @@ Library
37 Elm.Internal.Utils,
37 Elm.Internal.Utils,
38 Elm.Internal.Version
38 Elm.Internal.Version
39 Hs-Source-Dirs: compiler
39 Hs-Source-Dirs: compiler
40− other-modules: SourceSyntax.Declaration,
40+ other-modules: SourceSyntax.Annotation,
41+ SourceSyntax.Declaration,
41 SourceSyntax.Expression,
42 SourceSyntax.Expression,
42 SourceSyntax.Helpers,
43 SourceSyntax.Helpers,
43 SourceSyntax.Literal,
44 SourceSyntax.Literal,
44− SourceSyntax.Location,
45 SourceSyntax.Module,
45 SourceSyntax.Module,
46 SourceSyntax.Pattern,
46 SourceSyntax.Pattern,
47 SourceSyntax.PrettyPrint,
47 SourceSyntax.PrettyPrint,
48 SourceSyntax.Type,
48 SourceSyntax.Type,
49+ SourceSyntax.Variable,
49 Generate.JavaScript,
50 Generate.JavaScript,
50 Generate.JavaScript.Helpers,
51 Generate.JavaScript.Helpers,
51 Generate.JavaScript.Ports,
52 Generate.JavaScript.Ports,
52− Generate.Noscript,
53 Generate.Markdown,
53 Generate.Markdown,
54 Generate.Html,
54 Generate.Html,
55 Generate.Cases,
55 Generate.Cases,
@@ -120,19 +120,19 @@ Executable elm
120 Main-is: Compiler.hs
120 Main-is: Compiler.hs
121 ghc-options: -threaded -O2
121 ghc-options: -threaded -O2
122 Hs-Source-Dirs: compiler
122 Hs-Source-Dirs: compiler
123− other-modules: SourceSyntax.Declaration,
123+ other-modules: SourceSyntax.Annotation,
124+ SourceSyntax.Declaration,
124 SourceSyntax.Expression,
125 SourceSyntax.Expression,
125 SourceSyntax.Helpers,
126 SourceSyntax.Helpers,
126 SourceSyntax.Literal,
127 SourceSyntax.Literal,
127− SourceSyntax.Location,
128 SourceSyntax.Module,
128 SourceSyntax.Module,
129 SourceSyntax.Pattern,
129 SourceSyntax.Pattern,
130 SourceSyntax.PrettyPrint,
130 SourceSyntax.PrettyPrint,
131 SourceSyntax.Type,
131 SourceSyntax.Type,
132+ SourceSyntax.Variable,
132 Generate.JavaScript,
133 Generate.JavaScript,
133 Generate.JavaScript.Helpers,
134 Generate.JavaScript.Helpers,
134 Generate.JavaScript.Ports,
135 Generate.JavaScript.Ports,
135− Generate.Noscript,
136 Generate.Markdown,
136 Generate.Markdown,
137 Generate.Html,
137 Generate.Html,
138 Generate.Cases,
138 Generate.Cases,
@@ -202,15 +202,16 @@ Executable elm
202Executable elm-doc
202Executable elm-doc
203 Main-is: Docs.hs
203 Main-is: Docs.hs
204 Hs-Source-Dirs: compiler
204 Hs-Source-Dirs: compiler
205− other-modules: SourceSyntax.Declaration,
205+ other-modules: SourceSyntax.Annotation,
206+ SourceSyntax.Declaration,
206 SourceSyntax.Expression,
207 SourceSyntax.Expression,
207 SourceSyntax.Helpers,
208 SourceSyntax.Helpers,
208 SourceSyntax.Literal,
209 SourceSyntax.Literal,
209− SourceSyntax.Location,
210 SourceSyntax.Module,
210 SourceSyntax.Module,
211 SourceSyntax.Pattern,
211 SourceSyntax.Pattern,
212 SourceSyntax.PrettyPrint,
212 SourceSyntax.PrettyPrint,
213 SourceSyntax.Type,
213 SourceSyntax.Type,
214+ SourceSyntax.Variable,
214 Parse.Binop,
215 Parse.Binop,
215 Parse.Declaration,
216 Parse.Declaration,
216 Parse.Expression,
217 Parse.Expression,
Setup.hs+2−1
@@ -148,7 +148,8 @@ buildRuntime :: LocalBuildInfo -> [FilePath] -> IO ()
148buildRuntime lbi elmos = do
148buildRuntime lbi elmos = do
149 createDirectoryIfMissing True (rtsDir lbi)
149 createDirectoryIfMissing True (rtsDir lbi)
150 let rts' = rts lbi
150 let rts' = rts lbi
151+ writeFile rts' "'use strict';\n\
151− writeFile rts' "var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
152+ \var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
152 \var ElmRuntime = {}; ElmRuntime.Render = {};\n"
153 \var ElmRuntime = {}; ElmRuntime.Render = {};\n"
153 mapM_ (appendTo rts') =<< getFiles ".js" "libraries"
154 mapM_ (appendTo rts') =<< getFiles ".js" "libraries"
154 mapM_ (appendTo rts') elmos
155 mapM_ (appendTo rts') elmos
changelog.txt+28−3
@@ -1,10 +1,35 @@
1
1
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+
2## 0.11
24## 0.11
3
25
26+ * Ports, a new FFI that is more general and much nicer to use
4− * Lazy and Lazy.Stream (thanks to Max New)
27+ * Basic compiler tests (thanks to Max New)
28+
29+## 0.10.1
30+
5− * sortBy, sortWith (thanks to Max Goldstein)
31+ * sort, sortBy, sortWith (thanks to Max Goldstein)
6 * elm-repl
32 * elm-repl
7− * Markdown interpolation
8 * Bitwise library
33 * Bitwise library
9 * Regex library
34 * Regex library
10 * Improve Transform2D library (thanks to Michael Søndergaard)
35 * Improve Transform2D library (thanks to Michael Søndergaard)
compiler/Build/Source.hs+1−2
@@ -2,7 +2,6 @@
2module Build.Source (build) where
2module Build.Source (build) where
3
3
4import qualified Data.Map as Map
4import qualified Data.Map as Map
5−import qualified Data.Set as Set
6import System.FilePath as FP
5import System.FilePath as FP
7import Text.PrettyPrint (Doc)
6import Text.PrettyPrint (Doc)
8
7
@@ -33,7 +32,7 @@ build noPrelude interfaces source =
33
32
34 let exports'
33 let exports'
35 | null exs =
34 | null exs =
36− let get = Set.toList . Pattern.boundVars in
35+ let get = Pattern.boundVarList in
37 concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++
36 concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++
38 concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++
37 concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++
39 [ name | TypeAlias name _ (Type.Record _ _) <- decls ]
38 [ name | TypeAlias name _ (Type.Record _ _) <- decls ]
compiler/Build/Utils.hs+14
@@ -1,8 +1,11 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module Build.Utils where
2module Build.Utils where
3
3
4+import System.Directory (doesFileExist)
5+import System.Environment (getEnv)
4import System.FilePath ((</>), replaceExtension)
6import System.FilePath ((</>), replaceExtension)
5import qualified Build.Flags as Flag
7import qualified Build.Flags as Flag
8+import qualified Paths_Elm as This
6
9
7buildPath :: Flag.Flags -> FilePath -> String -> FilePath
10buildPath :: Flag.Flags -> FilePath -> String -> FilePath
8buildPath flags filePath ext =
11buildPath flags filePath ext =
@@ -19,3 +22,14 @@ elmo flags filePath =
19elmi :: Flag.Flags -> FilePath -> FilePath
22elmi :: Flag.Flags -> FilePath -> FilePath
20elmi flags filePath =
23elmi flags filePath =
21 cachePath flags filePath "elmi"
24 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
8import System.IO
8import System.IO
9
9
10import Control.Applicative ((<$>))
10import Control.Applicative ((<$>))
11+import Control.Arrow (second)
11import Data.Aeson
12import Data.Aeson
12import Data.Aeson.Encode.Pretty
13import Data.Aeson.Encode.Pretty
13import qualified Data.List as List
14import qualified Data.List as List
@@ -15,8 +16,8 @@ import qualified Data.Map as Map
15import qualified Data.ByteString.Lazy as BS
16import qualified Data.ByteString.Lazy as BS
16import qualified Data.Text as Text
17import qualified Data.Text as Text
17
18
18−import SourceSyntax.Helpers (isSymbol)
19+import qualified SourceSyntax.Helpers as Help
19−import SourceSyntax.Type (Type(..))
20+import qualified SourceSyntax.Type as T
20import qualified SourceSyntax.Expression as E
21import qualified SourceSyntax.Expression as E
21import qualified SourceSyntax.Declaration as D
22import qualified SourceSyntax.Declaration as D
22
23
@@ -30,20 +31,24 @@ data Flags = Flags
30 { files :: [FilePath] }
31 { files :: [FilePath] }
31 deriving (Data,Typeable,Show,Eq)
32 deriving (Data,Typeable,Show,Eq)
32
33
34+defaultFlags :: Flags
33defaultFlags = Flags
35defaultFlags = Flags
34 { files = def &= args &= typ "FILES"
36 { files = def &= args &= typ "FILES"
35 } &= help "Generate documentation for Elm"
37 } &= help "Generate documentation for Elm"
36 &= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
38 &= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
37
39
40+main :: IO ()
38main = do
41main = do
39 flags <- cmdArgs defaultFlags
42 flags <- cmdArgs defaultFlags
40− mapM parseFile (files flags)
43+ mapM_ parseFile (files flags)
41
44
45+config :: Config
42config = Config { confIndent = 2, confCompare = keyOrder keys }
46config = Config { confIndent = 2, confCompare = keyOrder keys }
43 where
47 where
44− keys = ["name","document","comment","raw","aliases","datatypes"
48+ keys = ["tag","name","document","comment","raw","aliases","datatypes"
45 ,"values","typeVariables","type","constructors"]
49 ,"values","typeVariables","type","constructors"]
46
50
51+parseFile :: FilePath -> IO ()
47parseFile path = do
52parseFile path = do
48 source <- readFile path
53 source <- readFile path
49 case iParse docs source of
54 case iParse docs source of
@@ -69,6 +74,7 @@ docComment = do
69 let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
74 let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
70 return $ dropWhile (==' ') (reverse reversed)
75 return $ dropWhile (==' ') (reverse reversed)
71
76
77+moduleDocs :: IParser (String, [String], String)
72moduleDocs = do
78moduleDocs = do
73 optional freshLine
79 optional freshLine
74 (names,exports) <- moduleDef
80 (names,exports) <- moduleDef
@@ -121,7 +127,7 @@ collect infixes types aliases adts things =
121 where
127 where
122 nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
128 nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
123 addDefaultInfix name pairs
129 addDefaultInfix name pairs
124− | all isSymbol name = addInfix (D.L, 9 :: Int) pairs
130+ | all Help.isSymbol name = addInfix (D.L, 9 :: Int) pairs
125 | otherwise = pairs
131 | otherwise = pairs
126
132
127 customOps = Map.intersectionWith addInfix infixes types
133 customOps = Map.intersectionWith addInfix infixes types
@@ -138,7 +144,7 @@ collect infixes types aliases adts things =
138 let fields = ["typeVariables" .= vars, "type" .= tipe ]
144 let fields = ["typeVariables" .= vars, "type" .= tipe ]
139 in collect infixes types (insert name fields aliases) adts rest
145 in collect infixes types (insert name fields aliases) adts rest
140 D.Datatype name vars ctors ->
146 D.Datatype name vars ctors ->
141− let tipe = Data name (map Var vars)
147+ let tipe = T.Data name (map T.Var vars)
142 fields = ["typeVariables" .= vars
148 fields = ["typeVariables" .= vars
143 , "constructors" .= map (ctorToJson tipe) ctors ]
149 , "constructors" .= map (ctorToJson tipe) ctors ]
144 in collect infixes types aliases (insert name fields adts) rest
150 in collect infixes types aliases (insert name fields adts) rest
@@ -147,17 +153,35 @@ collect infixes types aliases adts things =
147 obj name fields =
153 obj name fields =
148 [ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
154 [ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
149
155
150−instance ToJSON Type where
156+instance ToJSON T.Type where
151− toJSON tipe =
157+ toJSON tipe =
158+ object $
152− case tipe of
159+ case tipe of
153− Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
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)
154− Var x -> toJSON x
169+ , "name" .= toJSON x
170+ ]
171+
172+ T.Data name ts ->
173+ [ "tag" .= ("adt" :: Text.Text)
174+ , "name" .= toJSON name
155− Data name ts -> toJSON (toJSON name : map toJSON ts)
175+ , "args" .= map toJSON ts
176+ ]
177+
156− Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
178+ T.Record fields ext ->
157− where fields' = case ext of
179+ [ "tag" .= ("record" :: Text.Text)
158− Nothing -> fields
180+ , "fields" .= toJSON (map (toJSON . second toJSON) fields)
159− Just x -> ("_", Var x) : fields
181+ , "extension" .= toJSON ext
160−
182+ ]
183+
184+ctorToJson :: T.Type -> (String, [T.Type]) -> Value
161ctorToJson tipe (ctor, tipes) =
185ctorToJson tipe (ctor, tipes) =
162 object [ "name" .= ctor
186 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 #-}
1module Elm.Internal.Paths where
2module Elm.Internal.Paths where
2
3
4+import Build.Utils (getDataFile)
3−import System.IO.Unsafe
5+import System.IO.Unsafe (unsafePerformIO)
4−import qualified Paths_Elm as This
5
6
6-- |Name of directory for all of a project's dependencies.
7-- |Name of directory for all of a project's dependencies.
7dependencyDirectory :: FilePath
8dependencyDirectory :: FilePath
@@ -15,9 +16,9 @@ dependencyFile = "elm_dependencies.json"
15{-# NOINLINE runtime #-}
16{-# NOINLINE runtime #-}
16-- |The absolute path to Elm's runtime system.
17-- |The absolute path to Elm's runtime system.
17runtime :: FilePath
18runtime :: FilePath
18−runtime = unsafePerformIO $ This.getDataFileName "elm-runtime.js"
19+runtime = unsafePerformIO $ getDataFile "elm-runtime.js"
19
20
20{-# NOINLINE docs #-}
21{-# NOINLINE docs #-}
21-- |The absolute path to Elm's core library documentation.
22-- |The absolute path to Elm's core library documentation.
22docs :: FilePath
23docs :: 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
6import Data.List (groupBy,sortBy)
6import Data.List (groupBy,sortBy)
7import Data.Maybe (fromMaybe)
7import Data.Maybe (fromMaybe)
8
8
9−import SourceSyntax.Location
9+import SourceSyntax.Annotation
10−import SourceSyntax.Literal
11−import SourceSyntax.Pattern
12import SourceSyntax.Expression
10import SourceSyntax.Expression
11+import SourceSyntax.Literal
12+import qualified SourceSyntax.Pattern as P
13+import qualified SourceSyntax.Variable as V
13import Transform.Substitute
14import Transform.Substitute
14
15
15
16
16−toMatch :: [(Pattern, LExpr)] -> State Int (String, Match)
17+toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)
17toMatch patterns = do
18toMatch patterns = do
18 v <- newVar
19 v <- newVar
19 (,) v <$> match [v] (map (first (:[])) patterns) Fail
20 (,) v <$> match [v] (map (first (:[])) patterns) Fail
@@ -27,7 +28,7 @@ data Match
27 = Match String [Clause] Match
28 = Match String [Clause] Match
28 | Break
29 | Break
29 | Fail
30 | Fail
30− | Other LExpr
31+ | Other Expr
31 | Seq [Match]
32 | Seq [Match]
32 deriving Show
33 deriving Show
33
34
@@ -39,8 +40,8 @@ matchSubst :: [(String,String)] -> Match -> Match
39matchSubst _ Break = Break
40matchSubst _ Break = Break
40matchSubst _ Fail = Fail
41matchSubst _ Fail = Fail
41matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
42matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
42−matchSubst pairs (Other (L s e)) =
43+matchSubst pairs (Other (A a e)) =
43− Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
44+ Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs
44matchSubst pairs (Match n cs m) =
45matchSubst pairs (Match n cs m) =
45 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
46 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
46 where varSubst v = fromMaybe v (lookup v pairs)
47 where varSubst v = fromMaybe v (lookup v pairs)
@@ -49,13 +50,13 @@ matchSubst pairs (Match n cs m) =
49
50
50isCon (p:_, _) =
51isCon (p:_, _) =
51 case p of
52 case p of
52− PData _ _ -> True
53+ P.Data _ _ -> True
53− PLiteral _ -> True
54+ P.Literal _ -> True
54− _ -> False
55+ _ -> False
55
56
56isVar p = not (isCon p)
57isVar p = not (isCon p)
57
58
58−match :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
59+match :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
59match [] [] def = return def
60match [] [] def = return def
60match [] [([],e)] Fail = return $ Other e
61match [] [([],e)] Fail = return $ Other e
61match [] [([],e)] Break = return $ Other e
62match [] [([],e)] Break = return $ Other e
@@ -67,46 +68,46 @@ match vs@(v:_) cs def
67 where
68 where
68 cs' = map (dealias v) cs
69 cs' = map (dealias v) cs
69
70
70−dealias v c@(p:ps, L s e) =
71+dealias v c@(p:ps, A a e) =
71 case p of
72 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)
73 _ -> c
74 _ -> c
74
75
75−matchVar :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
76+matchVar :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
76matchVar (v:vs) cs def = match vs (map subVar cs) def
77matchVar (v:vs) cs def = match vs (map subVar cs) def
77 where
78 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)
79 where
80 where
80 subOnePattern pattern e =
81 subOnePattern pattern e =
81 case pattern of
82 case pattern of
82− PVar x -> subst x (Var v) e
83+ P.Var x -> subst x (rawVar v) e
83− PAnything -> e
84+ P.Anything -> e
84− PRecord fs ->
85+ P.Record fs ->
85− foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
86+ foldr (\x -> subst x (Access (A a (rawVar v)) x)) e fs
86
87
87−matchCon :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
88+matchCon :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
88matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
89matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
89 where
90 where
90 css = groupBy eq (sortBy cmp cs)
91 css = groupBy eq (sortBy cmp cs)
91
92
92 cmp (p1:_,_) (p2:_,_) =
93 cmp (p1:_,_) (p2:_,_) =
93 case (p1,p2) of
94 case (p1,p2) of
94− (PData n1 _, PData n2 _) -> compare n1 n2
95+ (P.Data n1 _, P.Data n2 _) -> compare n1 n2
95 _ -> compare p1 p2
96 _ -> compare p1 p2
96
97
97 eq (p1:_,_) (p2:_,_) =
98 eq (p1:_,_) (p2:_,_) =
98 case (p1,p2) of
99 case (p1,p2) of
99− (PData n1 _, PData n2 _) -> n1 == n2
100+ (P.Data n1 _, P.Data n2 _) -> n1 == n2
100 _ -> p1 == p2
101 _ -> p1 == p2
101
102
102 toClause cs =
103 toClause cs =
103 case head cs of
104 case head cs of
104− (PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
105+ (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
105− (PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
106+ (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
106
107
107matchClause :: Either String Literal
108matchClause :: Either String Literal
108 -> [String]
109 -> [String]
109− -> [([Pattern],LExpr)]
110+ -> [([P.Pattern],Expr)]
110 -> Match
111 -> Match
111 -> State Int Clause
112 -> State Int Clause
112matchClause c (_:vs) cs def =
113matchClause c (_:vs) cs def =
@@ -116,14 +117,14 @@ matchClause c (_:vs) cs def =
116
117
117 flatten (p:ps, e) =
118 flatten (p:ps, e) =
118 case p of
119 case p of
119− PData _ ps' -> (ps' ++ ps, e)
120+ P.Data _ ps' -> (ps' ++ ps, e)
120− PLiteral _ -> (ps, e)
121+ P.Literal _ -> (ps, e)
121
122
122 getVars =
123 getVars =
123 case head cs of
124 case head cs of
124− (PData _ ps : _, _) -> forM ps (const newVar)
125+ (P.Data _ ps : _, _) -> forM ps (const newVar)
125− (PLiteral _ : _, _) -> return []
126+ (P.Literal _ : _, _) -> return []
126
127
127−matchMix :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
128+matchMix :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
128matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
129matchMix 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 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module Generate.JavaScript (generate) where
2module Generate.JavaScript (generate) where
3
3
4−import Control.Arrow (first,(***))
5import Control.Applicative ((<$>),(<*>))
4import Control.Applicative ((<$>),(<*>))
5+import Control.Arrow (first,(***))
6import Control.Monad.State
6import Control.Monad.State
7import qualified Data.List as List
7import qualified Data.List as List
8import qualified Data.Map as Map
8import qualified Data.Map as Map
9import qualified Data.Set as Set
9import qualified Data.Set as Set
10+import Language.ECMAScript3.PrettyPrint
11+import Language.ECMAScript3.Syntax
10
12
11import Generate.JavaScript.Helpers
13import Generate.JavaScript.Helpers
12import qualified Generate.Cases as Case
14import qualified Generate.Cases as Case
13import qualified Generate.JavaScript.Ports as Port
15import qualified Generate.JavaScript.Ports as Port
14import qualified Generate.Markdown as MD
16import qualified Generate.Markdown as MD
17+import SourceSyntax.Annotation
18+import SourceSyntax.Expression
15import qualified SourceSyntax.Helpers as Help
19import qualified SourceSyntax.Helpers as Help
16import SourceSyntax.Literal
20import SourceSyntax.Literal
17−import SourceSyntax.Pattern as Pattern
18−import SourceSyntax.Location
19−import SourceSyntax.Expression
20import SourceSyntax.Module
21import SourceSyntax.Module
21−import Language.ECMAScript3.Syntax
22+import qualified SourceSyntax.Pattern as P
22−import Language.ECMAScript3.PrettyPrint
23+import SourceSyntax.PrettyPrint (renderPretty)
24+import qualified SourceSyntax.Variable as V
23import qualified Transform.SafeNames as MakeSafe
25import qualified Transform.SafeNames as MakeSafe
24
26
25varDecl :: String -> Expression () -> VarDecl ()
27varDecl :: String -> Expression () -> VarDecl ()
@@ -50,10 +52,10 @@ literal lit =
50 FloatNum n -> NumLit () n
52 FloatNum n -> NumLit () n
51 Boolean b -> BoolLit () b
53 Boolean b -> BoolLit () b
52
54
53−expression :: LExpr -> State Int (Expression ())
55+expression :: Expr -> State Int (Expression ())
54−expression (L span expr) =
56+expression (A region expr) =
55 case expr of
57 case expr of
56− Var x -> return $ ref x
58+ Var (V.Raw x) -> return $ ref x
57 Literal lit -> return $ literal lit
59 Literal lit -> return $ literal lit
58
60
59 Range lo hi ->
61 Range lo hi ->
@@ -93,9 +95,9 @@ expression (L span expr) =
93 Map.toList . Map.filter (not . null) $ Map.map tail fs
95 Map.toList . Map.filter (not . null) $ Map.map tail fs
94 visible fs = map (first prop) . Map.toList $ Map.map head fs
96 visible fs = map (first prop) . Map.toList $ Map.map head fs
95
97
96− Binop op e1 e2 -> binop span op e1 e2
98+ Binop op e1 e2 -> binop region op e1 e2
97
99
98− Lambda p e@(L s _) ->
100+ Lambda p e@(A ann _) ->
99 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
101 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
100 body' <- expression body
102 body' <- expression body
101 return $ case length args < 2 || length args > 9 of
103 return $ case length args < 2 || length args > 9 of
@@ -104,13 +106,14 @@ expression (L span expr) =
104 where
106 where
105 depattern (args, body) pattern =
107 depattern (args, body) pattern =
106 case pattern of
108 case pattern of
107− PVar x -> return (args ++ [x], body)
109+ P.Var x -> return (args ++ [x], body)
108 _ -> do arg <- Case.newVar
110 _ -> do arg <- Case.newVar
111+ return ( args ++ [arg]
109− return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
112+ , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))
110
113
111 (patterns, innerBody) = collect [p] e
114 (patterns, innerBody) = collect [p] e
112
115
113− collect patterns lexpr@(L _ expr) =
116+ collect patterns lexpr@(A _ expr) =
114 case expr of
117 case expr of
115 Lambda p e -> collect (p:patterns) e
118 Lambda p e -> collect (p:patterns) e
116 _ -> (patterns, lexpr)
119 _ -> (patterns, lexpr)
@@ -127,7 +130,7 @@ expression (L span expr) =
127 (func, args) = getArgs e1 [e2]
130 (func, args) = getArgs e1 [e2]
128 getArgs func args =
131 getArgs func args =
129 case func of
132 case func of
130− (L _ (App f arg)) -> getArgs f (arg : args)
133+ (A _ (App f arg)) -> getArgs f (arg : args)
131 _ -> (func, args)
134 _ -> (func, args)
132
135
133 Let defs e ->
136 Let defs e ->
@@ -139,9 +142,9 @@ expression (L span expr) =
139 MultiIf branches ->
142 MultiIf branches ->
140 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
143 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
141 return $ case last branches of
144 return $ case last branches of
142− (L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
145+ (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
143− (L _ (Literal (Boolean True)), _) -> safeIfs branches'
146+ (A _ (Literal (Boolean True)), _) -> safeIfs branches'
144− _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
147+ _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
145 where
148 where
146 safeIfs branches = ifs (init branches) (snd (last branches))
149 safeIfs branches = ifs (init branches) (snd (last branches))
147 ifs branches finally = foldr iff finally branches
150 ifs branches finally = foldr iff finally branches
@@ -151,10 +154,12 @@ expression (L span expr) =
151 do (tempVar,initialMatch) <- Case.toMatch cases
154 do (tempVar,initialMatch) <- Case.toMatch cases
152 (revisedMatch, stmt) <-
155 (revisedMatch, stmt) <-
153 case e of
156 case e of
157+ A _ (Var (V.Raw x)) ->
154− L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
158+ return (Case.matchSubst [(tempVar,x)] initialMatch, [])
159+ _ ->
155− _ -> do e' <- expression e
160+ do e' <- expression e
156− return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
161+ return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
157− match' <- match span revisedMatch
162+ match' <- match region revisedMatch
158 return (function [] (stmt ++ match') `call` [])
163 return (function [] (stmt ++ match') `call` [])
159
164
160 ExplicitList es ->
165 ExplicitList es ->
@@ -187,28 +192,28 @@ expression (L span expr) =
187 [ string name, Port.outgoing tipe, value' ]
192 [ string name, Port.outgoing tipe, value' ]
188
193
189definition :: Def -> State Int [Statement ()]
194definition :: Def -> State Int [Statement ()]
190−definition (Definition pattern expr@(L span _) _) = do
195+definition (Definition pattern expr@(A region _) _) = do
191 expr' <- expression expr
196 expr' <- expression expr
192 let assign x = varDecl x expr'
197 let assign x = varDecl x expr'
193 case pattern of
198 case pattern of
194− PVar x
199+ P.Var x
195 | Help.isOp x ->
200 | Help.isOp x ->
196 let op = LBracket () (ref "_op") (string x) in
201 let op = LBracket () (ref "_op") (string x) in
197 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
202 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
198 | otherwise ->
203 | otherwise ->
199 return [ VarDeclStmt () [ assign x ] ]
204 return [ VarDeclStmt () [ assign x ] ]
200
205
201− PRecord fields ->
206+ P.Record fields ->
202 let setField f = varDecl f (dotSep ["$",f]) in
207 let setField f = varDecl f (dotSep ["$",f]) in
203 return [ VarDeclStmt () (assign "$" : map setField fields) ]
208 return [ VarDeclStmt () (assign "$" : map setField fields) ]
204
209
205− PData name patterns | vars /= Nothing ->
210+ P.Data name patterns | vars /= Nothing ->
206 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
211 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
207 where
212 where
208 vars = getVars patterns
213 vars = getVars patterns
209 getVars patterns =
214 getVars patterns =
210 case patterns of
215 case patterns of
211− PVar x : rest -> (x:) `fmap` getVars rest
216+ P.Var x : rest -> (x:) `fmap` getVars rest
212 [] -> Just []
217 [] -> Just []
213 _ -> Nothing
218 _ -> Nothing
214
219
@@ -219,23 +224,23 @@ definition (Definition pattern expr@(L span _) _) = do
219
224
220 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
225 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
221 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
226 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)]
223
228
224 _ ->
229 _ ->
225 do defs' <- concat <$> mapM toDef vars
230 do defs' <- concat <$> mapM toDef vars
226 return (VarDeclStmt () [assign "$"] : defs')
231 return (VarDeclStmt () [assign "$"] : defs')
227 where
232 where
228− vars = Set.toList $ Pattern.boundVars pattern
233+ vars = P.boundVarList pattern
229− mkVar = L span . Var
234+ mkVar = A region . rawVar
230− toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
235+ toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
231− in definition $ Definition (PVar y) expr Nothing
236+ in definition $ Definition (P.Var y) expr Nothing
232
237
233−match :: SrcSpan -> Case.Match -> State Int [Statement ()]
238+match :: Region -> Case.Match -> State Int [Statement ()]
234−match span mtch =
239+match region mtch =
235 case mtch of
240 case mtch of
236 Case.Match name clauses mtch' ->
241 Case.Match name clauses mtch' ->
237− do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
242+ do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
238− mtch'' <- match span mtch'
243+ mtch'' <- match region mtch'
239 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
244 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
240 where
245 where
241 isLiteral p = case p of
246 isLiteral p = case p of
@@ -247,13 +252,13 @@ match span mtch =
247 | otherwise = e
252 | otherwise = e
248
253
249 Case.Fail ->
254 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)]) ]
251
256
252 Case.Break -> return [BreakStmt () Nothing]
257 Case.Break -> return [BreakStmt () Nothing]
253 Case.Other e ->
258 Case.Other e ->
254 do e' <- expression e
259 do e' <- expression e
255 return [ ret e' ]
260 return [ ret e' ]
256− Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
261+ Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
257 where
262 where
258 dropEnd acc [] = acc
263 dropEnd acc [] = acc
259 dropEnd acc (m:ms) =
264 dropEnd acc (m:ms) =
@@ -261,9 +266,9 @@ match span mtch =
261 Case.Other _ -> acc ++ [m]
266 Case.Other _ -> acc ++ [m]
262 _ -> dropEnd (acc ++ [m]) ms
267 _ -> dropEnd (acc ++ [m]) ms
263
268
264−clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
269+clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
265−clause span variable (Case.Clause value vars mtch) =
270+clause region variable (Case.Clause value vars mtch) =
266− (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
271+ (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
267 where
272 where
268 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
273 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
269 (isChar, pattern) =
274 (isChar, pattern) =
@@ -276,8 +281,8 @@ clause span variable (Case.Clause value vars mtch) =
276 [] -> name
281 [] -> name
277 is -> drop (last is + 1) name
282 is -> drop (last is + 1) name
278
283
279−flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
284+flattenLets :: [Def] -> Expr -> ([Def], Expr)
280−flattenLets defs lexpr@(L _ expr) =
285+flattenLets defs lexpr@(A _ expr) =
281 case expr of
286 case expr of
282 Let ds body -> flattenLets (defs ++ ds) body
287 Let ds body -> flattenLets (defs ++ ds) body
283 _ -> (defs, lexpr)
288 _ -> (defs, lexpr)
@@ -291,7 +296,8 @@ generate unsafeModule =
291 thisModule = dotSep ("_elm" : names modul ++ ["values"])
296 thisModule = dotSep ("_elm" : names modul ++ ["values"])
292 programStmts =
297 programStmts =
293 concat
298 concat
299+ [ [ ExprStmt () $ string "use strict" ]
294− [ setup (Just "_elm") (names modul ++ ["values"])
300+ , setup (Just "_elm") (names modul ++ ["values"])
295 , [ IfSingleStmt () thisModule (ret thisModule) ]
301 , [ IfSingleStmt () thisModule (ret thisModule) ]
296 , [ internalImports (List.intercalate "." (names modul)) ]
302 , [ internalImports (List.intercalate "." (names modul)) ]
297 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
303 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
@@ -324,8 +330,8 @@ generate unsafeModule =
324 Nothing -> tail . init $ List.inits path
330 Nothing -> tail . init $ List.inits path
325 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
331 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
326
332
327−binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
333+binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
328−binop span op e1 e2 =
334+binop region op e1 e2 =
329 case op of
335 case op of
330 "Basics.." ->
336 "Basics.." ->
331 do es <- mapM expression (e1 : collect [] e2)
337 do es <- mapM expression (e1 : collect [] e2)
@@ -338,7 +344,7 @@ binop span op e1 e2 =
338 do e1' <- expression e1
344 do e1' <- expression e1
339 e2' <- expression e2
345 e2' <- expression e2
340 return $ obj "_L.append" `call` [e1', e2']
346 return $ obj "_L.append" `call` [e1', e2']
341− "::" -> expression (L span (Data "::" [e1,e2]))
347+ "::" -> expression (A region (Data "::" [e1,e2]))
342 _ ->
348 _ ->
343 do e1' <- expression e1
349 do e1' <- expression e1
344 e2' <- expression e2
350 e2' <- expression e2
@@ -348,7 +354,7 @@ binop span op e1 e2 =
348 where
354 where
349 collect es e =
355 collect es e =
350 case e of
356 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
352 _ -> es ++ [e]
358 _ -> es ++ [e]
353
359
354 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
360 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
compiler/Generate/JavaScript/Ports.hs+22−16
@@ -32,7 +32,7 @@ incoming tipe =
32
32
33inc :: Type -> Expression () -> Expression ()
33inc :: Type -> Expression () -> Expression ()
34inc tipe x =
34inc tipe x =
35− case tipe of
35+ case tipe of
36 Lambda _ _ -> error "functions should not be allowed through input ports"
36 Lambda _ _ -> error "functions should not be allowed through input ports"
37 Var _ -> error "type variables should not be allowed through input ports"
37 Var _ -> error "type variables should not be allowed through input ports"
38 Data ctor []
38 Data ctor []
@@ -58,22 +58,26 @@ inc tipe x =
58 where
58 where
59 array = DotRef () x (var "map") <| incoming t
59 array = DotRef () x (var "map") <| incoming t
60
60
61+ Data ctor ts
61− Data ctor ts | Help.isTuple ctor -> check x JSArray tuple
62+ | Help.isTuple ctor -> check x JSArray tuple
62 where
63 where
63− tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values
64+ tuple = ObjectLit () $ (prop "ctor", string ctor) : values
64 values = zipWith convert [0..] ts
65 values = zipWith convert [0..] ts
65− convert n t = ( PropId () $ var ('_':show n)
66+ convert n t = ( prop ('_':show n)
66 , inc t (BracketRef () x (IntLit () n)))
67 , inc t (BracketRef () x (IntLit () n)))
67
68
69+ Data _ _ ->
68− Data _ _ -> error "bad ADT got to port generation code"
70+ error "bad ADT got to port generation code"
69
71
72+ Record _ (Just _) ->
70− Record _ (Just _) -> error "bad record got to port generation code"
73+ error "bad record got to port generation code"
71
74
75+ Record fields Nothing ->
72− Record fields Nothing -> check x (JSObject (map fst fields)) object
76+ check x (JSObject (map fst fields)) object
73 where
77 where
74− object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys
78+ object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
75 keys = map convert fields
79 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)))
77
81
78outgoing tipe =
82outgoing tipe =
79 case tipe of
83 case tipe of
@@ -114,14 +118,16 @@ out tipe x =
114 | ctor == "_List" ->
118 | ctor == "_List" ->
115 DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t
119 DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t
116
120
121+ Data ctor ts
117− Data ctor ts | Help.isTuple ctor ->
122+ | Help.isTuple ctor ->
118− ArrayLit () $ zipWith convert [0..] ts
119− where
120− convert n t = out t $ DotRef () x $ var ('_':show n)
123+ let convert n t = out t $ DotRef () x $ var ('_':show n)
121−
124+ in ArrayLit () $ zipWith convert [0..] ts
125+
126+ Data _ _ ->
122− Data _ _ -> error "bad ADT got to port generation code"
127+ error "bad ADT got to port generation code"
123
128
129+ Record _ (Just _) ->
124− Record _ (Just _) -> error "bad record got to port generation code"
130+ error "bad record got to port generation code"
125
131
126 Record fields Nothing ->
132 Record fields Nothing ->
127 ObjectLit () keys
133 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
3
3
4import qualified Data.Map as Map
4import qualified Data.Map as Map
5import qualified Control.Exception as E
5import qualified Control.Exception as E
6−import qualified Paths_Elm as Path
7import System.Exit
6import System.Exit
8import System.IO
7import System.IO
9import SourceSyntax.Module
8import SourceSyntax.Module
10import qualified Build.Interface as Interface
9import qualified Build.Interface as Interface
10+import Build.Utils (getDataFile)
11
11
12add :: Bool -> Module def -> Module def
12add :: Bool -> Module def -> Module def
13add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls
13add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls
@@ -30,8 +30,8 @@ prelude = string : text ++ map (\n -> (n, Hiding [])) modules
30interfaces :: Bool -> IO Interfaces
30interfaces :: Bool -> IO Interfaces
31interfaces noPrelude =
31interfaces noPrelude =
32 if noPrelude
32 if noPrelude
33− then return $ Map.empty
33+ then return Map.empty
34− else safeReadDocs =<< Path.getDataFileName "interfaces.data"
34+ else safeReadDocs =<< getDataFile "interfaces.data"
35
35
36safeReadDocs :: FilePath -> IO Interfaces
36safeReadDocs :: FilePath -> IO Interfaces
37safeReadDocs name =
37safeReadDocs name =
compiler/Parse/Binop.hs+17−16
@@ -1,10 +1,11 @@
1+{-# OPTIONS_GHC -W #-}
1module Parse.Binop (binops, OpTable) where
2module Parse.Binop (binops, OpTable) where
2
3
3import Control.Applicative ((<$>))
4import Control.Applicative ((<$>))
4−import Data.List (intercalate)
5+import qualified Data.List as List
5import qualified Data.Map as Map
6import qualified Data.Map as Map
6
7
7−import SourceSyntax.Location (merge)
8+import SourceSyntax.Annotation (merge)
8import qualified SourceSyntax.Expression as E
9import qualified SourceSyntax.Expression as E
9import SourceSyntax.Declaration (Assoc(..))
10import SourceSyntax.Declaration (Assoc(..))
10import Text.Parsec
11import Text.Parsec
@@ -16,13 +17,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table
16opAssoc :: OpTable -> String -> Assoc
17opAssoc :: OpTable -> String -> Assoc
17opAssoc table op = snd $ Map.findWithDefault (9,L) op table
18opAssoc table op = snd $ Map.findWithDefault (9,L) op table
18
19
19−hasLevel :: OpTable -> Int -> (String, E.LParseExpr) -> Bool
20+hasLevel :: OpTable -> Int -> (String, E.ParseExpr) -> Bool
20hasLevel table n (op,_) = opLevel table op == n
21hasLevel table n (op,_) = opLevel table op == n
21
22
22−binops :: IParser E.LParseExpr
23+binops :: IParser E.ParseExpr
23− -> IParser E.LParseExpr
24+ -> IParser E.ParseExpr
24 -> IParser String
25 -> IParser String
25− -> IParser E.LParseExpr
26+ -> IParser E.ParseExpr
26binops term last anyOp =
27binops term last anyOp =
27 do e <- term
28 do e <- term
28 table <- getState
29 table <- getState
@@ -38,9 +39,9 @@ binops term last anyOp =
38
39
39split :: OpTable
40split :: OpTable
40 -> Int
41 -> Int
41− -> E.LParseExpr
42+ -> E.ParseExpr
42− -> [(String, E.LParseExpr)]
43+ -> [(String, E.ParseExpr)]
43− -> IParser E.LParseExpr
44+ -> IParser E.ParseExpr
44split _ _ e [] = return e
45split _ _ e [] = return e
45split table n e eops = do
46split table n e eops = do
46 assoc <- getAssoc table n eops
47 assoc <- getAssoc table n eops
@@ -49,26 +50,26 @@ split table n e eops = do
49 case assoc of R -> joinR es ops
50 case assoc of R -> joinR es ops
50 _ -> joinL es ops
51 _ -> joinL es ops
51
52
52−splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)]
53+splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]
53− -> [IParser E.LParseExpr]
54+ -> [IParser E.ParseExpr]
54splitLevel table n e eops =
55splitLevel table n e eops =
55 case break (hasLevel table n) eops of
56 case break (hasLevel table n) eops of
56− (lops, (op,e'):rops) ->
57+ (lops, (_op,e'):rops) ->
57 split table (n+1) e lops : splitLevel table n e' rops
58 split table (n+1) e lops : splitLevel table n e' rops
58 (lops, []) -> [ split table (n+1) e lops ]
59 (lops, []) -> [ split table (n+1) e lops ]
59
60
60−joinL :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
61+joinL :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
61joinL [e] [] = return e
62joinL [e] [] = return e
62joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops
63joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops
63joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."
64joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."
64
65
65−joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
66+joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
66joinR [e] [] = return e
67joinR [e] [] = return e
67joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
68joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
68 return (merge a e (E.Binop op a e))
69 return (merge a e (E.Binop op a e))
69joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
70joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
70
71
71−getAssoc :: OpTable -> Int -> [(String,E.LParseExpr)] -> IParser Assoc
72+getAssoc :: OpTable -> Int -> [(String,E.ParseExpr)] -> IParser Assoc
72getAssoc table n eops
73getAssoc table n eops
73 | all (==L) assocs = return L
74 | all (==L) assocs = return L
74 | all (==R) assocs = return R
75 | all (==R) assocs = return R
@@ -79,5 +80,5 @@ getAssoc table n eops
79 assocs = map (opAssoc table . fst) levelOps
80 assocs = map (opAssoc table . fst) levelOps
80 msg problem =
81 msg problem =
81 concat [ "Conflicting " ++ problem ++ " for binary operators ("
82 concat [ "Conflicting " ++ problem ++ " for binary operators ("
82− , intercalate ", " (map fst eops), "). "
83+ , List.intercalate ", " (map fst eops), "). "
83 , "Consider adding parentheses to disambiguate." ]
84 , "Consider adding parentheses to disambiguate." ]
compiler/Parse/Expression.hs+67−66
@@ -5,45 +5,45 @@ import Data.List (foldl')
5import Text.Parsec hiding (newline,spaces)
5import Text.Parsec hiding (newline,spaces)
6import Text.Parsec.Indent
6import Text.Parsec.Indent
7
7
8+import Parse.Binop
8import Parse.Helpers
9import Parse.Helpers
10+import Parse.Literal
9import qualified Parse.Pattern as Pattern
11import qualified Parse.Pattern as Pattern
10import qualified Parse.Type as Type
12import qualified Parse.Type as Type
11−import Parse.Binop
12−import Parse.Literal
13
13
14−import SourceSyntax.Location as Location
14+import SourceSyntax.Annotation as Annotation
15−import SourceSyntax.Pattern hiding (tuple,list)
15+import qualified SourceSyntax.Pattern as P
16−import qualified SourceSyntax.Literal as Literal
16+import qualified SourceSyntax.Literal as L
17import SourceSyntax.Expression
17import SourceSyntax.Expression
18
18
19
19
20-------- Basic Terms --------
20-------- Basic Terms --------
21
21
22−varTerm :: IParser ParseExpr
22+varTerm :: IParser ParseExpr'
23varTerm = toVar <$> var <?> "variable"
23varTerm = toVar <$> var <?> "variable"
24
24
25−toVar :: String -> ParseExpr
25+toVar :: String -> ParseExpr'
26−toVar v = case v of "True" -> Literal (Literal.Boolean True)
26+toVar v = case v of "True" -> Literal (L.Boolean True)
27− "False" -> Literal (Literal.Boolean False)
27+ "False" -> Literal (L.Boolean False)
28− _ -> Var v
28+ _ -> rawVar v
29
29
30−accessor :: IParser ParseExpr
30+accessor :: IParser ParseExpr'
31accessor = do
31accessor = do
32 (start, lbl, end) <- located (try (string "." >> rLabel))
32 (start, lbl, end) <- located (try (string "." >> rLabel))
33− let loc e = Location.at start end e
33+ let loc e = Annotation.at start end e
34− return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
34+ return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))
35
35
36−negative :: IParser ParseExpr
36+negative :: IParser ParseExpr'
37negative = do
37negative = do
38 (start, nTerm, end) <-
38 (start, nTerm, end) <-
39 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
39 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
40− let loc e = Location.at start end e
40+ let loc e = Annotation.at start end e
41− return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)
41+ return (Binop "-" (loc $ Literal (L.IntNum 0)) nTerm)
42
42
43
43
44-------- Complex Terms --------
44-------- Complex Terms --------
45
45
46−listTerm :: IParser ParseExpr
46+listTerm :: IParser ParseExpr'
47listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> commaSep expr)
47listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> commaSep expr)
48 where
48 where
49 range = do
49 range = do
@@ -72,86 +72,87 @@ listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> co
72 string "}}"
72 string "}}"
73 return (span uid (length exprs), exprs ++ [e])
73 return (span uid (length exprs), exprs ++ [e])
74
74
75−parensTerm :: IParser LParseExpr
75+parensTerm :: IParser ParseExpr
76parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
76parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
77 where
77 where
78 opFn = do
78 opFn = do
79 (start, op, end) <- located anyOp
79 (start, op, end) <- located anyOp
80− let loc = Location.at start end
80+ let loc = Annotation.at start end
81− return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
81+ return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $
82− Binop op (loc $ Var "x") (loc $ Var "y")
82+ Binop op (loc $ rawVar "x") (loc $ rawVar "y")
83
83
84 tupleFn = do
84 tupleFn = do
85 let comma = char ',' <?> "comma ','"
85 let comma = char ',' <?> "comma ','"
86 (start, commas, end) <- located (comma >> many (whitespace >> comma))
86 (start, commas, end) <- located (comma >> many (whitespace >> comma))
87 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
87 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
88− loc = Location.at start end
88+ loc = Annotation.at start end
89 return $ foldr (\x e -> loc $ Lambda x e)
89 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)
91
91
92 parened = do
92 parened = do
93 (start, es, end) <- located (commaSep expr)
93 (start, es, end) <- located (commaSep expr)
94 return $ case es of
94 return $ case es of
95 [e] -> e
95 [e] -> e
96− _ -> Location.at start end (tuple es)
96+ _ -> Annotation.at start end (tuple es)
97
97
98−recordTerm :: IParser LParseExpr
98+recordTerm :: IParser ParseExpr
99recordTerm = brackets $ choice [ misc, addLocation record ]
99recordTerm = brackets $ choice [ misc, addLocation record ]
100+ where
100− where field = do
101+ field = do
101− label <- rLabel
102+ label <- rLabel
102− patterns <- spacePrefix Pattern.term
103+ patterns <- spacePrefix Pattern.term
103− padded equals
104+ padded equals
104− body <- expr
105+ body <- expr
105− return (label, makeFunction patterns body)
106+ return (label, makeFunction patterns body)
106
107
107− record = Record <$> commaSep field
108+ record = Record <$> commaSep field
108
109
109− change = do
110+ change = do
110− lbl <- rLabel
111+ lbl <- rLabel
111− padded (string "<-")
112+ padded (string "<-")
112− (,) lbl <$> expr
113+ (,) lbl <$> expr
113
114
114− remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
115+ remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
115
116
116− insert r = addLocation $ do
117+ insert r = addLocation $ do
117− string "|" >> whitespace
118+ string "|" >> whitespace
118− Insert r <$> rLabel <*> (padded equals >> expr)
119+ Insert r <$> rLabel <*> (padded equals >> expr)
119
120
120− modify r = addLocation
121+ modify r =
121− (string "|" >> whitespace >> Modify r <$> commaSep1 change)
122+ addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)
122
123
123− misc = try $ do
124+ misc = try $ do
124− record <- addLocation (Var <$> rLabel)
125+ record <- addLocation (rawVar <$> rLabel)
125− opt <- padded (optionMaybe (remove record))
126+ opt <- padded (optionMaybe (remove record))
126− case opt of
127+ case opt of
127− Just e -> try (insert e) <|> return e
128+ Just e -> try (insert e) <|> return e
128− Nothing -> try (insert record) <|> try (modify record)
129+ Nothing -> try (insert record) <|> try (modify record)
129
130
130
131
131−term :: IParser LParseExpr
132+term :: IParser ParseExpr
132term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
133term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
133 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
134 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
134 <?> "basic term (4, x, 'c', etc.)"
135 <?> "basic term (4, x, 'c', etc.)"
135
136
136-------- Applications --------
137-------- Applications --------
137
138
138−appExpr :: IParser LParseExpr
139+appExpr :: IParser ParseExpr
139appExpr = do
140appExpr = do
140 t <- term
141 t <- term
141 ts <- constrainedSpacePrefix term $ \str ->
142 ts <- constrainedSpacePrefix term $ \str ->
142 if null str then notFollowedBy (char '-') else return ()
143 if null str then notFollowedBy (char '-') else return ()
143 return $ case ts of
144 return $ case ts of
144 [] -> t
145 [] -> 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
146
147
147-------- Normal Expressions --------
148-------- Normal Expressions --------
148
149
149−binaryExpr :: IParser LParseExpr
150+binaryExpr :: IParser ParseExpr
150binaryExpr = binops appExpr lastExpr anyOp
151binaryExpr = binops appExpr lastExpr anyOp
151 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
152 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
152 <|> lambdaExpr
153 <|> lambdaExpr
153
154
154−ifExpr :: IParser ParseExpr
155+ifExpr :: IParser ParseExpr'
155ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
156ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
156 where
157 where
157 normal = do
158 normal = do
@@ -161,13 +162,13 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
161 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
162 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
162 elseBranch <- expr
163 elseBranch <- expr
163 return $ MultiIf [(bool, thenBranch),
164 return $ MultiIf [(bool, thenBranch),
164− (Location.sameAs elseBranch (Literal . Literal.Boolean $ True), elseBranch)]
165+ (Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]
165 multiIf = MultiIf <$> spaceSep1 iff
166 multiIf = MultiIf <$> spaceSep1 iff
166 where iff = do string "|" ; whitespace
167 where iff = do string "|" ; whitespace
167 b <- expr ; padded arrow
168 b <- expr ; padded arrow
168 (,) b <$> expr
169 (,) b <$> expr
169
170
170−lambdaExpr :: IParser LParseExpr
171+lambdaExpr :: IParser ParseExpr
171lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
172lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
172 whitespace
173 whitespace
173 args <- spaceSep1 Pattern.term
174 args <- spaceSep1 Pattern.term
@@ -178,14 +179,14 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
178defSet :: IParser [ParseDef]
179defSet :: IParser [ParseDef]
179defSet = block (do d <- def ; whitespace ; return d)
180defSet = block (do d <- def ; whitespace ; return d)
180
181
181−letExpr :: IParser ParseExpr
182+letExpr :: IParser ParseExpr'
182letExpr = do
183letExpr = do
183 reserved "let" ; whitespace
184 reserved "let" ; whitespace
184 defs <- defSet
185 defs <- defSet
185 padded (reserved "in")
186 padded (reserved "in")
186 Let defs <$> expr
187 Let defs <$> expr
187
188
188−caseExpr :: IParser ParseExpr
189+caseExpr :: IParser ParseExpr'
189caseExpr = do
190caseExpr = do
190 reserved "case"; e <- padded expr; reserved "of"; whitespace
191 reserved "case"; e <- padded expr; reserved "of"; whitespace
191 Case e <$> (with <|> without)
192 Case e <$> (with <|> without)
@@ -195,35 +196,35 @@ caseExpr = do
195 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
196 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
196 without = block (do c <- case_ ; whitespace ; return c)
197 without = block (do c <- case_ ; whitespace ; return c)
197
198
198−expr :: IParser LParseExpr
199+expr :: IParser ParseExpr
199expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
200expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
200 <|> lambdaExpr
201 <|> lambdaExpr
201 <|> binaryExpr
202 <|> binaryExpr
202 <?> "an expression"
203 <?> "an expression"
203
204
204−defStart :: IParser [Pattern]
205+defStart :: IParser [P.Pattern]
205defStart =
206defStart =
206 choice [ do p1 <- try Pattern.term
207 choice [ do p1 <- try Pattern.term
207 infics p1 <|> func p1
208 infics p1 <|> func p1
208− , func =<< (PVar <$> parens symOp)
209+ , func =<< (P.Var <$> parens symOp)
209 , (:[]) <$> Pattern.expr
210 , (:[]) <$> Pattern.expr
210 ] <?> "the definition of a variable (x = ...)"
211 ] <?> "the definition of a variable (x = ...)"
211 where
212 where
212 func pattern =
213 func pattern =
213 case pattern of
214 case pattern of
214− PVar _ -> (pattern:) <$> spacePrefix Pattern.term
215+ P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
215 _ -> do try (lookAhead (whitespace >> string "="))
216 _ -> do try (lookAhead (whitespace >> string "="))
216 return [pattern]
217 return [pattern]
217
218
218 infics p1 = do
219 infics p1 = do
219 o:p <- try (whitespace >> anyOp)
220 o:p <- try (whitespace >> anyOp)
220 p2 <- (whitespace >> Pattern.term)
221 p2 <- (whitespace >> Pattern.term)
221− return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
222+ return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
222− else [ PVar (o:p), p1, p2 ]
223+ else [ P.Var (o:p), p1, p2 ]
223
224
224−makeFunction :: [Pattern] -> LParseExpr -> LParseExpr
225+makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr
225−makeFunction args body@(L s _) =
226+makeFunction args body@(A ann _) =
226− foldr (\arg body' -> L s $ Lambda arg body') body args
227+ foldr (\arg body' -> A ann $ Lambda arg body') body args
227
228
228definition :: IParser ParseDef
229definition :: IParser ParseDef
229definition = withPos $ do
230definition = withPos $ do
compiler/Parse/Helpers.hs+16−12
@@ -14,12 +14,13 @@ import Text.Parsec hiding (newline,spaces,State)
14import Text.Parsec.Indent
14import Text.Parsec.Indent
15import qualified Text.Parsec.Token as T
15import qualified Text.Parsec.Token as T
16
16
17+import SourceSyntax.Annotation as Annotation
18+import SourceSyntax.Declaration (Assoc)
19+import SourceSyntax.Expression
17import SourceSyntax.Helpers as Help
20import SourceSyntax.Helpers as Help
18import SourceSyntax.Literal as Literal
21import SourceSyntax.Literal as Literal
19−import SourceSyntax.Location as Location
20−import SourceSyntax.Expression
21import SourceSyntax.PrettyPrint
22import SourceSyntax.PrettyPrint
22−import SourceSyntax.Declaration (Assoc)
23+import SourceSyntax.Variable as Variable
23
24
24reserveds = [ "if", "then", "else"
25reserveds = [ "if", "then", "else"
25 , "case", "of"
26 , "case", "of"
@@ -171,7 +172,8 @@ betwixt a b c = do char a ; out <- c
171 char b <?> "closing '" ++ [b] ++ "'" ; return out
172 char b <?> "closing '" ++ [b] ++ "'" ; return out
172
173
173surround a z name p = do
174surround a z name p = do
175+ char a
174− char a ; v <- padded p
176+ v <- padded p
175 char z <?> unwords ["closing", name, show z]
177 char z <?> unwords ["closing", name, show z]
176 return v
178 return v
177
179
@@ -184,10 +186,10 @@ parens = surround '(' ')' "paren"
184brackets :: IParser a -> IParser a
186brackets :: IParser a -> IParser a
185brackets = surround '{' '}' "bracket"
187brackets = surround '{' '}' "bracket"
186
188
187−addLocation :: (Pretty a) => IParser a -> IParser (Location.Located a)
189+addLocation :: (Pretty a) => IParser a -> IParser (Annotation.Located a)
188addLocation expr = do
190addLocation expr = do
189 (start, e, end) <- located expr
191 (start, e, end) <- located expr
190− return (Location.at start end e)
192+ return (Annotation.at start end e)
191
193
192located :: IParser a -> IParser (SourcePos, a, SourcePos)
194located :: IParser a -> IParser (SourcePos, a, SourcePos)
193located p = do
195located p = do
@@ -196,10 +198,10 @@ located p = do
196 end <- getPosition
198 end <- getPosition
197 return (start, e, end)
199 return (start, e, end)
198
200
199−accessible :: IParser LParseExpr -> IParser LParseExpr
201+accessible :: IParser ParseExpr -> IParser ParseExpr
200accessible expr = do
202accessible expr = do
201 start <- getPosition
203 start <- getPosition
202− ce@(L _ e) <- expr
204+ ce@(A _ e) <- expr
203 let rest f = do
205 let rest f = do
204 let dot = char '.' >> notFollowedBy (char '.')
206 let dot = char '.' >> notFollowedBy (char '.')
205 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
207 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
@@ -208,10 +210,12 @@ accessible expr = do
208 Just _ -> accessible $ do
210 Just _ -> accessible $ do
209 v <- var <?> "field access (e.g. List.map)"
211 v <- var <?> "field access (e.g. List.map)"
210 end <- getPosition
212 end <- getPosition
211− return (Location.at start end (f v))
213+ return (Annotation.at start end (f v))
214+ case e of
215+ Var (Variable.Raw (c:cs))
212− case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
216+ | isUpper c -> rest (\v -> rawVar (c:cs ++ '.':v))
213− | otherwise -> rest (Access ce)
217+ | otherwise -> rest (Access ce)
214− _ -> rest (Access ce)
218+ _ -> rest (Access ce)
215
219
216
220
217spaces :: IParser String
221spaces :: 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 #-}
2module Parse.Literal (literal) where
2module Parse.Literal (literal) where
3
3
4import Control.Applicative ((<$>))
4import Control.Applicative ((<$>))
@@ -7,16 +7,34 @@ import Parse.Helpers
7import SourceSyntax.Literal
7import SourceSyntax.Literal
8
8
9literal :: IParser Literal
9literal :: IParser Literal
10−literal = num <|> (Str <$> str) <|> (Chr <$> chr)
10+literal = num <|> (Str <$> str) <|> (Chr <$> chr) <?> "literal"
11
11
12num :: IParser Literal
12num :: IParser Literal
13−num = fmap toLit (preNum <?> "number")
13+num = toLit <$> (number <?> "number")
14+ where
15+ toLit n
14− where toLit n | '.' `elem` n = FloatNum (read n)
16+ | any (`elem` ".eE") n = FloatNum (read n)
15− | otherwise = IntNum (read n)
17+ | otherwise = IntNum (read n)
16− preNum = concat <$> sequence [ option "" minus, many1 digit, option "" postNum ]
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
17− postNum = do try $ lookAhead (string "." >> digit)
31+ try $ lookAhead (string "." >> digit)
18− string "."
32+ string "."
19− ('.':) <$> many1 digit
33+ n <- many1 digit
20− minus = try $ do string "-"
34+ return ('.' : n)
35+
36+ exponent = do
37+ string "e" <|> string "E"
38+ op <- option "" (string "+" <|> string "-")
21− lookAhead digit
39+ n <- many1 digit
22− return "-"
40+ return ('e' : op ++ n)
compiler/Parse/Module.hs+15−10
@@ -8,7 +8,7 @@ import Parse.Helpers
8import SourceSyntax.Module (ImportMethod(..), Imports)
8import SourceSyntax.Module (ImportMethod(..), Imports)
9
9
10varList :: IParser [String]
10varList :: IParser [String]
11−varList = parens $ commaSep1 (var <|> parens symOp)
11+varList = commaSep1 (var <|> parens symOp)
12
12
13getModuleName :: String -> Maybe String
13getModuleName :: String -> Maybe String
14getModuleName source =
14getModuleName source =
@@ -27,7 +27,7 @@ moduleDef = do
27 whitespace
27 whitespace
28 names <- dotSep1 capVar <?> "name of module"
28 names <- dotSep1 capVar <?> "name of module"
29 whitespace
29 whitespace
30− exports <- option [] varList
30+ exports <- option [] (parens varList)
31 whitespace <?> "reserved word 'where'"
31 whitespace <?> "reserved word 'where'"
32 reserved "where"
32 reserved "where"
33 return (names, exports)
33 return (names, exports)
@@ -38,17 +38,22 @@ imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
38import' :: IParser (String, ImportMethod)
38import' :: IParser (String, ImportMethod)
39import' =
39import' =
40 do reserved "import"
40 do reserved "import"
41− whitespace
42− open <- optionMaybe (reserved "open")
43 whitespace
41 whitespace
44 name <- intercalate "." <$> dotSep1 capVar
42 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
49 where
44 where
45+ method :: IParser ImportMethod
46+ method = try $ do whitespace
47+ as' <|> importing'
48+
50 as' :: IParser ImportMethod
49 as' :: IParser ImportMethod
50+ as' = do
51+ reserved "as"
52+ whitespace
51− as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
53+ As <$> capVar <?> "alias for module"
52
54
53 importing' :: IParser ImportMethod
55 importing' :: IParser ImportMethod
56+ importing' =
57+ parens (choice [ const (Hiding []) <$> string ".."
58+ , Importing <$> varList
54− importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"
59+ ] <?> "listing of imported values (x,y,z)")
compiler/Parse/Pattern.hs+29−27
@@ -3,57 +3,59 @@ module Parse.Pattern (term, expr) where
3
3
4import Control.Applicative ((<$>))
4import Control.Applicative ((<$>))
5import Data.Char (isUpper)
5import Data.Char (isUpper)
6−import Data.List (intercalate)
6+import qualified Data.List as List
7import Text.Parsec hiding (newline,spaces,State)
7import Text.Parsec hiding (newline,spaces,State)
8
8
9import Parse.Helpers
9import Parse.Helpers
10import Parse.Literal
10import Parse.Literal
11import SourceSyntax.Literal
11import SourceSyntax.Literal
12−import SourceSyntax.Pattern hiding (tuple, list)
13−import qualified SourceSyntax.Pattern as Pattern
12+import qualified SourceSyntax.Pattern as P
14
13
15−basic :: IParser Pattern
14+basic :: IParser P.Pattern
16basic = choice
15basic = choice
17− [ char '_' >> return PAnything
16+ [ char '_' >> return P.Anything
18 , do v <- var
17 , do v <- var
19 return $ case v of
18 return $ case v of
20− "True" -> PLiteral (Boolean True)
19+ "True" -> P.Literal (Boolean True)
21− "False" -> PLiteral (Boolean False)
20+ "False" -> P.Literal (Boolean False)
22− c:_ | isUpper c -> PData v []
21+ c:_ | isUpper c -> P.Data v []
23− _ -> PVar v
22+ _ -> P.Var v
24− , PLiteral <$> literal
23+ , P.Literal <$> literal
25 ]
24 ]
26
25
27−asPattern :: Pattern -> IParser Pattern
26+asPattern :: P.Pattern -> IParser P.Pattern
28asPattern pattern = do
27asPattern pattern = do
29 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
28 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
30 return $ case var of
29 return $ case var of
31− Just v -> PAlias v pattern
30+ Just v -> P.Alias v pattern
32 Nothing -> pattern
31 Nothing -> pattern
33
32
34−record :: IParser Pattern
33+record :: IParser P.Pattern
35−record = PRecord <$> brackets (commaSep1 lowVar)
34+record = P.Record <$> brackets (commaSep1 lowVar)
36
35
37−tuple :: IParser Pattern
36+tuple :: IParser P.Pattern
37+tuple = do
38−tuple = do ps <- parens (commaSep expr)
38+ ps <- parens (commaSep expr)
39− return $ case ps of { [p] -> p; _ -> Pattern.tuple ps }
39+ return $ case ps of
40+ [p] -> p
41+ _ -> P.tuple ps
40
42
41−list :: IParser Pattern
43+list :: IParser P.Pattern
42−list = Pattern.list <$> braces (commaSep expr)
44+list = P.list <$> braces (commaSep expr)
43
45
44−term :: IParser Pattern
46+term :: IParser P.Pattern
45term =
47term =
46 (choice [ record, tuple, list, basic ]) <?> "pattern"
48 (choice [ record, tuple, list, basic ]) <?> "pattern"
47
49
48−patternConstructor :: IParser Pattern
50+patternConstructor :: IParser P.Pattern
49patternConstructor = do
51patternConstructor = do
50− v <- intercalate "." <$> dotSep1 capVar
52+ v <- List.intercalate "." <$> dotSep1 capVar
51 case v of
53 case v of
52− "True" -> return $ PLiteral (Boolean True)
54+ "True" -> return $ P.Literal (Boolean True)
53− "False" -> return $ PLiteral (Boolean False)
55+ "False" -> return $ P.Literal (Boolean False)
54− _ -> PData v <$> spacePrefix term
56+ _ -> P.Data v <$> spacePrefix term
55
57
56−expr :: IParser Pattern
58+expr :: IParser P.Pattern
57expr = do
59expr = do
58 patterns <- consSep1 (patternConstructor <|> term)
60 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
20
20
21data ParsePort
21data ParsePort
22 = PPAnnotation String T.Type
22 = PPAnnotation String T.Type
23− | PPDef String Expr.LParseExpr
23+ | PPDef String Expr.ParseExpr
24 deriving (Show)
24 deriving (Show)
25
25
26data Port
26data Port
27− = Out String Expr.LExpr T.Type
27+ = Out String Expr.Expr T.Type
28 | In String T.Type
28 | In String T.Type
29 deriving (Show)
29 deriving (Show)
30
30
compiler/SourceSyntax/Expression.hs+88−62
@@ -11,50 +11,55 @@ module SourceSyntax.Expression where
11import SourceSyntax.PrettyPrint
11import SourceSyntax.PrettyPrint
12import Text.PrettyPrint as P
12import Text.PrettyPrint as P
13import qualified SourceSyntax.Helpers as Help
13import qualified SourceSyntax.Helpers as Help
14−import qualified SourceSyntax.Location as Location
14+import qualified SourceSyntax.Annotation as Annotation
15import qualified SourceSyntax.Pattern as Pattern
15import qualified SourceSyntax.Pattern as Pattern
16import qualified SourceSyntax.Type as SrcType
16import qualified SourceSyntax.Type as SrcType
17import qualified SourceSyntax.Literal as Literal
17import qualified SourceSyntax.Literal as Literal
18+import qualified SourceSyntax.Variable as Variable
18
19
19---- GENERAL AST ----
20---- GENERAL AST ----
20
21
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−
27{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
22{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
28"type holes" that allow us to enrich the AST with additional information as we
23"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
24+move through the compilation process. The type holes are used to represent:
30−structural changes in the types. The only type hole right now is:
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.
31
32
32− def: Parsing allows two kinds of definitions (type annotations or definitions),
33+ var: Representation of variables. Starts as strings, but is later enriched
33− but later checks will see that they are well formed and combine them.
34+ with information about what module a variable came from.
34
35
35-}
36-}
37+type GeneralExpr annotation definition variable =
38+ Annotation.Annotated annotation (GeneralExpr' annotation definition variable)
39+
36−data Expr' def
40+data GeneralExpr' ann def var
37 = Literal Literal.Literal
41 = Literal Literal.Literal
38− | Var String
42+ | Var var
39− | Range (LExpr' def) (LExpr' def)
43+ | Range (GeneralExpr ann def var) (GeneralExpr ann def var)
40− | ExplicitList [LExpr' def]
44+ | ExplicitList [GeneralExpr ann def var]
41− | Binop String (LExpr' def) (LExpr' def)
45+ | Binop String (GeneralExpr ann def var) (GeneralExpr ann def var)
42− | Lambda Pattern.Pattern (LExpr' def)
46+ | Lambda Pattern.Pattern (GeneralExpr ann def var)
43− | App (LExpr' def) (LExpr' def)
47+ | App (GeneralExpr ann def var) (GeneralExpr ann def var)
44− | MultiIf [(LExpr' def,LExpr' def)]
48+ | MultiIf [(GeneralExpr ann def var,GeneralExpr ann def var)]
45− | Let [def] (LExpr' def)
49+ | Let [def] (GeneralExpr ann def var)
46− | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
50+ | Case (GeneralExpr ann def var) [(Pattern.Pattern, GeneralExpr ann def var)]
47− | Data String [LExpr' def]
51+ | Data String [GeneralExpr ann def var]
48− | Access (LExpr' def) String
52+ | Access (GeneralExpr ann def var) String
49− | Remove (LExpr' def) String
53+ | Remove (GeneralExpr ann def var) String
50− | Insert (LExpr' def) String (LExpr' def)
54+ | Insert (GeneralExpr ann def var) String (GeneralExpr ann def var)
51− | Modify (LExpr' def) [(String, LExpr' def)]
55+ | Modify (GeneralExpr ann def var) [(String, GeneralExpr ann def var)]
52− | Record [(String, LExpr' def)]
56+ | Record [(String, GeneralExpr ann def var)]
53− | Markdown String String [LExpr' def]
57+ | Markdown String String [GeneralExpr ann def var]
54 -- for type checking and code gen only
58 -- for type checking and code gen only
55 | PortIn String SrcType.Type
59 | PortIn String SrcType.Type
56− | PortOut String SrcType.Type (LExpr' def)
60+ | PortOut String SrcType.Type (GeneralExpr ann def var)
57 | GLShader String String Literal.GLShaderTipe
61 | GLShader String String Literal.GLShaderTipe
62+ deriving (Show)
58
63
59
64
60---- SPECIALIZED ASTs ----
65---- SPECIALIZED ASTs ----
@@ -63,81 +68,100 @@ data Expr' def
63annotations and definitions, which is how they appear in source code and how
68annotations and definitions, which is how they appear in source code and how
64they are parsed.
69they are parsed.
65-}
70-}
66−type ParseExpr = Expr' ParseDef
71+type ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw
67−type LParseExpr = LExpr' ParseDef
72+type ParseExpr' = GeneralExpr' Annotation.Region ParseDef Variable.Raw
68
73
69data ParseDef
74data ParseDef
70− = Def Pattern.Pattern LParseExpr
75+ = Def Pattern.Pattern ParseExpr
71 | TypeAnnotation String SrcType.Type
76 | TypeAnnotation String SrcType.Type
72− deriving (Show)
77+ deriving (Show)
73
78
74{-| "Normal" expressions. When the compiler checks that type annotations and
79{-| "Normal" expressions. When the compiler checks that type annotations and
75ports are all paired with definitions in the appropriate order, it collapses
80ports are all paired with definitions in the appropriate order, it collapses
76them into a Def that is easier to work with in later phases of compilation.
81them into a Def that is easier to work with in later phases of compilation.
77-}
82-}
78−type LExpr = LExpr' Def
83+type Expr = GeneralExpr Annotation.Region Def Variable.Raw
79−type Expr = Expr' Def
84+type Expr' = GeneralExpr' Annotation.Region Def Variable.Raw
80
85
81−data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)
86+data Def = Definition Pattern.Pattern Expr (Maybe SrcType.Type)
82 deriving (Show)
87 deriving (Show)
83
88
84
89
90+
85---- UTILITIES ----
91---- UTILITIES ----
86
92
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
88tuple es = Data ("_Tuple" ++ show (length es)) es
97tuple es = Data ("_Tuple" ++ show (length es)) es
89
98
90−delist :: LExpr' def -> [LExpr' def]
99+delist :: GeneralExpr ann def var -> [GeneralExpr ann def var]
91−delist (Location.L _ (Data "::" [h,t])) = h : delist t
100+delist (Annotation.A _ (Data "::" [h,t])) = h : delist t
92delist _ = []
101delist _ = []
93
102
94saveEnvName :: String
103saveEnvName :: String
95saveEnvName = "_save_the_environment!!!"
104saveEnvName = "_save_the_environment!!!"
96
105
97−dummyLet :: Pretty def => [def] -> LExpr' def
106+dummyLet :: (Pretty def) => [def] -> GeneralExpr Annotation.Region def Variable.Raw
98dummyLet defs =
107dummyLet defs =
99− Location.none $ Let defs (Location.none $ Var saveEnvName)
108+ Annotation.none $ Let defs (Annotation.none $ rawVar saveEnvName)
100
109
101−instance Pretty def => Show (Expr' def) where
110+instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where
102− show = render . pretty
103−
104−instance Pretty def => Pretty (Expr' def) where
105 pretty expr =
111 pretty expr =
106 case expr of
112 case expr of
107 Literal lit -> pretty lit
113 Literal lit -> pretty lit
114+
108− Var x -> variable x
115+ Var x -> pretty x
116+
109 Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
117 Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
118+
110 ExplicitList es -> P.brackets (commaCat (map pretty es))
119 ExplicitList es -> P.brackets (commaCat (map pretty es))
120+
111− Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->
121+ Binop "-" (Annotation.A _ (Literal (Literal.IntNum 0))) e ->
112 P.text "-" <> prettyParens e
122 P.text "-" <> prettyParens e
123+
113 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
124 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
125+ where
114− where op' = if Help.isOp op then op else "`" ++ op ++ "`"
126+ op' = if Help.isOp op then op else "`" ++ op ++ "`"
127+
115 Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
128 Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
116 where
129 where
117− (ps,body) = collectLambdas (Location.none $ Lambda p e)
130+ (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)
118 args = P.sep (map Pattern.prettyParens ps)
131 args = P.sep (map Pattern.prettyParens ps)
132+
119 App _ _ -> P.hang func 2 (P.sep args)
133 App _ _ -> P.hang func 2 (P.sep args)
134+ where
120− where func:args = map prettyParens (collectApps (Location.none expr))
135+ func:args = map prettyParens (collectApps (Annotation.A undefined expr))
136+
121− MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
137+ MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
122 where
138 where
123 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
139 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
140+
124 Let defs e ->
141 Let defs e ->
125 P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
142 P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
126 , P.text "in" <+> pretty e ]
143 , P.text "in" <+> pretty e ]
144+
127 Case e pats ->
145 Case e pats ->
128 P.hang pexpr 2 (P.vcat (map pretty' pats))
146 P.hang pexpr 2 (P.vcat (map pretty' pats))
129 where
147 where
130 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
148 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
131 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
149 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
150+
132 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
151 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
133 Data "[]" [] -> P.text "[]"
152 Data "[]" [] -> P.text "[]"
134 Data name es
153 Data name es
135 | Help.isTuple name -> P.parens (commaCat (map pretty es))
154 | Help.isTuple name -> P.parens (commaCat (map pretty es))
136 | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
155 | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
156+
137 Access e x -> prettyParens e <> P.text "." <> variable x
157 Access e x -> prettyParens e <> P.text "." <> variable x
158+
138 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
159 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
160+
139− Insert (Location.L _ (Remove e y)) x v ->
161+ Insert (Annotation.A _ (Remove e y)) x v ->
140− P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
162+ P.braces $ P.hsep [ pretty e, P.text "-", variable y, P.text "|"
163+ , variable x, P.equals, pretty v ]
164+
141 Insert e x v ->
165 Insert e x v ->
142 P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
166 P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
143
167
@@ -178,21 +202,23 @@ instance Pretty Def where
178 Nothing -> P.empty
202 Nothing -> P.empty
179 Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
203 Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
180
204
181−collectApps :: LExpr' def -> [LExpr' def]
205+collectApps :: GeneralExpr ann def var -> [GeneralExpr ann def var]
182−collectApps lexpr@(Location.L _ expr) =
206+collectApps annExpr@(Annotation.A _ expr) =
183 case expr of
207 case expr of
184 App a b -> collectApps a ++ [b]
208 App a b -> collectApps a ++ [b]
185− _ -> [lexpr]
209+ _ -> [annExpr]
186
210
187−collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)
211+collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)
188−collectLambdas lexpr@(Location.L _ expr) =
212+collectLambdas lexpr@(Annotation.A _ expr) =
189 case expr of
213 case expr of
190− Lambda pattern body -> (pattern : ps, body')
214+ Lambda pattern body ->
191− where (ps, body') = collectLambdas body
215+ let (ps, body') = collectLambdas body
216+ in (pattern : ps, body')
217+
192 _ -> ([], lexpr)
218 _ -> ([], lexpr)
193
219
194−prettyParens :: (Pretty def) => LExpr' def -> Doc
220+prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc
195−prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
221+prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)
196 where
222 where
197 needed =
223 needed =
198 case expr of
224 case expr of
compiler/SourceSyntax/Literal.hs+4−2
@@ -21,7 +21,8 @@ instance Pretty Literal where
21 Str s -> PP.text . show $ s
21 Str s -> PP.text . show $ s
22 Boolean bool -> PP.text (show bool)
22 Boolean bool -> PP.text (show bool)
23
23
24−data GLTipe = Int | Float | V3 | V4 | M4
24+data GLTipe = Int | Float | V3 | V4 | M4 | Texture
25+ deriving (Show)
25
26
26glTipeName :: GLTipe -> String
27glTipeName :: GLTipe -> String
27glTipeName Int = "Int"
28glTipeName Int = "Int"
@@ -29,10 +30,11 @@ glTipeName Float = "Float"
29glTipeName V3 = "MJS.V3"
30glTipeName V3 = "MJS.V3"
30glTipeName V4 = "MJS.V4"
31glTipeName V4 = "MJS.V4"
31glTipeName M4 = "MJS.M4x4"
32glTipeName M4 = "MJS.M4x4"
33+glTipeName Texture = "Graphics.WebGL.Texture"
32
34
33data GLShaderTipe = GLShaderTipe
35data GLShaderTipe = GLShaderTipe
34 { attribute :: Map String GLTipe
36 { attribute :: Map String GLTipe
35 , uniform :: Map String GLTipe
37 , uniform :: Map String GLTipe
36 , varying :: Map String GLTipe
38 , varying :: Map String GLTipe
37− }
39+ } deriving (Show)
38
40
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
7import Control.Applicative ((<$>), (<*>))
7import Control.Applicative ((<$>), (<*>))
8import Text.PrettyPrint as P
8import Text.PrettyPrint as P
9
9
10−import SourceSyntax.Expression (LExpr)
10+import SourceSyntax.Expression (Expr)
11import SourceSyntax.Declaration
11import SourceSyntax.Declaration
12import SourceSyntax.PrettyPrint
12import SourceSyntax.PrettyPrint
13import SourceSyntax.Type
13import SourceSyntax.Type
@@ -30,12 +30,12 @@ instance (Pretty def) => Pretty (Module def) where
30 where
30 where
31 prettyDecls = P.sep $ map pretty decls
31 prettyDecls = P.sep $ map pretty decls
32
32
33− modul = P.text "module" <+> moduleName <+> where'
33+ modul = P.text "module" <+> moduleName <+> prettyExports <+> P.text "where"
34 moduleName = P.text $ List.intercalate "." modNames
34 moduleName = P.text $ List.intercalate "." modNames
35− where' =
35+ prettyExports =
36 case exports of
36 case exports of
37− [] -> P.text "where"
37+ [] -> P.empty
38− _ -> P.parens (commaCat $ map P.text exports) <+> P.text "where"
38+ _ -> P.parens . commaCat $ map P.text exports
39
39
40 prettyImports = P.vcat $ map prettyImport imports
40 prettyImports = P.vcat $ map prettyImport imports
41
41
@@ -72,7 +72,7 @@ data MetadataModule =
72 , path :: FilePath
72 , path :: FilePath
73 , exports :: [String]
73 , exports :: [String]
74 , imports :: [(String, ImportMethod)]
74 , imports :: [(String, ImportMethod)]
75− , program :: LExpr
75+ , program :: Expr
76 , types :: Map.Map String Type
76 , types :: Map.Map String Type
77 , fixities :: [(Assoc, Int, String)]
77 , fixities :: [(Assoc, Int, String)]
78 , aliases :: [Alias]
78 , aliases :: [Alias]
compiler/SourceSyntax/Pattern.hs+30−26
@@ -7,50 +7,54 @@ import Text.PrettyPrint as PP
7import qualified Data.Set as Set
7import qualified Data.Set as Set
8import SourceSyntax.Literal as Literal
8import SourceSyntax.Literal as Literal
9
9
10+data Pattern
10−data Pattern = PData String [Pattern]
11+ = Data String [Pattern]
11− | PRecord [String]
12+ | Record [String]
12− | PAlias String Pattern
13+ | Alias String Pattern
13− | PVar String
14+ | Var String
14− | PAnything
15+ | Anything
15− | PLiteral Literal.Literal
16+ | Literal Literal.Literal
16− deriving (Eq, Ord, Show)
17+ deriving (Eq, Ord, Show)
17
18
18cons :: Pattern -> Pattern -> Pattern
19cons :: Pattern -> Pattern -> Pattern
19−cons h t = PData "::" [h,t]
20+cons h t = Data "::" [h,t]
20
21
21nil :: Pattern
22nil :: Pattern
22−nil = PData "[]" []
23+nil = Data "[]" []
23
24
24list :: [Pattern] -> Pattern
25list :: [Pattern] -> Pattern
25list = foldr cons nil
26list = foldr cons nil
26
27
27tuple :: [Pattern] -> Pattern
28tuple :: [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
29
33
30boundVars :: Pattern -> Set.Set String
34boundVars :: Pattern -> Set.Set String
31boundVars pattern =
35boundVars pattern =
32 case pattern of
36 case pattern of
33− PVar x -> Set.singleton x
37+ Var x -> Set.singleton x
34− PAlias x p -> Set.insert x (boundVars p)
38+ Alias x p -> Set.insert x (boundVars p)
35− PData _ ps -> Set.unions (map boundVars ps)
39+ Data _ ps -> Set.unions (map boundVars ps)
36− PRecord fields -> Set.fromList fields
40+ Record fields -> Set.fromList fields
37− PAnything -> Set.empty
41+ Anything -> Set.empty
38− PLiteral _ -> Set.empty
42+ Literal _ -> Set.empty
39
43
40
44
41instance Pretty Pattern where
45instance Pretty Pattern where
42 pretty pattern =
46 pretty pattern =
43 case pattern of
47 case pattern of
44− PVar x -> variable x
48+ Var x -> variable x
45− PLiteral lit -> pretty lit
49+ Literal lit -> pretty lit
46− PRecord fs -> PP.braces (commaCat $ map variable fs)
50+ Record fs -> PP.braces (commaCat $ map variable fs)
47− PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x
51+ Alias x p -> prettyParens p <+> PP.text "as" <+> variable x
48− PAnything -> PP.text "_"
52+ Anything -> PP.text "_"
49− PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
53+ Data "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
50 where isCons = case hd of
54 where isCons = case hd of
51− PData "::" _ -> True
55+ Data "::" _ -> True
52 _ -> False
56 _ -> False
53− PData name ps ->
57+ Data name ps ->
54 if Help.isTuple name then
58 if Help.isTuple name then
55 PP.parens . commaCat $ map pretty ps
59 PP.parens . commaCat $ map pretty ps
56 else hsep (PP.text name : map prettyParens ps)
60 else hsep (PP.text name : map prettyParens ps)
@@ -60,6 +64,6 @@ prettyParens pattern = parensIf needsThem (pretty pattern)
60 where
64 where
61 needsThem =
65 needsThem =
62 case pattern of
66 case pattern of
63− PData name (_:_) | not (Help.isTuple name) -> True
67+ Data name (_:_) | not (Help.isTuple name) -> True
64− PAlias _ _ -> True
68+ Alias _ _ -> True
65 _ -> False
69 _ -> False
compiler/SourceSyntax/PrettyPrint.hs+5
@@ -10,11 +10,16 @@ class Pretty a where
10instance Pretty () where
10instance Pretty () where
11 pretty () = empty
11 pretty () = empty
12
12
13+renderPretty :: (Pretty a) => a -> String
14+renderPretty e = render (pretty e)
15+
13commaCat docs = cat (punctuate comma docs)
16commaCat docs = cat (punctuate comma docs)
14commaSep docs = sep (punctuate comma docs)
17commaSep docs = sep (punctuate comma docs)
15
18
19+parensIf :: Bool -> Doc -> Doc
16parensIf bool doc = if bool then parens doc else doc
20parensIf bool doc = if bool then parens doc else doc
17
21
22+variable :: String -> Doc
18variable x =
23variable x =
19 if Help.isOp x then parens (text x)
24 if Help.isOp x then parens (text x)
20 else text (reprime x)
25 else text (reprime x)
compiler/SourceSyntax/Type.hs+3−6
@@ -1,18 +1,18 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module SourceSyntax.Type where
2module SourceSyntax.Type where
3
3
4+import Control.Applicative ((<$>), (<*>))
4import Data.Binary
5import Data.Binary
5import qualified Data.Map as Map
6import qualified Data.Map as Map
6−import qualified SourceSyntax.Helpers as Help
7−import Control.Applicative ((<$>), (<*>))
8import SourceSyntax.PrettyPrint
7import SourceSyntax.PrettyPrint
8+import qualified SourceSyntax.Helpers as Help
9import Text.PrettyPrint as P
9import Text.PrettyPrint as P
10
10
11data Type = Lambda Type Type
11data Type = Lambda Type Type
12 | Var String
12 | Var String
13 | Data String [Type]
13 | Data String [Type]
14 | Record [(String,Type)] (Maybe String)
14 | Record [(String,Type)] (Maybe String)
15− deriving (Eq)
15+ deriving (Eq,Show)
16
16
17fieldMap :: [(String,a)] -> Map.Map String [a]
17fieldMap :: [(String,a)] -> Map.Map String [a]
18fieldMap fields =
18fieldMap fields =
@@ -27,9 +27,6 @@ listOf t = Data "_List" [t]
27tupleOf :: [Type] -> Type
27tupleOf :: [Type] -> Type
28tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
28tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
29
29
30−instance Show Type where
31− show = render . pretty
32−
33instance Pretty Type where
30instance Pretty Type where
34 pretty tipe =
31 pretty tipe =
35 case tipe of
32 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 #-}
2module Transform.Canonicalize (interface, metadataModule) where
2module Transform.Canonicalize (interface, metadataModule) where
3
3
4import Control.Arrow ((***))
4import Control.Arrow ((***))
5import Control.Applicative (Applicative,(<$>),(<*>))
5import Control.Applicative (Applicative,(<$>),(<*>))
6import Control.Monad.Identity
6import Control.Monad.Identity
7−import qualified Data.Traversable as T
7+import qualified Data.Either as Either
8+import qualified Data.List as List
8import qualified Data.Map as Map
9import qualified Data.Map as Map
9import qualified Data.Set as Set
10import qualified Data.Set as Set
10−import qualified Data.List as List
11+import qualified Data.Traversable as T
11−import qualified Data.Either as Either
12−import SourceSyntax.Module
12+import SourceSyntax.Annotation as A
13import SourceSyntax.Expression
13import SourceSyntax.Expression
14−import SourceSyntax.Location as Loc
14+import SourceSyntax.Module
15+import SourceSyntax.PrettyPrint (pretty)
15import qualified SourceSyntax.Pattern as P
16import qualified SourceSyntax.Pattern as P
16import qualified SourceSyntax.Type as Type
17import qualified SourceSyntax.Type as Type
18+import qualified SourceSyntax.Variable as Var
17import Text.PrettyPrint as P
19import Text.PrettyPrint as P
18
20
19interface :: String -> ModuleInterface -> ModuleInterface
21interface :: String -> ModuleInterface -> ModuleInterface
@@ -96,8 +98,7 @@ type Env = Map.Map String String
96
98
97extend :: Env -> P.Pattern -> Env
99extend :: Env -> P.Pattern -> Env
98extend env pattern = Map.union (Map.fromList (zip xs xs)) env
100extend env pattern = Map.union (Map.fromList (zip xs xs)) env
99− where xs = Set.toList (P.boundVars pattern)
101+ where xs = P.boundVarList pattern
100−
101
102
102replace :: String -> Env -> String -> Either String String
103replace :: String -> Env -> String -> Either String String
103replace variable env v =
104replace variable env v =
@@ -110,14 +111,18 @@ replace variable env v =
110 msg = if null matches then "" else
111 msg = if null matches then "" else
111 "\nClose matches include: " ++ List.intercalate ", " matches
112 "\nClose matches include: " ++ List.intercalate ", " matches
112
113
114+-- TODO: Var.Raw -> Var.Canonical
113−rename :: Env -> LExpr -> Either [Doc] LExpr
115+rename :: Env -> Expr -> Either [Doc] Expr
114−rename env (L s expr) =
116+rename env (A ann expr) =
115 let rnm = rename env
117 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+ ]
117 format = Either.either throw return
122 format = Either.either throw return
118− renameType' env = renameType (format . replace "variable" env)
123+ renameType' environ = renameType (format . replace "variable" environ)
119 in
124 in
120− L s <$>
125+ A ann <$>
121 case expr of
126 case expr of
122 Literal _ -> return expr
127 Literal _ -> return expr
123
128
@@ -155,7 +160,8 @@ rename env (L s expr) =
155 <*> rename env' body
160 <*> rename env' body
156 <*> T.traverse (renameType' env') mtipe
161 <*> T.traverse (renameType' env') mtipe
157
162
163+ -- TODO: Raw -> Canonical
158− Var x -> Var <$> format (replace "variable" env x)
164+ Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)
159
165
160 Data name es -> Data name <$> mapM rnm es
166 Data name es -> Data name <$> mapM rnm es
161
167
@@ -177,10 +183,10 @@ rename env (L s expr) =
177renamePattern :: Env -> P.Pattern -> Either String P.Pattern
183renamePattern :: Env -> P.Pattern -> Either String P.Pattern
178renamePattern env pattern =
184renamePattern env pattern =
179 case pattern of
185 case pattern of
180− P.PVar _ -> return pattern
186+ P.Var _ -> return pattern
181− P.PLiteral _ -> return pattern
187+ P.Literal _ -> return pattern
182− P.PRecord _ -> return pattern
188+ P.Record _ -> return pattern
183− P.PAnything -> return pattern
189+ P.Anything -> return pattern
184− P.PAlias x p -> P.PAlias x <$> renamePattern env p
190+ P.Alias x p -> P.Alias x <$> renamePattern env p
185− P.PData name ps -> P.PData <$> replace "pattern" env name
191+ P.Data name ps -> P.Data <$> replace "pattern" env name
186− <*> mapM (renamePattern env) ps
192+ <*> mapM (renamePattern env) ps
compiler/Transform/Check.hs+4−5
@@ -32,7 +32,7 @@ dupErr err x =
32
32
33duplicates :: [D.Declaration] -> [String]
33duplicates :: [D.Declaration] -> [String]
34duplicates decls =
34duplicates decls =
35− map msg (dups (portNames ++ concatMap getNames defPatterns)) ++
35+ map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
36 case mapM exprDups (portExprs ++ defExprs) of
36 case mapM exprDups (portExprs ++ defExprs) of
37 Left name -> [msg name]
37 Left name -> [msg name]
38 Right _ -> []
38 Right _ -> []
@@ -50,14 +50,13 @@ duplicates decls =
50 D.Out name expr _ -> (name, [expr])
50 D.Out name expr _ -> (name, [expr])
51 D.In name _ -> (name, [])
51 D.In name _ -> (name, [])
52
52
53− getNames = Set.toList . Pattern.boundVars
54−
55− exprDups :: E.LExpr -> Either String E.LExpr
53+ exprDups :: E.Expr -> Either String E.Expr
56 exprDups expr = Expr.crawlLet defsDups expr
54 exprDups expr = Expr.crawlLet defsDups expr
57
55
58 defsDups :: [E.Def] -> Either String [E.Def]
56 defsDups :: [E.Def] -> Either String [E.Def]
59 defsDups defs =
57 defsDups defs =
58+ let varsIn (E.Definition pattern _ _) = Pattern.boundVarList pattern in
60− case dups $ concatMap (\(E.Definition name _ _) -> getNames name) defs of
59+ case dups $ concatMap varsIn defs of
61 [] -> Right defs
60 [] -> Right defs
62 name:_ -> Left name
61 name:_ -> Left name
63
62
compiler/Transform/Declaration.hs+1−1
@@ -42,7 +42,7 @@ combineAnnotations = go
42
42
43 TypeAnnotation name tipe ->
43 TypeAnnotation name tipe ->
44 case defRest of
44 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' ->
46 do expr' <- exprCombineAnnotations expr
46 do expr' <- exprCombineAnnotations expr
47 let def' = E.Definition pat expr' (Just tipe)
47 let def' = E.Definition pat expr' (Just tipe)
48 (:) (D.Definition def') <$> go rest
48 (:) (D.Definition def') <$> go rest
compiler/Transform/Definition.hs+1−1
@@ -16,7 +16,7 @@ combineAnnotations = go
16
16
17 go defs =
17 go defs =
18 case defs of
18 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' ->
20 do expr' <- exprCombineAnnotations expr
20 do expr' <- exprCombineAnnotations expr
21 let def = Definition pat expr' (Just tipe)
21 let def = Definition pat expr' (Just tipe)
22 (:) def <$> go rest
22 (:) def <$> go rest
compiler/Transform/Expression.hs+15−13
@@ -2,17 +2,19 @@
2module Transform.Expression (crawlLet, checkPorts) where
2module Transform.Expression (crawlLet, checkPorts) where
3
3
4import Control.Applicative ((<$>),(<*>))
4import Control.Applicative ((<$>),(<*>))
5+import SourceSyntax.Annotation ( Annotated(A) )
5import SourceSyntax.Expression
6import SourceSyntax.Expression
6−import SourceSyntax.Location
7+import SourceSyntax.Type (Type)
7−import qualified SourceSyntax.Type as ST
8
8
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)
10crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
12crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
11
13
12−checkPorts :: (String -> ST.Type -> Either a ())
14+checkPorts :: (String -> Type -> Either a ())
13− -> (String -> ST.Type -> Either a ())
15+ -> (String -> Type -> Either a ())
14− -> LExpr
16+ -> Expr
15− -> Either a LExpr
17+ -> Either a Expr
16checkPorts inCheck outCheck expr =
18checkPorts inCheck outCheck expr =
17 crawl inCheck outCheck (mapM checkDef) expr
19 crawl inCheck outCheck (mapM checkDef) expr
18 where
20 where
@@ -20,15 +22,15 @@ checkPorts inCheck outCheck expr =
20 do _ <- checkPorts inCheck outCheck body
22 do _ <- checkPorts inCheck outCheck body
21 return def
23 return def
22
24
23−crawl :: (String -> ST.Type -> Either a ())
25+crawl :: (String -> Type -> Either a ())
24− -> (String -> ST.Type -> Either a ())
26+ -> (String -> Type -> Either a ())
25 -> ([def] -> Either a [def'])
27 -> ([def] -> Either a [def'])
26− -> LExpr' def
28+ -> GeneralExpr ann def var
27− -> Either a (LExpr' def')
29+ -> Either a (GeneralExpr ann def' var)
28crawl portInCheck portOutCheck defsTransform = go
30crawl portInCheck portOutCheck defsTransform = go
29 where
31 where
30− go (L srcSpan expr) =
32+ go (A srcSpan expr) =
31− L srcSpan <$>
33+ A srcSpan <$>
32 case expr of
34 case expr of
33 Var x -> return (Var x)
35 Var x -> return (Var x)
34 Lambda p e -> Lambda p <$> go e
36 Lambda p e -> Lambda p <$> go e
compiler/Transform/SafeNames.hs+19−18
@@ -1,43 +1,44 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Transform.SafeNames (metadataModule) where
2module Transform.SafeNames (metadataModule) where
3
3
4−import Control.Arrow (first, (***))
4+import Control.Arrow (first, (***))
5−import Data.List (intercalate)
5+import qualified Data.List as List
6−
7import qualified Data.Set as Set
6import qualified Data.Set as Set
8
7
9−import qualified Parse.Helpers as PHelp
8+import qualified Parse.Helpers as PHelp
9+import SourceSyntax.Annotation
10import SourceSyntax.Expression
10import SourceSyntax.Expression
11import qualified SourceSyntax.Helpers as SHelp
11import qualified SourceSyntax.Helpers as SHelp
12−import SourceSyntax.Location
13import SourceSyntax.Module
12import SourceSyntax.Module
14−import SourceSyntax.Pattern
13+import qualified SourceSyntax.Pattern as P
14+import qualified SourceSyntax.Variable as Variable
15
15
16var :: String -> String
16var :: String -> String
17−var = intercalate "." . map (dereserve . deprime) . SHelp.splitDots
17+var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots
18 where
18 where
19 deprime = map (\c -> if c == '\'' then '$' else c)
19 deprime = map (\c -> if c == '\'' then '$' else c)
20 dereserve x = case Set.member x PHelp.jsReserveds of
20 dereserve x = case Set.member x PHelp.jsReserveds of
21 False -> x
21 False -> x
22 True -> "$" ++ x
22 True -> "$" ++ x
23
23
24−pattern :: Pattern -> Pattern
24+pattern :: P.Pattern -> P.Pattern
25pattern pat =
25pattern pat =
26 case pat of
26 case pat of
27− PVar x -> PVar (var x)
27+ P.Var x -> P.Var (var x)
28− PLiteral _ -> pat
28+ P.Literal _ -> pat
29− PRecord fs -> PRecord (map var fs)
29+ P.Record fs -> P.Record (map var fs)
30− PAnything -> pat
30+ P.Anything -> pat
31− PAlias x p -> PAlias (var x) (pattern p)
31+ P.Alias x p -> P.Alias (var x) (pattern p)
32− PData name ps -> PData name (map pattern ps)
32+ P.Data name ps -> P.Data name (map pattern ps)
33
33
34+-- TODO: should be "normal expression" -> "expression for JS generation"
34−expression :: LExpr -> LExpr
35+expression :: Expr -> Expr
35−expression (L loc expr) =
36+expression (A ann expr) =
36 let f = expression in
37 let f = expression in
37− L loc $
38+ A ann $
38 case expr of
39 case expr of
39 Literal _ -> expr
40 Literal _ -> expr
40− Var x -> Var (var x)
41+ Var (Variable.Raw x) -> rawVar (var x)
41 Range e1 e2 -> Range (f e1) (f e2)
42 Range e1 e2 -> Range (f e1) (f e2)
42 ExplicitList es -> ExplicitList (map f es)
43 ExplicitList es -> ExplicitList (map f es)
43 Binop op e1 e2 -> Binop op (f e1) (f e2)
44 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
3
3
4import Control.Monad.State
4import Control.Monad.State
5import Control.Applicative ((<$>),(<*>))
5import Control.Applicative ((<$>),(<*>))
6+import qualified Data.Graph as Graph
6import qualified Data.Map as Map
7import qualified Data.Map as Map
8+import qualified Data.Maybe as Maybe
9+import qualified Data.Set as Set
10+import SourceSyntax.Annotation
7import SourceSyntax.Expression
11import SourceSyntax.Expression
8−import SourceSyntax.Location
9import qualified SourceSyntax.Pattern as P
12import qualified SourceSyntax.Pattern as P
10−import qualified Data.Graph as Graph
13+import qualified SourceSyntax.Variable as V
11−import qualified Data.Set as Set
12−import qualified Data.Maybe as Maybe
13
14
14ctors :: P.Pattern -> [String]
15ctors :: P.Pattern -> [String]
15ctors pattern =
16ctors pattern =
16 case pattern of
17 case pattern of
17− P.PVar _ -> []
18+ P.Var _ -> []
18− P.PAlias _ p -> ctors p
19+ P.Alias _ p -> ctors p
19− P.PData ctor ps -> ctor : concatMap ctors ps
20+ P.Data ctor ps -> ctor : concatMap ctors ps
20− P.PRecord _ -> []
21+ P.Record _ -> []
21− P.PAnything -> []
22+ P.Anything -> []
22− P.PLiteral _ -> []
23+ P.Literal _ -> []
23
24
24free :: String -> State (Set.Set String) ()
25free :: String -> State (Set.Set String) ()
25free x = modify (Set.insert x)
26free x = modify (Set.insert x)
@@ -27,15 +28,15 @@ free x = modify (Set.insert x)
27bound :: Set.Set String -> State (Set.Set String) ()
28bound :: Set.Set String -> State (Set.Set String) ()
28bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
29bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
29
30
30−sortDefs :: LExpr -> LExpr
31+sortDefs :: Expr -> Expr
31sortDefs expr = evalState (reorder expr) Set.empty
32sortDefs expr = evalState (reorder expr) Set.empty
32
33
33−reorder :: LExpr -> State (Set.Set String) LExpr
34+reorder :: Expr -> State (Set.Set String) Expr
34−reorder (L s expr) =
35+reorder (A ann expr) =
35− L s <$>
36+ A ann <$>
36 case expr of
37 case expr of
37 -- Be careful adding and restricting freeVars
38 -- Be careful adding and restricting freeVars
38− Var x -> free x >> return expr
39+ Var (V.Raw x) -> free x >> return expr
39
40
40 Lambda p e ->
41 Lambda p e ->
41 uncurry Lambda <$> bindingReorder (p,e)
42 uncurry Lambda <$> bindingReorder (p,e)
@@ -105,11 +106,11 @@ reorder (L s expr) =
105 bound (P.boundVars pattern)
106 bound (P.boundVars pattern)
106 mapM free (ctors pattern)
107 mapM free (ctors pattern)
107
108
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
109
110
110 return let'
111 return let'
111
112
112−bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)
113+bindingReorder :: (P.Pattern, Expr) -> State (Set.Set String) (P.Pattern, Expr)
113bindingReorder (pattern,expr) =
114bindingReorder (pattern,expr) =
114 do expr' <- reorder expr
115 do expr' <- reorder expr
115 bound (P.boundVars pattern)
116 bound (P.boundVars pattern)
compiler/Transform/Substitute.hs+7−5
@@ -2,14 +2,16 @@
2module Transform.Substitute (subst) where
2module Transform.Substitute (subst) where
3
3
4import Control.Arrow (second, (***))
4import Control.Arrow (second, (***))
5+import qualified Data.Set as Set
6+
7+import SourceSyntax.Annotation
5import SourceSyntax.Expression
8import SourceSyntax.Expression
6−import SourceSyntax.Location
7import qualified SourceSyntax.Pattern as Pattern
9import qualified SourceSyntax.Pattern as Pattern
8−import qualified Data.Set as Set
10+import qualified SourceSyntax.Variable as V
9
11
10−subst :: String -> Expr -> Expr -> Expr
12+subst :: String -> Expr' -> Expr' -> Expr'
11subst old new expr =
13subst 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
13 case expr of
15 case expr of
14 Range e1 e2 -> Range (f e1) (f e2)
16 Range e1 e2 -> Range (f e1) (f e2)
15 ExplicitList es -> ExplicitList (map f es)
17 ExplicitList es -> ExplicitList (map f es)
@@ -28,7 +30,7 @@ subst old new expr =
28 anyShadow =
30 anyShadow =
29 any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]
31 any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]
30
32
31− Var x -> if x == old then new else expr
33+ Var (V.Raw x) -> if x == old then new else expr
32 Case e cases -> Case (f e) $ map (second f) cases
34 Case e cases -> Case (f e) $ map (second f) cases
33 Data name es -> Data name (map f es)
35 Data name es -> Data name (map f es)
34 Access e x -> Access (f e) x
36 Access e x -> Access (f e) x
compiler/Type/Constrain/Declaration.hs+23−23
@@ -1,62 +1,62 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Declaration where
2module Type.Constrain.Declaration where
3
3
4+import qualified SourceSyntax.Annotation as A
4−import SourceSyntax.Declaration
5+import qualified SourceSyntax.Declaration as D
5import qualified SourceSyntax.Expression as E
6import qualified SourceSyntax.Expression as E
6−import qualified SourceSyntax.Location as L
7import qualified SourceSyntax.Pattern as P
7import qualified SourceSyntax.Pattern as P
8import qualified SourceSyntax.Type as T
8import qualified SourceSyntax.Type as T
9
9
10−toExpr :: [Declaration] -> [E.Def]
10+toExpr :: [D.Declaration] -> [E.Def]
11toExpr = concatMap toDefs
11toExpr = concatMap toDefs
12
12
13−toDefs :: Declaration -> [E.Def]
13+toDefs :: D.Declaration -> [E.Def]
14toDefs decl =
14toDefs decl =
15 case decl of
15 case decl of
16− Definition def -> [def]
16+ D.Definition def -> [def]
17
17
18− Datatype name tvars constructors -> concatMap toDefs' constructors
18+ D.Datatype name tvars constructors -> concatMap toDefs' constructors
19 where
19 where
20 toDefs' (ctor, tipes) =
20 toDefs' (ctor, tipes) =
21 let vars = take (length tipes) arguments
21 let vars = take (length tipes) arguments
22 tbody = T.Data name $ map T.Var tvars
22 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
24 in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
24 in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
25
25
26− TypeAlias name _ tipe@(T.Record fields ext) ->
26+ D.TypeAlias name _ tipe@(T.Record fields ext) ->
27 [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
27 [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
28 where
28 where
29 args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
29 args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
30
30
31− var = L.none . E.Var
31+ var = A.none . E.rawVar
32 vars = take (length args) arguments
32 vars = take (length args) arguments
33
33
34 efields = zip (map fst fields) (map var vars)
34 efields = zip (map fst fields) (map var vars)
35 record = case ext of
35 record = case ext of
36− Nothing -> L.none $ E.Record efields
36+ Nothing -> A.none $ E.Record efields
37− Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields
37+ Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
38
38
39 -- Type aliases must be added to an extended equality dictionary,
39 -- Type aliases must be added to an extended equality dictionary,
40 -- but they do not require any basic constraints.
40 -- but they do not require any basic constraints.
41− TypeAlias _ _ _ -> []
41+ D.TypeAlias _ _ _ -> []
42
42
43− Port port ->
43+ D.Port port ->
44 case port of
44 case port of
45− Out name expr@(L.L s _) tipe ->
45+ D.Out name expr@(A.A s _) tipe ->
46− [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
46+ [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
47− In name tipe ->
47+ D.In name tipe ->
48− [ definition name (L.none $ E.PortIn name tipe) tipe ]
48+ [ definition name (A.none $ E.PortIn name tipe) tipe ]
49
49
50 -- no constraints are needed for fixity declarations
50 -- no constraints are needed for fixity declarations
51− Fixity _ _ _ -> []
51+ D.Fixity _ _ _ -> []
52
52
53
53
54arguments :: [String]
54arguments :: [String]
55arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
55arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
56
56
57−buildFunction :: E.LExpr -> [String] -> E.LExpr
57+buildFunction :: E.Expr -> [String] -> E.Expr
58−buildFunction body@(L.L s _) vars =
58+buildFunction body@(A.A s _) vars =
59− foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)
59+ foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
60
60
61−definition :: String -> E.LExpr -> T.Type -> E.Def
61+definition :: String -> E.Expr -> T.Type -> E.Def
62−definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)
62+definition name expr tipe = E.Definition (P.Var name) expr (Just tipe)
compiler/Type/Constrain/Expression.hs+40−38
@@ -1,36 +1,37 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module Type.Constrain.Expression where
2module Type.Constrain.Expression where
3
3
4−import qualified Data.List as List
5−import qualified Data.Map as Map
6−import qualified Data.Set as Set
7import Control.Applicative ((<$>))
4import Control.Applicative ((<$>))
8import qualified Control.Monad as Monad
5import qualified Control.Monad as Monad
9import Control.Monad.Error
6import Control.Monad.Error
7+import qualified Data.List as List
8+import qualified Data.Map as Map
10import qualified Text.PrettyPrint as PP
9import qualified Text.PrettyPrint as PP
11
10
12import SourceSyntax.Literal as Lit
11import 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
15import SourceSyntax.Expression
14import 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
17import Type.Type hiding (Descriptor(..))
18import Type.Type hiding (Descriptor(..))
18import Type.Fragment
19import Type.Fragment
19import qualified Type.Environment as Env
20import qualified Type.Environment as Env
20import qualified Type.Constrain.Literal as Literal
21import qualified Type.Constrain.Literal as Literal
21import qualified Type.Constrain.Pattern as Pattern
22import qualified Type.Constrain.Pattern as Pattern
22
23
23−constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
24+constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
24−constrain env (L span expr) tipe =
25+constrain env (A region expr) tipe =
25 let list t = Env.get env Env.types "_List" <| t
26 let list t = Env.get env Env.types "_List" <| t
26− and = L span . CAnd
27+ and = A region . CAnd
27− true = L span CTrue
28+ true = A region CTrue
28− t1 === t2 = L span (CEqual t1 t2)
29+ t1 === t2 = A region (CEqual t1 t2)
29− x <? t = L span (CInstance x t)
30+ x <? t = A region (CInstance x t)
30− clet schemes c = L span (CLet schemes c)
31+ clet schemes c = A region (CLet schemes c)
31 in
32 in
32 case expr of
33 case expr of
33− Literal lit -> liftIO $ Literal.constrain env span lit tipe
34+ Literal lit -> liftIO $ Literal.constrain env region lit tipe
34
35
35 GLShader _uid _src gltipe ->
36 GLShader _uid _src gltipe ->
36 exists $ \attr ->
37 exists $ \attr ->
@@ -42,16 +43,17 @@ constrain env (L span expr) tipe =
42 attribute = makeRec Lit.attribute attr
43 attribute = makeRec Lit.attribute attr
43 uniform = makeRec Lit.uniform unif
44 uniform = makeRec Lit.uniform unif
44 varying = makeRec Lit.varying (TermN EmptyRecord1)
45 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)
46
47
48+ Var (V.Raw name)
47− Var name | name == saveEnvName -> return (L span CSaveEnv)
49+ | name == saveEnvName -> return (A region CSaveEnv)
48− | otherwise -> return (name <? tipe)
50+ | otherwise -> return (name <? tipe)
49
51
50 Range lo hi ->
52 Range lo hi ->
51− exists $ \x -> do
53+ existsNumber $ \n -> do
52− clo <- constrain env lo x
54+ clo <- constrain env lo n
53− chi <- constrain env hi x
55+ chi <- constrain env hi n
54− return $ and [clo, chi, list x === tipe]
56+ return $ and [clo, chi, list n === tipe]
55
57
56 ExplicitList exprs ->
58 ExplicitList exprs ->
57 exists $ \x -> do
59 exists $ \x -> do
@@ -68,7 +70,7 @@ constrain env (L span expr) tipe =
68 Lambda p e ->
70 Lambda p e ->
69 exists $ \t1 ->
71 exists $ \t1 ->
70 exists $ \t2 -> do
72 exists $ \t2 -> do
71− fragment <- try span $ Pattern.constrain env p t1
73+ fragment <- try region $ Pattern.constrain env p t1
72 c2 <- constrain env e t2
74 c2 <- constrain env e t2
73 let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
75 let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
74 (typeConstraint fragment /\ c2 ))
76 (typeConstraint fragment /\ c2 ))
@@ -92,7 +94,7 @@ constrain env (L span expr) tipe =
92 exists $ \t -> do
94 exists $ \t -> do
93 ce <- constrain env exp t
95 ce <- constrain env exp t
94 let branch (p,e) = do
96 let branch (p,e) = do
95− fragment <- try span $ Pattern.constrain env p t
97+ fragment <- try region $ Pattern.constrain env p t
96 clet [toScheme fragment] <$> constrain env e tipe
98 clet [toScheme fragment] <$> constrain env e tipe
97 and . (:) ce <$> mapM branch branches
99 and . (:) ce <$> mapM branch branches
98
100
@@ -125,11 +127,11 @@ constrain env (L span expr) tipe =
125 Modify e fields ->
127 Modify e fields ->
126 exists $ \t -> do
128 exists $ \t -> do
127 oldVars <- forM fields $ \_ -> liftIO (var Flexible)
129 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))
129 cOld <- ex oldVars <$> constrain env e (record oldFields t)
131 cOld <- ex oldVars <$> constrain env e (record oldFields t)
130
132
131 newVars <- forM fields $ \_ -> liftIO (var Flexible)
133 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))
133 let cNew = tipe === record newFields t
135 let cNew = tipe === record newFields t
134
136
135 cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
137 cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
@@ -139,7 +141,7 @@ constrain env (L span expr) tipe =
139 Record fields ->
141 Record fields ->
140 do vars <- forM fields $ \_ -> liftIO (var Flexible)
142 do vars <- forM fields $ \_ -> liftIO (var Flexible)
141 cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
143 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))
143 recordType = record fields' (TermN EmptyRecord1)
145 recordType = record fields' (TermN EmptyRecord1)
144 return . ex vars . and $ tipe === recordType : cs
146 return . ex vars . and $ tipe === recordType : cs
145
147
@@ -171,14 +173,14 @@ constrainDef env info (Definition pattern expr maybeTipe) =
171 do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.
173 do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.
172 -- Currently, qs is always [].
174 -- Currently, qs is always [].
173 case (pattern, maybeTipe) of
175 case (pattern, maybeTipe) of
174− (PVar name, Just tipe) -> do
176+ (P.Var name, Just tipe) -> do
175 flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
177 flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
176 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
178 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
177 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
179 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
178 (vars, typ) <- Env.instantiateType env tipe Map.empty
180 (vars, typ) <- Env.instantiateType env tipe Map.empty
179 let scheme = Scheme { rigidQuantifiers = [],
181 let scheme = Scheme { rigidQuantifiers = [],
180 flexibleQuantifiers = flexiVars ++ vars,
182 flexibleQuantifiers = flexiVars ++ vars,
181− constraint = Loc.noneNoDocs CTrue,
183+ constraint = Ann.noneNoDocs CTrue,
182 header = Map.singleton name typ }
184 header = Map.singleton name typ }
183 c <- constrain env' expr typ
185 c <- constrain env' expr typ
184 return ( scheme : schemes
186 return ( scheme : schemes
@@ -188,7 +190,7 @@ constrainDef env info (Definition pattern expr maybeTipe) =
188 , c2
190 , c2
189 , fl rigidVars c /\ c1 )
191 , fl rigidVars c /\ c1 )
190
192
191− (PVar name, Nothing) -> do
193+ (P.Var name, Nothing) -> do
192 v <- liftIO $ var Flexible
194 v <- liftIO $ var Flexible
193 let tipe = VarN v
195 let tipe = VarN v
194 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
196 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
@@ -204,19 +206,19 @@ constrainDef env info (Definition pattern expr maybeTipe) =
204 _ -> error (show pattern)
206 _ -> error (show pattern)
205
207
206expandPattern :: Def -> [Def]
208expandPattern :: Def -> [Def]
207−expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =
209+expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =
208 case pattern of
210 case pattern of
209− PVar _ -> [def]
211+ P.Var _ -> [def]
210− _ -> Definition (PVar x) lexpr maybeType : map toDef vars
212+ _ -> Definition (P.Var x) lexpr maybeType : map toDef vars
211 where
213 where
212− vars = Set.toList $ boundVars pattern
214+ vars = P.boundVarList pattern
213 x = "$" ++ concat vars
215 x = "$" ++ concat vars
214− mkVar = L s . Var
216+ mkVar = A r . rawVar
215− toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
217+ toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
216
218
217−try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
219+try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
218−try span computation = do
220+try region computation = do
219 result <- liftIO $ runErrorT computation
221 result <- liftIO $ runErrorT computation
220 case result of
222 case result of
221− Left err -> throwError [err span]
223+ Left err -> throwError [err region]
222 Right value -> return value
224 Right value -> return value
compiler/Type/Constrain/Literal.hs+5−4
@@ -1,14 +1,15 @@
1+{-# OPTIONS_GHC -W #-}
1module Type.Constrain.Literal where
2module Type.Constrain.Literal where
2
3
4+import SourceSyntax.Annotation
3import SourceSyntax.Literal
5import SourceSyntax.Literal
4−import SourceSyntax.Location
5import Type.Type
6import Type.Type
6import Type.Environment as Env
7import Type.Environment as Env
7
8
8−constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint
9+constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint
9−constrain env span literal tipe =
10+constrain env region literal tipe =
10 do tipe' <- litType
11 do tipe' <- litType
11− return . L span $ CEqual tipe tipe'
12+ return . A region $ CEqual tipe tipe'
12 where
13 where
13 prim name = return (Env.get env Env.types name)
14 prim name = return (Env.get env Env.types name)
14
15
compiler/Type/Constrain/Pattern.hs+17−18
@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -W #-}
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
2module Type.Constrain.Pattern where
3module Type.Constrain.Pattern where
3
4
@@ -8,31 +9,29 @@ import Control.Monad.Error
8import qualified Data.Map as Map
9import qualified Data.Map as Map
9import qualified Text.PrettyPrint as PP
10import qualified Text.PrettyPrint as PP
10
11
12+import qualified SourceSyntax.Annotation as A
11−import SourceSyntax.Pattern
13+import qualified SourceSyntax.Pattern as P
12−import SourceSyntax.Location
13−import SourceSyntax.PrettyPrint
14+import SourceSyntax.PrettyPrint (pretty)
14−import Text.PrettyPrint (render)
15−import qualified SourceSyntax.Location as Loc
16import Type.Type
15import Type.Type
17import Type.Fragment
16import Type.Fragment
18import Type.Environment as Env
17import Type.Environment as Env
19import qualified Type.Constrain.Literal as Literal
18import qualified Type.Constrain.Literal as Literal
20
19
21
20
22−constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment
21+constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment
23constrain env pattern tipe =
22constrain env pattern tipe =
24− let span = Loc.NoSpan (render $ pretty pattern)
23+ let region = A.None (pretty pattern)
25− t1 === t2 = Loc.L span (CEqual t1 t2)
24+ t1 === t2 = A.A region (CEqual t1 t2)
26− x <? t = Loc.L span (CInstance x t)
25+ x <? t = A.A region (CInstance x t)
27 in
26 in
28 case pattern of
27 case pattern of
29− PAnything -> return emptyFragment
28+ P.Anything -> return emptyFragment
30
29
31− PLiteral lit -> do
30+ P.Literal lit -> do
32− c <- liftIO $ Literal.constrain env span lit tipe
31+ c <- liftIO $ Literal.constrain env region lit tipe
33 return $ emptyFragment { typeConstraint = c }
32 return $ emptyFragment { typeConstraint = c }
34
33
35− PVar name -> do
34+ P.Var name -> do
36 v <- liftIO $ var Flexible
35 v <- liftIO $ var Flexible
37 return $ Fragment {
36 return $ Fragment {
38 typeEnv = Map.singleton name (VarN v),
37 typeEnv = Map.singleton name (VarN v),
@@ -40,14 +39,14 @@ constrain env pattern tipe =
40 typeConstraint = VarN v === tipe
39 typeConstraint = VarN v === tipe
41 }
40 }
42
41
43− PAlias name p -> do
42+ P.Alias name p -> do
44 fragment <- constrain env p tipe
43 fragment <- constrain env p tipe
45 return $ fragment {
44 return $ fragment {
46 typeEnv = Map.insert name tipe (typeEnv fragment),
45 typeEnv = Map.insert name tipe (typeEnv fragment),
47 typeConstraint = name <? tipe /\ typeConstraint fragment
46 typeConstraint = name <? tipe /\ typeConstraint fragment
48 }
47 }
49
48
50− PData name patterns -> do
49+ P.Data name patterns -> do
51 (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
50 (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
52 let msg = concat [ "Constructor '", name, "' expects ", show kind
51 let msg = concat [ "Constructor '", name, "' expects ", show kind
53 , " argument", if kind == 1 then "" else "s"
52 , " argument", if kind == 1 then "" else "s"
@@ -63,7 +62,7 @@ constrain env pattern tipe =
63 vars = cvars ++ vars fragment
62 vars = cvars ++ vars fragment
64 }
63 }
65
64
66− PRecord fields -> do
65+ P.Record fields -> do
67 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
66 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
68 let tenv = Map.fromList (map (second VarN) pairs)
67 let tenv = Map.fromList (map (second VarN) pairs)
69 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
68 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
@@ -73,8 +72,8 @@ constrain env pattern tipe =
73 typeConstraint = c
72 typeConstraint = c
74 }
73 }
75
74
76−instance Error (SrcSpan -> PP.Doc) where
75+instance Error (A.Region -> PP.Doc) where
77 noMsg _ = PP.empty
76 noMsg _ = PP.empty
78 strMsg str span =
77 strMsg str span =
79 PP.vcat [ PP.text $ "Type error " ++ show span
78 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 @@
1{-# OPTIONS_GHC -W #-}
1{-# 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+-}
2module Type.ExtraChecks (mainType, occurs, portTypes) where
7module 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.
6
8
7import Control.Applicative ((<$>),(<*>))
9import Control.Applicative ((<$>),(<*>))
8import Control.Monad.State
10import Control.Monad.State
9import qualified Data.List as List
11import qualified Data.List as List
10import qualified Data.Map as Map
12import qualified Data.Map as Map
13+import qualified Data.Traversable as Traverse
11import qualified Data.UnionFind.IO as UF
14import 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
15import Text.PrettyPrint as P
15import Text.PrettyPrint as P
16−import SourceSyntax.PrettyPrint (pretty)
16+
17−import qualified SourceSyntax.Helpers as Help
17+import qualified SourceSyntax.Annotation as A
18−import qualified SourceSyntax.Type as T
19import qualified SourceSyntax.Expression as E
18import 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
21import qualified Transform.Expression as Expr
22import 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
23
26
24throw err = Left [ P.vcat err ]
27throw err = Left [ P.vcat err ]
25
28
26−mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))
29+mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))
27−mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
30+mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env
28 where
31 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)
30 mainCheck rules env =
33 mainCheck rules env =
31 case Map.lookup "main" env of
34 case Map.lookup "main" env of
32 Nothing -> Right env
35 Nothing -> Right env
@@ -37,40 +40,40 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
37 acceptable = [ "Graphics.Element.Element"
40 acceptable = [ "Graphics.Element.Element"
38 , "Signal.Signal Graphics.Element.Element" ]
41 , "Signal.Signal Graphics.Element.Element" ]
39
42
40− tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType
43+ tipe = SPP.renderPretty $ Alias.canonicalRealias (fst rules) mainType
41 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
44 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
42 , P.text "Instead 'main' has type:\n"
45 , 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
44 , P.text " " ]
47 , P.text " " ]
45
48
46data Direction = In | Out
49data Direction = In | Out
47
50
48−portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
51+portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()
49portTypes rules expr =
52portTypes rules expr =
50 const () <$> Expr.checkPorts (check In) (check Out) expr
53 const () <$> Expr.checkPorts (check In) (check Out) expr
51 where
54 where
52 check = isValid True False False
55 check = isValid True False False
53 isValid isTopLevel seenFunc seenSignal direction name tipe =
56 isValid isTopLevel seenFunc seenSignal direction name tipe =
54 case tipe of
57 case tipe of
55− T.Data ctor ts
58+ ST.Data ctor ts
56 | isJs ctor || isElm ctor -> mapM_ valid ts
59 | isJs ctor || isElm ctor -> mapM_ valid ts
57 | ctor == "Signal.Signal" -> handleSignal ts
60 | ctor == "Signal.Signal" -> handleSignal ts
58 | otherwise -> err' True "an unsupported type"
61 | otherwise -> err' True "an unsupported type"
59
62
60− T.Var _ -> err "free type variables"
63+ ST.Var _ -> err "free type variables"
61
64
62− T.Lambda _ _ ->
65+ ST.Lambda _ _ ->
63 case direction of
66 case direction of
64 In -> err "functions"
67 In -> err "functions"
65 Out | seenFunc -> err "higher-order functions"
68 Out | seenFunc -> err "higher-order functions"
66 | seenSignal -> err "signals that contain functions"
69 | seenSignal -> err "signals that contain functions"
67 | otherwise ->
70 | otherwise ->
68− forM_ (T.collectLambdas tipe)
71+ forM_ (ST.collectLambdas tipe)
69 (isValid' True seenSignal direction name)
72 (isValid' True seenSignal direction name)
70
73
71− T.Record _ (Just _) -> err "extended records with free type variables"
74+ ST.Record _ (Just _) -> err "extended records with free type variables"
72
75
73− T.Record fields Nothing ->
76+ ST.Record fields Nothing ->
74 mapM_ (\(k,v) -> (,) k <$> valid v) fields
77 mapM_ (\(k,v) -> (,) k <$> valid v) fields
75
78
76 where
79 where
@@ -100,7 +103,7 @@ portTypes rules expr =
100 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
103 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
101 , " through port '", name, "' is invalid." ]
104 , " through port '", name, "' is invalid." ]
102 , txt [ "It contains ", kind, ":\n" ]
105 , 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"
104 , txt [ "Acceptable values for ", dir "incoming" "outgoing"
107 , txt [ "Acceptable values for ", dir "incoming" "outgoing"
105 , " ports include JavaScript values and" ]
108 , " ports include JavaScript values and" ]
106 , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
109 , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
@@ -112,37 +115,37 @@ portTypes rules expr =
112 , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]
115 , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]
113 ]
116 ]
114
117
115−occurs :: (String, Variable) -> StateT TS.SolverState IO ()
118+occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
116occurs (name, variable) =
119occurs (name, variable) =
117 do vars <- liftIO $ infiniteVars [] variable
120 do vars <- liftIO $ infiniteVars [] variable
118 case vars of
121 case vars of
119 [] -> return ()
122 [] -> return ()
120 var:_ -> do
123 var:_ -> do
121 desc <- liftIO $ UF.descriptor var
124 desc <- liftIO $ UF.descriptor var
122− case structure desc of
125+ case TT.structure desc of
123 Nothing ->
126 Nothing ->
124 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
127 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
125 Just _ ->
128 Just _ ->
126− do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
129+ do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
127 var' <- liftIO $ UF.fresh desc
130 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'
129 where
132 where
130 msg = "Infinite types are not allowed"
133 msg = "Infinite types are not allowed"
131 fallback _ = return $ P.text msg
134 fallback _ = return $ P.text msg
132
135
133− infiniteVars :: [Variable] -> Variable -> IO [Variable]
136+ infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
134− infiniteVars seen var =
137+ infiniteVars seen var =
135 let go = infiniteVars (var:seen) in
138 let go = infiniteVars (var:seen) in
136 if var `elem` seen
139 if var `elem` seen
137 then return [var]
140 then return [var]
138 else do
141 else do
139 desc <- UF.descriptor var
142 desc <- UF.descriptor var
140− case structure desc of
143+ case TT.structure desc of
141 Nothing -> return []
144 Nothing -> return []
142 Just struct ->
145 Just struct ->
143 case struct of
146 case struct of
144− App1 a b -> (++) <$> go a <*> go b
147+ TT.App1 a b -> (++) <$> go a <*> go b
145− Fun1 a b -> (++) <$> go a <*> go b
148+ TT.Fun1 a b -> (++) <$> go a <*> go b
146− Var1 a -> go a
149+ TT.Var1 a -> go a
147− EmptyRecord1 -> return []
150+ TT.EmptyRecord1 -> return []
148− Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
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
5
5
6import Type.Type
6import Type.Type
7import SourceSyntax.Pattern
7import SourceSyntax.Pattern
8−import SourceSyntax.Location (noneNoDocs)
8+import SourceSyntax.Annotation (noneNoDocs)
9
9
10−data Fragment = Fragment {
10+data Fragment = Fragment
11− typeEnv :: Map.Map String Type,
11+ { typeEnv :: Map.Map String Type
12− vars :: [Variable],
12+ , vars :: [Variable]
13− typeConstraint :: TypeConstraint
13+ , typeConstraint :: TypeConstraint
14−} deriving Show
14+ } deriving Show
15
15
16emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
16emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
17
17
18−joinFragment f1 f2 = Fragment {
18+joinFragment f1 f2 = Fragment
19− typeEnv = Map.union (typeEnv f1) (typeEnv f2),
19+ { typeEnv = Map.union (typeEnv f1) (typeEnv f2)
20− vars = vars f1 ++ vars f2,
20+ , vars = vars f1 ++ vars f2
21− typeConstraint = typeConstraint f1 /\ typeConstraint f2
21+ , typeConstraint = typeConstraint f1 /\ typeConstraint f2
22−}
22+ }
23
23
24joinFragments = List.foldl' (flip joinFragment) emptyFragment
24joinFragments = List.foldl' (flip joinFragment) emptyFragment
25
25
26−
27toScheme fragment =
26toScheme 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
9import qualified Type.Solve as Solve
9import qualified Type.Solve as Solve
10
10
11import SourceSyntax.Module as Module
11import SourceSyntax.Module as Module
12−import SourceSyntax.Location (noneNoDocs)
12+import SourceSyntax.Annotation (noneNoDocs)
13import SourceSyntax.Type (Type)
13import SourceSyntax.Type (Type)
14import Text.PrettyPrint
14import Text.PrettyPrint
15import qualified Type.State as TS
15import qualified Type.State as TS
compiler/Type/Solve.hs+19−19
@@ -3,15 +3,15 @@ module Type.Solve (solve) where
3
3
4import Control.Monad
4import Control.Monad
5import Control.Monad.State
5import Control.Monad.State
6−import qualified Data.UnionFind.IO as UF
6+import qualified Data.List as List
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8import qualified Data.Traversable as Traversable
8import qualified Data.Traversable as Traversable
9−import qualified Data.List as List
9+import qualified Data.UnionFind.IO as UF
10import Type.Type
10import Type.Type
11import Type.Unify
11import Type.Unify
12import qualified Type.ExtraChecks as Check
12import qualified Type.ExtraChecks as Check
13import qualified Type.State as TS
13import qualified Type.State as TS
14−import SourceSyntax.Location (Located(L), SrcSpan)
14+import qualified SourceSyntax.Annotation as A
15
15
16
16
17-- | Every variable has rank less than or equal to the maxRank of the pool.
17-- | Every variable has rank less than or equal to the maxRank of the pool.
@@ -96,7 +96,7 @@ adjustRank youngMark visitedMark groupRank variable =
96
96
97
97
98solve :: TypeConstraint -> StateT TS.SolverState IO ()
98solve :: TypeConstraint -> StateT TS.SolverState IO ()
99−solve (L span constraint) =
99+solve (A.A region constraint) =
100 case constraint of
100 case constraint of
101 CTrue -> return ()
101 CTrue -> return ()
102
102
@@ -105,11 +105,11 @@ solve (L span constraint) =
105 CEqual term1 term2 -> do
105 CEqual term1 term2 -> do
106 t1 <- TS.flatten term1
106 t1 <- TS.flatten term1
107 t2 <- TS.flatten term2
107 t2 <- TS.flatten term2
108− unify span t1 t2
108+ unify region t1 t2
109
109
110 CAnd cs -> mapM_ solve cs
110 CAnd cs -> mapM_ solve cs
111
111
112− CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do
112+ CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do
113 oldEnv <- TS.getEnv
113 oldEnv <- TS.getEnv
114 mapM TS.introduce fqs
114 mapM TS.introduce fqs
115 solve constraint'
115 solve constraint'
@@ -117,7 +117,7 @@ solve (L span constraint) =
117
117
118 CLet schemes constraint' -> do
118 CLet schemes constraint' -> do
119 oldEnv <- TS.getEnv
119 oldEnv <- TS.getEnv
120− headers <- Map.unions `fmap` mapM (solveScheme span) schemes
120+ headers <- Map.unions `fmap` mapM (solveScheme region) schemes
121 TS.modifyEnv $ \env -> Map.union headers env
121 TS.modifyEnv $ \env -> Map.union headers env
122 solve constraint'
122 solve constraint'
123 mapM Check.occurs $ Map.toList headers
123 mapM Check.occurs $ Map.toList headers
@@ -134,10 +134,10 @@ solve (L span constraint) =
134 error ("Could not find '" ++ name ++ "' when solving type constraints.")
134 error ("Could not find '" ++ name ++ "' when solving type constraints.")
135
135
136 t <- TS.flatten term
136 t <- TS.flatten term
137− unify span freshCopy t
137+ unify region freshCopy t
138
138
139−solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
139+solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
140−solveScheme span scheme =
140+solveScheme region scheme =
141 case scheme of
141 case scheme of
142 Scheme [] [] constraint header -> do
142 Scheme [] [] constraint header -> do
143 solve constraint
143 solve constraint
@@ -154,39 +154,39 @@ solveScheme span scheme =
154 header' <- Traversable.traverse TS.flatten header
154 header' <- Traversable.traverse TS.flatten header
155 solve constraint
155 solve constraint
156
156
157− allDistinct span rigidQuantifiers
157+ allDistinct region rigidQuantifiers
158 youngPool <- TS.getPool
158 youngPool <- TS.getPool
159 TS.switchToPool oldPool
159 TS.switchToPool oldPool
160 generalize youngPool
160 generalize youngPool
161− mapM (isGeneric span) rigidQuantifiers
161+ mapM (isGeneric region) rigidQuantifiers
162 return header'
162 return header'
163
163
164
164
165-- Checks that all of the given variables belong to distinct equivalence classes.
165-- Checks that all of the given variables belong to distinct equivalence classes.
166-- Also checks that their structure is Nothing, so they represent a variable, not
166-- Also checks that their structure is Nothing, so they represent a variable, not
167-- a more complex term.
167-- a more complex term.
168−allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()
168+allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
169−allDistinct span vars = do
169+allDistinct region vars = do
170 seen <- TS.uniqueMark
170 seen <- TS.uniqueMark
171 let check var = do
171 let check var = do
172 desc <- liftIO $ UF.descriptor var
172 desc <- liftIO $ UF.descriptor var
173 case structure desc of
173 case structure desc of
174− Just _ -> TS.addError span (Just msg) var var
174+ Just _ -> TS.addError region (Just msg) var var
175 where msg = "Cannot generalize something that is not a type variable."
175 where msg = "Cannot generalize something that is not a type variable."
176
176
177 Nothing -> do
177 Nothing -> do
178 if mark desc == seen
178 if mark desc == seen
179 then let msg = "Duplicate variable during generalization."
179 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
181 else return ()
181 else return ()
182 liftIO $ UF.setDescriptor var (desc { mark = seen })
182 liftIO $ UF.setDescriptor var (desc { mark = seen })
183 mapM_ check vars
183 mapM_ check vars
184
184
185-- Check that a variable has rank == noRank, meaning that it can be generalized.
185-- Check that a variable has rank == noRank, meaning that it can be generalized.
186−isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()
186+isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()
187−isGeneric span var = do
187+isGeneric region var = do
188 desc <- liftIO $ UF.descriptor var
188 desc <- liftIO $ UF.descriptor var
189 if rank desc == noRank
189 if rank desc == noRank
190 then return ()
190 then return ()
191 else let msg = "Unable to generalize a type variable. It is not unranked."
191 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 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module Type.State where
2module Type.State where
3
3
4−import Type.Type
5−import qualified Data.Map as Map
6−import qualified Data.UnionFind.IO as UF
7−import Control.Monad.State
8import Control.Applicative ((<$>),(<*>), Applicative)
4import Control.Applicative ((<$>),(<*>), Applicative)
5+import Control.Monad.State
6+import qualified Data.Map as Map
9import qualified Data.Traversable as Traversable
7import 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
11import SourceSyntax.PrettyPrint
11import SourceSyntax.PrettyPrint
12−import SourceSyntax.Location
12+import Text.PrettyPrint as P
13import qualified Type.Alias as Alias
13import qualified Type.Alias as Alias
14+import Type.Type
14
15
15-- Pool
16-- Pool
16-- Holds a bunch of variables
17-- Holds a bunch of variables
@@ -46,7 +47,7 @@ initialState = SS {
46modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
47modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
47modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
48modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
48
49
49−addError span hint t1 t2 =
50+addError region hint t1 t2 =
50 modify $ \state -> state { sErrors = makeError : sErrors state }
51 modify $ \state -> state { sErrors = makeError : sErrors state }
51 where
52 where
52 makeError rules = do
53 makeError rules = do
@@ -54,24 +55,15 @@ addError span hint t1 t2 =
54 t1' <- prettiest <$> toSrcType t1
55 t1' <- prettiest <$> toSrcType t1
55 t2' <- prettiest <$> toSrcType t2
56 t2' <- prettiest <$> toSrcType t2
56 return . P.vcat $
57 return . P.vcat $
57− [ P.text $ "Type error" ++ location ++ ":"
58+ [ P.text "Type error" <+> pretty region <> P.colon
58 , maybe P.empty P.text hint
59 , 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 ""
60 , P.text " Expected Type:" <+> t1'
63 , P.text " Expected Type:" <+> t1'
61 , P.text " Actual Type:" <+> t2'
64 , P.text " Actual Type:" <+> t2'
62 ]
65 ]
63
66
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−
75switchToPool pool = modifyPool (\_ -> pool)
67switchToPool pool = modifyPool (\_ -> pool)
76
68
77getPool :: StateT SolverState IO Pool
69getPool :: StateT SolverState IO Pool
compiler/Type/Type.hs+19−12
@@ -11,7 +11,7 @@ import Control.Applicative ((<$>),(<*>))
11import Control.Monad.State
11import Control.Monad.State
12import Control.Monad.Error
12import Control.Monad.Error
13import Data.Traversable (traverse)
13import Data.Traversable (traverse)
14−import SourceSyntax.Location
14+import SourceSyntax.Annotation
15import SourceSyntax.Helpers (isTuple)
15import SourceSyntax.Helpers (isTuple)
16import qualified SourceSyntax.Type as Src
16import qualified SourceSyntax.Type as Src
17
17
@@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
62infixl 8 /\
62infixl 8 /\
63
63
64(/\) :: Constraint a b -> Constraint a b -> Constraint a b
64(/\) :: Constraint a b -> Constraint a b -> Constraint a b
65−a@(L _ c1) /\ b@(L _ c2) =
65+a@(A _ c1) /\ b@(A _ c2) =
66 case (c1, c2) of
66 case (c1, c2) of
67 (CTrue, _) -> b
67 (CTrue, _) -> b
68 (_, CTrue) -> a
68 (_, CTrue) -> a
@@ -128,17 +128,24 @@ structuredVar structure = UF.fresh $ Descriptor {
128
128
129-- ex qs constraint == exists qs. constraint
129-- ex qs constraint == exists qs. constraint
130ex :: [Variable] -> TypeConstraint -> TypeConstraint
130ex :: [Variable] -> TypeConstraint -> TypeConstraint
131+ex fqs constraint@(A ann _) =
131−ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s CTrue)
132+ A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)
132
133
133-- fl qs constraint == forall qs. constraint
134-- fl qs constraint == forall qs. constraint
134fl :: [Variable] -> TypeConstraint -> TypeConstraint
135fl :: [Variable] -> TypeConstraint -> TypeConstraint
136+fl rqs constraint@(A ann _) =
135−fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)
137+ A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)
136
138
137exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
139exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
138exists f = do
140exists f = do
139 v <- liftIO $ var Flexible
141 v <- liftIO $ var Flexible
140 ex [v] <$> f (VarN v)
142 ex [v] <$> f (VarN v)
141
143
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+
142
149
143instance Show a => Show (UF.Point a) where
150instance Show a => Show (UF.Point a) where
144 show point = unsafePerformIO $ fmap show (UF.descriptor point)
151 show point = unsafePerformIO $ fmap show (UF.descriptor point)
@@ -148,8 +155,8 @@ instance PrettyType a => PrettyType (UF.Point a) where
148 pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
155 pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
149
156
150
157
151−instance PrettyType a => PrettyType (Located a) where
158+instance PrettyType t => PrettyType (Annotated a t) where
152− pretty when (L _ e) = pretty when e
159+ pretty when (A _ e) = pretty when e
153
160
154
161
155instance PrettyType a => PrettyType (Term1 a) where
162instance PrettyType a => PrettyType (Term1 a) where
@@ -212,12 +219,12 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
212 CAnd cs ->
219 CAnd cs ->
213 P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
220 P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
214
221
215− CLet [Scheme [] fqs constraint header] (L _ CTrue) | Map.null header ->
222+ CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header ->
216 P.sep [ binder, pretty Never c ]
223 P.sep [ binder, pretty Never c ]
217 where
224 where
218− mergeExists vs (L _ c) =
225+ mergeExists vs (A _ c) =
219 case c of
226 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'
221 _ -> (vs, c)
228 _ -> (vs, c)
222
229
223 (fqs', c) = mergeExists fqs constraint
230 (fqs', c) = mergeExists fqs constraint
@@ -233,7 +240,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
233 P.text name <+> P.text "<" <+> prty tipe
240 P.text name <+> P.text "<" <+> prty tipe
234
241
235instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
242instance (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) =
237 P.sep [ forall, cs, headers' ]
244 P.sep [ forall, cs, headers' ]
238 where
245 where
239 prty = pretty Never
246 prty = pretty Never
@@ -297,8 +304,8 @@ class Crawl t where
297 -> t
304 -> t
298 -> StateT CrawlState IO t
305 -> StateT CrawlState IO t
299
306
300−instance Crawl a => Crawl (Located a) where
307+instance Crawl e => Crawl (Annotated a e) where
301− crawl nextState (L s e) = L s <$> crawl nextState e
308+ crawl nextState (A ann e) = A ann <$> crawl nextState e
302
309
303instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
310instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
304 crawl nextState constraint =
311 crawl nextState constraint =
compiler/Type/Unify.hs+15−15
@@ -1,27 +1,27 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module Type.Unify (unify) where
2module Type.Unify (unify) where
3
3
4−import Type.Type
4+import Control.Monad.State
5−import qualified Data.UnionFind.IO as UF
6import qualified Data.Map as Map
5import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
6import qualified Data.Maybe as Maybe
7+import qualified Data.UnionFind.IO as UF
8+import qualified SourceSyntax.Annotation as A
8import qualified Type.State as TS
9import qualified Type.State as TS
9−import Control.Monad.State
10+import Type.Type
10−import SourceSyntax.Location
11import Type.PrettyPrint
11import Type.PrettyPrint
12import Text.PrettyPrint (render)
12import Text.PrettyPrint (render)
13
13
14−unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
14+unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
15−unify span variable1 variable2 = do
15+unify region variable1 variable2 = do
16 equivalent <- liftIO $ UF.equivalent variable1 variable2
16 equivalent <- liftIO $ UF.equivalent variable1 variable2
17 if equivalent then return ()
17 if equivalent then return ()
18− else actuallyUnify span variable1 variable2
18+ else actuallyUnify region variable1 variable2
19
19
20−actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
20+actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
21−actuallyUnify span variable1 variable2 = do
21+actuallyUnify region variable1 variable2 = do
22 desc1 <- liftIO $ UF.descriptor variable1
22 desc1 <- liftIO $ UF.descriptor variable1
23 desc2 <- liftIO $ UF.descriptor variable2
23 desc2 <- liftIO $ UF.descriptor variable2
24− let unify' = unify span
24+ let unify' = unify region
25
25
26 name' :: Maybe String
26 name' :: Maybe String
27 name' = case (name desc1, name desc2) of
27 name' = case (name desc1, name desc2) of
@@ -79,11 +79,11 @@ actuallyUnify span variable1 variable2 = do
79
79
80 unifyNumber svar name
80 unifyNumber svar name
81 | name `elem` ["Int","Float","number"] = flexAndUnify svar
81 | 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
83 where hint = "A number must be an Int or Float."
83 where hint = "A number must be an Int or Float."
84
84
85 comparableError maybe =
85 comparableError maybe =
86− TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
86+ TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
87 where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
87 where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
88
88
89 unifyComparable var name
89 unifyComparable var name
@@ -110,7 +110,7 @@ actuallyUnify span variable1 variable2 = do
110 List _ -> flexAndUnify varSuper
110 List _ -> flexAndUnify varSuper
111 _ -> comparableError Nothing
111 _ -> comparableError Nothing
112
112
113− rigidError variable = TS.addError span (Just hint) variable1 variable2
113+ rigidError variable = TS.addError region (Just hint) variable1 variable2
114 where
114 where
115 var = "'" ++ render (pretty Never variable) ++ "'"
115 var = "'" ++ render (pretty Never variable) ++ "'"
116 hint = "Cannot unify rigid type variable " ++ var ++
116 hint = "Cannot unify rigid type variable " ++ var ++
@@ -141,7 +141,7 @@ actuallyUnify span variable1 variable2 = do
141
141
142 (Rigid, _, _, _) -> rigidError variable1
142 (Rigid, _, _, _) -> rigidError variable1
143 (_, Rigid, _, _) -> rigidError variable2
143 (_, Rigid, _, _) -> rigidError variable2
144− _ -> TS.addError span Nothing variable1 variable2
144+ _ -> TS.addError region Nothing variable1 variable2
145
145
146 case (structure desc1, structure desc2) of
146 case (structure desc1, structure desc2) of
147 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
147 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
@@ -196,5 +196,5 @@ actuallyUnify span variable1 variable2 = do
196 eat (_:xs) (_:ys) = eat xs ys
196 eat (_:xs) (_:ys) = eat xs ys
197 eat xs _ = xs
197 eat xs _ = xs
198
198
199− _ -> TS.addError span Nothing variable1 variable2
199+ _ -> TS.addError region Nothing variable1 variable2
200
200
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.
31-}
31-}
32
32
33
33
34−import open Basics
34+import Basics (..)
35−import open Maybe
35+import Maybe (..)
36import Native.Error
36import Native.Error
37import List
37import List
38import String
38import String
libraries/Either.elm+26−4
@@ -26,28 +26,50 @@ data Either a b = Left a | Right b
26
26
27{-| Apply the first function to a `Left` and the second function to a `Right`.
27{-| Apply the first function to a `Left` and the second function to a `Right`.
28This allows the extraction of a value from an `Either`.
28This 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
29-}
35-}
30either : (a -> c) -> (b -> c) -> Either a b -> c
36either : (a -> c) -> (b -> c) -> Either a b -> c
31either f g e = case e of { Left x -> f x ; Right y -> g y }
37either f g e = case e of { Left x -> f x ; Right y -> g y }
32
38
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+-}
34isLeft : Either a b -> Bool
44isLeft : Either a b -> Bool
35isLeft e = case e of { Left _ -> True ; _ -> False }
45isLeft e = case e of { Left _ -> True ; _ -> False }
36
46
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+-}
38isRight : Either a b -> Bool
52isRight : Either a b -> Bool
39isRight e = case e of { Right _ -> True ; _ -> False }
53isRight e = case e of { Right _ -> True ; _ -> False }
40
54
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+-}
42lefts : [Either a b] -> [a]
59lefts : [Either a b] -> [a]
43lefts es = List.foldr consLeft [] es
60lefts es = List.foldr consLeft [] es
44
61
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+-}
46rights : [Either a b] -> [b]
66rights : [Either a b] -> [b]
47rights es = List.foldr consRight [] es
67rights es = List.foldr consRight [] es
48
68
49{-| Split into two lists, lefts on the left and rights on the right. So we
69{-| Split into two lists, lefts on the left and rights on the right. So we
50have the equivalence: `(partition es == (lefts es, rights es))`
70have the equivalence: `(partition es == (lefts es, rights es))`
71+
72+ partition [Left 3, Right 'a', Left 5, Right 'b'] == ([3,5],['a','b'])
51-}
73-}
52partition : [Either a b] -> ([a],[b])
74partition : [Either a b] -> ([a],[b])
53partition es = List.foldr consEither ([],[]) es
75partition es = List.foldr consEither ([],[]) es
libraries/Graphics/Collage.elm+1−1
@@ -30,7 +30,7 @@ it as a single unit.
30
30
31-}
31-}
32
32
33−import open Basics
33+import Basics (..)
34import List
34import List
35import Either (Either, Left, Right)
35import Either (Either, Left, Right)
36import Transform2D (Transform2D, identity)
36import Transform2D (Transform2D, identity)
libraries/Graphics/Element.elm+7−4
@@ -37,12 +37,12 @@ If you need more precision, you can create custom positions.
37 midRightAt, topLeftAt, topRightAt, bottomLeftAt, bottomRightAt
37 midRightAt, topLeftAt, topRightAt, bottomLeftAt, bottomRightAt
38-}
38-}
39
39
40−import open Basics
40+import Basics (..)
41import Native.Utils
41import Native.Utils
42import JavaScript as JS
42import JavaScript as JS
43import JavaScript (JSString)
43import JavaScript (JSString)
44import List as List
44import List as List
45−import open Color
45+import Color (..)
46import Maybe (Maybe, Just, Nothing)
46import Maybe (Maybe, Just, Nothing)
47
47
48type Properties = {
48type Properties = {
@@ -53,7 +53,8 @@ type Properties = {
53 color : Maybe Color,
53 color : Maybe Color,
54 href : JSString,
54 href : JSString,
55 tag : JSString,
55 tag : JSString,
56− hover : ()
56+ hover : (),
57+ click : ()
57 }
58 }
58
59
59type Element = { props : Properties, element : ElementPrim }
60type Element = { props : Properties, element : ElementPrim }
@@ -128,7 +129,9 @@ link href e = let p = e.props in
128
129
129emptyStr = JS.fromString ""
130emptyStr = JS.fromString ""
130newElement w h e =
131newElement 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+ }
132
135
133data ElementPrim
136data ElementPrim
134 = Image ImageStyle Int Int JSString
137 = Image ImageStyle Int Int JSString
libraries/Graphics/Input.elm+185−156
@@ -1,199 +1,228 @@
1module Graphics.Input where
1module Graphics.Input where
2−
3{-| This module is for creating standard input widgets such as buttons and
2{-| 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
3+text fields. All functions in this library follow a general pattern in which
5−events from the user.
4+you create an `Input` that many elements can report to:
5+
6+```haskell
7+clicks : Input ()
8+clicks = input ()
6
9
7−The simplest inputs are *one-way inputs*, meaning the user can update
10+clickableYogi : Element
8−them, but the programmer cannot. If you need to update an input from
11+clickableYogi = clickable clicks.handle () (image 40 40 "/yogi.jpg")
9−within the program you want the slightly more complex *two-way inputs*.
12+```
10−This document will always show the one-way inputs first, *then* the
11−two-way inputs.
12
13
13−# Buttons
14+Whenever the user clicks on the resulting `clickableYogi` element, it sends an
14−@docs button, customButton, buttons, customButtons
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!
15
17
16−# Fields
18+# Creating Inputs
17−@docs field, password, email, fields, FieldState, emptyFieldState
19+@docs Input, input
18
20
19−# Checkboxes
21+# Basic Input Elements
22+Text fields come later.
20−@docs checkbox, checkboxes
23+@docs button, customButton, checkbox, dropDown
21
24
22−# Drop Downs
25+# Clicks and Hovers
23−@docs stringDropDown, dropDown
26+@docs clickable, hoverable
24
27
25−# Mouse Hover
28+# Text Fields
26−@docs hoverable, hoverables
29+@docs field, password, email, noContent, FieldContent, Selection, Direction
27-}
30-}
28
31
29−import Basics (String)
30−import Signal (Signal,lift,dropRepeats)
32+import Signal (Signal)
31−import Native.Graphics.Input
32−import List
33import Graphics.Element (Element)
33import Graphics.Element (Element)
34−import Maybe (Maybe)
34+import Native.Graphics.Input
35−import JavaScript (JSString)
36
35
37−id x = x
36+{-| This is the key abstraction of this library. An `Input` is a record
37+of two fields:
38
38
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
40
41
41− * The first argument is the default value of the `events` signal.
42+This will make more sense as you see more examples.
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.
47-}
43-}
48−buttons : a -> { events : Signal a,
44+type Input a = { signal : Signal a, handle : Handle a }
49− button : a -> String -> Element }
45+
50−buttons = Native.Graphics.Input.buttons
46+data Handle a = Handle
47+
48+{-| Create a new `Input`. You just give the initial value for the
49+input&rsquo;s `signal`.
51
50
52−{-| Create a button with a given label. The result is an `Element` and
51+Note for Advanced Users: creating an `Input` is an inherently imperative
53−a signal of units. This signal triggers whenever the button is pressed.
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.
54-}
56-}
55−button : String -> (Element, Signal ())
57+input : a -> Input a
56−button txt =
58+input = Native.Graphics.Input.input
57− let pool = buttons ()
59+
58− in (pool.button () txt, pool.events)
60+{-| Create a standard button. The following example begins making a basic
59−
61+calculator:
60−{-| Create a group of custom buttons.
62+
61−
63+ data Keys = Number Int | Plus | Minus | Clear
62− * The first argument is the default value of the `events` signal.
64+
63− * The `events` signal represents all of the activity in this group
65+ keys : Input Keys
64− of custom buttons.
66+ keys = input Clear
65− * The `customButton` function creates a button with three different visual
67+
66− states, one for up, hovering, and down. The resulting button has dimensions
68+ calculator : Element
67− large enough to fit all three possible `Elements`.
69+ calculator =
68− The `a` value is sent to `events` whenever the button is pressed.
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)`.
69-}
77-}
70−customButtons : a -> { events : Signal a,
78+button : Handle a -> a -> String -> Element
71− customButton : a -> Element -> Element -> Element -> Element }
72−customButtons = Native.Graphics.Input.customButtons
79+button = Native.Graphics.Input.button
73
80
74−{-| Create a button with custom states for up, hovering, and down
81+{-| Same as `button` but lets you customize buttons to look however you want.
75−(given in that order). The result is an `Element` and a signal of
82+
76−units. This signal triggers whenever the button is pressed.
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")
77-}
92-}
78−customButton : Element -> Element -> Element -> (Element, Signal ())
93+customButton : Handle a -> a -> Element -> Element -> Element -> Element
79−customButton up hover down =
94+customButton = Native.Graphics.Input.customButton
80− let pool = customButtons ()
95+
81− in (pool.customButton () up hover down, pool.events)
96+{-| Create a checkbox. The following example creates three synced checkboxes:
82−
97+
83−{-| Create a group of checkboxes.
98+ check : Input Bool
84−
99+ check = input False
85− * The first argument is the default value of the `events` signal.
100+
86− * The `events` signal represents all of the activity in this group
101+ boxes : Bool -> Element
87− of checkboxes.
102+ boxes checked =
88− * The `checkbox` function creates a
103+ let box = container 40 40 middle (checkbox check.handle id checked)
89− checkbox with a given state. The `(Bool -> a)` function is used
104+ in flow right [ box, box, box ]
90− when the checkbox is modified. It takes the new state and turns
105+
91− it into a value that can be sent to `events`. For example, this
106+ main : Signal Element
92− lets you add an ID to distinguish between checkboxes.
107+ main = boxes <~ check.signal
93-}
108-}
94−checkboxes : a -> { events : Signal a,
95− checkbox : (Bool -> a) -> Bool -> Element }
109+checkbox : Handle a -> (Bool -> a) -> Bool -> Element
96−checkboxes = Native.Graphics.Input.checkboxes
110+checkbox = Native.Graphics.Input.checkbox
97−
111+
98−{-| Create a checkbox with a given start state. Unlike `button`, this
112+{-| Create a drop-down menu. The following drop-down lets you choose your
99−result is a *signal* of elements. That is because a checkbox has state
113+favorite British sport:
100−that updates based on user input. The boolean signal represents the
114+
101−current state of the checkbox.
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`.
102-}
131-}
103−checkbox : Bool -> (Signal Element, Signal Bool)
132+dropDown : Handle a -> [(String,a)] -> Element
104−checkbox b =
133+dropDown = Native.Graphics.Input.dropDown
105− let cbs = checkboxes b
134+
106− in (lift (cbs.checkbox id) cbs.events, cbs.events)
135+{-| Detect mouse hovers over a specific `Element`. In the following example,
107−
136+we will create a hoverable picture called `cat`.
108−{-| Detect when the mouse is hovering over some elements. This
137+
109−allows you to create and destroy elements dynamically and still
138+ hover : Input Bool
110−detect hover information.
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`.
111-}
147-}
112−hoverables : a -> { events : Signal a,
113− hoverable : (Bool -> a) -> Element -> Element }
148+hoverable : Handle a -> (Bool -> a) -> Element -> Element
114−hoverables = Native.Graphics.Input.hoverables
149+hoverable = Native.Graphics.Input.hoverable
115
150
116−{-| Detect when the mouse is hovering over a specific `Element`. -}
151+{-| Detect mouse clicks on a specific `Element`. In the following example,
117−hoverable : Element -> (Element, Signal Bool)
152+we will create a clickable picture called `cat`.
118−hoverable elem =
119− let pool = hoverables False
120− in (pool.hoverable id elem, pool.events)
121
153
122−{-| Represents the current state of a text field. The `string` represents the
154+ data Picture = Cat | Hat
123−characters filling the text field. The `selectionStart` and `selectionEnd`
155+
124−values represent what the user has selected with their mouse or keyboard.
156+ picture : Input Picture
125−For example:
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
126
175
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)
128
179
129This means the user highlighted the substring `"She"` backwards.
180This means the user highlighted the substring `"She"` backwards.
130-}
181-}
131−type FieldState = { string:String, selectionStart:Int, selectionEnd:Int }
182+type FieldContent = { string:String, selection:Selection }
132−
183+
133−{-| Create a group of text input fields.
184+{-| The selection within a text field. `start` is never greater than `end`:
134−
185+
135− * The first argument is the default value of the `events` signal.
186+ Selection 0 0 Forward -- cursor precedes all characters
136− * The `events` signal represents all of the activity in this group
187+
137− of text fields.
188+ Selection 5 9 Backward -- highlighting characters starting after
138− * The `field` function creates a
189+ -- the 5th and ending after the 9th
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.
144-}
190-}
145−fields : a -> { events : Signal a,
191+type Selection = { start:Int, end:Int, direction:Direction }
146− field : (FieldState -> a) -> String -> FieldState -> Element }
192+
147−fields = Native.Graphics.Input.fields
193+{-| The direction of selection.-}
194+data Direction = Forward | Backward
148
195
149−{-| The empty field state:
196+{-| A field with no content:
150
197
151− { string="", selectionStart=0, selectionEnd=0 }
198+ FieldContent "" (Selection 0 0 Forward)
152-}
199-}
153−emptyFieldState : FieldState
200+noContent : FieldContent
154−emptyFieldState = { string="", selectionStart=0, selectionEnd=0 }
201+noContent = FieldContent "" (Selection 0 0 Forward)
155
202
156−{-| Create a field with the given default text. The output is an element
203+{-| Create a text field. The following example creates a time-varying element
157−that updates to match the user input and a signal of strings representing
204+called `nameField`. As the user types their name, the field will be updated
158−the content of the field.
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
159-}
212-}
160−field : String -> (Signal Element, Signal String)
213+field : Handle a -> (FieldContent -> a) -> String -> FieldContent -> Element
161−field placeHolder =
214+field = Native.Graphics.Input.field
162− let tfs = fields emptyFieldState
163− changes = dropRepeats tfs.events
164− in (lift (tfs.field id placeHolder) changes,
165− dropRepeats (lift .string changes))
166
215
167{-| Same as `field` but the UI element blocks out each characters. -}
216{-| Same as `field` but the UI element blocks out each characters. -}
168−password : String -> (Signal Element, Signal String)
217+password : Handle a -> (FieldContent -> a) -> String -> FieldContent -> Element
169−password placeHolder =
170− let tfs = Native.Graphics.Input.passwords emptyFieldState
218+password = Native.Graphics.Input.password
171− changes = dropRepeats tfs.events
172− in (lift (tfs.field id placeHolder) changes,
173− dropRepeats (lift .string changes))
174
219
175{-| Same as `field` but it adds an annotation that this field is for email
220{-| Same as `field` but it adds an annotation that this field is for email
176addresses. This is helpful for auto-complete and for mobile users who may
221addresses. This is helpful for auto-complete and for mobile users who may
177get a custom keyboard with an `@` and `.com` button.
222get a custom keyboard with an `@` and `.com` button.
178-}
223-}
179−email : String -> (Signal Element, Signal String)
224+email : Handle a -> (FieldContent -> a) -> String -> FieldContent -> Element
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
225+email = Native.Graphics.Input.email
193
226
194−{-| Create a drop-down menu for selecting strings. The resulting
227+-- area : Handle a -> (FieldContent -> a) -> Handle b -> ((Int,Int) -> b) -> (Int,Int) -> String -> FieldContent -> Element
195−signal of strings represents the string that is currently selected.
228+-- area = Native.Graphics.Input.area
196−-}
197−stringDropDown : [String] -> (Signal Element, Signal String)
198−stringDropDown strs =
199− dropDown (List.map (\s -> (s,s)) strs)
libraries/Http.elm+1−1
@@ -14,7 +14,7 @@ you have very strict latency requirements.
14@docs Response
14@docs Response
15-}
15-}
16
16
17−import open Signal
17+import Signal (..)
18import Native.Http
18import Native.Http
19
19
20{-| The datatype for responses. Success contains only the returned message.
20{-| The datatype for responses. Success contains only the returned message.
libraries/Json.elm+1−1
@@ -17,7 +17,7 @@ module Json where
17
17
18-}
18-}
19
19
20−import open Basics
20+import Basics (..)
21import Dict
21import Dict
22import Maybe (Maybe)
22import Maybe (Maybe)
23import JavaScript as JS
23import JavaScript as JS
libraries/List.elm+2−2
@@ -10,7 +10,7 @@ list must have the same type.
10@docs head, tail, last, filter, take, drop
10@docs head, tail, last, filter, take, drop
11
11
12# Putting Lists Together
12# Putting Lists Together
13−@docs concat, concatMap, join, intersperse, zip, zipWith
13+@docs concat, concatMap, join, intersperse, zip, zipWith, repeat
14
14
15# Taking Lists Apart
15# Taking Lists Apart
16@docs partition, unzip
16@docs partition, unzip
@@ -25,7 +25,7 @@ list must have the same type.
25@docs sort, sortBy, sortWith
25@docs sort, sortBy, sortWith
26-}
26-}
27
27
28−import open Basics
28+import Basics (..)
29import Native.List
29import Native.List
30
30
31{-| Add an element to the front of a list `(1 :: [2,3] == [1,2,3])` -}
31{-| 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).
21-}
21-}
22data Maybe a = Just a | Nothing
22data Maybe a = Just a | Nothing
23
23
24−{-| Apply a function to the contents of a `Maybe`.
24+{-| Provide a default value and a function to extract the contents of a `Maybe`.
25−Return default when given `Nothing`.
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
26-}
33-}
27maybe : b -> (a -> b) -> Maybe a -> b
34maybe : b -> (a -> b) -> Maybe a -> b
28maybe b f m = case m of
35maybe b f m = case m of
29 Just v -> f v
36 Just v -> f v
30 Nothing -> b
37 Nothing -> b
31
38
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
33-}
44-}
34isJust : Maybe a -> Bool
45isJust : Maybe a -> Bool
35isJust = maybe False (\_ -> True)
46isJust = maybe False (\_ -> True)
36
47
37{-| Check if constructed with `Nothing`.
48{-| Check if constructed with `Nothing`.
49+
50+ isNothing (Just 42) == False
51+ isNothing (Just []) == False
52+ isNothing Nothing == True
38-}
53-}
39isNothing : Maybe a -> Bool
54isNothing : Maybe a -> Bool
40isNothing = not . isJust
55isNothing = not . isJust
41
56
57+cons : Maybe a -> [a] -> [a]
42cons mx xs = maybe xs (\x -> x :: xs) mx
58cons mx xs = maybe xs (\x -> x :: xs) mx
43
59
44{-| Filters out Nothings and extracts the remaining values.
60{-| Filters out Nothings and extracts the remaining values.
61+
62+ justs [Just 0, Nothing, Just 5, Just 7] == [0,5,7]
45-}
63-}
46justs : [Maybe a] -> [a]
64justs : [Maybe a] -> [a]
47justs = foldr cons []
65justs = 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 @@
1Elm.Native.Graphics.Input = {};
1Elm.Native.Graphics.Input = {};
2Elm.Native.Graphics.Input.make = function(elm) {
2Elm.Native.Graphics.Input.make = function(elm) {
3−
4− elm.Native = elm.Native || {};
3+ elm.Native = elm.Native || {};
5− elm.Native.Graphics = elm.Native.Graphics || {};
4+ elm.Native.Graphics = elm.Native.Graphics || {};
6− elm.Native.Graphics.Input = elm.Native.Graphics.Input || {};
5+ elm.Native.Graphics.Input = elm.Native.Graphics.Input || {};
7− if (elm.Native.Graphics.Input.values) return elm.Native.Graphics.Input.values;
6+ if (elm.Native.Graphics.Input.values) return elm.Native.Graphics.Input.values;
8−
7+
9− var Render = ElmRuntime.use(ElmRuntime.Render.Element);
8+ var Render = ElmRuntime.use(ElmRuntime.Render.Element);
10− var newNode = ElmRuntime.use(ElmRuntime.Render.Utils).newElement;
9+ var newNode = ElmRuntime.use(ElmRuntime.Render.Utils).newElement;
11−
10+
12− var Signal = Elm.Signal.make(elm);
11+ var Signal = Elm.Signal.make(elm);
13− var newElement = Elm.Graphics.Element.make(elm).newElement;
12+ var newElement = Elm.Graphics.Element.make(elm).newElement;
14− var JS = Elm.Native.JavaScript.make(elm);
13+ var JS = Elm.Native.JavaScript.make(elm);
15− var Utils = Elm.Native.Utils.make(elm);
14+ var Utils = Elm.Native.Utils.make(elm);
16− var Tuple2 = Utils.Tuple2;
15+ var Tuple2 = Utils.Tuple2;
17−
16+
17+ function input(initialValue) {
18+ var signal = Signal.constant(initialValue);
19+ return { _:{}, signal:signal, handle:signal };
20+ }
21+
18− function dropDown(values) {
22+ function renderDropDown(signal, values) {
23+ return function(_) {
19− var entries = JS.fromList(values);
24+ var entries = JS.fromList(values);
20− var events = Signal.constant(entries[0]._1);
25+
21−
22− var drop = newNode('select');
26+ var drop = newNode('select');
23− drop.style.border = '0 solid';
27+ drop.style.border = '0 solid';
28+ drop.style.pointerEvents = 'auto';
24− for (var i = 0; i < entries.length; ++i) {
29+ for (var i = 0; i < entries.length; ++i) {
25− var option = newNode('option');
30+ var option = newNode('option');
26− var name = JS.fromString(entries[i]._0);
31+ var name = JS.fromString(entries[i]._0);
27− option.value = name;
32+ option.value = name;
28− option.innerHTML = name;
33+ option.innerHTML = name;
29− drop.appendChild(option);
34+ drop.appendChild(option);
30− }
35+ }
31− drop.addEventListener('change', function() {
36+ drop.addEventListener('change', function() {
32− elm.notify(events.id, entries[drop.selectedIndex]._1);
37+ elm.notify(signal.id, entries[drop.selectedIndex]._1);
33− });
38+ });
34−
39+
35− var t = drop.cloneNode(true);
40+ var t = drop.cloneNode(true);
36− t.style.visibility = "hidden";
41+ t.style.visibility = "hidden";
37−
42+
38− elm.node.appendChild(t);
43+ elm.node.appendChild(t);
39− var style = window.getComputedStyle(t, null);
44+ var style = window.getComputedStyle(t, null);
40− var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);
45+ var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);
41− var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);
46+ var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);
42− elm.node.removeChild(t);
47+ elm.node.removeChild(t);
43−
48+ return drop;
49+ };
50+ }
51+
52+ function updateDropDown(node, oldModel, newModel) {
53+ }
54+
55+ function dropDown(signal, values) {
44− var element = A3(newElement, w, h, {
56+ return A3(newElement, 100, 24, {
45− ctor: 'Custom',
57+ ctor: 'Custom',
46− type: 'DropDown',
58+ type: 'DropDown',
47− render: function render(model) { return drop; },
59+ render: renderDropDown(signal,values),
48− update: function update(node, oldModel, newModel) {},
60+ update: updateDropDown,
49− model: {}
61+ model: {}
50− });
62+ });
51−
52− return Tuple2(Signal.constant(element), events);
53− }
63+ }
54−
64+
55− function buttons(defaultValue) {
65+ function renderButton(model) {
56− var events = Signal.constant(defaultValue);
66+ var node = newNode('button');
57−
67+ node.style.display = 'block';
58− function render(model) {
68+ node.style.pointerEvents = 'auto';
59− var b = newNode('button');
69+ node.elm_signal = model.signal;
60− b.style.display = 'block';
70+ node.elm_value = model.value;
61− b.elmEvent = model.event;
62− function click() { elm.notify(events.id, b.elmEvent); }
71+ function click() {
72+ elm.notify(node.elm_signal.id, node.elm_value);
73+ }
63− b.addEventListener('click', click);
74+ node.addEventListener('click', click);
64− b.innerHTML = model.text;
75+ node.innerHTML = model.text;
65− return b;
76+ return node;
66− }
77+ }
67−
78+
68− function update(node, oldModel, newModel) {
79+ function updateButton(node, oldModel, newModel) {
69− node.elmEvent = newModel.event;
80+ node.elm_signal = newModel.signal;
81+ node.elm_value = nemModel.value;
70− var txt = newModel.text;
82+ var txt = newModel.text;
71− if (oldModel.text !== txt) node.innerHTML = txt;
83+ if (oldModel.text !== txt) node.innerHTML = txt;
72− }
84+ }
73−
85+
74− function button(evnt, txt) {
86+ function button(signal, value, text) {
75− return A3(newElement, 100, 40, {
87+ return A3(newElement, 100, 40, {
76− ctor: 'Custom',
88+ ctor: 'Custom',
77− type: 'Button',
89+ type: 'Button',
78− render: render,
90+ render: renderButton,
79− update: update,
91+ update: updateButton,
80− model: { event:evnt, text:JS.fromString(txt) }
92+ model: { signal:signal, value:value, text:JS.fromString(text) }
81− });
93+ });
82− }
94+ }
83−
95+
84− return { _:{}, button:F2(button), events:events };
96+ function renderCustomButton(model) {
85− }
97+ var btn = newNode('div');
86−
98+ btn.style.pointerEvents = 'auto';
87− function customButtons(defaultValue) {
99+ btn.elm_signal = model.signal;
88− var events = Signal.constant(defaultValue);
100+ btn.elm_value = model.value;
89−
101+
90− function render(model) {
91− var btn = newNode('div');
92− btn.elmEvent = model.event;
93−
94− btn.elmUp = Render.render(model.up);
102+ btn.elm_up = Render.render(model.up);
95− btn.elmHover = Render.render(model.hover);
103+ btn.elm_hover = Render.render(model.hover);
96− btn.elmDown = Render.render(model.down);
104+ btn.elm_down = Render.render(model.down);
97−
105+
98− function replace(node) {
106+ function replace(node) {
107+ if (node !== btn.firstChild) {
99− if (node !== btn.firstChild) btn.replaceChild(node, btn.firstChild);
108+ btn.replaceChild(node, btn.firstChild);
109+ }
100− }
110+ }
101− var overCount = 0;
111+ var overCount = 0;
102− function over(e) {
112+ function over(e) {
103− if (overCount++ > 0) return;
113+ if (overCount++ > 0) return;
104− replace(btn.elmHover);
114+ replace(btn.elm_hover);
105− }
115+ }
106− function out(e) {
116+ function out(e) {
107− if (btn.contains(e.toElement || e.relatedTarget)) return;
117+ if (btn.contains(e.toElement || e.relatedTarget)) return;
108− overCount = 0;
118+ overCount = 0;
109− replace(btn.elmUp);
119+ replace(btn.elm_up);
110− }
120+ }
111− function up() {
121+ function up() {
112− replace(btn.elmHover);
122+ replace(btn.elm_hover);
113− elm.notify(events.id, btn.elmEvent);
123+ elm.notify(btn.elm_signal.id, btn.elm_value);
114− }
124+ }
115− function down() { replace(btn.elmDown); }
125+ function down() {
126+ replace(btn.elm_down);
127+ }
116− btn.addEventListener('mouseover', over);
128+ btn.addEventListener('mouseover', over);
117− btn.addEventListener('mouseout' , out);
129+ btn.addEventListener('mouseout' , out);
118− btn.addEventListener('mousedown', down);
130+ btn.addEventListener('mousedown', down);
119− btn.addEventListener('mouseup' , up);
131+ btn.addEventListener('mouseup' , up);
120−
132+
121− btn.appendChild(btn.elmUp);
133+ btn.appendChild(btn.elm_up);
122−
134+
123− var clicker = newNode('div');
135+ var clicker = newNode('div');
124− clicker.style.width = btn.elmUp.style.width;
136+ clicker.style.width = btn.elm_up.style.width;
125− clicker.style.height = btn.elmUp.style.height;
137+ clicker.style.height = btn.elm_up.style.height;
126− clicker.style.position = 'absolute';
138+ clicker.style.position = 'absolute';
127− clicker.style.top = 0;
139+ clicker.style.top = 0;
128− btn.appendChild(clicker);
140+ btn.appendChild(clicker);
129−
141+
130− return btn;
142+ return btn;
131− }
143+ }
132−
144+
133− function update(node, oldModel, newModel) {
145+ function updateCustomButton(node, oldModel, newModel) {
134− node.elmEvent = newModel.event;
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+
135− Render.update(node.elmUp, oldModel.up, newModel.up)
156+ Render.update(node.elm_up, oldModel.up, newModel.up)
136− Render.update(node.elmHover, oldModel.hover, newModel.hover)
157+ Render.update(node.elm_hover, oldModel.hover, newModel.hover)
137− Render.update(node.elmDown, oldModel.down, newModel.down)
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;
138− }
164+ }
139−
165+
140− function button(evnt, up, hover, down) {
166+ function customButton(signal, value, up, hover, down) {
141− return A3(newElement,
167+ return A3(newElement,
142− Math.max(up.props.width, hover.props.width, down.props.width),
168+ max3(up.props.width, hover.props.width, down.props.width),
143− Math.max(up.props.height, hover.props.height, down.props.height),
169+ max3(up.props.height, hover.props.height, down.props.height),
144− { ctor: 'Custom',
170+ { ctor: 'Custom',
145− type: 'CustomButton',
171+ type: 'CustomButton',
146− render: render,
172+ render: renderCustomButton,
147− update: update,
173+ update: updateCustomButton,
148− model: { event:evnt, up:up, hover:hover, down:down }
174+ model: { signal:signal, value:value, up:up, hover:hover, down:down }
149− });
175+ });
150− }
151−
152− return { _:{}, customButton:F4(button), events:events };
153− }
176+ }
154−
177+
155−
178+ function renderCheckbox(model) {
156− function hoverables(defaultValue) {
179+ var node = newNode('input');
157− var events = Signal.constant(defaultValue);
180+ node.type = 'checkbox';
158− function hoverable(handler, elem) {
181+ node.checked = model.checked;
159− function onHover(bool) {
182+ node.style.display = 'block';
160− elm.notify(events.id, handler(bool));
183+ node.style.pointerEvents = 'auto';
161− }
184+ node.elm_signal = model.signal;
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;
185+ node.elm_handler = model.handler;
178− function change() { elm.notify(events.id, b.elmHandler(b.checked)); }
186+ function change() {
187+ elm.notify(node.elm_signal.id, node.elm_handler(node.checked));
188+ }
179− b.addEventListener('change', change);
189+ node.addEventListener('change', change);
180− return b;
190+ return node;
181− }
191+ }
182−
192+
183− function update(node, oldModel, newModel) {
193+ function updateCheckbox(node, oldModel, newModel) {
184− node.elmHandler = newModel.handler;
194+ node.elm_signal = newModel.signal;
195+ node.elm_handler = newModel.handler;
185− node.checked = newModel.checked;
196+ node.checked = newModel.checked;
186− return true;
197+ return true;
187− }
198+ }
188−
199+
189− function box(handler, checked) {
200+ function checkbox(signal, handler, checked) {
190− return A3(newElement, 13, 13, {
201+ return A3(newElement, 13, 13, {
191− ctor: 'Custom',
202+ ctor: 'Custom',
192− type: 'CheckBox',
203+ type: 'CheckBox',
193− render: render,
204+ render: renderCheckbox,
194− update: update,
205+ update: updateCheckbox,
195− model: { checked:checked, handler:handler }
206+ model: { signal:signal, handler:handler, checked:checked }
196− });
207+ });
197− }
198−
199− return { _:{}, checkbox:F2(box), events:events };
200− }
208+ }
201−
209+
202− function setRange(node, start, end, dir) {
210+ function setRange(node, start, end, dir) {
203− if (node.parentNode) {
211+ if (node.parentNode) {
204− node.setSelectionRange(start, end, dir);
212+ node.setSelectionRange(start, end, dir);
205− } else {
213+ } else {
206− setTimeout(function(){node.setSelectionRange(start, end, dir);}, 0);
214+ setTimeout(function(){node.setSelectionRange(start, end, dir);}, 0);
207− }
215+ }
208− }
216+ }
209−
217+
210− function mkTextPool(type) { return function fields(defaultValue) {
218+ function renderField(model) {
211− var events = Signal.constant(defaultValue);
219+ var field = newNode('input');
212−
220+ field.style.border = 'none';
213− var state = null;
221+ field.style.outline = 'none';
214−
222+ field.style.backgroundColor = 'transparent';
215− function render(model) {
223+ field.style.pointerEvents = 'auto';
216− var field = newNode('input');
224+
217− field.elmHandler = model.handler;
218−
219− field.id = 'test';
220− field.type = type;
225+ field.type = model.type;
221− field.placeholder = JS.fromString(model.placeHolder);
226+ field.placeholder = JS.fromString(model.placeHolder);
222− field.value = JS.fromString(model.state.string);
227+ field.value = JS.fromString(model.content.string);
223− setRange(field, model.state.selectionStart, model.state.selectionEnd, 'forward');
228+ var selection = model.content.selection;
224− field.style.border = 'none';
229+ var direction = selection.direction.ctor === 'Forward' ? 'forward' : 'backward';
225− state = model.state;
230+ setRange(field, selection.start, selection.end, direction);
226−
231+
227− function update() {
232+ field.elm_signal = model.signal;
228− var start = field.selectionStart,
233+ field.elm_handler = model.handler;
229− end = field.selectionEnd;
234+ field.elm_old_value = field.value;
230− if (field.selectionDirection === 'backward') {
235+
231− start = end;
236+ function keyUpdate(event) {
232− end = field.selectionStart;
237+ var curr = field.value;
233− }
238+ var next = (curr.slice(0, field.selectionStart) +
234− state = { _:{},
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+ _:{},
235− string:JS.toString(field.value),
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';
236− selectionStart:start,
262+ var start = field.selectionStart;
237− selectionEnd:end };
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';
238− elm.notify(events.id, field.elmHandler(state));
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+ }));
239− }
288+ }
240− function mousedown() {
289+ function mousedown(event) {
241− update();
290+ mouseUpdate(event);
242− elm.node.addEventListener('mouseup', mouseup);
291+ elm.node.addEventListener('mouseup', mouseup);
243− }
292+ }
244− function mouseup() {
293+ function mouseup(event) {
245− update();
294+ mouseUpdate(event);
246− elm.node.removeEventListener('mouseup', mouseup)
295+ elm.node.removeEventListener('mouseup', mouseup)
247− }
296+ }
297+ field.addEventListener('keypress', keyUpdate);
248− field.addEventListener('keyup', update);
298+ field.addEventListener('input', inputUpdate);
249− field.addEventListener('mousedown', mousedown);
299+ field.addEventListener('mousedown', mousedown);
250−
300+
251− return field;
301+ return field;
252− }
302+ }
253−
303+
254− function update(node, oldModel, newModel) {
304+ function updateField(field, oldModel, newModel) {
255− node.elmHandler = newModel.handler;
305+ field.elm_signal = newModel.signal;
256− if (state === newModel.state) return;
306+ field.elm_handler = newModel.handler;
307+
308+ field.type = newModel.type;
309+ field.placeholder = JS.fromString(newModel.placeHolder);
257− var newStr = JS.fromString(newModel.state.string);
310+ var value = JS.fromString(newModel.content.string);
258− if (node.value !== newStr) node.value = newStr;
311+ field.value = value;
259−
312+ field.elm_old_value = value;
260− var start = newModel.state.selectionStart;
313+ var selection = newModel.content.selection;
261− var end = newModel.state.selectionEnd;
314+ var direction = selection.direction.ctor === 'Forward' ? 'forward' : 'backward';
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);
315+ setRange(field, selection.start, selection.end, direction);
273− }
316+ }
274− }
317+
275−
318+ function mkField(type) {
276− function field(handler, placeHolder, state) {
319+ function field(signal, handler, placeHolder, content) {
277− return A3(newElement, 200, 30,
320+ return A3(newElement, 200, 30, {
278− { ctor: 'Custom',
321+ ctor: 'Custom',
279− type: type + 'Input',
322+ type: type + 'Input',
280− render: render,
323+ render: renderField,
281− update: update,
324+ update: updateField,
325+ model: {
326+ signal:signal,
282− model: { handler:handler,
327+ handler:handler,
283− placeHolder:placeHolder,
328+ placeHolder:placeHolder,
284− state:state }
329+ content:content,
330+ type:type
331+ }
332+ });
285− });
333+ }
334+ return F4(field);
286− }
335+ }
287−
336+
288− return { _:{}, field:F3(field), events:events };
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 };
289− }
344+ }
345+
346+ function clickable(signal, value, elem) {
347+ function onClick(bool) {
348+ elm.notify(signal.id, value);
290− }
349+ }
291−
350+ var props = Utils.replace([['click',onClick]], elem.props);
351+ return { props:props, element:elem.element };
352+ }
353+
292− return elm.Native.Graphics.Input.values = {
354+ return elm.Native.Graphics.Input.values = {
293− buttons:buttons,
355+ input:input,
294− customButtons:customButtons,
356+ button:F3(button),
295− hoverables:hoverables,
357+ customButton:F5(customButton),
296− checkboxes:checkboxes,
358+ checkbox:F3(checkbox),
297− fields:mkTextPool('text'),
359+ dropDown:F2(dropDown),
298− emails:mkTextPool('email'),
360+ field:mkField('text'),
299− passwords:mkTextPool('password'),
361+ email:mkField('email'),
300− dropDown:dropDown
362+ password:mkField('password'),
363+ hoverable:F3(hoverable),
364+ clickable:F3(clickable)
301− };
365+ };
302
366
303};
367};
libraries/Native/Regex.js+10−19
@@ -15,7 +15,7 @@ Elm.Native.Regex.make = function(elm) {
15 function caseInsensitive(re) {
15 function caseInsensitive(re) {
16 return new RegExp(re.source, 'gi');
16 return new RegExp(re.source, 'gi');
17 }
17 }
18− function pattern(raw) {
18+ function regex(raw) {
19 return new RegExp(raw, 'g');
19 return new RegExp(raw, 'g');
20 }
20 }
21
21
@@ -23,10 +23,8 @@ Elm.Native.Regex.make = function(elm) {
23 return re.test(JS.fromString(string));
23 return re.test(JS.fromString(string));
24 }
24 }
25
25
26− function findAll(re, string) {
27− return find(Infinity, re, string);
28− }
29 function find(n, re, str) {
26 function find(n, re, str) {
27+ n = n.ctor === "All" ? Infinity : n._0;
30 var out = [];
28 var out = [];
31 var number = 0;
29 var number = 0;
32 var string = JS.fromString(str);
30 var string = JS.fromString(str);
@@ -51,10 +49,8 @@ Elm.Native.Regex.make = function(elm) {
51 return JS.toList(out);
49 return JS.toList(out);
52 }
50 }
53
51
54− function replaceAll(re, replacer, string) {
55− return replace(Infinity, re, replacer, string);
56− }
57 function replace(n, re, replacer, string) {
52 function replace(n, re, replacer, string) {
53+ n = n.ctor === "All" ? Infinity : n._0;
58 var count = 0;
54 var count = 0;
59 function jsReplacer(match) {
55 function jsReplacer(match) {
60 if (count++ > n) return match;
56 if (count++ > n) return match;
@@ -77,10 +73,10 @@ Elm.Native.Regex.make = function(elm) {
77 return string.replace(re, jsReplacer);
73 return string.replace(re, jsReplacer);
78 }
74 }
79
75
80− function split(re, string) {
76+ function split(n, re, str) {
77+ if (n === Infinity) {
81− return JS.toList(JS.fromString(string).split(re));
78+ return JS.toList(JS.fromString(string).split(re));
82− }
79+ }
83− function splitN(n, re, str) {
84 var string = JS.fromString(str);
80 var string = JS.fromString(str);
85 var result;
81 var result;
86 var out = [];
82 var out = [];
@@ -95,18 +91,13 @@ Elm.Native.Regex.make = function(elm) {
95 }
91 }
96
92
97 return Elm.Native.Regex.values = {
93 return Elm.Native.Regex.values = {
98− pattern: pattern,
94+ regex: regex,
99 caseInsensitive: caseInsensitive,
95 caseInsensitive: caseInsensitive,
100 escape: escape,
96 escape: escape,
101
97
102 contains: F2(contains),
98 contains: F2(contains),
103− findAll: F2(findAll),
104 find: F3(find),
99 find: F3(find),
105−
106− replaceAll: F3(replaceAll),
107 replace: F4(replace),
100 replace: F4(replace),
108−
109− split: F2(split),
101+ split: F3(split),
110− splitN: F3(splitN),
111 };
102 };
112−};
103+};
libraries/Native/Trampoline.js+4−2
@@ -5,7 +5,7 @@ Elm.Native.Trampoline.make = function(elm) {
5 if (elm.Native.Trampoline.values) return elm.Native.Trampoline.values;
5 if (elm.Native.Trampoline.values) return elm.Native.Trampoline.values;
6
6
7 // trampoline : Trampoline a -> a
7 // trampoline : Trampoline a -> a
8− trampoline = function(t) {
8+ function trampoline(t) {
9 var tramp = t;
9 var tramp = t;
10 while(true) {
10 while(true) {
11 switch(tramp.ctor) {
11 switch(tramp.ctor) {
@@ -18,5 +18,7 @@ Elm.Native.Trampoline.make = function(elm) {
18 }
18 }
19 }
19 }
20
20
21− return elm.Native.Trampoline.values = { trampoline: trampoline };
21+ return elm.Native.Trampoline.values = {
22+ trampoline:trampoline
23+ };
22};
24};
libraries/Regex.elm+49−56
@@ -3,16 +3,17 @@ module Regex where
3same kind of regular expressions accepted by JavaScript](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions).
3same kind of regular expressions accepted by JavaScript](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions).
4
4
5# Create
5# Create
6−@docs pattern, caseInsensitive, escape
6+@docs regex, escape, caseInsensitive
7
7
8−# Match
8+# Helpful Data Structures
9−@docs Match
10
9
11−# Find and Replace
10+These data structures are needed to help define functions like [`find`](#find)
12−@docs contains, find, findAll, replace, replaceAll
11+and [`replace`](#replace).
13
12
14−# Split
13+@docs HowMany, Match
14+
15+# Use
15−@docs split, splitN
16+@docs contains, find, replace, split
16
17
17-}
18-}
18
19
@@ -21,31 +22,35 @@ import Native.Regex
21
22
22data Regex = Regex
23data Regex = Regex
23
24
24−{-| Escape all special characters. So `pattern (escape "$$$")`
25+{-| Escape strings to be regular expressions, making all special characters
25−will match exactly `"$$$"` even though `$` is a special character.
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.
26-}
28-}
27escape : String -> String
29escape : String -> String
28escape = Native.Regex.escape
30escape = Native.Regex.escape
29
31
30{-| 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).
32{-| 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).
33+
31−Be careful to escape backslashes properly!
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.
32-}
37-}
33−pattern : String -> Regex
38+regex : String -> Regex
34−pattern = Native.Regex.pattern
39+regex = Native.Regex.regex
35
40
36
41
37−{-| Make a pattern case insensitive -}
42+{-| Make a regex case insensitive -}
38caseInsensitive : Regex -> Regex
43caseInsensitive : Regex -> Regex
39caseInsensitive = Native.Regex.caseInsensitive
44caseInsensitive = Native.Regex.caseInsensitive
40
45
41{-| Check to see if a Regex is contained in a string.
46{-| Check to see if a Regex is contained in a string.
42
47
43```haskell
48```haskell
44− contains (pattern "123") "12345" == True
49+ contains (regex "123") "12345" == True
45− contains (pattern "b+") "aabbcc" == True
50+ contains (regex "b+") "aabbcc" == True
46
51
47− contains (pattern "789") "12345" == False
52+ contains (regex "789") "12345" == False
48− contains (pattern "z+") "aabbcc" == False
53+ contains (regex "z+") "aabbcc" == False
49```
54```
50-}
55-}
51contains : Regex -> String -> Bool
56contains : Regex -> String -> Bool
@@ -55,79 +60,67 @@ contains = Native.Regex.contains
55Here are details on each field:
60Here are details on each field:
56
61
57 * `match` &mdash; the full string of the match.
62 * `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
59 parentheses](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions#Using_Parenthesized_Substring_Matches).
64 parentheses](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions#Using_Parenthesized_Substring_Matches).
60 If there are N subpatterns, there will be N elements in the `submatches` list.
65 If there are N subpatterns, there will be N elements in the `submatches` list.
61 Each submatch in this list is a `Maybe` because not all subpatterns may trigger.
66 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
63 many `b`&rsquo;s, but never both.
68 many `b`&rsquo;s, but never both.
64 * `index` &mdash; the index of the match in the original string.
69 * `index` &mdash; the index of the match in the original string.
65 * `number` &mdash; if you find many matches, you can think of each one
70 * `number` &mdash; if you find many matches, you can think of each one
66 as being labeled with a `number` starting at one. So the first time you
71 as being labeled with a `number` starting at one. So the first time you
67 find a match, that is match `number` one. Second time is match `number` two.
72 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
69 many times a pattern has appeared before.
74 many times a pattern has appeared before.
70-}
75-}
71type Match = { match : String, submatches : [Maybe String], index : Int, number : Int }
76type Match = { match : String, submatches : [Maybe String], index : Int, number : Int }
72
77
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+
73−{-| Find all of the matches in a string:
84+{-| Find matches in a string:
74
85
75```haskell
86```haskell
76− words = findAll (pattern "\\w+") "hello world"
87+ findTwoCommas = find (AtMost 2) (regex ",")
77
88
78− map .match words == ["hello","world"]
89+ -- map .index (findTwoCommas "a,b,c,d,e") == [1,3]
79− map .index words == [0,6]
90+ -- map .index (findTwoCommas "a b c d e") == []
80
91
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."
82
93
83− map .match places== ["on a boat", "in a lake"]
94+ -- map .match places == ["on a boat", "in a lake"]
84− map .submatches places == [ [Just "boat"], [Just "lake"] ]
95+ -- map .submatches places == [ [Just "boat"], [Just "lake"] ]
85```
96```
86-}
97-}
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]
95find = Native.Regex.find
99find = Native.Regex.find
96
100
97−{-| Replace all matches. The function from `Match` to `String` lets
101+{-| Replace matches. The function from `Match` to `String` lets
98you use the details of a specific match when making replacements.
102you use the details of a specific match when making replacements.
99
103
100```haskell
104```haskell
101− devowel = replaceAll (pattern "[aeiou]") (\_ -> "")
105+ devowel = replace All (regex "[aeiou]") (\_ -> "")
102
106
103− devowel "The quick brown fox" == "Th qck brwn fx"
107+ -- devowel "The quick brown fox" == "Th qck brwn fx"
104
108
105− reverseWords = replaceAll (pattern "\\w+") (\{match} -> String.reverse match)
109+ reverseWords = replace All (regex "\\w+") (\{match} -> String.reverse match)
106
110
107− reverseWords "deliver mined parts" == "reviled denim strap"
111+ -- reverseWords "deliver mined parts" == "reviled denim strap"
108```
112```
109-}
113-}
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
115replace = Native.Regex.replace
115replace = Native.Regex.replace
116
116
117{-| Split a string, using the regex as the separator.
117{-| Split a string, using the regex as the separator.
118
118
119```haskell
119```haskell
120− split (pattern " *, *") "a ,b, c,d" == ["a","b","c","d"]
120+ split (AtMost 1) (regex ",") "tom,99,90,85" == ["tom","99,90,85"]
121−```
122−-}
123−split : Regex -> String -> [String]
124−split = Native.Regex.split
125
121
126−{-| Same as `split` but stops after the *n<sup>th</sup>* match.
122+ split All (regex ",") "a,b,c,d" == ["a","b","c","d"]
127−
128−```haskell
129− splitN 1 (pattern ": *") "tom: 99,90,85" == ["tom","99,90,85"]
130```
123```
131-}
124-}
132−splitN : Int -> Regex -> String -> [String]
125+split : HowMany -> Regex -> String -> [String]
133−splitN = Native.Regex.splitN
126+split = Native.Regex.split
libraries/String.elm+5−1
@@ -103,6 +103,8 @@ foldr = Native.String.foldr
103
103
104 split "," "cat,dog,cow" == ["cat","dog","cow"]
104 split "," "cat,dog,cow" == ["cat","dog","cow"]
105 split "/" "home/evan/Desktop/" == ["home","evan","Desktop"]
105 split "/" "home/evan/Desktop/" == ["home","evan","Desktop"]
106+
107+Use `Regex.split` if you need something more flexible.
106-}
108-}
107split : String -> String -> [String]
109split : String -> String -> [String]
108split = Native.String.split
110split = Native.String.split
@@ -231,7 +233,7 @@ any = Native.String.any
231
233
232 all isDigit "90210" == True
234 all isDigit "90210" == True
233 all isDigit "R2-D2" == False
235 all isDigit "R2-D2" == False
234− any isDigit "heart" == False
236+ all isDigit "heart" == False
235-}
237-}
236all : (Char -> Bool) -> String -> Bool
238all : (Char -> Bool) -> String -> Bool
237all = Native.String.all
239all = Native.String.all
@@ -241,6 +243,8 @@ all = Native.String.all
241 contains "the" "theory" == True
243 contains "the" "theory" == True
242 contains "hat" "theory" == False
244 contains "hat" "theory" == False
243 contains "THE" "theory" == False
245 contains "THE" "theory" == False
246+
247+Use `Regex.contains` if you need something more flexible.
244-}
248-}
245contains : String -> String -> Bool
249contains : String -> String -> Bool
246contains = Native.String.contains
250contains = Native.String.contains
libraries/Text.elm+1−1
@@ -16,7 +16,7 @@ module Text where
16
16
17-}
17-}
18
18
19−import open Basics
19+import Basics (..)
20import Color (Color)
20import Color (Color)
21import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)
21import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)
22import Maybe (Maybe)
22import Maybe (Maybe)
libraries/Time.elm+1−1
@@ -14,7 +14,7 @@ module Time where
14
14
15-}
15-}
16
16
17−import open Basics
17+import Basics (..)
18import Native.Time
18import Native.Time
19import Signal (Signal)
19import Signal (Signal)
20
20
libraries/elm_dependencies.json+2
@@ -11,6 +11,7 @@
11 , "Char"
11 , "Char"
12 , "Color"
12 , "Color"
13 , "Date"
13 , "Date"
14+ , "Debug"
14 , "Dict"
15 , "Dict"
15 , "Either"
16 , "Either"
16 , "Graphics.Element"
17 , "Graphics.Element"
@@ -34,6 +35,7 @@
34 , "Text"
35 , "Text"
35 , "Time"
36 , "Time"
36 , "Touch"
37 , "Touch"
38+ , "Trampoline"
37 , "Transform2D"
39 , "Transform2D"
38 , "WebSocket"
40 , "WebSocket"
39 , "Window"
41 , "Window"
runtime/Render/Collage.js+1
@@ -254,6 +254,7 @@ function makeCanvas(w,h) {
254function render(model) {
254function render(model) {
255 var div = newElement('div');
255 var div = newElement('div');
256 div.style.overflow = 'hidden';
256 div.style.overflow = 'hidden';
257+ div.style.position = 'relative';
257 update(div, model, model);
258 update(div, model, model);
258 return div;
259 return div;
259}
260}
runtime/Render/Element.js+39−6
@@ -28,15 +28,30 @@ function setProps(props, e) {
28 e.appendChild(a);
28 e.appendChild(a);
29 }
29 }
30 if (props.hover.ctor !== '_Tuple0') {
30 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;
32 e.addEventListener('mouseover', function() {
34 e.addEventListener('mouseover', function() {
33− if (overCount++ > 0) return;
35+ if (e.elm_hover_count++ > 0) return;
34− props.hover(true);
36+ var handler = e.elm_hover_handler;
37+ if (handler !== null) {
38+ handler(true);
39+ }
35 });
40 });
36 e.addEventListener('mouseout', function(evt) {
41 e.addEventListener('mouseout', function(evt) {
37 if (e.contains(evt.toElement || evt.relatedTarget)) return;
42 if (e.contains(evt.toElement || evt.relatedTarget)) return;
38− overCount = 0;
43+ e.elm_hover_count = 0;
39− props.hover(false);
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);
40 });
55 });
41 }
56 }
42 return e;
57 return e;
@@ -99,6 +114,8 @@ function goDown(e) { return e }
99function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e; }
114function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e; }
100function flowWith(f, array) {
115function flowWith(f, array) {
101 var container = newElement('div');
116 var container = newElement('div');
117+ if (f == goIn) container.style.pointerEvents = 'none';
118+
102 for (var i = array.length; i--; ) {
119 for (var i = array.length; i--; ) {
103 container.appendChild(f(render(array[i])));
120 container.appendChild(f(render(array[i])));
104 }
121 }
@@ -209,7 +226,9 @@ function update(node, curr, next) {
209 case "RawHtml":
226 case "RawHtml":
210 // only markdown blocks have guids, so this must be a text block
227 // only markdown blocks have guids, so this must be a text block
211 if (nextE.guid === null) {
228 if (nextE.guid === null) {
229+ if(currE.html.valueOf() !== nextE.html.valueOf()) {
212− node.innerHTML = nextE.html;
230+ node.innerHTML = nextE.html;
231+ }
213 break;
232 break;
214 }
233 }
215 if (nextE.guid !== currE.guid) {
234 if (nextE.guid !== currE.guid) {
@@ -317,6 +336,20 @@ function updateProps(node, curr, next) {
317 node.lastNode.href = props.href;
336 node.lastNode.href = props.href;
318 }
337 }
319 }
338 }
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+ }
320}
353}
321
354
322return { render:render, update:update };
355return { render:render, update:update };
tests/Tests/Property.hs+17−16
@@ -10,7 +10,7 @@ import Text.Parsec.Combinator (eof)
10import Text.PrettyPrint as P
10import Text.PrettyPrint as P
11
11
12import SourceSyntax.Literal as Lit
12import SourceSyntax.Literal as Lit
13−import SourceSyntax.Pattern as Pat
13+import qualified SourceSyntax.Pattern as P
14import SourceSyntax.PrettyPrint (Pretty, pretty)
14import SourceSyntax.PrettyPrint (Pretty, pretty)
15import Parse.Helpers (IParser, iParse)
15import Parse.Helpers (IParser, iParse)
16import Parse.Literal (literal)
16import Parse.Literal (literal)
@@ -31,24 +31,25 @@ propertyTests =
31 where
31 where
32 -- This test was autogenerated from the Pattern test and should be
32 -- This test was autogenerated from the Pattern test and should be
33 -- left in all its ugly glory.
33 -- left in all its ugly glory.
34− longPat = Pat.PData "I" [ Pat.PLiteral (Lit.Chr '+')
34+ longPat = P.Data "I" [ P.Literal (Lit.Chr '+')
35− , Pat.PRecord [
35+ , P.Record
36− "q7yclkcm7k_ikstrczv_"
36+ [ "q7yclkcm7k_ikstrczv_"
37− , "wQRv6gKsvvkjw4b5F"
37+ , "wQRv6gKsvvkjw4b5F"
38− ,"c9'eFfhk9FTvsMnwF_D"
38+ ,"c9'eFfhk9FTvsMnwF_D"
39− ,"yqxhEkHvRFwZ"
39+ ,"yqxhEkHvRFwZ"
40− ,"o"
40+ ,"o"
41− ,"nbUlCn3y3NnkVoxhW"
41+ ,"nbUlCn3y3NnkVoxhW"
42− ,"iJ0MNy3KZ_lrs"
42+ ,"iJ0MNy3KZ_lrs"
43− ,"ug"
43+ ,"ug"
44− ,"sHHsX"
44+ ,"sHHsX"
45− ,"mRKs9d"
45+ ,"mRKs9d"
46− ,"o2KiCX5'ZRzHJfRi8" ]
46+ ,"o2KiCX5'ZRzHJfRi8" ]
47− , Pat.PVar "su'BrrbPUK6I33Eq" ]
47+ , P.Var "su'BrrbPUK6I33Eq"
48+ ]
48
49
49prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool
50prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool
50prop_parse_print p x =
51prop_parse_print p x =
51 either (const False) (== x) . parse_print p $ x
52 either (const False) (== x) . parse_print p $ x
52
53
53parse_print :: (Pretty a) => IParser a -> a -> Either String a
54parse_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
8import qualified Data.Set as Set
8import qualified Data.Set as Set
9import qualified Parse.Helpers (reserveds)
9import qualified Parse.Helpers (reserveds)
10
10
11−import SourceSyntax.Literal
11+import qualified SourceSyntax.Literal as L
12−import SourceSyntax.Pattern
12+import qualified SourceSyntax.Pattern as P
13−import SourceSyntax.Type hiding (listOf)
13+import qualified SourceSyntax.Type as T
14−
14+
15−instance Arbitrary Literal where
15+instance Arbitrary L.Literal where
16+ arbitrary =
17+ oneof
16− arbitrary = oneof [ IntNum <$> arbitrary
18+ [ L.IntNum <$> arbitrary
17− , FloatNum <$> (arbitrary `suchThat` noE)
19+ , L.FloatNum <$> (arbitrary `suchThat` noE)
18− , Chr <$> arbitrary
20+ , L.Chr <$> arbitrary
19− -- This is too permissive
21+ -- This is too permissive
20− , Str <$> arbitrary
22+ , L.Str <$> arbitrary
21− -- Booleans aren't actually source syntax
23+ -- Booleans aren't actually source syntax
22− -- , Boolean <$> arbitrary
24+ -- , Boolean <$> arbitrary
23− ]
25+ ]
26+
24− shrink l = case l of
27+ shrink lit =
28+ case lit of
25− IntNum n -> IntNum <$> shrink n
29+ L.IntNum n -> L.IntNum <$> shrink n
26− FloatNum f -> FloatNum <$> (filter noE . shrink $ f)
30+ L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)
27− Chr c -> Chr <$> shrink c
31+ L.Chr c -> L.Chr <$> shrink c
28− Str s -> Str <$> shrink s
32+ L.Str s -> L.Str <$> shrink s
29− Boolean b -> Boolean <$> shrink b
33+ L.Boolean b -> L.Boolean <$> shrink b
30
34
31noE :: Double -> Bool
35noE :: Double -> Bool
32noE = notElem 'e' . show
36noE = notElem 'e' . show
33
37
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
34
43
35−instance Arbitrary Pattern where
44+instance Arbitrary P.Pattern where
36 arbitrary = sized pat
45 arbitrary = sized pat
46+ where
37− where pat :: Int -> Gen Pattern
47+ pat :: Int -> Gen P.Pattern
38− pat n = oneof [ pure PAnything
48+ pat n =
49+ oneof
50+ [ pure P.Anything
39− , PVar <$> lowVar
51+ , P.Var <$> lowVar
40− , PRecord <$> (listOf1 lowVar)
52+ , P.Record <$> (listOf1 lowVar)
41− , PLiteral <$> arbitrary
53+ , P.Literal <$> arbitrary
42− , PAlias <$> lowVar <*> pat (n-1)
54+ , P.Alias <$> lowVar <*> pat (n-1)
43− , PData <$> capVar <*> sizedPats
55+ , P.Data <$> capVar <*> genVector n pat
44− ]
56+ ]
45− where sizedPats = do
57+
46− len <- choose (0,n)
47− let m = n `div` (len + 1)
48− vectorOf len $ pat m
49−
50− shrink pat = case pat of
58+ shrink pat =
51− PAnything -> []
59+ case pat of
60+ P.Anything -> []
52− PVar v -> PVar <$> shrinkWHead v
61+ P.Var v -> P.Var <$> shrinkWHead v
53− PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)
62+ P.Literal l -> P.Literal <$> shrink l
54− PLiteral l -> PLiteral <$> shrink l
55− PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
63+ P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)
56− PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
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
57
69
58shrinkWHead :: Arbitrary a => [a] -> [[a]]
70shrinkWHead :: Arbitrary a => [a] -> [[a]]
59shrinkWHead [] = error "Should be nonempty"
71shrinkWHead [] = error "Should be nonempty"
60shrinkWHead (x:xs) = (x:) <$> shrink xs
72shrinkWHead (x:xs) = (x:) <$> shrink xs
61
73
62−instance Arbitrary Type where
74+instance Arbitrary T.Type where
63 arbitrary = sized tipe
75 arbitrary = sized tipe
76+ where
64− where tipe :: Int -> Gen Type
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
65− tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
85+ [ T.Lambda <$> depthTipe <*> depthTipe
66− , Var <$> lowVar
86+ , T.Var <$> lowVar
67− , Data <$> capVar <*> depthTipes
87+ , T.Data <$> capVar <*> genVector n tipe
68− , Record <$> fields <*> pure Nothing
88+ , T.Record <$> fields <*> pure Nothing
69− , Record <$> fields1 <*> (Just <$> lowVar)
89+ , T.Record <$> fields1 <*> (Just <$> lowVar)
70− ]
90+ ]
71− where depthTipe = choose (0,n) >>= tipe
91+
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
92+ shrink tipe =
93+ case tipe of
85− Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t)
94+ T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)
86− Var _ -> []
95+ T.Var _ -> []
87− Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts)
96+ T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)
88− Record fs t -> map snd fs ++ case t of
97+ T.Record fs t -> map snd fs ++ record
98+ where
99+ record =
100+ case t of
89− Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing
101+ Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing
90− Just _ ->
102+ Just _ ->
91− do
92− fields <- filter (not . null) $ shrinkList shrinkField fs
103+ do fields <- filter (not . null) $ shrinkList shrinkField fs
93− return $ Record fields t
104+ return $ T.Record fields t
105+
94− where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
106+ shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
95
107
96lowVar :: Gen String
108lowVar :: Gen String
97lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
109lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
110+ where
98− where lower = elements ['a'..'z']
111+ lower = elements ['a'..'z']
99
112
100capVar :: Gen String
113capVar :: Gen String
101capVar = notReserved $ (:) <$> upper <*> listOf varLetter
114capVar = notReserved $ (:) <$> upper <*> listOf varLetter
115+ where
102− where upper = elements ['A'..'Z']
116+ upper = elements ['A'..'Z']
103
117
104varLetter :: Gen Char
118varLetter :: Gen Char
105varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
119varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
@@ -109,5 +123,6 @@ notReserved = flip exceptFor Parse.Helpers.reserveds
109
123
110exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
124exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
111exceptFor g xs = g `suchThat` notAnX
125exceptFor g xs = g `suchThat` notAnX
126+ where
112− where notAnX = flip Set.notMember xset
127+ notAnX = flip Set.notMember xset
113− xset = Set.fromList xs
128+ xset = Set.fromList xs