{-# LANGUAGE PatternGuards #-} module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where import Idris.AbsSyntax hiding (TypeCase) import IRTS.Bytecode import IRTS.Lang import IRTS.Simplified import IRTS.CodegenCommon import Idris.Core.TT import Paths_idris import Util.System import Control.Arrow import Control.Applicative ((<$>), (<*>), pure) import Data.Char import Numeric import Data.List import Data.Maybe import System.IO import System.Directory idrNamespace :: String idrNamespace = "__IDR__" idrRTNamespace = "__IDRRT__" idrLTNamespace = "__IDRLT__" idrCTRNamespace = "__IDRCTR__" data JSTarget = Node | JavaScript deriving Eq data JSType = JSIntTy | JSStringTy | JSIntegerTy | JSFloatTy | JSCharTy | JSPtrTy | JSForgotTy deriving Eq data JSInteger = JSBigZero | JSBigOne | JSBigInt Integer deriving Eq data JSNum = JSInt Int | JSFloat Double | JSInteger JSInteger deriving Eq data JSAnnotation = JSConstructor deriving Eq instance Show JSAnnotation where show JSConstructor = "constructor" data JS = JSRaw String | JSIdent String | JSFunction [String] JS | JSType JSType | JSSeq [JS] | JSReturn JS | JSApp JS [JS] | JSNew String [JS] | JSError String | JSBinOp String JS JS | JSPreOp String JS | JSPostOp String JS | JSProj JS String | JSVar LVar | JSNull | JSThis | JSTrue | JSFalse | JSArray [JS] | JSString String | JSNum JSNum | JSAssign JS JS | JSAlloc String (Maybe JS) | JSIndex JS JS | JSCond [(JS, JS)] | JSTernary JS JS JS | JSParens JS | JSWhile JS JS | JSFFI String [JS] | JSAnnotation JSAnnotation JS | JSNoop deriving Eq data FFI = FFICode Char | FFIArg Int | FFIError String ffi :: String -> [String] -> String ffi code args = let parsed = ffiParse code in case ffiError parsed of Just err -> error err Nothing -> renderFFI parsed args where ffiParse :: String -> [FFI] ffiParse "" = [] ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"] ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss ffiParse ('%':s:ss) | isDigit s = FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss) | otherwise = [FFIError $ "FFI - Invalid positional argument"] ffiParse (s:ss) = FFICode s : ffiParse ss ffiError :: [FFI] -> Maybe String ffiError [] = Nothing ffiError ((FFIError s):xs) = Just s ffiError (x:xs) = ffiError xs renderFFI :: [FFI] -> [String] -> String renderFFI [] _ = "" renderFFI ((FFICode c) : fs) args = c : renderFFI fs args renderFFI ((FFIArg i) : fs) args | i < length args && i >= 0 = args !! i ++ renderFFI fs args | otherwise = error "FFI - Argument index out of bounds" compileJS :: JS -> String compileJS JSNoop = "" compileJS (JSAnnotation annotation js) = "/** @" ++ show annotation ++ " */\n" ++ compileJS js compileJS (JSFFI raw args) = ffi raw (map compileJS args) compileJS (JSRaw code) = code compileJS (JSIdent ident) = ident compileJS (JSFunction args body) = "function(" ++ intercalate "," args ++ "){\n" ++ compileJS body ++ "\n}" compileJS (JSType ty) | JSIntTy <- ty = idrRTNamespace ++ "Int" | JSStringTy <- ty = idrRTNamespace ++ "String" | JSIntegerTy <- ty = idrRTNamespace ++ "Integer" | JSFloatTy <- ty = idrRTNamespace ++ "Float" | JSCharTy <- ty = idrRTNamespace ++ "Char" | JSPtrTy <- ty = idrRTNamespace ++ "Ptr" | JSForgotTy <- ty = idrRTNamespace ++ "Forgot" compileJS (JSSeq seq) = intercalate ";\n" (map compileJS seq) compileJS (JSReturn val) = "return " ++ compileJS val compileJS (JSApp lhs rhs) | JSFunction {} <- lhs = concat ["(", compileJS lhs, ")(", args, ")"] | otherwise = concat [compileJS lhs, "(", args, ")"] where args :: String args = intercalate "," $ map compileJS rhs compileJS (JSNew name args) = "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")" compileJS (JSError exc) = "throw new Error(\"" ++ exc ++ "\")" compileJS (JSBinOp op lhs rhs) = compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs compileJS (JSPreOp op val) = op ++ compileJS val compileJS (JSProj obj field) | JSFunction {} <- obj = concat ["(", compileJS obj, ").", field] | JSAssign {} <- obj = concat ["(", compileJS obj, ").", field] | otherwise = compileJS obj ++ '.' : field compileJS (JSVar var) = translateVariableName var compileJS JSNull = "null" compileJS JSThis = "this" compileJS JSTrue = "true" compileJS JSFalse = "false" compileJS (JSArray elems) = "[" ++ intercalate "," (map compileJS elems) ++ "]" compileJS (JSString str) = "\"" ++ str ++ "\"" compileJS (JSNum num) | JSInt i <- num = show i | JSFloat f <- num = show f | JSInteger JSBigZero <- num = "__IDRRT__ZERO" | JSInteger JSBigOne <- num = "__IDRRT__ONE" | JSInteger (JSBigInt i) <- num = show i compileJS (JSAssign lhs rhs) = compileJS lhs ++ "=" ++ compileJS rhs compileJS (JSAlloc name val) = "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val compileJS (JSIndex lhs rhs) = compileJS lhs ++ "[" ++ compileJS rhs ++ "]" compileJS (JSCond branches) = intercalate " else " $ map createIfBlock branches where createIfBlock (JSNoop, e) = "{\n" ++ compileJS e ++ ";\n}" createIfBlock (cond, e) = "if (" ++ compileJS cond ++") {\n" ++ compileJS e ++ ";\n}" compileJS (JSTernary cond true false) = let c = compileJS cond t = compileJS true f = compileJS false in "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")" compileJS (JSParens js) = "(" ++ compileJS js ++ ")" compileJS (JSWhile cond body) = "while (" ++ compileJS cond ++ ") {\n" ++ compileJS body ++ "\n}" jsTailcall :: JS -> JS jsTailcall call = jsCall (idrRTNamespace ++ "tailcall") [ JSFunction [] (JSReturn call) ] jsCall :: String -> [JS] -> JS jsCall fun = JSApp (JSIdent fun) jsMeth :: JS -> String -> [JS] -> JS jsMeth obj meth = JSApp (JSProj obj meth) jsInstanceOf :: JS -> JS -> JS jsInstanceOf = JSBinOp "instanceof" jsEq :: JS -> JS -> JS jsEq = JSBinOp "==" jsAnd :: JS -> JS -> JS jsAnd = JSBinOp "&&" jsOr :: JS -> JS -> JS jsOr = JSBinOp "||" jsType :: JS jsType = JSIdent $ idrRTNamespace ++ "Type" jsCon :: JS jsCon = JSIdent $ idrRTNamespace ++ "Con" jsTag :: JS -> JS jsTag obj = JSProj obj "tag" jsTypeTag :: JS -> JS jsTypeTag obj = JSProj obj "type" jsBigInt :: JS -> JS jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val] jsVar :: Int -> String jsVar = ("__var_" ++) . show jsLet :: String -> JS -> JS -> JS jsLet name value body = JSApp ( JSFunction [name] ( JSReturn body ) ) [value] jsError :: String -> JS jsError err = JSApp (JSFunction [] (JSError err)) [] foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a foldJS tr add acc js = fold js where fold js | JSFunction args body <- js = add (tr js) (fold body) | JSSeq seq <- js = add (tr js) $ foldl' add acc (map fold seq) | JSReturn ret <- js = add (tr js) (fold ret) | JSApp lhs rhs <- js = add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs) | JSNew _ args <- js = add (tr js) $ foldl' add acc $ map fold args | JSBinOp _ lhs rhs <- js = add (tr js) $ add (fold lhs) (fold rhs) | JSPreOp _ val <- js = add (tr js) $ fold val | JSPostOp _ val <- js = add (tr js) $ fold val | JSProj obj _ <- js = add (tr js) (fold obj) | JSArray vals <- js = add (tr js) $ foldl' add acc $ map fold vals | JSAssign lhs rhs <- js = add (tr js) $ add (fold lhs) (fold rhs) | JSIndex lhs rhs <- js = add (tr js) $ add (fold lhs) (fold rhs) | JSAlloc _ val <- js = add (tr js) $ fromMaybe acc $ fmap fold val | JSTernary c t f <- js = add (tr js) $ add (fold c) (add (fold t) (fold f)) | JSParens val <- js = add (tr js) $ fold val | JSCond conds <- js = add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds | JSWhile cond body <- js = add (tr js) $ add (fold cond) (fold body) | JSFFI raw args <- js = add (tr js) $ foldl' add acc $ map fold args | JSAnnotation a js <- js = add (tr js) $ fold js | otherwise = tr js transformJS :: (JS -> JS) -> JS -> JS transformJS tr js = transformHelper js where transformHelper :: JS -> JS transformHelper js | JSFunction args body <- js = JSFunction args $ tr body | JSSeq seq <- js = JSSeq $ map tr seq | JSReturn ret <- js = JSReturn $ tr ret | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs | JSNew con args <- js = JSNew con $ map tr args | JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs) | JSPreOp op val <- js = JSPreOp op (tr val) | JSPostOp op val <- js = JSPostOp op (tr val) | JSProj obj field <- js = JSProj (tr obj) field | JSArray vals <- js = JSArray $ map tr vals | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs) | JSAlloc var val <- js = JSAlloc var $ fmap tr val | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs) | JSCond conds <- js = JSCond $ map (tr *** tr) conds | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f) | JSParens val <- js = JSParens $ tr val | JSWhile cond body <- js = JSWhile (tr cond) (tr body) | JSFFI raw args <- js = JSFFI raw (map tr args) | JSAnnotation a js <- js = JSAnnotation a (tr js) | otherwise = js moveJSDeclToTop :: String -> [JS] -> [JS] moveJSDeclToTop decl js = move ([], js) where move :: ([JS], [JS]) -> [JS] move (front, js@(JSAnnotation _ (JSAlloc name _)):back) | name == decl = js : front ++ back move (front, js@(JSAlloc name _):back) | name == decl = js : front ++ back move (front, js:back) = move (front ++ [js], back) jsSubst :: JS -> JS -> JS -> JS jsSubst var new old | var == old = new jsSubst (JSIdent var) new (JSVar old) | var == translateVariableName old = new | otherwise = JSVar old jsSubst var new old@(JSIdent _) | var == old = new | otherwise = old jsSubst var new (JSArray fields) = JSArray (map (jsSubst var new) fields) jsSubst var new (JSNew con vals) = JSNew con $ map (jsSubst var new) vals jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals) | var `notElem` args = JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") ( map (jsSubst (JSIdent var) new) vals ) | otherwise = JSApp (JSProj (JSFunction args body) "apply") ( map (jsSubst (JSIdent var) new) vals ) jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals) | var /= arg = JSApp (JSFunction [arg] ( jsSubst (JSIdent var) new body )) $ map (jsSubst (JSIdent var) new) vals | otherwise = JSApp (JSFunction [arg] ( body )) $ map (jsSubst (JSIdent var) new) vals jsSubst var new js = transformJS (jsSubst var new) js removeAllocations :: JS -> JS removeAllocations (JSSeq body) = let opt = removeHelper (map removeAllocations body) in case opt of [ret] -> ret _ -> JSSeq opt where removeHelper :: [JS] -> [JS] removeHelper [js] = [js] removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) = map (jsSubst (JSIdent name) val) (removeHelper js) removeHelper (j:js) = j : removeHelper js removeAllocations js = transformJS removeAllocations js isJSConstant :: JS -> Bool isJSConstant js | JSString _ <- js = True | JSNum _ <- js = True | JSType _ <- js = True | JSNull <- js = True | JSArray vals <- js = all isJSConstant vals | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True | otherwise = False isJSConstantConstructor :: [String] -> JS -> Bool isJSConstantConstructor constants js | isJSConstant js = True | JSArray vals <- js = all (isJSConstantConstructor constants) vals | JSNew "__IDRRT__Con" args <- js = all (isJSConstantConstructor constants) args | JSIndex (JSProj (JSIdent name) "vars") (JSNum _) <- js , name `elem` constants = True | JSIdent name <- js , name `elem` constants = True | otherwise = False inlineJS :: JS -> JS inlineJS = inlineAssign . inlineError . inlineApply . inlineCaseMatch . inlineJSLet where inlineJSLet :: JS -> JS inlineJSLet (JSApp (JSFunction [arg] (JSReturn ret)) [val]) | opt <- inlineJSLet val = inlineJS $ jsSubst (JSIdent arg) opt ret inlineJSLet js = transformJS inlineJSLet js inlineCaseMatch (JSReturn (JSApp (JSFunction ["cse"] body) [val])) | opt <- inlineCaseMatch val = inlineCaseMatch $ jsSubst (JSIdent "cse") opt body inlineCaseMatch js = transformJS inlineCaseMatch js inlineApply js | JSApp ( JSProj (JSFunction args (JSReturn body)) "apply" ) [JSThis, JSProj var "vars"] <- js = inlineApply $ inlineApply' var args body 0 | JSReturn (JSApp ( JSProj (JSFunction args body@(JSCond _)) "apply" ) [JSThis, JSProj var "vars"]) <- js = inlineApply $ inlineApply' var args body 0 where inlineApply' _ [] body _ = body inlineApply' var (a:as) body n = inlineApply' var as ( jsSubst (JSIdent a) ( JSIndex (JSProj var "vars") (JSNum (JSInt n)) ) body ) (n + 1) inlineApply js = transformJS inlineApply js inlineError (JSReturn (JSApp (JSFunction [] error@(JSError _)) [])) = inlineError error inlineError js = transformJS inlineError js inlineAssign (JSAssign lhs rhs) | JSVar _ <- lhs , JSVar _ <- rhs , lhs == rhs = lhs inlineAssign (JSAssign lhs rhs) | JSIdent _ <- lhs , JSIdent _ <- rhs , lhs == rhs = lhs inlineAssign js = transformJS inlineAssign js removeEval :: [JS] -> [JS] removeEval js = let (ret, isReduced) = checkEval js in if isReduced then removeEvalApp ret else ret where removeEvalApp js = catMaybes (map removeEvalApp' js) where removeEvalApp' :: JS -> Maybe JS removeEvalApp' (JSAlloc "__IDR__mEVAL0" _) = Nothing removeEvalApp' js = Just $ transformJS match js where match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val match js = transformJS match js checkEval :: [JS] -> ([JS], Bool) checkEval js = foldr f ([], False) $ map checkEval' js where f :: (Maybe JS, Bool) -> ([JS], Bool) -> ([JS], Bool) f (Just js, isReduced) (ret, b) = (js : ret, isReduced || b) f (Nothing, isReduced) (ret, b) = (ret, isReduced || b) checkEval' :: JS -> (Maybe JS, Bool) checkEval' (JSAlloc "__IDRLT__EVAL" (Just (JSApp (JSFunction [] ( JSSeq [ _ , JSReturn (JSIdent "t") ] )) []))) = (Nothing, True) checkEval' js = (Just js, False) reduceJS :: [JS] -> [JS] reduceJS js = moveJSDeclToTop "__IDRRT__Con" $ reduceLoop [] ([], js) funName :: JS -> String funName (JSAlloc fun _) = fun elimDeadLoop :: [JS] -> [JS] elimDeadLoop js | ret <- deadEvalApplyCases js , ret /= js = elimDeadLoop ret | otherwise = js deadEvalApplyCases :: [JS] -> [JS] deadEvalApplyCases js = let tags = sort $ nub $ concatMap (getTags) js in map (removeHelper tags) js where getTags :: JS -> [Int] getTags = foldJS match (++) [] where match js | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag] | otherwise = [] removeHelper :: [Int] -> JS -> JS removeHelper tags (JSAlloc fun (Just ( JSApp (JSFunction [] (JSSeq seq)) [])) ) = (JSAlloc fun (Just ( JSApp (JSFunction [] (JSSeq $ remover tags seq)) [])) ) removeHelper _ js = js remover :: [Int] -> [JS] -> [JS] remover tags ( j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js ) | tag `notElem` tags = remover tags js remover tags (j:js) = j : remover tags js remover _ [] = [] initConstructors :: [JS] -> [JS] initConstructors js = let tags = nub $ sort $ concat (map getTags js) in rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js where rearrangePrelude :: [JS] -> [JS] rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con" getTags :: JS -> [Int] getTags = foldJS match (++) [] where match js | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag] | otherwise = [] replaceConstructors :: [Int] -> [JS] -> [JS] replaceConstructors tags js = map (replaceHelper tags) js where replaceHelper :: [Int] -> JS -> JS replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []]) | tag `elem` tags = JSIdent (idrCTRNamespace ++ show tag) replaceHelper tags js = transformJS (replaceHelper tags) js createConstant :: Int -> JS createConstant tag = JSAlloc (idrCTRNamespace ++ show tag) (Just ( JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []] )) removeIDs :: [JS] -> [JS] removeIDs js = case partition isID js of ([], rest) -> rest (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest where isID :: JS -> Bool isID (JSAlloc _ (Just (JSFunction _ (JSSeq body)))) | JSReturn (JSVar _) <- last body = True isID _ = False idFor :: JS -> (String, Int) idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos) removeIDCall :: [(String, Int)] -> JS -> JS removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( JSReturn (JSApp (JSIdent fun) args) )]) | Just pos <- lookup fun ids , pos < length args = args !! pos removeIDCall ids (JSNew _ [JSFunction [] ( JSReturn (JSApp (JSIdent fun) args) )]) | Just pos <- lookup fun ids , pos < length args = args !! pos removeIDCall ids js@(JSApp id@(JSIdent fun) args) | Just pos <- lookup fun ids , pos < length args = args !! pos removeIDCall ids js = transformJS (removeIDCall ids) js inlineFunctions :: [JS] -> [JS] inlineFunctions js = inlineHelper ([], js) where inlineHelper :: ([JS], [JS]) -> [JS] inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back) | countAll fun front + countAll fun back == 0 = inlineHelper (front, back) | Just new <- inlineAble ( countAll fun front + countAll fun back ) fun args body = let f = map (inline fun args new) in inlineHelper (f front, f back) inlineHelper (front, next:back) = inlineHelper (front ++ [next], back) inlineHelper (front, []) = front inlineAble :: Int -> String -> [String] -> JS -> Maybe JS inlineAble 1 fun args (JSReturn body) | nonRecur fun body = if all (<= 1) (map ($ body) (map countIDOccurences args)) then Just body else Nothing inlineAble _ _ _ _ = Nothing inline :: String -> [String] -> JS -> JS -> JS inline fun args body js = inline' js where inline' :: JS -> JS inline' (JSApp (JSIdent name) vals) | name == fun = let (js, phs) = insertPlaceHolders args body in inline' $ foldr (uncurry jsSubst) js (zip phs vals) inline' js = transformJS inline' js insertPlaceHolders :: [String] -> JS -> (JS, [JS]) insertPlaceHolders args body = insertPlaceHolders' args body [] where insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS]) insertPlaceHolders' (a:as) body ph | (body', ph') <- insertPlaceHolders' as body ph = let phvar = JSIdent $ "__PH_" ++ show (length ph') in (jsSubst (JSIdent a) phvar body', phvar : ph') insertPlaceHolders' [] body ph = (body, ph) nonRecur :: String -> JS -> Bool nonRecur name body = countInvokations name body == 0 countAll :: String -> [JS] -> Int countAll name js = sum $ map (countInvokations name) js countIDOccurences :: String -> JS -> Int countIDOccurences name = foldJS match (+) 0 where match :: JS -> Int match js | JSIdent ident <- js , name == ident = 1 | otherwise = 0 countInvokations :: String -> JS -> Int countInvokations name = foldJS match (+) 0 where match :: JS -> Int match js | JSApp (JSIdent ident) _ <- js , name == ident = 1 | JSNew con _ <- js , name == con = 1 | otherwise = 0 reduceContinuations :: JS -> JS reduceContinuations = inlineTC . reduceJS where reduceJS :: JS -> JS reduceJS (JSNew "__IDRRT__Cont" [JSFunction [] ( JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body]) )]) = reduceJS js reduceJS js = transformJS reduceJS js inlineTC :: JS -> JS inlineTC js | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( JSReturn (JSNew "__IDRRT__Cont" [JSFunction [] ( JSReturn ret@(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( JSReturn (JSNew "__IDRRT__Cont" _) )]) )]) )] <- js = inlineTC ret inlineTC js = transformJS inlineTC js reduceConstant :: JS -> JS reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val]) )]) | JSNum num <- val = val | JSBinOp op lhs rhs <- val = JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs) | JSApp (JSProj lhs op) [rhs] <- val , op `elem` [ "subtract" , "add" , "multiply" , "divide" , "mod" , "equals" , "lesser" , "lesserOrEquals" , "greater" , "greaterOrEquals" ] = val reduceConstant (JSApp ident [(JSParens js)]) = JSApp ident [reduceConstant js] reduceConstant js = transformJS reduceConstant js reduceConstants :: JS -> JS reduceConstants js | ret <- reduceConstant js , ret /= js = reduceConstants ret | otherwise = js elimDuplicateEvals :: JS -> JS elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) = JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq)) where elimHelper :: [JS] -> [JS] elimHelper (j@(JSAlloc var (Just val)):js) = j : map (jsSubst val (JSIdent var)) (elimHelper js) elimHelper (j:js) = j : elimHelper js elimHelper [] = [] elimDuplicateEvals js = js optimizeRuntimeCalls :: String -> String -> [JS] -> [JS] optimizeRuntimeCalls fun tc js = optTC tc : map optHelper js where optHelper :: JS -> JS optHelper (JSApp (JSIdent "__IDRRT__tailcall") [ JSFunction [] (JSReturn (JSApp (JSIdent n) args)) ]) | n == fun = JSApp (JSIdent tc) $ map optHelper args optHelper js = transformJS optHelper js optTC :: String -> JS optTC tc@"__IDRRT__EVALTC" = JSAlloc tc (Just $ JSFunction ["arg0"] ( JSSeq [ JSAlloc "ret" $ Just ( JSTernary ( (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd` (hasProp "__IDRLT__EVAL" "arg0") ) (JSApp (JSIndex (JSIdent "__IDRLT__EVAL") (JSProj (JSIdent "arg0") "tag") ) [JSIdent "arg0"] ) (JSIdent "arg0") ) , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) ( JSAssign (JSIdent "ret") ( JSApp (JSProj (JSIdent "ret") "k") [] ) ) , JSReturn $ JSIdent "ret" ] )) optTC tc@"__IDRRT__APPLYTC" = JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] ( JSSeq [ JSAlloc "ret" $ Just ( JSTernary ( (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd` (hasProp "__IDRLT__APPLY" "fn0") ) (JSApp (JSIndex (JSIdent "__IDRLT__APPLY") (JSProj (JSIdent "fn0") "tag") ) [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"] ) JSNull ) , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) ( JSAssign (JSIdent "ret") ( JSApp (JSProj (JSIdent "ret") "k") [] ) ) , JSReturn $ JSIdent "ret" ] )) hasProp :: String -> String -> JS hasProp table var = JSIndex (JSIdent table) (JSProj (JSIdent var) "tag") unfoldLookupTable :: [JS] -> [JS] unfoldLookupTable input = let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold js = applyunfold in adaptRuntime $ expandCons evals applys js where adaptRuntime :: [JS] -> [JS] adaptRuntime = adaptEvalTC . adaptApplyTC . adaptEval . adaptApply . adaptCon adaptApply :: [JS] -> [JS] adaptApply js = adaptApply' [] js where adaptApply' :: [JS] -> [JS] -> [JS] adaptApply' front ((JSAlloc "__IDR__mAPPLY0" (Just _)):back) = front ++ (new:back) adaptApply' front (next:back) = adaptApply' (front ++ [next]) back adaptApply' front [] = front new = JSAlloc "__IDR__mAPPLY0" (Just $ JSFunction ["mfn0", "marg0"] (JSReturn $ JSTernary ( (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd` (JSProj (JSIdent "mfn0") "app") ) (JSApp (JSProj (JSIdent "mfn0") "app") [JSIdent "mfn0", JSIdent "marg0"] ) JSNull ) ) adaptApplyTC :: [JS] -> [JS] adaptApplyTC js = adaptApplyTC' [] js where adaptApplyTC' :: [JS] -> [JS] -> [JS] adaptApplyTC' front ((JSAlloc "__IDRRT__APPLYTC" (Just _)):back) = front ++ (new:back) adaptApplyTC' front (next:back) = adaptApplyTC' (front ++ [next]) back adaptApplyTC' front [] = front new = JSAlloc "__IDRRT__APPLYTC" (Just $ JSFunction ["mfn0", "marg0"] ( JSSeq [ JSAlloc "ret" $ Just ( JSTernary ( (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd` (JSProj (JSIdent "mfn0") "app") ) (JSApp (JSProj (JSIdent "mfn0") "app") [JSIdent "mfn0", JSIdent "marg0"] ) JSNull ) , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) ( JSAssign (JSIdent "ret") ( JSApp (JSProj (JSIdent "ret") "k") [] ) ) , JSReturn $ JSIdent "ret" ] )) adaptEval :: [JS] -> [JS] adaptEval js = adaptEval' [] js where adaptEval' :: [JS] -> [JS] -> [JS] adaptEval' front ((JSAlloc "__IDR__mEVAL0" (Just _)):back) = front ++ (new:back) adaptEval' front (next:back) = adaptEval' (front ++ [next]) back adaptEval' front [] = front new = JSAlloc "__IDR__mEVAL0" (Just $ JSFunction ["marg0"] (JSReturn $ JSTernary ( (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd` (JSProj (JSIdent "marg0") "eval") ) (JSApp (JSProj (JSIdent "marg0") "eval") [JSIdent "marg0"] ) (JSIdent "marg0") ) ) adaptEvalTC :: [JS] -> [JS] adaptEvalTC js = adaptEvalTC' [] js where adaptEvalTC' :: [JS] -> [JS] -> [JS] adaptEvalTC' front ((JSAlloc "__IDRRT__EVALTC" (Just _)):back) = front ++ (new:back) adaptEvalTC' front (next:back) = adaptEvalTC' (front ++ [next]) back adaptEvalTC' front [] = front new = JSAlloc "__IDRRT__EVALTC" (Just $ JSFunction ["marg0"] ( JSSeq [ JSAlloc "ret" $ Just ( JSTernary ( (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd` (JSProj (JSIdent "marg0") "eval") ) (JSApp (JSProj (JSIdent "marg0") "eval") [JSIdent "marg0"] ) (JSIdent "marg0") ) , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) ( JSAssign (JSIdent "ret") ( JSApp (JSProj (JSIdent "ret") "k") [] ) ) , JSReturn $ JSIdent "ret" ] )) adaptCon js = adaptCon' [] js where adaptCon' front ((JSAnnotation _ (JSAlloc "__IDRRT__Con" _)):back) = front ++ (new:back) adaptCon' front (next:back) = adaptCon' (front ++ [next]) back adaptCon' front [] = front new = JSAnnotation JSConstructor $ JSAlloc "__IDRRT__Con" (Just $ JSFunction newArgs ( JSSeq (map newVar newArgs) ) ) where newVar var = JSAssign (JSProj JSThis var) (JSIdent var) newArgs = ["tag", "eval", "app", "vars"] unfoldLT :: String -> [JS] -> ([Int], [JS]) unfoldLT lt js = let (table, code) = extractLT lt js expanded = expandLT lt table in (map fst expanded, map snd expanded ++ code) expandCons :: [Int] -> [Int] -> [JS] -> [JS] expandCons evals applys js = map expandCons' js where expandCons' :: JS -> JS expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args]) | evalid <- getId "__IDRLT__EVAL" tag evals , applyid <- getId "__IDRLT__APPLY" tag applys = JSNew "__IDRRT__Con" [ JSNum (JSInt tag) , maybe JSNull JSIdent evalid , maybe JSNull JSIdent applyid , JSArray (map expandCons' args) ] expandCons' js = transformJS expandCons' js getId :: String -> Int -> [Int] -> Maybe String getId lt tag entries | tag `elem` entries = Just $ ltIdentifier lt tag | otherwise = Nothing ltIdentifier :: String -> Int -> String ltIdentifier "__IDRLT__EVAL" id = idrLTNamespace ++ "EVAL" ++ show id ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id extractLT :: String -> [JS] -> (JS, [JS]) extractLT lt js = extractLT' ([], js) where extractLT' :: ([JS], [JS]) -> (JS, [JS]) extractLT' (front, js@(JSAlloc fun _):back) | fun == lt = (js, front ++ back) extractLT' (front, js:back) = extractLT' (front ++ [js], back) extractLT' (front, back) = (JSNoop, front ++ back) expandLT :: String -> JS -> [(Int, JS)] expandLT lt ( JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) [])) ) = catMaybes (map expandEntry seq) where expandEntry :: JS -> Maybe (Int, JS) expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) = Just $ (id, JSAlloc (ltIdentifier lt id) (Just body)) expandEntry js = Nothing expandLT lt JSNoop = [] removeInstanceChecks :: JS -> JS removeInstanceChecks (JSCond conds) = JSCond $ eliminateDeadBranches $ map ( removeHelper *** removeInstanceChecks ) conds where removeHelper ( JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check ) = removeHelper check removeHelper js = js eliminateDeadBranches ((JSTrue, cond):_) = [(JSNoop, cond)] eliminateDeadBranches [(_, js)] = [(JSNoop, js)] eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs eliminateDeadBranches [] = [] removeInstanceChecks js = transformJS removeInstanceChecks js reduceLoop :: [String] -> ([JS], [JS]) -> [JS] reduceLoop reduced (cons, program) = case partition findConstructors program of ([], js) -> cons ++ js (candidates, rest) -> let names = reduced ++ map funName candidates in reduceLoop names ( cons ++ map reduce candidates, map (reduceCall names) rest ) where findConstructors :: JS -> Bool findConstructors js | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js = reducable $ last body | otherwise = False where reducable :: JS -> Bool reducable js | JSReturn ret <- js = reducable ret | JSNew _ args <- js = and $ map reducable args | JSArray fields <- js = and $ map reducable fields | JSNum _ <- js = True | JSNull <- js = True | JSIdent _ <- js = True | otherwise = False reduce :: JS -> JS reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) | JSReturn js <- last body = (JSAlloc fun (Just js)) reduce js = js reduceCall :: [String] -> JS -> JS reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( JSReturn (JSApp id@(JSIdent ret) _) )]) | ret `elem` funs = id reduceCall funs js@(JSApp id@(JSIdent fun) _) | fun `elem` funs = id reduceCall funs js = transformJS (reduceCall funs) js extractLocalConstructors :: [JS] -> [JS] extractLocalConstructors js = concatMap extractLocalConstructors' js where globalCons :: [String] globalCons = concatMap (getGlobalCons) js extractLocalConstructors' :: JS -> [JS] extractLocalConstructors' js@(JSAlloc fun (Just (JSFunction args body))) = addCons cons [foldr (uncurry jsSubst) js (reverse cons)] where cons :: [(JS, JS)] cons = zipWith genName (foldJS match (++) [] body) [1..] where genName :: JS -> Int -> (JS, JS) genName js id = (js, JSIdent $ idrCTRNamespace ++ fun ++ "_" ++ show id) match :: JS -> [JS] match js | JSNew "__IDRRT__Con" args <- js , all isConstant args = [js] | otherwise = [] addCons :: [(JS, JS)] -> [JS] -> [JS] addCons [] js = js addCons (con@(_, name):cons) js | sum (map (countOccur name) js) > 0 = addCons cons ((allocCon con) : js) | otherwise = addCons cons js countOccur :: JS -> JS -> Int countOccur ident js = foldJS match (+) 0 js where match :: JS -> Int match js | js == ident = 1 | otherwise = 0 allocCon :: (JS, JS) -> JS allocCon (js, JSIdent name) = JSAlloc name (Just js) isConstant :: JS -> Bool isConstant js | JSNew "__IDRRT__Con" args <- js , all isConstant args = True | otherwise = isJSConstantConstructor globalCons js extractLocalConstructors' js = [js] getGlobalCons :: JS -> [String] getGlobalCons js = foldJS match (++) [] js where match :: JS -> [String] match js | (JSAlloc name (Just (JSNew "__IDRRT__Con" _))) <- js = [name] | otherwise = [] evalCons :: [JS] -> [JS] evalCons js = map (collapseCont . collapseTC . expandProj . evalCons') js where cons :: [(String, JS)] cons = concatMap getGlobalCons js evalCons' :: JS -> JS evalCons' js = transformJS match js where match :: JS -> JS match (JSApp (JSIdent "__IDRRT__EVALTC") [arg]) | JSIdent name <- arg , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons = arg match (JSApp (JSIdent "__IDR__mEVAL0") [arg]) | JSIdent name <- arg , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons = arg match js = transformJS match js lookupConstructor :: String -> [(String, JS)] -> Maybe JS lookupConstructor ctr cons | Just (JSIdent name) <- lookup ctr cons = lookupConstructor name cons | Just con@(JSNew _ _) <- lookup ctr cons = Just con | otherwise = Nothing expandProj :: JS -> JS expandProj js = transformJS match js where match :: JS -> JS match ( JSIndex ( JSProj (JSIdent name) "vars" ) ( JSNum (JSInt idx) ) ) | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons = args !! idx match js = transformJS match js collapseTC :: JS -> JS collapseTC js = transformJS match js where match :: JS -> JS match (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( JSReturn (JSIdent name) )]) | Just _ <- lookup name cons = (JSIdent name) match js = transformJS match js collapseCont :: JS -> JS collapseCont js = transformJS match js where match :: JS -> JS match (JSNew "__IDRRT__Cont" [JSFunction [] ( JSReturn ret@(JSNew "__IDRRT__Cont" [JSFunction [] _]) )]) = collapseCont ret match (JSNew "__IDRRT__Cont" [JSFunction [] ( JSReturn (JSIdent name) )]) = JSIdent name match (JSNew "__IDRRT__Cont" [JSFunction [] ( JSReturn ret@(JSNew "__IDRRT__Con" [_, _, _, JSArray args]) )]) | all collapsable args = ret where collapsable :: JS -> Bool collapsable (JSIdent _) = True collapsable js = isJSConstantConstructor (map fst cons) js match js = transformJS match js getGlobalCons :: JS -> [(String, JS)] getGlobalCons js = foldJS match (++) [] js where match :: JS -> [(String, JS)] match js | (JSAlloc name (Just con@(JSNew "__IDRRT__Con" _))) <- js = [(name, con)] | (JSAlloc name (Just con@(JSIdent _))) <- js = [(name, con)] | otherwise = [] getIncludes :: [FilePath] -> IO [String] getIncludes = mapM readFile codegenJavaScript :: CodeGenerator codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci) (includes ci) (outputFile ci) (outputType ci) codegenNode :: CodeGenerator codegenNode ci = codegenJS_all Node (simpleDecls ci) (includes ci) (outputFile ci) (outputType ci) codegenJS_all :: JSTarget -> [(Name, SDecl)] -> [FilePath] -> FilePath -> OutputType -> IO () codegenJS_all target definitions includes filename outputType = do let (header, rt) = case target of Node -> ("#!/usr/bin/env node\n", "-node") JavaScript -> ("", "-browser") included <- getIncludes includes path <- (++) <$> getDataDir <*> (pure "/jsrts/") idrRuntime <- readFile $ path ++ "Runtime-common.js" tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"] jsbn <- readFile $ path ++ "jsbn/jsbn.js" writeFile filename $ header ++ ( intercalate "\n" $ included ++ runtime jsbn idrRuntime tgtRuntime ++ functions ) setPermissions filename (emptyPermissions { readable = True , executable = target == Node , writable = True }) where def :: [(String, SDecl)] def = map (first translateNamespace) definitions checkForBigInt :: [JS] -> Bool checkForBigInt js = occur where occur :: Bool occur = or $ map (foldJS match (||) False) js match :: JS -> Bool match (JSIdent "__IDRRT__bigInt") = True match (JSNum (JSInteger _)) = True match js = False runtime :: String -> String -> String -> [String] runtime jsbn idrRuntime tgtRuntime = if checkForBigInt optimized then [jsbn, idrRuntime, tgtRuntime] else [idrRuntime, tgtRuntime] optimized :: [JS] optimized = translate >>> optimize $ def where translate p = prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop] optimize p = foldl' (flip ($)) p opt opt = [ removeEval , map inlineJS , removeIDs , reduceJS , map reduceConstants , initConstructors , map removeAllocations , elimDeadLoop , map elimDuplicateEvals , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC" , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC" , map removeInstanceChecks , inlineFunctions , map reduceContinuations , extractLocalConstructors , unfoldLookupTable , evalCons ] functions :: [String] functions = map compileJS optimized prelude :: [JS] prelude = [ JSAnnotation JSConstructor $ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] ( JSAssign (JSProj JSThis "k") (JSIdent "k") )) , JSAnnotation JSConstructor $ JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] ( JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag") , JSAssign (JSProj JSThis "vars") (JSIdent "vars") ] )) ] mainLoop :: JS mainLoop = JSAlloc "main" $ Just $ JSFunction [] ( case target of Node -> mainFun JavaScript -> JSCond [(isReady, mainFun), (JSTrue, jsMeth (JSIdent "window") "addEventListener" [ JSString "DOMContentLoaded", JSFunction [] ( mainFun ), JSFalse ])] ) where mainFun :: JS mainFun = jsTailcall $ jsCall runMain [] isReady :: JS isReady = readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded" readyState :: JS readyState = JSProj (JSIdent "document") "readyState" runMain :: String runMain = idrNamespace ++ translateName (sMN 0 "runMain") invokeLoop :: JS invokeLoop = jsCall "main" [] translateIdentifier :: String -> String translateIdentifier = replaceReserved . concatMap replaceBadChars where replaceBadChars :: Char -> String replaceBadChars c | ' ' <- c = "_" | '_' <- c = "__" | isDigit c = '_' : show (ord c) | not (isLetter c && isAscii c) = '_' : show (ord c) | otherwise = [c] replaceReserved s | s `elem` reserved = '_' : s | otherwise = s reserved = [ "break" , "case" , "catch" , "continue" , "debugger" , "default" , "delete" , "do" , "else" , "finally" , "for" , "function" , "if" , "in" , "instanceof" , "new" , "return" , "switch" , "this" , "throw" , "try" , "typeof" , "var" , "void" , "while" , "with" , "class" , "enum" , "export" , "extends" , "import" , "super" , "implements" , "interface" , "let" , "package" , "private" , "protected" , "public" , "static" , "yield" ] translateNamespace :: Name -> String translateNamespace (UN _) = idrNamespace translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns translateNamespace (MN _ _) = idrNamespace translateNamespace (SN name) = idrNamespace ++ translateSpecialName name translateNamespace NErased = idrNamespace translateName :: Name -> String translateName (UN name) = 'u' : translateIdentifier (str name) translateName (NS name _) = 'n' : translateName name translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i translateName (SN name) = 's' : translateSpecialName name translateName NErased = "e" translateSpecialName :: SpecialName -> String translateSpecialName name | WhereN i m n <- name = 'w' : translateName m ++ translateName n ++ show i | InstanceN n s <- name = 'i' : translateName n ++ concatMap (translateIdentifier . str) s | ParentN n s <- name = 'p' : translateName n ++ translateIdentifier (str s) | MethodN n <- name = 'm' : translateName n | CaseN n <- name = 'c' : translateName n translateConstant :: Const -> JS translateConstant (I i) = JSNum (JSInt i) translateConstant (Fl f) = JSNum (JSFloat f) translateConstant (Ch c) = JSString $ translateChar c translateConstant (Str s) = JSString $ concatMap translateChar s translateConstant (AType (ATInt ITNative)) = JSType JSIntTy translateConstant StrType = JSType JSStringTy translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy translateConstant (AType ATFloat) = JSType JSFloatTy translateConstant (AType (ATInt ITChar)) = JSType JSCharTy translateConstant PtrType = JSType JSPtrTy translateConstant Forgot = JSType JSForgotTy translateConstant (BI i) = jsBigInt $ JSString (show i) translateConstant c = jsError $ "Unimplemented Constant: " ++ show c translateChar :: Char -> String translateChar ch | '\a' <- ch = "\\u0007" | '\b' <- ch = "\\b" | '\f' <- ch = "\\f" | '\n' <- ch = "\\n" | '\r' <- ch = "\\r" | '\t' <- ch = "\\t" | '\v' <- ch = "\\v" | '\SO' <- ch = "\\u000E" | '\DEL' <- ch = "\\u007F" | '\\' <- ch = "\\\\" | '\"' <- ch = "\\\"" | '\'' <- ch = "\\\'" | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "") | otherwise = [ch] where fill :: String -> String fill s = if length s == 1 then '0' : s else s asciiTab = ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL', '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI', '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB', '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US'] translateDeclaration :: (String, SDecl) -> [JS] translateDeclaration (path, SFun name params stackSize body) | (MN _ ap) <- name , (SChkCase var cases) <- body , ap == txt "APPLY" = [ lookupTable "APPLY" [] var cases , jsDecl $ JSFunction ["mfn0", "marg0"] (JSReturn $ JSTernary ( (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd` (hasProp (idrLTNamespace ++ "APPLY") "mfn0") ) (JSApp (JSIndex (JSIdent (idrLTNamespace ++ "APPLY")) (JSProj (JSIdent "mfn0") "tag") ) [JSIdent "mfn0", JSIdent "marg0"] ) JSNull ) ] | (MN _ ev) <- name , (SChkCase var cases) <- body , ev == txt "EVAL" = [ lookupTable "EVAL" [] var cases , jsDecl $ JSFunction ["marg0"] (JSReturn $ JSTernary ( (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd` (hasProp (idrLTNamespace ++ "EVAL") "marg0") ) (JSApp (JSIndex (JSIdent (idrLTNamespace ++ "EVAL")) (JSProj (JSIdent "marg0") "tag") ) [JSIdent "marg0"] ) (JSIdent "marg0") ) ] | otherwise = let fun = translateExpression body in [jsDecl $ jsFun fun] where hasProp :: String -> String -> JS hasProp table var = JSIndex (JSIdent table) (JSProj (JSIdent var) "tag") caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS caseFun aux var cse = let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in jsFunAux aux c getTag :: SAlt -> Maybe Int getTag (SConCase _ tag _ _ _) = Just tag getTag _ = Nothing lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS lookupTable table aux var cases = JSAlloc (idrLTNamespace ++ table) $ Just ( JSApp (JSFunction [] ( JSSeq $ [ JSAlloc "t" $ Just (JSArray []) ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [ JSReturn (JSIdent "t") ] )) [] ) where assignEntries :: [(Int, JS)] -> [JS] assignEntries entries = map (\(tag, fun) -> JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun ) entries lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS) lookupEntry aux var alt = do tag <- getTag alt return (tag, caseFun aux var alt) jsDecl :: JS -> JS jsDecl = JSAlloc (path ++ translateName name) . Just jsFun body = jsFunAux [] body jsFunAux :: [(LVar, String)] -> JS -> JS jsFunAux aux body = JSFunction (p ++ map snd aux) ( JSSeq $ zipWith assignVar [0..] p ++ map assignAux aux ++ [JSReturn body] ) where assignVar :: Int -> String -> JS assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s) assignAux :: (LVar, String) -> JS assignAux (Loc var, val) = JSAlloc (jsVar var) (Just $ JSIdent val) p :: [String] p = map translateName params translateVariableName :: LVar -> String translateVariableName (Loc i) = jsVar i translateExpression :: SExp -> JS translateExpression (SLet name value body) = jsLet (translateVariableName name) ( translateExpression value ) (translateExpression body) translateExpression (SConst cst) = translateConstant cst translateExpression (SV var) = JSVar var translateExpression (SApp tc name vars) | False <- tc = jsTailcall $ translateFunctionCall name vars | True <- tc = JSNew (idrRTNamespace ++ "Cont") [JSFunction [] ( JSReturn $ translateFunctionCall name vars )] where translateFunctionCall name vars = jsCall (translateNamespace name ++ translateName name) (map JSVar vars) translateExpression (SOp op vars) | LNoOp <- op = JSVar (last vars) | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)] | (LPlus (ATInt ITBig)) <- op , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs] | (LMinus (ATInt ITBig)) <- op , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs] | (LTimes (ATInt ITBig)) <- op , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs] | (LSDiv (ATInt ITBig)) <- op , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs] | (LSRem (ATInt ITBig)) <- op , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs] | (LEq (ATInt ITBig)) <- op , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs] | (LSLt (ATInt ITBig)) <- op , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs] | (LSLe (ATInt ITBig)) <- op , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs] | (LSGt (ATInt ITBig)) <- op , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs] | (LSGe (ATInt ITBig)) <- op , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs] | (LPlus ATFloat) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs | (LMinus ATFloat) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs | (LTimes ATFloat) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs | (LSDiv ATFloat) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs | (LEq ATFloat) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs | (LSLt ATFloat) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs | (LSLe ATFloat) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs | (LSGt ATFloat) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs | (LSGe ATFloat) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs | (LPlus _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs | (LMinus _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs | (LTimes _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs | (LSDiv _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs | (LSRem _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs | (LEq _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs | (LSLt _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs | (LSLe _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs | (LSGt _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs | (LSGe _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs | (LAnd _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs | (LOr _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs | (LXOr _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs | (LSHL _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs | (LASHR _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs | (LCompl _) <- op , (arg:_) <- vars = JSPreOp "~" (JSVar arg) | LStrConcat <- op , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs | LStrEq <- op , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs | LStrLt <- op , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs | LStrLen <- op , (arg:_) <- vars = JSProj (JSVar arg) "length" | (LStrInt ITNative) <- op , (arg:_) <- vars = jsCall "parseInt" [JSVar arg] | (LIntStr ITNative) <- op , (arg:_) <- vars = jsCall "String" [JSVar arg] | (LSExt ITNative ITBig) <- op , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg] | (LTrunc ITBig ITNative) <- op , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" [] | (LIntStr ITBig) <- op , (arg:_) <- vars = jsMeth (JSVar arg) "toString" [] | (LStrInt ITBig) <- op , (arg:_) <- vars = jsBigInt $ JSVar arg | LFloatStr <- op , (arg:_) <- vars = jsCall "String" [JSVar arg] | LStrFloat <- op , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg] | (LIntFloat ITNative) <- op , (arg:_) <- vars = JSVar arg | (LFloatInt ITNative) <- op , (arg:_) <- vars = JSVar arg | (LChInt ITNative) <- op , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)" | (LIntCh ITNative) <- op , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg] | LFExp <- op , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg] | LFLog <- op , (arg:_) <- vars = jsCall "Math.log" [JSVar arg] | LFSin <- op , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg] | LFCos <- op , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg] | LFTan <- op , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg] | LFASin <- op , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg] | LFACos <- op , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg] | LFATan <- op , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg] | LFSqrt <- op , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg] | LFFloor <- op , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg] | LFCeil <- op , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg] | LStrCons <- op , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs | LStrHead <- op , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0)) | LStrRev <- op , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')" | LStrIndex <- op , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs) | LStrTail <- op , (arg:_) <- vars = let v = translateVariableName arg in JSApp (JSProj (JSIdent v) "substr") [ JSNum (JSInt 1), JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1)) ] | LNullPtr <- op , (_) <- vars = JSNull where translateBinaryOp :: String -> LVar -> LVar -> JS translateBinaryOp f lhs rhs = JSBinOp f (JSVar lhs) (JSVar rhs) invokeMeth :: LVar -> String -> [LVar] -> JS invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args) translateExpression (SError msg) = jsError msg translateExpression (SForeign _ _ "putStr" [(FString, var)]) = jsCall (idrRTNamespace ++ "print") [JSVar var] translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) = JSBinOp "==" (JSVar var) JSNull translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) = JSBinOp "==" (JSVar lhs) (JSVar rhs) translateExpression (SForeign _ _ "idris_time" []) = JSRaw "(new Date()).getTime()" translateExpression (SForeign _ _ fun args) = JSFFI fun (map generateWrapper args) where generateWrapper (ffunc, name) | FFunction <- ffunc = JSApp ( JSIdent $ idrRTNamespace ++ "ffiWrap" ) [JSIdent $ translateVariableName name] | FFunctionIO <- ffunc = JSApp ( JSIdent $ idrRTNamespace ++ "ffiWrap" ) [JSIdent $ translateVariableName name] generateWrapper (_, name) = JSIdent $ translateVariableName name translateExpression patterncase | (SChkCase var cases) <- patterncase = caseHelper var cases "chk" | (SCase var cases) <- patterncase = caseHelper var cases "cse" where caseHelper var cases param = JSApp (JSFunction [param] ( JSCond $ map (expandCase param . translateCaseCond param) cases )) [JSVar var] expandCase :: String -> (Cond, JS) -> (JS, JS) expandCase _ (RawCond cond, branch) = (cond, branch) expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch) expandCase var (CaseCond caseTy, branch) | ConCase tag <- caseTy = let checkCon = JSIdent var `jsInstanceOf` jsCon checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in (checkCon `jsAnd` checkTag, branch) | TypeCase ty <- caseTy = let checkTy = JSIdent var `jsInstanceOf` jsType checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in (checkTy `jsAnd` checkTag, branch) translateExpression (SCon i name vars) = JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i , JSArray $ map JSVar vars ] translateExpression (SUpdate var@(Loc i) e) = JSAssign (JSVar var) (translateExpression e) translateExpression (SProj var i) = JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i) translateExpression SNothing = JSNull translateExpression e = jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e) data CaseType = ConCase Int | TypeCase JSType | DefaultCase deriving Eq data Cond = CaseCond CaseType | RawCond JS translateCaseCond :: String -> SAlt -> (Cond, JS) translateCaseCond _ cse@(SDefaultCase _) = (CaseCond DefaultCase, translateCase Nothing cse) translateCaseCond var cse@(SConstCase ty _) | StrType <- ty = matchHelper JSStringTy | PtrType <- ty = matchHelper JSPtrTy | Forgot <- ty = matchHelper JSForgotTy | (AType ATFloat) <- ty = matchHelper JSFloatTy | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy where matchHelper :: JSType -> (Cond, JS) matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse) translateCaseCond var cse@(SConstCase cst@(BI _) _) = let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in (RawCond cond, translateCase Nothing cse) translateCaseCond var cse@(SConstCase cst _) = let cond = JSIdent var `jsEq` translateConstant cst in (RawCond cond, translateCase Nothing cse) translateCaseCond var cse@(SConCase _ tag _ _ _) = (CaseCond $ ConCase tag, translateCase (Just var) cse) translateCase :: Maybe String -> SAlt -> JS translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e translateCase (Just var) (SConCase a _ _ vars e) = let params = map jsVar [a .. (a + length vars)] in JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [ JSThis, JSProj (JSIdent var) "vars" ]