{-# OPTIONS_GHC -W #-} module Generate.JavaScript (generate) where import Control.Arrow (first,(***)) import Control.Applicative ((<$>),(<*>)) import Control.Monad.State import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import qualified Generate.Cases as Case import qualified Generate.Markdown as MD import qualified SourceSyntax.Helpers as Help import SourceSyntax.Literal import SourceSyntax.Pattern as Pattern import SourceSyntax.Location import SourceSyntax.Expression import SourceSyntax.Module import Language.ECMAScript3.Syntax import Language.ECMAScript3.PrettyPrint import qualified Transform.SafeNames as MakeSafe split :: String -> [String] split = go [] where go vars str = case break (=='.') str of (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest] | otherwise -> go (vars ++ [x]) rest (x,[]) -> vars ++ [x] var name = Id () name ref name = VarRef () (var name) prop name = PropId () (var name) f <| x = CallExpr () f [x] args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ] function args stmts = FuncExpr () Nothing (map var args) stmts call = CallExpr () string = StringLit () dotSep vars = case vars of x:xs -> foldl (DotRef ()) (ref x) (map var xs) [] -> error "dotSep must be called on a non-empty list of variables" obj = dotSep . split varDecl :: String -> Expression () -> VarDecl () varDecl x expr = VarDecl () (var x) (Just expr) include alias moduleName = varDecl alias (obj (moduleName ++ ".make") <| ref "_elm") 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 :: LExpr -> State Int (Expression ()) expression (L span expr) = case expr of Var x -> return $ ref 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 () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap where combine r (k,v) = Map.insertWith (++) k [v] r prop = PropId () . var 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 span op e1 e2 Lambda p e@(L s _) -> 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 PVar x -> return (args ++ [x], body) _ -> do arg <- Case.newVar return (args ++ [arg], L s (Case (L s (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 -> 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 (L _ (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 ++ [ ReturnStmt () (Just exp) ]) `call` [] MultiIf branches -> do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e return $ case last branches of (L _ (Var "Basics.otherwise"), _) -> safeIfs branches' (L _ (Literal (Boolean True)), _) -> safeIfs branches' _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ]) 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 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, []) _ -> do e' <- expression e return (initialMatch, [VarDeclStmt () [varDecl tempVar e']]) match' <- match span 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 = "