module IRTS.CodegenJava (codegenJava) where

import           Core.TT
import           IRTS.BCImp
import           IRTS.CodegenCommon
import           IRTS.Lang
import           IRTS.Simplified
import           Paths_idris
import           Util.System

import           Control.Applicative
import           Control.Arrow
import           Control.Monad
import qualified Control.Monad.Trans as T
import           Control.Monad.Trans.State
import           Data.Char
import           Data.Maybe (fromJust)
import           Data.List (isPrefixOf, isSuffixOf, intercalate, foldl')
import           Data.Int
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
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

data CodeGenerationEnv = CodeGenerationEnv { globalVariablePositions :: [(Name, Integer)] }

type CodeGeneration = StateT (CodeGenerationEnv) (Either String)

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 (evalStateT (mkClassName out) (mkCodeGenEnv globalInit))
    let outjava = srcdir </> clsName <.> "java"
    let jout = either error
                      (flatIndent . prettyPrint)
                      (evalStateT (mkCompilationUnit globalInit defs hdrs out) (mkCodeGenEnv globalInit))
    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")

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")

mkCodeGenEnv :: [(Name, SExp)] -> CodeGenerationEnv
mkCodeGenEnv globalInit = 
  CodeGenerationEnv $ zipWith (\ (name, _) pos -> (name, pos)) globalInit [0..]

mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit
mkCompilationUnit globalInit defs hdrs out =
  CompilationUnit Nothing ( [ ImportDecl False idrisRts True
                            , ImportDecl True idrisForeign True
                            , ImportDecl False bigInteger False
                            , ImportDecl False stringBuffer False
                            , ImportDecl False runtimeException False
                            , ImportDecl False scanner False
                            , ImportDecl False arrays False
                            ] ++ otherHdrs
                          )
                          <$> mkTypeDecl globalInit defs out
  where
    idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
    idrisForeign = J.Name $ map Ident ["org", "idris", "rts", "ForeignPrimitives"]
    bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
    stringBuffer = J.Name $ map Ident ["java", "lang", "StringBuffer"]
    runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
    scanner = J.Name $ map Ident ["java", "util", "Scanner"]
    arrays = J.Name $ map Ident ["java", "util", "Arrays"]
    otherHdrs = map ( (\ name -> ImportDecl False name False)
                      . J.Name 
                      . map (Ident . T.unpack) 
                      . T.splitOn (T.pack ".") 
                      . T.pack) 
                $ filter (not . isSuffixOf ".h") hdrs

flatIndent :: String -> String
flatIndent (' ' : ' ' : xs) = flatIndent xs
flatIndent (x:xs) = x:flatIndent xs
flatIndent [] = []

prefixCallNamespaces :: Ident -> SExp -> SExp
prefixCallNamespaces (Ident name) (SApp tail (NS n ns) args) = SApp tail (NS n (name:ns)) args
prefixCallNamespaces name (SLet var e1 e2) = SLet var (prefixCallNamespaces name e1) (prefixCallNamespaces name e2)
prefixCallNamespaces name (SUpdate var e) = SUpdate var (prefixCallNamespaces name e)
prefixCallNamespaces name (SCase var alts) = SCase var (map (prefixCallNamespacesCase name) alts)
prefixCallNamespaces name (SChkCase var alts) = SChkCase var (map (prefixCallNamespacesCase name) alts)
prefixCallNamespaces _ exp = exp

prefixCallNamespacesCase :: Ident -> SAlt -> SAlt
prefixCallNamespacesCase name (SConCase x y n ns e) = SConCase x y n ns (prefixCallNamespaces name e)
prefixCallNamespacesCase name (SConstCase c e) = SConstCase c (prefixCallNamespaces name e)
prefixCallNamespacesCase name (SDefaultCase e) = SDefaultCase (prefixCallNamespaces name e)

prefixCallNamespacesDecl :: Ident -> SDecl -> SDecl
prefixCallNamespacesDecl name (SFun fname args i e) = SFun fname args i (prefixCallNamespaces name e)

mkTypeDecl :: [(Name, SExp)] -> [(Name, SDecl)] -> FilePath -> CodeGeneration [TypeDecl]
mkTypeDecl globalInit defs out =
  (\ name body -> [ClassTypeDecl $ ClassDecl [ Public
                                             ,  Annotation $ SingleElementAnnotation 
                                                             (J.Name [Ident "SuppressWarnings"])
                                                             (EVVal . InitExp . Lit $ String "unchecked")
                                             ] 
                                             name 
                                             [] 
                                             Nothing 
                                             [] 
                                             body])
  <$> mkClassName out
  <*> ( mkClassName out 
        >>= (\ ident -> mkClassBody globalInit (map (second (prefixCallNamespacesDecl ident)) defs))
      )

mkClassName :: FilePath -> CodeGeneration Ident
mkClassName path =
  T.lift $ left (\ err -> "Parser error in \"" ++ path ++ "\": " ++ (show err))
                (parser ident . takeBaseName $ takeFileName path)

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 = 
  (\ exps -> [ MemberDecl $ FieldDecl [Private, Static, Final] 
                                      objectArrayType 
                                      [VarDecl (VarId $ Ident "globalContext") 
                                               (Just . InitArray $ ArrayInit exps)               
                                      ]
             ]
  )
  <$> mapM (\ (_, exp) -> InitExp <$> mkExp exp) initExps

  

addMainMethod :: [Decl] -> [Decl]
addMainMethod decls
  | findMain decls = mkMainMethod : decls
  | otherwise = decls
  where
    findMain ((MemberDecl (MemberClassDecl (ClassDecl _ (Ident "Main") _ _ _ (ClassBody body)))):_) =
      findMainMethod body
    findMain (_:decls) = findMain decls
    findMain [] = False

    findMainMethod ((MemberDecl (MethodDecl _ _ _ (Ident "main") [] _ _)):_) = True
    findMainMethod (_:decls) = findMainMethod decls
    findMainMethod [] = False

mkMainMethod :: Decl
mkMainMethod = 
  MemberDecl $ MethodDecl [Public, Static] 
                          [] 
                          Nothing 
                          (Ident "main") 
                          [FormalParam [] stringArrayType False (VarId $ Ident "args")]
                          [] 
                          (MethodBody . Just $ Block [ BlockStmt . ExpStmt . MethodInv $
                                                                 MethodCall (J.Name [Ident "idris_initArgs"])
                                                                            [ MethodInv $ TypeMethodCall
                                                                                        (J.Name [Ident "Thread"])
                                                                                        []
                                                                                        (Ident "currentThread")
                                                                                        []
                                                                            , ExpName $ J.Name [Ident "args"]
                                                                            ]           
                                                     , BlockStmt . ExpStmt . MethodInv $
                                                                 MethodCall (J.Name [Ident "runMain_0"])
                                                                            []
                                                     ]
                          )

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']


mkIdentifier :: Name -> CodeGeneration Ident
mkIdentifier (NS name _) = mkIdentifier name
mkIdentifier (MN i name) = (\ (Ident x) -> Ident $ x ++ ('_' : show i))
                           <$> mkIdentifier (UN name)
mkIdentifier (UN name) =
  T.lift $ left (\ err -> "Parser error in \"" ++ name ++ "\": " ++ (show err))
                ( parser ident
                . cleanReserved
                . cleanNonLetter
                . cleanStart
                $ cleanWs False name)
  where
    cleanStart (x:xs)
      | isNumber x = '_' : (x:xs)
      | otherwise = (x:xs)
    cleanStart [] = []
    cleanNonLetter (x:xs)
      | x == '#' = "_Hash" ++ cleanNonLetter xs
      | x == '@' = "_At" ++ cleanNonLetter xs
      | x == '$' = "_Dollar" ++ cleanNonLetter xs
      | x == '!' = "_Bang" ++ cleanNonLetter xs
      | x == '.' = "_Dot" ++ cleanNonLetter xs
      | x == '\'' = "_Prime" ++ cleanNonLetter xs
      | x == '*' = "_Times" ++ cleanNonLetter xs
      | x == '+' = "_Plus" ++ cleanNonLetter xs
      | x == '/' = "_Divide" ++ cleanNonLetter xs
      | x == '-' = "_Minus" ++ cleanNonLetter xs
      | x == '%' = "_Mod" ++ cleanNonLetter xs
      | x == '<' = "_LessThan" ++ cleanNonLetter xs
      | x == '=' = "_Equals" ++ cleanNonLetter xs
      | x == '>' = "_MoreThan" ++ cleanNonLetter xs
      | x == '[' = "_LSBrace" ++ cleanNonLetter xs
      | x == ']' = "_RSBrace" ++ cleanNonLetter xs
      | x == '(' = "_LBrace" ++ cleanNonLetter xs
      | x == ')' = "_RBrace" ++ cleanNonLetter xs
      | x == '_' = "__" ++ cleanNonLetter xs
      | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs
      | otherwise = x:cleanNonLetter xs
    cleanNonLetter [] = []
    cleanWs capitalize (x:xs)
      | isSpace x  = cleanWs True xs
      | capitalize = (toUpper x) : (cleanWs False xs)
      | otherwise  = x : (cleanWs False xs)
    cleanWs _ [] = []


    cleanReserved "param" = "_param"
    cleanReserved "globalContext" = "_globalContext"
    cleanReserved "context" = "_context"
    cleanReserved "newcontext" = "_newcontext"

    cleanReserved "void" = "_void"
    cleanReserved "null" = "_null"
    cleanReserved "int" = "_int"
    cleanReserved "long" = "_long"
    cleanReserved "char" = "_char"
    cleanReserved "byte" = "_byte"
    cleanReserved "double" = "_double"
    cleanReserved "float" = "_float"
    cleanReserved "boolean" = "_boolean"
    cleanReserved "Object" = "_Object"
    cleanReserved "String" = "_String"
    cleanReserved "StringBuilder" = "_StringBuilder"
    cleanReserved "StringBuffer" = "_StringBuffer"
    cleanReserved "Scanner" = "_Scanner"
    cleanReserved "Integer" = "_Integer"
    cleanReserved "Double" = "_Double"
    cleanReserved "Byte" = "_Byte"
    cleanReserved "Character" = "_Character"
    cleanReserved "BigInteger" = "_BigInteger"
    cleanReserved "Boolean" = "_Boolean"
    cleanReserved "Closure" = "_Closure"
    cleanReserved "IdrisObject" = "_IdrisObject"
    cleanReserved "TailCallClosure" = "_TailCallClosure"
    cleanReserved "System" = "_System"
    cleanReserved "Math" = "_Math"
    cleanReserved "Arrays" = "_Arrays"
    cleanReserved "RuntimeException" = "_RuntimeException"
    cleanReserved "Comparable" = "_Comparable"

    cleanReserved "class" = "_class"
    cleanReserved "enum" = "_enum"
    cleanReserved "interface" = "_interface"
    cleanReserved "extends" = "_extends"
    cleanReserved "implements" = "_implements"
    cleanReserved "public" = "_public"
    cleanReserved "private" = "_private"
    cleanReserved "protected" = "_protected"
    cleanReserved "static" = "_static"
    cleanReserved "final" = "_final"
    cleanReserved "abstract" = "_abstract"
    cleanReserved "strict" = "_strict"
    cleanReserved "volatile" = "_volatile"
    cleanReserved "transient" = "_transient"
    cleanReserved "native" = "_native"
    cleanReserved "const" = "_const"

    cleanReserved "import" = "_import"
    cleanReserved "package" = "_package"

    cleanReserved "throw" = "_throw"
    cleanReserved "throws" = "_throws"
    cleanReserved "try" = "_try"
    cleanReserved "catch" = "_catch"

    cleanReserved "synchronized" = "_synchronized"

    cleanReserved "if" = "_if"
    cleanReserved "else" = "_else"
    cleanReserved "switch" = "_switch"
    cleanReserved "case" = "_case"
    cleanReserved "default" = "_default"

    cleanReserved "while" = "_while"
    cleanReserved "for" = "_for"
    cleanReserved "do" = "_do"
    cleanReserved "break" = "_break"
    cleanReserved "continue" = "_continue"
    cleanReserved "goto" = "_goto"

    cleanReserved "this" = "_this"
    cleanReserved "super" = "_super"
    cleanReserved "new" = "_new"
    cleanReserved "return" = "_return"

    cleanReserved "idris_initArgs" = "_idris_initArgs"
    cleanReserved "idris_numArgs" = "_idris_numArgs"
    cleanReserved "idris_getArg" = "_idris_getArg"
    cleanReserved "getenv" = "_getenv"
    cleanReserved "exit" = "_exit"
    cleanReserved "usleep" = "_usleep"
    cleanReserved "idris_sendMessage" = "_idris_sendMessage"
    cleanReserved "idris_checkMessage" = "_idris_checkMessage"
    cleanReserved "idris_recvMessage" = "_idris_recvMessage"
    cleanReserved "putStr" = "_putStr"
    cleanReserved "putchar" = "_putchar"
    cleanReserved "getchar" = "_getchar"
    cleanReserved "fileOpen" = "_fileOpen"
    cleanReserved "fileClose" = "_fileClose"
    cleanReserved "fputStr" = "_fputStr"
    cleanReserved "fileEOF" = "_fileEOF"
    cleanReserved "isNull" = "_isNull"
    cleanReserved "idris_K" = "_idris_K"
    cleanReserved "idris_flipK" = "_idris_flipK"
    cleanReserved "idris_assignStack" = "_idris_assignStack"
    cleanReserved "free" = "_free"
    cleanReserved "malloc" = "_malloc"
    cleanReserved "idris_memset" = "_idris_memset"
    cleanReserved "idris_peek" = "_idris_peek"
    cleanReserved "idris_poke" = "_idris_poke"
    cleanReserved "idris_memmove" = "_idris_memmove"

    cleanReserved x = x

mkName :: Name -> CodeGeneration J.Name
mkName (NS name nss) = (\ n ns -> J.Name (n:ns))
                       <$> mkIdentifier name
                       <*> mapM (mkIdentifier . UN) nss
mkName n = J.Name . (:[]) <$> mkIdentifier n

voidType :: ClassType
voidType = ClassType [(Ident "Void", [])]

objectType :: ClassType
objectType = ClassType [(Ident "Object", [])]

objectArrayType :: Language.Java.Syntax.Type
objectArrayType = RefType . ArrayType . RefType . ClassRefType $ objectType

idrisClosureType :: ClassType
idrisClosureType = ClassType [(Ident "Closure", [])]

idrisTailCallClosureType :: ClassType
idrisTailCallClosureType = ClassType [(Ident "TailCallClosure", [])]

idrisObjectType :: ClassType
idrisObjectType = ClassType [(Ident "IdrisObject", [])]

contextArray :: LVar -> Exp
contextArray (Loc _) = ExpName $ J.Name [Ident "context"]
contextArray (Glob _) = ExpName $ J.Name [Ident "globalContext"]

charType :: ClassType
charType = ClassType [(Ident "Character", [])]

byteType :: ClassType
byteType = ClassType [(Ident "Byte", [])]

shortType :: ClassType
shortType = ClassType [(Ident "Short", [])]

integerType :: ClassType
integerType = ClassType [(Ident "Integer", [])]

longType :: ClassType
longType = ClassType [(Ident "Long", [])]

nextIntTy :: IntTy -> IntTy
nextIntTy IT8 = IT16
nextIntTy IT16 = IT32
nextIntTy IT32 = IT64
nextIntTy IT64 = IT64
nextIntTy ITNative = IT64

intTyToIdent :: IntTy -> Ident
intTyToIdent IT8  = Ident "Byte"
intTyToIdent IT16 = Ident "Short"
intTyToIdent IT32 = Ident "Integer"
intTyToIdent IT64 = Ident "Long"
intTyToIdent ITNative = Ident "Integer"
intTyToIdent ITBig = Ident "BigInteger"

intTyToClass :: IntTy -> ClassType
intTyToClass ty = ClassType [(intTyToIdent ty, [])]

intTyToMethod :: IntTy -> String
intTyToMethod IT8  = "byteValue"
intTyToMethod IT16 = "shortValue"
intTyToMethod IT32 = "intValue"
intTyToMethod IT64 = "longValue"
intTyToMethod ITNative = "intValue"

intTyToPrimTy :: IntTy -> PrimType
intTyToPrimTy IT8  = ByteT
intTyToPrimTy IT16 = ShortT
intTyToPrimTy IT32 = IntT
intTyToPrimTy IT64 = LongT
intTyToPrimTy ITNative = IntT

bigIntegerType :: ClassType
bigIntegerType = ClassType [(Ident "BigInteger", [])]

doubleType :: ClassType
doubleType = ClassType [(Ident "Double", [])]

stringType :: ClassType
stringType = ClassType [(Ident "String", [])]

stringArrayType :: Language.Java.Syntax.Type
stringArrayType = RefType . ArrayType . RefType . ClassRefType $ stringType

exceptionType :: ClassType
exceptionType = ClassType [(Ident "Throwable", [])]

runtimeExceptionType :: ClassType
runtimeExceptionType = ClassType [(Ident "RuntimeException", [])]

comparableType :: ClassType
comparableType = ClassType [(Ident "Comparable", [])]

mkDecl :: (Name, SDecl) -> CodeGeneration Decl
mkDecl ((NS n (ns:nss)), decl) =
  (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
  <$> mkIdentifier (UN ns)
  <*> mkClassBody [] [(NS n nss, decl)]
mkDecl (_, SFun name params stackSize body) =
  (\ name params paramNames methodBody ->
     MemberDecl $ MethodDecl [Public, Static]
                             []
                             (Just . RefType $ ClassRefType objectType)
                             name
                             params
                             []
                             (MethodBody . Just $ Block 
                                           [ LocalVars [Final]
                                                       objectArrayType
                                                       [ VarDecl (VarDeclArray . VarId $ Ident "context")
                                                                 (Just . InitArray . ArrayInit $
                                                                       paramNames 
                                                                       ++ replicate stackSize (InitExp . Lit $ Null))
                                                       ]
                                           , BlockStmt . Return $ Just methodBody
                                           ]
                             )
  )
  <$> mkIdentifier name
  <*> mapM mkFormalParam params
  <*> mapM (\ p -> (InitExp . ExpName) <$> mkName p) params
  <*> mkExp body


mkClosure :: [Name] -> Int -> SExp -> CodeGeneration Exp
mkClosure params stackSize body =
  (\ paramArray body -> 
     InstanceCreation [] 
                      idrisClosureType 
                      [paramArray]
                      (Just $ ClassBody [body])
  )
  <$> mkStackInit params stackSize
  <*> mkClosureCall body

mkFormalParam :: Name -> CodeGeneration FormalParam
mkFormalParam name =
  (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name))
  <$> mkIdentifier name

mkClosureCall :: SExp -> CodeGeneration Decl
mkClosureCall body =
  (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body)
  <$> mkMethodBody body

mkMethodBody :: SExp -> CodeGeneration MethodBody
mkMethodBody exp =
  (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp])
  <$> mkExp exp

mkStackInit :: [Name] -> Int -> CodeGeneration Exp
mkStackInit params stackSize =
  (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $
                  (map (InitExp . ExpName) localVars)
                  ++ (replicate (stackSize) (InitExp $ Lit Null)))
  <$> mapM mkName params

mkK :: Exp -> Exp -> Exp
mkK result drop = 
  MethodInv $ MethodCall (J.Name [Ident "idris_K"]) [ result, drop ]

mkFlipK :: Exp -> Exp -> Exp
mkFlipK drop result = 
  MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ]

mkLet :: LVar -> SExp -> SExp -> CodeGeneration Exp
mkLet (Loc pos) oldExp newExp =
  (\ oldExp newExp ->
     mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"])
                                              (Lit $ Int (toInteger pos)))
                      EqualA
                      newExp
             )
             oldExp
  )
  <$> mkExp oldExp
  <*> mkExp newExp
mkLet (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"

reverseNameSpace :: J.Name -> J.Name
reverseNameSpace (J.Name ids) =
  J.Name ((tail ids) ++ [head ids])

mkCase :: Bool -> LVar -> [SAlt] -> CodeGeneration Exp
mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression):cases) =
  mkConsCase checked
             var
             parentStackPos 
             consIndex 
             params 
             branchExpression
             (SCase var cases)
mkCase checked var (c@(SConstCase constant branchExpression):cases) =
  (\ constant branchExpression alternative var-> 
     Cond ( MethodInv $ PrimaryMethodCall (constant)
                                          []
                                          (Ident "equals")
                                          [var]
          )
          branchExpression
          alternative
  )
  <$> mkExp (SConst constant)
  <*> mkExp branchExpression
  <*> mkCase checked var cases
  <*> mkVarAccess Nothing var
mkCase checked var (SDefaultCase exp:cases) = mkExp exp
mkCase checked  _ [] = mkExp (SError "Non-exhaustive pattern")

mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> CodeGeneration Exp
mkConsCase checked
           toDeconstruct
           parentStackStart 
           consIndex 
           params 
           branchExpression 
           alternative =
  (\ caseBinding alternative var varCasted-> 
     Cond (BinOp (InstanceOf (var) 
                             (ClassRefType idrisObjectType)
                 )
                 CAnd
                 ( BinOp
                   ( MethodInv $ PrimaryMethodCall (varCasted)
                                                   []
                                                   (Ident "getConstructorId")
                                                   []
                   )
                   Equal
                   (Lit $ Int (toInteger consIndex))
                 )
          )
          (caseBinding)
          alternative
  )
  <$> mkCaseBinding checked toDeconstruct parentStackStart params branchExpression
  <*> mkExp alternative
  <*> mkVarAccess (Nothing) toDeconstruct
  <*> mkVarAccess (Just idrisObjectType) toDeconstruct


mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> CodeGeneration Exp
mkCaseBinding True  var parentStackStart params branchExpression =
  (\ branchExpression deconstruction -> 
     mkFlipK (MethodInv $ MethodCall (J.Name [Ident "idris_assignStack"])
             ( (ExpName $ J.Name [Ident "context"])
               : (Lit $ Int (toInteger parentStackStart))
               : deconstruction
             ))
             (branchExpression)
  )
  <$> mkExp branchExpression
  <*> mkCaseBindingDeconstruction var params
mkCaseBinding False var parentStackStart params branchExpression =
  (\ bindingMethod deconstruction ->
     MethodInv $ PrimaryMethodCall 
               ( MethodInv $ PrimaryMethodCall (InstanceCreation []
                                                                 (ClassType [(Ident "Object", [])])
                                                                 []
                                                                 (Just $ ClassBody [MemberDecl $ bindingMethod])
                                               )
                                               []
                                               (Ident "apply")
                                               ( contextArray (Loc undefined) : deconstruction )
               )
               []
               (Ident "call")
               []
  )
  <$> mkCaseBindingMethod parentStackStart params branchExpression
  <*> mkCaseBindingDeconstruction var params

mkCaseBindingDeconstruction :: LVar -> [Name] -> CodeGeneration [Exp]
mkCaseBindingDeconstruction var members =
  mapM (mkProjection var) ([0..(length members - 1)])

mkCaseBindingMethod :: Int -> [Name] -> SExp -> CodeGeneration MemberDecl
mkCaseBindingMethod parentStackStart params branchExpression =
  (\ formalParams caseBindingStack branchExpression -> 
     MethodDecl [Final, Public]
                []
                (Just . RefType $ ClassRefType idrisClosureType)
                (Ident "apply")
                (mkContextParam:formalParams)
                []
                (MethodBody . Just . Block $
                              caseBindingStack ++
                              [BlockStmt . Return $ Just branchExpression]))
  <$> mapM mkFormalParam params
  <*> mkBindingStack False parentStackStart params
  <*> mkBindingClosure branchExpression

mkContextParam :: FormalParam
mkContextParam = 
  FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))

mkBindingClosure :: SExp -> CodeGeneration Exp
mkBindingClosure oldExp =
  (\ oldCall -> 
     InstanceCreation [] 
                      idrisClosureType
                      [ ExpName $ J.Name [Ident "new_context"] ]
                      (Just $ ClassBody [oldCall])
  )
  <$> mkClosureCall oldExp


mkBindingStack :: Bool -> Int -> [Name] -> CodeGeneration [BlockStmt]
mkBindingStack checked parentStackStart params =
  (\ paramNames ->
    ( LocalVars [Final]
                objectArrayType
                [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
                          (Just . InitExp $ mkContextCopy checked parentStackStart params)
                ])
    : ( map (\ (param, pos) ->
               BlockStmt . ExpStmt $
                         Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"])
                                                       (Lit $ Int (toInteger pos)))
                                EqualA
                                (ExpName param)) $ zip paramNames [parentStackStart..]
      )
  ) 
  <$> mapM mkName params

mkContextCopy :: Bool -> Int -> [Name] -> Exp
mkContextCopy True parentStackStart params =
  MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"])
                                []
                                (Ident "clone")
                                []
mkContextCopy False parentStackStart params =
  MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"])
                             []
                             (Ident "copyOf")
                             [ ExpName $ J.Name [Ident "context"]
                             , MethodInv
                             $ TypeMethodCall (J.Name [Ident "Math"])
                                 []
                                 (Ident "max")
                                 [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"])
                                                                    (Ident "length")
                                 , Lit . Int $ toInteger (parentStackStart + length params)
                                 ]
                             ]

mkProjection :: LVar -> Int -> CodeGeneration Exp
mkProjection var memberNr =
  (\ var -> ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall
                                                   (var)
                                                   []
                                                   (Ident "getData")
                                                   []
                                     )
                                     (Lit $ Int (toInteger memberNr))
  )
  <$> mkVarAccess (Just idrisObjectType) var

type ClassName = String

mkPrimitive :: ClassName -> Literal -> Exp
mkPrimitive className value = 
  MethodInv $ TypeMethodCall (J.Name [Ident className]) 
                             []
                             (Ident "valueOf")
                             [Lit $ value]

mkClass :: ClassType -> Exp
mkClass classType =
  ClassLit . Just . RefType .ClassRefType $ classType

mkBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
mkBinOpExp castTo op (var:vars) = do
  start <- mkVarAccess (Just castTo) var
  foldM (\ exp var -> BinOp exp op <$> mkVarAccess (Just castTo) var) start vars

mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) = do
  start <- (mkVarAccess (Just castTo) var) 
  foldM (\ exp var -> resultTransformation 
                        . BinOp (opTransformation exp) op 
                        . opTransformation 
                        <$> mkVarAccess (Just castTo) var) 
        start
        vars

mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])]) op args =
  mkBinOpExpTrans (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls]) 
                                                       [] 
                                                       (Ident fromMethodName) 
                                                       [exp]
                  ) 
                  (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls]) 
                                                       [] 
                                                       (Ident "valueOf") 
                                                       [Cast (PrimType $ toType) exp]
                  )
                  fromType
                  op 
                  args

mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
mkLogicalBinOpExp castTo op (var:vars) = do
  start <- mkVarAccess (Just castTo) var
  foldM (\ exp var -> mkBoolToNumber castTo . BinOp exp op <$> mkVarAccess (Just castTo) var) 
        start
        vars

mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
mkMethodOpChain1 = mkMethodOpChain id

mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) = do
  start <- initialTransformation <$> mkVarAccess (Just $ castTo) arg
  foldM (\ exp arg' -> 
           resultTransformation 
           . MethodInv 
           . PrimaryMethodCall exp [] (Ident method)
           . (:[])
           <$> mkVarAccess (Just $ castTo) arg'
        )
        start
        args

mkBoolToNumber :: ClassType -> Exp -> Exp
mkBoolToNumber (ClassType [(Ident name, [])]) boolExp =
  Cond boolExp (mkPrimitive name (Int 1)) (mkPrimitive name (Int 0))

mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var = do
  (\ var sext -> 
     MethodInv $ TypeMethodCall (J.Name [toTypeName])
                                []
                                (Ident "valueOf")
                                [ Cond ( BinOp (var)
                                               LThan
                                               (Lit $ Int 0)
                                       )
                                       ( BinOp (Lit $ Int (2^bits))
                                               Add
                                               (sext)
                                       )
                                       sext
                                ]
   )
  <$> mkVarAccess (Just $ fromType) var
  <*> mkSignedExt' toMethod fromType var
  
mkSignedExt :: String -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
mkSignedExt toMethod fromType (ClassType [(toTypeName, [])]) var =
  (\ sext -> MethodInv $ TypeMethodCall (J.Name [toTypeName])
                                        []
                                        (Ident "valueOf")
                                        [ sext ]
  )
  <$> mkSignedExt' toMethod fromType var

mkSignedExt' :: String -> ClassType -> LVar -> CodeGeneration Exp
mkSignedExt' toMethod fromType var =
  (\ var -> MethodInv $ PrimaryMethodCall (var)
                                          [] 
                                          (Ident toMethod)
                                          []
  )
  <$> mkVarAccess (Just $ fromType) var

data SPartialOrder
  = SLt
  | SLe
  | SEq
  | SGe
  | SGt

mkPartialOrder :: SPartialOrder -> Exp -> Exp
mkPartialOrder SLt x = (BinOp (Lit $ Int (-1)) Equal x)
mkPartialOrder SLe x = 
  BinOp (BinOp (Lit $ Int (-1)) Equal x)
        COr
        (BinOp (Lit $ Int 0) Equal x)
mkPartialOrder SEq x = BinOp (Lit $ Int 0) Equal x
mkPartialOrder SGe x =
  BinOp (BinOp (Lit $ Int 1) Equal x)
        COr
        (BinOp (Lit $ Int 0) Equal x)
mkPartialOrder SGt x = (BinOp (Lit $ Int 1) Equal x)

varPos :: LVar -> CodeGeneration Integer
varPos (Loc i) = return (toInteger i)
varPos (Glob name) = do
  positions <- globalVariablePositions <$> get
  case lookup name positions of
    (Just pos) -> return pos
    Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name

mkVarAccess :: Maybe ClassType -> LVar -> CodeGeneration Exp
mkVarAccess Nothing var = 
  (\ pos -> ArrayAccess $ ArrayIndex (contextArray var) (Lit $ Int pos)) 
  <$> varPos var
mkVarAccess (Just castTo) var = 
  Cast (RefType . ClassRefType $ castTo) <$> (mkVarAccess Nothing var)

mkPrimitiveCast :: ClassType -> ClassType -> LVar -> CodeGeneration Exp
mkPrimitiveCast fromType (ClassType [(toType, [])]) var =
  (\ var -> 
     MethodInv $ TypeMethodCall (J.Name [toType])
                                []
                                (Ident "valueOf")
                                [var]
  )
  <$> mkVarAccess (Just fromType) var

mkToString :: ClassType -> LVar -> CodeGeneration Exp
mkToString castTo var =
  (\ var -> MethodInv $ PrimaryMethodCall (var)
                                          []
                                          (Ident "toString")
                                          []
  )
  <$> mkVarAccess (Just castTo) var
data Std = In | Out | Err

instance Show Std where
  show In = "in"
  show Out = "out"
  show Err = "err"

mkSystemStd :: Std -> Exp
mkSystemStd std = FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "System"]) (Ident $ show std)

mkSystemOutPrint :: Exp -> Exp
mkSystemOutPrint value =
  MethodInv $ PrimaryMethodCall (mkSystemStd Out)
                                []
                                (Ident "print")
                                [value]

mkMathFun :: String -> LVar -> CodeGeneration Exp
mkMathFun funName var =
  (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
                                       []
                                       (Ident "valueOf")
                                       [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"])
                                                                    []
                                                                    (Ident funName)
                                                                    [var]
                                       ]
  )
  <$> mkVarAccess (Just doubleType) var

mkStringAtIndex :: LVar -> Exp -> CodeGeneration Exp
mkStringAtIndex var indexExp =
  (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Integer"]) 
                                       []
                                       (Ident "valueOf")
                                       [ MethodInv $ PrimaryMethodCall (var)
                                                                       []
                                                                       (Ident "charAt")
                                                                       [indexExp]
                                       ]
  )
  <$> mkVarAccess (Just stringType) var

mkForeignType :: FType -> Maybe ClassType
mkForeignType (FInt ty) = return (intTyToClass ty)
mkForeignType FChar = return integerType
mkForeignType FString = return stringType
mkForeignType FPtr = return objectType
mkForeignType FDouble = return doubleType
mkForeignType FAny = return objectType
mkForeignType FUnit = Nothing

mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp
mkForeignVarAccess (FInt ty) var = 
  (\ var -> MethodInv $ PrimaryMethodCall var
                                          []
                                          (Ident (intTyToMethod ty))
                                          []
  )
  <$> mkVarAccess (Just $ intTyToClass ty) var
mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess (FInt IT32) var
mkForeignVarAccess FDouble var = 
  (\ var -> MethodInv $ PrimaryMethodCall (var)
                                          []
                                          (Ident "doubleValue")
                                          []
  )
  <$> mkVarAccess (Just doubleType) var
mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var 
 
mkFromForeignType :: FType -> Exp -> Exp
mkFromForeignType (FInt ty) from = 
  MethodInv $ TypeMethodCall (J.Name [intTyToIdent ty])
                             []
                             (Ident "valueOf")
                             [from]
mkFromForeignType FChar from = mkFromForeignType (FInt IT32) from
mkFromForeignType FDouble from =   
  MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
                             []
                             (Ident "valueOf")
                             [from]
mkFromForeignType _ from = from

mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> CodeGeneration Exp
mkForeignInvoke fType method args =
  (\ foreignInvokeMeth -> 
     MethodInv $ PrimaryMethodCall (InstanceCreation [] 
                                                     objectType 
                                                     [] 
                                                     (Just $ ClassBody [ MemberDecl $ foreignInvokeMeth ])
                                   )
                                   []
                                   (Ident "foreignInvoke")
                                   []
  )
  <$> mkForeignInvokeMethod fType method args


mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> CodeGeneration MemberDecl 
mkForeignInvokeMethod fType method args =
  (\ tryBlock -> 
    MethodDecl [Public, Final]
               []
               (Just . RefType $ ClassRefType objectType)
               (Ident "foreignInvoke")
               []
               []
               (MethodBody . Just $ Block 
                             [ BlockStmt 
                               $ Try tryBlock
                                   [ Catch (FormalParam [] 
                                                        (RefType $ ClassRefType exceptionType)
                                                        False
                                                        (VarId $ Ident "ex")
                                           )
                                           (Block [ BlockStmt 
                                                    . Throw
                                                    $ InstanceCreation []
                                                                       runtimeExceptionType
                                                                       [ExpName $ J.Name [Ident "ex"]]
                                                                       Nothing
                                                  ]
                                           )
                                   ]
                                   Nothing
                             ]
               )
  )
 <$> mkForeignInvokeTryBlock fType method args


mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> CodeGeneration Block
mkForeignInvokeTryBlock FUnit method args =
  (\ method args -> Block [ BlockStmt . ExpStmt . MethodInv $ MethodCall method args
                          , BlockStmt $ Return (Just $ Lit Null)
                          ]
  )
  <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
                 (parser name method)
      )
  <*> mapM (uncurry mkForeignVarAccess) args
mkForeignInvokeTryBlock fType method args =
  (\ method args -> Block [ BlockStmt . Return 
                                 . Just 
                                 . mkFromForeignType fType
                                 . MethodInv 
                                 $ MethodCall method args
                          ]
  )
  <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
                      (parser name method)
      )
  <*> mapM (uncurry mkForeignVarAccess) args

mkMethodClosure :: Name -> [LVar] -> CodeGeneration Exp
mkMethodClosure name args =
  (\ name args -> 
     InstanceCreation []
                      idrisClosureType
                      [ (ExpName $ J.Name [Ident "context"]) ]
                      ( Just 
                        $ ClassBody 
                            [ MemberDecl 
                              $ MethodDecl [Public, Final]
                                           []
                                           (Just . RefType $ ClassRefType objectType)
                                           (Ident "call")
                                           []
                                           []
                                           ( MethodBody 
                                             . Just 
                                             $ Block [ BlockStmt 
                                                       . Return 
                                                       . Just 
                                                       . MethodInv 
                                                       $ MethodCall (reverseNameSpace name) 
                                                                    args
                                                     ]
                                           )
                            ]
                      )
  )
  <$> mkName name
  <*> mapM (mkExp . SV) args

mkThread :: LVar -> CodeGeneration Exp
mkThread arg =
  (\ eval -> 
     MethodInv  
     $ PrimaryMethodCall (InstanceCreation [] 
                                           (ClassType [(Ident "Thread", [])]) 
                                           [ eval ] 
                                           ( Just 
                                             $ ClassBody [ MemberDecl 
                                                           $ MethodDecl [Public, Final]
                                                                        []
                                                                        (Just . RefType $ ClassRefType objectType)
                                                                        (Ident "_start")
                                                                        []
                                                                        []
                                                                        ( MethodBody 
                                                                          . Just 
                                                                          $ Block [ BlockStmt 
                                                                                    . ExpStmt 
                                                                                    . MethodInv 
                                                                                     $ MethodCall (J.Name [Ident "start"])
                                                                                                  []
                                                                                  , BlockStmt 
                                                                                    . Return 
                                                                                    . Just 
                                                                                    $ This
                                                                                  ]
                                                                        )
                                                         ]
                                           )
                         )
                         []
                         (Ident "_start")
                         []
  )
  <$> mkThreadBinding arg

mkThreadBinding :: LVar -> CodeGeneration Exp
mkThreadBinding var =
  (\ bindingMethod var ->
     MethodInv $ PrimaryMethodCall ( InstanceCreation []
                                                      objectType
                                                      []
                                                      (Just $ ClassBody [MemberDecl $ bindingMethod])
                                   )
                                   []
                                   (Ident "apply")
                                   [ var ]
  )
  <$> mkThreadBindingMethod
  <*> mkVarAccess Nothing var


mkThreadBindingMethod :: CodeGeneration MemberDecl
mkThreadBindingMethod = 
  (\ compute -> 
     MethodDecl [Final, Public]
                []
                (Just . RefType $ ClassRefType idrisClosureType)
                (Ident "apply")
                [ FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId $ Ident "param") ]
                []
                (MethodBody . Just $ Block
                            [ mkThreadBindingStack
                            , BlockStmt . Return $ Just compute
                            ]
                )
  )
  <$> mkBindingClosure (SUpdate (Loc 0) (SApp False (MN 0 "EVAL") [Loc 0]))


mkThreadBindingStack :: BlockStmt
mkThreadBindingStack =
  LocalVars [Final]
            objectArrayType
            [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
                        (Just . InitArray $ ArrayInit [InitExp . ExpName $ J.Name [Ident "param"]])
            ]
 

mkExp :: SExp -> CodeGeneration Exp
mkExp (SV var) = mkVarAccess Nothing var
mkExp (SApp False name args) =
  (\ methClosure ->
     MethodInv $ PrimaryMethodCall ( InstanceCreation []
                                                      idrisTailCallClosureType
                                                      [ methClosure ]
                                                      Nothing
                                   )
                                   []
                                   (Ident "call")
                                   []
  )
  <$> mkMethodClosure name args
mkExp (SApp True name args) =
  (\ methClosure ->
     ( InstanceCreation []
                        idrisTailCallClosureType
                        [ methClosure ]
                        Nothing
     )
  )
  <$> mkMethodClosure name args
mkExp (SLet var new old) =
  mkLet var old new
mkExp (SUpdate var exp) =
  (\ rhs varPos -> Assign (ArrayLhs $ ArrayIndex (contextArray var) (Lit $ Int varPos))
                          EqualA
                          rhs
  )
  <$> mkExp exp
  <*> varPos var
mkExp (SCon conId name args) =
  (\ args -> InstanceCreation []
                              idrisObjectType
                              ((Lit $ Int (toInteger conId)):args)
                              Nothing)
  <$> mapM (mkExp .SV) args
mkExp (SCase var alts) = mkCase False var alts
mkExp (SChkCase var alts) = mkCase True var alts
mkExp (SProj var i) = mkProjection var i
mkExp (SConst (I x)) = 
  let x' :: Int32; x' = fromInteger (toInteger x) in
  return $ mkPrimitive "Integer" (Int (fromInteger (toInteger x')))
mkExp (SConst (BI x)) =
  return $ InstanceCreation [] 
                            (ClassType [(Ident "BigInteger", [])])
                            [Lit $ String (show x)]
                            Nothing
mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x)
mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x)
mkExp (SConst (Str x)) = return $ Lit $ String x
mkExp (SConst IType) = return $ mkClass integerType
mkExp (SConst BIType) = return $ mkClass bigIntegerType
mkExp (SConst FlType) = return $ mkClass doubleType
mkExp (SConst ChType) = return $ mkClass charType
mkExp (SConst StrType) = return $ mkClass stringType
mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (String (show x))
mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (String (show x))
mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (String (show x))
mkExp (SConst (B8Type))= return $ mkClass byteType
mkExp (SConst (B16Type)) = return $ mkClass shortType
mkExp (SConst (B32Type)) = return $ mkClass integerType
mkExp (SConst (B64Type)) = return $ mkClass longType
mkExp (SConst (PtrType)) = return $ mkClass objectType
mkExp (SConst (VoidType)) = return $ mkClass voidType
mkExp (SConst (Forgot)) = return $ mkClass objectType
mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args
mkExp (SOp (LPlus ITNative) args) = mkExp (SOp (LPlus IT32) args)
mkExp (SOp (LMinus ITNative) args) = mkExp (SOp (LMinus IT32) args)
mkExp (SOp (LTimes ITNative) args) = mkExp (SOp (LTimes IT32) args)
mkExp (SOp (LSDiv ITNative) args) = mkExp (SOp (LSDiv IT32) args)
mkExp (SOp (LSRem ITNative) args) = mkExp (SOp (LSRem IT32) args)
mkExp (SOp (LAnd ITNative) args) = mkExp (SOp (LAnd IT32) args)
mkExp (SOp (LOr ITNative) args) = mkExp (SOp (LOr IT32) args)
mkExp (SOp (LXOr ITNative) args) = mkExp (SOp (LXOr IT32) args)
mkExp (SOp (LCompl ITNative) args) = mkExp (SOp (LCompl IT32) args)
mkExp (SOp (LSHL ITNative) args) = mkExp (SOp (LSHL IT32) args)
mkExp (SOp (LASHR ITNative) args) = mkExp (SOp (LASHR IT32) args)
mkExp (SOp (LEq ITNative) args) = mkExp (SOp (LEq IT32) args)
mkExp (SOp (LLt ITNative) args) = mkExp (SOp (LLt IT32) args)
mkExp (SOp (LLe ITNative) args) = mkExp (SOp (LLe IT32) args)
mkExp (SOp (LGt ITNative) args) = mkExp (SOp (LGt IT32) args)
mkExp (SOp (LGe ITNative) args) = mkExp (SOp (LGe IT32) args)
mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args
mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args
mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args
mkExp (SOp LFDiv args) = mkBinOpExp doubleType Div args
mkExp (SOp LFEq args) = 
  mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args
mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args
mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args
mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args
mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args
mkExp (SOp (LPlus ITBig) args) = mkMethodOpChain1 id bigIntegerType "add" args
mkExp (SOp (LMinus ITBig) args) = mkMethodOpChain1 id bigIntegerType "subtract" args
mkExp (SOp (LTimes ITBig) args) = mkMethodOpChain1 id bigIntegerType "multiply" args
mkExp (SOp (LSDiv ITBig) args) = mkMethodOpChain1 id bigIntegerType "divide" args
mkExp (SOp (LSRem ITBig) args) = mkMethodOpChain1 id bigIntegerType "mod" args
mkExp (SOp (LEq ITBig) args) = 
  mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args
mkExp (SOp (LLt ITBig) args) =
  mkMethodOpChain1 ( mkBoolToNumber bigIntegerType 
                     . mkPartialOrder SLt
                   ) 
                   bigIntegerType 
                   "compareTo" 
                   args
mkExp (SOp (LLe ITBig) args) =
  mkMethodOpChain1 ( mkBoolToNumber bigIntegerType 
                   . mkPartialOrder SLe
                   ) 
                   bigIntegerType 
                   "compareTo" 
                   args
mkExp (SOp (LGt ITBig) args) =
  mkMethodOpChain1 ( mkBoolToNumber bigIntegerType 
                   . mkPartialOrder SGt
                   ) 
                   bigIntegerType 
                   "compareTo" 
                   args
mkExp (SOp (LGe ITBig) args) =
  mkMethodOpChain1 ( mkBoolToNumber bigIntegerType 
                   . mkPartialOrder SGe
                   ) 
                   bigIntegerType 
                   "compareTo" 
                   args
mkExp (SOp LStrConcat args) =
  mkMethodOpChain (\ exp -> InstanceCreation [] 
                                             (ClassType [(Ident "StringBuilder", [])])
                                             [exp]
                                             Nothing
                  )
                  (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") [])
                  stringType 
                  "append"
                  args
mkExp (SOp LStrLt args@[_, _]) =
  mkMethodOpChain1 ( mkBoolToNumber integerType
                   . mkPartialOrder SLt
                   )
                   stringType
                   "compareTo"
                   args
mkExp (SOp LStrEq args@[_, _]) =
  mkMethodOpChain1 ( mkBoolToNumber integerType)
                   stringType
                   "equals"
                   args
mkExp (SOp LStrLen [arg]) =
  (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") [])
  <$> mkVarAccess (Just stringType) arg
mkExp (SOp (LIntFloat ity) [arg]) =
  mkPrimitiveCast (intTyToClass ity) doubleType arg
mkExp (SOp (LFloatInt ity) [arg]) =
  mkPrimitiveCast doubleType (intTyToClass ity) arg
mkExp (SOp (LIntStr ITBig) [arg]) =
  (\ var -> InstanceCreation [] bigIntegerType [var] Nothing)
  <$> mkVarAccess (Just stringType) arg
mkExp (SOp (LIntStr ity) [arg]) =
  mkToString (intTyToClass ity) arg
mkExp (SOp (LStrInt ity) [arg]) =
  mkPrimitiveCast stringType (intTyToClass ity) arg
mkExp (SOp LFloatStr [arg]) =
  mkToString doubleType arg
mkExp (SOp LStrFloat [arg]) =
  mkPrimitiveCast doubleType stringType arg
mkExp (SOp (LSExt ITNative ITBig) [arg]) =
  mkPrimitiveCast integerType bigIntegerType arg
mkExp (SOp (LTrunc ITBig ITNative) [arg]) =
  mkPrimitiveCast bigIntegerType integerType arg
mkExp (SOp (LChInt ITNative) [arg]) =
  mkVarAccess (Just integerType) arg
mkExp (SOp (LIntCh ITNative) [arg]) =
  mkVarAccess (Just integerType) arg
mkExp (SOp LPrintNum [arg]) =
  mkSystemOutPrint <$> (mkVarAccess Nothing arg)
mkExp (SOp LPrintStr [arg]) =
  mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)
mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])
mkExp (SOp (LLt ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThan args
mkExp (SOp (LLe ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThanE args
mkExp (SOp (LEq ty) args) = 
  mkMethodOpChain1 (mkBoolToNumber (intTyToClass ty)) (intTyToClass ty) "equals" args
mkExp (SOp (LGt ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThan args
mkExp (SOp (LGe ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThanE args
mkExp (SOp (LPlus ty) args) = mkBinOpExp (intTyToClass ty) Add args
mkExp (SOp (LMinus ty) args) = mkBinOpExp (intTyToClass ty) Sub args
mkExp (SOp (LTimes ty) args) = mkBinOpExp (intTyToClass ty) Mult args
mkExp (SOp (LUDiv IT64) (arg:args)) = do
  (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
  return $ foldl (\ exp arg ->
                    MethodInv $ PrimaryMethodCall
                              ( MethodInv $ PrimaryMethodCall
                                            ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
                                                                         []
                                                                         (Ident "valueOf")
                                                                         [ exp ]
                                            )
                                            []
                                            (Ident "divide")
                                            [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
                                                                         []
                                                                         (Ident "valueOf")
                                                                         [ arg ]
                                            ]
                              )
                              []
                              (Ident "longValue")
                              []
                 )                                
           arg
           args
mkExp (SOp (LUDiv ty) args) = 
  mkBinOpExpConv (intTyToMethod $ nextIntTy ty) 
                 (intTyToPrimTy $ nextIntTy ty) 
                 (intTyToClass ty) 
                 Div 
                 args
mkExp (SOp (LSDiv ty) args) = mkBinOpExp (intTyToClass ty) Div args
mkExp (SOp (LURem IT64) (arg:args)) = do
  (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
  return $ foldl (\ exp arg ->
                    MethodInv $ PrimaryMethodCall
                              ( MethodInv $ PrimaryMethodCall
                                            ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
                                                                         []
                                                                         (Ident "valueOf")
                                                                         [ exp ]
                                            )
                                            []
                                            (Ident "remainder")
                                            [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
                                                                         []
                                                                         (Ident "valueOf")
                                                                         [ arg ]
                                            ]
                              )
                              []
                              (Ident "longValue")
                              []
                 )                                
           arg
           args
mkExp (SOp (LURem ty) args) =
  mkBinOpExpConv (intTyToMethod $ nextIntTy ty) 
                 (intTyToPrimTy $ nextIntTy ty) 
                 (intTyToClass ty)
                 Rem
                 args
mkExp (SOp (LSRem ty) args) = mkBinOpExp (intTyToClass ty) Rem args
mkExp (SOp (LSHL ty) args) = mkBinOpExp (intTyToClass ty) LShift args
mkExp (SOp (LLSHR ty) args) = mkBinOpExp (intTyToClass ty) RRShift args
mkExp (SOp (LASHR ty) args) = mkBinOpExp (intTyToClass ty) RShift args
mkExp (SOp (LAnd ty) args) = mkBinOpExp (intTyToClass ty) And args
mkExp (SOp (LOr ty) args) = mkBinOpExp (intTyToClass ty) Or args
mkExp (SOp (LXOr ty) args) = mkBinOpExp (intTyToClass ty) Xor args
mkExp (SOp (LCompl ty) [var]) = PreBitCompl <$> mkVarAccess (Just $ intTyToClass ty) var
mkExp (SOp (LZExt from to) [var])
    | intTyWidth from < intTyWidth to
        = mkZeroExt (intTyToMethod to) (intTyWidth from) (intTyToClass from) (intTyToClass to) var
mkExp (SOp (LSExt from to) [var])
    | intTyWidth from < intTyWidth to
        = mkSignedExt (intTyToMethod to) (intTyToClass from) (intTyToClass to) var
mkExp (SOp (LTrunc from to) [var])
    | intTyWidth from > intTyWidth to
        = (\ var -> MethodInv $ 
            TypeMethodCall (J.Name [intTyToIdent to])
                           []
                           (Ident "valueOf")
                           [ MethodInv 
                             $ PrimaryMethodCall var [] (Ident (intTyToMethod to)) [] ]
  )
  <$> mkVarAccess (Just $ intTyToClass from) var
mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg
mkExp (SOp LFLog [arg]) = mkMathFun "log" arg
mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg
mkExp (SOp LFCos [arg]) = mkMathFun "cos" arg
mkExp (SOp LFTan [arg]) = mkMathFun "tan" arg
mkExp (SOp LFASin [arg]) = mkMathFun "asin" arg
mkExp (SOp LFACos [arg]) = mkMathFun "acos" arg
mkExp (SOp LFATan [arg]) = mkMathFun "atan" arg
mkExp (SOp LFSqrt [arg]) = mkMathFun "sqrt" arg
mkExp (SOp LFFloor [arg]) = mkMathFun "floor" arg
mkExp (SOp LFCeil [arg]) = mkMathFun "ceil" arg
mkExp (SOp LStrHead [arg]) = mkStringAtIndex arg (Lit $ Int 0)
mkExp (SOp LStrTail [arg]) = 
  (\ var -> MethodInv $ PrimaryMethodCall (var)
                                         []
                                         (Ident "substring")
                                         [Lit $ Int 1]
  ) 
  <$> mkVarAccess (Just stringType) arg
mkExp (SOp LStrCons [c, cs]) =
  (\ cVar csVar -> MethodInv $ 
         PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation [] 
                                                                             (ClassType [(Ident "StringBuilder", [])])
                                                                             [csVar]
                                                                             Nothing
                                                           )
                                                           []
                                                           (Ident "insert")
                                                           [ Lit $ Int 0, 
                                                             Cast (PrimType CharT) 
                                                                  (MethodInv $ PrimaryMethodCall 
                                                                               (cVar)
                                                                               []
                                                                               (Ident "intValue")
                                                                               []
                                                                  )
                                                           ]
                           )
                           []
                           (Ident "toString")
                           []
 )
 <$> mkVarAccess (Just integerType) c
 <*> mkVarAccess (Just stringType) cs
mkExp (SOp LStrIndex [str, i]) = mkVarAccess (Just integerType) i >>= mkStringAtIndex str 
mkExp (SOp LStrRev [str]) = 
  (\ var -> MethodInv $ 
         PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
                                                                            (ClassType [(Ident "StringBuffer", [])])
                                                                            [var]
                                                                            Nothing
                                                           )
                                                           []
                                                           (Ident "reverse")
                                                           []
                           )
                           []
                           (Ident "toString")
                           []
  )
  <$> mkVarAccess (Just stringType) str
mkExp (SOp LStdIn []) = return $ mkSystemStd In
mkExp (SOp LStdOut []) = return $ mkSystemStd Out
mkExp (SOp LStdErr []) = return $ mkSystemStd Err
mkExp (SOp LFork [arg]) = mkThread arg
mkExp (SOp LPar [arg]) = mkExp (SV arg)
mkExp (SOp LVMPtr []) = 
  return $ MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") []
mkExp (SOp LNoOp args) = mkExp . SV $ last args
mkExp (SNothing) = return $ Lit Null
mkExp (SError err) =
  return . MethodInv $ 
         PrimaryMethodCall (InstanceCreation [] 
                                             runtimeExceptionType 
                                             [Lit $ String err]
                                             ( Just $ ClassBody
                                                    [ MemberDecl $ MethodDecl [Public, Final]
                                                                              []
                                                                              (Just . RefType $ ClassRefType objectType)
                                                                              (Ident "throwSelf")
                                                                              []
                                                                              []
                                                                              ( MethodBody . Just $
                                                                                          Block [ BlockStmt (Throw This) ]
                                                                              )
                                                     ]
                                             )
                           )
                           []
                           (Ident "throwSelf")
                           []
mkExp other = error (show other)
