git.iko.soy/elk
on 142c2c0 help sign in
elk/compiler/Generate/JavaScript.hs
389 lines 15 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
17import SourceSyntax.Annotation
18import SourceSyntax.Expression
19import qualified SourceSyntax.Helpers as Help
20import SourceSyntax.Literal
21import SourceSyntax.Module
22import qualified SourceSyntax.Pattern as P
23import SourceSyntax.PrettyPrint (renderPretty)
24import qualified SourceSyntax.Variable as V
25import qualified Transform.SafeNames as MakeSafe
27varDecl :: String -> Expression () -> VarDecl ()
28varDecl x expr =
29 VarDecl () (var x) (Just expr)
31include :: String -> String -> VarDecl ()
32include alias moduleName =
33 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
35internalImports :: String -> Statement ()
36internalImports name =
37 VarDeclStmt ()
38 [ varDecl "_N" (obj "Elm.Native")
39 , include "_U" "_N.Utils"
40 , include "_L" "_N.List"
41 , include "_E" "_N.Error"
42 , include "_J" "_N.JavaScript"
43 , varDecl "$moduleName" (string name)
44 ]
46literal :: Literal -> Expression ()
47literal lit =
48 case lit of
49 Chr c -> obj "_U.chr" <| string [c]
50 Str s -> string s
51 IntNum n -> IntLit () n
52 FloatNum n -> NumLit () n
53 Boolean b -> BoolLit () b
55expression :: Expr -> State Int (Expression ())
56expression (A region expr) =
57 case expr of
58 Var (V.Raw x) -> return $ ref x
59 Literal lit -> return $ literal lit
61 Range lo hi ->
62 do lo' <- expression lo
63 hi' <- expression hi
64 return $ obj "_L.range" `call` [lo',hi']
66 Access e x ->
67 do e' <- expression e
68 return $ DotRef () e' (var x)
70 Remove e x ->
71 do e' <- expression e
72 return $ obj "_U.remove" `call` [string x, e']
74 Insert e x v ->
75 do v' <- expression v
76 e' <- expression e
77 return $ obj "_U.insert" `call` [string x, v', e']
79 Modify e fs ->
80 do e' <- expression e
81 fs' <- forM fs $ \(f,v) -> do
82 v' <- expression v
83 return $ ArrayLit () [string f, v']
84 return $ obj "_U.replace" `call` [ArrayLit () fs', e']
86 Record fields ->
87 do fields' <- forM fields $ \(f,e) -> do
88 (,) f <$> expression e
89 let fieldMap = List.foldl' combine Map.empty fields'
90 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
91 where
92 combine r (k,v) = Map.insertWith (++) k [v] r
93 prop = PropId () . var
94 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
95 Map.toList . Map.filter (not . null) $ Map.map tail fs
96 visible fs = map (first prop) . Map.toList $ Map.map head fs
98 Binop op e1 e2 -> binop region op e1 e2
100 Lambda p e@(A ann _) ->
101 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
102 body' <- expression body
103 return $ case length args < 2 || length args > 9 of
104 True -> foldr (==>) body' (map (:[]) args)
105 False -> ref ("F" ++ show (length args)) <| (args ==> body')
106 where
107 depattern (args, body) pattern =
108 case pattern of
109 P.Var x -> return (args ++ [x], body)
110 _ -> do arg <- Case.newVar
111 return ( args ++ [arg]
112 , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))
114 (patterns, innerBody) = collect [p] e
116 collect patterns lexpr@(A _ expr) =
117 case expr of
118 Lambda p e -> collect (p:patterns) e
119 _ -> (patterns, lexpr)
121 App e1 e2 ->
122 do func' <- expression func
123 args' <- mapM expression args
124 return $ case args' of
125 [arg] -> func' <| arg
126 _ | length args' <= 9 -> ref aN `call` (func':args')
127 | otherwise -> foldl1 (<|) (func':args')
128 where
129 aN = "A" ++ show (length args)
130 (func, args) = getArgs e1 [e2]
131 getArgs func args =
132 case func of
133 (A _ (App f arg)) -> getArgs f (arg : args)
134 _ -> (func, args)
136 Let defs e ->
137 do let (defs',e') = flattenLets defs e
138 stmts <- concat <$> mapM definition defs'
139 exp <- expression e'
140 return $ function [] (stmts ++ [ ret exp ]) `call` []
142 MultiIf branches ->
143 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
144 return $ case last branches of
145 (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
146 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
147 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
148 where
149 safeIfs branches = ifs (init branches) (snd (last branches))
150 ifs branches finally = foldr iff finally branches
151 iff (if', then') else' = CondExpr () if' then' else'
153 Case e cases ->
154 do (tempVar,initialMatch) <- Case.toMatch cases
155 (revisedMatch, stmt) <-
156 case e of
157 A _ (Var (V.Raw x)) ->
158 return (Case.matchSubst [(tempVar,x)] initialMatch, [])
159 _ ->
160 do e' <- expression e
161 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
162 match' <- match region revisedMatch
163 return (function [] (stmt ++ match') `call` [])
165 ExplicitList es ->
166 do es' <- mapM expression es
167 return $ obj "_J.toList" <| ArrayLit () es'
169 Data name es ->
170 do es' <- mapM expression es
171 return $ ObjectLit () (ctor : fields es')
172 where
173 ctor = (prop "ctor", string name)
174 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
176 Markdown uid doc es ->
177 do es' <- mapM expression es
178 return $ obj "Text.markdown" `call` (string md : string uid : es')
179 where
180 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
181 md = pad ++ MD.toHtml doc ++ pad
183 PortIn name tipe ->
184 return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
186 PortOut name tipe value ->
187 do value' <- expression value
188 return $ obj "Native.Ports.portOut" `call`
189 [ string name, Port.outgoing tipe, value' ]
191definition :: Def -> State Int [Statement ()]
192definition (Definition pattern expr@(A region _) _) = do
193 expr' <- expression expr
194 let assign x = varDecl x expr'
195 case pattern of
196 P.Var x
197 | Help.isOp x ->
198 let op = LBracket () (ref "_op") (string x) in
199 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
200 | otherwise ->
201 return [ VarDeclStmt () [ assign x ] ]
203 P.Record fields ->
204 let setField f = varDecl f (dotSep ["$",f]) in
205 return [ VarDeclStmt () (assign "$" : map setField fields) ]
207 P.Data name patterns | vars /= Nothing ->
208 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
209 where
210 vars = getVars patterns
211 getVars patterns =
212 case patterns of
213 P.Var x : rest -> (x:) `fmap` getVars rest
214 [] -> Just []
215 _ -> Nothing
217 decl x n = varDecl x (dotSep ["$","_" ++ show n])
218 setup vars
219 | Help.isTuple name = assign "$" : vars
220 | otherwise = assign "$raw" : safeAssign : vars
222 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
223 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
224 exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
226 _ ->
227 do defs' <- concat <$> mapM toDef vars
228 return (VarDeclStmt () [assign "$"] : defs')
229 where
230 vars = P.boundVarList pattern
231 mkVar = A region . rawVar
232 toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
233 in definition $ Definition (P.Var y) expr Nothing
235match :: Region -> Case.Match -> State Int [Statement ()]
236match region mtch =
237 case mtch of
238 Case.Match name clauses mtch' ->
239 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
240 mtch'' <- match region mtch'
241 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
242 where
243 isLiteral p = case p of
244 Case.Clause (Right _) _ _ -> True
245 _ -> False
246 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
247 format isChars e
248 | or isChars = InfixExpr () OpAdd e (string "")
249 | otherwise = e
251 Case.Fail ->
252 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
254 Case.Break -> return [BreakStmt () Nothing]
255 Case.Other e ->
256 do e' <- expression e
257 return [ ret e' ]
258 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
259 where
260 dropEnd acc [] = acc
261 dropEnd acc (m:ms) =
262 case m of
263 Case.Other _ -> acc ++ [m]
264 _ -> dropEnd (acc ++ [m]) ms
266clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
267clause region variable (Case.Clause value vars mtch) =
268 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
269 where
270 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
271 (isChar, pattern) =
272 case value of
273 Right (Chr c) -> (True, string [c])
274 _ -> (,) False $ case value of
275 Right (Boolean b) -> BoolLit () b
276 Right lit -> literal lit
277 Left name -> string $ case List.elemIndices '.' name of
278 [] -> name
279 is -> drop (last is + 1) name
281flattenLets :: [Def] -> Expr -> ([Def], Expr)
282flattenLets defs lexpr@(A _ expr) =
283 case expr of
284 Let ds body -> flattenLets (defs ++ ds) body
285 _ -> (defs, lexpr)
287generate :: MetadataModule -> String
288generate unsafeModule =
289 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
290 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
291 where
292 modul = MakeSafe.metadataModule unsafeModule
293 thisModule = dotSep ("_elm" : names modul ++ ["values"])
294 programStmts =
295 concat
296 [ [ ExprStmt () $ string "use strict" ]
297 , setup (Just "_elm") (names modul ++ ["values"])
298 , [ IfSingleStmt () thisModule (ret thisModule) ]
299 , [ internalImports (List.intercalate "." (names modul)) ]
300 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
301 , [ assign ["_op"] (ObjectLit () []) ]
302 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
303 , [ jsExports ]
304 , [ ret thisModule ]
305 ]
307 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
308 where
309 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
310 entry x = (PropId () (var x), ref x)
312 assign path expr =
313 case path of
314 [x] -> VarDeclStmt () [ varDecl x expr ]
315 _ -> ExprStmt () $
316 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
318 jsImport modul = setup Nothing path ++ [ include ]
319 where
320 path = Help.splitDots modul
321 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
323 setup namespace path = map create paths
324 where
325 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
326 paths = case namespace of
327 Nothing -> tail . init $ List.inits path
328 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
330binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
331binop region op e1 e2 =
332 case op of
333 "Basics.." ->
334 do es <- mapM expression (e1 : collect [] e2)
335 return $ ["$"] ==> foldr (<|) (ref "$") es
336 "Basics.<|" ->
337 do e2' <- expression e2
338 es <- mapM expression (collect [] e1)
339 return $ foldr (<|) e2' es
340 "List.++" ->
341 do e1' <- expression e1
342 e2' <- expression e2
343 return $ obj "_L.append" `call` [e1', e2']
344 "::" -> expression (A region (Data "::" [e1,e2]))
345 _ ->
346 do e1' <- expression e1
347 e2' <- expression e2
348 return $ case Map.lookup op opDict of
349 Just f -> f e1' e2'
350 Nothing -> ref "A2" `call` [ func, e1', e2' ]
351 where
352 collect es e =
353 case e of
354 A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
355 _ -> es ++ [e]
357 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
358 | otherwise = dotSep parts
359 where
360 parts = Help.splitDots op
361 operator = last parts
363 opDict = Map.fromList (infixOps ++ specialOps)
365 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
366 infixOp str op = specialOp str (InfixExpr () op)
368 infixOps = concat
369 [ infixOp "+" OpAdd
370 , infixOp "-" OpSub
371 , infixOp "*" OpMul
372 , infixOp "/" OpDiv
373 , infixOp "&&" OpLAnd
374 , infixOp "||" OpLOr
375 ]
377 specialOps = concat
378 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
379 , specialOp "|>" $ flip (<|)
380 , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
381 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
382 , specialOp "<" $ cmp OpLT 0
383 , specialOp ">" $ cmp OpGT 0
384 , specialOp "<=" $ cmp OpLT 1
385 , specialOp ">=" $ cmp OpGT (-1)
386 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
387 ]
389 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)