module Generate.JavaScript (showErr, jsModule) where
import Control.Arrow (first,second)
import Control.Monad (liftM,(<=<),join,ap)
import Data.Char (isAlpha,isDigit)
import qualified Data.List as List
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
deprime :: String -> String
deprime = map (\c -> if c == '\'' then '$' else c)
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 ++ "}"
commaSep = List.intercalate ", "
dotSep = List.intercalate "."
jsObj = brackets . commaSep
jsList ss = "["++ List.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 . fst . SD.flattenLets [] $ program modul
foreignImport <- mapM importEvent (foreignImports modul)
return $ concat [ setup ("Elm": names modul)
, globalAssign ("Elm." ++ modName)
(jsFunc "elm" $ makeProgram body foreignImport) ]
where
modName = dotSep (names modul)
makeProgram body foreignImport =
concat [ "\nvar " ++ usefulFuncs ++ ";"
, concatMap jsImport (imports modul)
, concat foreignImport
, concatMap exportEvent $ foreignExports modul
, assign "_op" "{}"
, body
, jsExports
]
setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
map dotSep . drop 2 . List.inits $ init names
usefulFuncs = commaSep (map (uncurry assign') internalImports)
jsExports = setup ("elm" : names modul) ++
ret (assign' ("elm." ++ modName) (brackets exs))
where
exs = indent . commaSep . concatMap pair $ "_op" : exports modul
pair x | isOp x = []
| otherwise = ["\n" ++ 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, method) =
concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
where
starters = "\nvar " : repeat "\n"
values = map (\name -> name ++ " || {}") (init subnames) ++
["Elm." ++ modul ++ parens "elm"]
subnames = map dotSep . tail . List.inits $ split modul
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 (deprime x) `liftM` toJS' e
toJS (Def pattern e) =
do n <- guid
let x = "_" ++ show n
var = Loc.none . Var
toDef y' = let y = deprime y' in
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 span expr) =
case expr of
MultiIf ps -> multiIfToJS span ps
Case e cases -> caseToJS span e cases
_ -> toJS expr
remove x e = "_N.remove('" ++ deprime x ++ "', " ++ e ++ ")"
addField x v e = "_N.insert('" ++ deprime x ++ "', " ++ v ++ ", " ++ e ++ ")"
setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
where f (x,v) = "['" ++ deprime x ++ "'," ++ v ++ "]"
access x e = e ++ "." ++ deprime x
makeRecord kvs = record `liftM` collect kvs
where
combine r (k,v) = Map.insertWith (++) k v r
collect = liftM (List.foldl' combine Map.empty) . mapM prep
prep (k, e) =
do v <- toJS' e
return (deprime k, [v])
fields fs =
brackets ("\n "++List.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 (deprime 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 (fastFunc . ret) (toJS' body)
where
fastFunc body
| length args < 2 || length args > 9 = foldr jsFunc body args
| otherwise = "F" ++ show (length args) ++ parens (jsFunc (commaSep args) body)
(args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])
depattern (pattern,n) (args, body) =
case pattern of
PVar x -> (deprime 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 _ 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 = "