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