{-# LANGUAGE PatternGuards #-} module IRTS.CodegenJava (codegenJava) where import Core.TT hiding (mkApp) import IRTS.BCImp import IRTS.CodegenCommon import IRTS.Java.ASTBuilding import IRTS.Java.JTypes import IRTS.Java.Mangling import IRTS.Lang import IRTS.Simplified import Paths_idris import Util.System import Control.Applicative hiding (Const) import Control.Arrow import Control.Monad import Control.Monad.Error import qualified Control.Monad.Trans as T import Control.Monad.Trans.State import Data.Int import Data.List (foldl', intercalate, isPrefixOf, isSuffixOf) import Data.Maybe (fromJust) import qualified Data.Text as T import qualified Data.Text.IO as TIO import qualified Data.Vector.Unboxed as V import Language.Java.Parser import Language.Java.Pretty import Language.Java.Syntax hiding (Name) import qualified Language.Java.Syntax as J import System.Directory import System.Exit import System.FilePath import System.IO import System.Process ----------------------------------------------------------------------- -- Main function codegenJava :: [(Name, SExp)] -> -- initialization of globals [(Name, SDecl)] -> FilePath -> -- output file name [String] -> -- headers [String] -> -- libs OutputType -> IO () codegenJava globalInit defs out hdrs libs exec = do withTempdir (takeBaseName out) $ \ tmpDir -> do let srcdir = tmpDir "src" "main" "java" createDirectoryIfMissing True srcdir let (Ident clsName) = either error id (mkClassName out) let outjava = srcdir clsName <.> "java" let jout = either error (prettyPrint)-- flatIndent . prettyPrint) (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv) writeFile outjava jout if (exec == Raw) then copyFile outjava (takeDirectory out clsName <.> "java") else do execPom <- getExecutablePom execPomTemplate <- TIO.readFile execPom let execPom = T.replace (T.pack "$MAIN-CLASS$") (T.pack clsName) (T.replace (T.pack "$ARTIFACT-NAME$") (T.pack $ takeBaseName out) (T.replace (T.pack "$DEPENDENCIES$") (mkPomDependencies libs) execPomTemplate ) ) TIO.writeFile (tmpDir "pom.xml") execPom mvnCmd <- getMvn let args = ["-f", (tmpDir "pom.xml")] (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["compile"]) "" when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout) if (exec == Object) then do classFiles <- map (\ clsFile -> tmpDir "target" "classes" clsFile) . filter ((".class" ==) . takeExtension) <$> getDirectoryContents (tmpDir "target" "classes") mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out takeFileName clsFile)) classFiles else do (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) "" when (exit /= ExitSuccess) (error ("FAILURE: " ++ mvnCmd ++ " package\n" ++ err ++ mvout)) copyFile (tmpDir "target" (takeBaseName out) <.> "jar") out handle <- openBinaryFile out ReadMode contents <- TIO.hGetContents handle hClose handle handle <- openBinaryFile out WriteMode TIO.hPutStr handle (T.append (T.pack jarHeader) contents) hFlush handle hClose handle perms <- getPermissions out setPermissions out (setOwnerExecutable True perms) readProcess mvnCmd (args ++ ["clean"]) "" removeFile (tmpDir "pom.xml") ----------------------------------------------------------------------- -- Jar and Pom infrastructure jarHeader :: String jarHeader = "#!/bin/sh\n" ++ "MYSELF=`which \"$0\" 2>/dev/null`\n" ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n" ++ "java=java\n" ++ "if test -n \"$JAVA_HOME\"; then\n" ++ " java=\"$JAVA_HOME/bin/java\"\n" ++ "fi\n" ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\"" ++ "exit 1\n" mkPomDependencies :: [String] -> T.Text mkPomDependencies deps = T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps where mkDependency s = case T.splitOn (T.pack ":") s of [g, a, v] -> [ T.pack $ "\n" , T.append (T.pack " ") $ mkGroupId g , T.append (T.pack " ") $ mkArtifactId a , T.append (T.pack " ") $ mkVersion v , T.pack $ "\n" ] _ -> [] mkGroupId g = T.append (T.pack $ "") (T.append g $ T.pack "\n") mkArtifactId a = T.append (T.pack $ "") (T.append a $ T.pack "\n") mkVersion v = T.append (T.pack $ "") (T.append v $ T.pack "\n") ----------------------------------------------------------------------- -- Code generation environment data CodeGenerationEnv = CodeGenerationEnv { globalVariables :: [(Name, ArrayIndex)] , localVariables :: [[(Int, Ident)]] , localVarCounter :: Int } type CodeGeneration = StateT (CodeGenerationEnv) (Either String) mkCodeGenEnv :: CodeGenerationEnv mkCodeGenEnv = CodeGenerationEnv [] [] 0 varPos :: LVar -> CodeGeneration (Either ArrayIndex Ident) varPos (Loc i) = do vars <- (concat . localVariables) <$> get case lookup i vars of (Just varName) -> return (Right varName) Nothing -> throwError $ "Invalid local variable id: " ++ show i varPos (Glob name) = do vars <- globalVariables <$> get case lookup name vars of (Just varIdx) -> return (Left varIdx) Nothing -> throwError $ "Invalid global variable id: " ++ show name pushScope :: CodeGeneration () pushScope = modify (\ env -> env { localVariables = []:(localVariables env) }) popScope :: CodeGeneration () popScope = do env <- get let lVars = tail $ localVariables env let vC = if null lVars then 0 else localVarCounter env put $ env { localVariables = tail (localVariables env) , localVarCounter = vC } setVariable :: LVar -> CodeGeneration (Either ArrayIndex Ident) setVariable (Loc i) = do env <- get let lVars = localVariables env let getter = localVar $ localVarCounter env let lVars' = ((i, getter) : head lVars) : tail lVars put $ env { localVariables = lVars' , localVarCounter = 1 + localVarCounter env} return (Right getter) setVariable (Glob n) = do env <- get let gVars = globalVariables env let getter = globalContext @! length gVars let gVars' = (n, getter):gVars put (env { globalVariables = gVars' }) return (Left getter) pushParams :: [Ident] -> CodeGeneration () pushParams paramNames = let varMap = zipWith (flip (,)) paramNames [0..] in modify (\ env -> env { localVariables = varMap:(localVariables env) , localVarCounter = (length varMap) + (localVarCounter env) }) flatIndent :: String -> String flatIndent (' ' : ' ' : xs) = flatIndent xs flatIndent (x:xs) = x:flatIndent xs flatIndent [] = [] ----------------------------------------------------------------------- -- Maintaining control structures over code blocks data BlockPostprocessor = BlockPostprocessor { ppInnerBlock :: [BlockStmt] -> Exp -> CodeGeneration [BlockStmt] , ppOuterBlock :: [BlockStmt] -> CodeGeneration [BlockStmt] } ppExp :: BlockPostprocessor -> Exp -> CodeGeneration [BlockStmt] ppExp pp exp = ((ppInnerBlock pp) [] exp) >>= ppOuterBlock pp addReturn :: BlockPostprocessor addReturn = BlockPostprocessor { ppInnerBlock = (\ block exp -> return $ block ++ [jReturn exp]) , ppOuterBlock = return } ignoreResult :: BlockPostprocessor ignoreResult = BlockPostprocessor { ppInnerBlock = (\ block exp -> return block) , ppOuterBlock = return } ignoreOuter :: BlockPostprocessor -> BlockPostprocessor ignoreOuter pp = pp { ppOuterBlock = return } throwRuntimeException :: BlockPostprocessor -> BlockPostprocessor throwRuntimeException pp = pp { ppInnerBlock = (\ blk exp -> return $ blk ++ [ BlockStmt $ Throw ( InstanceCreation [] (toClassType runtimeExceptionType) [exp] Nothing ) ] ) } rethrowAsRuntimeException :: BlockPostprocessor -> BlockPostprocessor rethrowAsRuntimeException pp = pp { ppOuterBlock = (\ blk -> do ex <- ppInnerBlock (throwRuntimeException pp) [] (ExpName $ J.Name [Ident "ex"]) ppOuterBlock pp $ [ BlockStmt $ Try (Block blk) [Catch (FormalParam [] exceptionType False (VarId (Ident "ex"))) $ Block ex ] Nothing ] ) } ----------------------------------------------------------------------- -- File structure mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit mkCompilationUnit globalInit defs hdrs out = do clsName <- mkClassName out CompilationUnit Nothing ( [ ImportDecl False idrisRts True , ImportDecl True idrisPrelude True , ImportDecl False bigInteger False , ImportDecl False runtimeException False ] ++ otherHdrs ) <$> mkTypeDecl clsName globalInit defs where idrisRts = J.Name $ map Ident ["org", "idris", "rts"] idrisPrelude = J.Name $ map Ident ["org", "idris", "rts", "Prelude"] bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"] runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"] otherHdrs = map ( (\ name -> ImportDecl False name False) . J.Name . map (Ident . T.unpack) . T.splitOn (T.pack ".") . T.pack) $ filter (not . isSuffixOf ".h") hdrs ----------------------------------------------------------------------- -- Main class mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl] mkTypeDecl name globalInit defs = (\ body -> [ClassTypeDecl $ ClassDecl [ Public , Annotation $ SingleElementAnnotation (jName "SuppressWarnings") (EVVal . InitExp $ jString "unchecked") ] name [] Nothing [] body]) <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs) mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody mkClassBody globalInit defs = (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs) <$> mkGlobalContext globalInit <*> mapM mkDecl defs mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl] mkGlobalContext [] = return [] mkGlobalContext initExps = do pushScope varInit <- mapM (\ (name, exp) -> do pos <- setVariable (Glob name) mkUpdate ignoreResult (Glob name) exp ) initExps popScope return [ MemberDecl $ FieldDecl [Private, Static, Final] (array objectType) [ VarDecl (VarId $ globalContextID). Just . InitExp $ ArrayCreate objectType [jInt $ length initExps] 0 ] , InitDecl True (Block $ concat varInit) ] addMainMethod :: [Decl] -> [Decl] addMainMethod decls | findMain decls = mkMainMethod : decls | otherwise = decls where findMain ((MemberDecl (MemberClassDecl (ClassDecl _ name _ _ _ (ClassBody body)))):_) | name == mangle' (UN "Main") = findMainMethod body findMain (_:decls) = findMain decls findMain [] = False innerMainMethod = (either error id $ mangle (UN "main")) findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_) | name == mangle' (UN "main") = True findMainMethod (_:decls) = findMainMethod decls findMainMethod [] = False mkMainMethod :: Decl mkMainMethod = simpleMethod [Public, Static] Nothing "main" [FormalParam [] (array stringType) False (VarId $ Ident "args")] $ Block [ BlockStmt . ExpStmt $ call "idris_initArgs" [ (threadType ~> "currentThread") [] , jConst "args" ] , BlockStmt . ExpStmt $ call (mangle' (MN 0 "runMain")) [] ] ----------------------------------------------------------------------- -- Inner classes (idris namespaces) mergeInnerClasses :: [Decl] -> [Decl] mergeInnerClasses = foldl' mergeInner [] where mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls) decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body')))) | name == name' = (MemberDecl $ MemberClassDecl $ ClassDecl priv name targs (mplus ext ext') (imp ++ imp') (ClassBody $ mergeInnerClasses (body ++ body'))) : decls | otherwise = decl:(mergeInner decls decl') mergeInner (decl:decls) decl' = decl:(mergeInner decls decl') mergeInner [] decl' = [decl'] mkDecl :: (Name, SDecl) -> CodeGeneration Decl mkDecl ((NS n (ns:nss)), decl) = (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body) <$> mangle (UN ns) <*> mkClassBody [] [(NS n nss, decl)] mkDecl (_, SFun name params stackSize body) = do (Ident methodName) <- mangle name methodParams <- mapM mkFormalParam params paramNames <- mapM mangle params pushParams paramNames methodBody <- mkExp addReturn body popScope return $ simpleMethod [Public, Static] (Just objectType) methodName methodParams (Block methodBody) mkFormalParam :: Name -> CodeGeneration FormalParam mkFormalParam name = (\ name -> FormalParam [Final] objectType False (VarId name)) <$> mangle name ----------------------------------------------------------------------- -- Expressions -- | Compile a simple expression and use the given continuation to postprocess -- the resulting value. mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt] -- Variables mkExp pp (SV var) = (Nothing <>@! var) >>= ppExp pp -- Applications mkExp pp (SApp pushTail name args) = mkApp pushTail name args >>= ppExp pp -- Bindings mkExp pp (SLet var newExp inExp) = mkLet pp var newExp inExp mkExp pp (SUpdate var newExp) = mkUpdate pp var newExp -- Objects mkExp pp (SCon conId _ args) = mkIdrisObject conId args >>= ppExp pp -- Case expressions mkExp pp (SCase var alts) = mkCase pp True var alts mkExp pp (SChkCase var alts) = mkCase pp False var alts -- Projections mkExp pp (SProj var i) = mkProjection var i >>= ppExp pp -- Constants mkExp pp (SConst c) = ppExp pp $ mkConstant c -- Foreign function calls mkExp pp (SForeign lang resTy text params) = mkForeign pp lang resTy text params -- Primitive functions mkExp pp (SOp LFork [arg]) = (mkThread arg) >>= ppExp pp mkExp pp (SOp LPar [arg]) = (Nothing <>@! arg) >>= ppExp pp mkExp pp (SOp LNoOp args) = (Nothing <>@! (last args)) >>= ppExp pp mkExp pp (SOp op args) = (mkPrimitiveFunction op args) >>= ppExp pp -- Empty expressions mkExp pp (SNothing) = ppExp pp $ Lit Null -- Errors mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err) ----------------------------------------------------------------------- -- Variable access (<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp (<>@!) Nothing var = either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var (<>@!) (Just castTo) var = (castTo <>) <$> (Nothing <>@! var) ----------------------------------------------------------------------- -- Application (wrap method calls in tail call closures) mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp mkApp False name args = (\ methodName params -> (idrisClosureType ~> "unwrapTailCall") [call methodName params] ) <$> mangleFull name <*> mapM (Nothing <>@!) args mkApp True name args = mkMethodCallClosure name args mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp mkMethodCallClosure name args = (\ name args -> closure (call name args)) <$> mangleFull name <*> mapM (Nothing <>@!) args ----------------------------------------------------------------------- -- Updates (change context array) and Let bindings (Update, execute) mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt] mkUpdate pp var exp = mkExp ( pp { ppInnerBlock = (\ blk rhs -> do pos <- setVariable var vExp <- Nothing <>@! var ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp ) } ) exp mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt] mkLet pp var@(Loc pos) newExp inExp = mkUpdate (pp { ppInnerBlock = (\ blk _ -> do inBlk <- mkExp pp inExp return (blk ++ inBlk) ) } ) var newExp mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable" ----------------------------------------------------------------------- -- Object creation mkIdrisObject :: Int -> [LVar] -> CodeGeneration Exp mkIdrisObject conId args = (\ args -> InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing ) <$> mapM (Nothing <>@!) args ----------------------------------------------------------------------- -- Case expressions mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt] mkCase pp checked var cases | isDefaultOnlyCase cases = mkDefaultMatch pp cases | isConstCase cases = do ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases ppOuterBlock pp [BlockStmt ifte] | otherwise = do switchExp <- mkGetConstructorId checked var matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks] isConstCase :: [SAlt] -> Bool isConstCase ((SConstCase _ _):_) = True isConstCase ((SDefaultCase _):cases) = isConstCase cases isConstCase _ = False isDefaultOnlyCase :: [SAlt] -> Bool isDefaultOnlyCase [SDefaultCase _] = True isDefaultOnlyCase [] = True isDefaultOnlyCase _ = False mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt] mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) = do pushScope stmt <- mkExp pp branchExpression popScope return stmt mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs mkDefaultMatch pp [] = ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern") mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp mkMatchConstExp var c | isPrimitive cty = (\ var -> (primFnType ~> opName (LEq undefined)) [var, jc] ~==~ jInt 1) <$> (Just cty <>@! var) | isArray cty = (\ var -> (arraysType ~> "equals") [var, jc]) <$> (Just cty <>@! var) | isString cty = (\ var -> ((primFnType ~> opName (LStrEq)) [var, jc] ~==~ jInt 1)) <$> (Just cty <>@! var) | otherwise = (\ var -> (var ~> "equals") [jc]) <$> (Just cty <>@! var) where cty = constType c jc = mkConstant c mkConstMatch :: BlockPostprocessor -> (BlockPostprocessor -> CodeGeneration [BlockStmt]) -> LVar -> [SAlt] -> CodeGeneration Stmt mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do matchExp <- mkMatchConstExp var constant pushScope branchBlock <- mkExp pp branchExpression popScope otherBranches <- mkConstMatch pp getDefaultStmts var cases return $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases mkConstMatch pp getDefaultStmts _ [] = do defaultBlock <- getDefaultStmts pp return $ StmtBlock (Block defaultBlock) mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp mkGetConstructorId True var = (\ var -> ((idrisObjectType <> var) ~> "getConstructorId") []) <$> (Nothing <>@! var) mkGetConstructorId False var = (\ var match -> Cond (InstanceOf var (toRefType idrisObjectType)) match (jInt (-1)) ) <$> (Nothing <>@! var) <*> mkGetConstructorId True var mkConsMatch :: BlockPostprocessor -> (BlockPostprocessor -> CodeGeneration [BlockStmt]) -> LVar -> [SAlt] -> CodeGeneration [SwitchBlock] mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do pushScope caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression popScope otherBranches <- mkConsMatch pp getDefaultStmts var cases return $ (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases mkConsMatch pp getDefaultStmts _ [] = do defaultBlock <- getDefaultStmts pp return $ [SwitchBlock Default defaultBlock] mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt] mkCaseBinding pp var stackStart params branchExpression = mkExp pp (toLetIn var stackStart params branchExpression) where toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp toLetIn var stackStart members start = foldr (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp) start [0.. (length members - 1)] ----------------------------------------------------------------------- -- Projection (retrieve the n-th field of an object) mkProjection :: LVar -> Int -> CodeGeneration Exp mkProjection var memberNr = (\ var -> ArrayAccess $ ((var ~> "getData") []) @! memberNr) <$> (Just idrisObjectType <>@! var) ----------------------------------------------------------------------- -- Constants mkConstantArray :: (V.Unbox a) => J.Type -> (a -> Const) -> V.Vector a -> Exp mkConstantArray cty elemToConst elems = ArrayCreateInit cty 0 (ArrayInit . map (InitExp . mkConstant . elemToConst) $ V.toList elems) mkConstant :: Const -> Exp mkConstant c@(I x) = constType c <> (Lit . Word $ toInteger x) mkConstant c@(BI x) = bigInteger (show x) mkConstant c@(Fl x) = constType c <> (Lit . Double $ x) mkConstant c@(Ch x) = constType c <> (Lit . Char $ x) mkConstant c@(Str x) = constType c <> (Lit . String $ x) mkConstant c@(B8 x) = constType c <> (Lit . Word $ toInteger x) mkConstant c@(B16 x) = constType c <> (Lit . Word $ toInteger x) mkConstant c@(B32 x) = constType c <> (Lit . Word $ toInteger x) mkConstant c@(B64 x) = (bigInteger (show c) ~> "longValue") [] mkConstant c@(B8V x) = mkConstantArray (constType c) B8 x mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x mkConstant c@(AType x) = ClassLit (Just $ box (constType c)) mkConstant c@(StrType ) = ClassLit (Just $ stringType) mkConstant c@(PtrType ) = ClassLit (Just $ objectType) mkConstant c@(VoidType ) = ClassLit (Just $ voidType) mkConstant c@(Forgot ) = ClassLit (Just $ objectType) ----------------------------------------------------------------------- -- Foreign function calls mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt] mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params mkForeign pp (LANG_JAVA callType) resTy text params | callType <- FStatic = do method <- liftParsed (parser name text) args <- foreignVarAccess params wrapReturn resTy (call method args) | callType <- FObject = do method <- liftParsed (parser ident text) (tgt:args) <- foreignVarAccess params wrapReturn resTy ((tgt ~> (show $ pretty method)) args) | callType <- FConstructor = do clsTy <- liftParsed (parser classType text) args <- foreignVarAccess params wrapReturn resTy (InstanceCreation [] clsTy args Nothing) where foreignVarAccess args = mapM (\ (fty, var) -> (foreignType fty <>@! var)) args pp' = rethrowAsRuntimeException pp wrapReturn FUnit exp = ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp' wrapReturn _ exp = ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp' ----------------------------------------------------------------------- -- Primitive functions mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp mkPrimitiveFunction op args = (\ args -> (primFnType ~> opName op) args) <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op)) mkThread :: LVar -> CodeGeneration Exp mkThread arg = (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (MN 0 "EVAL") [arg]