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