git.iko.soy/elk
on d288733 help sign in
elk/compiler/Generate/JavaScript.hs
386 lines 15 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Generate.JavaScript (generate) where
4import Control.Arrow (first,(***))
5import Control.Applicative ((<$>),(<*>))
6import Control.Monad.State
7import qualified Data.List as List
8import qualified Data.Map as Map
9import qualified Data.Set as Set
11import Generate.JavaScript.Helpers
12import qualified Generate.Cases as Case
13import qualified Generate.JavaScript.Ports as Port
14import qualified Generate.Markdown as MD
15import qualified SourceSyntax.Helpers as Help
16import SourceSyntax.Literal
17import SourceSyntax.Pattern as Pattern
18import SourceSyntax.Location
19import SourceSyntax.Expression
20import SourceSyntax.Module
21import Language.ECMAScript3.Syntax
22import Language.ECMAScript3.PrettyPrint
23import qualified Transform.SafeNames as MakeSafe
25varDecl :: String -> Expression () -> VarDecl ()
26varDecl x expr =
27 VarDecl () (var x) (Just expr)
29include :: String -> String -> VarDecl ()
30include alias moduleName =
31 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
33internalImports :: String -> Statement ()
34internalImports name =
35 VarDeclStmt ()
36 [ varDecl "_N" (obj "Elm.Native")
37 , include "_U" "_N.Utils"
38 , include "_L" "_N.List"
39 , include "_E" "_N.Error"
40 , include "_J" "_N.JavaScript"
41 , varDecl "$moduleName" (string name)
42 ]
44literal :: Literal -> Expression ()
45literal lit =
46 case lit of
47 Chr c -> obj "_U.chr" <| string [c]
48 Str s -> string s
49 IntNum n -> IntLit () n
50 FloatNum n -> NumLit () n
51 Boolean b -> BoolLit () b
53expression :: LExpr -> State Int (Expression ())
54expression (L span expr) =
55 case expr of
56 Var x -> return $ ref x
57 Literal lit -> return $ literal lit
59 Range lo hi ->
60 do lo' <- expression lo
61 hi' <- expression hi
62 return $ obj "_L.range" `call` [lo',hi']
64 Access e x ->
65 do e' <- expression e
66 return $ DotRef () e' (var x)
68 Remove e x ->
69 do e' <- expression e
70 return $ obj "_U.remove" `call` [string x, e']
72 Insert e x v ->
73 do v' <- expression v
74 e' <- expression e
75 return $ obj "_U.insert" `call` [string x, v', e']
77 Modify e fs ->
78 do e' <- expression e
79 fs' <- forM fs $ \(f,v) -> do
80 v' <- expression v
81 return $ ArrayLit () [string f, v']
82 return $ obj "_U.replace" `call` [ArrayLit () fs', e']
84 Record fields ->
85 do fields' <- forM fields $ \(f,e) -> do
86 (,) f <$> expression e
87 let fieldMap = List.foldl' combine Map.empty fields'
88 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
89 where
90 combine r (k,v) = Map.insertWith (++) k [v] r
91 prop = PropId () . var
92 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
93 Map.toList . Map.filter (not . null) $ Map.map tail fs
94 visible fs = map (first prop) . Map.toList $ Map.map head fs
96 Binop op e1 e2 -> binop span op e1 e2
98 Lambda p e@(L s _) ->
99 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
100 body' <- expression body
101 return $ case length args < 2 || length args > 9 of
102 True -> foldr (==>) body' (map (:[]) args)
103 False -> ref ("F" ++ show (length args)) <| (args ==> body')
104 where
105 depattern (args, body) pattern =
106 case pattern of
107 PVar x -> return (args ++ [x], body)
108 _ -> do arg <- Case.newVar
109 return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
111 (patterns, innerBody) = collect [p] e
113 collect patterns lexpr@(L _ expr) =
114 case expr of
115 Lambda p e -> collect (p:patterns) e
116 _ -> (patterns, lexpr)
118 App e1 e2 ->
119 do func' <- expression func
120 args' <- mapM expression args
121 return $ case args' of
122 [arg] -> func' <| arg
123 _ | length args' <= 9 -> ref aN `call` (func':args')
124 | otherwise -> foldl1 (<|) (func':args')
125 where
126 aN = "A" ++ show (length args)
127 (func, args) = getArgs e1 [e2]
128 getArgs func args =
129 case func of
130 (L _ (App f arg)) -> getArgs f (arg : args)
131 _ -> (func, args)
133 Let defs e ->
134 do let (defs',e') = flattenLets defs e
135 stmts <- concat <$> mapM definition defs'
136 exp <- expression e'
137 return $ function [] (stmts ++ [ ret exp ]) `call` []
139 MultiIf branches ->
140 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
141 return $ case last branches of
142 (L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
143 (L _ (Literal (Boolean True)), _) -> safeIfs branches'
144 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
145 where
146 safeIfs branches = ifs (init branches) (snd (last branches))
147 ifs branches finally = foldr iff finally branches
148 iff (if', then') else' = CondExpr () if' then' else'
150 Case e cases ->
151 do (tempVar,initialMatch) <- Case.toMatch cases
152 (revisedMatch, stmt) <-
153 case e of
154 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
155 _ -> do e' <- expression e
156 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
157 match' <- match span revisedMatch
158 return (function [] (stmt ++ match') `call` [])
160 ExplicitList es ->
161 do es' <- mapM expression es
162 return $ obj "_J.toList" <| ArrayLit () es'
164 Data name es ->
165 do es' <- mapM expression es
166 return $ ObjectLit () (ctor : fields es')
167 where
168 ctor = (prop "ctor", string name)
169 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
171 Markdown uid doc es ->
172 do es' <- mapM expression es
173 return $ obj "Text.markdown" `call` (string md : string uid : es')
174 where
175 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
176 md = pad ++ MD.toHtml doc ++ pad
178 GLShader _uid src _tipe ->
179 return $ ObjectLit () [(PropString () "src", literal (Str src))]
181 PortIn name tipe ->
182 return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
184 PortOut name tipe value ->
185 do value' <- expression value
186 return $ obj "Native.Ports.portOut" `call`
187 [ string name, Port.outgoing tipe, value' ]
189definition :: Def -> State Int [Statement ()]
190definition (Definition pattern expr@(L span _) _) = do
191 expr' <- expression expr
192 let assign x = varDecl x expr'
193 case pattern of
194 PVar x
195 | Help.isOp x ->
196 let op = LBracket () (ref "_op") (string x) in
197 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
198 | otherwise ->
199 return [ VarDeclStmt () [ assign x ] ]
201 PRecord fields ->
202 let setField f = varDecl f (dotSep ["$",f]) in
203 return [ VarDeclStmt () (assign "$" : map setField fields) ]
205 PData name patterns | vars /= Nothing ->
206 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
207 where
208 vars = getVars patterns
209 getVars patterns =
210 case patterns of
211 PVar x : rest -> (x:) `fmap` getVars rest
212 [] -> Just []
213 _ -> Nothing
215 decl x n = varDecl x (dotSep ["$","_" ++ show n])
216 setup vars
217 | Help.isTuple name = assign "$" : vars
218 | otherwise = assign "$raw" : safeAssign : vars
220 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
221 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
222 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
224 _ ->
225 do defs' <- concat <$> mapM toDef vars
226 return (VarDeclStmt () [assign "$"] : defs')
227 where
228 vars = Set.toList $ Pattern.boundVars pattern
229 mkVar = L span . Var
230 toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
231 in definition $ Definition (PVar y) expr Nothing
233match :: SrcSpan -> Case.Match -> State Int [Statement ()]
234match span mtch =
235 case mtch of
236 Case.Match name clauses mtch' ->
237 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
238 mtch'' <- match span mtch'
239 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
240 where
241 isLiteral p = case p of
242 Case.Clause (Right _) _ _ -> True
243 _ -> False
244 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
245 format isChars e
246 | or isChars = InfixExpr () OpAdd e (string "")
247 | otherwise = e
249 Case.Fail ->
250 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
252 Case.Break -> return [BreakStmt () Nothing]
253 Case.Other e ->
254 do e' <- expression e
255 return [ ret e' ]
256 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
257 where
258 dropEnd acc [] = acc
259 dropEnd acc (m:ms) =
260 case m of
261 Case.Other _ -> acc ++ [m]
262 _ -> dropEnd (acc ++ [m]) ms
264clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
265clause span variable (Case.Clause value vars mtch) =
266 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
267 where
268 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
269 (isChar, pattern) =
270 case value of
271 Right (Chr c) -> (True, string [c])
272 _ -> (,) False $ case value of
273 Right (Boolean b) -> BoolLit () b
274 Right lit -> literal lit
275 Left name -> string $ case List.elemIndices '.' name of
276 [] -> name
277 is -> drop (last is + 1) name
279flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
280flattenLets defs lexpr@(L _ expr) =
281 case expr of
282 Let ds body -> flattenLets (defs ++ ds) body
283 _ -> (defs, lexpr)
285generate :: MetadataModule -> String
286generate unsafeModule =
287 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
288 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
289 where
290 modul = MakeSafe.metadataModule unsafeModule
291 thisModule = dotSep ("_elm" : names modul ++ ["values"])
292 programStmts =
293 concat
294 [ setup (Just "_elm") (names modul ++ ["values"])
295 , [ IfSingleStmt () thisModule (ret thisModule) ]
296 , [ internalImports (List.intercalate "." (names modul)) ]
297 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
298 , [ assign ["_op"] (ObjectLit () []) ]
299 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
300 , [ jsExports ]
301 , [ ret thisModule ]
302 ]
304 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
305 where
306 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
307 entry x = (PropId () (var x), ref x)
309 assign path expr =
310 case path of
311 [x] -> VarDeclStmt () [ varDecl x expr ]
312 _ -> ExprStmt () $
313 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
315 jsImport modul = setup Nothing path ++ [ include ]
316 where
317 path = Help.splitDots modul
318 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
320 setup namespace path = map create paths
321 where
322 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
323 paths = case namespace of
324 Nothing -> tail . init $ List.inits path
325 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
327binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
328binop span op e1 e2 =
329 case op of
330 "Basics.." ->
331 do es <- mapM expression (e1 : collect [] e2)
332 return $ ["$"] ==> foldr (<|) (ref "$") es
333 "Basics.<|" ->
334 do e2' <- expression e2
335 es <- mapM expression (collect [] e1)
336 return $ foldr (<|) e2' es
337 "List.++" ->
338 do e1' <- expression e1
339 e2' <- expression e2
340 return $ obj "_L.append" `call` [e1', e2']
341 "::" -> expression (L span (Data "::" [e1,e2]))
342 _ ->
343 do e1' <- expression e1
344 e2' <- expression e2
345 return $ case Map.lookup op opDict of
346 Just f -> f e1' e2'
347 Nothing -> ref "A2" `call` [ func, e1', e2' ]
348 where
349 collect es e =
350 case e of
351 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
352 _ -> es ++ [e]
354 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
355 | otherwise = dotSep parts
356 where
357 parts = Help.splitDots op
358 operator = last parts
360 opDict = Map.fromList (infixOps ++ specialOps)
362 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
363 infixOp str op = specialOp str (InfixExpr () op)
365 infixOps = concat
366 [ infixOp "+" OpAdd
367 , infixOp "-" OpSub
368 , infixOp "*" OpMul
369 , infixOp "/" OpDiv
370 , infixOp "&&" OpLAnd
371 , infixOp "||" OpLOr
372 ]
374 specialOps = concat
375 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
376 , specialOp "|>" $ flip (<|)
377 , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
378 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
379 , specialOp "<" $ cmp OpLT 0
380 , specialOp ">" $ cmp OpGT 0
381 , specialOp "<=" $ cmp OpLT 1
382 , specialOp ">=" $ cmp OpGT (-1)
383 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
384 ]
386 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)