git.iko.soy/elk
on master help sign in
Get closer to full conversion to language-ecmascript
bd445c4Evan Czaplicki
compiler/Generate/JavaScript.hs+60−57
compare with master
unifiedsplit
@@ -1,13 +1,12 @@
1module Generate.JavaScript where
1module Generate.JavaScript where
2
2
3−import Control.Monad (liftM,(<=<),join,ap)
3+import Control.Applicative ((<$>))
4import Data.Char (isAlpha,isDigit)
4import Data.Char (isAlpha,isDigit)
5import qualified Data.List as List
5import qualified Data.List as List
6import qualified Data.Map as Map
6import qualified Data.Map as Map
7import qualified Data.Set as Set
7import qualified Data.Set as Set
8import Data.Either (partitionEithers)
8import Data.Either (partitionEithers)
9
9
10−
11import Unique
10import Unique
12import Generate.Cases
11import Generate.Cases
13import SourceSyntax.Everything
12import SourceSyntax.Everything
@@ -19,7 +18,9 @@ import Parse.Helpers (makeSafe, iParse)
19
18
20import Parse.Expression
19import Parse.Expression
21
20
21+testExpr str = case iParse expr "" str of
22−testExpr str = (prettyPrint . expression) `fmap` iParse expr "" str
22+ Right e -> prettyPrint (expression e)
23+ Left err -> error (show err)
23
24
24var name = Id () (makeSafe name)
25var name = Id () (makeSafe name)
25ref name = VarRef () (var name)
26ref name = VarRef () (var name)
@@ -65,14 +66,12 @@ expression (L span expr) =
65 Access e x -> DotRef () (expression e) (var x)
66 Access e x -> DotRef () (expression e) (var x)
66 Remove e x -> dotSep ["_N","remove"] `call` [ref x, expression e]
67 Remove e x -> dotSep ["_N","remove"] `call` [ref x, expression e]
67 Insert e x v -> dotSep ["_N","insert"] `call` [ref x, expression v, expression e]
68 Insert e x v -> dotSep ["_N","insert"] `call` [ref x, expression v, expression e]
69+ Modify e fs ->
70+ let modify (f,v) = ArrayLit () [ref f, expression e]
71+ in dotSep ["_N","replace"] `call` [ArrayLit () (map modify fs), expression e]
72+
68{--
73{--
69− Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
70− setField fs' `liftM` toJS' e
71 Record fs -> makeRecord fs
74 Record fs -> makeRecord fs
72−
73−addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
74−setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
75− where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
76makeRecord kvs = record `liftM` collect kvs
75makeRecord kvs = record `liftM` collect kvs
77 where
76 where
78 combine r (k,v) = Map.insertWith (++) k v r
77 combine r (k,v) = Map.insertWith (++) k v r
@@ -96,7 +95,7 @@ makeRecord kvs = record `liftM` collect kvs
96 | otherwise =
95 | otherwise =
97 ref ("F" ++ show (length args)) <| (args ==> expression body)
96 ref ("F" ++ show (length args)) <| (args ==> expression body)
98
97
99− (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
98+ (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
100
99
101 depattern (pattern,n) (args, body) =
100 depattern (pattern,n) (args, body) =
102 case pattern of
101 case pattern of
@@ -110,7 +109,7 @@ makeRecord kvs = record `liftM` collect kvs
110 case expr of
109 case expr of
111 Lambda p e -> collect (p:patterns) e
110 Lambda p e -> collect (p:patterns) e
112 _ -> (patterns, lexpr)
111 _ -> (patterns, lexpr)
113−--}
112+
114 App e1 e2 ->
113 App e1 e2 ->
115 case args of
114 case args of
116 [arg] -> func <| arg
115 [arg] -> func <| arg
@@ -122,9 +121,11 @@ makeRecord kvs = record `liftM` collect kvs
122 case func of
121 case func of
123 (L _ (App f arg)) -> getArgs f (arg : args)
122 (L _ (App f arg)) -> getArgs f (arg : args)
124 _ -> (expression func, map expression args)
123 _ -> (expression func, map expression args)
125−{--
124+
125+ Let defs e -> FuncExpr () Nothing [] stmts `call` []
126+ where
126− Let defs e -> jsLet $ SD.flattenLets defs e
127+ (defs',e') = SD.flattenLets defs e
127−--}
128+ stmts = map definition defs' ++ [ ReturnStmt () (Just (expression e')) ]
128
129
129 MultiIf branches ->
130 MultiIf branches ->
130 case last branches of
131 case last branches of
@@ -148,6 +149,50 @@ makeRecord kvs = record `liftM` collect kvs
148 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
149 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
149--}
150--}
150
151
152+definition def =
153+ case def of
154+ TypeAnnotation _ _ -> EmptyStmt ()
155+ Def pattern expr@(L span _) ->
156+ let assign x = VarDecl () (var x) (Just (expression expr)) in
157+ case pattern of
158+ PVar x
159+ | isOp x ->
160+ let op = LBracket () (ref "_op") (string x) in
161+ ExprStmt () (AssignExpr () OpAssign op (expression expr))
162+ | otherwise ->
163+ VarDeclStmt () [ assign x ]
164+
165+ PRecord fields -> VarDeclStmt () (assign "$" : map setField fields)
166+ where
167+ setField f = VarDecl () (var f) (Just (dotSep ["$",f]))
168+
169+ PData name patterns | vars /= Nothing ->
170+ case vars of
171+ Just vs -> VarDeclStmt () (setup (zipWith varDecl vs [0..]))
172+ where
173+ vars = getVars patterns
174+ getVars patterns =
175+ case patterns of
176+ PVar x : rest -> (x:) <$> getVars rest
177+ [] -> Just []
178+ _ -> Nothing
179+
180+ varDecl x n = VarDecl () (var x) (Just (dotSep ["$","_" ++ show n]))
181+ setup vars
182+ | isTuple name = assign "$" : vars
183+ | otherwise = safeAssign : vars
184+
185+ safeAssign = VarDecl () (var "$") (Just $ CondExpr () if' (expression expr) exception)
186+ if' = InfixExpr () OpStrictEq (dotSep ["$","ctor"]) (string name)
187+ exception = dotSep ["_E","Case"] `call` [ref "$moduleName", string (show span)]
188+
189+ _ -> BlockStmt () ( VarDeclStmt () [assign "$"] : map toDef vars )
190+ where
191+ vars = Set.toList $ SD.boundVars pattern
192+ mkVar = L span . Var
193+ toDef y = definition $
194+ Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
195+--}
151{--
196{--
152
197
153globalAssign n e = "\n" ++ assign' n e ++ ";"
198globalAssign n e = "\n" ++ assign' n e ++ ";"
@@ -216,50 +261,12 @@ jsImport (modul, method) =
216 [] -> (reverse name, [])
261 [] -> (reverse name, [])
217
262
218
263
219−class ToJS a where
220− toJS :: a -> Unique String
221−
222−
223−instance ToJS (Def t v) where
224−
225− -- TODO: Make this handle patterns besides plain variables
226− toJS (Def (PVar x) e)
227− | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
228− | otherwise = assign x `liftM` toJS' e
229−
230− toJS (Def pattern e@(L s _)) =
231− do n <- guid
232− let x = "_" ++ show n
233− var = L s . Var
234− toDef y = Def (PVar y) (L s $ Case (var x) [(pattern, var y)])
235− stmt <- assign x `liftM` toJS' e
236− vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
237− return (stmt ++ vars)
238−
239− toJS (TypeAnnotation _ _) = return ""
240−
241−
242−instance ToJS a => ToJS [a] where
243− toJS xs = concat `liftM` mapM toJS xs
244−
245−toJS' :: LExpr t v -> Unique String
246−toJS' (L span expr) =
247− case expr of
248− Case e cases -> caseToJS span e cases
249− _ -> toJS expr
250−
251−
252−
253formatMarkdown = concatMap f
264formatMarkdown = concatMap f
254 where f '\'' = "\\'"
265 where f '\'' = "\\'"
255 f '\n' = "\\n"
266 f '\n' = "\\n"
256 f '"' = "\""
267 f '"' = "\""
257 f c = [c]
268 f c = [c]
258
269
259−jsLet (defs,e') = do ds <- mapM toJS defs
260− e <- toJS' e'
261− return $ jsFunc "" (concat ds ++ ret e) ++ "()"
262−
263caseToJS span e ps = do
270caseToJS span e ps = do
264 (tempVar,match) <- caseToMatch ps
271 (tempVar,match) <- caseToMatch ps
265 e' <- toJS' e
272 e' <- toJS' e
@@ -303,9 +310,6 @@ clauseToJS span var (Clause value vars e) = do
303 is -> drop (last is + 1) name
310 is -> drop (last is + 1) name
304 return $ concat [ "\ncase ", pattern, ":", indent s ]
311 return $ concat [ "\ncase ", pattern, ":", indent s ]
305
312
306−jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
307−jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
308−
309--}
313--}
310binop span op e1 e2 =
314binop span op e1 e2 =
311 case op of
315 case op of
@@ -358,5 +362,4 @@ binop span op e1 e2 =
358 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
362 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
359 ]
363 ]
360
364
361− cmp op n a b = InfixExpr () op (dotSep ["_N","cmp"] `call` [a,b]) (IntLit () n)
365+ cmp op n a b = InfixExpr () op (dotSep ["_N","cmp"] `call` [a,b]) (IntLit () n)
362−--}