{-# 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 as Help import qualified Generate.Cases as Case import qualified Generate.JavaScript.Ports as Port import qualified Generate.JavaScript.Variable as Var import qualified Generate.Markdown as MD import AST.Annotation import AST.Module import AST.Expression.General import qualified AST.Expression.Canonical as Canonical import qualified AST.Module as Module import qualified AST.Helpers as Help import AST.Literal import qualified AST.Pattern as P import qualified AST.Variable as Var varDecl :: String -> Expression () -> VarDecl () varDecl x expr = VarDecl () (var x) (Just expr) internalImports :: String -> [VarDecl ()] internalImports name = [ varDecl "_N" (obj ["Elm","Native"]) , include "_U" "Utils" , include "_L" "List" , include "_A" "Array" , include "_E" "Error" , varDecl Help.localModuleName (string name) ] where include :: String -> String -> VarDecl () include alias modul = varDecl alias (obj ["_N", modul, "make"] <| ref "_elm") _Utils :: String -> Expression () _Utils x = obj ["_U", x] _List :: String -> Expression () _List x = obj ["_L", x] literal :: Literal -> Expression () literal lit = case lit of Chr c -> _Utils "chr" <| string [c] Str s -> string s IntNum n -> IntLit () n FloatNum n -> NumLit () n Boolean b -> BoolLit () b expression :: Canonical.Expr -> State Int (Expression ()) expression (A region expr) = case expr of Var var -> return $ Var.canonical var Literal lit -> return $ literal lit Range lo hi -> do lo' <- expression lo hi' <- expression hi return $ _List "range" `call` [lo',hi'] Access e x -> do e' <- expression e return $ DotRef () e' (var x) Remove e x -> do e' <- expression e return $ _Utils "remove" `call` [string x, e'] Insert e x v -> do v' <- expression v e' <- expression e return $ _Utils "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 $ _Utils "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 ++ [ Var.varName x ], body) _ -> do arg <- Case.newVar return ( args ++ [arg] , A ann (Case (A ann (localVar 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 (Var.Canonical (Var.Module "Basics") "otherwise")), _) -> safeIfs branches' (A _ (Literal (Boolean True)), _) -> safeIfs branches' _ -> ifs branches' (throw "If" 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 (Var.Canonical Var.Local x)) -> return (Case.matchSubst [(tempVar, Var.varName 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 $ _List "fromArray" <| 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 $ Var.value "Text" "markdown" `call` (string md : string uid : es') where pad = "