{--
JVM-Bridge -- bridge from FP languages and others to the Java VM
Copyright (C) 2001 Ashley Yakeley <ashley@semantic.org>

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
--}

module Main where
    {
    import Foreign.JavaVM.Typed;
    import Platform.JavaVM;
    import Control.Monad.Reference;
    import Control.Monad.Loop;
    import Data.String;
    import Data.Nothing;
    import Data.Witness;
    import Data.Bits;
    import System.Environment;
    import System.IO;
    import System.Exit;


    data JObjectClass;
    instance IsJavaClassMarker JObjectClass where
        {cName Type = "java/lang/Object";};
    type JObject = ObjectRef JObjectClass;
    class IsJObject c where
        {toJObject :: c -> JObject;};
    instance IsJObject JObject where
        {toJObject = castTLRef;};

    instance IsJObject JClass where
        {toJObject = castTLRef;};

    data JReaderClass;
    instance IsJavaClassMarker JReaderClass where
        {cName Type = "java/io/Reader";};
    type JReader = ObjectRef JReaderClass;
    class IsJReader c where
        {toJReader :: c -> JReader;};
    instance IsJReader JReader where
        {toJReader = castTLRef;};
    instance IsJObject JReader where
        {toJObject = castTLRef;};

    data JBufferedReaderClass;
    instance IsJavaClassMarker JBufferedReaderClass where
        {cName Type = "java/io/BufferedReader";};
    type JBufferedReader = ObjectRef JBufferedReaderClass;
    instance IsJReader JBufferedReader where
        {toJReader = castTLRef;};
    instance IsJObject JBufferedReader where
        {toJObject = castTLRef;};

    data JInputStreamReaderClass;
    instance IsJavaClassMarker JInputStreamReaderClass where
        {cName Type = "java/io/InputStreamReader";};
    type JInputStreamReader = ObjectRef JInputStreamReaderClass;
    instance IsJReader JInputStreamReader where
        {toJReader = castTLRef;};
    instance IsJObject JInputStreamReader where
        {toJObject = castTLRef;};

    data JInputStreamClass;
    instance IsJavaClassMarker JInputStreamClass where
        {cName Type = "java/io/InputStream";};
    type JInputStream = ObjectRef JInputStreamClass;
    instance IsJObject JInputStream where
        {toJObject = castTLRef;};

    data JPrintStreamClass;
    instance IsJavaClassMarker JPrintStreamClass where
        {cName Type = "java/io/PrintStream";};
    type JPrintStream = ObjectRef JPrintStreamClass;
    instance IsJObject JPrintStream where
        {toJObject = castTLRef;};

    data JSystemClass;
    instance IsJavaClassMarker JSystemClass where
        {cName Type = "java/lang/System";};
    type JSystem = ObjectRef JSystemClass;
    instance IsJObject JSystem where
        {toJObject = castTLRef;};

    data JMemberClass;
    instance IsJavaClassMarker JMemberClass where
        {cName Type = "java/lang/reflect/Member";};
    type JMember = ObjectRef JMemberClass;
    class IsJMember c where
        {toJMember :: c -> JMember;};
    instance IsJMember JMember where
        {toJMember = castTLRef;};
    instance IsJObject JMember where
        {toJObject = castTLRef;};

    data JMethodClass;
    instance IsJavaClassMarker JMethodClass where
        {cName Type = "java/lang/reflect/Method";};
    type JMethod = ObjectRef JMethodClass;
    instance IsJMember JMethod where
        {toJMember = castTLRef;};
    instance IsJObject JMethod where
        {toJObject = castTLRef;};

    data JConstructorClass;
    instance IsJavaClassMarker JConstructorClass where
        {cName Type = "java/lang/reflect/Constructor";};
    type JConstructor = ObjectRef JConstructorClass;
    instance IsJMember JConstructor where
        {toJMember = castTLRef;};
    instance IsJObject JConstructor where
        {toJObject = castTLRef;};

    data JFieldClass;
    instance IsJavaClassMarker JFieldClass where
        {cName Type = "java/lang/reflect/Field";};
    type JField = ObjectRef JFieldClass;
    instance IsJMember JField where
        {toJMember = castTLRef;};
    instance IsJObject JField where
        {toJObject = castTLRef;};


    type JVM a = VM a;


    runJVMOnArgClasspath :: VM () -> IO ();
    runJVMOnArgClasspath foo = catch (do
        {
        classpath <- getArgs;
        runVMReport classpath foo;
        })
        (\ex -> (do
        {
        putStrLn ("caught exception: " ++ (show ex));
        exitFailure;
        }));

    forAny :: (Monad m) => [a] -> (a -> m Bool) -> m Bool;
    forAny [] _ = return False;
    forAny (a:as) getMatch = do
        {
        isA <- getMatch a;
        if isA then (return True) else (forAny as getMatch);
        };

    foreachgen :: (Monad m) => c -> (b -> c -> m c) -> [a] -> (a -> m b) -> m c;
    foreachgen nn _ [] _ = return nn;
    foreachgen nn gather (a:as) f = do
        {
        b <- f a;
        c <- foreachgen nn gather as f;
        gather b c;
        };

    foreach :: (Monad m) => [a] -> (a -> m ()) -> m ();
    foreach = foreachgen () (\() () -> return ());

    foreachres :: (Monad m) => [a] -> (a -> m b) -> m [b];
    foreachres = foreachgen [] (\b c -> return (b:c));

    foreachcollect :: (Monad m) => [a] -> (a -> m [b]) -> m [b];
    foreachcollect = foreachgen [] (\b c -> return (b ++ c));

    mergeOne :: (Monad m) => (a -> a -> m Bool) -> [a] -> a -> m [a];
    mergeOne eqF pl q = do
        {
        has <- forAny pl (\p -> eqF p q);
        return (if has
         then pl
         else (q:pl)
            );
        };

    merge :: (Monad m) => (a -> a -> m Bool) -> [a] -> [a] -> m [a];
    merge _ pl [] = return pl;
    merge eqF pl (q:qs) = do
        {
        has <- forAny pl (\p -> eqF p q);
        if has
         then (merge eqF pl qs)
         else do
            {
            pq <- merge eqF pl qs;
            return (q:pq);
            };
        };

    foreachmerge :: (Monad m) => (b -> b -> m Bool) -> [a] -> (a -> m [b]) -> m [b];
    foreachmerge eqF = foreachgen [] (merge eqF);

    isWS :: Jchar -> Bool;
    isWS c = c <= 32;

    firstNWS :: JavaString -> (JavaString,JavaString);
    firstNWS [] = ([],[]);
    firstNWS (c:cs) | isWS c = ([],cs);
    firstNWS (c:cs) = let {(f,r) = firstNWS cs} in (c:f,r);

    trimWS :: JavaString -> JavaString;
    trimWS [] = [];
    trimWS (c:cs) | isWS c = trimWS cs;
    trimWS s = s;

    splitWS :: JavaString -> [JavaString];
    splitWS s = case firstNWS (trimWS s) of
        {
        ([],_) -> [];
        (f,r) -> f:(splitWS r);
        };

    slashToDot :: Jchar -> Jchar;
    slashToDot 47 = 46;
    slashToDot c = c;

    dotToSlash :: Jchar -> Jchar;
    dotToSlash 46 = 47;
    dotToSlash c = c;

    main :: IO ();
    main = runJVMOnArgClasspath (do
        {
        objectClass                <- findClass (Type :: Type JObject);
        (equalsMethod :: JObject -> (JObject) -> IO Jboolean)
                                <- getMethod objectClass "equals";

        systemClass                <- findClass (Type :: Type JSystem);
        (inRef :: Ref IO JInputStream)
                                <- getStaticField systemClass "in";
        --(outRef :: Ref JVM JPrintStream)
        --                        <- getStaticField systemClass "out";

        stringClass                <- findClass (Type :: Type JString);
        (toCharArray :: JString -> () -> IO [Jchar])
                                <- getMethod stringClass "toCharArray";
        --(makeNewString :: ([Jchar]) -> JVM JString)
        --                        <- getMakeNewObject stringClass;
        
        readerClass                <- findClass (Type :: Type JReader);
        (close :: JReader -> () -> IO ())
                                <- getMethod readerClass "close";

        --fileInputStreamClass    <- findClassByName "java/io/FileInputStream";
        --(makeNewFileInputStream :: JString -> JVM JInputStream)
        --                        <- getMakeNewObject fileInputStreamClass;

        inputStreamReaderClass    <- findClass (Type :: Type JInputStreamReader);
        (makeNewInputStreamReader :: JInputStream -> IO JInputStreamReader)
                                <- getMakeNewObject inputStreamReaderClass;

        bufferedReaderClass        <- findClass (Type :: Type JBufferedReader);
        (makeNewBufferedReader :: JReader -> IO JBufferedReader)
                                <- getMakeNewObject bufferedReaderClass;
        (readLine :: JBufferedReader -> () -> IO JString)
                                <- getMethod bufferedReaderClass "readLine";

        --printStreamClass        <- findClass (Type :: Type JPrintStream);
        --(println :: JPrintStream -> ([Jchar]) -> JVM Jvoid)
        --                        <- getMethod printStreamClass "println";        

        classClass                <- findClass (Type :: Type JClass);
        --(forName :: (JString) -> JVM JClass)
        --                        <- getStaticMethod classClass "forName";        
        (getName :: JClass -> () -> IO JString)
                                <- getMethod classClass "getName";
        (getClassModifiers :: JClass -> () -> IO Jint)
                                <- getMethod classClass "getModifiers";
        (getInterfaces :: JClass -> () -> IO [JClass])
                                <- getMethod classClass "getInterfaces";
        (getSuperclass :: JClass -> () -> IO JClass)
                                <- getMethod classClass "getSuperclass";
        (getDeclaredFields :: JClass -> () -> IO [JField])
                                <- getMethod classClass "getDeclaredFields";
        (getDeclaredMethods :: JClass -> () -> IO [JMethod])
                                <- getMethod classClass "getDeclaredMethods";
        (getDeclaredConstructors :: JClass -> () -> IO [JConstructor])
                                <- getMethod classClass "getDeclaredConstructors";
        (getDeclaredMethod :: JClass -> (JString,[JClass]) -> IO JMethod)
                                <- getMethod classClass "getDeclaredMethod";

        constructorClass        <- findClass (Type :: Type JConstructor);
        (constructorgetParameterTypes :: JConstructor -> () -> IO [JClass])
                                <- getMethod constructorClass "getParameterTypes";
        
        memberClass                <- findClass (Type :: Type JMember);
        (membergetName :: JMember -> () -> IO JString)
                                <- getMethod memberClass "getName";
        (getModifiers :: JMember -> () -> IO Jint)
                                <- getMethod memberClass "getModifiers";
        
        fieldClass                <- findClass (Type :: Type JField);
        (jgetType :: JField -> () -> IO JClass)
                                <- getMethod fieldClass "getType";
        
        methodClass                <- findClass (Type :: Type JMethod);
        (getReturnType :: JMethod -> () -> IO JClass)
                                <- getMethod methodClass "getReturnType";
        (getParameterTypes :: JMethod -> () -> IO [JClass])
                                <- getMethod methodClass "getParameterTypes";
        
        
        classesIS    <- get inRef;
        classesISR    <- makeNewInputStreamReader classesIS;
        classesBR    <- makeNewBufferedReader (toJReader classesISR);
        
        --outStream    <- get outRef;
        
        let
            {
            outputLine :: JavaString -> JVM ();
--            outputLine s = return ();
--            outputLine s = println outStream s;
--            outputLine s = putStrLn (showJavaString s);
            outputLine s = do
                {
                putStrLn (showJavaString s);
                hFlush stdout;
                };
    
            commaList :: [JavaString] -> JavaString;
            commaList [] = [];
            commaList (x:[]) = x;
            commaList (x:xs) = x ++ "," ++ (commaList xs);
            
            parameterList :: [JavaString] -> JavaString;
            parameterList ss = "(" ++ (commaList ss) ++ ")";
            
            -- m4-style quoting
            enquote :: JavaString -> JavaString;
            enquote x = "`" ++ x ++ "'";

            mkCmd :: JavaString -> [JavaString] -> JavaString;
            mkCmd cmd ss = cmd ++ (parameterList (fmap enquote ss));
    
            outputCmd :: JavaString -> [JavaString] -> JVM ();
            outputCmd cmd ss = outputLine (mkCmd cmd ss);

            equalsObj :: (IsJObject a,IsJObject b) => a -> (b) -> JVM Jboolean;
            equalsObj a b = equalsMethod (toJObject a) (toJObject b);

            getNameArray :: JClass -> JVM JavaString;
            getNameArray c = do
                {
                str <- getName c ();
                rawName <- toCharArray str ();
                return (fixClassName rawName);
                } where
                {
                fixClassName :: JavaString -> JavaString;
                fixClassName ss@(ff:_) | ff == (toJChar '[')        = typeNameFromSig ss where
                    {
                    typeNameFromSig :: JavaString -> JavaString;
                    typeNameFromSig (f:[])    | f == (toJChar 'V')    = "void";
                    typeNameFromSig (f:[])    | f == (toJChar 'Z')    = "boolean";
                    typeNameFromSig (f:[])    | f == (toJChar 'B')    = "byte";
                    typeNameFromSig (f:[])    | f == (toJChar 'C')    = "char";
                    typeNameFromSig (f:[])    | f == (toJChar 'S')    = "short";
                    typeNameFromSig (f:[])    | f == (toJChar 'I')    = "int";
                    typeNameFromSig (f:[])    | f == (toJChar 'J')    = "long";
                    typeNameFromSig (f:[])    | f == (toJChar 'F')    = "float";
                    typeNameFromSig (f:[])    | f == (toJChar 'D')    = "double";
                    typeNameFromSig (f:s)    | (f == (toJChar 'L')) && ((last s) == (toJChar ';'))    = take ((length s) - 1) s;
                    typeNameFromSig (f:s)    | f == (toJChar '[')    = "[" ++ (typeNameFromSig s) ++ "]";
                    typeNameFromSig _ = error "unmatched typeNameFromSig";
                    };
                fixClassName s = s;
                };
            
            foundInClasses :: [JClass] -> JString -> [JClass] -> JVM Bool;
            foundInClasses classes mName mTypes = forAny classes foundInClass where
                {                
                foundInClass :: JClass -> JVM Bool;
                foundInClass cl = do
                    {
                    theMethod <- catchJThrowable (getDeclaredMethod cl (mName,mTypes)) (\_ -> getNothing);
                    noMethod <- getIsNothing theMethod;
                    return (not noMethod);
                    };
                };
            
            outputClass :: JavaString -> JVM ();
            outputClass classname = do
                {
                theClass <- catchJThrowable (findClassByName (fmap dotToSlash classname)) (\_ -> getNothing);
                noClass <- getIsNothing theClass;
                if (noClass)
                 then do
                     {
                    outputLine [];
                    outputLine ("dnl " ++ classname ++ " not found");
                    hPutStrLn stderr ("ShowClasses: " ++ (showJavaString classname) ++ " not found");
                    hFlush stderr;
                    exitFailure;
                     }
                 else do
                    {
                    cmodifiers <- getClassModifiers theClass ();
                    -- public classes only
                    if (cmodifiers .&. 1 > 0) then do
                        {
                        cname <- getNameArray theClass;
                        outputLine [];
                        outputLine (("dnl ") ++ cname);
                        outputCmd "sc_classname" [cname];

                        -- superclasses and interfaces
                        supers <- let
                            {
                            newInterfaces :: [JClass] -> JClass -> JVM [JClass];
                            newInterfaces intfs aClass = do
                                {
                                interfaces <- getInterfaces aClass ();
                                foreachmerge equalsObj interfaces (\iClass -> do
                                    {
                                    already <- forAny intfs (\intf -> equalsObj intf iClass);
                                    if already
                                     then (return [])
                                     else do
                                        {
                                        iSupers <- newInterfaces intfs iClass;
                                        return (iClass:iSupers);
                                        };
                                    });
                                };
                            addSupers :: [JClass] -> JClass -> JVM [JClass];
                            addSupers intfs aClass = do
                                {
                                interfaces <- newInterfaces intfs aClass;
                                sClass <- getSuperclass aClass ();
                                noSClass <- getIsNothing sClass;
                                if noSClass
                                 then (return (intfs ++ interfaces))
                                 else do
                                    {
                                    sSupers <- addSupers (intfs ++ interfaces) sClass;
                                    return (sClass:sSupers);
                                    };
                                };
                            }
                        in addSupers [] theClass;
                        
                        foreach supers (\cl -> do
                            {
                            scname <- getNameArray cl;
                            outputCmd "sc_subclass" [cname,scname];
                            });
                        
                        -- fields
                        fields <- getDeclaredFields theClass ();
                        foreach fields (\field -> do
                            {
                            fmodifiers <- getModifiers (toJMember field) ();
                            -- public only
                            if (fmodifiers .&. 1 > 0) then do
                                {
                                jname <- membergetName (toJMember field) ();
                                fname <- toCharArray jname ();
                                ftype <- jgetType field ();
                                ftname <- getNameArray ftype;
                                outputCmd
                                 (if (fmodifiers .&. 8 > 0) then "sc_staticfield" else "sc_field")
                                 [classname,fname,ftname];
                                }
                             else (return ());
                            });
                        
                        -- methods
                        methods <- getDeclaredMethods theClass ();
                        foreach methods (\method -> do
                            {
                            modifiers <- getModifiers (toJMember method) ();
                            -- public only
                            if (modifiers .&. 1 > 0) then do
                                {
                                let {isStatic = modifiers .&. 8 > 0};
                                methodName <- membergetName (toJMember method) ();
                                methodPTypes <- getParameterTypes method ();
                                inherited <- if (isStatic) then (return False) else (foundInClasses supers methodName methodPTypes);
                                if (inherited)
                                 then (return ())
                                 else do
                                    {
                                    name <- toCharArray methodName ();
                                    mtype <- getReturnType method ();
                                    mtname <- getNameArray mtype;
                                    pnames <- foreachres methodPTypes getNameArray;
                                    outputCmd
                                     (if isStatic then "sc_staticmethod" else "sc_method")
                                     [classname,name,mtname,parameterList pnames];
                                    };
                                }
                             else (return ());
                            });
                        
                        -- constructors
                        constructors <- getDeclaredConstructors theClass ();
                        foreach constructors (\method -> do
                            {
                            mmodifiers <- getModifiers (toJMember method) ();
                            -- public only
                            if (mmodifiers .&. 1 > 0) then do
                                {
                                -- let {isStatic = mmodifiers .&. 8 > 0};
                                methodPTypes <- constructorgetParameterTypes method ();
                                pnames <- foreachres methodPTypes getNameArray;
                                outputCmd "sc_constructor" [classname,parameterList pnames];
                                }
                             else (return ());
                            });

                        outputCmd "sc_endclass" [cname];
                        }
                    else do
                        {
                        hPutStrLn stderr ("ShowClasses: " ++ (showJavaString classname) ++ " not public");
                        hFlush stderr;
                        };
                    };
                };
            };
        while (do
            {
            jClassNamesLine <- readLine classesBR ();
            stop <- getIsNothing jClassNamesLine;
            if (stop)
             then (return False)
             else do
                {
                classNamesLine <- toCharArray jClassNamesLine ();
                mapM_ (outputClass . (fmap slashToDot)) (splitWS classNamesLine);
                return True;
                };
            });
        
        close (toJReader classesBR) ();

        return ();
        } :: JVM ());
    }