git.iko.soy/elk
on 34b72a2 help sign in
elk/compiler/Generate/JavaScript.hs
431 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 :: String -> [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 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,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 $ obj ["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 $ obj ["Native","Ports","portIn"] `call` [ string name, Port.incoming tipe ]
197 PortOut name tipe value ->
198 do value' <- expression value
199 return $ obj ["Native","Ports","portOut"] `call`
200 [ string name, Port.outgoing tipe, value' ]
202definition :: Canonical.Def -> State Int [Statement ()]
203definition (Canonical.Definition pattern expr@(A region _) _) = do
204 expr' <- expression expr
205 let assign x = varDecl x expr'
206 case pattern of
207 P.Var x
208 | Help.isOp x ->
209 let op = LBracket () (ref "_op") (string x) in
210 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
211 | otherwise ->
212 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
214 P.Record fields ->
215 let setField f = varDecl f (obj ["$",f]) in
216 return [ VarDeclStmt () (assign "$" : map setField fields) ]
218 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
219 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
220 where
221 vars = getVars patterns
222 getVars patterns =
223 case patterns of
224 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
225 [] -> Just []
226 _ -> Nothing
228 decl x n = varDecl x (obj ["$","_" ++ show n])
229 setup vars
230 | Help.isTuple name = assign "$" : vars
231 | otherwise = assign "_raw" : safeAssign : vars
233 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
234 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
235 exception = Help.throw "Case" region
237 _ ->
238 do defs' <- concat <$> mapM toDef vars
239 return (VarDeclStmt () [assign "_"] : defs')
240 where
241 vars = P.boundVarList pattern
242 mkVar = A region . localVar
243 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
244 in definition $ Canonical.Definition (P.Var y) expr Nothing
246match :: Region -> Case.Match -> State Int [Statement ()]
247match region mtch =
248 case mtch of
249 Case.Match name clauses mtch' ->
250 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
251 mtch'' <- match region mtch'
252 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
253 where
254 isLiteral p = case p of
255 Case.Clause (Right _) _ _ -> True
256 _ -> False
258 access name
259 | any isLiteral clauses = obj [name]
260 | otherwise = obj (Help.splitDots name ++ ["ctor"])
262 format isChars e
263 | or isChars = InfixExpr () OpAdd e (string "")
264 | otherwise = e
266 Case.Fail ->
267 return [ ExprStmt () (Help.throw "Case" region) ]
269 Case.Break -> return [BreakStmt () Nothing]
271 Case.Other e ->
272 do e' <- expression e
273 return [ ret e' ]
275 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
276 where
277 dropEnd acc [] = acc
278 dropEnd acc (m:ms) =
279 case m of
280 Case.Other _ -> acc ++ [m]
281 _ -> dropEnd (acc ++ [m]) ms
283clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
284clause region variable (Case.Clause value vars mtch) =
285 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
286 where
287 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
288 (isChar, pattern) =
289 case value of
290 Right (Chr c) -> (True, string [c])
291 _ -> (,) False $ case value of
292 Right (Boolean b) -> BoolLit () b
293 Right lit -> literal lit
294 Left (Var.Canonical _ name) ->
295 string name
297flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
298flattenLets defs lexpr@(A _ expr) =
299 case expr of
300 Let ds body -> flattenLets (defs ++ ds) body
301 _ -> (defs, lexpr)
303generate :: CanonicalModule -> String
304generate modul =
305 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
306 [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]
307 where
308 names :: [String]
309 names = Module.names modul
311 thisModule :: Expression ()
312 thisModule = obj ("_elm" : names ++ ["values"])
314 programStmts :: [Statement ()]
315 programStmts =
316 concat
317 [ [ ExprStmt () (string "use strict") ]
318 , setup "_elm" (names ++ ["values"])
319 , [ IfSingleStmt () thisModule (ret thisModule) ]
320 , [ VarDeclStmt () localVars ]
321 , body
322 , [ jsExports ]
323 , [ ret thisModule ]
324 ]
326 localVars :: [VarDecl ()]
327 localVars = varDecl "_op" (ObjectLit () []) :
328 internalImports (Module.getName modul) ++
329 explicitImports
330 where
331 explicitImports :: [VarDecl ()]
332 explicitImports =
333 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
335 jsImport :: String -> VarDecl ()
336 jsImport name =
337 varDecl (Var.moduleName name) $
338 obj ("Elm" : Help.splitDots name ++ ["make"]) <| ref "_elm"
340 body :: [Statement ()]
341 body = concat $ evalState defs 0
342 where
343 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
345 setup namespace path = map create paths
346 where
347 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
348 paths = drop 2 . init . List.inits $ namespace : path
350 jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)
351 where
352 exs = map entry $ "_op" : concatMap extract (exports modul)
353 entry x = (prop x, ref x)
354 extract value =
355 case value of
356 Var.Alias _ -> []
357 Var.Value x | Help.isOp x -> []
358 | otherwise -> [x]
359 Var.ADT _ (Var.Listing ctors _) -> ctors
361 assign path expr =
362 case path of
363 [x] -> VarDeclStmt () [ varDecl x expr ]
364 _ -> ExprStmt () $
365 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
367binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr
368 -> State Int (Expression ())
369binop region func@(Var.Canonical home op) e1 e2 =
370 case (home, op) of
371 (Var.Module "Basics", ".") ->
372 do es <- mapM expression (e1 : collect [] e2)
373 return $ ["$"] ==> foldr (<|) (ref "$") es
375 (Var.Module "Basics", "<|") ->
376 do e2' <- expression e2
377 es <- mapM expression (collect [] e1)
378 return $ foldr (<|) e2' es
380 (Var.Module "List", "++") ->
381 do e1' <- expression e1
382 e2' <- expression e2
383 return $ _List "append" `call` [e1', e2']
385 (Var.BuiltIn, "::") ->
386 expression (A region (Data "::" [e1,e2]))
388 (Var.Module "Basics", _) ->
389 do e1' <- expression e1
390 e2' <- expression e2
391 return $ case Map.lookup op basicOps of
392 Just f -> f e1' e2'
393 Nothing -> ref "A2" `call` [ Var.canonical func, e1', e2' ]
395 _ ->
396 do e1' <- expression e1
397 e2' <- expression e2
398 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
400 where
401 collect es e =
402 case e of
403 A _ (Binop (Var.Canonical (Var.Module "Basics") ".") e1 e2) ->
404 collect (es ++ [e1]) e2
405 _ -> es ++ [e]
407 basicOps = Map.fromList (infixOps ++ specialOps)
409 infixOps =
410 let infixOp str op = (str, InfixExpr () op) in
411 [ infixOp "+" OpAdd
412 , infixOp "-" OpSub
413 , infixOp "*" OpMul
414 , infixOp "/" OpDiv
415 , infixOp "&&" OpLAnd
416 , infixOp "||" OpLOr
417 ]
419 specialOps =
420 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
421 , (,) "|>" $ flip (<|)
422 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
423 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
424 , (,) "<" $ cmp OpLT 0
425 , (,) ">" $ cmp OpGT 0
426 , (,) "<=" $ cmp OpLT 1
427 , (,) ">=" $ cmp OpGT (-1)
428 , (,) "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
429 ]
431 cmp op n a b = InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)