{-# OPTIONS_GHC -W #-} module Generate.JavaScript (generate) where import Control.Applicative ((<$>),(<*>)) import Control.Arrow (first,(***)) import Control.Monad.State import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import Language.ECMAScript3.PrettyPrint import Language.ECMAScript3.Syntax import Generate.JavaScript.Helpers import qualified Generate.Cases as Case import qualified Generate.JavaScript.Ports as Port import qualified Generate.Markdown as MD import SourceSyntax.Annotation import SourceSyntax.Expression import qualified SourceSyntax.Helpers as Help import SourceSyntax.Literal import SourceSyntax.Module import qualified SourceSyntax.Pattern as P import SourceSyntax.PrettyPrint (renderPretty) import qualified SourceSyntax.Variable as V import qualified Transform.SafeNames as MakeSafe varDecl :: String -> Expression () -> VarDecl () varDecl x expr = VarDecl () (var x) (Just expr) include :: String -> String -> VarDecl () include alias moduleName = varDecl alias (obj (moduleName ++ ".make") <| ref "_elm") internalImports :: String -> Statement () internalImports name = VarDeclStmt () [ varDecl "_N" (obj "Elm.Native") , include "_U" "_N.Utils" , include "_L" "_N.List" , include "_E" "_N.Error" , include "_J" "_N.JavaScript" , varDecl "$moduleName" (string name) ] literal :: Literal -> Expression () literal lit = case lit of Chr c -> obj "_U.chr" <| string [c] Str s -> string s IntNum n -> IntLit () n FloatNum n -> NumLit () n Boolean b -> BoolLit () b expression :: Expr -> State Int (Expression ()) expression (A region expr) = case expr of Var (V.Raw x) -> return $ obj x Literal lit -> return $ literal lit Range lo hi -> do lo' <- expression lo hi' <- expression hi return $ obj "_L.range" `call` [lo',hi'] Access e x -> do e' <- expression e return $ DotRef () e' (var x) Remove e x -> do e' <- expression e return $ obj "_U.remove" `call` [string x, e'] Insert e x v -> do v' <- expression v e' <- expression e return $ obj "_U.insert" `call` [string x, v', e'] Modify e fs -> do e' <- expression e fs' <- forM fs $ \(f,v) -> do v' <- expression v return $ ArrayLit () [string f, v'] return $ obj "_U.replace" `call` [ArrayLit () fs', e'] Record fields -> do fields' <- forM fields $ \(f,e) -> do (,) f <$> expression e let fieldMap = List.foldl' combine Map.empty fields' return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap where combine r (k,v) = Map.insertWith (++) k [v] r hidden fs = ObjectLit () . map (prop *** ArrayLit ()) . Map.toList . Map.filter (not . null) $ Map.map tail fs visible fs = map (first prop) . Map.toList $ Map.map head fs Binop op e1 e2 -> binop region op e1 e2 Lambda p e@(A ann _) -> do (args, body) <- foldM depattern ([], innerBody) (reverse patterns) body' <- expression body return $ case length args < 2 || length args > 9 of True -> foldr (==>) body' (map (:[]) args) False -> ref ("F" ++ show (length args)) <| (args ==> body') where depattern (args, body) pattern = case pattern of P.Var x -> return (args ++ [x], body) _ -> do arg <- Case.newVar return ( args ++ [arg] , A ann (Case (A ann (rawVar arg)) [(pattern, body)])) (patterns, innerBody) = collect [p] e collect patterns lexpr@(A _ expr) = case expr of Lambda p e -> collect (p:patterns) e _ -> (patterns, lexpr) App e1 e2 -> do func' <- expression func args' <- mapM expression args return $ case args' of [arg] -> func' <| arg _ | length args' <= 9 -> ref aN `call` (func':args') | otherwise -> foldl1 (<|) (func':args') where aN = "A" ++ show (length args) (func, args) = getArgs e1 [e2] getArgs func args = case func of (A _ (App f arg)) -> getArgs f (arg : args) _ -> (func, args) Let defs e -> do let (defs',e') = flattenLets defs e stmts <- concat <$> mapM definition defs' exp <- expression e' return $ function [] (stmts ++ [ ret exp ]) `call` [] MultiIf branches -> do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e return $ case last branches of (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches' (A _ (Literal (Boolean True)), _) -> safeIfs branches' _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ]) where safeIfs branches = ifs (init branches) (snd (last branches)) ifs branches finally = foldr iff finally branches iff (if', then') else' = CondExpr () if' then' else' Case e cases -> do (tempVar,initialMatch) <- Case.toMatch cases (revisedMatch, stmt) <- case e of A _ (Var (V.Raw x)) -> return (Case.matchSubst [(tempVar,x)] initialMatch, []) _ -> do e' <- expression e return (initialMatch, [VarDeclStmt () [varDecl tempVar e']]) match' <- match region revisedMatch return (function [] (stmt ++ match') `call` []) ExplicitList es -> do es' <- mapM expression es return $ obj "_J.toList" <| ArrayLit () es' Data name es -> do es' <- mapM expression es return $ ObjectLit () (ctor : fields es') where ctor = (prop "ctor", string name) fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..] Markdown uid doc es -> do es' <- mapM expression es return $ obj "Text.markdown" `call` (string md : string uid : es') where pad = "