git.iko.soy/elk
on 15d87f2 help sign in
elk/compiler/Generate/JavaScript.hs
392 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 $ obj 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 () $ (prop "_", hidden fieldMap) : visible fieldMap
91 where
92 combine r (k,v) = Map.insertWith (++) k [v] r
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 region op e1 e2
99 Lambda p e@(A ann _) ->
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 P.Var x -> return (args ++ [x], body)
109 _ -> do arg <- Case.newVar
110 return ( args ++ [arg]
111 , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))
113 (patterns, innerBody) = collect [p] e
115 collect patterns lexpr@(A _ expr) =
116 case expr of
117 Lambda p e -> collect (p:patterns) e
118 _ -> (patterns, lexpr)
120 App e1 e2 ->
121 do func' <- expression func
122 args' <- mapM expression args
123 return $ case args' of
124 [arg] -> func' <| arg
125 _ | length args' <= 9 -> ref aN `call` (func':args')
126 | otherwise -> foldl1 (<|) (func':args')
127 where
128 aN = "A" ++ show (length args)
129 (func, args) = getArgs e1 [e2]
130 getArgs func args =
131 case func of
132 (A _ (App f arg)) -> getArgs f (arg : args)
133 _ -> (func, args)
135 Let defs e ->
136 do let (defs',e') = flattenLets defs e
137 stmts <- concat <$> mapM definition defs'
138 exp <- expression e'
139 return $ function [] (stmts ++ [ ret exp ]) `call` []
141 MultiIf branches ->
142 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
143 return $ case last branches of
144 (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
145 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
146 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
147 where
148 safeIfs branches = ifs (init branches) (snd (last branches))
149 ifs branches finally = foldr iff finally branches
150 iff (if', then') else' = CondExpr () if' then' else'
152 Case e cases ->
153 do (tempVar,initialMatch) <- Case.toMatch cases
154 (revisedMatch, stmt) <-
155 case e of
156 A _ (Var (V.Raw x)) ->
157 return (Case.matchSubst [(tempVar,x)] initialMatch, [])
158 _ ->
159 do e' <- expression e
160 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
161 match' <- match region revisedMatch
162 return (function [] (stmt ++ match') `call` [])
164 ExplicitList es ->
165 do es' <- mapM expression es
166 return $ obj "_J.toList" <| ArrayLit () es'
168 Data name es ->
169 do es' <- mapM expression es
170 return $ ObjectLit () (ctor : fields es')
171 where
172 ctor = (prop "ctor", string name)
173 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
175 Markdown uid doc es ->
176 do es' <- mapM expression es
177 return $ obj "Text.markdown" `call` (string md : string uid : es')
178 where
179 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
180 md = pad ++ MD.toHtml doc ++ pad
182 PortIn name tipe ->
183 return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
185 PortOut name tipe value ->
186 do value' <- expression value
187 return $ obj "Native.Ports.portOut" `call`
188 [ string name, Port.outgoing tipe, value' ]
190definition :: Def -> State Int [Statement ()]
191definition (Definition pattern expr@(A region _) _) = do
192 expr' <- expression expr
193 let assign x = varDecl x expr'
194 case pattern of
195 P.Var x
196 | Help.isOp x ->
197 let op = LBracket () (ref "_op") (string x) in
198 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
199 | otherwise ->
200 return [ VarDeclStmt () [ assign x ] ]
202 P.Record fields ->
203 let setField f = varDecl f (dotSep ["$",f]) in
204 return [ VarDeclStmt () (assign "$" : map setField fields) ]
206 P.Data name patterns | vars /= Nothing ->
207 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
208 where
209 vars = getVars patterns
210 getVars patterns =
211 case patterns of
212 P.Var x : rest -> (x:) `fmap` getVars rest
213 [] -> Just []
214 _ -> Nothing
216 decl x n = varDecl x (dotSep ["$","_" ++ show n])
217 setup vars
218 | Help.isTuple name = assign "$" : vars
219 | otherwise = assign "$raw" : safeAssign : vars
221 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
222 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
223 exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
225 _ ->
226 do defs' <- concat <$> mapM toDef vars
227 return (VarDeclStmt () [assign "$"] : defs')
228 where
229 vars = P.boundVarList pattern
230 mkVar = A region . rawVar
231 toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
232 in definition $ Definition (P.Var y) expr Nothing
234match :: Region -> Case.Match -> State Int [Statement ()]
235match region mtch =
236 case mtch of
237 Case.Match name clauses mtch' ->
238 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
239 mtch'' <- match region mtch'
240 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
241 where
242 isLiteral p = case p of
243 Case.Clause (Right _) _ _ -> True
244 _ -> False
246 access name
247 | any isLiteral clauses = obj name
248 | otherwise = dotSep (split name ++ ["ctor"])
250 format isChars e
251 | or isChars = InfixExpr () OpAdd e (string "")
252 | otherwise = e
254 Case.Fail ->
255 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
257 Case.Break -> return [BreakStmt () Nothing]
258 Case.Other e ->
259 do e' <- expression e
260 return [ ret e' ]
261 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
262 where
263 dropEnd acc [] = acc
264 dropEnd acc (m:ms) =
265 case m of
266 Case.Other _ -> acc ++ [m]
267 _ -> dropEnd (acc ++ [m]) ms
269clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
270clause region variable (Case.Clause value vars mtch) =
271 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
272 where
273 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
274 (isChar, pattern) =
275 case value of
276 Right (Chr c) -> (True, string [c])
277 _ -> (,) False $ case value of
278 Right (Boolean b) -> BoolLit () b
279 Right lit -> literal lit
280 Left name -> string $ case List.elemIndices '.' name of
281 [] -> name
282 is -> drop (last is + 1) name
284flattenLets :: [Def] -> Expr -> ([Def], Expr)
285flattenLets defs lexpr@(A _ expr) =
286 case expr of
287 Let ds body -> flattenLets (defs ++ ds) body
288 _ -> (defs, lexpr)
290generate :: MetadataModule -> String
291generate unsafeModule =
292 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
293 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
294 where
295 modul = MakeSafe.metadataModule unsafeModule
296 thisModule = dotSep ("_elm" : names modul ++ ["values"])
297 programStmts =
298 concat
299 [ [ ExprStmt () $ string "use strict" ]
300 , setup (Just "_elm") (names modul ++ ["values"])
301 , [ IfSingleStmt () thisModule (ret thisModule) ]
302 , [ internalImports (List.intercalate "." (names modul)) ]
303 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
304 , [ assign ["_op"] (ObjectLit () []) ]
305 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
306 , [ jsExports ]
307 , [ ret thisModule ]
308 ]
310 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
311 where
312 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
313 entry x = (prop x, ref x)
315 assign path expr =
316 case path of
317 [x] -> VarDeclStmt () [ varDecl x expr ]
318 _ -> ExprStmt () $
319 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
321 jsImport modul = setup Nothing path ++ [ include ]
322 where
323 path = Help.splitDots modul
324 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
326 setup namespace path = map create paths
327 where
328 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
329 paths = case namespace of
330 Nothing -> tail . init $ List.inits path
331 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
333binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
334binop region op e1 e2 =
335 case op of
336 "Basics.." ->
337 do es <- mapM expression (e1 : collect [] e2)
338 return $ ["$"] ==> foldr (<|) (ref "$") es
339 "Basics.<|" ->
340 do e2' <- expression e2
341 es <- mapM expression (collect [] e1)
342 return $ foldr (<|) e2' es
343 "List.++" ->
344 do e1' <- expression e1
345 e2' <- expression e2
346 return $ obj "_L.append" `call` [e1', e2']
347 "::" -> expression (A region (Data "::" [e1,e2]))
348 _ ->
349 do e1' <- expression e1
350 e2' <- expression e2
351 return $ case Map.lookup op opDict of
352 Just f -> f e1' e2'
353 Nothing -> ref "A2" `call` [ func, e1', e2' ]
354 where
355 collect es e =
356 case e of
357 A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
358 _ -> es ++ [e]
360 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
361 | otherwise = dotSep parts
362 where
363 parts = Help.splitDots op
364 operator = last parts
366 opDict = Map.fromList (infixOps ++ specialOps)
368 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
369 infixOp str op = specialOp str (InfixExpr () op)
371 infixOps = concat
372 [ infixOp "+" OpAdd
373 , infixOp "-" OpSub
374 , infixOp "*" OpMul
375 , infixOp "/" OpDiv
376 , infixOp "&&" OpLAnd
377 , infixOp "||" OpLOr
378 ]
380 specialOps = concat
381 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
382 , specialOp "|>" $ flip (<|)
383 , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
384 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
385 , specialOp "<" $ cmp OpLT 0
386 , specialOp ">" $ cmp OpGT 0
387 , specialOp "<=" $ cmp OpLT 1
388 , specialOp ">=" $ cmp OpGT (-1)
389 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
390 ]
392 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)