jvm-binary 0.0.2 → 0.1.0

raw patch · 57 files changed

+4812/−1636 lines, 57 filesdep +QuickCheckdep +attoparsecdep +data-binary-ieee754dep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, attoparsec, data-binary-ieee754, deepseq, deriving-compat, generic-random, hspec-expectations-pretty-diff, mtl, template-haskell

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−1
• README.md +21/−6
• benchmark/Main.hs +55/−5
• jvm-binary.cabal +67/−18
• package.yaml +22/−19
• src/Language/JVM.hs +16/−13
• src/Language/JVM/AccessFlag.hs +16/−13
• src/Language/JVM/Attribute.hs +10/−115
• src/Language/JVM/Attribute/Base.hs +160/−0
• src/Language/JVM/Attribute/BootstrapMethods.hs +33/−21
• src/Language/JVM/Attribute/Code.hs +105/−633
• src/Language/JVM/Attribute/ConstantValue.hs +22/−8
• src/Language/JVM/Attribute/Exceptions.hs +20/−14
• src/Language/JVM/Attribute/LineNumberTable.hs +79/−0
• src/Language/JVM/Attribute/Signature.hs +97/−0
• src/Language/JVM/Attribute/StackMapTable.hs +153/−68
• src/Language/JVM/ByteCode.hs +1322/−0
• src/Language/JVM/ClassFile.hs +114/−47
• src/Language/JVM/ClassFileReader.hs +225/−0
• src/Language/JVM/Constant.hs +422/−131
• src/Language/JVM/ConstantPool.hs +105/−0
• src/Language/JVM/Field.hs +69/−18
• src/Language/JVM/Method.hs +82/−41
• src/Language/JVM/Stage.hs +49/−0
• src/Language/JVM/Staged.hs +146/−0
• src/Language/JVM/TH.hs +87/−0
• src/Language/JVM/Type.hs +194/−0
• src/Language/JVM/Utils.hs +70/−14
• stack.yaml +2/−3
• test-suite/Language/JVM/Attribute/CodeTest.hs +0/−84
• test-suite/Language/JVM/Attribute/StackMapTableTest.hs +0/−50
• test-suite/Language/JVM/AttributeTest.hs +0/−21
• test-suite/Language/JVM/ClassFileTest.hs +0/−33
• test-suite/Language/JVM/ConstantTest.hs +0/−42
• test-suite/Language/JVM/FieldTest.hs +0/−19
• test-suite/Language/JVM/MethodTest.hs +0/−19
• test-suite/Language/JVM/UtilsTest.hs +0/−22
• test-suite/Language/JVMTest.hs +0/−30
• test-suite/SpecHelper.hs +0/−68
• test-suite/Test.hs +0/−60
• test/Language/JVM/Attribute/BootstrapMethodsTest.hs +20/−0
• test/Language/JVM/Attribute/CodeTest.hs +178/−0
• test/Language/JVM/Attribute/ConstantValueTest.hs +15/−0
• test/Language/JVM/Attribute/ExceptionsTest.hs +15/−0
• test/Language/JVM/Attribute/LineNumberTableTest.hs +26/−0
• test/Language/JVM/Attribute/SignatureTest.hs +27/−0
• test/Language/JVM/Attribute/StackMapTableTest.hs +77/−0
• test/Language/JVM/AttributeTest.hs +23/−0
• test/Language/JVM/ClassFileTest.hs +43/−0
• test/Language/JVM/ConstantTest.hs +124/−0
• test/Language/JVM/FieldTest.hs +26/−0
• test/Language/JVM/MethodTest.hs +29/−0
• test/Language/JVM/TypeTest.hs +50/−0
• test/Language/JVM/UtilsTest.hs +64/−0
• test/Language/JVMTest.hs +164/−0
• test/SpecHelper.hs +155/−0
• test/Test.hs +1/−0

@@ -1,6 +1,17 @@ # Change log -## Version 0.0.X+## Version 0.1.0 ++- Fix documentation+- Remove ConstantRef+- Add better method and field descriptions +- Introducing a stageing system+- Added Code writing+- Changed Megaparsec to Attoparsec of improved performance.+- A lot of extra work++- Add Attributes +  - LineNumberTable  ## Version 0.0.2 

@@ -9,19 +9,34 @@ ```haskell import           Language.JVM import qualified Language.JVM.Attribute.Code as Code++import qualified Data.ByteString.Lazy as BL++main :: IO ()+main = +  ecfl <- readClassFile <$> BL.readFile "test/data/project/Main.class" +  case ecfl of +    Right clf -> do+      print (cThisClass clf)+      print (cSuperClass clf)+    Left msg -> +      print msg ``` -## Todo's+## Stages -- Add more Attributes as to the-[docs](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.7).-The most notable and required are:+There are two stages in the current state of the repository. `Low` is closer+to the class-file, while the `High` stage is easier to work with. The reason+that we have the two stages is that the class-file representation has indices+into the Constant Pool. The `High` stage eliminates all these problems. -  - LineNumberTable -- Add lenses for better access of deep fields+## Todo's +- Add more Attributes as to the+[docs](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.7). - Add documentation for Code+- Setup regular benchmarks  ## Developing 

@@ -7,9 +7,59 @@ import Data.ByteString.Lazy as BL  main :: IO ()-main = defaultMain-  [ bench "simple load" (-      whnfIO $ decodeClassFile <$>-        BL.readFile "test-suite/data/project/Main.class"-      )+main = defaultMain $+  [ decodebm+  , encodebm+  , evolvebm+  , devolvebm+  ] <*> [ ex2 ]++decodebm :: FilePath -> Benchmark+decodebm fp = bgroup ("decode " ++ fp)+  [ bench "lazy"+      (whnfIO $ decodeClassFile <$> BL.readFile ex2)+  , bench "strict"+      (nfIO $ decodeClassFile <$> BL.readFile ex2)   ]++encodebm :: FilePath -> Benchmark+encodebm fp =+  env (decodeClassFile' fp) $ \clf ->+    bgroup ("encode " ++ fp)+    [ bench "lazy"+        (whnf encodeClassFile clf)+    , bench "strict"+        (nf encodeClassFile clf)+    ]++evolvebm :: FilePath -> Benchmark+evolvebm fp =+  env (decodeClassFile' fp)$ \clf ->+    bgroup ("evolve " ++ fp)+    [ bench "strict"+        (nf evolveClassFile clf)+    ]++devolvebm :: FilePath -> Benchmark+devolvebm fp =+  env (readClassFile' fp) $ \clf ->+    bgroup ("devolve " ++ fp)+    [ bench "strict"+        (nf devolveClassFile clf)+    ]++decodeClassFile' :: FilePath -> IO (ClassFile Low)+decodeClassFile' fp = do+  Right clf <- decodeClassFile <$> BL.readFile fp+  return clf++readClassFile' :: FilePath -> IO (ClassFile High)+readClassFile' fp = do+  Right clf <- readClassFile <$> BL.readFile fp+  return clf++ex1 :: String+ex1 = "test/data/project/Main.class"++ex2 :: String+ex2 = "test/data/java/util/zip/ZipOutputStream.class"

@@ -1,12 +1,14 @@--- This file has been generated from package.yaml by hpack version 0.17.1.+-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack+--+-- hash: 097c125068d4157309ad1e355ed38e1c038f019d7b88ee213afb43df08ad7784  name:           jvm-binary-version:        0.0.2+version:        0.1.0 synopsis:       A library for reading Java class-files description:    A library for reading Java class-files.-category:       Language, Java+category:       Language, Java, JVM homepage:       https://github.com/ucla-pls/jvm-binary#readme bug-reports:    https://github.com/ucla-pls/jvm-binary/issues author:         Christian Gram Kalhauge@@ -32,58 +34,93 @@       src   ghc-options: -Wall   build-depends:-      base >= 4.9 && < 4.10+      attoparsec+    , base >=4.9 && <4.11     , binary     , bytestring     , containers+    , data-binary-ieee754+    , deepseq >=1.4.3.0+    , deriving-compat+    , mtl+    , template-haskell     , text     , vector   exposed-modules:       Language.JVM       Language.JVM.AccessFlag       Language.JVM.Attribute+      Language.JVM.Attribute.Base       Language.JVM.Attribute.BootstrapMethods       Language.JVM.Attribute.Code       Language.JVM.Attribute.ConstantValue       Language.JVM.Attribute.Exceptions+      Language.JVM.Attribute.LineNumberTable+      Language.JVM.Attribute.Signature       Language.JVM.Attribute.StackMapTable+      Language.JVM.ByteCode       Language.JVM.ClassFile+      Language.JVM.ClassFileReader       Language.JVM.Constant+      Language.JVM.ConstantPool       Language.JVM.Field       Language.JVM.Method+      Language.JVM.Stage+      Language.JVM.Staged+      Language.JVM.TH+      Language.JVM.Type       Language.JVM.Utils+  other-modules:+      Paths_jvm_binary   default-language: Haskell2010 -test-suite jvm-binary-test-suite+test-suite jvm-binary-test   type: exitcode-stdio-1.0   main-is: Test.hs   hs-source-dirs:-      test-suite-  ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N -fno-warn-orphans+      test+  ghc-options: -rtsopts -threaded -with-rtsopts=-N -fno-warn-orphans   build-depends:-      base >= 4.9 && < 4.10-    , jvm-binary-    , tasty-    , tasty-hspec-    , tasty-discover-    , tasty-quickcheck+      QuickCheck+    , attoparsec+    , base >=4.9 && <4.11     , binary     , bytestring     , containers-    , filepath+    , data-binary-ieee754+    , deepseq >=1.4.3.0+    , deriving-compat     , directory+    , filepath+    , generic-random+    , hspec-expectations-pretty-diff+    , jvm-binary+    , mtl+    , tasty+    , tasty-discover+    , tasty-hspec+    , tasty-quickcheck+    , template-haskell     , text+    , vector   other-modules:+      Language.JVM.Attribute.BootstrapMethodsTest       Language.JVM.Attribute.CodeTest+      Language.JVM.Attribute.ConstantValueTest+      Language.JVM.Attribute.ExceptionsTest+      Language.JVM.Attribute.LineNumberTableTest+      Language.JVM.Attribute.SignatureTest       Language.JVM.Attribute.StackMapTableTest       Language.JVM.AttributeTest       Language.JVM.ClassFileTest       Language.JVM.ConstantTest       Language.JVM.FieldTest       Language.JVM.MethodTest+      Language.JVM.TypeTest       Language.JVM.UtilsTest       Language.JVMTest       SpecHelper+      Paths_jvm_binary   default-language: Haskell2010  benchmark jvm-binary-benchmarks@@ -91,10 +128,22 @@   main-is: Main.hs   hs-source-dirs:       benchmark-  ghc-options: -Wall -rtsopts -threaded -funbox-strict-fields -with-rtsopts=-N+  ghc-options: -rtsopts -threaded -funbox-strict-fields -with-rtsopts=-N   build-depends:-      base >= 4.9 && < 4.10-    , jvm-binary-    , criterion+      attoparsec+    , base >=4.9 && <4.11+    , binary     , bytestring+    , containers+    , criterion+    , data-binary-ieee754+    , deepseq >=1.4.3.0+    , deriving-compat+    , jvm-binary+    , mtl+    , template-haskell+    , text+    , vector+  other-modules:+      Paths_jvm_binary   default-language: Haskell2010

@@ -1,18 +1,16 @@ name: jvm-binary-version: '0.0.2'+version: '0.1.0' author: Christian Gram Kalhauge maintainer: Christian Gram Kalhauge <kalhauge@cs.ucla.edu> synopsis: A library for reading Java class-files  license: MIT license-file: LICENSE.md-category: Language, Java+category: Language, Java, JVM github: ucla-pls/jvm-binary  description: A library for reading Java class-files. -ghc-options: -Wall- extra-source-files: - CHANGELOG.md - LICENSE.md@@ -20,46 +18,51 @@ - README.md - stack.yaml +dependencies:+- base >= 4.9 && < 4.11+- binary+- bytestring+- containers+- text+- vector+- deepseq >= 1.4.3.0+- deriving-compat+- attoparsec+- mtl+- data-binary-ieee754+- template-haskell+ library:-  dependencies:-  - base >= 4.9 && < 4.10-  - binary-  - bytestring-  - containers-  - text-  - vector   source-dirs: src+  ghc-options: -Wall  tests:-  jvm-binary-test-suite:+  jvm-binary-test:     dependencies:-    - base >= 4.9 && < 4.10     - jvm-binary     - tasty     - tasty-hspec     - tasty-discover     - tasty-quickcheck-    - binary-    - bytestring-    - containers+    - QuickCheck     - filepath     - directory     - text+    - generic-random+    - hspec-expectations-pretty-diff     ghc-options:     - -rtsopts     - -threaded     - -with-rtsopts=-N     - -fno-warn-orphans     main: Test.hs-    source-dirs: test-suite+    source-dirs: test  benchmarks:   jvm-binary-benchmarks:     dependencies:-    - base >= 4.9 && < 4.10     - jvm-binary     - criterion-    - bytestring     ghc-options:     - -rtsopts     - -threaded

@@ -8,28 +8,31 @@ -}  module Language.JVM-  ( decodeClassFile-+  ( module Language.JVM.AccessFlag   , module Language.JVM.Attribute   , module Language.JVM.ClassFile+  , module Language.JVM.ClassFileReader   , module Language.JVM.Constant+  , module Language.JVM.ConstantPool   , module Language.JVM.Field   , module Language.JVM.Method+  , module Language.JVM.Stage+  , module Language.JVM.Staged+  , module Language.JVM.Utils+  , module Language.JVM.Type+  , module Language.JVM.ByteCode   ) where -import qualified Data.ByteString.Lazy   as BL-import           Data.Binary-+import           Language.JVM.AccessFlag import           Language.JVM.Attribute+import           Language.JVM.ByteCode import           Language.JVM.ClassFile+import           Language.JVM.ClassFileReader import           Language.JVM.Constant+import           Language.JVM.ConstantPool import           Language.JVM.Field import           Language.JVM.Method---- | Create a class file from a lazy 'BL.ByteString'-decodeClassFile :: BL.ByteString -> Either String ClassFile-decodeClassFile bs = do-  case decodeOrFail bs of-    Right (_, _, cf) -> Right cf-    Left (_, _, msg) -> Left msg-+import           Language.JVM.Stage+import           Language.JVM.Staged+import           Language.JVM.Type+import           Language.JVM.Utils

@@ -6,7 +6,8 @@  Contains the AccessFlags used in the different modules. -}-+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-} module Language.JVM.AccessFlag   ( MAccessFlag(..), mflags   , FAccessFlag(..), fflags@@ -15,6 +16,9 @@  import           Language.JVM.Utils +import           GHC.Generics (Generic)+import           Control.DeepSeq (NFData)+ -- | Access flags for the 'Language.JVM.Method.Method' data MAccessFlag   = MPublic@@ -29,8 +33,7 @@   | MAbstract   | MStrictFP   | MSynthetic-  deriving (Ord, Show, Eq)-+  deriving (Ord, Show, Eq, NFData, Generic)  -- | The 'Enumish' mapping of the 'MAccessFlag' mflags :: [(Int, MAccessFlag)]@@ -57,11 +60,13 @@   = CPublic   | CFinal   | CSuper+  | CInterface   | CAbstract   | CSynthetic   | CAnnotation   | CEnum-  deriving (Ord, Show, Eq)+  | CModule+  deriving (Ord, Show, Eq, NFData, Generic)  -- | The 'Enumish' mapping of the 'CAccessFlag' cflags :: [(Int, CAccessFlag)]@@ -69,10 +74,12 @@   [ (0, CPublic)   , (4, CFinal)   , (5, CSuper)+  , (9, CInterface)   , (10, CAbstract)   , (12, CSynthetic)   , (13, CAnnotation)   , (14, CEnum)+  , (15, CModule)   ]  instance Enumish CAccessFlag where@@ -85,13 +92,11 @@   | FProtected   | FStatic   | FFinal-  | FSynchronized-  | FUnused6   | FVolatile   | FTransient   | FSynthetic   | FEnum-  deriving (Ord, Show, Eq)+  deriving (Ord, Show, Eq, NFData, Generic)  -- | The 'Enumish' mapping of the 'FAccessFlag' fflags :: [(Int, FAccessFlag)]@@ -101,12 +106,10 @@   , (2,  FProtected)   , (3,  FStatic)   , (4,  FFinal)-  , (5,  FSynchronized)-  , (6,  FUnused6)-  , (7,  FVolatile)-  , (8,  FTransient)-  , (13, FSynthetic)-  , (15, FEnum)+  , (6,  FVolatile)+  , (7,  FTransient)+  , (12, FSynthetic)+  , (14, FEnum)   ]  instance Enumish FAccessFlag where

@@ -7,134 +7,29 @@ This is the main module for accessing all kinds of Attributes. -} +{-# LANGUAGE DeriveAnyClass       #-} {-# LANGUAGE DeriveGeneric        #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE TypeSynonymInstances #-} module Language.JVM.Attribute-  ( Attribute (..)-  , aInfo--  , aName--  , IsAttribute (..)-  -- * SubAttributes+  ( module Language.JVM.Attribute.Base+  -- * Subattributes+  , BootstrapMethods   , Code-  , codeStackMapTable   , ConstantValue   , Exceptions+  , LineNumberTable   , StackMapTable-  , BootstrapMethods--  -- * Helpers-  , Const+  , Signature   ) where -import           GHC.Generics                            (Generic)--import           Data.Bifunctor-import           Data.Binary-import qualified Data.ByteString                         as BS-import qualified Data.ByteString.Lazy                    as BL-import           Data.Monoid-import           Data.Text                               as Text--import           Language.JVM.Constant                   (ConstantPool,-                                                          ConstantRef,-                                                          lookupText)-import           Language.JVM.Utils                      (SizedByteString32,-                                                          trd,-                                                          unSizedByteString)-+import           Language.JVM.Attribute.Base import           Language.JVM.Attribute.BootstrapMethods (BootstrapMethods)-import qualified Language.JVM.Attribute.Code             as Code+import           Language.JVM.Attribute.Code             (Code) import           Language.JVM.Attribute.ConstantValue    (ConstantValue) import           Language.JVM.Attribute.Exceptions       (Exceptions)+import           Language.JVM.Attribute.LineNumberTable  (LineNumberTable)+import           Language.JVM.Attribute.Signature        (Signature) import           Language.JVM.Attribute.StackMapTable    (StackMapTable)---- | An Attribute, simply contains of a reference to a name and--- contains info.-data Attribute = Attribute-  { aNameIndex :: ! ConstantRef-  , aInfo'     :: ! SizedByteString32-  } deriving (Show, Eq, Generic)--instance Binary Attribute where---- | A small helper function to extract the info as a--- lazy 'Data.ByteString.Lazy.ByteString'.-aInfo :: Attribute -> BS.ByteString-aInfo = unSizedByteString . aInfo'---- | Extracts the name from the attribute, if it exists in the--- ConstantPool.-aName :: ConstantPool -> Attribute -> Maybe Text.Text-aName cp as = lookupText (aNameIndex as) cp---- | Create a type dependent on another type 'b',--- used for accessing the correct 'attrName' in 'IsAttribute'.-newtype Const a b = Const { unConst :: a }---- | A class-type that describes a data-type 'a' as an Attribute. Most notable--- it provides the 'fromAttribute'' method that enables converting an Attribute--- to a data-type 'a'.-class IsAttribute a where-  attrName :: Const Text.Text a-  -- ^ The name of the attribute.--  fromAttribute :: Attribute -> Either String a-  -- ^ Generate a 'a' from an Attribute.--  fromAttribute'-    :: ConstantPool-    -> Attribute-    -> Maybe (Either String a)-  fromAttribute' cp as = do-    name <- aName cp as-    if name == unConst (attrName :: Const Text.Text a) then-       return $ fromAttribute as-    else Nothing--readFromStrict :: Binary a => Attribute -> Either String a-readFromStrict =-    bimap trd trd . decodeOrFail . BL.fromStrict . aInfo---- # Attributes----- | 'Code' is an Attribute.-instance IsAttribute Code where-  attrName = Const "Code"-  fromAttribute = readFromStrict---- | 'ConstantValue' is an Attribute.-instance IsAttribute ConstantValue where-  attrName = Const "ConstantValue"-  fromAttribute = readFromStrict---- | 'Exceptions' is an Attribute.-instance IsAttribute Exceptions where-  attrName = Const "Exceptions"-  fromAttribute = readFromStrict---- | 'StackMapTable' is an Attribute.-instance IsAttribute StackMapTable where-  attrName = Const "StackMapTable"-  fromAttribute = readFromStrict---- | 'BootstrapMethods' is an Attribute.-instance IsAttribute BootstrapMethods where-  attrName = Const "BootstrapMethods"-  fromAttribute = readFromStrict---- | Code is redefined with Attribute, as it is recursively containing--- 'Attribute'. This is a small hack to fix it.-type Code = Code.Code Attribute---- | The a attribute of the code is the StackMapTable. There can be at most one.--- If the version number of the file is more than 50, and there is no StackMapTable.--- there is an implicit empty StackMapTable.-codeStackMapTable :: ConstantPool -> Code -> Maybe (Either String BootstrapMethods)-codeStackMapTable cp =-  getFirst . foldMap (First . fromAttribute' cp) . Code.attributes

@@ -0,0 +1,160 @@+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TemplateHaskell     #-}+{-|+Module      : Language.JVM.Attribute.Base+Copyright   : (c) Christian Gram Kalhauge, 2017+License     : MIT+Maintainer  : kalhuage@cs.ucla.edu+-}+module Language.JVM.Attribute.Base+  ( Attribute (..)+  , aInfo+  , toAttribute+  , devolveAttribute+  , fromAttribute'+  , toAttribute'++  -- * Helpers+  , IsAttribute (..)+  , Attributes+  , fromAttributes+  , toC+  , toC'+  , collect+  , Const (..)+  , firstOne+  ) where++import           Control.Monad+import           Data.Bifunctor+import           Data.Binary+import qualified Data.ByteString      as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.List            as List+import qualified Data.Text            as Text++import           Language.JVM.Staged+import           Language.JVM.Utils++-- | Maybe return the first element of a list+firstOne :: [a] -> Maybe a+firstOne as = fst <$> List.uncons as++-- | An Attribute, simply contains of a reference to a name and+-- contains info.+data Attribute r = Attribute+  { aName  :: ! (Ref Text.Text r)+  , aInfo' :: ! (SizedByteString32)+  }++-- | A small helper function to extract the info as a+-- lazy 'Data.ByteString.Lazy.ByteString'.+aInfo :: Attribute r -> BS.ByteString+aInfo = unSizedByteString . aInfo'++instance Staged Attribute where+  evolve (Attribute an ai) = do+    an' <- link an+    return $ Attribute an' ai+  devolve (Attribute an ai) = do+    an' <- unlink an+    return $ Attribute an' ai++$(deriveBaseWithBinary ''Attribute)++-- | A list of attributes and described by the expected values.+type Attributes b r = Choice (SizedList16 (Attribute r)) (b r) r++-- | Create a type dependent on another type 'b',+-- used for accessing the correct 'attrName' in 'IsAttribute'.+newtype Const a b = Const { unConst :: a }++-- | A class-type that describes a data-type 'a' as an Attribute. Most notable+-- it provides the 'fromAttribute'' method that enables converting an Attribute+-- to a data-type 'a'.+class (Binary a) => IsAttribute a where+  -- | The name of an attribute. This is used to lookup an attribute.+  attrName :: Const Text.Text a++-- | Generate an attribute in a low stage 'Low'.+fromAttribute' :: IsAttribute a => Attribute r -> Either String a+fromAttribute' = readFromStrict++toAttribute' :: forall a. IsAttribute a => a -> Attribute High+toAttribute' a =+  let name = unConst (attrName :: Const Text.Text a)+      bytes = encode a+  in Attribute name (SizedByteString . BL.toStrict $ bytes)++toAttribute :: (IsAttribute (a Low), Staged a, DevolveM m) => a High -> m (Attribute Low)+toAttribute =+  devolveAttribute devolve++devolveAttribute :: (IsAttribute (a Low), DevolveM m) => (a High -> m (a Low)) -> a High -> m (Attribute Low)+devolveAttribute f a = do+  a' <- f a+  devolve $ toAttribute' a'++-- | Generate an attribute in the 'EvolveM' monad+fromAttribute ::+  forall a m. (IsAttribute (a Low), Staged a, EvolveM m)+  => Attribute High+  -> Maybe (m (a High))+fromAttribute as =+  if aName as == unConst (attrName :: Const Text.Text (a Low))+  then Just $ do+    either attributeError evolve $ fromAttribute' as+  else Nothing++-- | Generate an attribute in the 'EvolveM' monad+evolveAttribute ::+  forall a m. (IsAttribute (a Low), EvolveM m)+  => (a Low -> m (a High))+  -> Attribute High+  -> Maybe (m (a High))+evolveAttribute g as =+  if aName as == unConst (attrName :: Const Text.Text (a Low))+  then Just $ do+    either attributeError g $ fromAttribute' as+  else Nothing++toC :: (EvolveM m, Staged a, IsAttribute (a Low)) => (a High -> c) -> Attribute High -> Maybe (m c)+toC f attr =+  case fromAttribute attr of+    Just m  -> Just $ f <$> m+    Nothing -> Nothing++toC' :: (EvolveM m, IsAttribute (a Low)) => (a Low -> m (a High)) -> (a High -> c) -> Attribute High -> Maybe (m c)+toC' g f attr =+  case evolveAttribute g attr of+    Just m  -> Just $ f <$> m+    Nothing -> Nothing++collect :: (Monad m) => c -> Attribute High -> [Attribute High -> Maybe (m c)] -> m c+collect c attr options =+  case msum $ Prelude.map ($ attr) options of+    Just x  -> x+    Nothing -> return c++-- | Given a 'Foldable' structure 'f', and a function that can calculate a+-- monoid given an 'Attribute' calculate the monoid over all attributes.+fromAttributes ::+  (Foldable f, EvolveM m, Monoid a)+  => (Attribute High -> m a)+  -> f (Attribute Low)+  -> m a+fromAttributes f attrs =+  Prelude.foldl g (return mempty) attrs+  where+    g m a' = do+      b <- m+      x <- f =<< evolve a'+      return $ b `mappend` x++readFromStrict :: Binary a => Attribute r -> Either String a+readFromStrict =+    bimap trd trd . decodeOrFail . BL.fromStrict . aInfo

@@ -1,3 +1,9 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE StandaloneDeriving #-} {-| Module      : Language.JVM.Attribute.BootstrapMethods Copyright   : (c) Christian Gram Kalhauge, 2017@@ -7,41 +13,47 @@ Based on the BootstrapMethods Attribute, as documented [here](http://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.23). -}-{-# LANGUAGE DeriveGeneric   #-}  module Language.JVM.Attribute.BootstrapMethods   ( BootstrapMethods (..)   , methods   , BootstrapMethod (..)-  , arguments   ) where -import           GHC.Generics          (Generic)--import           Data.Binary--import           Language.JVM.Constant (ConstantRef (..))+import           Language.JVM.Constant+import           Language.JVM.Attribute.Base+import           Language.JVM.Staged import           Language.JVM.Utils --- | Is a list of bootstrapped methods.-data BootstrapMethods = BootstrapMethods-  { methods' :: SizedList16 BootstrapMethod-  } deriving (Show, Eq, Generic)+-- | 'BootstrapMethods' is an Attribute.+instance IsAttribute (BootstrapMethods Low) where+  attrName = Const "BootstrapMethods" -instance Binary BootstrapMethods where+-- | Is a list of bootstrapped methods.+newtype BootstrapMethods r = BootstrapMethods+  { methods' :: SizedList16 (BootstrapMethod r)+  }  -- | The methods as list-methods :: BootstrapMethods -> [ BootstrapMethod ]+methods :: BootstrapMethods r -> [ BootstrapMethod r ] methods = unSizedList . methods'  -- | A bootstraped methods.-data BootstrapMethod = BootstrapMethod-  { methodIndex :: ConstantRef-  , arguments' :: SizedList16 ConstantRef-  } deriving (Show, Eq, Generic)+data BootstrapMethod r = BootstrapMethod+  { method :: !(DeepRef MethodHandle r)+  , arguments :: !(SizedList16 (Ref JValue r))+  } --- | The arguments is a cool-arguments :: BootstrapMethod -> [ ConstantRef ]-arguments = unSizedList . arguments'+instance Staged BootstrapMethods where+  stage f (BootstrapMethods m) =+    label "BootstrapMethods" $ BootstrapMethods <$> mapM f m -instance Binary BootstrapMethod where+instance Staged BootstrapMethod where+  evolve (BootstrapMethod a m) =+    BootstrapMethod <$> link a <*> mapM link m++  devolve (BootstrapMethod a m) =+    BootstrapMethod <$> unlink a <*> mapM unlink m++$(deriveBaseWithBinary ''BootstrapMethod)+$(deriveBaseWithBinary ''BootstrapMethods)

@@ -1,664 +1,136 @@ {-| Module      : Language.JVM.Attribute.Code-Copyright   : (c) Christian Gram Kalhauge, 2017+Copyright   : (c) Christian Gram Kalhauge, 2018 License     : MIT Maintainer  : kalhuage@cs.ucla.edu -}--{-# LANGUAGE DeriveGeneric   #-}-{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RecordWildCards    #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell    #-} module Language.JVM.Attribute.Code   ( Code (..)--  , ByteCode (..)+  , CodeAttributes (..)   , ExceptionTable (..)--  , ByteCodeInst (..)-  , ByteCodeOpr (..)--  , Constant (..)-  , WordSize-  , OneOrTwo (..)-  , ArithmeticType (..)-  , SmallArithmeticType (..)-  , BinOpr (..)-  , LocalType (..)-  , ArrayType (..)-  , CmpOpr (..)-  , LongOffset-  , Offset--  , LocalAddress (..)-  , IncrementAmount (..)-  , BitOpr (..)-  , FieldAccess (..)-  , Invokation (..)+  , codeStackMapTable+  , codeByteCodeOprs+  , codeByteCodeInsts   ) where -import           GHC.Generics          (Generic)--import           Prelude               hiding (fail)-import qualified Prelude               as P--import           Numeric               (showHex)--import           Control.Monad         hiding (fail)-import           Control.Monad.Fail    (fail)+import           Prelude hiding (fail)  import           Data.Binary-import           Data.Binary.Get       hiding (Get)-import           Data.Binary.Put       hiding (Put)-import qualified Data.ByteString.Lazy  as BL-import           Data.Int-import qualified Data.Vector           as V+import           Data.Monoid+import qualified Data.Vector as V -import           Language.JVM.Constant (ConstantRef (..))+import           Language.JVM.Attribute.Base+import           Language.JVM.Attribute.LineNumberTable+import           Language.JVM.Attribute.StackMapTable+import           Language.JVM.ByteCode+import           Language.JVM.Constant+import           Language.JVM.Staged import           Language.JVM.Utils --data Code a = Code-  { maxStack       :: Int16-  , maxLocals      :: Int16-  , bytecode       :: ByteCode-  , exceptionTable :: SizedList16 ExceptionTable-  , attributes     :: SizedList16 a-  } deriving (Show, Eq, Generic)--instance (Binary a) => Binary (Code a) where-  -- Auto implemented by generic--newtype ByteCode = ByteCode-  { unByteCode :: [ByteCodeInst]-  } deriving (Show, Eq)--instance Binary ByteCode where-  get = do-    x <- getWord32be-    bs <- getLazyByteString (fromIntegral x)-    case runGetOrFail go bs of-      Right (_,_,bcs) -> return $ ByteCode bcs-      Left (_,_,msg)  -> fail msg-    where-      go = isEmpty >>= \t ->-        if t-          then return []-          else do-            x <- get-            (x:) <$> go---  put (ByteCode lst)= do-    let bs = runPut (mapM_ put lst)-    putWord32be (fromIntegral $ BL.length bs)-    putLazyByteString bs+-- | 'Code' is an Attribute.+instance IsAttribute (Code Low) where+  attrName = Const "Code" +-- | Code contains the actual byte-code. The 'i' type parameter is added to+-- allow indicate the two stages of the code file, before and after access to+-- the 'ConstantPool'. i should be either 'Ref' or 'Deref'.+data Code r = Code+  { codeMaxStack       :: !(Word16)+  , codeMaxLocals      :: !(Word16)+  , codeByteCode       :: !((ByteCode r))+  , codeExceptionTable :: !(SizedList16 (ExceptionTable r))+  , codeAttributes     :: !(Attributes CodeAttributes r)+  } -data ExceptionTable = ExceptionTable-  { start     :: ! Word16+data ExceptionTable r = ExceptionTable+  { start     :: ! (ByteCodeRef r)   -- ^ Inclusive program counter into 'code'-  , end       :: ! Word16+  , end       :: ! (ByteCodeRef r)   -- ^ Exclusive program counter into 'code'-  , handler   :: ! Word16+  , handler   :: ! (ByteCodeRef r)   -- ^ A program counter into 'code' indicating the handler.-  , catchType :: ! ConstantRef+  , catchType :: ! (Ref (Maybe ClassName) r)   }-  deriving (Show, Eq, Generic) -instance Binary ExceptionTable where--data ByteCodeInst = ByteCodeInst-  { offset :: LongOffset-  , opcode :: ByteCodeOpr-  }-  deriving (Show, Eq, Generic)--instance Binary ByteCodeInst where-  get =-    ByteCodeInst <$> (fromIntegral <$> bytesRead) <*> get-  put x =-    put $ opcode x--data ArithmeticType = MInt | MLong | MFloat | MDouble-  deriving (Show, Eq, Enum, Bounded)--data SmallArithmeticType = MByte | MChar | MShort-  deriving (Show, Eq, Enum, Bounded)--data LocalType = LInt | LLong | LFloat | LDouble | LRef-  deriving (Show, Eq, Enum, Bounded)--data ArrayType a-  = ABoolean | AByte | AChar | AShort | AInt | ALong-  | AFloat | ADouble | ARef a-  deriving (Show, Eq)--data Invokation-  = InvkSpecial-  | InvkVirtual-  | InvkStatic-  | InvkInterface Word8-  | InvkDynamic-  deriving (Show, Eq)--data FieldAccess-  = FldStatic-  | FldField-  deriving (Show, Eq)--data OneOrTwo = One | Two-  deriving (Show, Ord, Bounded, Eq, Enum)--type WordSize = OneOrTwo--data Constant-  = CNull--  | CIntM1-  | CInt0-  | CInt1-  | CInt2-  | CInt3-  | CInt4-  | CInt5--  | CLong0-  | CLong1--  | CFloat0-  | CFloat1-  | CFloat2--  | CDouble0-  | CDouble1--  | CByte Int8-  | CShort Int16--  | CHalfRef ConstantRef-  | CRef WordSize ConstantRef-  deriving (Show, Eq)--data BinOpr-  = Add-  | Sub-  | Mul-  | Div-  | Rem-  deriving (Show, Eq)--data BitOpr-  = ShL-  | ShR-  | UShR-  | And-  | Or-  | XOr-  deriving (Show, Eq)--type Offset = Int16-type LongOffset = Int32--data LocalAddress-  = LWide Word16-  | LSingle Word8-  deriving (Show, Eq)--data IncrementAmount-  = IWide Int16-  | ISingle Int8-  deriving (Show, Eq)--data CmpOpr-  = CEq | CNe | CLt | CGe | CGt | CLe-  deriving (Show, Eq)--data ByteCodeOpr-  = ArrayLoad (ArrayType ())-  -- ^ aaload baload ...-  | ArrayStore (ArrayType ())-  -- ^ aastore bastore ...--  | Push Constant--  | Load LocalType LocalAddress-  -- ^ aload_0, bload_2, iload 5 ...-  | Store LocalType LocalAddress-  -- ^ aload, bload ...--  | BinaryOpr BinOpr ArithmeticType-  -- ^ iadd ...-  | Neg ArithmeticType-  -- ^ ineg ...--  | BitOpr BitOpr WordSize-  -- ^ Exclusively on int and long, identified by the word-size--  | IncrLocal !LocalAddress !IncrementAmount-  -- ^ Only works on ints, increment local #1, with #2--  | Cast ArithmeticType ArithmeticType-  -- ^ Only valid on different types--  | CastDown SmallArithmeticType-  -- ^ Only valid on different types--  | CompareLongs--  | CompareFloating Bool WordSize-  -- ^ Compare two floating values, #1 indicates if greater-than, #2-  -- is if float or double should be used.--  | If CmpOpr OneOrTwo Offset-  -- ^ compare with 0 if #2 is False, and two ints from the stack if-  -- True. the last value is the offset--  | IfRef Bool OneOrTwo Offset-  -- ^ check if two objects are equal, or not equal. If #2 is True, compare-  -- with null.--  | Goto LongOffset-  | Jsr LongOffset-  | Ret LocalAddress--  | TableSwitch Int32 Int32 Int32 (V.Vector Int32)-  -- ^ a table switch has 3 values `default` `low` `high` and a list of-  -- offets.-  | LookupSwitch Int32 (V.Vector (Int32, Int32))-  -- ^ a lookup switch has a `default` value and a list of pairs.--  | Get FieldAccess ConstantRef-  | Put FieldAccess ConstantRef--  | Invoke Invokation ConstantRef--  | New ConstantRef-  | NewArray (ArrayType ConstantRef)--  | ArrayLength--  | Throw--  | CheckCast ConstantRef-  | InstanceOf ConstantRef--  | Monitor Bool-  -- ^ True => Enter, False => Exit--  | MultiNewArray ConstantRef Word8-  -- ^ Create a new multi array of #1 and with #2 dimensions--  | Return (Maybe LocalType)--  | Nop--  | Pop WordSize--  | Dup WordSize-  | DupX1 WordSize-  | DupX2 WordSize--  | Swap--  deriving (Show, Eq)--instance Binary ByteCodeOpr where-  get = do-    cmd <- getWord8-    case cmd of-      0x00 -> return Nop-      0x01 -> return $ Push CNull--      0x02 -> return $ Push CIntM1-      0x03 -> return $ Push CInt0-      0x04 -> return $ Push CInt1-      0x05 -> return $ Push CInt2-      0x06 -> return $ Push CInt3-      0x07 -> return $ Push CInt4-      0x08 -> return $ Push CInt5--      0x09 -> return $ Push CLong0-      0x0a -> return $ Push CLong1--      0x0b -> return $ Push CFloat0-      0x0c -> return $ Push CFloat1-      0x0d -> return $ Push CFloat2--      0x0e -> return $ Push CDouble0-      0x0f -> return $ Push CDouble1--      0x10 -> Push . CByte <$> get-      0x11 -> Push . CShort <$> get--      0x12 -> Push . CHalfRef . ConstantRef . fromIntegral <$> getWord8-      0x13 -> Push . CRef One <$> get-      0x14 -> Push . CRef Two <$> get--      0x15 -> Load LInt . LSingle <$> get-      0x16 -> Load LLong . LSingle <$> get-      0x17 -> Load LFloat . LSingle <$> get-      0x18 -> Load LDouble . LSingle <$> get-      0x19 -> Load LRef . LSingle <$> get--      0x1a -> return $ Load LInt (LSingle 0)-      0x1b -> return $ Load LInt (LSingle 1)-      0x1c -> return $ Load LInt (LSingle 2)-      0x1d -> return $ Load LInt (LSingle 3)--      0x1e -> return $ Load LLong (LSingle 0)-      0x1f -> return $ Load LLong (LSingle 1)-      0x20 -> return $ Load LLong (LSingle 2)-      0x21 -> return $ Load LLong (LSingle 3)--      0x22 -> return $ Load LFloat (LSingle 0)-      0x23 -> return $ Load LFloat (LSingle 1)-      0x24 -> return $ Load LFloat (LSingle 2)-      0x25 -> return $ Load LFloat (LSingle 3)--      0x26 -> return $ Load LDouble (LSingle 0)-      0x27 -> return $ Load LDouble (LSingle 1)-      0x28 -> return $ Load LDouble (LSingle 2)-      0x29 -> return $ Load LDouble (LSingle 3)--      0x2a -> return $ Load LRef (LSingle 0)-      0x2b -> return $ Load LRef (LSingle 1)-      0x2c -> return $ Load LRef (LSingle 2)-      0x2d -> return $ Load LRef (LSingle 3)--      0x2e -> return $ ArrayLoad AInt-      0x2f -> return $ ArrayLoad ALong-      0x30 -> return $ ArrayLoad AFloat-      0x31 -> return $ ArrayLoad ADouble-      0x32 -> return $ ArrayLoad (ARef ())-      0x33 -> return $ ArrayLoad AByte-      0x34 -> return $ ArrayLoad AChar-      0x35 -> return $ ArrayLoad AShort--      0x36 -> Store LInt . LSingle <$> get-      0x37 -> Store LLong . LSingle <$> get-      0x38 -> Store LFloat . LSingle <$> get-      0x39 -> Store LDouble . LSingle <$> get-      0x3a -> Store LRef . LSingle <$> get--      0x3b -> return $ Store LInt (LSingle 0)-      0x3c -> return $ Store LInt (LSingle 1)-      0x3d -> return $ Store LInt (LSingle 2)-      0x3e -> return $ Store LInt (LSingle 3)--      0x3f -> return $ Store LLong (LSingle 0)-      0x40 -> return $ Store LLong (LSingle 1)-      0x41 -> return $ Store LLong (LSingle 2)-      0x42 -> return $ Store LLong (LSingle 3)--      0x43 -> return $ Store LFloat (LSingle 0)-      0x44 -> return $ Store LFloat (LSingle 1)-      0x45 -> return $ Store LFloat (LSingle 2)-      0x46 -> return $ Store LFloat (LSingle 3)--      0x47 -> return $ Store LDouble (LSingle 0)-      0x48 -> return $ Store LDouble (LSingle 1)-      0x49 -> return $ Store LDouble (LSingle 2)-      0x4a -> return $ Store LDouble (LSingle 3)--      0x4b -> return $ Store LRef (LSingle 0)-      0x4c -> return $ Store LRef (LSingle 1)-      0x4d -> return $ Store LRef (LSingle 2)-      0x4e -> return $ Store LRef (LSingle 3)--      0x4f -> return $ ArrayStore AInt-      0x50 -> return $ ArrayStore ALong-      0x51 -> return $ ArrayStore AFloat-      0x52 -> return $ ArrayStore ADouble-      0x53 -> return $ ArrayStore (ARef ())-      0x54 -> return $ ArrayStore AByte-      0x55 -> return $ ArrayStore AChar-      0x56 -> return $ ArrayStore AShort--      0x57 -> return $ Pop One-      0x58 -> return $ Pop Two--      0x59 -> return $ Dup One-      0x5a -> return $ DupX1 One-      0x5b -> return $ DupX2 One--      0x5c -> return $ Dup Two-      0x5d -> return $ DupX1 Two-      0x5e -> return $ DupX2 Two--      0x5f -> return $ Swap--      0x60 -> return $ BinaryOpr Add MInt-      0x61 -> return $ BinaryOpr Add MLong-      0x62 -> return $ BinaryOpr Add MFloat-      0x63 -> return $ BinaryOpr Add MDouble--      0x64 -> return $ BinaryOpr Sub MInt-      0x65 -> return $ BinaryOpr Sub MLong-      0x66 -> return $ BinaryOpr Sub MFloat-      0x67 -> return $ BinaryOpr Sub MDouble--      0x68 -> return $ BinaryOpr Mul MInt-      0x69 -> return $ BinaryOpr Mul MLong-      0x6a -> return $ BinaryOpr Mul MFloat-      0x6b -> return $ BinaryOpr Mul MDouble--      0x6c -> return $ BinaryOpr Div MInt-      0x6d -> return $ BinaryOpr Div MLong-      0x6e -> return $ BinaryOpr Div MFloat-      0x6f -> return $ BinaryOpr Div MDouble--      0x70 -> return $ BinaryOpr Rem MInt-      0x71 -> return $ BinaryOpr Rem MLong-      0x72 -> return $ BinaryOpr Rem MFloat-      0x73 -> return $ BinaryOpr Rem MDouble--      0x74 -> return $ Neg MInt-      0x75 -> return $ Neg MLong-      0x76 -> return $ Neg MFloat-      0x77 -> return $ Neg MDouble--      0x78 -> return $ BitOpr ShL One-      0x79 -> return $ BitOpr ShL Two-      0x7a -> return $ BitOpr ShR One-      0x7b -> return $ BitOpr ShR Two--      0x7c -> return $ BitOpr UShR One-      0x7d -> return $ BitOpr UShR Two--      0x7e -> return $ BitOpr And One-      0x7f -> return $ BitOpr And Two-      0x80 -> return $ BitOpr Or One-      0x81 -> return $ BitOpr Or Two-      0x82 -> return $ BitOpr XOr One-      0x83 -> return $ BitOpr XOr Two--      0x84 -> IncrLocal <$> (LSingle <$> get) <*> (ISingle <$> get)--      0x85 -> return $ Cast MInt MLong-      0x86 -> return $ Cast MInt MFloat-      0x87 -> return $ Cast MInt MDouble--      0x88 -> return $ Cast MLong MInt-      0x89 -> return $ Cast MLong MFloat-      0x8a -> return $ Cast MLong MDouble--      0x8b -> return $ Cast MFloat MInt-      0x8c -> return $ Cast MFloat MLong-      0x8d -> return $ Cast MFloat MDouble--      0x8e -> return $ Cast MDouble MInt-      0x8f -> return $ Cast MDouble MLong-      0x90 -> return $ Cast MDouble MFloat--      0x91 -> return $ CastDown MByte-      0x92 -> return $ CastDown MChar-      0x93 -> return $ CastDown MShort--      0x94 -> return $ CompareLongs--      0x95 -> return $ CompareFloating True One-      0x96 -> return $ CompareFloating False Two--      0x97 -> return $ CompareFloating True One-      0x98 -> return $ CompareFloating False Two--      0x99 -> If CEq One <$> get-      0x9a -> If CNe One <$> get-      0x9b -> If CLt One <$> get-      0x9c -> If CGe One <$> get-      0x9d -> If CGt One <$> get-      0x9e -> If CLe One <$> get--      0x9f -> If CEq Two <$> get-      0xa0 -> If CNe Two <$> get-      0xa1 -> If CLt Two <$> get-      0xa2 -> If CGe Two <$> get-      0xa3 -> If CGt Two <$> get-      0xa4 -> If CLe Two <$> get--      0xa5 -> IfRef True Two <$> get-      0xa6 -> IfRef False Two <$> get--      0xa7 -> Goto . fromIntegral <$> getInt16be-      0xa8 -> Jsr . fromIntegral <$> getInt16be-      0xa9 -> Ret . LSingle <$> get--      0xaa -> do-        offset' <- bytesRead-        let skipAmount = (4 - offset' `mod` 4) `mod` 4-        if skipAmount > 0 then skip $ fromIntegral skipAmount else return ()-        dft <- getInt32be-        low <- getInt32be-        high <- getInt32be-        table <- V.replicateM (fromIntegral $ high - low + 1) getInt32be-        return $ TableSwitch dft low high table--      0xab -> do-        offset' <- bytesRead-        let skipAmount = (4 - offset' `mod` 4) `mod` 4-        if skipAmount > 0 then skip $ fromIntegral skipAmount else return ()-        dft <- getInt32be-        npairs <- getInt32be-        pairs <- V.replicateM (fromIntegral npairs) get-        return $ LookupSwitch dft pairs--      0xac -> return . Return . Just $ LInt-      0xad -> return . Return . Just $ LLong-      0xae -> return . Return . Just $ LFloat-      0xaf -> return . Return . Just $ LDouble-      0xb0 -> return . Return . Just $ LRef-      0xb1 -> return . Return $ Nothing--      0xb2 -> Get FldStatic <$> get-      0xb3 -> Put FldStatic <$> get--      0xb4 -> Get FldField <$> get-      0xb5 -> Put FldField <$> get--      0xb6 -> Invoke InvkVirtual <$> get-      0xb7 -> Invoke InvkSpecial <$> get-      0xb8 -> Invoke InvkStatic <$> get-      0xb9 -> do-        ref <- get-        count <- get-        when (count == 0) $ fail "Should be not zero"-        zero <- getWord8-        when (zero /= 0) $ fail "Should be zero"-        return $ Invoke (InvkInterface count) ref-      0xba -> do-        ref <- get-        count <- getWord8-        when (count /= 0) $ fail "Should be zero"-        zero <- getWord8-        when (zero /= 0) $ fail "Should be zero"-        return $ Invoke InvkDynamic ref-      0xbb -> New <$> get--      0xbc -> do-        x <- getWord8-        NewArray <$> case x of-          4  -> return ABoolean-          5  -> return AChar-          6  -> return AFloat-          7  -> return ADouble-          8  -> return AByte-          9  -> return AShort-          10 -> return AInt-          11 -> return ALong-          _  -> fail $ "Unknown type '0x" ++ showHex x "'."--      0xbd -> NewArray . ARef <$> get--      0xbe -> return ArrayLength--      0xbf -> return Throw--      0xc0 -> CheckCast <$> get-      0xc1 -> InstanceOf <$> get--      0xc2 -> return $ Monitor True-      0xc3 -> return $ Monitor False--      0xc4 -> do-        subopcode <- getWord8-        case subopcode of-          0x15 -> Load LInt . LWide <$> get-          0x16 -> Load LLong . LWide <$> get-          0x17 -> Load LFloat . LWide <$> get-          0x18 -> Load LDouble . LWide <$> get-          0x19 -> Load LRef . LWide <$> get--          0x36 -> Store LInt . LWide <$> get-          0x37 -> Store LLong . LWide <$> get-          0x38 -> Store LFloat . LWide <$> get-          0x39 -> Store LDouble . LWide <$> get-          0x3a -> Store LRef . LWide <$> get+-- | Extracts a list of bytecode operation+codeByteCodeOprs :: Code High -> V.Vector (ByteCodeOpr High)+codeByteCodeOprs =+  unByteCode . codeByteCode -          0x84 -> IncrLocal <$> (LWide <$> get)-                            <*> (IWide <$> get)+-- | Extracts a list of bytecode instructions+codeByteCodeInsts :: Code Low -> V.Vector (ByteCodeInst Low)+codeByteCodeInsts =+  snd . unByteCode . codeByteCode -          0xa9 -> Ret . LWide <$> get+-- | Returns the StackMapTable attribute if any+codeStackMapTable :: Code High -> Maybe (StackMapTable High)+codeStackMapTable =+  firstOne . caStackMapTable . codeAttributes -          _ -> fail $ "Wide does not work for opcode 'Ox"-                ++ showHex subopcode "'"+data CodeAttributes r = CodeAttributes+  { caStackMapTable   :: [ StackMapTable r ]+  , caLineNumberTable :: [ LineNumberTable r ]+  , caOthers          :: [ Attribute r ]+  } -      0xc5 -> MultiNewArray <$> get <*> get+instance Staged Code where+  evolve Code{..} = label "Code" $ do+    (offsets, codeByteCode) <- evolveByteCode codeByteCode+    let evolver = (evolveOffset offsets)+    codeExceptionTable <- mapM (evolveBC evolver) codeExceptionTable+    codeAttributes <- fromCollector <$> fromAttributes (collect' evolver) codeAttributes+    return $ Code {..}+    where+      fromCollector (a, b, c) =+        CodeAttributes (appEndo a []) (appEndo b []) (appEndo c [])+      collect' evolver attr =+        collect (mempty, mempty, Endo (attr:)) attr+          [ toC' (evolveBC evolver) $ \e -> (Endo (e:), mempty, mempty)+          , toC' (evolveBC evolver) $ \e -> (mempty, Endo (e:), mempty)+          ] -      0xc6 -> IfRef False One <$> get-      0xc7 -> IfRef True One <$> get+  devolve Code{..} = do+    codeByteCode <- devolveByteCode codeByteCode+    let bcdevolver = devolveOffset codeByteCode+    codeExceptionTable <-+      mapM (devolveBC bcdevolver) codeExceptionTable+    codeAttributes <- SizedList <$> fromCodeAttributes bcdevolver codeAttributes+    return $ Code {..}+    where+      fromCodeAttributes bcdevolver (CodeAttributes a b c) = do+        a' <- mapM (devolveAttribute (devolveBC bcdevolver)) a+        b' <- mapM (devolveAttribute (devolveBC bcdevolver)) b+        c' <- mapM devolve c+        return (a' ++ b' ++ c') -      0xc8 -> Goto <$> getInt32be-      0xc9 -> Jsr <$> getInt32be+instance ByteCodeStaged ExceptionTable where+  evolveBC f ExceptionTable{..} = label "ExceptionTable" $ do+    catchType <- case catchType of+      0 -> return $ Nothing+      n -> Just <$> link n+    start <- f start+    end <- f end+    handler <- f handler+    return $ ExceptionTable {..} -      _ -> fail $ "I do not know this bytecode '0x" ++ showHex cmd "'."+  devolveBC f ExceptionTable{..} = do+    catchType <- case catchType of+      Just s  -> unlink s+      Nothing -> return $ 0+    start <- f start+    end <- f end+    handler <- f handler+    return $ ExceptionTable {..}  -  put bc =-    case bc of-      Nop -> putInt8 0x00-      Push CNull -> putInt8 0x01--      Push CIntM1 -> putInt8 0x02-      Push CInt0 -> putInt8 0x03-      Push CInt1 -> putInt8 0x04-      Push CInt2 -> putInt8 0x05-      Push CInt3 -> putInt8 0x06-      Push CInt4 -> putInt8 0x07-      Push CInt5 -> putInt8 0x08--      Push CLong0 -> putInt8 0x09-      Push CLong1 -> putInt8 0x0a--      Push CFloat0 -> putInt8 0x0b-      Push CFloat1 -> putInt8 0x0c-      Push CFloat2 -> putInt8 0x0d--      Push CDouble0 -> putInt8 0x0e-      Push CDouble1 -> putInt8 0x0f--      Push (CByte x) -> putInt8 0x10 >> put x-      Push (CShort x) -> putInt8 0x11 >> put x--      Push (CHalfRef (ConstantRef r)) -> putInt8 0x12 >> putWord8 (fromIntegral r)-      Push (CRef One (ConstantRef r)) -> putInt8 0x13 >> put r-      Push (CRef Two (ConstantRef r)) -> putInt8 0x14 >> put r-      _ -> P.fail $ "Is not able to print '" ++ show bc ++ "' yet."+$(deriveBaseWithBinary ''Code)+$(deriveBaseWithBinary ''ExceptionTable)+$(deriveBase ''CodeAttributes)

@@ -1,3 +1,9 @@+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell    #-} {-| Module      : Language.JVM.Attribute.ConstantValue Copyright   : (c) Christian Gram Kalhauge, 2017@@ -6,21 +12,29 @@  Based on the ConstantValue, as documented [here](http://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.5). -}-{-# LANGUAGE DeriveGeneric   #-}  module Language.JVM.Attribute.ConstantValue   ( ConstantValue (..)   ) where -import           GHC.Generics          (Generic)+import           Language.JVM.Attribute.Base+import           Language.JVM.Constant+import           Language.JVM.Staged -import           Data.Binary+-- | 'ConstantValue' is an Attribute.+instance IsAttribute (ConstantValue Low) where+  attrName = Const "ConstantValue" -import           Language.JVM.Constant (ConstantRef (..))  -- | A constant value is just a index into the constant pool.-data ConstantValue = ConstantValue-  { constantValueIndex :: !ConstantRef-  } deriving (Show, Eq, Generic)+data ConstantValue r = ConstantValue+  { constantValue :: !(Ref JValue r)+  } -instance Binary ConstantValue where+instance Staged ConstantValue where+  evolve (ConstantValue r) =+    ConstantValue <$> link r+  devolve (ConstantValue r) =+    ConstantValue <$> unlink r++$(deriveBaseWithBinary ''ConstantValue)

@@ -1,3 +1,9 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric   #-}+{-# LANGUAGE DeriveAnyClass   #-} {-| Module      : Language.JVM.Attribute.Exceptions Copyright   : (c) Christian Gram Kalhauge, 2017@@ -7,28 +13,28 @@ Based on the Exceptions Attribute, as documented [here](http://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.5). It describes the checked exceptions that a method can make. -}-{-# LANGUAGE DeriveGeneric   #-}- module Language.JVM.Attribute.Exceptions   ( Exceptions (..)-  , exceptionIndexTable   ) where -import           GHC.Generics          (Generic)+import           Language.JVM.Attribute.Base+import           Language.JVM.Staged+import           Language.JVM.Constant+import           Language.JVM.Utils -import           Data.Binary -import           Language.JVM.Constant (ConstantRef (..))-import           Language.JVM.Utils+-- | 'Exceptions' is an Attribute.+instance IsAttribute (Exceptions Low) where+  attrName = Const "Exceptions"  -- | An Exceptions attribute is a list of references into the -- constant pool.-data Exceptions = Exceptions-  { exceptionIndexTable' :: SizedList16 ConstantRef-  } deriving (Show, Eq, Generic)+newtype Exceptions r = Exceptions+  { exceptions :: SizedList16 (Ref ClassName r)+  } --- | Get the constant refs that points .-exceptionIndexTable :: Exceptions -> [ConstantRef]-exceptionIndexTable = unSizedList . exceptionIndexTable'+instance Staged Exceptions where+  evolve (Exceptions t) = Exceptions <$> mapM link t+  devolve (Exceptions t) = Exceptions <$> mapM unlink t -instance Binary Exceptions where+$(deriveBaseWithBinary ''Exceptions)

@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell    #-}+{-|+Module      : Language.JVM.Attribute.LineNumberTable+Copyright   : (c) Christian Gram Kalhauge, 2018+License     : MIT+Maintainer  : kalhuage@cs.ucla.edu++Based on the LineNumberTable Attribute,+as documented [here](http://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.12).+-}++module Language.JVM.Attribute.LineNumberTable+  ( LineNumberTable (..)+  , LineNumber++  , BinaryFormat+  -- * Helper functions+  , linenumber+  , linenumber'+  ) where++import           Control.DeepSeq             (NFData)+import           Data.Binary+import qualified Data.IntMap as IM+import           GHC.Generics                (Generic)+import           Language.JVM.Attribute.Base+import           Language.JVM.ByteCode+import           Language.JVM.Utils+import           Language.JVM.Staged++-- | 'Signature' is an Attribute.+instance IsAttribute (LineNumberTable Low) where+  attrName = Const "LineNumberTable"++type LineNumber = Word16++-- | The 'LineNumberTable' is just a mapping from offsets to linenumbers.+newtype LineNumberTable r = LineNumberTable+  { lineNumberTable :: IM.IntMap LineNumber+  } deriving (Show, Eq, Ord, Generic, NFData)+++instance ByteCodeStaged LineNumberTable where+  evolveBC f (LineNumberTable mp) =+    LineNumberTable+    . IM.fromList <$> (mapM (\(x, y) -> do x' <- f (fromIntegral x); pure (x', y)) . IM.toList) mp++  devolveBC f (LineNumberTable mp) =+    LineNumberTable+    . IM.fromList <$> (mapM (\(x, y) -> do x' <- f x; pure (fromIntegral x', y)) . IM.toList) mp++-- | Returns the line number of an offset.+linenumber :: Int -> LineNumberTable r -> Maybe LineNumber+linenumber i (LineNumberTable t) =+  snd <$> IM.lookupLE i t++-- | Returns the line number of an offset. Helper function that also+-- does the conversion from integral to int.+linenumber' :: Integral a => a -> LineNumberTable r -> Maybe LineNumber+linenumber' i = linenumber (fromIntegral i)++type BinaryFormat = SizedList16 (Word16, LineNumber)++instance Binary (LineNumberTable Low) where+  get = do+    LineNumberTable . IM.fromList . map f . unSizedList <$> (get :: Get BinaryFormat)+    where+      f (a,b) = (fromIntegral a, b)+  put (LineNumberTable x) = do+    put sl+    where+      sl :: BinaryFormat+      sl = SizedList . map f . IM.toList $ x+      f (a,b) = (fromIntegral a, b)

@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell    #-}+{-|+Module      : Language.JVM.Attribute.Signature+Copyright   : (c) Christian Gram Kalhauge, 2018+License     : MIT+Maintainer  : kalhuage@cs.ucla.edu++Based on the Signature Attribute,+as documented [here](http://docs.oracle.com/javase/specs/jvms/se9/html/jvms-4.html#jvms-4.7.9),+and the signature syntax defined [here](https://docs.oracle.com/javase/specs/jvms/se9/html/jvms-4.html#jvms-4.7.9.1).+-}++module Language.JVM.Attribute.Signature+  ( Signature (..)+  , signatureToText+  , signatureFromText+  ) where++-- import           Control.DeepSeq             (NFData)+-- import           Data.Binary+-- import qualified Data.IntMap                 as IM+import qualified Data.Text                   as Text+-- import           GHC.Generics                (Generic)+import           Language.JVM.Attribute.Base+import           Language.JVM.Staged+-- import           Language.JVM.Type++instance IsAttribute (Signature Low) where+  attrName = Const "Signature"++data Signature a =+  Signature (Ref Text.Text a)++signatureToText :: Signature High -> Text.Text+signatureToText (Signature s) = s++signatureFromText :: Text.Text -> Signature High+signatureFromText s = Signature s++-- data ClassSignature = ClassSignature+--   { csTypeParameters :: [TypeParameter]+--   , csSuperclassSignature :: ClassTypeSignature+--   , csInterfaceSignatures :: [ClassTypeSignature]+--   }++-- data TypeParameter =+--   TypeParameter+--   { tpIndentifier :: Text.Text+--   , tpClassBound :: Maybe ClassName+--   , tpInterfaceBound :: [ClassName]+--   }++-- data ClassTypeSignature+--   = ClassTypeSignature+--     { ctsClassName :: ClassName+--     , ctsTypeArguments :: [TypeArgument]+--     }+--   | InnerClassTypeSignature+--     { ctsInnerClassName :: Text.Text+--     , ctsTypeArguments :: [TypeArgument]+--     }++-- data TypeArgument+--   = AnyTypeArgument+--   | TypeArgument+--     { taWildcard :: Maybe Wildcard+--     , taType :: ReferenceType+--     }++-- data ReferenceType+--   = RTClassType ClassTypeSignature+--   | RTTypeVariable TypeVariableSignature+--   | RTArrayType JavaTypeSignature++-- newtype TypeVariableSignature+--   = TypeVariableSignature Text.Text++-- data JavaTypeSignature+--   = ReferenceType ReferenceType+--   | BaseType JBaseType++-- data Wildcard =+--   WPlus | WMinus++instance Staged Signature where+  evolve (Signature a) =+    label "Signature" $ Signature <$> link a++  devolve (Signature a) =+    label "Signature" $ Signature <$> unlink a++$(deriveBaseWithBinary ''Signature)

@@ -1,6 +1,13 @@+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TemplateHaskell     #-} {-| Module      : Language.JVM.Attribute.StackMapTable-Copyright   : (c) Christian Gram Kalhauge, 2017+Copyright   : (c) Christian Gram Kalhauge, 2018 License     : MIT Maintainer  : kalhuage@cs.ucla.edu @@ -8,7 +15,6 @@ as documented [here](http://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.4).  -}-{-# LANGUAGE DeriveGeneric   #-}  module Language.JVM.Attribute.StackMapTable   ( StackMapTable (..)@@ -17,76 +23,86 @@   , StackMapFrameType (..)    , VerificationTypeInfo (..)-  ) where -import           GHC.Generics          (Generic)+  -- * Helper functions+  , offsetDelta+  , offsetDeltaInv+  ) where +import           Control.Monad               (replicateM) import           Data.Binary+import           Data.Binary.Get             hiding (label)+import           Data.Binary.Put+import           Data.Foldable import           Numeric-import           Control.Monad (replicateM)+import           Unsafe.Coerce -import           Language.JVM.Constant (ConstantRef (..))+import           Language.JVM.Attribute.Base+import           Language.JVM.ByteCode+import           Language.JVM.Constant+import           Language.JVM.Staged import           Language.JVM.Utils +-- | 'StackMapTable' is an Attribute.+instance IsAttribute (StackMapTable Low) where+  attrName = Const "StackMapTable"+ -- | An Exceptions attribute is a list of references into the -- constant pool.-data StackMapTable = StackMapTable-  { stackMapTable :: SizedList16 StackMapFrame-  } deriving (Show, Eq, Generic)--instance Binary StackMapTable where+newtype StackMapTable r = StackMapTable+  { stackMapTable :: Choice (SizedList16 (StackMapFrame Low)) [StackMapFrame High] r+  }  -- | A delta offset-type DeltaOffset = Word8+type DeltaOffset i = Choice Word16 Int i  -- | An stack map frame-data StackMapFrame = StackMapFrame-  { deltaOffset :: DeltaOffset-  , frameType :: StackMapFrameType-  } deriving (Show, Eq)+data StackMapFrame r = StackMapFrame+  { deltaOffset :: DeltaOffset r+  , frameType   :: StackMapFrameType r+  }  -- | An stack map frame type-data StackMapFrameType+data StackMapFrameType r   = SameFrame-  | SameLocals1StackItemFrame VerificationTypeInfo+  | SameLocals1StackItemFrame (VerificationTypeInfo r)   | ChopFrame Word8-  | AppendFrame [VerificationTypeInfo]+  | AppendFrame [VerificationTypeInfo r]   | FullFrame-      (SizedList16 VerificationTypeInfo)-      (SizedList16 VerificationTypeInfo)-  deriving (Show, Eq)+      (SizedList16 (VerificationTypeInfo r))+      (SizedList16 (VerificationTypeInfo r)) -instance Binary StackMapFrame where+instance Binary (StackMapFrame Low) where   get = do     ft <- getWord8     let       framegetter         | 0 <= ft && ft <= 63-        = return $ StackMapFrame ft SameFrame+        = return $ StackMapFrame (fromIntegral ft) SameFrame          | 64 <= ft && ft <= 127-        = StackMapFrame (ft - 64) . SameLocals1StackItemFrame <$> get+        = StackMapFrame (fromIntegral $ ft - 64) . SameLocals1StackItemFrame <$> get          | 128 <= ft && ft <= 246         = fail $ "Reserved for further use: '0x" ++ showHex ft "'"          | ft == 247-        = StackMapFrame <$> get <*> (SameLocals1StackItemFrame <$> get)+        = StackMapFrame <$> getWord16be <*> (SameLocals1StackItemFrame <$> get)          | 248 <= ft && ft <= 250-        = StackMapFrame <$> get <*> pure (ChopFrame (251 - ft))+        = StackMapFrame <$> getWord16be <*> pure (ChopFrame (251 - ft))          | ft == 251-        = StackMapFrame <$> get <*> pure SameFrame+        = StackMapFrame <$> getWord16be <*> pure SameFrame          | 252 <= ft && ft <= 254         = do-            offset <- get+            offset' <- getWord16be             locals <- replicateM (fromIntegral $ ft - 251) get-            return $ StackMapFrame offset (AppendFrame locals)+            return $ StackMapFrame offset' (AppendFrame locals)          | ft == 255-        = StackMapFrame <$> get <*> (FullFrame <$> get <*> get)+        = StackMapFrame <$> getWord16be <*> (FullFrame <$> get <*> get)          | otherwise         = fail $ "Unknown frame type '0x" ++ showHex ft "'"@@ -97,77 +113,146 @@        SameFrame         | off <= 63 ->-            putWord8 off+            putWord8 (fromIntegral off)         | otherwise -> do             putWord8 251-            putWord8 off+            putWord16be off        SameLocals1StackItemFrame vt         | off <= 63 -> do-            putWord8 (64 + off)+            putWord8 $ fromIntegral (64 + off)             put vt         | otherwise -> do             putWord8 247-            putWord8 off+            putWord16be off             put vt        ChopFrame w         | 0 < w && w <= 3 -> do           putWord8 (251 - w)-          putWord8 off+          putWord16be off         | otherwise ->           fail $ "Can't write a cutoff value outside ]0,3], but was: " ++ show w        AppendFrame vs         | length vs <= 3 && 0 < length vs -> do           putWord8 (fromIntegral $ 251 + length vs)-          putWord8 off+          putWord16be off           mapM_ put vs         | otherwise ->           fail $ "The AppendFrame has to contain at least 1 and at most 3 elements: " ++ show vs        FullFrame ls1 ls2 -> do         putWord8 255-        put off+        putWord16be off         put ls1         put ls2  -- | The types info of the stack map frame.-data VerificationTypeInfo-  = VTop-  | VInteger-  | VFloat-  | VLong-  | VDouble-  | VNull-  | VUninitializedThis-  | VObject !ConstantRef-  | VUninitialized !Word16-  deriving (Show, Eq)+data VerificationTypeInfo r+  = VTTop+  | VTInteger+  | VTFloat+  | VTLong+  | VTDouble+  | VTNull+  | VTUninitializedThis+  | VTObject (Ref ClassName r)+  | VTUninitialized !Word16 -instance Binary VerificationTypeInfo where++instance Binary (VerificationTypeInfo Low) where   get = do     tag <- getWord8     case tag of-      0 -> pure VTop-      1 -> pure VInteger-      2 -> pure VFloat-      3 -> pure VLong-      4 -> pure VDouble-      5 -> pure VNull-      6 -> pure VUninitializedThis-      7 -> VObject <$> get-      8 -> VUninitialized <$> get+      0 -> pure VTTop+      1 -> pure VTInteger+      2 -> pure VTFloat+      3 -> pure VTLong+      4 -> pure VTDouble+      5 -> pure VTNull+      6 -> pure VTUninitializedThis+      7 -> VTObject <$> get+      8 -> VTUninitialized <$> get       _ -> fail $ "Unexpected tag : '0x" ++ showHex tag "'"    put a = do     case a of-      VTop -> putWord8 0-      VInteger -> putWord8 1-      VFloat -> putWord8 2-      VLong -> putWord8 3-      VDouble -> putWord8 4-      VNull -> putWord8 5-      VUninitializedThis -> putWord8 6-      VObject s -> do putWord8 7; put s-      VUninitialized s -> do putWord8 8; put s+      VTTop               -> putWord8 0+      VTInteger           -> putWord8 1+      VTFloat             -> putWord8 2+      VTLong              -> putWord8 3+      VTDouble            -> putWord8 4+      VTNull              -> putWord8 5+      VTUninitializedThis -> putWord8 6+      VTObject s          -> do putWord8 7; put s+      VTUninitialized s   -> do putWord8 8; put s++instance ByteCodeStaged StackMapTable where+  evolveBC f (StackMapTable ls) =+    label "StackMapTable" $+    StackMapTable . reverse . snd <$> foldl' acc (return (0, [])) ls+    where+      acc a (StackMapFrame delta frm) = do+        (lidx, lst) <- a+        frm' <- evolve frm+        let bco = if lst /= [] then offsetDelta lidx delta else delta+        x <- f bco+        return (bco, StackMapFrame x frm' : lst)++  devolveBC f (StackMapTable ls) =+    label "StackMapTable" $+    StackMapTable . SizedList . reverse . snd <$> foldl' acc (return (0 :: Word16, [])) ls+    where+      acc a (StackMapFrame x frm) = do+        (lidx, lst) <- a+        frm' <- devolve frm+        tidx <- f x+        let delta = if lst /= [] then offsetDeltaInv lidx tidx else tidx+        return (tidx, StackMapFrame delta frm' : lst)+++offsetDelta ::+  Word16+  -- ^ Last Index+  -> Word16+  -- ^ Delta+  -> Word16+  -- ^ This Index+offsetDelta lidx delta+  = lidx + delta + 1++offsetDeltaInv ::+  Word16+  -- ^ Last Index+  -> Word16+  -- ^ Current Index+  -> Word16+  -- ^ Delta+offsetDeltaInv lidx tidx+  = tidx - lidx - 1++instance Staged StackMapFrameType where+  stage f x =+    case x of+      SameLocals1StackItemFrame a -> SameLocals1StackItemFrame <$> f a+      AppendFrame ls              -> AppendFrame <$> mapM f ls+      FullFrame bs as             -> FullFrame <$> mapM f bs <*> mapM f as+      a                           -> return $ unsafeCoerce a++instance Staged VerificationTypeInfo where+  devolve x =+    case x of+      VTObject a -> VTObject <$> unlink a+      a         -> return $ unsafeCoerce a++  evolve x =+    case x of+      VTObject a -> VTObject <$> link a+      a         -> return $ unsafeCoerce a+++$(deriveBaseWithBinary ''StackMapTable)+$(deriveBase ''StackMapFrame)+$(deriveBase ''StackMapFrameType)+$(deriveBase ''VerificationTypeInfo)

@@ -0,0 +1,1322 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE RecordWildCards    #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TupleSections      #-}+{-|+Module      : Language.JVM.ByteCode+Copyright   : (c) Christian Gram Kalhauge, 2018+License     : MIT+Maintainer  : kalhuage@cs.ucla.edu+-}+module Language.JVM.ByteCode+  ( ByteCode (..)++  -- * evolve and devolve+  , evolveByteCode+  , devolveByteCode+  , evolveOffset+  , devolveOffset++  , ByteCodeStaged (..)++  -- * Managing offsets+  , ByteCodeInst (..)+  , ByteCodeRef+  , ByteCodeOffset+  , ByteCodeIndex+  , OffsetMap+  , indexOffset+  , offsetIndex+  , offsetMap++  -- * ByteCode Operations+  , ByteCodeOpr (..)++  , CConstant (..)+  , OneOrTwo (..)++  , SwitchTable (..)+  , switchHigh++  , FieldAccess (..)+  , Invocation (..)++  -- * Operations+  , BinOpr (..)+  , BitOpr (..)+  , CmpOpr (..)+  , CastOpr (..)++  -- * Type sets+  , ArithmeticType (..)+  , SmallArithmeticType (..)+  , LocalType (..)+  , ArrayType (..)+  , ExactArrayType (..)++  -- * Renames+  , WordSize+  , ByteOffset+  , LocalAddress+  , IncrementAmount+  ) where++import           GHC.Generics          (Generic)++import           Numeric               (showHex)+import           Prelude               hiding (fail)++import           Control.DeepSeq       (NFData)+import           Control.Monad         hiding (fail)+import           Control.Monad.Fail    (fail)+import           Unsafe.Coerce++import           Data.Binary+import           Data.Binary.Get       hiding (Get, label)+import           Data.Binary.Put       hiding (Put)+import qualified Data.ByteString.Lazy  as BL+import           Data.Int+import qualified Data.IntMap           as IM+import qualified Data.Vector           as V++import           Language.JVM.Constant+import           Language.JVM.Staged++-- | ByteCode is a newtype wrapper around a list of ByteCode instructions.+-- if the ByteCode is in the Low stage then the byte code instructions are+-- annotated with the byte code offsets.+newtype ByteCode i = ByteCode+  { unByteCode ::+      Choice (Word32, V.Vector (ByteCodeInst Low)) (V.Vector (ByteCodeOpr High)) i+  }++-- | The offset in the byte code+type ByteCodeOffset = Word16++-- | The index of the byte code.+type ByteCodeIndex = Int++-- | A ByteCode reference is either byte code offset in the+-- low stage, and a byte code index in the high state+type ByteCodeRef i  = Choice ByteCodeOffset ByteCodeIndex i++-- | The offset map, maps offset to instruction ids.+type OffsetMap = IM.IntMap ByteCodeIndex++-- | Given an `OffsetMap` turn a offset into a bytecode index+offsetIndex :: OffsetMap -> ByteCodeOffset -> Maybe (ByteCodeIndex)+offsetIndex o i = IM.lookup (fromIntegral i) o++-- | Given an `OffsetMap` turn a offset into a bytecode index+evolveOffset ::+  EvolveM m+  => OffsetMap+  -> ByteCodeOffset+  -> m (ByteCodeIndex)+evolveOffset o i =+  case offsetIndex o i of+    Just a -> return $ a+    Nothing ->+      attributeError $ "Not valid offset " ++ show i++-- | Given low byte code we can create an `OffsetMap`+offsetMap :: ByteCode Low -> OffsetMap+offsetMap (ByteCode (l, v)) =+  IM.fromList+    . ((fromIntegral l, V.length v):)+    . V.ifoldl' (\ls idx i -> (fromIntegral $ offset i, idx) : ls) []+    $ v++-- | Given an `OffsetMap` turn a offset into a bytecode index+devolveOffset ::+  DevolveM m+  => ByteCode Low+  -> ByteCodeIndex+  -> m (ByteCodeOffset)+devolveOffset v i = do+  case indexOffset v i of+    Just x ->+      return x+    Nothing ->+      error $ "Bad index " ++ show i++-- | Return the bytecode offset from the bytecode.+indexOffset :: ByteCode Low -> ByteCodeIndex -> Maybe (ByteCodeOffset)+indexOffset (ByteCode (x, bc)) i =+  if i == V.length bc+    then return (fromIntegral x)+    else offset <$> bc V.!? i++devolveOffset' ::+  DevolveM m+  => V.Vector ByteCodeOffset+  -> ByteCodeIndex+  -> m (ByteCodeOffset)+devolveOffset' v i = do+  case indexOffset' v i of+    Just x ->+      return x+    Nothing ->+      error $ "Bad index " ++ show i++indexOffset' :: V.Vector ByteCodeOffset -> ByteCodeIndex -> Maybe (ByteCodeOffset)+indexOffset' c i = c V.!? i++-- | The byte code instruction is mostly used to succinctly read and+-- write an bytecode instruction from a bytestring.+data ByteCodeInst r = ByteCodeInst+  { offset :: !(ByteCodeOffset)+  , opcode :: !(ByteCodeOpr r)+  }++(...) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c+(...) = (.) . (.)++evolveByteCode :: EvolveM m => ByteCode Low -> m (OffsetMap, ByteCode High)+evolveByteCode bc@(ByteCode (_, v)) = do+  let om = offsetMap bc+  (om,) . ByteCode <$> V.mapM (fmap opcode . evolveByteCodeInst (evolveOffset om)) v++devolveByteCode :: DevolveM m => ByteCode High -> m (ByteCode Low)+devolveByteCode (ByteCode bc) = do+  -- Devolving byte code is not straight forward.+  (len, vect) <- V.foldM' acc (0,[]) bc+  let offsets = V.fromList . reverse $ vect+  ByteCode . (fromIntegral len,)+     <$> V.zipWithM (devolveByteCodeInst (devolveOffset' offsets) ... ByteCodeInst) offsets bc+  where+    acc (off, lst) opr = do+      inst <- devolveByteCodeInst (const $ return 0) (ByteCodeInst off opr)+      let o = off + byteSize inst+      return (o, off:lst)++class ByteCodeStaged s where+  evolveBC ::+    EvolveM m+    => (ByteCodeOffset -> m ByteCodeIndex)+    -> s Low+    -> m (s High)++  devolveBC ::+    DevolveM m+    => (ByteCodeIndex -> m ByteCodeOffset)+    -> s High+    -> m (s Low)++byteSize :: ByteCodeInst Low -> Word16+byteSize inst =+  fromIntegral . BL.length . runPut $ putByteCode (offset inst) (opcode inst)++instance ByteCodeStaged ByteCodeInst where+  evolveBC = evolveByteCodeInst+  devolveBC = devolveByteCodeInst++evolveByteCodeInst ::+  EvolveM m+  => (ByteCodeOffset -> m ByteCodeIndex)+  -> ByteCodeInst Low+  -> m (ByteCodeInst High)+evolveByteCodeInst g (ByteCodeInst ofs opr) = do+  x <- case opr of+    Push c            -> label "Push" $ Push <$> evolveBConstant c+    Get fa r          -> label "Get" $ Get fa <$> link r+    Put fa r          -> label "Put" $ Put fa <$> link r+    Invoke r          -> label "Invoke" $ Invoke <$> evolve r+    New r             -> label "New" $ New <$> link r+    NewArray r        -> label "NewArray" $ NewArray <$> evolve r+    MultiNewArray r u -> label "MultiNewArray" $ MultiNewArray <$> link r <*> pure u+    CheckCast r       -> label "CheckCast" $ CheckCast <$> link r+    InstanceOf r      -> label "InstanceOf" $ InstanceOf <$> link r+    If cp on r        -> label "If" $ If cp on <$> calcOffset r+    IfRef b on r      -> label "IfRef" $ IfRef b on <$> calcOffset r+    Goto r            -> label "Goto" $ Goto <$> calcOffset r+    Jsr r             -> label "Jsr" $ Jsr <$> calcOffset r+    TableSwitch i (SwitchTable l ofss) ->+      label "TableSwitch" $ (TableSwitch i . SwitchTable l <$> V.mapM calcOffset ofss)+    a                 -> return $ unsafeCoerce a+  return (ByteCodeInst ofs x)+  where+    calcOffset r =+      g (fromIntegral $ fromIntegral ofs + r)++devolveByteCodeInst ::+  DevolveM m+  => (ByteCodeIndex -> m ByteCodeOffset)+  -> ByteCodeInst High+  -> m (ByteCodeInst Low)+devolveByteCodeInst g (ByteCodeInst ofs opr) =+  ByteCodeInst ofs <$> case opr of+    Push c            -> label "Push" $ Push <$> devolveBConstant c+    Get fa r          -> label "Get" $ Get fa <$> unlink r+    Put fa r          -> label "Put" $ Put fa <$> unlink r+    Invoke r          -> label "Invoke" $ Invoke <$> devolve r+    New r             -> label "New" $ New <$> unlink r+    NewArray r        -> label "NewArray" $ NewArray <$> devolve r+    MultiNewArray r u -> label "MultiNewArray" $ MultiNewArray <$> unlink r <*> pure u+    CheckCast r       -> label "CheckCast" $ CheckCast <$> unlink r+    InstanceOf r      -> label "InstanceOf" $ InstanceOf <$> unlink r+    If cp on r        -> label "If" $ If cp on <$> calcOffset r+    IfRef b on r      -> label "IfRef" $ IfRef b on <$> calcOffset r+    Goto r            -> label "Goto" $ Goto <$> calcOffset r+    Jsr r             -> label "Jsr" $ Jsr <$> calcOffset r+    TableSwitch i (SwitchTable l ofss) -> label "TableSwitch" $+        (TableSwitch i . SwitchTable l <$> V.mapM calcOffset ofss)+    a -> return $ unsafeCoerce a+  where+    calcOffset r = do+      x <- g r+      return (fromIntegral x - fromIntegral ofs)++instance Staged Invocation where+  evolve i =+    case i of+      InvkSpecial r     -> label "InvkSpecial" $ InvkSpecial <$> link r+      InvkVirtual r     -> label "InvkVirtual" $ InvkVirtual <$> link r+      InvkStatic r      -> label "InvkStatic" $ InvkStatic <$> link r+      InvkInterface w r -> label "InvkInterface" $ InvkInterface w <$> link r+      InvkDynamic r     -> label "InvkDynamic" $ InvkDynamic <$> link r++  devolve i =+    case i of+      InvkSpecial r     -> label "InvkSpecial" $ InvkSpecial <$> unlink r+      InvkVirtual r     -> label "InvkVirtual" $ InvkVirtual <$> unlink r+      InvkStatic r      -> label "InvkStatic" $ InvkStatic <$> unlink r+      InvkInterface w r -> label "InvkInterface" $ InvkInterface w <$> unlink r+      InvkDynamic r     -> label "InvkDynamic" $ InvkDynamic <$> unlink r+++instance Staged ExactArrayType where+  evolve x =+    case x of+      EARef r -> EARef <$> link r+      a       -> return $ unsafeCoerce a+  devolve x =+    case x of+      EARef r -> EARef <$> unlink r+      a       -> return $ unsafeCoerce a+++instance Binary (ByteCode Low) where+  get = do+    x <- getWord32be+    bs <- getLazyByteString (fromIntegral x)+    case runGetOrFail go bs of+      Right (_,_,bcs) -> return . ByteCode . (x,) . V.fromList $ bcs+      Left (_,_,msg)  -> fail msg+    where+      go = isEmpty >>= \t ->+        if t+          then return []+          else do+            x <- get+            (x:) <$> go++  put (ByteCode (_, lst))= do+    let bs = runPut (mapM_ put lst)+    putWord32be (fromIntegral $ BL.length bs)+    putLazyByteString bs++instance Binary (ByteCodeInst Low) where+  get =+    ByteCodeInst <$> (fromIntegral <$> bytesRead) <*> get+  put x =+    putByteCode (offset x) $ opcode x++-- | A short relative bytecode ref is defined in correspondence with the+type ShortRelativeRef i = Choice Int16 ByteCodeIndex i++-- | A Long relative reference. The only reason this exist because+-- the signed nature of int, looses a bit.+type LongRelativeRef i = Choice Int32 ByteCodeIndex i++data ArithmeticType = MInt | MLong | MFloat | MDouble+  deriving (Show, Ord, Eq, Enum, Bounded, Generic, NFData)++data SmallArithmeticType = MByte | MChar | MShort+  deriving (Show, Ord, Eq, Enum, Bounded, Generic, NFData)++data LocalType = LInt | LLong | LFloat | LDouble | LRef+  deriving (Show, Ord, Eq, Enum, Bounded, Generic, NFData)++data ArrayType+  = AByte | AChar | AShort | AInt | ALong+  | AFloat | ADouble | ARef+  deriving (Show, Eq, Ord, Generic, NFData)++data ExactArrayType r+  = EABoolean | EAByte | EAChar | EAShort | EAInt | EALong+  | EAFloat | EADouble | EARef (Ref ClassName r)++data Invocation r+  = InvkSpecial (DeepRef AbsVariableMethodId r)+  -- ^ Variable since 52.0+  | InvkVirtual (DeepRef AbsMethodId r)+  | InvkStatic (DeepRef AbsVariableMethodId r)+  -- ^ Variable since 52.0+  | InvkInterface Word8 (DeepRef AbsInterfaceMethodId r)+  -- ^ Should be a positive number+  | InvkDynamic (DeepRef InvokeDynamic r)++data FieldAccess+  = FldStatic+  | FldField+  deriving (Show, Ord, Eq, Generic, NFData)++data OneOrTwo = One | Two+  deriving (Show, Ord, Bounded, Eq, Enum, Generic, NFData)++type WordSize = OneOrTwo+++evolveBConstant :: EvolveM m => BConstant Low -> m (BConstant High)+evolveBConstant ccnst = do+  x <- evolve ccnst+  return $ case x of+    CNull    -> Nothing+    CIntM1   -> Just $ VInteger (-1)+    CInt0    -> Just $ VInteger 0+    CInt1    -> Just $ VInteger 1+    CInt2    -> Just $ VInteger 2+    CInt3    -> Just $ VInteger 3+    CInt4    -> Just $ VInteger 4+    CInt5    -> Just $ VInteger 5+    CLong0   -> Just $ VLong 0+    CLong1   -> Just $ VLong 1+    CFloat0  -> Just $ VFloat 0+    CFloat1  -> Just $ VFloat 1+    CFloat2  -> Just $ VFloat 2+    CDouble0 -> Just $ VDouble 0+    CDouble1 -> Just $ VDouble 1+    CByte i  -> Just $ VInteger (fromIntegral i)+    CShort i -> Just $ VInteger (fromIntegral i)+    CRef _ r -> Just $ r++devolveBConstant :: DevolveM m =>  BConstant High -> m (BConstant Low)+devolveBConstant x = do+  devolve v+  where+    v :: CConstant High+    v = case x of+      Nothing -> CNull+      Just x' -> case x' of+        VInteger i ->+          case i of+            (-1) -> CIntM1; 0 -> CInt0; 1 -> CInt1; 2 -> CInt2; 3 -> CInt3; 4 -> CInt4; 5 -> CInt5;+            i | -128 <= i && i <= 127      -> CByte (fromIntegral i)+              | -32768 <= i && i <= 32767 -> CShort (fromIntegral i)+              | otherwise -> CRef Nothing x'+        VLong 0                           -> CLong0+        VLong 1                           -> CLong1+        VFloat 0                          -> CFloat0+        VFloat 1                          -> CFloat1+        VFloat 2                          -> CFloat2+        VDouble 0                         -> CDouble0+        VDouble 1                         -> CDouble1+        VDouble _                         -> CRef (Just Two) x'+        VLong _                           -> CRef (Just Two) x'+        _                                 -> CRef Nothing x'+++-- | A Wrapper around CConstant.+type BConstant r = Choice (CConstant r) (Maybe JValue) r++instance Staged CConstant where+  evolve x =+    case x of+      CRef w r -> label "Ref" $ CRef w <$> link r+      a        -> return $ unsafeCoerce a++  devolve x =+    case x of+      CRef w r -> label "Ref" $ CRef w <$> unlink r+      a        -> return $ unsafeCoerce a+++data CConstant r+  = CNull++  | CIntM1+   -- ^ -1+  | CInt0+  | CInt1+  | CInt2+  | CInt3+  | CInt4+  | CInt5++  | CLong0+  | CLong1++  | CFloat0+  | CFloat1+  | CFloat2++  | CDouble0+  | CDouble1++  | CByte Int8+  | CShort Int16++  | CRef (Maybe WordSize) (Ref JValue r)++data BinOpr+  = Add+  | Sub+  | Mul+  | Div+  | Rem+  deriving (Show, Ord, Eq, Generic, NFData)++data BitOpr+  = ShL+  | ShR+  | UShR+  | And+  | Or+  | XOr+  deriving (Show, Ord, Eq, Generic, NFData)++type LocalAddress = Word16+type IncrementAmount = Int16++maxWord8 :: Word16+maxWord8 = 0xff++data CmpOpr+  = CEq | CNe | CLt | CGe | CGt | CLe+  deriving (Show, Ord, Eq, Generic, NFData)++data CastOpr+  = CastDown SmallArithmeticType+  -- ^ Cast from Int to a smaller type+  | CastTo ArithmeticType ArithmeticType+  -- ^ Cast from any to any arithmetic type. Cannot be the same type.+  deriving (Show, Ord, Eq, Generic, NFData)+++data SwitchTable r = SwitchTable+  { switchLow     :: Int32+  , switchOffsets :: V.Vector (LongRelativeRef r)+  }++switchHigh :: SwitchTable Low -> Int32+switchHigh st =+  len - 1 + switchLow st+  where+    len = fromIntegral . V.length $ switchOffsets st++data ByteCodeOpr r+  = ArrayLoad ArrayType+  -- ^ aaload baload ...+  | ArrayStore ArrayType+  -- ^ aastore bastore ...++  | Push (BConstant r)++  | Load LocalType LocalAddress+  -- ^ aload_0, bload_2, iload 5 ...+  | Store LocalType LocalAddress+  -- ^ aload, bload ...++  | BinaryOpr BinOpr ArithmeticType+  -- ^ iadd ...+  | Neg ArithmeticType+  -- ^ ineg ...++  | BitOpr BitOpr WordSize+  -- ^ Exclusively on int and long, identified by the word-size++  | IncrLocal !LocalAddress !IncrementAmount+  -- ^ Only works on ints, increment local #1, with #2++  | Cast CastOpr+  -- ^ Only valid on different types++  | CompareLongs++  | CompareFloating Bool WordSize+  -- ^ Compare two floating values, #1 indicates if greater-than, #2+  -- is if float or double should be used.++  | If CmpOpr OneOrTwo (ShortRelativeRef r)+  -- ^ compare with 0 if #2 is False, and two ints from the stack if+  -- True. the last value is the offset++  | IfRef Bool OneOrTwo (ShortRelativeRef r)+  -- ^ check if two objects are equal, or not equal. If #2 is True, compare+  -- with null.++  | Goto (LongRelativeRef r)+  | Jsr (LongRelativeRef r)+  | Ret LocalAddress++  | TableSwitch Int32 (SwitchTable r)+  -- ^ a table switch has 2 values a `default` and a `SwitchTable`+  | LookupSwitch Int32 (V.Vector (Int32, Int32))+  -- ^ a lookup switch has a `default` value and a list of pairs.++  | Get FieldAccess (DeepRef (InClass FieldId) r)+  | Put FieldAccess (DeepRef (InClass FieldId) r)++  | Invoke (Invocation r)++  | New (Ref ClassName r)++  | NewArray (ExactArrayType r)++  | ArrayLength++  | Throw++  | CheckCast (Ref ClassName r)+  | InstanceOf (Ref ClassName r)++  | Monitor Bool+  -- ^ True => Enter, False => Exit++  -- TODO: Fix this so that its more clear what it points to.+  | MultiNewArray (Ref ClassName r) Word8+  -- ^ Create a new multi array of #1 and with #2 dimensions+  -- ^ This might point to an array type.++  | Return (Maybe LocalType)++  | Nop++  | Pop WordSize++  | Dup WordSize+  | DupX1 WordSize+  | DupX2 WordSize++  | Swap+++instance Binary (ByteCodeOpr Low) where+  get = do+    cmd <- getWord8+    case cmd of+      0x00 -> return Nop+      0x01 -> return $ Push CNull++      0x02 -> return $ Push CIntM1+      0x03 -> return $ Push CInt0+      0x04 -> return $ Push CInt1+      0x05 -> return $ Push CInt2+      0x06 -> return $ Push CInt3+      0x07 -> return $ Push CInt4+      0x08 -> return $ Push CInt5++      0x09 -> return $ Push CLong0+      0x0a -> return $ Push CLong1++      0x0b -> return $ Push CFloat0+      0x0c -> return $ Push CFloat1+      0x0d -> return $ Push CFloat2++      0x0e -> return $ Push CDouble0+      0x0f -> return $ Push CDouble1++      0x10 -> Push . CByte <$> get+      0x11 -> Push . CShort <$> get++      0x12 -> Push . CRef Nothing . fromIntegral <$> getWord8+      0x13 -> Push . CRef (Just One) <$> get+      0x14 -> Push . CRef (Just Two) <$> get++      0x15 -> Load LInt . fromIntegral <$> getWord8+      0x16 -> Load LLong . fromIntegral <$> getWord8+      0x17 -> Load LFloat . fromIntegral <$> getWord8+      0x18 -> Load LDouble . fromIntegral <$> getWord8+      0x19 -> Load LRef . fromIntegral <$> getWord8++      0x1a -> return $ Load LInt 0+      0x1b -> return $ Load LInt 1+      0x1c -> return $ Load LInt 2+      0x1d -> return $ Load LInt 3++      0x1e -> return $ Load LLong 0+      0x1f -> return $ Load LLong 1+      0x20 -> return $ Load LLong 2+      0x21 -> return $ Load LLong 3++      0x22 -> return $ Load LFloat 0+      0x23 -> return $ Load LFloat 1+      0x24 -> return $ Load LFloat 2+      0x25 -> return $ Load LFloat 3++      0x26 -> return $ Load LDouble 0+      0x27 -> return $ Load LDouble 1+      0x28 -> return $ Load LDouble 2+      0x29 -> return $ Load LDouble 3++      0x2a -> return $ Load LRef 0+      0x2b -> return $ Load LRef 1+      0x2c -> return $ Load LRef 2+      0x2d -> return $ Load LRef 3++      0x2e -> return $ ArrayLoad AInt+      0x2f -> return $ ArrayLoad ALong+      0x30 -> return $ ArrayLoad AFloat+      0x31 -> return $ ArrayLoad ADouble+      0x32 -> return $ ArrayLoad ARef+      0x33 -> return $ ArrayLoad AByte+      0x34 -> return $ ArrayLoad AChar+      0x35 -> return $ ArrayLoad AShort++      0x36 -> Store LInt . fromIntegral <$> getWord8+      0x37 -> Store LLong . fromIntegral <$> getWord8+      0x38 -> Store LFloat . fromIntegral <$> getWord8+      0x39 -> Store LDouble . fromIntegral <$> getWord8+      0x3a -> Store LRef . fromIntegral <$> getWord8++      0x3b -> return $ Store LInt 0+      0x3c -> return $ Store LInt 1+      0x3d -> return $ Store LInt 2+      0x3e -> return $ Store LInt 3++      0x3f -> return $ Store LLong 0+      0x40 -> return $ Store LLong 1+      0x41 -> return $ Store LLong 2+      0x42 -> return $ Store LLong 3++      0x43 -> return $ Store LFloat 0+      0x44 -> return $ Store LFloat 1+      0x45 -> return $ Store LFloat 2+      0x46 -> return $ Store LFloat 3++      0x47 -> return $ Store LDouble 0+      0x48 -> return $ Store LDouble 1+      0x49 -> return $ Store LDouble 2+      0x4a -> return $ Store LDouble 3++      0x4b -> return $ Store LRef 0+      0x4c -> return $ Store LRef 1+      0x4d -> return $ Store LRef 2+      0x4e -> return $ Store LRef 3++      0x4f -> return $ ArrayStore AInt+      0x50 -> return $ ArrayStore ALong+      0x51 -> return $ ArrayStore AFloat+      0x52 -> return $ ArrayStore ADouble+      0x53 -> return $ ArrayStore ARef+      0x54 -> return $ ArrayStore AByte+      0x55 -> return $ ArrayStore AChar+      0x56 -> return $ ArrayStore AShort++      0x57 -> return $ Pop One+      0x58 -> return $ Pop Two++      0x59 -> return $ Dup One+      0x5a -> return $ DupX1 One+      0x5b -> return $ DupX2 One++      0x5c -> return $ Dup Two+      0x5d -> return $ DupX1 Two+      0x5e -> return $ DupX2 Two++      0x5f -> return $ Swap++      0x60 -> return $ BinaryOpr Add MInt+      0x61 -> return $ BinaryOpr Add MLong+      0x62 -> return $ BinaryOpr Add MFloat+      0x63 -> return $ BinaryOpr Add MDouble++      0x64 -> return $ BinaryOpr Sub MInt+      0x65 -> return $ BinaryOpr Sub MLong+      0x66 -> return $ BinaryOpr Sub MFloat+      0x67 -> return $ BinaryOpr Sub MDouble++      0x68 -> return $ BinaryOpr Mul MInt+      0x69 -> return $ BinaryOpr Mul MLong+      0x6a -> return $ BinaryOpr Mul MFloat+      0x6b -> return $ BinaryOpr Mul MDouble++      0x6c -> return $ BinaryOpr Div MInt+      0x6d -> return $ BinaryOpr Div MLong+      0x6e -> return $ BinaryOpr Div MFloat+      0x6f -> return $ BinaryOpr Div MDouble++      0x70 -> return $ BinaryOpr Rem MInt+      0x71 -> return $ BinaryOpr Rem MLong+      0x72 -> return $ BinaryOpr Rem MFloat+      0x73 -> return $ BinaryOpr Rem MDouble++      0x74 -> return $ Neg MInt+      0x75 -> return $ Neg MLong+      0x76 -> return $ Neg MFloat+      0x77 -> return $ Neg MDouble++      0x78 -> return $ BitOpr ShL One+      0x79 -> return $ BitOpr ShL Two+      0x7a -> return $ BitOpr ShR One+      0x7b -> return $ BitOpr ShR Two++      0x7c -> return $ BitOpr UShR One+      0x7d -> return $ BitOpr UShR Two++      0x7e -> return $ BitOpr And One+      0x7f -> return $ BitOpr And Two+      0x80 -> return $ BitOpr Or One+      0x81 -> return $ BitOpr Or Two+      0x82 -> return $ BitOpr XOr One+      0x83 -> return $ BitOpr XOr Two++      0x84 -> IncrLocal <$> (fromIntegral <$> getWord8) <*> (fromIntegral <$> getInt8)++      0x85 -> return $ Cast (CastTo MInt MLong)+      0x86 -> return $ Cast (CastTo MInt MFloat)+      0x87 -> return $ Cast (CastTo MInt MDouble)++      0x88 -> return $ Cast (CastTo MLong MInt)+      0x89 -> return $ Cast (CastTo MLong MFloat)+      0x8a -> return $ Cast (CastTo MLong MDouble)++      0x8b -> return $ Cast (CastTo MFloat MInt)+      0x8c -> return $ Cast (CastTo MFloat MLong)+      0x8d -> return $ Cast (CastTo MFloat MDouble)++      0x8e -> return $ Cast (CastTo MDouble MInt)+      0x8f -> return $ Cast (CastTo MDouble MLong)+      0x90 -> return $ Cast (CastTo MDouble MFloat)++      0x91 -> return $ Cast (CastDown MByte)+      0x92 -> return $ Cast (CastDown MChar)+      0x93 -> return $ Cast (CastDown MShort)++      0x94 -> return $ CompareLongs++      0x95 -> return $ CompareFloating True One+      0x96 -> return $ CompareFloating False One++      0x97 -> return $ CompareFloating True Two+      0x98 -> return $ CompareFloating False Two++      0x99 -> If CEq One <$> get+      0x9a -> If CNe One <$> get+      0x9b -> If CLt One <$> get+      0x9c -> If CGe One <$> get+      0x9d -> If CGt One <$> get+      0x9e -> If CLe One <$> get++      0x9f -> If CEq Two <$> get+      0xa0 -> If CNe Two <$> get+      0xa1 -> If CLt Two <$> get+      0xa2 -> If CGe Two <$> get+      0xa3 -> If CGt Two <$> get+      0xa4 -> If CLe Two <$> get++      0xa5 -> IfRef True Two <$> get+      0xa6 -> IfRef False Two <$> get++      0xa7 -> Goto . fromIntegral <$> getInt16be+      0xa8 -> Jsr . fromIntegral <$> getInt16be++      0xa9 -> Ret . fromIntegral <$> getWord8++      0xaa -> do+        offset' <- bytesRead+        let skipAmount = (4 - offset' `mod` 4) `mod` 4+        skip $ fromIntegral skipAmount+        dft <- getInt32be+        low <- getInt32be+        high <- getInt32be+        table <- V.replicateM (fromIntegral $ high - low + 1) getInt32be+        return $ TableSwitch dft (SwitchTable low table)++      0xab -> do+        offset' <- bytesRead+        let skipAmount = ((4 - offset' `mod` 4) `mod` 4)+        skip $ fromIntegral skipAmount+        dft <- getInt32be+        npairs <- getInt32be+        pairs <- V.replicateM (fromIntegral npairs) get+        return $ LookupSwitch dft pairs++      0xac -> return . Return . Just $ LInt+      0xad -> return . Return . Just $ LLong+      0xae -> return . Return . Just $ LFloat+      0xaf -> return . Return . Just $ LDouble+      0xb0 -> return . Return . Just $ LRef+      0xb1 -> return . Return $ Nothing++      0xb2 -> Get FldStatic <$> get+      0xb3 -> Put FldStatic <$> get++      0xb4 -> Get FldField <$> get+      0xb5 -> Put FldField <$> get++      0xb6 -> Invoke . InvkVirtual <$> get+      0xb7 -> Invoke . InvkSpecial <$> get+      0xb8 -> Invoke . InvkStatic <$> get+      0xb9 -> do+        ref <- get+        count <- get+        when (count == 0) $ fail "Should be not zero"+        zero <- getWord8+        when (zero /= 0) $ fail "Should be zero"+        return $ Invoke (InvkInterface count ref)+      0xba -> do+        ref <- get+        count <- getWord8+        when (count /= 0) $ fail "Should be zero"+        zero <- getWord8+        when (zero /= 0) $ fail "Should be zero"+        return $ Invoke (InvkDynamic ref)+      0xbb -> New <$> get++      0xbc -> do+        x <- getWord8+        NewArray <$> case x of+          4  -> return EABoolean+          5  -> return EAChar+          6  -> return EAFloat+          7  -> return EADouble+          8  -> return EAByte+          9  -> return EAShort+          10 -> return EAInt+          11 -> return EALong+          _  -> fail $ "Unknown type '0x" ++ showHex x "'."++      0xbd -> NewArray . EARef <$> get++      0xbe -> return ArrayLength++      0xbf -> return Throw++      0xc0 -> CheckCast <$> get+      0xc1 -> InstanceOf <$> get++      0xc2 -> return $ Monitor True+      0xc3 -> return $ Monitor False++      0xc4 -> do+        subopcode <- getWord8+        case subopcode of+          0x15 -> Load LInt <$> get+          0x16 -> Load LLong <$> get+          0x17 -> Load LFloat <$> get+          0x18 -> Load LDouble <$> get+          0x19 -> Load LRef <$> get++          0x36 -> Store LInt <$> get+          0x37 -> Store LLong <$> get+          0x38 -> Store LFloat <$> get+          0x39 -> Store LDouble <$> get+          0x3a -> Store LRef <$> get++          0x84 -> IncrLocal <$> get <*> get++          0xa9 -> Ret <$> get++          _ -> fail $ "Wide does not work for opcode '0x"+                ++ showHex subopcode "'"++      0xc5 -> MultiNewArray <$> get <*> get++      0xc6 -> IfRef False One <$> get+      0xc7 -> IfRef True One <$> get++      0xc8 -> Goto <$> getInt32be+      0xc9 -> Jsr <$> getInt32be++      _ -> fail $ "I do not know this bytecode '0x" ++ showHex cmd "'."++  put = putByteCode 0++putByteCode :: Word16 -> ByteCodeOpr Low -> Put+putByteCode n bc =+  case bc of+    Nop -> putWord8 0x00+    Push CNull -> putWord8 0x01++    Push CIntM1 -> putWord8 0x02+    Push CInt0 -> putWord8 0x03+    Push CInt1 -> putWord8 0x04+    Push CInt2 -> putWord8 0x05+    Push CInt3 -> putWord8 0x06+    Push CInt4 -> putWord8 0x07+    Push CInt5 -> putWord8 0x08++    Push CLong0 -> putWord8 0x09+    Push CLong1 -> putWord8 0x0a++    Push CFloat0 -> putWord8 0x0b+    Push CFloat1 -> putWord8 0x0c+    Push CFloat2 -> putWord8 0x0d++    Push CDouble0 -> putWord8 0x0e+    Push CDouble1 -> putWord8 0x0f++    Push (CByte x) -> putWord8 0x10 >> put x+    Push (CShort x) -> putWord8 0x11 >> put x++    Push (CRef (Just One) x) ->+      putWord8 0x13 >> put x+    -- In this case force the wide+    Push (CRef Nothing x)+      | x <= 0xff -> putWord8 0x12 >> (putWord8 . fromIntegral $ x)+      | otherwise -> putWord8 0x13 >> put x+    -- Here there is no direct restrictions+    Push (CRef (Just Two) r) -> putWord8 0x14 >> put r++    Load tp vl ->+      case tp of+        LInt ->+          case vl of+            0 -> putWord8 0x1a+            1 -> putWord8 0x1b+            2 -> putWord8 0x1c+            3 -> putWord8 0x1d+            a | a <= maxWord8 -> do+                putWord8 0x15+                putWord8 (fromIntegral a)+            a -> do+              putWord8 0xc4 >> putWord8 0x15 >> put a+        LLong ->+          case vl of+            0 -> putWord8 0x1e+            1 -> putWord8 0x1f+            2 -> putWord8 0x20+            3 -> putWord8 0x21+            a | a <= maxWord8 -> do+                putWord8 0x16+                putWord8 (fromIntegral a)+            a -> do+              putWord8 0xc4 >> putWord8 0x16 >> put a+        LFloat ->+          case vl of+            0 -> putWord8 0x22+            1 -> putWord8 0x23+            2 -> putWord8 0x24+            3 -> putWord8 0x25+            a | a <= maxWord8 -> do+                putWord8 0x17+                putWord8 (fromIntegral a)+            a -> do+              putWord8 0xc4 >> putWord8 0x17 >> put a+        LDouble ->+          case vl of+            0 -> putWord8 0x26+            1 -> putWord8 0x27+            2 -> putWord8 0x28+            3 -> putWord8 0x29+            a | a <= maxWord8 -> do+                putWord8 0x18+                putWord8 (fromIntegral a)+            a -> do+              putWord8 0xc4 >> putWord8 0x18 >> put a+        LRef ->+          case vl of+            0 -> putWord8 0x2a+            1 -> putWord8 0x2b+            2 -> putWord8 0x2c+            3 -> putWord8 0x2d+            a | a <= maxWord8 -> do+                putWord8 0x19+                putWord8 (fromIntegral a)+            a -> do+              putWord8 0xc4 >> putWord8 0x19 >> put a+++    ArrayLoad t ->+      case t of+        AInt    -> putWord8 0x2e+        ALong   -> putWord8 0x2f+        AFloat  -> putWord8 0x30+        ADouble -> putWord8 0x31+        ARef    -> putWord8 0x32+        AByte   -> putWord8 0x33+        AChar   -> putWord8 0x34+        AShort  -> putWord8 0x35++    Store tp vl ->+      case tp of+        LInt ->+          case vl of+            0 -> putWord8 0x3b+            1 -> putWord8 0x3c+            2 -> putWord8 0x3d+            3 -> putWord8 0x3e+            a | a <= maxWord8 -> do+                putWord8 0x36+                putWord8 (fromIntegral a)+            a -> do+              putWord8 0xc4 >> putWord8 0x36 >> put a++        LLong ->+          case vl of+            0 -> putWord8 0x3f+            1 -> putWord8 0x40+            2 -> putWord8 0x41+            3 -> putWord8 0x42+            a | a <= maxWord8 -> do+                putWord8 0x37+                putWord8 (fromIntegral a)+            a -> do+              putWord8 0xc4 >> putWord8 0x37 >> put a++        LFloat ->+          case vl of+            0 -> putWord8 0x43+            1 -> putWord8 0x44+            2 -> putWord8 0x45+            3 -> putWord8 0x46+            a | a <= maxWord8 -> do+                putWord8 0x38+                putWord8 (fromIntegral a)+            a -> do+              putWord8 0xc4 >> putWord8 0x38 >> put a++        LDouble ->+          case vl of+            0 -> putWord8 0x47+            1 -> putWord8 0x48+            2 -> putWord8 0x49+            3 -> putWord8 0x4a+            a | a <= maxWord8 -> do+                putWord8 0x39+                putWord8 (fromIntegral a)+            a -> do+              putWord8 0xc4 >> putWord8 0x39 >> put a++        LRef ->+          case vl of+            0 -> putWord8 0x4b+            1 -> putWord8 0x4c+            2 -> putWord8 0x4d+            3 -> putWord8 0x4e+            a | a <= maxWord8 -> do+                putWord8 0x3a+                putWord8 (fromIntegral a)+            a -> do+              putWord8 0xc4 >> putWord8 0x3a >> put a++    ArrayStore AInt -> putWord8 0x4f+    ArrayStore ALong -> putWord8 0x50+    ArrayStore AFloat -> putWord8 0x51+    ArrayStore ADouble -> putWord8 0x52+    ArrayStore ARef -> putWord8 0x53+    ArrayStore AByte -> putWord8 0x54+    ArrayStore AChar -> putWord8 0x55+    ArrayStore AShort -> putWord8 0x56++    Pop One -> putWord8 0x57+    Pop Two -> putWord8 0x58++    Dup One -> putWord8 0x59+    DupX1 One -> putWord8 0x5a+    DupX2 One -> putWord8 0x5b++    Dup Two -> putWord8 0x5c+    DupX1 Two -> putWord8 0x5d+    DupX2 Two -> putWord8 0x5e++    Swap -> putWord8 0x5f++    BinaryOpr Add MInt -> putWord8 0x60+    BinaryOpr Add MLong -> putWord8 0x61+    BinaryOpr Add MFloat -> putWord8 0x62+    BinaryOpr Add MDouble -> putWord8 0x63++    BinaryOpr Sub MInt -> putWord8 0x64+    BinaryOpr Sub MLong -> putWord8 0x65+    BinaryOpr Sub MFloat -> putWord8 0x66+    BinaryOpr Sub MDouble -> putWord8 0x67++    BinaryOpr Mul MInt -> putWord8 0x68+    BinaryOpr Mul MLong -> putWord8 0x69+    BinaryOpr Mul MFloat -> putWord8 0x6a+    BinaryOpr Mul MDouble -> putWord8 0x6b++    BinaryOpr Div MInt -> putWord8 0x6c+    BinaryOpr Div MLong -> putWord8 0x6d+    BinaryOpr Div MFloat -> putWord8 0x6e+    BinaryOpr Div MDouble -> putWord8 0x6f++    BinaryOpr Rem MInt -> putWord8 0x70+    BinaryOpr Rem MLong -> putWord8 0x71+    BinaryOpr Rem MFloat -> putWord8 0x72+    BinaryOpr Rem MDouble -> putWord8 0x73++    Neg MInt -> putWord8 0x74+    Neg MLong -> putWord8 0x75+    Neg MFloat -> putWord8 0x76+    Neg MDouble -> putWord8 0x77++    BitOpr ShL One -> putWord8 0x78+    BitOpr ShL Two -> putWord8 0x79+    BitOpr ShR One -> putWord8 0x7a+    BitOpr ShR Two -> putWord8 0x7b++    BitOpr UShR One -> putWord8 0x7c+    BitOpr UShR Two -> putWord8 0x7d++    BitOpr And One -> putWord8 0x7e+    BitOpr And Two -> putWord8 0x7f+    BitOpr Or One -> putWord8 0x80+    BitOpr Or Two -> putWord8 0x81+    BitOpr XOr One -> putWord8 0x82+    BitOpr XOr Two -> putWord8 0x83++    IncrLocal s1 s2 ->+      if s1 > maxWord8 || s2 > fromIntegral (maxBound :: Int8) || s2 < fromIntegral (minBound :: Int8) then+        putWord8 0xc4 >> putWord8 0x84 >> put s1 >> put s2+      else+        putWord8 0x84 >> putWord8 (fromIntegral s1) >> putInt8 (fromIntegral s2)++    Cast a ->+      case a of+        CastTo MInt MLong -> putWord8 0x85+        CastTo MInt MFloat -> putWord8 0x86+        CastTo MInt MDouble -> putWord8 0x87++        CastTo MLong MInt -> putWord8 0x88+        CastTo MLong MFloat -> putWord8 0x89+        CastTo MLong MDouble -> putWord8 0x8a++        CastTo MFloat MInt -> putWord8 0x8b+        CastTo MFloat MLong -> putWord8 0x8c+        CastTo MFloat MDouble -> putWord8 0x8d++        CastTo MDouble MInt -> putWord8 0x8e+        CastTo MDouble MLong -> putWord8 0x8f+        CastTo MDouble MFloat -> putWord8 0x90++        CastDown MByte -> putWord8 0x91+        CastDown MChar -> putWord8 0x92+        CastDown MShort -> putWord8 0x93++        _ -> error $ "Cannot cast from " ++ show a ++ " to " ++ show a ++ "."++    CompareLongs -> putWord8 0x94++    CompareFloating True One -> putWord8 0x95+    CompareFloating False One -> putWord8 0x96++    CompareFloating True Two -> putWord8 0x97+    CompareFloating False Two -> putWord8 0x98++    If CEq One a -> putWord8 0x99 >> put a+    If CNe One a -> putWord8 0x9a >> put a+    If CLt One a -> putWord8 0x9b >> put a+    If CGe One a -> putWord8 0x9c >> put a+    If CGt One a -> putWord8 0x9d >> put a+    If CLe One a -> putWord8 0x9e >> put a++    If CEq Two a -> putWord8 0x9f >> put a+    If CNe Two a -> putWord8 0xa0 >> put a+    If CLt Two a -> putWord8 0xa1 >> put a+    If CGe Two a -> putWord8 0xa2 >> put a+    If CGt Two a -> putWord8 0xa3 >> put a+    If CLe Two a -> putWord8 0xa4 >> put a++    IfRef True Two a -> putWord8 0xa5 >> put a+    IfRef False Two a -> putWord8 0xa6 >> put a++    Goto a -> do+      if (abs a) < (2 :: Int32) ^ (15 :: Int32) then do+        putWord8 0xa7+        putInt16be (fromIntegral a)+      else do+        putWord8 0xc8+        putInt32be a+    Jsr a ->+      if (abs a) < (2 :: Int32) ^ (15 :: Int32) then do+        putWord8 0xa8+        putInt16be (fromIntegral a)+      else do+        putWord8 0xc9+        putInt32be a++    Ret a ->+      -- Check if correct size+      if a <= maxWord8+      then do+        putWord8 0xa9+        putWord8 (fromIntegral a)+      else do+        putWord8 0xc4 >> putWord8 0xa9 >> put a++    TableSwitch dft table -> do+      putWord8 0xaa+      -- missing pad+      replicateM_ (fromIntegral ((4 - (n + 1) `mod` 4) `mod` 4)) $ putWord8 0x00+      putInt32be dft+      putInt32be (switchLow table)+      putInt32be (switchHigh table)+      V.mapM_ putInt32be (switchOffsets table)++    LookupSwitch dft pairs -> do+      putWord8 0xab+      replicateM_ (fromIntegral ((4 - (n + 1) `mod` 4) `mod` 4)) $ putWord8 0x00+      putInt32be dft+      putInt32be . fromIntegral $ V.length pairs+      V.mapM_ put pairs++    Return ( Just LInt ) -> putWord8 0xac+    Return ( Just LLong ) -> putWord8 0xad+    Return ( Just LFloat ) -> putWord8 0xae+    Return ( Just LDouble ) -> putWord8 0xaf+    Return ( Just LRef ) -> putWord8 0xb0+    Return Nothing -> putWord8 0xb1++    Get FldStatic a -> putWord8 0xb2 >> put a+    Put FldStatic a -> putWord8 0xb3 >> put a++    Get FldField a -> putWord8 0xb4 >> put a+    Put FldField a -> putWord8 0xb5 >> put a++    Invoke i ->+      case i of+        InvkVirtual a -> putWord8 0xb6 >> put a+        InvkSpecial a -> putWord8 0xb7 >> put a+        InvkStatic a -> putWord8 0xb8 >> put a+        InvkInterface count a -> do+          when (count == 0) $ error "Should be not zero"+          putWord8 0xb9+          put a+          put count+          putWord8 0+        InvkDynamic a ->+          putWord8 0xba >> put a >> putWord8 0 >> putWord8 0++    New a -> putWord8 0xbb >> put a+    NewArray x -> do+      case x of+        EABoolean -> putWord8 0xbc >> putWord8 4+        EAChar    -> putWord8 0xbc >> putWord8 5+        EAFloat   -> putWord8 0xbc >> putWord8 6+        EADouble  -> putWord8 0xbc >> putWord8 7+        EAByte    -> putWord8 0xbc >> putWord8 8+        EAShort   -> putWord8 0xbc >> putWord8 9+        EAInt     -> putWord8 0xbc >> putWord8 10+        EALong    -> putWord8 0xbc >> putWord8 11+        EARef a   -> putWord8 0xbd >> put a+    ArrayLength -> putWord8 0xbe+    Throw -> putWord8 0xbf++    CheckCast a -> putWord8 0xc0 >> put a+    InstanceOf a -> putWord8 0xc1 >> put a++    Monitor True -> putWord8 0xc2+    Monitor False -> putWord8 0xc3++    MultiNewArray a b -> putWord8 0xc5 >> put a >> put b++    IfRef False One a -> putWord8 0xc6 >> put a+    IfRef True One a -> putWord8 0xc7 >> put a+++$(deriveBase ''ByteCode)+$(deriveBase ''ByteCodeInst)+$(deriveBase ''ByteCodeOpr)+$(deriveBase ''SwitchTable)+$(deriveBase ''Invocation)+$(deriveBase ''CConstant)+$(deriveBase ''ExactArrayType)

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE TemplateHaskell    #-} {-| Module      : Language.JVM.ClassFile Copyright   : (c) Christian Gram Kalhauge, 2017@@ -6,85 +8,150 @@  The class file is described in this module. -}--{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE StandaloneDeriving #-} module Language.JVM.ClassFile   ( ClassFile (..)--  , cInterfaces+  , cAccessFlags   , cFields   , cMethods-  , cAttributes--  , cThisClass-  , cSuperClass+  , cSignature    -- * Attributes+  , ClassAttributes (..)   , cBootstrapMethods   ) where  import           Data.Binary import           Data.Monoid-import qualified Data.Text               as Text-import           GHC.Generics            (Generic)+import           Data.Set  import           Language.JVM.AccessFlag-import           Language.JVM.Attribute  (Attribute, BootstrapMethods, fromAttribute')+import           Language.JVM.Attribute+import           Language.JVM.Attribute.BootstrapMethods+-- import           Language.JVM.Attribute.Signature import           Language.JVM.Constant-import           Language.JVM.Field      (Field)-import           Language.JVM.Method     (Method)+import           Language.JVM.ConstantPool               as CP+import           Language.JVM.Field                      (Field)+import           Language.JVM.Method                     (Method)+import           Language.JVM.Staged import           Language.JVM.Utils  -- | A 'ClassFile' as described -- [here](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html). -data ClassFile = ClassFile-  { cMagicNumber     :: !Word32--  , cMinorVersion    :: !Word16-  , cMajorVersion    :: !Word16+data ClassFile r = ClassFile+  { cMagicNumber  :: !Word32 -  , cConstantPool    :: !ConstantPool+  , cMinorVersion :: !Word16+  , cMajorVersion :: !Word16 -  , cAccessFlags     :: BitSet16 CAccessFlag+  , cConstantPool :: !(Choice (ConstantPool r) () r) -  , cThisClassIndex  :: !ConstantRef-  , cSuperClassIndex :: !ConstantRef+  , cAccessFlags' :: !(BitSet16 CAccessFlag) -  , cInterfaces'     :: SizedList16 ConstantRef-  , cFields'         :: SizedList16 Field-  , cMethods'        :: SizedList16 Method-  , cAttributes'     :: SizedList16 Attribute-  } deriving (Show, Eq, Generic)+  , cThisClass    :: !(Ref ClassName r)+  , cSuperClass   :: !(Ref ClassName r) -instance Binary ClassFile where+  , cInterfaces   :: !(SizedList16 (Ref ClassName r))+  , cFields'      :: !(SizedList16 (Field r))+  , cMethods'     :: !(SizedList16 (Method r))+  , cAttributes   :: !(Attributes ClassAttributes r)+  } --- | Get a list of 'ConstantRef's to interfaces.-cInterfaces :: ClassFile -> [ConstantRef]-cInterfaces = unSizedList . cInterfaces'+-- | Get the set of access flags+cAccessFlags :: ClassFile r -> Set CAccessFlag+cAccessFlags = toSet . cAccessFlags'  -- | Get a list of 'Field's of a ClassFile.-cFields :: ClassFile -> [Field]+cFields :: ClassFile r -> [Field r] cFields = unSizedList . cFields'  -- | Get a list of 'Method's of a ClassFile.-cMethods :: ClassFile -> [Method]+cMethods :: ClassFile r -> [Method r] cMethods = unSizedList . cMethods' --- | Lookup the this class in a ConstantPool-cThisClass :: ConstantPool -> ClassFile -> Maybe Text.Text-cThisClass cp = flip lookupClassName cp . cThisClassIndex --- | Lookup the super class in the ConstantPool-cSuperClass :: ConstantPool -> ClassFile -> Maybe Text.Text-cSuperClass cp = flip lookupClassName cp . cSuperClassIndex+-- | Fetch the 'BootstrapMethods' attribute.+-- There can only one bootstrap methods per class, but there might not be+-- one.+cBootstrapMethods' :: ClassFile High -> Maybe (BootstrapMethods High)+cBootstrapMethods' =+  firstOne . caBootstrapMethods . cAttributes --- | Get a list of 'Attribute's of a ClassFile.-cAttributes :: ClassFile -> [Attribute]-cAttributes = unSizedList . cAttributes'+cBootstrapMethods :: ClassFile High -> [BootstrapMethod High]+cBootstrapMethods =+  maybe [] methods . cBootstrapMethods' --- | Fetch the 'BootstrapMethods' attribute.--- There can only one be one exceptions attribute on a class-file.-cBootstrapMethods :: ConstantPool -> ClassFile -> Maybe (Either String BootstrapMethods)-cBootstrapMethods cp =-  getFirst . foldMap (First . fromAttribute' cp) . cAttributes+cSignature :: ClassFile High -> Maybe (Signature High)+cSignature =+  firstOne . caSignature . cAttributes++data ClassAttributes r = ClassAttributes+  { caBootstrapMethods :: [ BootstrapMethods r]+  , caSignature        :: [ Signature r ]+  , caOthers           :: [ Attribute r ]+  }++instance Staged ClassFile where+  evolve cf = label "ClassFile" $ do+    tci' <- link (cThisClass cf)+    sci' <-+      if tci' /= ClassName "java/lang/Object"+      then do+        link (cSuperClass cf)+      else do+        return $ ClassName "java/lang/Object"+    cii' <- mapM link $ cInterfaces cf+    cf' <- mapM evolve $ cFields' cf+    cm' <- mapM evolve $ cMethods' cf+    ca' <- fromCollector <$> fromAttributes collect' (cAttributes cf)+    return $ cf+      { cConstantPool = ()+      , cThisClass = tci'+      , cSuperClass = sci'+      , cInterfaces = cii'+      , cFields'            = cf'+      , cMethods'           = cm'+      , cAttributes         = ca'+      }+    where+      fromCollector (a, b, c) =+        ClassAttributes (appEndo a []) (appEndo b []) (appEndo c [])+      collect' attr =+        collect (mempty, mempty, Endo (attr:)) attr+          [ toC $ \e -> (Endo (e:), mempty, mempty)+          , toC $ \e -> (mempty, Endo (e:), mempty)]++  devolve cf = do+    tci' <- unlink (cThisClass cf)+    sci' <-+      if cThisClass cf /= ClassName "java/lang/Object" then+        unlink (cSuperClass cf)+      else+        return $ 0+    cii' <- mapM unlink $ cInterfaces cf+    cf' <- mapM devolve $ cFields' cf+    cm' <- mapM devolve $ cMethods' cf+    ca' <- fromClassAttributes $ cAttributes cf+    return $ cf+      { cConstantPool       = CP.empty+      -- We cannot yet set the constant pool+      , cThisClass = tci'+      , cSuperClass = sci'+      , cInterfaces  = cii'+      , cFields'            = cf'+      , cMethods'           = cm'+      , cAttributes         = SizedList ca'+      }+    where+      fromClassAttributes (ClassAttributes cm cs at) = do+        cm' <- mapM toAttribute cm+        cs' <- mapM toAttribute cs+        at' <- mapM devolve at+        return (cm' ++ cs' ++ at')++$(deriveBase ''ClassAttributes)+$(deriveBaseWithBinary ''ClassFile)

@@ -0,0 +1,225 @@+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MonoLocalBinds             #-}+{-# LANGUAGE RankNTypes                 #-}+module Language.JVM.ClassFileReader+  ( readClassFile+  , writeClassFile++  , writeClassFile'++  -- * Finer granularity commands+  , decodeClassFile+  , encodeClassFile+  , evolveClassFile+  , devolveClassFile+  , devolveClassFile'++  -- * Evolve+  , Evolve+  , ClassFileError+  , runEvolve+  , bootstrapConstantPool++  -- * Builder+  , ConstantPoolBuilder+  , runConstantPoolBuilder+  , CPBuilder (..)+  , builderFromConstantPool+  , cpbEmpty+  ) where++import           Control.DeepSeq           (NFData)+import           Control.Monad.Except+import           Control.Monad.Reader+import           Control.Monad.State+import qualified Data.ByteString.Lazy      as BL+import qualified Data.IntMap               as IM+import qualified Data.Map                  as Map+import           Data.Monoid+import           Data.Binary+import           GHC.Generics              (Generic)++import           Language.JVM.ClassFile+import           Language.JVM.Constant+import           Language.JVM.ConstantPool as CP+import           Language.JVM.Staged++-- | Decode a class file from a lazy 'BL.ByteString'. Ensures that the lazy+-- bytestring is read to EOF, and thereby closing any open files.+decodeClassFile :: BL.ByteString -> Either ClassFileError (ClassFile Low)+decodeClassFile bs = do+  case decodeOrFail bs of+    Right (rest, off, cf)+      | BL.length rest == 0 -> Right cf+      | otherwise ->+        unreadable rest off "expected end of file"+    Left (rest, off, msg) ->+      unreadable rest off msg+  where+    unreadable rest off msg =+      Left $ CFEUnreadableFile ((show off) ++ "/" ++ (show $ BL.length rest) ++ ": " ++ msg)++-- | Create a lazy byte string from a class file+encodeClassFile :: ClassFile Low -> BL.ByteString+encodeClassFile clf = do+  encode clf++-- | Changed the stage from Index to Deref+evolveClassFile :: ClassFile Low -> Either ClassFileError (ClassFile High)+evolveClassFile cf = do+  cp <- bootstrapConstantPool (cConstantPool cf)+  runEvolve cp (evolve cf)++-- | Devolve a ClassFile from High to Low. This might make the 'ClassFile' contain+-- invalid attributes, since we can't read all attributes. If this this is a problem+-- see 'devolveClassFile''.+devolveClassFile :: ClassFile High -> ClassFile Low+devolveClassFile cf =+  let (cf', cpb) = runConstantPoolBuilder (devolve cf) cpbEmpty in+  cf' { cConstantPool = cpbConstantPool cpb }++-- | Devolve a 'ClassFile' form 'High' to 'Low', while maintaining the class+-- pool of the original class file. This is useful if we care that unread+-- attributes are still valid. This can cause untended bloat as we do not+-- want to throw away anything in the program+devolveClassFile' :: ConstantPool Low -> ClassFile High -> ClassFile Low+devolveClassFile' cp cf =+  let (cf', cpb) = runConstantPoolBuilder (devolve cf) (builderFromConstantPool cp) in+  cf' { cConstantPool = cpbConstantPool cpb }+++-- | Top level command that combines 'decode' and 'evolve'.+readClassFile :: BL.ByteString -> Either ClassFileError (ClassFile High)+readClassFile bs = do+  clf <- decodeClassFile bs+  evolveClassFile clf++-- | Top level command that combines 'devolve' and 'encode'.+writeClassFile :: ClassFile High -> BL.ByteString+writeClassFile =+  encodeClassFile . devolveClassFile++-- | Top level command that combines 'devolve' and 'encode', but tries+-- to retain exact syntax of a previous run using the class pool.+writeClassFile' :: ConstantPool Low -> ClassFile High -> BL.ByteString+writeClassFile' cp =+  encodeClassFile . devolveClassFile' cp+++-- $deref+-- Dereffing is the flattening of the constant pool to get the values+-- of all references.++-- | An error while reading a class file is represented using+-- this data structure+data ClassFileError+  = CFEPoolAccessError !String !PoolAccessError+  | CFEInconsistentClassPool !String !String+  | CFEConversionError !String !String+  | CFEUnreadableFile !String+  deriving (Show, Eq, Generic)++instance NFData ClassFileError++newtype Evolve a =+  Evolve (ReaderT (String, ConstantPool High) (Either ClassFileError) a)+  deriving+  ( Functor+  , Applicative+  , Monad+  , MonadReader (String, ConstantPool High)+  , MonadError ClassFileError+  )++runEvolve :: ConstantPool High -> Evolve a -> Either ClassFileError a+runEvolve cp (Evolve m) = runReaderT m ("", cp)++instance LabelM Evolve where+  label str (Evolve m) = do+    Evolve . withReaderT (\(x, cp) -> (x ++ "/" ++ str, cp)) $ m++instance EvolveM Evolve where+  link w = do+    (lvl, cp) <- ask+    r <- either (throwError . CFEPoolAccessError lvl ) return $ access w cp+    fromConst (throwError . CFEInconsistentClassPool lvl) r++  attributeError msg = do+    (lvl, _) <- ask+    throwError (CFEConversionError lvl msg)++-- | Untie the constant pool, this requires a special operation as the constant pool+-- might reference itself.+bootstrapConstantPool :: ConstantPool Low -> Either ClassFileError (ConstantPool High)+bootstrapConstantPool reffed =+  case stage' IM.empty (IM.toList $ unConstantPool reffed) of+    Right cp ->+      Right $ ConstantPool cp+    Left xs ->+      Left . CFEInconsistentClassPool "ConstantPool"+           $ "Could not load all constants in the constant pool: " ++ (show xs)+  where+    stage' cp mis =+      let (cp', mis') = foldMap (grow cp) mis in+      case appEndo mis' [] of+        [] | IM.null cp' -> Right cp+        xs+          | IM.null cp' ->+            Left xs+          | otherwise ->+            stage' (cp `IM.union` cp') (map snd xs)++    grow cp (k,a) =+      case runEvolve (ConstantPool cp) $ evolve a of+        Right c -> (IM.singleton k c, Endo id)+        Left msg  -> (IM.empty, Endo ((msg, (k,a)):))++-- $build++data CPBuilder = CPBuilder+   { cpbMapper       :: Map.Map (Constant Low) Index+   , cpbConstantPool :: ConstantPool Low+   }++cpbEmpty :: CPBuilder+cpbEmpty = CPBuilder Map.empty CP.empty++builderFromConstantPool :: ConstantPool Low -> CPBuilder+builderFromConstantPool cp =+  CPBuilder (Map.fromList . map change . IM.toList $ unConstantPool cp) cp+  where+    change (a, b) = (b, fromIntegral a)+++newtype ConstantPoolBuilder a =+  ConstantPoolBuilder (State CPBuilder a)+  deriving (Monad, MonadState CPBuilder, Functor, Applicative)++runConstantPoolBuilder :: ConstantPoolBuilder a -> CPBuilder -> (a, CPBuilder)+runConstantPoolBuilder (ConstantPoolBuilder m) a=+  runState m a++instance LabelM ConstantPoolBuilder++instance DevolveM ConstantPoolBuilder where+  unlink r = do+    c <- toConst r+    c' <- devolve c+    mw <- gets (Map.lookup c' . cpbMapper)+    case mw of+      Just w -> return w+      Nothing -> do+        w <- state . stateCPBuilder $ c'+        return w++stateCPBuilder+  :: Constant Low+  -> CPBuilder+  -> (Word16, CPBuilder)+stateCPBuilder c' cpb =+  let (w, cp') = append c' . cpbConstantPool $ cpb in+  (w, cpb { cpbConstantPool = cp'+          , cpbMapper = Map.insert c' w . cpbMapper $ cpb+          })

@@ -1,5 +1,12 @@+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-} {-|-Module      : Language.JVM.Constant Copyright   : (c) Christian Gram Kalhauge, 2017 License     : MIT Maintainer  : kalhuage@cs.ucla.edu@@ -8,173 +15,457 @@ are essential for accessing data in the class-file. -} -{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RankNTypes    #-} module Language.JVM.Constant-  (-    -- * Constant-    Constant (..)+  ( Constant (..)   , constantSize-  , ConstantRef (..)+  , typeToStr -    -- * Constant Pool-    -- $ConstantPool-  , ConstantPool (..)+  , Referenceable (..) -  , lookupConstant-  , lookupText-  , lookupClassName+  , JValue (..) -  , toListOfConstants-  ) where+    -- * Special constants+  , ClassName (..) -import           GHC.Generics       (Generic)+  , InClass (..) -import           Prelude            hiding (fail, lookup)+  , AbsMethodId+  , AbsFieldId+  , AbsInterfaceMethodId (..)+  , AbsVariableMethodId (..) -import           Control.Monad      (forM_)-import           Control.Monad.Fail (fail)+  , MethodId (..)+  , FieldId (..)+  , NameAndType (..) ++  , MethodDescriptor+  , FieldDescriptor+++  , MethodHandle (..)+  , MethodHandleField (..)+  , MethodHandleMethod (..)+  , MethodHandleInterface (..)+  , MethodHandleFieldKind (..)+  , InvokeDynamic (..)++  -- * re-exports+  , High+  , Low+  ) where++import           Control.DeepSeq          (NFData)+import           Control.Monad.Reader import           Data.Binary-import           Data.Binary.Get-import           Data.Binary.Put-import qualified Data.IntMap.Strict as IM+import           Data.String+import           Data.Binary.IEEE754+import qualified Data.ByteString          as BS+import           Data.Int+import qualified Data.Text                as Text+import qualified Data.Text.Encoding.Error as TE+import           GHC.Generics             (Generic)+import           Numeric                  (showHex)+import           Prelude                  hiding (fail, lookup) +import           Language.JVM.Stage+import           Language.JVM.TH+import           Language.JVM.Type import           Language.JVM.Utils  -import qualified Data.Text          as Text-import qualified Data.Text.Encoding as TE+-- | A constant is a multi word item in the 'ConstantPool'. Each of+-- the constructors are pretty much self-explanatory from the types.+data Constant r+  = CString !SizedByteString16+  | CInteger !Int32+  | CFloat !Float+  | CLong !Int64+  | CDouble !Double+  | CClassRef !(Ref Text.Text r)+  | CStringRef !(Ref BS.ByteString r)+  | CFieldRef !(InClass FieldId r)+  | CMethodRef !(InClass MethodId r)+  | CInterfaceMethodRef !(InClass MethodId r)+  | CNameAndType !(Ref Text.Text r) !(Ref Text.Text r)+  | CMethodHandle !(MethodHandle r)+  | CMethodType !(Ref MethodDescriptor r)+  | CInvokeDynamic !(InvokeDynamic r) --- | A constant is referenced by the ConstantRef data type. It is--- just a 16 bit word, but wrapped for type safety.-newtype ConstantRef =-  ConstantRef Word16-  deriving (Eq, Show, Generic)+--deriving (Show, Eq, Generic, NFData) -instance Binary ConstantRef where+-- | Anything pointing inside a class+data InClass a r = InClass+  { inClassName :: !(Ref ClassName r)+  , inClassId   :: !(Ref a r)+  } --- | A constant is a multi word item in the 'ConstantPool'. Each of--- the constructors are pretty much self expiatory from the types.-data Constant-  = String !SizedByteString16-  | Integer !Word32-  | Float !Word32-  | Long !Word64-  | Double !Word64-  | ClassRef !ConstantRef-  | StringRef !ConstantRef-  | FieldRef !ConstantRef !ConstantRef-  | MethodRef !ConstantRef !ConstantRef-  | InterfaceMethodRef !ConstantRef !ConstantRef-  | NameAndType !ConstantRef !ConstantRef-  | MethodHandle !Word8 !ConstantRef-  | MethodType !ConstantRef-  | InvokeDynamic !ConstantRef !ConstantRef-  deriving (Show, Eq)+-- | A method id in a class.+type AbsMethodId = InClass MethodId -instance Binary Constant where+-- | A field id in a class+type AbsFieldId = InClass FieldId++-- | An interface method, which is a class in a method.+newtype AbsInterfaceMethodId r = AbsInterfaceMethodId+  { interfaceMethodId :: InClass MethodId r+  }++newtype MethodId = MethodId (NameAndType MethodDescriptor)+  deriving (Eq, Show, NFData, Ord, Generic)++newtype FieldId  = FieldId (NameAndType FieldDescriptor)+  deriving (Eq, Show, NFData, Ord, Generic)++instance IsString FieldId where+  fromString = FieldId . fromString++instance IsString MethodId where+  fromString = MethodId . fromString++-- | In some cases we can both point to interface methods and+-- regular methods.+data AbsVariableMethodId r+  = VInterfaceMethodId !(AbsInterfaceMethodId r)+  | VMethodId !(AbsMethodId r)++-- | The union type over the different method handles.+data MethodHandle r+  = MHField !(MethodHandleField r)+  | MHMethod !(MethodHandleMethod r)+  | MHInterface !(MethodHandleInterface r)+++data MethodHandleField r = MethodHandleField+  { methodHandleFieldKind :: !MethodHandleFieldKind+  , methodHandleFieldRef  :: !(DeepRef AbsFieldId r)+  }++data MethodHandleFieldKind+  = MHGetField+  | MHGetStatic+  | MHPutField+  | MHPutStatic+  deriving (Eq, Show, NFData, Generic, Ord)++data MethodHandleMethod r+  = MHInvokeVirtual !(DeepRef AbsMethodId r)+  | MHInvokeStatic !(DeepRef AbsVariableMethodId r)+  -- ^ Since version 52.0+  | MHInvokeSpecial !(DeepRef AbsVariableMethodId r)+  -- ^ Since version 52.0+  | MHNewInvokeSpecial !(DeepRef AbsMethodId r)++data MethodHandleInterface r = MethodHandleInterface+  {  methodHandleInterfaceRef :: !(DeepRef AbsInterfaceMethodId r)+  }++data InvokeDynamic r = InvokeDynamic+  { invokeDynamicAttrIndex :: !Word16+  , invokeDynamicMethod    :: !(Ref MethodId r)+  }++-- | Hack that returns the name of a constant.+typeToStr :: Constant r -> String+typeToStr c =+  case c of+    CString _             -> "CString"+    CInteger _            -> "CInteger"+    CFloat _              -> "CFloat"+    CLong _               -> "CLong"+    CDouble _             -> "CDouble"+    CClassRef _           -> "CClassRef"+    CStringRef _          -> "CStringRef"+    CFieldRef _           -> "CFieldRef"+    CMethodRef _          -> "CMethodRef"+    CInterfaceMethodRef _ -> "CInterfaceMethodRef"+    CNameAndType _ _      -> "CNameAndType"+    CMethodHandle _       -> "CMethodHandle"+    CMethodType _         -> "CMethodType"+    CInvokeDynamic _      -> "CInvokeDynamic"++instance Binary (Constant Low) where   get = do     ident <- getWord8     case ident of-      1  -> String <$> get-      3  -> Integer <$> get-      4  -> Float <$> get-      5  -> Long <$> get-      6  -> Double <$> get-      7  -> ClassRef <$> get-      8  -> StringRef <$> get-      9  -> FieldRef <$> get <*> get-      10 -> MethodRef <$> get <*> get-      11 -> InterfaceMethodRef <$> get <*> get-      12 -> NameAndType <$> get <*> get-      15 -> MethodHandle <$> get <*> get-      16 -> MethodType <$> get-      18 -> InvokeDynamic <$> get <*> get+      1  -> CString <$> get+      3  -> CInteger <$> get+      4  -> CFloat <$> getFloat32be+      5  -> CLong <$> get+      6  -> CDouble <$> getFloat64be+      7  -> CClassRef <$> get+      8  -> CStringRef <$> get+      9  -> CFieldRef <$> get+      10 -> CMethodRef <$> get+      11 -> CInterfaceMethodRef <$> get+      12 -> CNameAndType <$> get <*> get+      15 -> CMethodHandle <$> get+      16 -> CMethodType <$> get+      18 -> CInvokeDynamic <$> get       _  -> fail $ "Unkown identifier " ++ show ident    put x =     case x of-      String bs              -> do putWord8 1; put bs-      Integer i              -> do putWord8 3; put i-      Float i                -> do putWord8 4; put i-      Long i                 -> do putWord8 5; put i-      Double i               -> do putWord8 6; put i-      ClassRef i             -> do putWord8 7; put i-      StringRef i            -> do putWord8 8; put i-      FieldRef i j           -> do putWord8 9; put i; put j-      MethodRef i j          -> do putWord8 10; put i; put j-      InterfaceMethodRef i j -> do putWord8 11; put i; put j-      NameAndType i j        -> do putWord8 12; put i; put j-      MethodHandle i j       -> do putWord8 15; put i; put j-      MethodType i           -> do putWord8 16; put i;-      InvokeDynamic i j      -> do putWord8 18; put i; put j+      CString bs            -> do putWord8 1; put bs+      CInteger i            -> do putWord8 3; put i+      CFloat i              -> do putWord8 4; putFloat32be i+      CLong i               -> do putWord8 5; put i+      CDouble i             -> do putWord8 6; putFloat64be i+      CClassRef i           -> do putWord8 7; put i+      CStringRef i          -> do putWord8 8; put i+      CFieldRef i           -> do putWord8 9; put i+      CMethodRef i          -> do putWord8 10; put i+      CInterfaceMethodRef i -> do putWord8 11; put i+      CNameAndType i j      -> do putWord8 12; put i; put j+      CMethodHandle h       -> do putWord8 15; put h+      CMethodType i         -> do putWord8 16; put i;+      CInvokeDynamic i      -> do putWord8 18; put i +instance Binary (MethodHandle Low) where+  get = do+    w <- getWord8+    case w of+      1 -> MHField . MethodHandleField MHGetField <$> get+      2 -> MHField . MethodHandleField MHGetStatic <$> get+      3 -> MHField . MethodHandleField MHPutField <$> get+      4 -> MHField . MethodHandleField MHPutStatic <$> get++      5 -> MHMethod . MHInvokeVirtual <$> get+      6 -> MHMethod . MHInvokeStatic <$> get+      7 -> MHMethod . MHInvokeSpecial<$> get+      8 -> MHMethod . MHNewInvokeSpecial <$> get++      9 -> MHInterface . MethodHandleInterface <$> get++      _ -> fail $ "Unknown method handle kind 'x" ++ showHex w "'"++  put x = case x of+    MHField h -> do+      putWord8 $ case methodHandleFieldKind h of+        MHGetField  -> 1+        MHGetStatic -> 2+        MHPutField  -> 3+        MHPutStatic -> 4+      put $ methodHandleFieldRef h++    MHMethod h -> do+      case h of+        MHInvokeVirtual m    -> putWord8 5 >> put m+        MHInvokeStatic m     -> putWord8 6 >> put m+        MHInvokeSpecial m    -> putWord8 7 >> put m+        MHNewInvokeSpecial m -> putWord8 8 >> put m++    MHInterface h -> do+      putWord8  9+      put $ methodHandleInterfaceRef h+ -- | Some of the 'Constant's take up more space in the constant pool than other. -- Notice that 'Language.JVM.Constant.String' and 'MethodType' is not of size -- 32, but is still awarded value 1. This is due to an -- [inconsistency](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.4.5) -- in JVM.-constantSize :: Constant -> Int+constantSize :: Constant r -> Int constantSize x =   case x of-    Double _ -> 2-    Long _   -> 2-    _        -> 1+    CDouble _ -> 2+    CLong _   -> 2+    _         -> 1 --- $ConstantPool------ The 'ConstantPool' contains all the constants, and is accessible using the--- Lookup methods.+-- | 'Referenceable' is something that can exist in the constant pool.+class Referenceable a where+  fromConst+    :: (Monad m)+    => (forall a'. String -> m a')+    -> Constant High+    -> m a+  toConst+    :: (Monad m)+    => a+    -> m (Constant High) --- | A ConstantPool is just an 'IntMap'. A 'IntMap' is used, because constants are--- accessed after their byte-offset. 'constantSize'-newtype ConstantPool = ConstantPool-  { unConstantPool :: IM.IntMap Constant-  } deriving (Show, Eq)+instance Referenceable (Constant High) where+  fromConst _ a = return a+  toConst a = return a --- | Return a list of reference-constant pairs.-toListOfConstants :: ConstantPool -> [(ConstantRef, Constant)]-toListOfConstants =-  map (\(a,b) -> (ConstantRef . fromIntegral $ a, b)) . IM.toList . unConstantPool+instance TypeParse a => Referenceable (NameAndType a) where+  fromConst err (CNameAndType rn txt) = do+    md <- either err return $ fromText txt+    return $ NameAndType rn md+  fromConst e c = expected "CNameAndType" e c -instance Binary ConstantPool where-  get = do-    len <- fromIntegral <$> getInt16be-    list <- go len 1-    return . ConstantPool $ IM.fromList list-    where-      go len n | len > n = do-        constant <- get-        rest <- go len (n + constantSize constant)-        return $ (n, constant) : rest-      go _ _ = return []-  put (ConstantPool p)= do-    case IM.maxViewWithKey p of-      Just ((key, e), _) -> do-        putInt16be (fromIntegral (key + constantSize e))-        forM_ (IM.toAscList p) (put . snd)-      Nothing -> do-        putInt16be 0+  toConst (NameAndType rn md) =+    return $ CNameAndType rn (toText md) --- | Lookup a 'Constant' in the 'ConstantPool'.-lookupConstant :: ConstantRef -> ConstantPool -> Maybe Constant-lookupConstant (ConstantRef ref) (ConstantPool cp) =-  IM.lookup (fromIntegral ref) cp+-- TODO: Find good encoding of string.+instance Referenceable Text.Text where+  fromConst err c =+    case c of+      CString str ->+        case sizedByteStringToText str of+          Left (TE.DecodeError msg _) ->+            err $ badEncoding msg (unSizedByteString str)+          Left _ -> error "This is deprecated in the api"+          Right txt -> return txt+      a -> err $ wrongType "String" a --- | Lookup a 'Text.Text' in the 'ConstantPool', returns 'Nothing' if the--- reference does not point to something in the ConstantPool, if it points to--- something not a 'Language.JVM.Constant.String' Constant, or if it is--- impossible to decode the 'ByteString' as Utf8.-lookupText :: ConstantRef -> ConstantPool -> Maybe Text.Text-lookupText ref cp = do-  String str <- lookupConstant ref cp-  case TE.decodeUtf8' . unSizedByteString $ str of-    Left _    -> Nothing-    Right txt -> Just txt+  toConst =+    return . CString . sizedByteStringFromText --- | Lookup a class name in the 'ConstantPool', returns 'Nothing' otherwise.-lookupClassName :: ConstantRef -> ConstantPool -> Maybe Text.Text-lookupClassName ref cp = do-  ClassRef r <- lookupConstant ref cp-  lookupText r cp+instance Referenceable BS.ByteString where+  fromConst err c =+    case c of+      CString str -> return $ unSizedByteString str+      a           -> err $ wrongType "String" a+  toConst =+    return . CString . SizedByteString+++instance Referenceable ClassName where+  fromConst _ (CClassRef r) =+    return . ClassName $ r+  fromConst err a =+    err $ wrongType "ClassRef" a++  toConst (ClassName txt) = do+    return . CClassRef $ txt++instance Referenceable MethodDescriptor where+  fromConst err =+    fromConst err >=> either err pure . fromText+  toConst = toConst . toText++instance Referenceable FieldDescriptor where+  fromConst err =+    fromConst err >=> either err pure . fromText+  toConst = toConst . toText++-- instance TypeParse f => Referenceable (NameAndType f) where+--   fromConst err =+--     fromConst err >=> either err pure . fromText+--   toConst = toConst . toText++instance Referenceable MethodId where+  fromConst err x = MethodId <$> fromConst err x+  toConst (MethodId s) = toConst s++instance Referenceable FieldId where+  fromConst err x = FieldId <$> fromConst err x+  toConst (FieldId s) = toConst s++instance Referenceable (InClass FieldId High) where+  fromConst _ (CFieldRef s) = do+    return $ s+  fromConst err c = expected "CFieldRef" err c++  toConst s =+    return $ CFieldRef s++instance Referenceable (InClass MethodId High) where+  fromConst _ (CMethodRef s) = do+    return $ s+  fromConst err c = expected "CMethodRef" err c++  toConst s =+    return $ CMethodRef s++instance Referenceable (InvokeDynamic High) where+  fromConst _ (CInvokeDynamic c) = do+    return $ c+  fromConst err c = expected "CInvokeDynamic" err c++  toConst s =+    return $ CInvokeDynamic s++instance Referenceable (MethodHandle High) where+  fromConst _ (CMethodHandle c) = do+    return $ c+  fromConst err c = expected "CMethodHandle" err c++  toConst s =+    return $ CMethodHandle s++instance Referenceable (AbsInterfaceMethodId High) where+  fromConst _ (CInterfaceMethodRef s) = do+    return . AbsInterfaceMethodId $ s+  fromConst err c = expected "CInterfaceMethodRef" err c++  toConst (AbsInterfaceMethodId s) =+    return $ CInterfaceMethodRef s++instance Referenceable (AbsVariableMethodId High) where+  fromConst _ (CInterfaceMethodRef s) = do+    return . VInterfaceMethodId . AbsInterfaceMethodId $ s++  fromConst _ (CMethodRef s) = do+    return . VMethodId $ s++  fromConst err c = expected "CInterfaceMethodRef or CMethodRef" err c++  toConst (VInterfaceMethodId (AbsInterfaceMethodId s)) =+    return $ CInterfaceMethodRef s++  toConst (VMethodId s) =+    return $ CMethodRef s++expected :: String -> (String -> a) -> (Constant r) -> a+expected name err c =+  err $ wrongType name c++wrongType :: String -> Constant r -> String+wrongType n c =+  "Expected '" ++ n ++ "', but found '" ++ typeToStr c ++ "'."++badEncoding :: String -> BS.ByteString -> String+badEncoding str bs =+  "Could not encode '" ++ str ++ "': " ++ show bs++-- $(deriveBaseWithBinary ''MethodId)+-- $(deriveBaseWithBinary ''FieldId)++$(deriveBase ''Constant)+$(deriveBase ''MethodHandle)+$(deriveBase ''MethodHandleField)+$(deriveBase ''MethodHandleMethod)+$(deriveBase ''MethodHandleInterface)+$(deriveBaseWithBinary ''InvokeDynamic)++$(deriveBaseWithBinary ''AbsMethodId)+$(deriveBaseWithBinary ''AbsFieldId)+$(deriveBaseWithBinary ''AbsInterfaceMethodId)+$(deriveBaseWithBinary ''AbsVariableMethodId)++-- | A constant pool value in java+data JValue+  = VInteger Int32+  | VLong Int64+  | VFloat Float+  | VDouble Double+  | VString BS.ByteString+  | VClass ClassName+  | VMethodType (MethodDescriptor)+  | VMethodHandle (MethodHandle High)+  deriving (Show, Eq, Generic, NFData)++instance Referenceable JValue where+  fromConst err c = do+    case c of+      CStringRef s    -> return $ VString s+      CInteger i      -> return $ VInteger i+      CFloat f        -> return $ VFloat f+      CLong l         -> return $ VLong l+      CDouble d       -> return $ VDouble d+      CClassRef r     -> return $ VClass (ClassName r)+      CMethodHandle m -> return $ VMethodHandle m+      CMethodType t   -> return $ VMethodType t+      x               -> expected "Expected a Value" err x++  toConst c =+    return $ case c of+      VString s            -> CStringRef s+      VInteger i           -> CInteger i+      VFloat f             -> CFloat f+      VLong l              -> CLong l+      VDouble d            -> CDouble d+      VClass (ClassName r) -> CClassRef r+      VMethodHandle m      -> CMethodHandle m+      VMethodType t        -> CMethodType t

@@ -0,0 +1,105 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveFunctor #-}+-- {-# LANGUAGE DeriveAnyClass             #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TemplateHaskell            #-}+{-|+Copyright   : (c) Christian Gram Kalhauge, 2018+License     : MIT+Maintainer  : kalhuage@cs.ucla.edu++This module contains the 'ConstantPool' data structure and multiple+other types, and classes.+-}+module Language.JVM.ConstantPool+  (+  -- * Constant Pool+  -- $ConstantPool+    ConstantPool (..)+  , access+  , append+  , empty+  , PoolAccessError (..)+  ) where++import           Control.DeepSeq          (NFData)+import           Control.Monad.Except+import           Data.Binary+-- import           Debug.Trace+import           Data.Binary.Get+import           Data.Binary.Put+import qualified Data.IntMap              as IM+import           GHC.Generics             (Generic)++import           Language.JVM.Constant+import           Language.JVM.Stage+import           Language.JVM.TH+++-- $ConstantPool+-- The 'ConstantPool' contains all the constants, and is accessible using the+-- Lookup methods.++-- | A ConstantPool is just an 'IntMap'. A 'IntMap' is used, because constants are+-- accessed using their byte-offset, and sometimes the offset depends on the constant+-- size. See 'constantSize'.+newtype ConstantPool r = ConstantPool+  { unConstantPool :: IM.IntMap (Constant r)+  }++instance Binary (ConstantPool Low) where+  get = do+    len <- fromIntegral <$> getWord16be+    list <- go len 1+    return . ConstantPool $ IM.fromList list+    where+      go len n | len > n = do+        constant <- get+        rest <- go len (n + constantSize constant)+        return $ (n, constant) : rest+      go _ _ = return []+  put (ConstantPool p) = do+    case IM.maxViewWithKey p of+      Just ((key, e), _) -> do+        putInt16be (fromIntegral (key + constantSize e))+        forM_ (IM.toAscList p) (put . snd)+      Nothing -> do+        putInt16be 0++-- | A pool access error+data PoolAccessError = PoolAccessError+  { paErrorRef :: !Word16+  , paErrorMsg :: String+  } deriving (Show, Eq, Generic)++instance NFData PoolAccessError++-- | Creates an empty constant pool+empty :: ConstantPool r+empty = ConstantPool (IM.empty)++-- | Access a constant in the constant pool+access :: Index -> ConstantPool r -> Either PoolAccessError (Constant r)+access ref (ConstantPool cp) =+  case IM.lookup (fromIntegral ref) cp of+    Just x -> Right x+    Nothing -> Left $ PoolAccessError ref "No such element."++-- | Append a constant to the constant pool, and get the offset.+append :: Constant r -> ConstantPool r -> (Index, ConstantPool r)+append c (ConstantPool cp) =+  (fromIntegral i, ConstantPool $ IM.insert i c cp)+  where+    i =+      case IM.toDescList cp of+        (k, a):_ ->+          k + constantSize a+        _ -> 1++$(deriveBase ''ConstantPool)

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell    #-} {-| Module      : Language.JVM.Field Copyright   : (c) Christian Gram Kalhauge, 2017@@ -5,36 +6,86 @@ Maintainer  : kalhuage@cs.ucla.edu -} -{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE StandaloneDeriving #-} module Language.JVM.Field   ( Field (..)-+  , fAccessFlags   -- * Attributes   , fConstantValue+  , fSignature+  , FieldAttributes (..)   ) where -import           Data.Binary-import           Data.Monoid-import           GHC.Generics            (Generic) +import Data.Monoid+import qualified Data.Set                as Set+import qualified Data.Text               as Text+ import           Language.JVM.AccessFlag-import           Language.JVM.Attribute  (Attribute, ConstantValue, fromAttribute')-import           Language.JVM.Constant   (ConstantRef, ConstantPool)+import           Language.JVM.Attribute+import           Language.JVM.Constant+import           Language.JVM.Staged import           Language.JVM.Utils + -- | A Field in the class-file, as described -- [here](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.5).-data Field = Field-  { fAccessFlags     :: BitSet16 FAccessFlag-  , fNameIndex       :: ! ConstantRef-  , fDescriptorIndex :: ! ConstantRef-  , fAttributes      :: SizedList16 Attribute-  } deriving (Show, Eq, Generic)+data Field r = Field+  { fAccessFlags'    :: !(BitSet16 FAccessFlag)+  , fName  :: !(Ref Text.Text r)+  , fDescriptor :: !(Ref FieldDescriptor r)+  , fAttributes      :: !(Attributes FieldAttributes r)+  } -instance Binary Field where+-- | Get the set of access flags+fAccessFlags :: Field r -> Set.Set FAccessFlag+fAccessFlags = toSet . fAccessFlags'  -- | Fetch the 'ConstantValue' attribute.--- There can only one be one exceptions attribute on a field.-fConstantValue :: ConstantPool -> Field -> Maybe (Either String ConstantValue)-fConstantValue cp =-  getFirst . foldMap (First . fromAttribute' cp) . fAttributes+fConstantValue :: Field High -> Maybe (ConstantValue High)+fConstantValue =+  firstOne . faConstantValues . fAttributes++-- | Fetches the 'Signature' attribute, if any.+fSignature :: Field High -> Maybe (Signature High)+fSignature =+  firstOne . faSignatures . fAttributes++data FieldAttributes r = FieldAttributes+  { faConstantValues :: [ ConstantValue r ]+  , faSignatures     :: [ Signature r ]+  , faOthers         :: [ Attribute r ]+  }++instance Staged Field where+  evolve field = label "Field" $ do+    fi <- link (fName field)+    fd <- link (fDescriptor field)+    fattr <- fromCollector <$> fromAttributes collect' (fAttributes field)+    return $ Field (fAccessFlags' field) fi fd fattr+    where+      fromCollector (cv, sig, others) =+        FieldAttributes (appEndo cv []) (appEndo sig []) (appEndo others [])+      collect' attr =+        collect (mempty, mempty, Endo(attr:)) attr+          [ toC $ \x -> (Endo (x:), mempty, mempty)+          , toC $ \x -> (mempty, Endo (x:), mempty) ]++  devolve field = do+    fi <- unlink (fName field)+    fd <- unlink (fDescriptor field)+    fattr <- fromFieldAttributes (fAttributes field)+    return $ Field (fAccessFlags' field) fi fd (SizedList fattr)++    where+      fromFieldAttributes (FieldAttributes cvs fsg attr) =+        (\a b c -> a ++ b ++ c)+        <$> mapM toAttribute cvs+        <*> mapM toAttribute fsg+        <*> mapM devolve attr++$(deriveBase ''FieldAttributes)+$(deriveBaseWithBinary ''Field)

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE TemplateHaskell    #-} {-| Module      : Language.JVM.Method Copyright   : (c) Christian Gram Kalhauge, 2017@@ -5,69 +7,108 @@ Maintainer  : kalhuage@cs.ucla.edu -} -{-# LANGUAGE DeriveGeneric   #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE StandaloneDeriving #-} module Language.JVM.Method   ( Method (..)-   , mAccessFlags-  , mAttributes -  , mName-  , mDescriptor-   -- * Attributes+  , MethodAttributes (..)   , mCode+  , mExceptions'   , mExceptions+  , mSignature    ) where -import           Data.Binary-import           Data.Set (Set)-import qualified Data.Text as Text-import           GHC.Generics            (Generic)-+import           Data.Maybe import           Data.Monoid+import           Data.Set                          (Set)+import qualified Data.Text                         as Text  import           Language.JVM.AccessFlag-import           Language.JVM.Attribute  (Attribute, fromAttribute', Code, Exceptions)-import           Language.JVM.Constant   (ConstantRef, ConstantPool, lookupText)+import           Language.JVM.Attribute+import           Language.JVM.Attribute.Exceptions (exceptions)+import           Language.JVM.Constant+import           Language.JVM.Staged+import           Language.JVM.Type import           Language.JVM.Utils  -- | A Method in the class-file, as described -- [here](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.6).-data Method = Method-  { mAccessFlags'    :: BitSet16 MAccessFlag-  , mNameIndex       :: ! ConstantRef-  , mDescriptorIndex :: ! ConstantRef-  , mAttributes'     :: SizedList16 Attribute-  } deriving (Show, Eq, Generic)--instance Binary Method where+data Method r = Method+  { mAccessFlags' :: !(BitSet16 MAccessFlag)+  , mName         :: !(Ref Text.Text r)+  , mDescriptor   :: !(Ref MethodDescriptor r)+  , mAttributes   :: !(Attributes MethodAttributes r)+  }  -- | Unpack the BitSet and get the AccessFlags as a Set.-mAccessFlags :: Method -> Set MAccessFlag+mAccessFlags :: Method r -> Set MAccessFlag mAccessFlags = toSet . mAccessFlags' --- | Unpack the SizedList and get the attributes as a List.-mAttributes :: Method -> [Attribute]-mAttributes = unSizedList . mAttributes'---- | Lookup the name of the method in the 'ConstantPool'.-mName :: ConstantPool -> Method -> Maybe Text.Text-mName cp = flip lookupText cp . mNameIndex---- | Lookup the descriptor of the method in the 'ConstantPool'.-mDescriptor :: ConstantPool -> Method -> Maybe Text.Text-mDescriptor cp = flip lookupText cp . mDescriptorIndex+data MethodAttributes r = MethodAttributes+  { maCode       :: [Code r]+  , maExceptions :: [Exceptions r]+  , maSignatures :: [Signature r]+  , maOthers     :: [Attribute r]+  }  -- | Fetch the 'Code' attribute, if any.--- There can only one be one code attribute on a method.-mCode :: ConstantPool -> Method -> Maybe (Either String Code)-mCode cp =-  getFirst . foldMap (First . fromAttribute' cp) . mAttributes+-- There can only be one code attribute in a method.+mCode :: Method High -> Maybe (Code High)+mCode =+  firstOne . maCode . mAttributes  -- | Fetch the 'Exceptions' attribute.--- There can only one be one exceptions attribute on a method.-mExceptions :: ConstantPool -> Method -> Maybe (Either String Exceptions)-mExceptions cp =-  getFirst . foldMap (First . fromAttribute' cp) . mAttributes+-- There can only be one exceptions attribute in a method.+mExceptions' :: Method High -> Maybe (Exceptions High)+mExceptions' =+  firstOne . maExceptions . mAttributes++-- | Fetches the 'Exceptions' attribute, but turns it into an list of exceptions.+-- If no exceptions field where found the empty list is returned+mExceptions :: Method High -> [ClassName]+mExceptions =+  fromMaybe [] . fmap (unSizedList . exceptions) . mExceptions'++-- | Fetches the 'Signature' attribute, if any.+mSignature :: Method High -> Maybe (Signature High)+mSignature =+  firstOne . maSignatures . mAttributes++instance Staged Method where+  evolve (Method mf mn md mattr) = do+    mn' <- link mn+    md' <- link md+    mattr' <- label (Text.unpack (mn' <> ":" <> toText md'))+      $ fromCollector <$> fromAttributes collect' mattr+    return $ Method mf mn' md' mattr'+    where+      fromCollector (a, b, c, d) =+        MethodAttributes (appEndo a []) (appEndo b []) (appEndo c []) (appEndo d [])+      collect' attr =+        collect (mempty, mempty, mempty, Endo (attr:)) attr+          [ toC $ \e -> (Endo (e:), mempty, mempty, mempty)+          , toC $ \e -> (mempty, Endo (e:), mempty, mempty)+          , toC $ \e -> (mempty, mempty, Endo (e:), mempty)+          ]++  devolve (Method mf mn md mattr) = do+    mn' <- unlink mn+    md' <- unlink md+    mattr' <- fromMethodAttributes $ mattr+    return $ Method mf mn' md' (SizedList mattr')+    where+      fromMethodAttributes (MethodAttributes a b c d) = do+        a' <- mapM toAttribute a+        b' <- mapM toAttribute b+        c' <- mapM toAttribute c+        d' <- mapM devolve d+        return (a' ++ b' ++ c' ++ d')++$(deriveBase ''MethodAttributes)+$(deriveBaseWithBinary ''Method)

@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}+{-|+Copyright   : (c) Christian Gram Kalhauge, 2018+License     : MIT+Maintainer  : kalhuage@cs.ucla.edu++This module contains the stages, there are two stages; 'Low' and 'High'. 'Low'+represents closest to the metal and 'High' represents closer to the conceptual+representation.+-}+module Language.JVM.Stage+  ( Low+  , High+  , Ref+  , Index+  , DeepRef+  , Choice+  ) where++import Data.Word++-- | Any data structure that is in the low stage should be serializable using+-- the binary library.+data Low++-- | Any data structure in the 'High' stage, is easier to read.+data High++-- | The basic part of the stage system is the choice. The 'Choice' chooses+-- between two types depending on the stage.+type family Choice a b r+type instance Choice a b High = b+type instance Choice a b Low = a++-- | An index into the constant pool.+type Index = Word16++-- | A reference is a choice between an index and a value.+type Ref v r = Choice Index v r++-- | A deep reference points to something that itself is staged.+type DeepRef v r = Ref (v r) r

@@ -0,0 +1,146 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-|+Copyright   : (c) Christian Gram Kalhauge, 2018+License     : MIT+Maintainer  : kalhuage@cs.ucla.edu++-}+module Language.JVM.Staged+  ( Staged (..)++  -- * Monad Classes+  , LabelM (..)+  , EvolveM (..)+  , DevolveM (..)+  -- * Re-exports+  , module Language.JVM.Stage+  , module Language.JVM.TH+  ) where++import Language.JVM.Constant+import Language.JVM.Stage+import Language.JVM.TH++class Monad m => LabelM m where+  label :: String -> m a -> m a+  -- ^ label the current position in the class-file, good for debugging+  label _ = id++class LabelM m => EvolveM m where+  link :: Referenceable r => Index -> m r+  attributeError :: String -> m r++class LabelM m => DevolveM m where+  unlink :: Referenceable r => r -> m Index++class Staged s where+  {-# MINIMAL stage | evolve, devolve #-}+  stage :: LabelM m => (forall s'. Staged s' => s' r -> m (s' r')) -> s r -> m (s r')+  stage f a = f a++  evolve ::  EvolveM m => s Low -> m (s High)+  evolve = stage evolve++  devolve :: DevolveM m => s High -> m (s Low)+  devolve = stage devolve++instance Staged Constant where+  evolve c =+    case c of+      CString s -> pure $ CString s+      CInteger i -> pure $ CInteger i+      CFloat d -> pure $ CFloat d+      CLong l -> pure $ CLong l+      CDouble d -> pure $ CDouble d+      CClassRef r -> label "CClassRef" $ CClassRef <$> link r+      CStringRef r -> label "CStringRef" $ CStringRef <$> link r+      CFieldRef r -> label "CFieldRef" $ CFieldRef <$> evolve r+      CMethodRef r -> label "CMethodRef" $ CMethodRef <$> evolve r+      CInterfaceMethodRef r -> label "CInterfaceMethodRef" $ CInterfaceMethodRef <$> evolve r+      CNameAndType r1 r2 -> label "CNameAndType" $ CNameAndType <$> link r1 <*> link r2+      CMethodHandle mh -> label "CMetho" $ CMethodHandle <$> evolve mh+      CMethodType r -> label "CMethodType" $ CMethodType <$> link r+      CInvokeDynamic i -> label "CInvokeDynamic" $ CInvokeDynamic <$> evolve i++  devolve c =+    case c of+      CString s -> pure $ CString s+      CInteger i -> pure $ CInteger i+      CFloat d -> pure $ CFloat d+      CLong l -> pure $ CLong l+      CDouble d -> pure $ CDouble d+      CClassRef r -> label "CClassRef" $ CClassRef <$> unlink r+      CStringRef r -> label "CStringRef" $ CStringRef <$> unlink r+      CFieldRef r -> label "CFieldRef" $ CFieldRef <$> devolve r+      CMethodRef r -> label "CMethodRef" $ CMethodRef <$> devolve r+      CInterfaceMethodRef r -> label "CInterfaceMethodRef" $ CInterfaceMethodRef <$> devolve r+      CNameAndType r1 r2 -> label "CNameAndType" $ CNameAndType <$> unlink r1 <*> unlink r2+      CMethodHandle mh -> label "CMetho" $ CMethodHandle <$> devolve mh+      CMethodType r -> label "CMethodType" $ CMethodType <$> unlink r+      CInvokeDynamic i -> label "CInvokeDynamic" $ CInvokeDynamic <$> devolve i+++instance Staged InvokeDynamic where+  evolve (InvokeDynamic w ref) =+    InvokeDynamic w <$> link ref++  devolve (InvokeDynamic w ref) =+    InvokeDynamic w <$> unlink ref++-- instance Staged MethodId where+--   evolve (MethodId n d) =+--     MethodId <$> link n <*> link d++--   devolve (MethodId n d) =+--     MethodId <$> unlink n <*> unlink d++instance Referenceable r => Staged (InClass r) where+  evolve (InClass cn cid) =+    InClass <$> link cn <*> link cid+  devolve (InClass cn cid) =+    InClass <$> unlink cn <*> unlink cid++instance Staged MethodHandle where+  evolve m =+    case m of+      MHField r -> MHField <$> evolve r+      MHMethod r -> MHMethod <$> evolve r+      MHInterface r -> MHInterface <$> evolve r++  devolve m =+    case m of+      MHField r -> MHField <$> devolve r+      MHMethod r -> MHMethod <$> devolve r+      MHInterface r -> MHInterface <$> devolve r++instance Staged MethodHandleMethod where+  evolve g =+    case g of+      MHInvokeVirtual m -> MHInvokeVirtual <$> link m+      MHInvokeStatic m -> MHInvokeStatic <$> link m+      MHInvokeSpecial m -> MHInvokeSpecial <$> link m+      MHNewInvokeSpecial m -> MHNewInvokeSpecial <$> link m++  devolve g =+    case g of+      MHInvokeVirtual m -> MHInvokeVirtual <$> unlink m+      MHInvokeStatic m -> MHInvokeStatic <$> unlink m+      MHInvokeSpecial m -> MHInvokeSpecial <$> unlink m+      MHNewInvokeSpecial m -> MHNewInvokeSpecial <$> unlink m++instance Staged MethodHandleField where+  evolve (MethodHandleField k ref) =+    MethodHandleField k <$> link ref++  devolve (MethodHandleField k ref) =+    MethodHandleField k <$> unlink ref++instance Staged MethodHandleInterface where+  evolve (MethodHandleInterface ref) =+    MethodHandleInterface <$> link ref++  devolve (MethodHandleInterface ref) =+    MethodHandleInterface <$> unlink ref

@@ -0,0 +1,87 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE StandaloneDeriving #-}+{-|+Module      : Language.JVM.TH+Copyright   : (c) Christian Gram Kalhauge, 2018+License     : MIT+Maintainer  : kalhuage@cs.ucla.edu++This module contains some Template Haskell functions for internal use.+-}++module Language.JVM.TH+  ( deriveBase+  , deriveBases+  , deriveBaseWithBinary+  ) where++import Language.Haskell.TH++import GHC.Generics+import Control.DeepSeq+import Data.Binary++import Language.JVM.Stage++-- | Derives the 'NFData', 'Show', 'Eq', and 'Generic'+-- from something that is 'Staged'+deriveBase :: Name -> Q [Dec]+deriveBase name =+  concat <$> sequence+  [ [d|deriving instance Show ($n Low)|]+  , [d|deriving instance Eq ($n Low)|]+  , [d|deriving instance Generic ($n Low)|]+  , [d|deriving instance NFData ($n Low)|]+  , [d|deriving instance Ord ($n Low)|]++  , [d|deriving instance Show ($n High)|]+  , [d|deriving instance Eq ($n High)|]+  , [d|deriving instance Generic ($n High)|]+  , [d|deriving instance NFData ($n High)|]+  ]+  where n = conT name++-- | Derives the bases of a list of names+deriveBases :: [Name] -> Q [Dec]+deriveBases names =+  concat <$> mapM deriveBase names++-- | Derives the 'NFData', 'Show', 'Eq', and 'Generic' from something that is+-- 'Staged'+deriveBaseWithBinary :: Name -> Q [Dec]+deriveBaseWithBinary name = do+  b <- deriveBase name+  m1 <- deriveBinary name+  return (b ++ m1)++deriveBinary :: Name -> Q [Dec]+deriveBinary name =+  [d|deriving instance Binary ($n Low)|]+  where+    n = conT name++-- -- | Derives the 'NFData', 'Show', 'Eq', and 'Generic'+-- -- from something that is 'Staged'+-- deriveBaseO :: Name -> Name -> Q [Dec]+-- deriveBaseO tp name = do+--   b <- deriveBase name+--   m1 <- [d|deriving instance Eq ($n $t)|]+--   m2 <- [d|deriving instance Ord ($n $t)|]+--   return (b ++ m1 ++ m2)+--   where+--     n = conT name+--     t = conT tp++-- -- | Derives the 'NFData', 'Show', 'Eq', and 'Generic'+-- -- from something that is 'Staged'+-- deriveBaseBO :: Name -> Name -> Q [Dec]+-- deriveBaseBO tp name = do+--   b <- deriveBaseB tp name+--   m1 <- [d|deriving instance Eq ($n $t)|]+--   m2 <- [d|deriving instance Ord ($n $t)|]+--   return (b ++ m1 ++ m2)+--   where+--     n = conT name+--     t = conT tp

@@ -0,0 +1,194 @@+{-|+Module      : Language.JVM.Type+Copyright   : (c) Christian Gram Kalhauge, 2018+License     : MIT+Maintainer  : kalhuage@cs.ucla.edu++This module contains the 'JType', 'ClassName', 'MethodDescriptor', and+'FieldDescriptor'.+-}+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE OverloadedStrings    #-}+module Language.JVM.Type+  (+  -- * Base types+  -- ** ClassName+    ClassName (..)+  , strCls+  , dotCls++  -- ** JType+  , JType (..)+  , JBaseType (..)++  -- ** MethodDescriptor+  , MethodDescriptor (..)++  -- ** FieldDescriptor+  , FieldDescriptor (..)++  -- ** NameAndType+  , NameAndType (..)+  , (<:>)++  , TypeParse (..)+  ) where++import           Control.DeepSeq      (NFData)+import           Data.Attoparsec.Text+import           Data.String+import qualified Data.Text            as Text+import           GHC.Generics         (Generic)+import           Prelude              hiding (takeWhile)++-- | A class name+newtype ClassName = ClassName+  { classNameAsText :: Text.Text+  } deriving (Eq, Ord, Generic, NFData)++instance Show ClassName where+  show = show . classNameAsText++-- | Wrapper method that converts a string representation of a class into+-- a class.+strCls :: String -> ClassName+strCls = dotCls . Text.pack++-- | Takes the dot representation and converts it into a class.+dotCls :: Text.Text -> ClassName+dotCls = ClassName . Text.intercalate "/" . Text.splitOn "."++-- | The Jvm Primitive Types+data JBaseType+  = JTByte+  | JTChar+  | JTDouble+  | JTFloat+  | JTInt+  | JTLong+  | JTShort+  | JTBoolean+  deriving (Show, Eq, Ord, Generic, NFData)++-- | The JVM types+data JType+  = JTBase JBaseType+  | JTClass ClassName+  | JTArray JType+  deriving (Show, Eq, Ord, Generic, NFData)++-- | Method Descriptor+data MethodDescriptor = MethodDescriptor+  { methodDescriptorArguments  :: [JType]+  , methodDescriptorReturnType :: Maybe JType+  } deriving (Show, Ord, Eq, Generic, NFData)++-- | Field Descriptor+newtype FieldDescriptor = FieldDescriptor+  { fieldDescriptorType :: JType+  } deriving (Show, Ord, Eq, Generic, NFData)++-- | A name and a type+data NameAndType a = NameAndType+  { ntName       :: Text.Text+  , ntDescriptor :: a+  } deriving (Show, Eq, Ord, Generic, NFData)++(<:>) :: Text.Text -> a -> NameAndType a+(<:>) = NameAndType++class TypeParse a where+  fromText :: Text.Text -> Either String a+  fromText = parseOnly parseText+  parseText :: Parser a+  toText :: a -> Text.Text++instance TypeParse JType where+  parseText = try $ do+    s <- anyChar+    case s :: Char of+      'B' -> return $ JTBase JTByte+      'C' -> return $ JTBase JTChar+      'D' -> return $ JTBase JTDouble+      'F' -> return $ JTBase JTFloat+      'I' -> return $ JTBase JTInt+      'J' -> return $ JTBase JTLong+      'L' -> do+        txt <- takeWhile (/= ';')+        _ <- char ';'+        return $ JTClass (ClassName txt)+      'S' -> return $ JTBase JTShort+      'Z' -> return $ JTBase JTBoolean+      '[' -> JTArray <$> parseText+      _ -> fail $ "Unknown char " ++ show s+  toText tp =+    Text.pack $ go tp ""+    where+      go x =+        case x of+          JTBase y               -> textbase y+          JTClass (ClassName cn) -> ((('L':Text.unpack cn) ++ ";") ++)+          JTArray tp'            -> ('[':) . go tp'+      textbase y =+        case y of+          JTByte    -> ('B':)+          JTChar    -> ('C':)+          JTDouble  -> ('D':)+          JTFloat   -> ('F':)+          JTInt     -> ('I':)+          JTLong    -> ('J':)+          JTShort   -> ('S':)+          JTBoolean -> ('Z':)++instance TypeParse MethodDescriptor where+  toText md =+    Text.concat (+      ["("]+      ++ map toText (methodDescriptorArguments md)+      ++ [")", maybe "V" toText $ methodDescriptorReturnType md ]+    )+  parseText = do+    _ <- char '('+    args <- many' parseText <?> "method arguments"+    _ <- char ')'+    returnType <- choice+      [ char 'V' >> return Nothing+      , Just <$> parseText+      ] <?> "return type"+    return $ MethodDescriptor args returnType++instance TypeParse FieldDescriptor where+  parseText = FieldDescriptor <$> parseText+  toText (FieldDescriptor t) = toText t++instance TypeParse t => TypeParse (NameAndType t)  where+  parseText = do+    name <- many1 $ notChar ':'+    _ <- char ':'+    _type <- parseText+    return $ NameAndType (Text.pack name) _type+  toText (NameAndType name _type) =+    Text.concat [ name , ":" , toText _type ]++fromString' ::+  TypeParse t+  => String+  -> t+fromString' =+  either (error . ("Failed " ++)) id . fromText . Text.pack++instance IsString ClassName where+  fromString = strCls++instance IsString JType where+  fromString = fromString'++instance IsString FieldDescriptor where+  fromString = fromString'++instance IsString MethodDescriptor where+  fromString = fromString'++instance TypeParse t => IsString (NameAndType t) where+  fromString = fromString'

@@ -7,8 +7,10 @@ This module contains utilities missing not in other libraries. -} -{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}  module Language.JVM.Utils   ( -- * Sized Data Structures@@ -24,7 +26,11 @@   , SizedList16   , SizedByteString32   , SizedByteString16+  , sizedByteStringFromText+  , sizedByteStringToText +  , tryDecode+     -- * Bit Set     --     -- $BitSet@@ -43,14 +49,23 @@ import           Data.Binary.Get import           Data.Binary.Put import           Data.Bits-import           Data.List       as List-import           Data.Set        as Set+import           Data.List                as List+import           Data.Set                 as Set+import           Data.String +import           Control.DeepSeq          (NFData) import           Control.Monad -import qualified Data.ByteString as BS+import qualified Data.Text                as Text +import qualified Data.Text.Encoding       as TE+import qualified Data.Text.Encoding.Error as TE +import qualified Data.ByteString          as BS++-- import           Debug.Trace++ -- $SizedDataStructures -- These data structures enables binary reading and writing of lists and -- byte strings that are prepended with the number of elements to read or write.@@ -60,7 +75,7 @@ -- length N of type 'w' and then N items of type 'a'. newtype SizedList w a = SizedList   { unSizedList :: [ a ]-  } deriving (Show, Eq, Functor)+  } deriving (Show, Eq, Functor, NFData, Ord)  -- | Get the size of the sized list. listSize :: Num w => SizedList w a -> w@@ -87,7 +102,7 @@ -- | A byte string with a size w. newtype SizedByteString w = SizedByteString   { unSizedByteString :: BS.ByteString-  } deriving (Show, Eq)+  } deriving (Show, Eq, NFData, Ord, IsString)  -- | Get the size of a SizedByteString byteStringSize :: (Num w) => SizedByteString w -> w@@ -102,6 +117,42 @@     put (byteStringSize sbs)     putByteString bs +replaceJavaZeroWithNormalZero :: BS.ByteString -> BS.ByteString+replaceJavaZeroWithNormalZero = go+  where+    go bs =+      case BS.breakSubstring "\192\128" bs of+        (h, "") -> h+        (h, t) -> h `BS.append` "\0" `BS.append` go (BS.drop 2 t)++replaceNormalZeroWithJavaZero::BS.ByteString -> BS.ByteString+replaceNormalZeroWithJavaZero = go+  where+      go bs =+        case BS.breakSubstring "\0" bs of+          (h, "") -> h+          (h, t) -> h `BS.append` "\192\128" `BS.append` go (BS.drop 1 t)++-- | Convert a Sized bytestring to Utf8 Text.+sizedByteStringToText ::+     SizedByteString w+  -> Either TE.UnicodeException Text.Text+sizedByteStringToText (SizedByteString bs) =+  let rst = TE.decodeUtf8' bs+    in case rst of+      Right txt -> Right txt+      Left _ -> tryDecode bs++tryDecode :: BS.ByteString -> Either TE.UnicodeException Text.Text+tryDecode =  TE.decodeUtf8' . replaceJavaZeroWithNormalZero++-- | Convert a Sized bytestring from Utf8 Text.+sizedByteStringFromText ::+     Text.Text+  -> SizedByteString w+sizedByteStringFromText t+  = SizedByteString . replaceNormalZeroWithJavaZero . TE.encodeUtf8 $ t+ -- $BitSet -- A bit set is a set where each element is represented a bit in a word. This -- section also defines the 'Enumish' type class. It is different than a 'Enum'@@ -123,18 +174,23 @@ -- | A bit set of size w newtype BitSet w a = BitSet   { toSet :: Set.Set a-  } deriving (Ord, Show, Eq)+  } deriving (Ord, Show, Eq, NFData) -instance (Bits w, Binary w, Enumish a) => Binary (BitSet w a) where++bitSetToWord :: (Enumish a, Bits w) => BitSet w a -> w+bitSetToWord =+  toWord . Set.toList . toSet++toWord :: (Enumish a, Bits w) => [a] -> w+toWord =+  List.foldl' (\a -> setBit a . fromEnumish) zeroBits++instance (Show w, Bits w, Binary w, Enumish a) => Binary (BitSet w a) where   get = do     word <- get :: Get w     return . BitSet $ Set.fromList [ x | (i, x) <- inOrder, testBit word i ] -  put (BitSet f) = do-    let word =-          List.foldl' setBit zeroBits-            (List.map fromEnumish $ Set.toList f) :: w-    put word+  put = put . bitSetToWord  -- | A sized list using a 16 bit word as length type SizedList16 = SizedList Word16

@@ -1,6 +1,5 @@-resolver: lts-9.3+resolver: lts-10.5 packages: - .-extra-deps: [] flags: {}-extra-package-dbs: []+extra-deps: []

@@ -1,84 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Language.JVM.Attribute.CodeTest where--import           SpecHelper--import           Data.Word--import           Language.JVM.Attribute     (Attribute)-import           Language.JVM.AttributeTest ()--import           Language.JVM.Attribute.Code-import qualified Language.JVM.Constant      as Constant-import           Language.JVM.UtilsTest ()----- prop_encode_and_decode_ByteCode :: ByteCode -> Property--- prop_encode_and_decode_ByteCode = isoBinary---- prop_encode_and_decode :: Code Attribute -> Property--- prop_encode_and_decode = isoBinary--instance Arbitrary (Code Attribute) where-  arbitrary = Code-    <$> arbitrary-    <*> arbitrary-    <*> arbitrary-    <*> arbitrary-    <*> arbitrary---instance Arbitrary ArithmeticType where-  arbitrary = elements [ MInt, MLong, MFloat, MDouble ]--instance Arbitrary LocalType where-  arbitrary = elements [ LInt, LLong, LFloat, LDouble, LRef ]--instance Arbitrary ByteCodeInst where-  arbitrary = ByteCodeInst <$> arbitrary <*> arbitrary--instance Arbitrary ByteCodeOpr where-  arbitrary = oneof-    [ pure Nop-    , Push <$> arbitrary-    ]--instance Arbitrary Constant where-  arbitrary = oneof-    [ pure CNull-    , pure CIntM1-    , pure CInt0-    , pure CInt1-    , pure CInt2-    , pure CInt3-    , pure CInt4-    , pure CInt5--    , pure CLong0-    , pure CLong1--    , pure CFloat0-    , pure CFloat1-    , pure CFloat2--    , pure CDouble0-    , pure CDouble1--    , CByte <$> arbitrary-    , CShort <$> arbitrary--    , CHalfRef . Constant.ConstantRef . fromIntegral <$> (arbitrary  :: Gen Word8)-    , CRef One <$> arbitrary-    , CRef Two <$> arbitrary-    ]--instance Arbitrary ByteCode where-  arbitrary = ByteCode <$> arbitrary--instance Arbitrary ExceptionTable where-  arbitrary = ExceptionTable-    <$> arbitrary-    <*> arbitrary-    <*> arbitrary-    <*> arbitrary

@@ -1,50 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Language.JVM.Attribute.StackMapTableTest where--import           SpecHelper--import           Language.JVM.AttributeTest           ()-import           Language.JVM.ConstantTest            ()-import           Language.JVM.UtilsTest               ()--import           Language.JVM.Attribute.StackMapTable--prop_encode_and_decode :: StackMapTable -> Property-prop_encode_and_decode = isoBinary--prop_StackMapFrame_encode_and_decode :: StackMapFrame -> Property-prop_StackMapFrame_encode_and_decode = isoBinary--instance Arbitrary StackMapTable where-  arbitrary = StackMapTable <$> arbitrary--instance Arbitrary StackMapFrame where-  arbitrary =-    StackMapFrame <$> arbitrary <*> arbitrary--instance Arbitrary StackMapFrameType where-  arbitrary = oneof-    [ pure SameFrame-    , SameLocals1StackItemFrame <$> arbitrary-    , ChopFrame <$> choose (1,3)-    , AppendFrame <$> (choose (1,3) >>= flip vectorOf arbitrary)-    , FullFrame <$> arbitrary <*> arbitrary-    ]--instance Arbitrary (VerificationTypeInfo) where-  arbitrary = oneof-    [ pure VTop-    , pure VInteger-    , pure VTop-    , pure VInteger-    , pure VFloat-    , pure VLong-    , pure VDouble-    , pure VNull-    , pure VUninitializedThis-    , VObject <$> arbitrary-    , VUninitialized <$> arbitrary-    ]

@@ -1,21 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Language.JVM.AttributeTest where--import SpecHelper--import Language.JVM.Attribute (Attribute (..))-import Language.JVM.ConstantTest ()-import Language.JVM.Utils-import Language.JVM.UtilsTest ()--import qualified Data.ByteString as BS--prop_encode_and_decode :: Attribute -> Property-prop_encode_and_decode = isoBinary--instance Arbitrary Attribute where-  arbitrary = do-    idx <- arbitrary-    len <- choose (0, 50)-    bs <- SizedByteString . BS.pack <$> sequence (replicate len arbitrary)-    return $ Attribute idx bs

@@ -1,33 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Language.JVM.ClassFileTest where--import SpecHelper--import qualified Data.IntMap as IM--import Language.JVM.ClassFile-import Language.JVM.Constant--import Language.JVM.Utils-import Language.JVM.UtilsTest ()-import Language.JVM.AttributeTest ()-import Language.JVM.ConstantTest ()-import Language.JVM.FieldTest ()-import Language.JVM.MethodTest ()--prop_encode_and_decode :: ClassFile -> Property-prop_encode_and_decode = isoBinary--instance Arbitrary ClassFile where-  arbitrary = ClassFile-    <$> arbitrary-    <*> arbitrary-    <*> arbitrary-    <*> (pure $ ConstantPool IM.empty)-    <*> arbitrary-    <*> arbitrary-    <*> arbitrary-    <*> (pure $ SizedList [])-    <*> (pure $ SizedList [])-    <*> (pure $ SizedList [])-    <*> (pure $ SizedList [])

@@ -1,42 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Language.JVM.ConstantTest where--import SpecHelper--import Language.JVM.Constant-import Language.JVM.UtilsTest ()--import qualified Data.IntMap as IM--prop_encode_and_decode :: ConstantPool -> Property-prop_encode_and_decode = isoBinary--instance Arbitrary ConstantRef where-  arbitrary =-    ConstantRef <$> arbitrary--instance Arbitrary ConstantPool where-  arbitrary =-    ConstantPool . IM.fromList . go 1 <$> arbitrary-    where-      go n (e : lst) =-        (n, e) : go (n + constantSize e) lst-      go _ [] = []--instance Arbitrary Constant where-  arbitrary = oneof-    [ String <$> arbitrary-    , Integer <$> arbitrary-    , Float <$> arbitrary-    , Long <$> arbitrary-    , Double <$> arbitrary-    , ClassRef <$> arbitrary-    , StringRef <$> arbitrary-    , FieldRef <$> arbitrary <*> arbitrary-    , MethodRef <$> arbitrary <*> arbitrary-    , InterfaceMethodRef <$> arbitrary <*> arbitrary-    , NameAndType <$> arbitrary <*> arbitrary-    , MethodHandle <$> arbitrary <*> arbitrary-    , MethodType <$> arbitrary-    , InvokeDynamic <$> arbitrary <*> arbitrary-    ]

@@ -1,19 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Language.JVM.FieldTest where--import SpecHelper--import Language.JVM.Field-import Language.JVM.UtilsTest ()-import Language.JVM.ConstantTest ()-import Language.JVM.AttributeTest ()--prop_encode_and_decode :: Field -> Property-prop_encode_and_decode = isoBinary--instance Arbitrary Field where-  arbitrary = Field-    <$> arbitrary-    <*> arbitrary-    <*> arbitrary-    <*> arbitrary

@@ -1,19 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Language.JVM.MethodTest where--import SpecHelper--import Language.JVM.Method-import Language.JVM.UtilsTest ()-import Language.JVM.ConstantTest ()-import Language.JVM.AttributeTest ()--prop_encode_and_decode :: Method -> Property-prop_encode_and_decode = isoBinary--instance Arbitrary Method where-  arbitrary = Method-    <$> arbitrary-    <*> arbitrary-    <*> arbitrary-    <*> arbitrary

@@ -1,22 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Language.JVM.UtilsTest where--import SpecHelper--import qualified Data.ByteString as BS--import Data.Set as Set-import Language.JVM.Utils--instance Arbitrary a => Arbitrary (SizedList w a) where-  arbitrary =-    SizedList <$> arbitrary--instance Arbitrary (SizedByteString w) where-  arbitrary = do-    len <- choose (0, 50)-    SizedByteString . BS.pack <$> sequence (replicate len arbitrary)--instance (Enumish a) => Arbitrary (BitSet w a) where-  arbitrary =-    BitSet . Set.fromList <$> sublistOf (snd <$> inOrder)

@@ -1,30 +0,0 @@-module Language.JVMTest where--import SpecHelper--import Control.Monad--- import Data.Text as Text-import Data.Maybe-import Data.Either--- import Debug.Trace--import Language.JVM-import Language.JVM.Attribute.Code ()--test_reading_classfile :: IO [TestTree]-test_reading_classfile = testAllFiles $ do-  it "can parse the bytestring" $ \bs -> do-    decodeClassFile bs `shouldSatisfy` isRight--  beforeWith (\bs -> either fail return $ decodeClassFile bs) $ do--    it "has a the magic number: 0xCAFEBABE" $ \cls ->-      cMagicNumber cls `shouldBe` 0xCAFEBABE--    it "has a class name" $ \cls ->-      cThisClass (cConstantPool cls) cls `shouldSatisfy` isJust--    it "can parse all method codes" $ \cls ->-      forM_ (catMaybes . map (mCode (cConstantPool cls)) $ cMethods cls) $-      \code-> do-        code `shouldSatisfy` isRight

@@ -1,68 +0,0 @@-module SpecHelper-  ( module Test.Tasty-  , module Test.Tasty.Hspec-  , module Test.Tasty.QuickCheck-  , decode-  , encode-  , blReadFile-  , isoBinary-  , testAllFiles-  , testSomeFiles-  ) where--import Test.Tasty-import Test.Tasty.Hspec-import Test.Tasty.QuickCheck-import qualified Data.ByteString.Lazy as BL--import System.FilePath-import System.Directory--import Control.Monad-import Data.Binary-import Data.Bits--blReadFile :: FilePath -> IO BL.ByteString-blReadFile = BL.readFile--toHex :: Word8 -> String-toHex x =-  [ alpha !! fromIntegral (x `shift` (-4))-  , alpha !! fromIntegral (x `mod` 16)-  ]-  where alpha = "0123456789abcdef"--testAllFiles :: SpecWith BL.ByteString -> IO [TestTree]-testAllFiles spec = do-  files <- filter isClass <$> recursiveContents "test-suite/data"-  forM files $ \file -> testSpec file (beforeAll (blReadFile file) spec)-  where-    isClass p = takeExtension p == ".class"---testSomeFiles :: SpecWith BL.ByteString -> IO [TestTree]-testSomeFiles spec =-  forM files $ \file -> testSpec file (beforeAll (blReadFile file) spec)-  where-    files =-      [ "test-suite/data/java/util/zip/ZipOutputStream.class"-      -- , "test-suite/data/project/Main.class"-      ]--isoBinary :: (Binary a, Eq a, Show a) => a -> Property-isoBinary a =-  let bs = encode a-  in counterexample (concat . map toHex $ BL.unpack bs) $-      decode bs === a--folderContents :: FilePath -> IO [ FilePath ]-folderContents fp =-  map (fp </>) <$> listDirectory fp--recursiveContents :: FilePath -> IO [ FilePath ]-recursiveContents fp = do-  test <- doesDirectoryExist fp-  (fp:) <$> if test then do-    content <- folderContents fp-    concat <$> mapM recursiveContents content-  else return []

@@ -1,60 +0,0 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}----- {-# LANGUAGE OverloadedStrings #-}--- import           Language.JVM.Binary.Attribute (Attribute(..))--- import           Language.JVM.Binary.ClassFile----- import           Data.Binary            (decode, encode)--- import qualified Data.ByteString.Lazy   as LBS--- import qualified Data.ByteString.Char8  as BC--- import qualified Data.ByteString as BS---- import qualified Test.Tasty--- import           Test.Tasty.Hspec--- import           Test.Tasty.QuickCheck  as QC----- main :: IO ()--- main = do---   putStrLn ".."---   test <- testSpec "jvmhs" classfileSpec---   Test.Tasty.defaultMain (Test.Tasty.testGroup "All of it" [ test, encodedecode ])---- classfileSpec :: Spec--- classfileSpec = beforeAll (LBS.readFile "test-suite/project/Main.class") $ do---   it "can read the bytestring" $---     \bs -> let classfile = decode bs---            in (magicNumber classfile) `shouldBe` 3405691582----   it "can encode and decode attributes" $---     \_ -> let attr = Attribute 1 (BC.pack "Hello")---            in (decode . encode ) attr `shouldBe` attr----   it "will encode and decode back to a class file" $ \bs ->---     let classfile = decode bs :: ClassFile---         encoding = encode classfile---     in (methods classfile) `shouldBe` (methods $ decode (LBS.append encoding (LBS.repeat 0)))----   it "will encode the data back to the same format" $ \bs ->---     let classfile = decode bs :: ClassFile---     in bs `shouldBe` encode classfile----- encodedecode :: Test.Tasty.TestTree--- encodedecode =---   Test.Tasty.testGroup "encode . decode == id"---   [ QC.testProperty "Attribute" $ \(ArbAttribute attr) ->---       (decode . encode) attr == attr---   ]---- newtype ArbAttribute =---   ArbAttribute Attribute deriving (Show, Eq)---- instance Arbitrary ArbAttribute where---   arbitrary = do---     index <- arbitrary---     len <- choose (0, 50)---     bs <- BS.pack <$> sequence (replicate len arbitrary)---     return $ ArbAttribute (Attribute index bs)

@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleInstances #-}++module Language.JVM.Attribute.BootstrapMethodsTest where++import           SpecHelper++import           Language.JVM.ConstantTest               ()++import           Language.JVM.Attribute.BootstrapMethods+import           Language.JVM++prop_roundtrip_BootstrapMethods :: BootstrapMethods High -> Property+prop_roundtrip_BootstrapMethods = isoRoundtrip++instance Arbitrary (BootstrapMethods High) where+  arbitrary = genericArbitraryU++instance Arbitrary (BootstrapMethod High) where+  arbitrary =+    BootstrapMethod <$> arbitrary <*> (SizedList <$> listOf (resize 1 arbitrary))

@@ -0,0 +1,178 @@+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.JVM.Attribute.CodeTest where++import qualified Data.Vector                                as V+import           Generic.Random+++import           SpecHelper++import           Language.JVM.Attribute.LineNumberTableTest ()+import           Language.JVM.Attribute.StackMapTableTest   ()+import           Language.JVM.AttributeTest                 ()+import           Language.JVM.UtilsTest                     ()++import           Language.JVM+import           Language.JVM.Attribute.Code++prop_roundtrip_Code :: Code High -> Property+prop_roundtrip_Code = isoRoundtrip++-- prop_roundtrip_ByteCode :: ByteCode High -> Property+-- prop_roundtrip_ByteCode = isoRoundtrip++prop_roundtrip_ExceptionTable :: ExceptionTable High -> Property+prop_roundtrip_ExceptionTable = isoByteCodeRoundtrip++prop_roundtrip_ByteCodeInst :: ByteCodeInst High -> Property+prop_roundtrip_ByteCodeInst = isoByteCodeRoundtrip+++spec_ByteCode_examples :: SpecWith ()+spec_ByteCode_examples = do+  it "can round trip 'push (i127)'" $ do+    let opr = ByteCodeInst 0 (Push (Just (VInteger 127)))+    (snd <$> byteCodeRoundtrip opr) `shouldBe` Right opr++  it "can round trip 'push (i-129)'" $ do+    let opr = ByteCodeInst 0 (Push (Just (VInteger (-129))))+    (snd <$> byteCodeRoundtrip opr) `shouldBe` Right opr++instance Arbitrary (Code High) where+  arbitrary = do+    bc <- arbitrary+    Code+      <$> arbitrary+      <*> arbitrary+      <*> pure bc+      <*> (SizedList <$> listOf (genExceptionTable (fromIntegral . V.length . unByteCode $ bc)))+      <*> pure (CodeAttributes [] [] [])++genExceptionTable :: Int -> Gen (ExceptionTable High)+genExceptionTable i =+  ExceptionTable+    <$> (arbitraryRef i)+    <*> (arbitraryRef i)+    <*> (arbitraryRef i)+    <*> arbitrary++arbitraryRef :: Int -> Gen Int+arbitraryRef i =+  choose (0, i - 1)++instance Arbitrary (CodeAttributes High) where+  arbitrary = genericArbitraryU++instance Arbitrary (ExceptionTable High) where+  arbitrary =+    ExceptionTable <$> arbitraryRef 0xffff <*> arbitraryRef 0xffff <*> arbitraryRef 0xffff <*> arbitrary++instance Arbitrary (ByteCode High) where+  arbitrary = do+    s <- getSize+    ByteCode . V.fromList <$> vectorOf s (genByteCodeOpr s)++instance Arbitrary (ByteCodeInst High) where+  arbitrary =+    ByteCodeInst <$> pure 0 <*> genByteCodeOpr 0xffff++instance Arbitrary ArithmeticType where+  arbitrary = elements [ MInt, MLong, MFloat, MDouble ]++instance Arbitrary LocalType where+  arbitrary = elements [ LInt, LLong, LFloat, LDouble, LRef ]+++genByteCodeOpr :: Int -> Gen (ByteCodeOpr High)+genByteCodeOpr i = do+  x <- (genericArbitraryU :: Gen (ByteCodeOpr High))+  case x of+    If cp on _   -> If cp on <$> arbitraryRef i+    IfRef b on _ -> IfRef b on <$> arbitraryRef i+    Goto _       -> Goto <$> arbitraryRef i+    Jsr _        -> Jsr <$> arbitraryRef i+    TableSwitch r (SwitchTable l ofss) ->+      TableSwitch r . SwitchTable l <$> V.mapM (const $ arbitraryRef i) ofss+    _            -> return x++instance Arbitrary a => Arbitrary (V.Vector a) where+  arbitrary = V.fromList <$> arbitrary++instance Arbitrary ArrayType where+  arbitrary = genericArbitrary uniform++instance Arbitrary (ExactArrayType High) where+  arbitrary =+    oneof+    [ pure EABoolean+    , pure EAByte+    , pure EAChar+    , pure EAShort+    , pure EAInt+    , pure EALong+    , pure EAFloat+    , pure EADouble+    , EARef <$> arbitrary+    ]++instance Arbitrary BinOpr where+  arbitrary = genericArbitrary uniform++instance Arbitrary CastOpr where+  arbitrary =+    oneof . map pure $+      [ CastTo MInt MLong+      , CastTo MInt MFloat+      , CastTo MInt MDouble++      , CastTo MLong MInt+      , CastTo MLong MFloat+      , CastTo MLong MDouble++      , CastTo MFloat MInt+      , CastTo MFloat MLong+      , CastTo MFloat MDouble++      , CastTo MDouble MInt+      , CastTo MDouble MLong+      , CastTo MDouble MFloat++      , CastDown MByte+      , CastDown MChar+      , CastDown MShort+      ]++instance Arbitrary BitOpr where+  arbitrary = genericArbitraryU++instance Arbitrary OneOrTwo where+  arbitrary = genericArbitraryU++instance Arbitrary SmallArithmeticType where+  arbitrary = genericArbitraryU++instance Arbitrary CmpOpr where+  arbitrary = genericArbitraryU++instance Arbitrary FieldAccess where+  arbitrary = genericArbitrary uniform++instance Arbitrary (Invocation High) where+  arbitrary =+    oneof+    [ InvkSpecial <$> arbitrary+    , InvkVirtual <$> arbitrary+    , InvkStatic <$> arbitrary+    , InvkInterface <$> (arbitrary `suchThat` \i -> i > 0) <*> arbitrary+    , InvkDynamic <$> arbitrary+    ]+instance Arbitrary (CConstant High) where+  arbitrary = genericArbitraryU++instance Arbitrary (SwitchTable High) where+  arbitrary = genericArbitraryU+