git.iko.soy/elk
on da033e3 help sign in
elk/compiler/Generate/JavaScript.hs
400 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 qualified Generate.Cases as Case
12import qualified Generate.Markdown as MD
13import qualified SourceSyntax.Helpers as Help
14import SourceSyntax.Literal
15import SourceSyntax.Pattern as Pattern
16import SourceSyntax.Location
17import SourceSyntax.Expression
18import SourceSyntax.Module
19import Language.ECMAScript3.Syntax
20import Language.ECMAScript3.PrettyPrint
21import qualified Transform.SafeNames as MakeSafe
23split :: String -> [String]
24split = go []
25 where
26 go vars str =
27 case break (=='.') str of
28 (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
29 | otherwise -> go (vars ++ [x]) rest
30 (x,[]) -> vars ++ [x]
32var name = Id () name
33ref name = VarRef () (var name)
34prop name = PropId () (var name)
35f <| x = CallExpr () f [x]
36args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
37function args stmts = FuncExpr () Nothing (map var args) stmts
38call = CallExpr ()
39string = StringLit ()
41dotSep vars =
42 case vars of
43 x:xs -> foldl (DotRef ()) (ref x) (map var xs)
44 [] -> error "dotSep must be called on a non-empty list of variables"
46obj = dotSep . split
48varDecl :: String -> Expression () -> VarDecl ()
49varDecl x expr =
50 VarDecl () (var x) (Just expr)
52include alias moduleName =
53 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
55internalImports name =
56 VarDeclStmt ()
57 [ varDecl "_N" (obj "Elm.Native")
58 , include "_U" "_N.Utils"
59 , include "_L" "_N.List"
60 , include "_E" "_N.Error"
61 , include "_J" "_N.JavaScript"
62 , varDecl "$moduleName" (string name)
63 ]
65literal :: Literal -> Expression ()
66literal lit =
67 case lit of
68 Chr c -> obj "_U.chr" <| string [c]
69 Str s -> string s
70 IntNum n -> IntLit () n
71 FloatNum n -> NumLit () n
72 Boolean b -> BoolLit () b
74expression :: LExpr -> State Int (Expression ())
75expression (L span expr) =
76 case expr of
77 Var x -> return $ ref x
78 Literal lit -> return $ literal lit
80 Range lo hi ->
81 do lo' <- expression lo
82 hi' <- expression hi
83 return $ obj "_L.range" `call` [lo',hi']
85 Access e x ->
86 do e' <- expression e
87 return $ DotRef () e' (var x)
89 Remove e x ->
90 do e' <- expression e
91 return $ obj "_U.remove" `call` [string x, e']
93 Insert e x v ->
94 do v' <- expression v
95 e' <- expression e
96 return $ obj "_U.insert" `call` [string x, v', e']
98 Modify e fs ->
99 do e' <- expression e
100 fs' <- forM fs $ \(f,v) -> do
101 v' <- expression v
102 return $ ArrayLit () [string f, v']
103 return $ obj "_U.replace" `call` [ArrayLit () fs', e']
105 Record fields ->
106 do fields' <- forM fields $ \(f,e) -> do
107 (,) f <$> expression e
108 let fieldMap = List.foldl' combine Map.empty fields'
109 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
110 where
111 combine r (k,v) = Map.insertWith (++) k [v] r
112 prop = PropId () . var
113 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
114 Map.toList . Map.filter (not . null) $ Map.map tail fs
115 visible fs = map (first prop) . Map.toList $ Map.map head fs
117 Binop op e1 e2 -> binop span op e1 e2
119 Lambda p e@(L s _) ->
120 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
121 body' <- expression body
122 return $ case length args < 2 || length args > 9 of
123 True -> foldr (==>) body' (map (:[]) args)
124 False -> ref ("F" ++ show (length args)) <| (args ==> body')
125 where
126 depattern (args, body) pattern =
127 case pattern of
128 PVar x -> return (args ++ [x], body)
129 _ -> do arg <- Case.newVar
130 return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
132 (patterns, innerBody) = collect [p] e
134 collect patterns lexpr@(L _ expr) =
135 case expr of
136 Lambda p e -> collect (p:patterns) e
137 _ -> (patterns, lexpr)
139 App e1 e2 ->
140 do func' <- expression func
141 args' <- mapM expression args
142 return $ case args' of
143 [arg] -> func' <| arg
144 _ | length args' <= 9 -> ref aN `call` (func':args')
145 | otherwise -> foldl1 (<|) (func':args')
146 where
147 aN = "A" ++ show (length args)
148 (func, args) = getArgs e1 [e2]
149 getArgs func args =
150 case func of
151 (L _ (App f arg)) -> getArgs f (arg : args)
152 _ -> (func, args)
154 Let defs e ->
155 do let (defs',e') = flattenLets defs e
156 stmts <- concat <$> mapM definition defs'
157 exp <- expression e'
158 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
160 MultiIf branches ->
161 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
162 return $ case last branches of
163 (L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
164 (L _ (Literal (Boolean True)), _) -> safeIfs branches'
165 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
166 where
167 safeIfs branches = ifs (init branches) (snd (last branches))
168 ifs branches finally = foldr iff finally branches
169 iff (if', then') else' = CondExpr () if' then' else'
171 Case e cases ->
172 do (tempVar,initialMatch) <- Case.toMatch cases
173 (revisedMatch, stmt) <-
174 case e of
175 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
176 _ -> do e' <- expression e
177 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
178 match' <- match span revisedMatch
179 return (function [] (stmt ++ match') `call` [])
181 ExplicitList es ->
182 do es' <- mapM expression es
183 return $ obj "_J.toList" <| 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 _ _ handler ->
200 do handler' <- expression handler
201 return $ obj "Native.Ports.portIn" `call` [ string name, handler' ]
203 PortOut name _ signal ->
204 do signal' <- expression signal
205 return $ obj "Native.Ports.portOut" `call` [ string name, signal' ]
207definition :: Def -> State Int [Statement ()]
208definition (Definition pattern expr@(L span _) _) = do
209 expr' <- expression expr
210 let assign x = varDecl x expr'
211 case pattern of
212 PVar 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 PRecord fields ->
220 let setField f = varDecl f (dotSep ["$",f]) in
221 return [ VarDeclStmt () (assign "$" : map setField fields) ]
223 PData 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 PVar 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 (show span)]
242 _ ->
243 do defs' <- concat <$> mapM toDef vars
244 return (VarDeclStmt () [assign "$"] : defs')
245 where
246 vars = Set.toList $ Pattern.boundVars pattern
247 mkVar = L span . Var
248 toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
249 in definition $ Definition (PVar y) expr Nothing
251match :: (Show a) => a -> Case.Match -> State Int [Statement ()]
252match span mtch =
253 case mtch of
254 Case.Match name clauses mtch' ->
255 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
256 mtch'' <- match span 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
262 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
263 format isChars e
264 | or isChars = InfixExpr () OpAdd e (string "")
265 | otherwise = e
267 Case.Fail ->
268 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
270 Case.Break -> return [BreakStmt () Nothing]
271 Case.Other e ->
272 do e' <- expression e
273 return [ ReturnStmt () (Just e') ]
274 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
275 where
276 dropEnd acc [] = acc
277 dropEnd acc (m:ms) =
278 case m of
279 Case.Other _ -> acc ++ [m]
280 _ -> dropEnd (acc ++ [m]) ms
282clause span variable (Case.Clause value vars mtch) =
283 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
284 where
285 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
286 (isChar, pattern) =
287 case value of
288 Right (Chr c) -> (True, string [c])
289 _ -> (,) False $ case value of
290 Right (Boolean b) -> BoolLit () b
291 Right lit -> literal lit
292 Left name -> string $ case List.elemIndices '.' name of
293 [] -> name
294 is -> drop (last is + 1) name
296flattenLets defs lexpr@(L _ expr) =
297 case expr of
298 Let ds body -> flattenLets (defs ++ ds) body
299 _ -> (defs, lexpr)
301generate :: MetadataModule -> String
302generate unsafeModule =
303 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
304 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
305 where
306 modul = MakeSafe.metadataModule unsafeModule
307 thisModule = dotSep ("_elm" : names modul ++ ["values"])
308 programStmts =
309 concat [ setup (Just "_elm") (names modul ++ ["values"])
310 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
311 , [ internalImports (List.intercalate "." (names modul)) ]
312 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
313 , [ assign ["_op"] (ObjectLit () []) ]
314 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
315 , [ jsExports ]
316 , [ ReturnStmt () (Just thisModule) ]
317 ]
319 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
320 where
321 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
322 entry x = (PropId () (var x), ref x)
324 assign path expr =
325 case path of
326 [x] -> VarDeclStmt () [ varDecl x expr ]
327 _ -> ExprStmt () $
328 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
330 jsImport modul = setup Nothing path ++ [ include ]
331 where
332 path = split modul
333 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
335 setup namespace path = map create paths
336 where
337 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
338 paths = case namespace of
339 Nothing -> tail . init $ List.inits path
340 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
342binop span op e1 e2 =
343 case op of
344 "Basics.." ->
345 do es <- mapM expression (e1 : collect [] e2)
346 return $ ["$"] ==> foldr (<|) (ref "$") es
347 "Basics.<|" ->
348 do e2' <- expression e2
349 es <- mapM expression (collect [] e1)
350 return $ foldr (<|) e2' es
351 "List.++" ->
352 do e1' <- expression e1
353 e2' <- expression e2
354 return $ obj "_L.append" `call` [e1', e2']
355 "::" -> expression (L span (Data "::" [e1,e2]))
356 _ ->
357 do e1' <- expression e1
358 e2' <- expression e2
359 return $ case Map.lookup op opDict of
360 Just f -> f e1' e2'
361 Nothing -> ref "A2" `call` [ func, e1', e2' ]
362 where
363 collect es e =
364 case e of
365 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
366 _ -> es ++ [e]
368 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
369 | otherwise = dotSep parts
370 where
371 parts = split op
372 operator = last parts
374 opDict = Map.fromList (infixOps ++ specialOps)
376 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
377 infixOp str op = specialOp str (InfixExpr () op)
379 infixOps = concat
380 [ infixOp "+" OpAdd
381 , infixOp "-" OpSub
382 , infixOp "*" OpMul
383 , infixOp "/" OpDiv
384 , infixOp "&&" OpLAnd
385 , infixOp "||" OpLOr
386 ]
388 specialOps = concat
389 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
390 , specialOp "|>" $ flip (<|)
391 , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
392 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
393 , specialOp "<" $ cmp OpLT 0
394 , specialOp ">" $ cmp OpGT 0
395 , specialOp "<=" $ cmp OpLT 1
396 , specialOp ">=" $ cmp OpGT (-1)
397 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
398 ]
400 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)