git.iko.soy/elk
on dbe27eb help sign in
elk/src/Generate/JavaScript.hs
442 lines 16 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Generate.JavaScript (generate) where
4import Control.Applicative ((<$>),(<*>))
5import Control.Arrow (first,(***))
6import Control.Monad.State
7import qualified Data.List as List
8import qualified Data.Map as Map
9import qualified Data.Set as Set
10import Language.ECMAScript3.PrettyPrint
11import Language.ECMAScript3.Syntax
13import Generate.JavaScript.Helpers as Help
14import qualified Generate.Cases as Case
15import qualified Generate.JavaScript.Ports as Port
16import qualified Generate.JavaScript.Variable as Var
17import qualified Generate.Markdown as MD
19import AST.Annotation
20import AST.Module
21import AST.Expression.General
22import qualified AST.Expression.Canonical as Canonical
23import qualified AST.Module as Module
24import qualified AST.Helpers as Help
25import AST.Literal
26import qualified AST.Pattern as P
27import qualified AST.Variable as Var
29varDecl :: String -> Expression () -> VarDecl ()
30varDecl x expr =
31 VarDecl () (var x) (Just expr)
33internalImports :: Module.Name -> [VarDecl ()]
34internalImports name =
35 [ varDecl "_N" (obj ["Elm","Native"])
36 , include "_U" "Utils"
37 , include "_L" "List"
38 , include "_A" "Array"
39 , include "_E" "Error"
40 , varDecl Help.localModuleName (string (Module.nameToString name))
41 ]
42 where
43 include :: String -> String -> VarDecl ()
44 include alias modul =
45 varDecl alias (obj ["_N", modul, "make"] <| ref "_elm")
47_Utils :: String -> Expression ()
48_Utils x = obj ["_U", x]
50_List :: String -> Expression ()
51_List x = obj ["_L", x]
53literal :: Literal -> Expression ()
54literal lit =
55 case lit of
56 Chr c -> _Utils "chr" <| string [c]
57 Str s -> string s
58 IntNum n -> IntLit () n
59 FloatNum n -> NumLit () n
60 Boolean b -> BoolLit () b
62expression :: Canonical.Expr -> State Int (Expression ())
63expression (A region expr) =
64 case expr of
65 Var var -> return $ Var.canonical var
67 Literal lit -> return $ literal lit
69 Range lo hi ->
70 do lo' <- expression lo
71 hi' <- expression hi
72 return $ _List "range" `call` [lo',hi']
74 Access e x ->
75 do e' <- expression e
76 return $ DotRef () e' (var x)
78 Remove e x ->
79 do e' <- expression e
80 return $ _Utils "remove" `call` [string x, e']
82 Insert e x v ->
83 do v' <- expression v
84 e' <- expression e
85 return $ _Utils "insert" `call` [string x, v', e']
87 Modify e fs ->
88 do e' <- expression e
89 fs' <- forM fs $ \(f,v) -> do
90 v' <- expression v
91 return $ ArrayLit () [string f, v']
92 return $ _Utils "replace" `call` [ArrayLit () fs', e']
94 Record fields ->
95 do fields' <- forM fields $ \(f,e) -> do
96 (,) f <$> expression e
97 let fieldMap = List.foldl' combine Map.empty fields'
98 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
99 where
100 combine r (k,v) = Map.insertWith (++) k [v] r
101 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
102 Map.toList . Map.filter (not . null) $ Map.map tail fs
103 visible fs = map (first prop) . Map.toList $ Map.map head fs
105 Binop op e1 e2 -> binop region op e1 e2
107 Lambda p e@(A ann _) ->
108 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
109 body' <- expression body
110 return $ case length args < 2 || length args > 9 of
111 True -> foldr (==>) body' (map (:[]) args)
112 False -> ref ("F" ++ show (length args)) <| (args ==> body')
113 where
114 depattern (args, body) pattern =
115 case pattern of
116 P.Var x -> return (args ++ [ Var.varName x ], body)
117 _ -> do arg <- Case.newVar
118 return ( args ++ [arg]
119 , A ann (Case (A ann (localVar arg)) [(pattern, body)]))
121 (patterns, innerBody) = collect [p] e
123 collect patterns lexpr@(A _ expr) =
124 case expr of
125 Lambda p e -> collect (p:patterns) e
126 _ -> (patterns, lexpr)
128 App e1 e2 ->
129 do func' <- expression func
130 args' <- mapM expression args
131 return $ case args' of
132 [arg] -> func' <| arg
133 _ | length args' <= 9 -> ref aN `call` (func':args')
134 | otherwise -> foldl1 (<|) (func':args')
135 where
136 aN = "A" ++ show (length args)
137 (func, args) = getArgs e1 [e2]
138 getArgs func args =
139 case func of
140 (A _ (App f arg)) -> getArgs f (arg : args)
141 _ -> (func, args)
143 Let defs e ->
144 do let (defs',e') = flattenLets defs e
145 stmts <- concat <$> mapM definition defs'
146 exp <- expression e'
147 return $ function [] (stmts ++ [ ret exp ]) `call` []
149 MultiIf branches ->
150 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
151 return $ case last branches of
152 (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
153 safeIfs branches'
154 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
155 _ -> ifs branches' (throw "If" region)
156 where
157 safeIfs branches = ifs (init branches) (snd (last branches))
158 ifs branches finally = foldr iff finally branches
159 iff (if', then') else' = CondExpr () if' then' else'
161 Case e cases ->
162 do (tempVar,initialMatch) <- Case.toMatch cases
163 (revisedMatch, stmt) <-
164 case e of
165 A _ (Var (Var.Canonical Var.Local x)) ->
166 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
167 _ ->
168 do e' <- expression e
169 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
170 match' <- match region revisedMatch
171 return (function [] (stmt ++ match') `call` [])
173 ExplicitList es ->
174 do es' <- mapM expression es
175 return $ _List "fromArray" <| ArrayLit () es'
177 Data name es ->
178 do es' <- mapM expression es
179 return $ ObjectLit () (ctor : fields es')
180 where
181 ctor = (prop "ctor", string name)
182 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
184 Markdown uid doc es ->
185 do es' <- mapM expression es
186 return $ Var.value ["Text"] "markdown" `call` (string md : string uid : es')
187 where
188 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
189 md = pad ++ MD.toHtml doc ++ pad
191 GLShader _uid src _tipe ->
192 return $ ObjectLit () [(PropString () "src", literal (Str src))]
194 PortIn name tipe ->
195 return $ Var.value ["Native","Ports"] "portIn" `call`
196 [ string name, Port.incoming tipe ]
198 PortOut name tipe value ->
199 do value' <- expression value
200 return $ Var.value ["Native","Ports"] "portOut" `call`
201 [ string name, Port.outgoing tipe, value' ]
203definition :: Canonical.Def -> State Int [Statement ()]
204definition (Canonical.Definition pattern expr@(A region _) _) = do
205 expr' <- expression expr
206 let assign x = varDecl x expr'
207 case pattern of
208 P.Var x
209 | Help.isOp x ->
210 let op = LBracket () (ref "_op") (string x) in
211 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
212 | otherwise ->
213 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
215 P.Record fields ->
216 let setField f = varDecl f (obj ["$",f]) in
217 return [ VarDeclStmt () (assign "$" : map setField fields) ]
219 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
220 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
221 where
222 vars = getVars patterns
223 getVars patterns =
224 case patterns of
225 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
226 [] -> Just []
227 _ -> Nothing
229 decl x n = varDecl x (obj ["$","_" ++ show n])
230 setup vars
231 | Help.isTuple name = assign "$" : vars
232 | otherwise = assign "_raw" : safeAssign : vars
234 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
235 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
236 exception = Help.throw "Case" region
238 _ ->
239 do defs' <- concat <$> mapM toDef vars
240 return (VarDeclStmt () [assign "_"] : defs')
241 where
242 vars = P.boundVarList pattern
243 mkVar = A region . localVar
244 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
245 in definition $ Canonical.Definition (P.Var y) expr Nothing
247match :: Region -> Case.Match -> State Int [Statement ()]
248match region mtch =
249 case mtch of
250 Case.Match name clauses mtch' ->
251 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
252 mtch'' <- match region mtch'
253 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
254 where
255 isLiteral p = case p of
256 Case.Clause (Right _) _ _ -> True
257 _ -> False
259 access name
260 | any isLiteral clauses = obj [name]
261 | otherwise = obj (Help.splitDots name ++ ["ctor"])
263 format isChars e
264 | or isChars = InfixExpr () OpAdd e (string "")
265 | otherwise = e
267 Case.Fail ->
268 return [ ExprStmt () (Help.throw "Case" region) ]
270 Case.Break -> return [BreakStmt () Nothing]
272 Case.Other e ->
273 do e' <- expression e
274 return [ ret e' ]
276 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
277 where
278 dropEnd acc [] = acc
279 dropEnd acc (m:ms) =
280 case m of
281 Case.Other _ -> acc ++ [m]
282 _ -> dropEnd (acc ++ [m]) ms
284clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
285clause region variable (Case.Clause value vars mtch) =
286 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
287 where
288 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
289 (isChar, pattern) =
290 case value of
291 Right (Chr c) -> (True, string [c])
292 _ -> (,) False $ case value of
293 Right (Boolean b) -> BoolLit () b
294 Right lit -> literal lit
295 Left (Var.Canonical _ name) ->
296 string name
298flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
299flattenLets defs lexpr@(A _ expr) =
300 case expr of
301 Let ds body -> flattenLets (defs ++ ds) body
302 _ -> (defs, lexpr)
304generate :: CanonicalModule -> String
305generate modul =
306 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
307 [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]
308 where
309 names :: [String]
310 names = Module.names modul
312 thisModule :: Expression ()
313 thisModule = obj ("_elm" : names ++ ["values"])
315 programStmts :: [Statement ()]
316 programStmts =
317 concat
318 [ [ ExprStmt () (string "use strict") ]
319 , setup "_elm" (names ++ ["values"])
320 , [ IfSingleStmt () thisModule (ret thisModule) ]
321 , [ VarDeclStmt () localVars ]
322 , body
323 , [ jsExports ]
324 , [ ret thisModule ]
325 ]
327 localVars :: [VarDecl ()]
328 localVars = varDecl "_op" (ObjectLit () []) :
329 internalImports (Module.names modul) ++
330 explicitImports
331 where
332 explicitImports :: [VarDecl ()]
333 explicitImports =
334 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
336 jsImport :: Module.Name -> VarDecl ()
337 jsImport name =
338 varDecl (Var.moduleName name) $
339 obj ("Elm" : name ++ ["make"]) <| ref "_elm"
341 body :: [Statement ()]
342 body = concat $ evalState defs 0
343 where
344 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
346 setup namespace path = map create paths
347 where
348 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
349 paths = drop 2 . init . List.inits $ namespace : path
351 jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)
352 where
353 exs = map entry $ "_op" : concatMap extract (exports modul)
354 entry x = (prop x, ref x)
355 extract value =
356 case value of
357 Var.Alias _ -> []
358 Var.Value x | Help.isOp x -> []
359 | otherwise -> [Var.varName x]
360 Var.ADT _ (Var.Listing ctors _) -> map Var.varName ctors
362 assign path expr =
363 case path of
364 [x] -> VarDeclStmt () [ varDecl x expr ]
365 _ -> ExprStmt () $
366 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
368binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr
369 -> State Int (Expression ())
370binop region func@(Var.Canonical home op) e1 e2 =
371 case (home, op) of
372 (Var.Module ["Basics"], ">>") ->
373 do es <- mapM expression (collectLeftAssoc [e2] e1)
374 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
376 (Var.Module ["Basics"], "<<") ->
377 do es <- mapM expression (e1 : collectRightAssoc [] e2)
378 return $ ["$"] ==> foldr (<|) (ref "$") es
380 (Var.Module ["Basics"], "<|") ->
381 do e2' <- expression e2
382 es <- mapM expression (collectRightAssoc [] e1)
383 return $ foldr (<|) e2' es
385 (Var.Module ["List"], "++") ->
386 do e1' <- expression e1
387 e2' <- expression e2
388 return $ _List "append" `call` [e1', e2']
390 (Var.BuiltIn, "::") ->
391 expression (A region (Data "::" [e1,e2]))
393 (Var.Module ["Basics"], _) ->
394 do e1' <- expression e1
395 e2' <- expression e2
396 return $ case Map.lookup op basicOps of
397 Just f -> f e1' e2'
398 Nothing -> ref "A2" `call` [ Var.canonical func, e1', e2' ]
400 _ ->
401 do e1' <- expression e1
402 e2' <- expression e2
403 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
405 where
406 collectRightAssoc es e =
407 case e of
408 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
409 collectRightAssoc (es ++ [e1]) e2
410 _ -> es ++ [e]
412 collectLeftAssoc es e =
413 case e of
414 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
415 collectLeftAssoc (e2 : es) e1
416 _ -> e : es
418 basicOps = Map.fromList (infixOps ++ specialOps)
420 infixOps =
421 let infixOp str op = (str, InfixExpr () op) in
422 [ infixOp "+" OpAdd
423 , infixOp "-" OpSub
424 , infixOp "*" OpMul
425 , infixOp "/" OpDiv
426 , infixOp "&&" OpLAnd
427 , infixOp "||" OpLOr
428 ]
430 specialOps =
431 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
432 , (,) "|>" $ flip (<|)
433 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
434 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
435 , (,) "<" $ cmp OpLT 0
436 , (,) ">" $ cmp OpGT 0
437 , (,) "<=" $ cmp OpLT 1
438 , (,) ">=" $ cmp OpGT (-1)
439 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
440 ]
442 cmp op n a b = InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)