module Generate.JavaScript (showErr, jsModule) where
import Control.Arrow (first,second)
import Control.Monad (liftM,(<=<),join,ap)
import Data.Char (isAlpha,isDigit)
import Data.List (intercalate,inits,foldl')
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Either (partitionEithers)
import qualified Text.Pandoc as Pan
import Unique
import Generate.Cases
import SourceSyntax.Everything hiding (parens)
import SourceSyntax.Location as Loc
import qualified Transform.SortDefinitions as SD
showErr :: String -> String
showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
where msg = show . concatMap (++"
") . lines $ err
body = "var T = Elm.Text(elm);\n\
\return { main : T.text(T.monospace(" ++ msg ++ ")) };"
indent = concatMap f
where f '\n' = "\n "
f c = [c]
internalImports =
[ ("N" , "Elm.Native"),
("_N", "N.Utils(elm)"),
("_L", "N.List(elm)"),
("_E", "N.Error(elm)"),
("_J", "N.JavaScript(elm)"),
("_str", "_J.toString")
]
parens s = "(" ++ s ++ ")"
brackets s = "{" ++ s ++ "}"
jsObj = brackets . intercalate ", "
jsList ss = "["++ intercalate "," ss ++"]"
jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
ret e = "\nreturn "++ e ++";"
quoted s = "'" ++ concatMap f s ++ "'"
where f '\n' = "\\n"
f '\'' = "\\'"
f '\t' = "\\t"
f '\"' = "\\\""
f '\\' = "\\\\"
f c = [c]
globalAssign n e = "\n" ++ assign' n e ++ ";"
assign' n e = n ++ " = " ++ e
jsModule :: MetadataModule t v -> String
jsModule modul =
run $ do
body <- toJS (defs modul)
foreignImport <- mapM importEvent (foreignImports modul)
return $ concat [ setup ("Elm": names modul)
, globalAssign ("Elm." ++ modName)
(jsFunc "elm" $ program body foreignImport) ]
where
modName = intercalate "." (names modul)
program body foreignImport =
concat [ "\nvar " ++ usefulFuncs ++ ";"
, assign "_op" "{}"
, concatMap jsImport (imports modul)
, concat foreignImport
, concatMap exportEvent $ foreignExports modul
, body
, setup ("elm" : "Native" : names modul)
, assign "_" ("elm.Native." ++ modName ++ "||{}")
, concatMap jsExport (exports modul)
, setup ("elm" : names modul)
, ret (assign' ("elm." ++ modName) "_")
]
setup names = concatMap (\n -> globalAssign n $ n ++ "||{}") .
map (intercalate ".") . drop 2 . inits $ init names
usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
jsExport x =
if isOp x then "\n_._op['" ++ x ++ "'] = _op['" ++ x ++ "'];"
else "\n_." ++ derename x ++ " = " ++ x ++ ";"
importEvent (js,base,elm,_) =
do v <- toJS' base
return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
, "\ndocument.addEventListener('", js
, "_' + elm.id, function(e) { elm.notify(", elm
, ".id, e.value); });" ]
exportEvent (js,elm,_) =
concat [ "\nlift(function(v) { "
, "var e = document.createEvent('Event');"
, "e.initEvent('", js, "_' + elm.id, true, true);"
, "e.value = v;"
, "document.dispatchEvent(e); return v; })(", elm, ");" ]
jsImport (modul, how) =
case how of
As name -> assign name ("Elm." ++ modul ++ parens "elm")
Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
"; for(var k in _){if(k in hiding)continue;" ++
"eval('var '+k+'=_[\"'+k+'\"]')}"
Importing vs -> include ++ named
where
imprt v = assign' v ("_." ++ v)
def x = imprt $ if isOp x then "_op['" ++ x ++ "']" else deprime x
named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
where
include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
where
defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
subnames = map (intercalate ".") . tail . inits . init . split
split names = case go [] names of
(name, []) -> [name]
(name, ns) -> name : split ns
go name str = case str of
'.':rest -> (reverse name, rest)
c:rest -> go (c:name) rest
[] -> (reverse name, [])
class ToJS a where
toJS :: a -> Unique String
instance ToJS (Def t v) where
-- TODO: Make this handle patterns besides plain variables
toJS (Def (PVar x) e)
| isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
| otherwise = assign x `liftM` toJS' e
toJS (Def pattern e) =
do n <- guid
let x = "_" ++ show n
var = Loc.none . Var
toDef y = Def (PVar y) (Loc.none $ Case (var x) [(pattern, var y)])
stmt <- assign x `liftM` toJS' e
vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
return (stmt ++ vars)
toJS (TypeAnnotation _ _) = return ""
instance ToJS a => ToJS [a] where
toJS xs = concat `liftM` mapM toJS xs
toJS' :: LExpr t v -> Unique String
toJS' (L txt span expr) =
case expr of
MultiIf ps -> multiIfToJS span ps
Case e cases -> caseToJS span e cases
_ -> toJS expr
remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
access x e = e ++ "." ++ x
makeRecord kvs = record `liftM` collect kvs
where
combine r (k,v) = Map.insertWith (++) k v r
collect = liftM (foldl' combine Map.empty) . mapM prep
prep (k, e) =
do v <- toJS' e
return (k,[v])
fields fs =
brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
hidden = fields . map (second jsList) .
filter (not . null . snd) . Map.toList . Map.map tail
record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
instance ToJS Literal where
toJS lit =
case lit of
Chr c -> return $ quoted [c]
Str s -> return $ "_str" ++ parens (quoted s)
IntNum n -> return $ show n
FloatNum n -> return $ show n
Boolean b -> return $ if b then "true" else "false"
instance ToJS (Expr t v) where
toJS expr =
case expr of
Var x -> return x
Literal lit -> toJS lit
Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
Access e x -> access x `liftM` toJS' e
Remove e x -> remove x `liftM` toJS' e
Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
setField fs' `liftM` toJS' e
Record fs -> makeRecord fs
Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
Lambda p e -> liftM (jsFunc (intercalate ", " args) . ret) (toJS' body)
where
(args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
depattern (pattern,n) (args, body) =
case pattern of
PVar x -> (x:args, body)
_ -> let arg = "arg" ++ show n
in (arg:args, Loc.none (Case (Loc.none (Var arg)) [(pattern, body)]))
(patterns, innerBody) = collect [p] e
collect patterns lexpr@(L a b expr) =
case expr of
Lambda p e -> collect (p:patterns) e
_ -> (patterns, lexpr)
App e1 e2 -> jsApp e1 e2
Let defs e -> jsLet $ SD.flattenLets defs e
ExplicitList es ->
do es' <- mapM toJS' es
return $ "_J.toList" ++ parens (jsList es')
Data name es ->
do fs <- mapM toJS' es
return $ case name of
"[]" -> jsNil
"::" -> jsCons (head fs) ((head . tail) fs)
_ -> jsObj $ ("ctor:" ++ show name) : fields
where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
where pad = "