X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=JVM%2FBuilder%2FMonad.hs;h=76426f54be665ebd0d4db8a3624ba74787eec43b;hb=312938f1af414da6443d21246e51a55e4457a885;hp=2ab3f7a452b3bd4a026aa3e567588eb0399bf5eb;hpb=9e0a8d2e1db1f7d06969879a901374ca560f0d21;p=hs-java.git

diff --git a/JVM/Builder/Monad.hs b/JVM/Builder/Monad.hs
index 2ab3f7a..76426f5 100644
--- a/JVM/Builder/Monad.hs
+++ b/JVM/Builder/Monad.hs
@@ -1,59 +1,141 @@
-{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-}
-module JVM.Builder.Monad where
+{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
+-- | This module defines Generate[IO] monad, which helps generating JVM code and
+-- creating Java class constants pool.
+--
+-- Code generation could be done using one of two monads: Generate and GenerateIO.
+-- Generate monad is pure (simply State monad), while GenerateIO is IO-related.
+-- In GenerateIO additional actions are available, such as setting up ClassPath
+-- and loading classes (from .class files or JAR archives).
+--
+module JVM.Builder.Monad
+  (GState (..),
+   emptyGState,
+   Generator (..),
+   Generate, GenerateIO,
+   addToPool,
+   i0, i1, i8,
+   newMethod,
+   setStackSize, setMaxLocals,
+   withClassPath,
+   getClassField, getClassMethod,
+   generate, generateIO
+  ) where
 
+import Prelude hiding (catch)
 import Control.Monad.State as St
+import Control.Monad.Exception
+import Control.Monad.Exception.Base
 import Data.Word
-import Data.List
 import Data.Binary
 import qualified Data.Map as M
 import qualified Data.Set as S
 import qualified Data.ByteString.Lazy as B
 
-import JVM.Common ()  -- import instances only
+import JVM.Common
 import JVM.ClassFile
 import JVM.Assembler
+import JVM.Exceptions
+import Java.ClassPath
 
+-- | Generator state
 data GState = GState {
-  generated :: [Instruction],
-  currentPool :: Pool Resolved,
-  doneMethods :: [Method Resolved],
-  currentMethod :: Maybe (Method Resolved),
-  stackSize :: Word16,
-  locals :: Word16 }
+  generated :: [Instruction],             -- ^ Already generated code (in current method)
+  currentPool :: Pool Direct,             -- ^ Already generated constants pool
+  nextPoolIndex :: Word16,                -- ^ Next index to be used in constants pool
+  doneMethods :: [Method Direct],         -- ^ Already generated class methods
+  currentMethod :: Maybe (Method Direct), -- ^ Current method
+  stackSize :: Word16,                    -- ^ Maximum stack size for current method
+  locals :: Word16,                       -- ^ Maximum number of local variables for current method
+  classPath :: [Tree CPEntry]
+  }
   deriving (Eq,Show)
 
+-- | Empty generator state
+emptyGState ::  GState
 emptyGState = GState {
   generated = [],
   currentPool = M.empty,
+  nextPoolIndex = 1,
   doneMethods = [],
   currentMethod = Nothing,
   stackSize = 496,
-  locals = 0 }
+  locals = 0,
+  classPath = []}
 
-type Generate a = State GState a
+class (Monad (g e), MonadState GState (g e)) => Generator e g where
+  throwG :: (Exception x, Throws x e) => x -> g e a
 
-appendPool :: Constant Resolved -> Pool Resolved -> (Pool Resolved, Word16)
-appendPool c pool =
-  let size = fromIntegral (M.size pool)
-      pool' = M.insert size c pool
-  in  (pool', size)
+-- | Generate monad
+newtype Generate e a = Generate {
+  runGenerate :: EMT e (State GState) a }
+  deriving (Monad, MonadState GState)
 
-addItem :: Constant Resolved -> Generate Word16
+instance MonadState st (EMT e (StateT st IO)) where
+  get = lift St.get
+  put x = lift (St.put x)
+
+instance MonadState st (EMT e (State st)) where
+  get = lift St.get
+  put x = lift (St.put x)
+
+-- | IO version of Generate monad
+newtype GenerateIO e a = GenerateIO {
+  runGenerateIO :: EMT e (StateT GState IO) a }
+  deriving (Monad, MonadState GState, MonadIO)
+
+instance MonadIO (EMT e (StateT GState IO)) where
+  liftIO action = lift $ liftIO action
+
+instance Generator e GenerateIO where
+  throwG e = GenerateIO (throw e)
+
+instance (MonadState GState (EMT e (State GState))) => Generator e Generate where
+  throwG e = Generate (throw e)
+
+execGenerateIO :: [Tree CPEntry]
+               -> GenerateIO (Caught SomeException NoExceptions) a
+               -> IO GState
+execGenerateIO cp (GenerateIO emt) = do
+    let caught = emt `catch` (\(e :: SomeException) -> fail $ show e)
+    execStateT (runEMT caught) (emptyGState {classPath = cp})
+
+execGenerate :: [Tree CPEntry]
+             -> Generate (Caught SomeException NoExceptions) a
+             -> GState
+execGenerate cp (Generate emt) = do
+    let caught = emt `catch` (\(e :: SomeException) -> fail $ show e)
+    execState (runEMT caught) (emptyGState {classPath = cp})
+
+-- | Update ClassPath
+withClassPath :: ClassPath () -> GenerateIO e ()
+withClassPath cp = do
+  res <- liftIO $ execClassPath cp
+  st <- St.get
+  St.put $ st {classPath = res}
+
+-- | Add a constant to pool
+addItem :: (Generator e g) => Constant Direct -> g e Word16
 addItem c = do
   pool <- St.gets currentPool
   case lookupPool c pool of
-    Just i -> return (i+1)
+    Just i -> return i
     Nothing -> do
-      let (pool', i) = appendPool c pool
+      i <- St.gets nextPoolIndex
+      let pool' = M.insert i c pool
+          i' = if long c
+                 then i+2
+                 else i+1
       st <- St.get
-      St.put $ st {currentPool = pool'}
-      return (i+1)
+      St.put $ st {currentPool = pool',
+                   nextPoolIndex = i'}
+      return i
 
-lookupPool :: Constant Resolved -> Pool Resolved -> Maybe Word16
+-- | Lookup in a pool
+lookupPool :: Constant Direct -> Pool Direct -> Maybe Word16
 lookupPool c pool =
-  fromIntegral `fmap` findIndex (== c) (M.elems pool)
+  fromIntegral `fmap` mapFindIndex (== c) pool
 
-addNT :: Binary (Signature a) => NameType a -> Generate Word16
+addNT :: (Generator e g, HasSignature a) => NameType a -> g e Word16
 addNT (NameType name sig) = do
   let bsig = encode sig
   x <- addItem (CNameType name bsig)
@@ -61,12 +143,13 @@ addNT (NameType name sig) = do
   addItem (CUTF8 bsig)
   return x
 
-addSig :: MethodSignature -> Generate Word16
+addSig :: (Generator e g) => MethodSignature -> g e Word16
 addSig c@(MethodSignature args ret) = do
   let bsig = encode c
   addItem (CUTF8 bsig)
 
-addToPool :: Constant Resolved -> Generate Word16
+-- | Add a constant into pool
+addToPool :: (Generator e g) => Constant Direct -> g e Word16
 addToPool c@(CClass str) = do
   addItem (CUTF8 str)
   addItem c
@@ -91,36 +174,42 @@ addToPool c@(CNameType name sig) = do
   addItem c
 addToPool c = addItem c
 
-putInstruction :: Instruction -> Generate ()
+putInstruction :: (Generator e g) => Instruction -> g e ()
 putInstruction instr = do
   st <- St.get
   let code = generated st
   St.put $ st {generated = code ++ [instr]}
 
-i0 :: Instruction -> Generate ()
+-- | Generate one (zero-arguments) instruction
+i0 :: (Generator e g) => Instruction -> g e ()
 i0 = putInstruction
 
-i1 :: (Word16 -> Instruction) -> Constant Resolved -> Generate ()
+-- | Generate one one-argument instruction
+i1 :: (Generator e g) => (Word16 -> Instruction) -> Constant Direct -> g e ()
 i1 fn c = do
   ix <- addToPool c
   i0 (fn ix)
 
-i8 :: (Word8 -> Instruction) -> Constant Resolved -> Generate ()
+-- | Generate one one-argument instruction
+i8 :: (Generator e g) => (Word8 -> Instruction) -> Constant Direct -> g e ()
 i8 fn c = do
   ix <- addToPool c
   i0 (fn $ fromIntegral ix)
 
-setStackSize :: Word16 -> Generate ()
+-- | Set maximum stack size for current method
+setStackSize :: (Generator e g) => Word16 -> g e ()
 setStackSize n = do
   st <- St.get
   St.put $ st {stackSize = n}
 
-setMaxLocals :: Word16 -> Generate ()
+-- | Set maximum number of local variables for current method
+setMaxLocals :: (Generator e g) => Word16 -> g e ()
 setMaxLocals n = do
   st <- St.get
   St.put $ st {locals = n}
 
-startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate ()
+-- | Start generating new method
+startMethod :: (Generator e g) => [AccessFlag] -> B.ByteString -> MethodSignature -> g e ()
 startMethod flags name sig = do
   addToPool (CString name)
   addSig sig
@@ -136,12 +225,13 @@ startMethod flags name sig = do
   St.put $ st {generated = [],
                currentMethod = Just method }
 
-endMethod :: Generate ()
+-- | End of method generation
+endMethod :: (Generator e g, Throws UnexpectedEndMethod e) => g e ()
 endMethod = do
   m <- St.gets currentMethod
   code <- St.gets genCode
   case m of
-    Nothing -> fail "endMethod without startMethod!"
+    Nothing -> throwG UnexpectedEndMethod
     Just method -> do
       let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],
                             methodAttributesCount = 1}
@@ -150,7 +240,14 @@ endMethod = do
                    currentMethod = Nothing,
                    doneMethods = doneMethods st ++ [method']}
 
-newMethod :: [AccessFlag] -> B.ByteString -> [ArgumentSignature] -> ReturnSignature -> Generate () -> Generate (NameType Method)
+-- | Generate new method
+newMethod :: (Generator e g, Throws UnexpectedEndMethod e)
+          => [AccessFlag]        -- ^ Access flags for method (public, static etc)
+          -> B.ByteString        -- ^ Method name
+          -> [ArgumentSignature] -- ^ Signatures of method arguments
+          -> ReturnSignature     -- ^ Method return signature
+          -> g e ()                -- ^ Generator for method code
+          -> g e (NameType (Method Direct))
 newMethod flags name args ret gen = do
   let sig = MethodSignature args ret
   startMethod flags name sig
@@ -158,6 +255,38 @@ newMethod flags name args ret gen = do
   endMethod
   return (NameType name sig)
 
+-- | Get a class from current ClassPath
+getClass :: (Throws ENotLoaded e, Throws ENotFound e)
+         => String -> GenerateIO e (Class Direct)
+getClass name = do
+  cp <- St.gets classPath
+  res <- liftIO $ getEntry cp name
+  case res of
+    Just (NotLoaded p) -> throwG (ClassFileNotLoaded p)
+    Just (Loaded _ c) -> return c
+    Just (NotLoadedJAR p c) -> throwG (JARNotLoaded p c)
+    Just (LoadedJAR _ c) -> return c
+    Nothing -> throwG (ClassNotFound name)
+
+-- | Get class field signature from current ClassPath
+getClassField :: (Throws ENotFound e, Throws ENotLoaded e)
+              => String -> B.ByteString -> GenerateIO e (NameType (Field Direct))
+getClassField clsName fldName = do
+  cls <- getClass clsName
+  case lookupField fldName cls of
+    Just fld -> return (fieldNameType fld)
+    Nothing  -> throwG (FieldNotFound clsName fldName)
+
+-- | Get class method signature from current ClassPath
+getClassMethod :: (Throws ENotFound e, Throws ENotLoaded e)
+               => String -> B.ByteString -> GenerateIO e (NameType (Method Direct))
+getClassMethod clsName mName = do
+  cls <- getClass clsName
+  case lookupMethod mName cls of
+    Just m -> return (methodNameType m)
+    Nothing  -> throwG (MethodNotFound clsName mName)
+
+-- | Convert Generator state to method Code.
 genCode :: GState -> Code
 genCode st = Code {
     codeStackSize = stackSize st,
@@ -171,34 +300,52 @@ genCode st = Code {
   where
     len = fromIntegral $ B.length $ encodeInstructions (generated st)
 
-initClass :: B.ByteString -> Generate Word16
+-- | Start class generation.
+initClass :: (Generator e g) => B.ByteString -> g e Word16
 initClass name = do
   addToPool (CClass "java/lang/Object")
   addToPool (CClass name)
   addToPool (CString "Code")
 
-generate :: B.ByteString -> Generate () -> Class Resolved
-generate name gen =
+-- | Generate a class
+generateIO :: [Tree CPEntry]
+           -> B.ByteString
+           -> GenerateIO (Caught SomeException NoExceptions) ()
+           -> IO (Class Direct)
+generateIO cp name gen = do
+  let generator = do
+        initClass name
+        gen
+  res <- execGenerateIO cp generator
+  let code = genCode res
+      d = defaultClass :: Class Direct
+  return $ d {
+        constsPoolSize = fromIntegral $ M.size (currentPool res),
+        constsPool = currentPool res,
+        accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
+        thisClass = name,
+        superClass = "java/lang/Object",
+        classMethodsCount = fromIntegral $ length (doneMethods res),
+        classMethods = doneMethods res }
+
+-- | Generate a class
+generate :: [Tree CPEntry]
+         -> B.ByteString
+         -> Generate (Caught SomeException NoExceptions) ()
+         -> Class Direct
+generate cp name gen =
   let generator = do
         initClass name
         gen
-      res = execState generator emptyGState
+      res = execGenerate cp generator
       code = genCode res
-  in  Class {
-        magic = 0xCAFEBABE,
-        minorVersion = 0,
-        majorVersion = 50,
+      d = defaultClass :: Class Direct
+  in  d {
         constsPoolSize = fromIntegral $ M.size (currentPool res),
         constsPool = currentPool res,
         accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
         thisClass = name,
         superClass = "java/lang/Object",
-        interfacesCount = 0,
-        interfaces = [],
-        classFieldsCount = 0,
-        classFields = [],
         classMethodsCount = fromIntegral $ length (doneMethods res),
-        classMethods = doneMethods res,
-        classAttributesCount = 0,
-        classAttributes = AR M.empty }
+        classMethods = doneMethods res }