{-# LANGUAGE Haskell2010, FlexibleContexts #-}
-- {-# OPTIONS -Wall -fno-warn-name-shadowing #-}

-- | Functions for generating glue code between Haskell and Java.
module CodeGen.JavaBindings where

import CodeGen.Class
import CodeGen.Typomatic
import Types
import Utils

import qualified Haskell.X as X
import Haskell.X.Unsafe
import Haskell.X.Ops

import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class

import Data.Function
import qualified Data.List as L
import qualified Data.Char as C


imports :: Monad m => CodeGenerator m
-- ^ Imports of all auto generated java code files.
imports = do
    return """
        import qualified Foreign.Java as JNI
        import Foreign.Java ((-->))
        import qualified Prelude as P
        import Prelude ((.), ($), (>>=), (>>), return)
        import qualified Foreign.Java.Bindings as JNIS
        import Data.Functor ((<$>))
        """


javaPackageModule :: Monad m => String -> CodeGenerator m
-- ^ java.lang -> Java.Lang (package hierarchy)
javaPackageModule packageName = do

    commonImports <- imports
    deps <- getPackageModuleDeps packageName

    moduleName <- getModNameForPackage packageName
    moduleComment <- return """The @#{packageName}@ package."""
    moduleImports <- return deps
        >>= return . concatMap (\name -> "import " ++ name ++ "__\n")
    moduleExports <- return deps
        >>= return . concat . L.intersperse ",\n" . map (\x -> "module " ++ x ++ "__")

    return """
        {-# LANGUAGE Haskell2010 #-}
        -- | #{moduleComment}
        module #{moduleName} (
        #{moduleExports}\
        ) where
        #{commonImports}
        #{moduleImports}
        """


readArg :: String -> JavaType -> String
readArg name jtype = case jtype of
    JBoolean -> """#{name}' <- JNIS.toBoolean #{name}\n"""
    JChar    -> """#{name}' <- JNIS.toChar #{name}\n"""
    JByte    -> """#{name}' <- JNIS.toByte #{name}\n"""
    JShort   -> """#{name}' <- JNIS.toShort #{name}\n"""
    JInt     -> """#{name}' <- JNIS.toInt #{name}\n"""
    JLong    -> """#{name}' <- JNIS.toLong #{name}\n"""
    JFloat   -> """#{name}' <- JNIS.toFloat #{name}\n"""
    JDouble  -> """#{name}' <- JNIS.toDouble #{name}\n"""
    JObj _   -> """#{name}' <- P.Just <$> JNI.asObject #{name}\n"""
    JArr _   -> """#{name}' <- JNIS.asMaybeArrayObject #{name}\n"""

convertResult :: Maybe JavaType -> String
convertResult rtype = case rtype of
    Nothing -> "JNIS.toVoidResult"
    Just t -> case t of
        JBoolean -> "JNIS.toBooleanResult"
        JChar    -> "JNIS.toCharResult"
        JByte    -> "JNIS.toByteResult"
        JShort   -> "JNIS.toShortResult"
        JInt     -> "JNIS.toIntResult"
        JLong    -> "JNIS.toLongResult"
        JFloat   -> "JNIS.toFloatResult"
        JDouble  -> "JNIS.toDoubleResult"
        JObj n   -> "JNIS.toObjectResult"
        JArr c   -> "(\\x -> let (P.Right (P.Just y)) = x in return y)"


javaClassModule :: (Functor m, Monad m) => String -> CodeGenerator m
-- ^ java.lang.Thread -> Java.Lang.Thread (implementation file)
javaClassModule className = do

    clazz <- getClassInfoFor className
    commonImports <- imports
    moduleName <- getModNameForClass className
    let baseName = takeClassName moduleName
        isIface  = classIface clazz

    moduleImports <- getClassModuleDeps clazz
        >>= return . concatMap (\name -> "import qualified " ++ name ++ "__\n")

    let mkConstructorNames :: [JavaConstructor] -> [String]
        mkConstructorNames = zipWith (flip (++)) (iterate (++"'") "") . map (const $ "new'" ++ baseName)

        mkMethodNames :: [JavaMethod] -> [String]
        mkMethodNames = concatMap (zipWith (flip (++)) (iterate (++"'") ""))
                        . L.group . map sanitize . map methodName
          where
            sanitize name
              | C.isUpper (head name) = '_' : name
              | name `elem` haskellKeywords = name ++ "'"
              | otherwise = name

        mkFields :: [JavaField] -> [(JavaField, (String, Maybe String))]
        mkFields = map mkField . L.nubBy ((==) `on` fieldName)
          where
            mkField f = (f, ("get'" ++ name, (if fieldFinal f then Nothing else Just ("set'" ++ name))))
              where name = fieldName f

        methods_ = L.sortBy (compare `on` methodName) (classMethods clazz)
        constrs_ = L.sortBy compareConstructors (classConstructors clazz)

        compareConstructors a b = length (constructorParams a) `compare` length (constructorParams b)

    constrNames <- constrs_ =>> mkConstructorNames
    methodNames <- methods_ =>> mkMethodNames

    constrs <- constrNames =>> zip constrs_
    methods <- methodNames =>> zip methods_
    fields  <- (classFields clazz) =>> mkFields

    let (constrNames, fieldNames, methodNames)
          = (map snd constrs,
             concatMap (\(_, (g, s)) -> g : maybe [] (:[]) s) fields,
             map snd methods)
        functions = concat [constrNames, fieldNames, methodNames]
        ifaceConstructor = """new'#{baseName}"""
        constructors
            | classIface clazz = """
                -- * Constructors
                #{ifaceConstructor},
                \n"""
            | otherwise = """
                -- * Constructors
                #{if null constrs then '-':"- | No Constructors!" else concatMap (++ ",\n") constrNames}
                \n"""

    moduleComment <- return ""
    moduleExports <- return """
        #{constructors}
        -- * Fields
        #{if null fields then '-':"- | No Fields!" else concatMap (++ ",\n") fieldNames}
        
        -- * Methods
        #{if null methods then '-':"- | No Methods!" else concat $ L.intersperse ",\n" methodNames}
        """

    infoFunc <- getClassInfoFunc
    modFunc  <- getClassModFunc

    constrDeclarations <- case classIface clazz of
        True -> return """
                #{ifaceConstructor} :: a
                #{ifaceConstructor} = P.undefined
                \n"""
        False -> fmap concat $ forM constrs $ \(constr, name) -> do
            let argsInfo = runTypomatic infoFunc (constructorType clazz constr modFunc)
                args = fArgNames argsInfo

                readArgs = concatMap (("    " ++) . uncurry readArg)
                                     (zip args (map fst $ constructorParams constr))

                preamble = """
                    #{name} :: #{fSignature argsInfo}
                    #{name}#{concatMap (' ':) args} = do
                        (P.Just clazz) <- JNI.getClass "#{className}"
                    """

            case constructorParams constr of
                [] -> return """
                    #{preamble}
                        JNI.newObjectE clazz >>= JNIS.toObjectResult
                    \n"""
                _ -> return """
                    #{preamble}
                        (P.Just constr) <- JNI.getConstructor clazz $ #{fJniSignature argsInfo}
                    #{readArgs}\
                        result <- JNI.newObjectFromE constr #{concatMap (++ "' ") args}
                        JNIS.toObjectResult result
                    \n"""


    methodDeclarations <- fmap concat $ forM methods $ \(method, name) -> do

        let isStatic = methodStatic method
            getMethod = if isStatic then "getStaticMethod" else "getMethod"
            callMethod = if isStatic then "callStaticMethodE" else "callMethodE"

            argsInfo = runTypomatic infoFunc (methodType clazz method modFunc)
            args = fArgNames argsInfo
            argsNotThis = (if isStatic then id else tail) args

            haddock = """
                @#{if isStatic then "static " else "virtual "}\
                #{if methodSynchronized method then "synchronized " else ""}\
                #{if methodNative method then "native " else ""}\
                #{if methodFinal method then "final " else ""}\
                #{fJavaSignature argsInfo} -> #{fJavaReturnType argsInfo}@"""

            thisArg = if isStatic then "" else """    #{head args}' <- JNI.asObject #{head args}\n"""
            readArgs = concatMap (("    " ++) . uncurry readArg)
                                 (zip argsNotThis (map fst $ methodParams method))

        return """
            {- | #{haddock} -}
            #{name} :: #{fSignature argsInfo}
            #{name}#{concatMap (' ':) args} = do
                (P.Just clazz) <- JNI.getClass "#{className}"
                (P.Just method) <- clazz `JNI.#{getMethod}` #{fJniSignature argsInfo}
            #{thisArg}\
            #{readArgs}\
                result <- JNI.#{callMethod} method #{concatMap (++ "' ") args}
                #{convertResult (fst (methodReturnType method))} result
            \n"""

    fieldDeclarations <- fmap concat $ forM fields $ \(field, (getterName, setterName)) -> do

        let isStatic = fieldStatic field
            jniType  = printJniType $ fst $ fieldType field
            (getField, readField, writeField) = case isStatic of
                True  -> ("getStaticField", "readStaticField", "writeStaticField")
                False -> ("getField",       "readField",       "writeField")

            getterInfo = runTypomatic infoFunc (getterType clazz field modFunc)
            setterInfo = runTypomatic infoFunc (setterType clazz field modFunc)

            getterArgs = fArgNames getterInfo
            getterArgsNotThis = (if isStatic then id else tail) getterArgs

            setterArgs = fArgNames setterInfo
            setterArgsNotThis = (if isStatic then id else tail) setterArgs

            thisArg = if isStatic then ""
                else """    #{head getterArgs}' <- JNI.asObject #{head getterArgs}\n"""

            getter = """
                #{getterName} :: #{fSignature getterInfo}
                #{getterName}#{concatMap (' ':) getterArgs} = do
                    (P.Just clazz) <- JNI.getClass "#{className}"
                    (P.Just field) <- JNI.#{getField} clazz "#{fieldName field}" (#{jniType})
                #{thisArg}\
                    result <- JNI.#{readField} field #{concatMap (++ "' ") getterArgs}
                    #{convertResult (Just (fst (fieldType field)))} (P.Right result)
                \n"""
            setter
                | (Just name) <- setterName = """
                    #{name} :: #{fSignature setterInfo}
                    #{name}#{concatMap (' ':) setterArgs} = do
                        (P.Just clazz) <- JNI.getClass "#{className}"
                        (P.Just field) <- JNI.#{getField} clazz "#{fieldName field}" (#{jniType})
                    #{thisArg}\
                        JNI.#{writeField} field #{concatMap (++ "' ") setterArgs}
                        return ()
                    \n"""
                | otherwise = ""

        return $ getter ++ setter

    return """
        {-# LANGUAGE Haskell2010 #-}
        -- | #{moduleComment}
        module #{moduleName} (
        #{moduleExports}\
        ) where
        #{commonImports}
        #{moduleImports}
        #{constrDeclarations}
        #{methodDeclarations}
        #{fieldDeclarations}
        """


javaClassModule' :: (Functor m, Monad m) => String -> CodeGenerator m
-- ^ java.lang.Thread -> Java.Lang.Thread__ (interface file)
javaClassModule' className = do

    clazz <- getClassInfoFor className
    moduleName <- getModNameForClass className
    baseName <- moduleName =>> takeClassName

    commonImports <- imports
    moduleImports <- getClassModulesUniq (classParents clazz ++ classIfaces clazz)
        >>= return . concatMap (\name -> "import qualified " ++ name ++ "__\n")

    moduleComment <- return """See "#{moduleName}" for the available methods."""

    let params = concatMap (\(p:ps) -> ' ' : C.toLower p : ps)
                  $ map (tyVarName . paramName) $ classTypeParams clazz

        newtTDecl = newtTName baseName ++ params
        newtCDecl = newtCName baseName
        dataTDecl = dataTName baseName ++ params
        dataCDecl = dataCName baseName ++ params

        parentInstance parent = do
            modName <- getModNameForClass parent
            let qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName)
            return """instance #{qualifiedName} (#{newtTDecl})\n"""

        parentContext parent = do
            modName <- getModNameForClass parent
            let qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName)            
            return """, #{qualifiedName} this"""

    context   <- concat <$> mapM parentContext  (classParents clazz)
    instances <- concat <$> mapM parentInstance (classParents clazz)

    let tyclTDecl = """(JNI.JavaObject this#{context}) => #{tyclTName baseName} this"""

        enumConstants = map sanitize $ map snd $ classEnumConstants clazz
          where sanitize (x:xs) = C.toUpper x : xs

        newtAdditions
            | classEnum clazz = enumConstants
            | otherwise = []

        newtDeclaration
            | null newtAdditions = """newtype #{newtTDecl} = #{newtCDecl} JNI.JObject"""
            | otherwise = """data #{newtTDecl} = #{newtCDecl} JNI.JObject"""
                ++ concatMap (" | " ++ ) newtAdditions

        newtExport
            | null newtAdditions = ""
            | otherwise = concat (" (" : L.intersperse ", " newtAdditions ++ [")"])

        moduleExports = """
            #{tyclTName baseName},
            #{dataTName baseName} (..),
            #{newtTName baseName}#{newtExport},
            """

        javaObjectInstance
            | classEnum clazz = """
                instance JNI.JavaObject (#{newtTDecl}) where
                    asObject (#{newtCName baseName} obj) = return obj
                #{concatMap (uncurry asObjectMatch) $ zip enumConstants $ classEnumConstants clazz}"""
            | otherwise = """
                instance JNI.JavaObject (#{newtTDecl}) where
                    asObject (#{newtCName baseName} obj) = return obj"""
          where
            asObjectMatch enum (ord, name) = """
                    asObject #{enum} = do
                        -- #{show ord}, #{name}
                        (P.Just clazz) <- JNI.getClass "#{className}"
                        (P.Just field) <- JNI.getStaticField clazz "#{name}" (JNI.object "#{className}")
                        (P.Just object) <- JNI.readStaticField field
                        return object
                """

        moduleDeclarations = """
                class #{tyclTDecl}
                #{newtDeclaration}
                data #{dataTDecl} = #{dataCDecl}
                
                #{javaObjectInstance}
                
                instance JNIS.UnsafeCast (#{newtTDecl}) where
                    unsafeFromJObject obj = return (#{newtCDecl} obj)
                
                instance #{tyclTName baseName} (#{newtTDecl})
                
                instance JNIS.InstanceOf (#{dataTDecl}) where
                    type CoercedType (#{dataTDecl}) = (#{newtTDecl})
                    coerce o t = do
                        obj <- JNI.asObject o
                        (P.Just clazz) <- JNI.getClass "#{className}"
                        isInstanceOf <- obj `JNI.isInstanceOf` clazz
                        if isInstanceOf
                            then P.Just <$> (JNIS.unsafeFromJObject obj)
                            else return P.Nothing
                
                #{instances}
                """

    additionalDeclarations <- case className of
        "java.lang.String" -> return """
            instance JNI.JavaObject [P.Char] where
                asObject s = do
                    (P.Just clazz) <- JNI.getClass "java.lang.String"
                    (P.Just valueOf) <- clazz `JNI.getStaticMethod` "valueOf" ::= JNI.string --> JNI.object "java.lang.String"
                    (P.Just string) <- JNI.callStaticMethod valueOf s
                    JNI.asObject string
            instance Java.Lang.Object [P.Char]
            instance Java.Lang.String [P.Char]
            """
        "java.lang.Character" -> return """
            instance JNI.JavaObject P.Char where
                asObject ...
            instance Java.Lang.Object P.Char
            instance Java.Lang.Character P.Char
            """
        "java.lang.Boolean" -> return """
            instance JNI.JavaObject P.Bool where
                asObject n = do
                    (P.Just clazz) <- JNI.getClass "java.lang.Boolean"
                    (P.Just valueOf) <- clazz `JNI.getStaticMethod` "valueOf"
                                        ::= JNI.byte --> JNI.object "java.lang.Boolean"
                    (P.Just boolean) <- JNI.callStaticMethod valueOf n
                    JNI.asObject boolean
            instance Java.Lang.Object P.Bool
            instance Java.Lang.Boolean P.Bool
            """
        "java.lang.Number" -> return """
            import qualified Data.Int
            import qualified Data.Word
            instance JNI.JavaObject Data.Int.Int8 where
                asObject n = do
                    (P.Just clazz) <- JNI.getClass "java.lang.Byte"
                    (P.Just valueOf) <- clazz `JNI.getStaticMethod` "valueOf"
                                        ::= JNI.byte --> JNI.object "java.lang.Byte"
                    (P.Just number) <- JNI.callStaticMethod valueOf n
                    JNI.asObject number
            instance JNI.JavaObject Data.Int.Int16 where
                asObject n = do
                    (P.Just clazz) <- JNI.getClass "java.lang.Short"
                    (P.Just valueOf) <- clazz `JNI.getStaticMethod` "valueOf"
                                        ::= JNI.short --> JNI.object "java.lang.Short"
                    (P.Just number) <- JNI.callStaticMethod valueOf n
                    JNI.asObject number
            instance JNI.JavaObject Data.Int.Int32 where
                asObject n = do
                    (P.Just clazz) <- JNI.getClass "java.lang.Integer"
                    (P.Just valueOf) <- clazz `JNI.getStaticMethod` "valueOf"
                                        ::= JNI.int --> JNI.object "java.lang.Integer"
                    (P.Just number) <- JNI.callStaticMethod valueOf n
                    JNI.asObject number
            instance JNI.JavaObject Data.Int.Int64 where
                asObject n = do
                    (P.Just clazz) <- JNI.getClass "java.lang.Long"
                    (P.Just valueOf) <- clazz `JNI.getStaticMethod` "valueOf"
                                        ::= JNI.long --> JNI.object "java.lang.Long"
                    (P.Just number) <- JNI.callStaticMethod valueOf n
                    JNI.asObject number

            instance Java.Lang.Object P.Int
            instance Java.Lang.Number P.Int
            instance Java.Lang.Object Data.Int.Int8
            instance Java.Lang.Number Data.Int.Int8
            instance Java.Lang.Object Data.Int.Int16
            instance Java.Lang.Number Data.Int.Int16
            instance Java.Lang.Object Data.Int.Int32
            instance Java.Lang.Number Data.Int.Int32
            instance Java.Lang.Object Data.Int.Int64
            instance Java.Lang.Number Data.Int.Int64
            """
        "java.lang.Byte" -> return """
            import qualified Data.Int
            import qualified Data.Word
            instance Java.Lang.Byte Data.Int
            """
        "java.lang.Short" -> return """
            import qualified Data.Int
            import qualified Data.Word
            instance Java.Lang.Short Data.Int
            """
        "java.lang.Integer" -> return """
            import qualified Data.Int
            import qualified Data.Word
            instance Java.Lang.Integer Data.Int
            """
        "java.lang.Long" -> return """
            import qualified Data.Int
            import qualified Data.Word
            instance Java.Lang.Long Data.Int
            """
        "java.lang.Float" -> return """
            import qualified Data.Int
            import qualified Data.Word
            instance Java.Lang.Float Data.Int
            """
        "java.lang.Double" -> return """
            import qualified Data.Int
            import qualified Data.Word
            instance Java.Lang.Double Data.Int
            """


    return """
        {-# LANGUAGE Haskell2010, TypeFamilies, FlexibleInstances #-}
        -- | #{moduleComment}
        module #{moduleName}__ (
        #{moduleExports}
        ) where
        #{commonImports}
        #{moduleImports}
        #{additionalDeclarations}
        #{moduleDeclarations}
        """