@@ -3,7 +3,7 @@ module Generate.JavaScript (showErr, jsModule) where
33import Control.Arrow (first,second)
44import Control.Monad (liftM,(<=<),join,ap)
55import Data.Char (isAlpha,isDigit)
6−import Data.List (intercalate,sortBy,inits,foldl')
6+import Data.List (intercalate,inits,foldl')
77import qualified Data.Map as Map
88import qualified Data.Set as Set
99import Data.Either (partitionEithers)
@@ -13,7 +13,7 @@ import Unique
1313import Generate.Cases
1414import SourceSyntax.Everything hiding (parens)
1515import SourceSyntax.Location as Loc
16−import Transform.SortDefinitions
16+import qualified Transform.SortDefinitions as SD
1717
1818showErr :: String -> String
1919showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
@@ -52,49 +52,50 @@ quoted s = "'" ++ concatMap f s ++ "'"
5252globalAssign n e = "\n" ++ assign' n e ++ ";"
5353assign' n e = n ++ " = " ++ e
5454
55−jsModule (Module names exports imports stmts) =
56− setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
55+jsModule :: MetadataModule t v -> String
56+jsModule modul =
57+ run $ do
58+ body <- toJS (defs modul)
59+ foreignImport <- mapM importEvent (foreignImports modul)
60+ return $ concat [ setup ("Elm": names modul)
61+ , globalAssign ("Elm." ++ modName)
62+ (jsFunc "elm" $ program body foreignImport) ]
5763 where
58− modNames = if null names then ["Main"] else names
59− modName = intercalate "." modNames
60− includes = concatMap jsImport imports
61− body = stmtsToJS stmts
62− defs = assign "$op" "{}"
63− program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
64− setup ("elm":"Native":modNames) ++
65− assign "_" ("elm.Native." ++ modName ++ "||{}") ++
66− getExports exports stmts ++ setup ("elm":modNames) ++
67− ret (assign' ("elm." ++ modName) "_") ++ "\n"
68− setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
69− map (intercalate ".") . drop 2 . inits $ init modNames
64+ modName = intercalate "." (names modul)
65+ program body foreignImport =
66+ concat [ "\nvar " ++ usefulFuncs ++ ";"
67+ , assign "_op" "{}"
68+ , concatMap jsImport (imports modul)
69+ , concat foreignImport
70+ , concatMap exportEvent $ foreignExports modul
71+ , body
72+ , setup ("elm" : "Native" : names modul)
73+ , assign "_" ("elm.Native." ++ modName ++ "||{}")
74+ , concatMap jsExport (exports modul)
75+ , setup ("elm" : names modul)
76+ , ret (assign' ("elm." ++ modName) "_")
77+ ]
78+ setup names = concatMap (\n -> globalAssign n $ n ++ "||{}") .
79+ map (intercalate ".") . drop 2 . inits $ init names
7080 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
7181
72−getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
73− where exNames n = either derename id n `elem` names
74− exports | null names = concatMap get stmts
75− | otherwise = filter exNames (concatMap get stmts)
76−
77− (fns,ops) = partitionEithers exports
78−
79− opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
80− fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
81−
82− op = ("_.$op = "++) . jsObj $ map opPair ops
83−
84− get' def =
85− case def of
86− TypeAnnotation _ _ -> []
87− Def pattern _ ->
88− case Set.toList (boundVars pattern) of
89− [var@(c:_)] -> [if isOp c then Right var else Left var]
90− vars -> map Left vars
91−
92− get s = case s of Definition def -> get' def
93− Datatype _ _ tcs -> map (Left . fst) tcs
94− ImportEvent _ _ x _ -> [ Left x ]
95− ExportEvent _ _ _ -> []
96− TypeAlias _ _ _ -> []
82+ jsExport x =
83+ if isOp x then "\n_._op['" ++ x ++ "'] = _op['" ++ x ++ "'];"
84+ else "\n_." ++ derename x ++ " = " ++ x ++ ";"
85+
86+ importEvent (js,base,elm,_) =
87+ do v <- toJS' base
88+ return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
89+ , "\ndocument.addEventListener('", js
90+ , "_' + elm.id, function(e) { elm.notify(", elm
91+ , ".id, e.value); });" ]
9792
93+ exportEvent (js,elm,_) =
94+ concat [ "\nlift(function(v) { "
95+ , "var e = document.createEvent('Event');"
96+ , "e.initEvent('", js, "_' + elm.id, true, true);"
97+ , "e.value = v;"
98+ , "document.dispatchEvent(e); return v; })(", elm, ");" ]
9899
99100jsImport (modul, how) =
100101 case how of
@@ -105,7 +106,7 @@ jsImport (modul, how) =
105106 Importing vs -> include ++ named
106107 where
107108 imprt v = assign' v ("_." ++ v)
108− def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
109+ def x = imprt $ if isOp x then "_op['" ++ x ++ "']" else deprime x
109110 named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
110111 where
111112 include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
@@ -122,69 +123,31 @@ jsImport (modul, how) =
122123 [] -> (reverse name, [])
123124
124125
125−
126−stmtsToJS :: [Declaration t v] -> String
127−stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
128− return (concat program)
129− where
130− cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
131− valueOf s = case s of
132− Datatype _ _ _ -> 1
133− ImportEvent _ _ _ _ -> 2
134− Definition (Def f (L _ _ (Lambda _ _))) -> 3
135− Definition (Def (PVar name) _) ->
136− if derename name == "main" then 5 else 4
137− Definition (Def _ _) -> 4
138− Definition (TypeAnnotation _ _) -> 0
139− ExportEvent _ _ _ -> 6
140− TypeAlias _ _ _ -> 0
141−
142126class ToJS a where
143127 toJS :: a -> Unique String
144128
129+
145130instance ToJS (Def t v) where
146131
147132 -- TODO: Make this handle patterns besides plain variables
133+ toJS (Def (PVar x) e)
134+ | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
135+ | otherwise = assign x `liftM` toJS' e
136+
137+ toJS (Def pattern e) =
138+ do n <- guid
139+ let x = "_" ++ show n
140+ var = Loc.none . Var
141+ toDef y = Def (PVar y) (Loc.none $ Case (var x) [(pattern, var y)])
142+ stmt <- assign x `liftM` toJS' e
143+ vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
144+ return (stmt ++ vars)
148145
149− toJS (Def (PVar x) e) = assign x `liftM` toJS' e
150−{--
151− toJS (Def f e) = (assign f . wrapper . func) `liftM` toJS' e
152− where
153− func body = jsFunc (intercalate ", " as) (ret body)
154− wrapper e | length as == 1 = e
155− | otherwise = 'F' : show (length as) ++ parens e
156− toJS (OpDef op a1 a2 e) =
157− do body <- toJS' e
158− let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
159− return (globalAssign ("$op['" ++ op ++ "']") func)
160−--}
161146 toJS (TypeAnnotation _ _) = return ""
162147
163148
164−instance ToJS (Declaration t v) where
165− toJS stmt =
166− case stmt of
167− Definition d -> toJS d
168− Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
169− where toDef (name,args) =
170− let vars = map (('a':) . show) [1..length args]
171− body = Loc.none (Data (derename name) (map (Loc.none . Var) vars))
172− func = foldr (\x e -> Loc.none (Lambda (PVar x) e)) body vars
173− in Definition $ Def (PVar name) func
174−
175− ImportEvent js base elm _ ->
176− do v <- toJS' base
177− return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
178− , "\ndocument.addEventListener('", js
179− , "_' + elm.id, function(e) { elm.notify(", elm
180− , ".id, e.value); });" ]
181− ExportEvent js elm _ ->
182− return $ concat [ "\nlift(function(v) { "
183− , "var e = document.createEvent('Event');"
184− , "e.initEvent('", js, "_' + elm.id, true, true);"
185− , "e.value = v;"
186− , "document.dispatchEvent(e); return v; })(", elm, ");" ]
187− TypeAlias n _ t -> return ""
149+instance ToJS a => ToJS [a] where
150+ toJS xs = concat `liftM` mapM toJS xs
188151
189152toJS' :: LExpr t v -> Unique String
190153toJS' (L txt span expr) =
@@ -254,7 +217,7 @@ instance ToJS (Expr t v) where
254217 _ -> (patterns, lexpr)
255218
256219 App e1 e2 -> jsApp e1 e2
257− Let defs e -> jsLet defs e
220+ Let defs e -> jsLet $ SD.flattenLets defs e
258221
259222 ExplicitList es ->
260223 do es' <- mapM toJS' es
@@ -302,15 +265,9 @@ multiIfToJS span ps =
302265 e' <- toJS' e
303266 return (b' ++ " ? " ++ e')
304267
305−jsLet defs e' = do ds <- jsDefs defs
306− e <- toJS' e'
307− return $ jsFunc "" (concat ds ++ ret e) ++ "()"
308− where
309− jsDefs defs = mapM toJS (sortBy f defs)
310− f a b = compare (valueOf a) (valueOf b)
311− valueOf (Def _ (L _ _ (Lambda _ _))) = 1
312− valueOf (Def _ _) = 2
313− valueOf (TypeAnnotation _ _) = 0
268+jsLet (defs,e') = do ds <- mapM toJS defs
269+ e <- toJS' e'
270+ return $ jsFunc "" (concat ds ++ ret e) ++ "()"
314271
315272caseToJS span e ps = do
316273 match <- caseToMatch ps
@@ -379,5 +336,5 @@ binop (o:p) e1 e2
379336 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
380337 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
381338 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
382− | otherwise -> concat [ "$op['", o:p, "']"
339+ | otherwise -> concat [ "_op['", o:p, "']"
383340 , parens e1, parens e2 ]