git.iko.soy/elk
on 5ea3ec7 help sign in
elk/compiler/Generate/JavaScript.hs
401 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
310 [ setup (Just "_elm") (names modul ++ ["values"])
311 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
312 , [ internalImports (List.intercalate "." (names modul)) ]
313 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
314 , [ assign ["_op"] (ObjectLit () []) ]
315 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
316 , [ jsExports ]
317 , [ ReturnStmt () (Just thisModule) ]
318 ]
320 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
321 where
322 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
323 entry x = (PropId () (var x), ref x)
325 assign path expr =
326 case path of
327 [x] -> VarDeclStmt () [ varDecl x expr ]
328 _ -> ExprStmt () $
329 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
331 jsImport modul = setup Nothing path ++ [ include ]
332 where
333 path = split modul
334 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
336 setup namespace path = map create paths
337 where
338 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
339 paths = case namespace of
340 Nothing -> tail . init $ List.inits path
341 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
343binop span op e1 e2 =
344 case op of
345 "Basics.." ->
346 do es <- mapM expression (e1 : collect [] e2)
347 return $ ["$"] ==> foldr (<|) (ref "$") es
348 "Basics.<|" ->
349 do e2' <- expression e2
350 es <- mapM expression (collect [] e1)
351 return $ foldr (<|) e2' es
352 "List.++" ->
353 do e1' <- expression e1
354 e2' <- expression e2
355 return $ obj "_L.append" `call` [e1', e2']
356 "::" -> expression (L span (Data "::" [e1,e2]))
357 _ ->
358 do e1' <- expression e1
359 e2' <- expression e2
360 return $ case Map.lookup op opDict of
361 Just f -> f e1' e2'
362 Nothing -> ref "A2" `call` [ func, e1', e2' ]
363 where
364 collect es e =
365 case e of
366 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
367 _ -> es ++ [e]
369 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
370 | otherwise = dotSep parts
371 where
372 parts = split op
373 operator = last parts
375 opDict = Map.fromList (infixOps ++ specialOps)
377 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
378 infixOp str op = specialOp str (InfixExpr () op)
380 infixOps = concat
381 [ infixOp "+" OpAdd
382 , infixOp "-" OpSub
383 , infixOp "*" OpMul
384 , infixOp "/" OpDiv
385 , infixOp "&&" OpLAnd
386 , infixOp "||" OpLOr
387 ]
389 specialOps = concat
390 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
391 , specialOp "|>" $ flip (<|)
392 , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
393 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
394 , specialOp "<" $ cmp OpLT 0
395 , specialOp ">" $ cmp OpGT 0
396 , specialOp "<=" $ cmp OpLT 1
397 , specialOp ">=" $ cmp OpGT (-1)
398 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
399 ]
401 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)