git.iko.soy/elk
on master help sign in
Update JS generation code
26fab71Evan Czaplicki
compiler/Generate/Cases.hs+41−20
compare with master
unifiedsplit
@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -W #-}
1module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where
2module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where
2
3
3import Control.Applicative ((<$>))
4import Control.Applicative ((<$>))
@@ -6,14 +7,15 @@ import Control.Monad.State
6import Data.List (groupBy,sortBy)
7import Data.List (groupBy,sortBy)
7import Data.Maybe (fromMaybe)
8import Data.Maybe (fromMaybe)
8
9
9−import SourceSyntax.Annotation
10+import AST.Annotation
10−import SourceSyntax.Expression
11+import AST.Expression.General
12+import AST.Expression.Canonical as Canonical
11−import SourceSyntax.Literal
13+import AST.Literal
12−import qualified SourceSyntax.Pattern as P
14+import qualified AST.Pattern as P
13−import qualified SourceSyntax.Variable as V
15+import qualified AST.Variable as Var
14import Transform.Substitute
16import Transform.Substitute
15
17
16−toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)
18+toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)
17toMatch patterns = do
19toMatch patterns = do
18 v <- newVar
20 v <- newVar
19 (,) v <$> match [v] (map (first (:[])) patterns) Fail
21 (,) v <$> match [v] (map (first (:[])) patterns) Fail
@@ -27,12 +29,12 @@ data Match
27 = Match String [Clause] Match
29 = Match String [Clause] Match
28 | Break
30 | Break
29 | Fail
31 | Fail
30− | Other Expr
32+ | Other Canonical.Expr
31 | Seq [Match]
33 | Seq [Match]
32 deriving Show
34 deriving Show
33
35
34data Clause =
36data Clause =
35− Clause (Either String Literal) [String] Match
37+ Clause (Either Var.Canonical Literal) [String] Match
36 deriving Show
38 deriving Show
37
39
38matchSubst :: [(String,String)] -> Match -> Match
40matchSubst :: [(String,String)] -> Match -> Match
@@ -42,7 +44,7 @@ matchSubst pairs match =
42 Fail -> Fail
44 Fail -> Fail
43 Seq ms -> Seq (map (matchSubst pairs) ms)
45 Seq ms -> Seq (map (matchSubst pairs) ms)
44 Other (A a e) ->
46 Other (A a e) ->
45− Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs
47+ Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (localVar y)) pairs
46 Match n cs m ->
48 Match n cs m ->
47 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
49 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
48 where
50 where
@@ -50,15 +52,18 @@ matchSubst pairs match =
50 clauseSubst (Clause c vs m) =
52 clauseSubst (Clause c vs m) =
51 Clause c (map varSubst vs) (matchSubst pairs m)
53 Clause c (map varSubst vs) (matchSubst pairs m)
52
54
55+isCon :: ([P.Pattern var], expr) -> Bool
56+isCon ([] , _) = noMatch "isCon"
53isCon (p:_, _) =
57isCon (p:_, _) =
54 case p of
58 case p of
55 P.Data _ _ -> True
59 P.Data _ _ -> True
56 P.Literal _ -> True
60 P.Literal _ -> True
57 _ -> False
61 _ -> False
58
62
63+isVar :: ([P.Pattern var], expr) -> Bool
59isVar p = not (isCon p)
64isVar p = not (isCon p)
60
65
61−match :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
66+match :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match
62match [] [] def = return def
67match [] [] def = return def
63match [] [([],e)] Fail = return $ Other e
68match [] [([],e)] Fail = return $ Other e
64match [] [([],e)] Break = return $ Other e
69match [] [([],e)] Break = return $ Other e
@@ -70,25 +75,30 @@ match vs@(v:_) cs def
70 where
75 where
71 cs' = map (dealias v) cs
76 cs' = map (dealias v) cs
72
77
73−dealias :: String -> ([P.Pattern],Expr) -> ([P.Pattern],Expr)
78+dealias :: String -> ([P.CanonicalPattern], Canonical.Expr) -> ([P.CanonicalPattern], Canonical.Expr)
79+dealias _ ([], _) = noMatch "dealias"
74dealias v c@(p:ps, A a e) =
80dealias v c@(p:ps, A a e) =
75 case p of
81 case p of
76− P.Alias x pattern -> (pattern:ps, A a $ subst x (rawVar v) e)
82+ P.Alias x pattern -> (pattern:ps, A a $ subst x (localVar v) e)
77 _ -> c
83 _ -> c
78
84
79−matchVar :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
85+matchVar :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match
86+matchVar [] _ _ = noMatch "matchVar"
80matchVar (v:vs) cs def = match vs (map subVar cs) def
87matchVar (v:vs) cs def = match vs (map subVar cs) def
81 where
88 where
89+ subVar ([], _) = noMatch "matchVar.subVar"
82 subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)
90 subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)
83 where
91 where
84 subOnePattern pattern e =
92 subOnePattern pattern e =
85 case pattern of
93 case pattern of
86− P.Var x -> subst x (rawVar v) e
94+ P.Var x -> subst x (localVar v) e
87 P.Anything -> e
95 P.Anything -> e
88 P.Record fs ->
96 P.Record fs ->
89− foldr (\x -> subst x (Access (A a (rawVar v)) x)) e fs
97+ foldr (\x -> subst x (Access (A a (localVar v)) x)) e fs
98+ _ -> noMatch "matchVar.subVar"
90
99
91−matchCon :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
100+matchCon :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match
101+matchCon [] _ _ = noMatch "matchCon"
92matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
102matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
93 where
103 where
94 css = groupBy eq (sortBy cmp cs)
104 css = groupBy eq (sortBy cmp cs)
@@ -97,37 +107,48 @@ matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
97 case (p1,p2) of
107 case (p1,p2) of
98 (P.Data n1 _, P.Data n2 _) -> compare n1 n2
108 (P.Data n1 _, P.Data n2 _) -> compare n1 n2
99 _ -> compare p1 p2
109 _ -> compare p1 p2
110+ cmp _ _ = noMatch "matchCon.cmp"
100
111
101 eq (p1:_,_) (p2:_,_) =
112 eq (p1:_,_) (p2:_,_) =
102 case (p1,p2) of
113 case (p1,p2) of
103 (P.Data n1 _, P.Data n2 _) -> n1 == n2
114 (P.Data n1 _, P.Data n2 _) -> n1 == n2
104 _ -> p1 == p2
115 _ -> p1 == p2
116+ eq _ _ = noMatch "matchCon.eq"
105
117
106 toClause cs =
118 toClause cs =
107 case head cs of
119 case head cs of
108 (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
120 (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
109 (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
121 (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
122+ _ -> noMatch "matchCon"
110
123
111−matchClause :: Either String Literal
124+matchClause :: Either Var.Canonical Literal
112 -> [String]
125 -> [String]
113− -> [([P.Pattern],Expr)]
126+ -> [([P.CanonicalPattern], Canonical.Expr)]
114 -> Match
127 -> Match
115 -> State Int Clause
128 -> State Int Clause
129+matchClause _ [] _ _ = noMatch "matchClause"
116matchClause c (_:vs) cs def =
130matchClause c (_:vs) cs def =
117 do vs' <- getVars
131 do vs' <- getVars
118 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def
132 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def
119 where
133 where
120−
134+ flatten ([], _) = noMatch "matchClause.flatten"
121 flatten (p:ps, e) =
135 flatten (p:ps, e) =
122 case p of
136 case p of
123 P.Data _ ps' -> (ps' ++ ps, e)
137 P.Data _ ps' -> (ps' ++ ps, e)
124 P.Literal _ -> (ps, e)
138 P.Literal _ -> (ps, e)
139+ _ -> noMatch "matchClause.flatten"
125
140
126 getVars =
141 getVars =
127 case head cs of
142 case head cs of
128 (P.Data _ ps : _, _) -> forM ps (const newVar)
143 (P.Data _ ps : _, _) -> forM ps (const newVar)
129 (P.Literal _ : _, _) -> return []
144 (P.Literal _ : _, _) -> return []
145+ _ -> noMatch "matchClause.getVars"
130
146
131−matchMix :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
147+matchMix :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match
132matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
148matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
133 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
149 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
150+
151+noMatch :: String -> a
152+noMatch name =
153+ error $ "unexpected pattern in '" ++ name ++
154+ "' function. Report a compiler issue to <https://github.com/elm-lang/Elm>."
compiler/Generate/JavaScript.hs+105−73
@@ -14,15 +14,17 @@ import Generate.JavaScript.Helpers
14import qualified Generate.Cases as Case
14import qualified Generate.Cases as Case
15import qualified Generate.JavaScript.Ports as Port
15import qualified Generate.JavaScript.Ports as Port
16import qualified Generate.Markdown as MD
16import qualified Generate.Markdown as MD
17+
17−import SourceSyntax.Annotation
18+import AST.Annotation
18−import SourceSyntax.Expression
19+import AST.Module
20+import AST.Expression.General
21+import qualified AST.Expression.Canonical as Canonical
19−import qualified SourceSyntax.Helpers as Help
22+import qualified AST.Module as Module
23+import qualified AST.Helpers as Help
20−import SourceSyntax.Literal
24+import AST.Literal
21−import SourceSyntax.Module
22−import qualified SourceSyntax.Pattern as P
25+import qualified AST.Pattern as P
23−import SourceSyntax.PrettyPrint (renderPretty)
26+import AST.PrettyPrint (renderPretty)
24−import qualified SourceSyntax.Variable as V
27+import qualified AST.Variable as Var
25−import qualified Transform.SafeNames as MakeSafe
26
28
27varDecl :: String -> Expression () -> VarDecl ()
29varDecl :: String -> Expression () -> VarDecl ()
28varDecl x expr =
30varDecl x expr =
@@ -51,10 +53,24 @@ literal lit =
51 FloatNum n -> NumLit () n
53 FloatNum n -> NumLit () n
52 Boolean b -> BoolLit () b
54 Boolean b -> BoolLit () b
53
55
56+canonical :: Var.Canonical -> Expression ()
57+canonical (Var.Canonical home name) =
58+ case Help.isOp name of
59+ True -> BracketRef () (dotSep (home' ++ ["_op"])) (string name)
60+ False -> dotSep (home' ++ [map (swap '\'' '$') name])
61+ where
62+ swap from to c = if c == from then to else c
63+
64+ home' =
65+ case home of
66+ Var.Local -> []
67+ Var.BuiltIn -> []
68+ Var.Module path -> [ map (swap '.' '$') path ]
69+
54−expression :: Expr -> State Int (Expression ())
70+expression :: Canonical.Expr -> State Int (Expression ())
55expression (A region expr) =
71expression (A region expr) =
56 case expr of
72 case expr of
57− Var (V.Raw x) -> return $ obj x
73+ Var var -> return $ canonical var
58
74
59 Literal lit -> return $ literal lit
75 Literal lit -> return $ literal lit
60
76
@@ -108,7 +124,7 @@ expression (A region expr) =
108 P.Var x -> return (args ++ [x], body)
124 P.Var x -> return (args ++ [x], body)
109 _ -> do arg <- Case.newVar
125 _ -> do arg <- Case.newVar
110 return ( args ++ [arg]
126 return ( args ++ [arg]
111− , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))
127+ , A ann (Case (A ann (localVar arg)) [(pattern, body)]))
112
128
113 (patterns, innerBody) = collect [p] e
129 (patterns, innerBody) = collect [p] e
114
130
@@ -141,7 +157,8 @@ expression (A region expr) =
141 MultiIf branches ->
157 MultiIf branches ->
142 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
158 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
143 return $ case last branches of
159 return $ case last branches of
160+ (A _ (Var (Var.Canonical (Var.Module "Basics") "otherwise")), _) ->
144− (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
161+ safeIfs branches'
145 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
162 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
146 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
163 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
147 where
164 where
@@ -153,7 +170,7 @@ expression (A region expr) =
153 do (tempVar,initialMatch) <- Case.toMatch cases
170 do (tempVar,initialMatch) <- Case.toMatch cases
154 (revisedMatch, stmt) <-
171 (revisedMatch, stmt) <-
155 case e of
172 case e of
156− A _ (Var (V.Raw x)) ->
173+ A _ (Var (Var.Canonical Var.Local x)) ->
157 return (Case.matchSubst [(tempVar,x)] initialMatch, [])
174 return (Case.matchSubst [(tempVar,x)] initialMatch, [])
158 _ ->
175 _ ->
159 do e' <- expression e
176 do e' <- expression e
@@ -187,8 +204,8 @@ expression (A region expr) =
187 return $ obj "Native.Ports.portOut" `call`
204 return $ obj "Native.Ports.portOut" `call`
188 [ string name, Port.outgoing tipe, value' ]
205 [ string name, Port.outgoing tipe, value' ]
189
206
190−definition :: Def -> State Int [Statement ()]
207+definition :: Canonical.Def -> State Int [Statement ()]
191−definition (Definition pattern expr@(A region _) _) = do
208+definition (Canonical.Definition pattern expr@(A region _) _) = do
192 expr' <- expression expr
209 expr' <- expression expr
193 let assign x = varDecl x expr'
210 let assign x = varDecl x expr'
194 case pattern of
211 case pattern of
@@ -203,7 +220,7 @@ definition (Definition pattern expr@(A region _) _) = do
203 let setField f = varDecl f (dotSep ["$",f]) in
220 let setField f = varDecl f (dotSep ["$",f]) in
204 return [ VarDeclStmt () (assign "$" : map setField fields) ]
221 return [ VarDeclStmt () (assign "$" : map setField fields) ]
205
222
206− P.Data name patterns | vars /= Nothing ->
223+ P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
207 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
224 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
208 where
225 where
209 vars = getVars patterns
226 vars = getVars patterns
@@ -227,9 +244,9 @@ definition (Definition pattern expr@(A region _) _) = do
227 return (VarDeclStmt () [assign "_"] : defs')
244 return (VarDeclStmt () [assign "_"] : defs')
228 where
245 where
229 vars = P.boundVarList pattern
246 vars = P.boundVarList pattern
230− mkVar = A region . rawVar
247+ mkVar = A region . localVar
231 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
248 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
232− in definition $ Definition (P.Var y) expr Nothing
249+ in definition $ Canonical.Definition (P.Var y) expr Nothing
233
250
234match :: Region -> Case.Match -> State Int [Statement ()]
251match :: Region -> Case.Match -> State Int [Statement ()]
235match region mtch =
252match region mtch =
@@ -279,40 +296,46 @@ clause region variable (Case.Clause value vars mtch) =
279 _ -> (,) False $ case value of
296 _ -> (,) False $ case value of
280 Right (Boolean b) -> BoolLit () b
297 Right (Boolean b) -> BoolLit () b
281 Right lit -> literal lit
298 Right lit -> literal lit
282− Left name -> string $ case List.elemIndices '.' name of
299+ Left (Var.Canonical _ name) ->
283− [] -> name
300+ string name
284− is -> drop (last is + 1) name
285
301
286−flattenLets :: [Def] -> Expr -> ([Def], Expr)
302+flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
287flattenLets defs lexpr@(A _ expr) =
303flattenLets defs lexpr@(A _ expr) =
288 case expr of
304 case expr of
289 Let ds body -> flattenLets (defs ++ ds) body
305 Let ds body -> flattenLets (defs ++ ds) body
290 _ -> (defs, lexpr)
306 _ -> (defs, lexpr)
291
307
292−generate :: MetadataModule -> String
308+generate :: CanonicalModule -> String
293−generate unsafeModule =
309+generate modul =
294− show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
310+ show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
295− [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
311+ [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]
296 where
312 where
297− modul = MakeSafe.metadataModule unsafeModule
313+ names = Module.names modul
314+
298− thisModule = dotSep ("_elm" : names modul ++ ["values"])
315+ thisModule = dotSep ("_elm" : names ++ ["values"])
299 programStmts =
316 programStmts =
300 concat
317 concat
301 [ [ ExprStmt () $ string "use strict" ]
318 [ [ ExprStmt () $ string "use strict" ]
302− , setup (Just "_elm") (names modul ++ ["values"])
319+ , setup "_elm" (names ++ ["values"])
303 , [ IfSingleStmt () thisModule (ret thisModule) ]
320 , [ IfSingleStmt () thisModule (ret thisModule) ]
304− , [ internalImports (List.intercalate "." (names modul)) ]
321+ , [ internalImports (List.intercalate "." names) ]
305− , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
322+ , map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
306 , [ assign ["_op"] (ObjectLit () []) ]
323 , [ assign ["_op"] (ObjectLit () []) ]
307− , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
324+ , concat $ evalState (mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)) 0
308 , [ jsExports ]
325 , [ jsExports ]
309 , [ ret thisModule ]
326 , [ ret thisModule ]
310 ]
327 ]
311
328
312− jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
329+ jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)
313 where
330 where
314− exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
331+ exs = map entry $ "_op" : concatMap extract (exports modul)
315 entry x = (prop x, ref x)
332 entry x = (prop x, ref x)
333+ extract value =
334+ case value of
335+ Var.Alias _ -> []
336+ Var.Value x | Help.isOp x -> []
337+ | otherwise -> [x]
338+ Var.ADT _ (Var.Listing ctors _) -> ctors
316
339
317 assign path expr =
340 assign path expr =
318 case path of
341 case path of
@@ -320,57 +343,66 @@ generate unsafeModule =
320 _ -> ExprStmt () $
343 _ -> ExprStmt () $
321 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
344 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
322
345
323− jsImport modul = setup Nothing path ++ [ include ]
346+ jsImport name =
324− where
325− path = Help.splitDots modul
326− include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
347+ assign [dolarize name] $ dotSep ("Elm" : Help.splitDots name ++ ["make"]) <| ref "_elm"
327
348
328 setup namespace path = map create paths
349 setup namespace path = map create paths
329 where
350 where
330 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
351 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
331− paths = case namespace of
332− Nothing -> tail . init $ List.inits path
333− Just nmspc -> drop 2 . init . List.inits $ nmspc : path
352+ paths = drop 2 . init . List.inits $ namespace : path
334−
353+
354+binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr
335−binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
355+ -> State Int (Expression ())
336−binop region op e1 e2 =
356+binop region (Var.Canonical home op) e1 e2 =
337− case op of
357+ case (home, op) of
338− "Basics.." ->
358+ (Var.Module "Basics", ".") ->
339 do es <- mapM expression (e1 : collect [] e2)
359 do es <- mapM expression (e1 : collect [] e2)
340 return $ ["$"] ==> foldr (<|) (ref "$") es
360 return $ ["$"] ==> foldr (<|) (ref "$") es
341− "Basics.<|" ->
361+
362+ (Var.Module "Basics", "<|") ->
342 do e2' <- expression e2
363 do e2' <- expression e2
343 es <- mapM expression (collect [] e1)
364 es <- mapM expression (collect [] e1)
344 return $ foldr (<|) e2' es
365 return $ foldr (<|) e2' es
345− "List.++" ->
366+
367+ (Var.Module "List", "++") ->
346 do e1' <- expression e1
368 do e1' <- expression e1
347 e2' <- expression e2
369 e2' <- expression e2
348 return $ obj "_L.append" `call` [e1', e2']
370 return $ obj "_L.append" `call` [e1', e2']
371+
372+ (Var.BuiltIn, "::") ->
349− "::" -> expression (A region (Data "::" [e1,e2]))
373+ expression (A region (Data "::" [e1,e2]))
350− _ ->
374+
375+ (Var.Module "Basics", _) ->
351 do e1' <- expression e1
376 do e1' <- expression e1
352 e2' <- expression e2
377 e2' <- expression e2
353− return $ case Map.lookup op opDict of
378+ return $ case Map.lookup op basicOps of
354 Just f -> f e1' e2'
379 Just f -> f e1' e2'
355 Nothing -> ref "A2" `call` [ func, e1', e2' ]
380 Nothing -> ref "A2" `call` [ func, e1', e2' ]
381+
382+ _ ->
383+ do e1' <- expression e1
384+ e2' <- expression e2
385+ return (ref "A2" `call` [ func, e1', e2' ])
386+
356 where
387 where
357 collect es e =
388 collect es e =
358 case e of
389 case e of
390+ A _ (Binop (Var.Canonical (Var.Module "Basics") ".") e1 e2) ->
359− A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
391+ collect (es ++ [e1]) e2
360 _ -> es ++ [e]
392 _ -> es ++ [e]
361
393
362− func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
394+ func | Help.isOp op = BracketRef () (dotSep (path ++ ["_op"])) (string op)
363− | otherwise = dotSep parts
395+ | otherwise = dotSep (path ++ [op])
364− where
396+ where
365− parts = Help.splitDots op
397+ path = case home of
366− operator = last parts
398+ Var.Local -> []
367−
399+ Var.BuiltIn -> []
368− opDict = Map.fromList (infixOps ++ specialOps)
400+ Var.Module m -> [dolarize m]
369
401
370− specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
402+ basicOps = Map.fromList (infixOps ++ specialOps)
371− infixOp str op = specialOp str (InfixExpr () op)
372
403
373− infixOps = concat
404+ infixOps =
405+ let infixOp str op = (str, InfixExpr () op) in
374 [ infixOp "+" OpAdd
406 [ infixOp "+" OpAdd
375 , infixOp "-" OpSub
407 , infixOp "-" OpSub
376 , infixOp "*" OpMul
408 , infixOp "*" OpMul
@@ -379,16 +411,16 @@ binop region op e1 e2 =
379 , infixOp "||" OpLOr
411 , infixOp "||" OpLOr
380 ]
412 ]
381
413
382− specialOps = concat
414+ specialOps =
383− [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
415+ [ (,) "^" $ \a b -> obj "Math.pow" `call` [a,b]
384− , specialOp "|>" $ flip (<|)
416+ , (,) "|>" $ flip (<|)
385− , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
417+ , (,) "==" $ \a b -> obj "_U.eq" `call` [a,b]
386− , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
418+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
387− , specialOp "<" $ cmp OpLT 0
419+ , (,) "<" $ cmp OpLT 0
388− , specialOp ">" $ cmp OpGT 0
420+ , (,) ">" $ cmp OpGT 0
389− , specialOp "<=" $ cmp OpLT 1
421+ , (,) "<=" $ cmp OpLT 1
390− , specialOp ">=" $ cmp OpGT (-1)
422+ , (,) ">=" $ cmp OpGT (-1)
391− , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
423+ , (,) "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
392 ]
424 ]
393
425
394 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)
426 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)
compiler/Generate/JavaScript/Helpers.hs+9−1
@@ -1,9 +1,12 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module Generate.JavaScript.Helpers where
2module Generate.JavaScript.Helpers where
3
3
4−import qualified SourceSyntax.Helpers as Help
4+import qualified AST.Helpers as Help
5import Language.ECMAScript3.Syntax
5import Language.ECMAScript3.Syntax
6
6
7+dolarize :: String -> String
8+dolarize x = map (\c -> if c == '.' then '$' else c) x
9+
7split :: String -> [String]
10split :: String -> [String]
8split = go []
11split = go []
9 where
12 where
@@ -13,8 +16,12 @@ split = go []
13 | otherwise -> go (vars ++ [x]) rest
16 | otherwise -> go (vars ++ [x]) rest
14 (x,[]) -> vars ++ [x]
17 (x,[]) -> vars ++ [x]
15
18
19+var :: String -> Id ()
16var name = Id () name
20var name = Id () name
21+
22+ref :: String -> Expression ()
17ref name = VarRef () (var name)
23ref name = VarRef () (var name)
24+
18prop name = PropId () (var name)
25prop name = PropId () (var name)
19f <| x = CallExpr () f [x]
26f <| x = CallExpr () f [x]
20ret e = ReturnStmt () (Just e)
27ret e = ReturnStmt () (Just e)
@@ -23,6 +30,7 @@ function args stmts = FuncExpr () Nothing (map var args) stmts
23call = CallExpr ()
30call = CallExpr ()
24string = StringLit ()
31string = StringLit ()
25
32
33+dotSep :: [String] -> Expression ()
26dotSep vars =
34dotSep vars =
27 case vars of
35 case vars of
28 x:xs -> foldl (DotRef ()) (ref x) (map var xs)
36 x:xs -> foldl (DotRef ()) (ref x) (map var xs)
compiler/Generate/JavaScript/Ports.hs+42−30
@@ -2,8 +2,9 @@
2module Generate.JavaScript.Ports (incoming, outgoing) where
2module Generate.JavaScript.Ports (incoming, outgoing) where
3
3
4import Generate.JavaScript.Helpers
4import Generate.JavaScript.Helpers
5−import qualified SourceSyntax.Helpers as Help
5+import qualified AST.Helpers as Help
6−import SourceSyntax.Type as T
6+import AST.Type as T
7+import qualified AST.Variable as Var
7import Language.ECMAScript3.Syntax
8import Language.ECMAScript3.Syntax
8
9
9data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]
10data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]
@@ -23,23 +24,28 @@ check x jsType continue =
23 JSArray -> [instanceof "Array"]
24 JSArray -> [instanceof "Array"]
24 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]
25 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]
25
26
26−incoming :: Type -> Expression ()
27+incoming :: CanonicalType -> Expression ()
27incoming tipe =
28incoming tipe =
28 case tipe of
29 case tipe of
30+ Aliased _ t -> incoming t
31+
29− Data "Signal.Signal" [t] ->
32+ Data (Var.Canonical (Var.Module "Signal") "Signal") [t] ->
30 obj "Native.Ports.incomingSignal" <| incoming t
33 obj "Native.Ports.incomingSignal" <| incoming t
34+
31 _ -> ["v"] ==> inc tipe (ref "v")
35 _ -> ["v"] ==> inc tipe (ref "v")
32
36
33−inc :: Type -> Expression () -> Expression ()
37+inc :: CanonicalType -> Expression () -> Expression ()
34inc tipe x =
38inc tipe x =
35 case tipe of
39 case tipe of
36 Lambda _ _ -> error "functions should not be allowed through input ports"
40 Lambda _ _ -> error "functions should not be allowed through input ports"
37 Var _ -> error "type variables should not be allowed through input ports"
41 Var _ -> error "type variables should not be allowed through input ports"
42+ Aliased _ t ->
43+ inc t x
38
44
39− Data "Json.Value" [] ->
45+ Data (Var.Canonical (Var.Module "Json") "Value") [] ->
40 obj "Native.Json.fromJS" <| x
46 obj "Native.Json.fromJS" <| x
41
47
42− Data ctor []
48+ Data (Var.Canonical Var.BuiltIn ctor) []
43 | ctor == "Int" -> from JSNumber
49 | ctor == "Int" -> from JSNumber
44 | ctor == "Float" -> from JSNumber
50 | ctor == "Float" -> from JSNumber
45 | ctor == "Bool" -> from JSBoolean
51 | ctor == "Bool" -> from JSBoolean
@@ -47,18 +53,17 @@ inc tipe x =
47 where
53 where
48 from checks = check x checks x
54 from checks = check x checks x
49
55
50− Data ctor [t]
56+ Data (Var.Canonical (Var.Module "Maybe") "Maybe") [t] ->
51− | ctor == "Maybe.Maybe" ->
52− CondExpr () (equal x (NullLit ()))
57+ CondExpr () (equal x (NullLit ()))
53− (obj "Maybe.Nothing")
58+ (obj "Maybe.Nothing")
54− (obj "Maybe.Just" <| inc t x)
59+ (obj "Maybe.Just" <| inc t x)
55
60
56− | ctor == "_List" ->
61+ Data (Var.Canonical Var.BuiltIn "_List") [t] ->
57− check x JSArray (obj "_L.fromArray" <| array)
62+ check x JSArray (obj "_L.fromArray" <| array)
58− where
63+ where
59− array = DotRef () x (var "map") <| incoming t
64+ array = DotRef () x (var "map") <| incoming t
60
65
61− Data ctor ts
66+ Data (Var.Canonical Var.BuiltIn ctor) ts
62 | Help.isTuple ctor -> check x JSArray tuple
67 | Help.isTuple ctor -> check x JSArray tuple
63 where
68 where
64 tuple = ObjectLit () $ (prop "ctor", string ctor) : values
69 tuple = ObjectLit () $ (prop "ctor", string ctor) : values
@@ -79,15 +84,21 @@ inc tipe x =
79 keys = map convert fields
84 keys = map convert fields
80 convert (f,t) = (prop f, inc t (DotRef () x (var f)))
85 convert (f,t) = (prop f, inc t (DotRef () x (var f)))
81
86
87+outgoing :: CanonicalType -> Expression ()
82outgoing tipe =
88outgoing tipe =
83 case tipe of
89 case tipe of
90+ Aliased _ t -> outgoing t
91+
84− Data "Signal.Signal" [t] ->
92+ Data (Var.Canonical (Var.Module "Signal") "Signal") [t] ->
85 obj "Native.Ports.outgoingSignal" <| outgoing t
93 obj "Native.Ports.outgoingSignal" <| outgoing t
94+
86 _ -> ["v"] ==> out tipe (ref "v")
95 _ -> ["v"] ==> out tipe (ref "v")
87
96
88−out :: Type -> Expression () -> Expression ()
97+out :: CanonicalType -> Expression () -> Expression ()
89out tipe x =
98out tipe x =
90 case tipe of
99 case tipe of
100+ Aliased _ t -> out t x
101+
91 Lambda _ _
102 Lambda _ _
92 | numArgs > 1 && numArgs < 10 ->
103 | numArgs > 1 && numArgs < 10 ->
93 func (ref ('A':show numArgs) `call` (x:values))
104 func (ref ('A':show numArgs) `call` (x:values))
@@ -103,21 +114,22 @@ out tipe x =
103 ]
114 ]
104
115
105 Var _ -> error "type variables should not be allowed through input ports"
116 Var _ -> error "type variables should not be allowed through input ports"
117+
106− Data ctor []
118+ Data (Var.Canonical Var.BuiltIn ctor) []
107 | ctor `elem` ["Int","Float","Bool","String"] -> x
119 | ctor `elem` ["Int","Float","Bool","String"] -> x
108− | ctor == "Json.Value" ->
109− obj "Native.Json.toJS" <| x
110
120
111− Data ctor [t]
121+ Data (Var.Canonical (Var.Module "Json") "Value") [] ->
122+ obj "Native.Json.toJS" <| x
123+
112− | ctor == "Maybe.Maybe" ->
124+ Data (Var.Canonical (Var.Module "Maybe") "Maybe") [t] ->
113− CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
125+ CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
114− (NullLit ())
126+ (NullLit ())
115− (out t (DotRef () x (var "_0")))
127+ (out t (DotRef () x (var "_0")))
116
128
117− | ctor == "_List" ->
129+ Data (Var.Canonical Var.BuiltIn "_List") [t] ->
118− DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t
130+ DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t
119
131
120− Data ctor ts
132+ Data (Var.Canonical Var.BuiltIn ctor) ts
121 | Help.isTuple ctor ->
133 | Help.isTuple ctor ->
122 let convert n t = out t $ DotRef () x $ var ('_':show n)
134 let convert n t = out t $ DotRef () x $ var ('_':show n)
123 in ArrayLit () $ zipWith convert [0..] ts
135 in ArrayLit () $ zipWith convert [0..] ts
compiler/Transform/SafeNames.hsdeleted−77
@@ -1,77 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Transform.SafeNames (metadataModule) where
3−
4−import Control.Arrow (first, (***))
5−import qualified Data.List as List
6−import qualified Data.Set as Set
7−
8−import qualified Parse.Helpers as PHelp
9−import SourceSyntax.Annotation
10−import SourceSyntax.Expression
11−import qualified SourceSyntax.Helpers as SHelp
12−import SourceSyntax.Module
13−import qualified SourceSyntax.Pattern as P
14−import qualified SourceSyntax.Variable as Variable
15−
16−var :: String -> String
17−var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots
18− where
19− deprime = map (\c -> if c == '\'' then '$' else c)
20− dereserve x = case Set.member x PHelp.jsReserveds of
21− False -> x
22− True -> "$" ++ x
23−
24−pattern :: P.Pattern -> P.Pattern
25−pattern pat =
26− case pat of
27− P.Var x -> P.Var (var x)
28− P.Literal _ -> pat
29− P.Record fs -> P.Record (map var fs)
30− P.Anything -> pat
31− P.Alias x p -> P.Alias (var x) (pattern p)
32− P.Data name ps -> P.Data name (map pattern ps)
33−
34−-- TODO: should be "normal expression" -> "expression for JS generation"
35−expression :: Expr -> Expr
36−expression (A ann expr) =
37− let f = expression in
38− A ann $
39− case expr of
40− Literal _ -> expr
41− Var (Variable.Raw x) -> rawVar (var x)
42− Range e1 e2 -> Range (f e1) (f e2)
43− ExplicitList es -> ExplicitList (map f es)
44− Binop op e1 e2 -> Binop op (f e1) (f e2)
45− Lambda p e -> Lambda (pattern p) (f e)
46− App e1 e2 -> App (f e1) (f e2)
47− MultiIf ps -> MultiIf (map (f *** f) ps)
48− Let defs body -> Let (map definition defs) (f body)
49− Case e cases -> Case (f e) $ map (pattern *** f) cases
50− Data name es -> Data name (map f es)
51− Access e x -> Access (f e) (var x)
52− Remove e x -> Remove (f e) (var x)
53− Insert e x v -> Insert (f e) (var x) (f v)
54− Modify r fs -> Modify (f r) (map (var *** f) fs)
55− Record fs -> Record (map (var *** f) fs)
56− Markdown uid md es -> Markdown uid md (map f es)
57− PortIn name st -> PortIn name st
58− PortOut name st signal -> PortOut name st (f signal)
59−
60−definition :: Def -> Def
61−definition (Definition p e t) =
62− Definition (pattern p) (expression e) t
63−
64−metadataModule :: MetadataModule -> MetadataModule
65−metadataModule modul =
66− modul
67− { names = map var (names modul)
68− , exports = map var (exports modul)
69− , imports = map (first var) (imports modul)
70− , program = expression (program modul)
71− , aliases =
72− let makeSafe (name,tvars,tipe) = (var name, tvars, tipe)
73− in map makeSafe (aliases modul)
74− , datatypes =
75− let makeSafe (name,tvars,ctors) = (var name, tvars, map (first var) ctors)
76− in map makeSafe (datatypes modul)
77− }