git.iko.soy/elk
on 06503fe help sign in
elk/compiler/Generate/JavaScript.hs
409 lines 15 kB history raw
1module Generate.JavaScript (generate) where
3import Control.Arrow (first,(***))
4import Control.Applicative ((<$>),(<*>))
5import Control.Monad.State
6import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Set as Set
10import qualified Generate.Cases as Case
11import qualified Generate.Markdown as MD
12import qualified SourceSyntax.Helpers as Help
13import SourceSyntax.Literal
14import SourceSyntax.Pattern as Pattern
15import SourceSyntax.Location
16import SourceSyntax.Expression
17import SourceSyntax.Module
18import Language.ECMAScript3.Syntax
19import Language.ECMAScript3.PrettyPrint
20import qualified Transform.SafeNames as MakeSafe
22split :: String -> [String]
23split = go []
24 where
25 go vars str =
26 case break (=='.') str of
27 (x,'.':rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
28 | otherwise -> go (vars ++ [x]) rest
29 (x,[]) -> vars ++ [x]
31var name = Id () name
32ref name = VarRef () (var name)
33prop name = PropId () (var name)
34f <| x = CallExpr () f [x]
35args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
36function args stmts = FuncExpr () Nothing (map var args) stmts
37call = CallExpr ()
38string = StringLit ()
40dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
41obj = dotSep . split
43varDecl :: String -> Expression () -> VarDecl ()
44varDecl x expr =
45 VarDecl () (var x) (Just expr)
47include alias moduleName =
48 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
50internalImports name =
51 VarDeclStmt ()
52 [ varDecl "N" (obj "Elm.Native")
53 , include "_N" "N.Utils"
54 , include "_L" "N.List"
55 , include "_E" "N.Error"
56 , include "_J" "N.JavaScript"
57 , varDecl "$moduleName" (string name)
58 ]
60literal :: Literal -> Expression ()
61literal lit =
62 case lit of
63 Chr c -> obj "_N.chr" <| string [c]
64 Str s -> string s
65 IntNum n -> IntLit () n
66 FloatNum n -> NumLit () n
67 Boolean b -> BoolLit () b
69expression :: LExpr -> State Int (Expression ())
70expression (L span expr) =
71 case expr of
72 Var x -> return $ ref x
73 Literal lit -> return $ literal lit
75 Range lo hi ->
76 do lo' <- expression lo
77 hi' <- expression hi
78 return $ obj "_L.range" `call` [lo',hi']
80 Access e x ->
81 do e' <- expression e
82 return $ DotRef () e' (var x)
84 Remove e x ->
85 do e' <- expression e
86 return $ obj "_N.remove" `call` [string x, e']
88 Insert e x v ->
89 do v' <- expression v
90 e' <- expression e
91 return $ obj "_N.insert" `call` [string x, v', e']
93 Modify e fs ->
94 do e' <- expression e
95 fs' <- forM fs $ \(f,v) -> do
96 v' <- expression v
97 return $ ArrayLit () [string f, v']
98 return $ obj "_N.replace" `call` [ArrayLit () fs', e']
100 Record fields ->
101 do fields' <- forM fields $ \(f,e) -> do
102 (,) f <$> expression e
103 let fieldMap = List.foldl' combine Map.empty fields'
104 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
105 where
106 combine r (k,v) = Map.insertWith (++) k [v] r
107 prop = PropId () . var
108 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
109 Map.toList . Map.filter (not . null) $ Map.map tail fs
110 visible fs = map (first prop) . Map.toList $ Map.map head fs
112 Binop op e1 e2 -> binop span op e1 e2
114 Lambda p e@(L s _) ->
115 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
116 body' <- expression body
117 return $ case length args < 2 || length args > 9 of
118 True -> foldr (==>) body' (map (:[]) args)
119 False -> ref ("F" ++ show (length args)) <| (args ==> body')
120 where
121 depattern (args, body) pattern =
122 case pattern of
123 PVar x -> return (args ++ [x], body)
124 _ -> do arg <- Case.newVar
125 return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
127 (patterns, innerBody) = collect [p] e
129 collect patterns lexpr@(L _ expr) =
130 case expr of
131 Lambda p e -> collect (p:patterns) e
132 _ -> (patterns, lexpr)
134 App e1 e2 ->
135 do func' <- expression func
136 args' <- mapM expression args
137 return $ case args' of
138 [arg] -> func' <| arg
139 _ | length args' <= 9 -> ref aN `call` (func':args')
140 | otherwise -> foldl1 (<|) (func':args')
141 where
142 aN = "A" ++ show (length args)
143 (func, args) = getArgs e1 [e2]
144 getArgs func args =
145 case func of
146 (L _ (App f arg)) -> getArgs f (arg : args)
147 _ -> (func, args)
149 Let defs e ->
150 do let (defs',e') = flattenLets defs e
151 stmts <- concat <$> mapM definition defs'
152 exp <- expression e'
153 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
155 MultiIf branches ->
156 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
157 return $ case last branches of
158 (L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
159 (L _ (Literal (Boolean True)), _) -> safeIfs branches'
160 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
161 where
162 safeIfs branches = ifs (init branches) (snd (last branches))
163 ifs branches finally = foldr iff finally branches
164 iff (if', then') else' = CondExpr () if' then' else'
166 Case e cases ->
167 do (tempVar,initialMatch) <- Case.toMatch cases
168 (revisedMatch, stmt) <-
169 case e of
170 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
171 _ -> do e' <- expression e
172 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
173 match' <- match span revisedMatch
174 return (function [] (stmt ++ match') `call` [])
176 ExplicitList es ->
177 do es' <- mapM expression es
178 return $ obj "_J.toList" <| ArrayLit () es'
180 Data name es ->
181 do es' <- mapM expression es
182 return $ ObjectLit () (ctor : fields es')
183 where
184 ctor = (prop "ctor", string name)
185 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
187 Markdown uid doc es ->
188 do es' <- mapM expression es
189 return $ obj "Text.markdown" `call` (string md : string uid : es')
190 where
191 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
192 md = pad ++ MD.toHtml doc ++ pad
194definition :: Def -> State Int [Statement ()]
195definition (Definition pattern expr@(L span _) _) = do
196 expr' <- expression expr
197 let assign x = varDecl x expr'
198 case pattern of
199 PVar x
200 | Help.isOp x ->
201 let op = LBracket () (ref "_op") (string x) in
202 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
203 | otherwise ->
204 return [ VarDeclStmt () [ assign x ] ]
206 PRecord fields ->
207 let setField f = varDecl f (dotSep ["$",f]) in
208 return [ VarDeclStmt () (assign "$" : map setField fields) ]
210 PData name patterns | vars /= Nothing ->
211 case vars of
212 Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
213 where
214 vars = getVars patterns
215 getVars patterns =
216 case patterns of
217 PVar x : rest -> (x:) `fmap` getVars rest
218 [] -> Just []
219 _ -> Nothing
221 decl x n = varDecl x (dotSep ["$","_" ++ show n])
222 setup vars
223 | Help.isTuple name = assign "$" : vars
224 | otherwise = assign "$raw" : safeAssign : vars
226 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
227 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
228 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
230 _ ->
231 do defs' <- concat <$> mapM toDef vars
232 return (VarDeclStmt () [assign "$"] : defs')
233 where
234 vars = Set.toList $ Pattern.boundVars pattern
235 mkVar = L span . Var
236 toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
237 in definition $ Definition (PVar y) expr Nothing
239match :: (Show a) => a -> Case.Match -> State Int [Statement ()]
240match span mtch =
241 case mtch of
242 Case.Match name clauses mtch' ->
243 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
244 mtch'' <- match span mtch'
245 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
246 where
247 isLiteral p = case p of
248 Case.Clause (Right _) _ _ -> True
249 _ -> False
250 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
251 format isChars e
252 | or isChars = InfixExpr () OpAdd e (string "")
253 | otherwise = e
255 Case.Fail ->
256 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
258 Case.Break -> return [BreakStmt () Nothing]
259 Case.Other e ->
260 do e' <- expression e
261 return [ ReturnStmt () (Just e') ]
262 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
263 where
264 dropEnd acc [] = acc
265 dropEnd acc (m:ms) =
266 case m of
267 Case.Other _ -> acc ++ [m]
268 _ -> dropEnd (acc ++ [m]) ms
270clause span variable (Case.Clause value vars mtch) =
271 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
272 where
273 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
274 (isChar, pattern) =
275 case value of
276 Right (Chr c) -> (True, string [c])
277 _ -> (,) False $ case value of
278 Right (Boolean b) -> BoolLit () b
279 Right lit -> literal lit
280 Left name -> string $ case List.elemIndices '.' name of
281 [] -> name
282 is -> drop (last is + 1) name
284flattenLets defs lexpr@(L _ expr) =
285 case expr of
286 Let ds body -> flattenLets (defs ++ ds) body
287 _ -> (defs, lexpr)
289generate :: MetadataModule -> String
290generate unsafeModule =
291 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
292 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
293 where
294 modul = MakeSafe.metadataModule unsafeModule
295 thisModule = dotSep ("_elm" : names modul ++ ["values"])
296 programStmts =
297 concat [ setup (Just "_elm") (names modul ++ ["values"])
298 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
299 , [ internalImports (List.intercalate "." (names modul)) ]
300 , concatMap jsImport (imports modul)
301 , checkInPorts (recvPorts modul)
302 , map inPort (recvPorts modul)
303 , map outPort (sendPorts modul)
304 , [ assign ["_op"] (ObjectLit () []) ]
305 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
306 , [ jsExports ]
307 , [ ReturnStmt () (Just thisModule) ]
308 ]
310 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
311 where
312 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
313 entry x = (PropId () (var x), ref x)
315 assign path expr =
316 case path of
317 [x] -> VarDeclStmt () [ varDecl x expr ]
318 _ -> ExprStmt () $
319 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
321 jsImport (modul,_) = setup Nothing path ++ [ include ]
322 where
323 path = split modul
324 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
326 setup namespace path = map create paths
327 where
328 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
329 paths = case namespace of
330 Nothing -> tail . init $ List.inits path
331 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
333 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "_elm.id")
335 checkInPorts ports =
336 [ ExprStmt () $ obj "_N.checkPorts" `call` [ref "$moduleName", names] ]
337 where
338 names = ArrayLit () [ string name | (name, _, _) <- ports ]
340 inPort (name, expr, _) =
341 assign [name] $ obj "_N.inPort" `call` [ dotSep ["_elm","ports_in",name]
342 , evalState (expression expr) 0 ]
344 outPort (name, expr, _) =
345 let signal = evalState (expression expr) 0 in
346 assign ["_elm","ports_out",name] signal
348binop span op e1 e2 =
349 case op of
350 "Basics.." ->
351 do es <- mapM expression (e1 : collect [] e2)
352 return $ ["$"] ==> foldr (<|) (ref "$") es
353 "Basics.<|" ->
354 do e2' <- expression e2
355 es <- mapM expression (collect [] e1)
356 return $ foldr (<|) e2' es
357 "List.++" ->
358 do e1' <- expression e1
359 e2' <- expression e2
360 return $ obj "_L.append" `call` [e1', e2']
361 "::" -> expression (L span (Data "::" [e1,e2]))
362 _ ->
363 do e1' <- expression e1
364 e2' <- expression e2
365 return $ case Map.lookup op opDict of
366 Just f -> f e1' e2'
367 Nothing -> ref "A2" `call` [ func, e1', e2' ]
368 where
369 collect es e =
370 case e of
371 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
372 _ -> es ++ [e]
374 js1 = expression e1
375 js2 = expression e2
377 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
378 | otherwise = dotSep parts
379 where
380 parts = split op
381 operator = last parts
383 opDict = Map.fromList (infixOps ++ specialOps)
385 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
386 infixOp str op = specialOp str (InfixExpr () op)
388 infixOps = concat
389 [ infixOp "+" OpAdd
390 , infixOp "-" OpSub
391 , infixOp "*" OpMul
392 , infixOp "/" OpDiv
393 , infixOp "&&" OpLAnd
394 , infixOp "||" OpLOr
395 ]
397 specialOps = concat
398 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
399 , specialOp "|>" $ flip (<|)
400 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
401 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
402 , specialOp "<" $ cmp OpLT 0
403 , specialOp ">" $ cmp OpGT 0
404 , specialOp "<=" $ cmp OpLT 1
405 , specialOp ">=" $ cmp OpGT (-1)
406 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
407 ]
409 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)