git.iko.soy/elk
on 702f99c help sign in
elk/compiler/Generate/JavaScript.hs
430 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
14import qualified Generate.Cases as Case
15import qualified Generate.JavaScript.Ports as Port
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 AST.PrettyPrint (renderPretty)
27import qualified AST.Variable as Var
29varDecl :: String -> Expression () -> VarDecl ()
30varDecl x expr =
31 VarDecl () (var x) (Just expr)
33include :: String -> String -> VarDecl ()
34include alias moduleName =
35 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
37internalImports :: String -> Statement ()
38internalImports name =
39 VarDeclStmt ()
40 [ varDecl "_N" (obj "Elm.Native")
41 , include "_U" "_N.Utils"
42 , include "_L" "_N.List"
43 , include "_A" "_N.Array"
44 , include "_E" "_N.Error"
45 , varDecl "$moduleName" (string name)
46 ]
48literal :: Literal -> Expression ()
49literal lit =
50 case lit of
51 Chr c -> obj "_U.chr" <| string [c]
52 Str s -> string s
53 IntNum n -> IntLit () n
54 FloatNum n -> NumLit () n
55 Boolean b -> BoolLit () b
57canonical :: Var.Canonical -> Expression ()
58canonical (Var.Canonical home name) =
59 case Help.isOp name of
60 True -> BracketRef () (dotSep (home' ++ ["_op"])) (string name)
61 False -> dotSep (home' ++ [map (swap '\'' '$') name])
62 where
63 swap from to c = if c == from then to else c
65 home' =
66 case home of
67 Var.Local -> []
68 Var.BuiltIn -> []
69 Var.Module path -> [ map (swap '.' '$') path ]
71expression :: Canonical.Expr -> State Int (Expression ())
72expression (A region expr) =
73 case expr of
74 Var var -> return $ canonical var
76 Literal lit -> return $ literal lit
78 Range lo hi ->
79 do lo' <- expression lo
80 hi' <- expression hi
81 return $ obj "_L.range" `call` [lo',hi']
83 Access e x ->
84 do e' <- expression e
85 return $ DotRef () e' (var x)
87 Remove e x ->
88 do e' <- expression e
89 return $ obj "_U.remove" `call` [string x, e']
91 Insert e x v ->
92 do v' <- expression v
93 e' <- expression e
94 return $ obj "_U.insert" `call` [string x, v', e']
96 Modify e fs ->
97 do e' <- expression e
98 fs' <- forM fs $ \(f,v) -> do
99 v' <- expression v
100 return $ ArrayLit () [string f, v']
101 return $ obj "_U.replace" `call` [ArrayLit () fs', e']
103 Record fields ->
104 do fields' <- forM fields $ \(f,e) -> do
105 (,) f <$> expression e
106 let fieldMap = List.foldl' combine Map.empty fields'
107 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
108 where
109 combine r (k,v) = Map.insertWith (++) k [v] r
110 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
111 Map.toList . Map.filter (not . null) $ Map.map tail fs
112 visible fs = map (first prop) . Map.toList $ Map.map head fs
114 Binop op e1 e2 -> binop region op e1 e2
116 Lambda p e@(A ann _) ->
117 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
118 body' <- expression body
119 return $ case length args < 2 || length args > 9 of
120 True -> foldr (==>) body' (map (:[]) args)
121 False -> ref ("F" ++ show (length args)) <| (args ==> body')
122 where
123 depattern (args, body) pattern =
124 case pattern of
125 P.Var x -> return (args ++ [x], body)
126 _ -> do arg <- Case.newVar
127 return ( args ++ [arg]
128 , A ann (Case (A ann (localVar arg)) [(pattern, body)]))
130 (patterns, innerBody) = collect [p] e
132 collect patterns lexpr@(A _ expr) =
133 case expr of
134 Lambda p e -> collect (p:patterns) e
135 _ -> (patterns, lexpr)
137 App e1 e2 ->
138 do func' <- expression func
139 args' <- mapM expression args
140 return $ case args' of
141 [arg] -> func' <| arg
142 _ | length args' <= 9 -> ref aN `call` (func':args')
143 | otherwise -> foldl1 (<|) (func':args')
144 where
145 aN = "A" ++ show (length args)
146 (func, args) = getArgs e1 [e2]
147 getArgs func args =
148 case func of
149 (A _ (App f arg)) -> getArgs f (arg : args)
150 _ -> (func, args)
152 Let defs e ->
153 do let (defs',e') = flattenLets defs e
154 stmts <- concat <$> mapM definition defs'
155 exp <- expression e'
156 return $ function [] (stmts ++ [ ret exp ]) `call` []
158 MultiIf branches ->
159 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
160 return $ case last branches of
161 (A _ (Var (Var.Canonical (Var.Module "Basics") "otherwise")), _) ->
162 safeIfs branches'
163 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
164 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
165 where
166 safeIfs branches = ifs (init branches) (snd (last branches))
167 ifs branches finally = foldr iff finally branches
168 iff (if', then') else' = CondExpr () if' then' else'
170 Case e cases ->
171 do (tempVar,initialMatch) <- Case.toMatch cases
172 (revisedMatch, stmt) <-
173 case e of
174 A _ (Var (Var.Canonical Var.Local x)) ->
175 return (Case.matchSubst [(tempVar,x)] initialMatch, [])
176 _ ->
177 do e' <- expression e
178 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
179 match' <- match region revisedMatch
180 return (function [] (stmt ++ match') `call` [])
182 ExplicitList es ->
183 do es' <- mapM expression es
184 return $ obj "_L.fromArray" <| ArrayLit () es'
186 Data name es ->
187 do es' <- mapM expression es
188 return $ ObjectLit () (ctor : fields es')
189 where
190 ctor = (prop "ctor", string name)
191 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
193 Markdown uid doc es ->
194 do es' <- mapM expression es
195 return $ obj "Text.markdown" `call` (string md : string uid : es')
196 where
197 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
198 md = pad ++ MD.toHtml doc ++ pad
200 GLShader _uid src _tipe ->
201 return $ ObjectLit () [(PropString () "src", literal (Str src))]
203 PortIn name tipe ->
204 return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
206 PortOut name tipe value ->
207 do value' <- expression value
208 return $ obj "Native.Ports.portOut" `call`
209 [ string name, Port.outgoing tipe, value' ]
211definition :: Canonical.Def -> State Int [Statement ()]
212definition (Canonical.Definition pattern expr@(A region _) _) = do
213 expr' <- expression expr
214 let assign x = varDecl x expr'
215 case pattern of
216 P.Var x
217 | Help.isOp x ->
218 let op = LBracket () (ref "_op") (string x) in
219 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
220 | otherwise ->
221 return [ VarDeclStmt () [ assign x ] ]
223 P.Record fields ->
224 let setField f = varDecl f (dotSep ["$",f]) in
225 return [ VarDeclStmt () (assign "$" : map setField fields) ]
227 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
228 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
229 where
230 vars = getVars patterns
231 getVars patterns =
232 case patterns of
233 P.Var x : rest -> (x:) `fmap` getVars rest
234 [] -> Just []
235 _ -> Nothing
237 decl x n = varDecl x (dotSep ["$","_" ++ show n])
238 setup vars
239 | Help.isTuple name = assign "$" : vars
240 | otherwise = assign "_raw" : safeAssign : vars
242 safeAssign = varDecl "$" (CondExpr () if' (obj "_raw") exception)
243 if' = InfixExpr () OpStrictEq (obj "_raw.ctor") (string name)
244 exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
246 _ ->
247 do defs' <- concat <$> mapM toDef vars
248 return (VarDeclStmt () [assign "_"] : defs')
249 where
250 vars = P.boundVarList pattern
251 mkVar = A region . localVar
252 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
253 in definition $ Canonical.Definition (P.Var y) expr Nothing
255match :: Region -> Case.Match -> State Int [Statement ()]
256match region mtch =
257 case mtch of
258 Case.Match name clauses mtch' ->
259 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
260 mtch'' <- match region mtch'
261 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
262 where
263 isLiteral p = case p of
264 Case.Clause (Right _) _ _ -> True
265 _ -> False
267 access name
268 | any isLiteral clauses = obj name
269 | otherwise = dotSep (split name ++ ["ctor"])
271 format isChars e
272 | or isChars = InfixExpr () OpAdd e (string "")
273 | otherwise = e
275 Case.Fail ->
276 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
278 Case.Break -> return [BreakStmt () Nothing]
280 Case.Other e ->
281 do e' <- expression e
282 return [ ret e' ]
284 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
285 where
286 dropEnd acc [] = acc
287 dropEnd acc (m:ms) =
288 case m of
289 Case.Other _ -> acc ++ [m]
290 _ -> dropEnd (acc ++ [m]) ms
292clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
293clause region variable (Case.Clause value vars mtch) =
294 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
295 where
296 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
297 (isChar, pattern) =
298 case value of
299 Right (Chr c) -> (True, string [c])
300 _ -> (,) False $ case value of
301 Right (Boolean b) -> BoolLit () b
302 Right lit -> literal lit
303 Left (Var.Canonical _ name) ->
304 string name
306flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
307flattenLets defs lexpr@(A _ expr) =
308 case expr of
309 Let ds body -> flattenLets (defs ++ ds) body
310 _ -> (defs, lexpr)
312generate :: CanonicalModule -> String
313generate modul =
314 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
315 [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]
316 where
317 names = Module.names modul
319 thisModule = dotSep ("_elm" : names ++ ["values"])
320 programStmts =
321 concat
322 [ [ ExprStmt () $ string "use strict" ]
323 , setup "_elm" (names ++ ["values"])
324 , [ IfSingleStmt () thisModule (ret thisModule) ]
325 , [ internalImports (List.intercalate "." names) ]
326 , map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
327 , [ assign ["_op"] (ObjectLit () []) ]
328 , concat $ evalState (mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)) 0
329 , [ jsExports ]
330 , [ ret thisModule ]
331 ]
333 jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)
334 where
335 exs = map entry $ "_op" : concatMap extract (exports modul)
336 entry x = (prop x, ref x)
337 extract value =
338 case value of
339 Var.Alias _ -> []
340 Var.Value x | Help.isOp x -> []
341 | otherwise -> [x]
342 Var.ADT _ (Var.Listing ctors _) -> ctors
344 assign path expr =
345 case path of
346 [x] -> VarDeclStmt () [ varDecl x expr ]
347 _ -> ExprStmt () $
348 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
350 jsImport name =
351 assign [dolarize name] $ dotSep ("Elm" : Help.splitDots name ++ ["make"]) <| ref "_elm"
353 setup namespace path = map create paths
354 where
355 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
356 paths = drop 2 . init . List.inits $ namespace : path
358binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr
359 -> State Int (Expression ())
360binop region (Var.Canonical home op) e1 e2 =
361 case (home, op) of
362 (Var.Module "Basics", ".") ->
363 do es <- mapM expression (e1 : collect [] e2)
364 return $ ["$"] ==> foldr (<|) (ref "$") es
366 (Var.Module "Basics", "<|") ->
367 do e2' <- expression e2
368 es <- mapM expression (collect [] e1)
369 return $ foldr (<|) e2' es
371 (Var.Module "List", "++") ->
372 do e1' <- expression e1
373 e2' <- expression e2
374 return $ obj "_L.append" `call` [e1', e2']
376 (Var.BuiltIn, "::") ->
377 expression (A region (Data "::" [e1,e2]))
379 (Var.Module "Basics", _) ->
380 do e1' <- expression e1
381 e2' <- expression e2
382 return $ case Map.lookup op basicOps of
383 Just f -> f e1' e2'
384 Nothing -> ref "A2" `call` [ func, e1', e2' ]
386 _ ->
387 do e1' <- expression e1
388 e2' <- expression e2
389 return (ref "A2" `call` [ func, e1', e2' ])
391 where
392 collect es e =
393 case e of
394 A _ (Binop (Var.Canonical (Var.Module "Basics") ".") e1 e2) ->
395 collect (es ++ [e1]) e2
396 _ -> es ++ [e]
398 func | Help.isOp op = BracketRef () (dotSep (path ++ ["_op"])) (string op)
399 | otherwise = dotSep (path ++ [op])
400 where
401 path = case home of
402 Var.Local -> []
403 Var.BuiltIn -> []
404 Var.Module m -> [dolarize m]
406 basicOps = Map.fromList (infixOps ++ specialOps)
408 infixOps =
409 let infixOp str op = (str, InfixExpr () op) in
410 [ infixOp "+" OpAdd
411 , infixOp "-" OpSub
412 , infixOp "*" OpMul
413 , infixOp "/" OpDiv
414 , infixOp "&&" OpLAnd
415 , infixOp "||" OpLOr
416 ]
418 specialOps =
419 [ (,) "^" $ \a b -> obj "Math.pow" `call` [a,b]
420 , (,) "|>" $ flip (<|)
421 , (,) "==" $ \a b -> obj "_U.eq" `call` [a,b]
422 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
423 , (,) "<" $ cmp OpLT 0
424 , (,) ">" $ cmp OpGT 0
425 , (,) "<=" $ cmp OpLT 1
426 , (,) ">=" $ cmp OpGT (-1)
427 , (,) "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
428 ]
430 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)