{-# 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]


