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