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