idris-0.9.9: src/IRTS/CodegenJava.hs
{-# 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 $ "<dependency>\n"
, T.append (T.pack " ") $ mkGroupId g
, T.append (T.pack " ") $ mkArtifactId a
, T.append (T.pack " ") $ mkVersion v
, T.pack $ "</dependency>\n"
]
_ -> []
mkGroupId g = T.append (T.pack $ "<groupId>") (T.append g $ T.pack "</groupId>\n")
mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")
mkVersion v = T.append (T.pack $ "<version>") (T.append v $ T.pack "</version>\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]