JVM/Types.hs

   1 {-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
   2 -- | This module declares `high-level' data types for Java classes, methods etc.
   3 module JVM.Types where
   4
   5 import Codec.Binary.UTF8.String hiding (encode, decode)
   6 import Control.Applicative
   7 import Data.Array
   8 import Data.Binary
   9 import Data.Binary.Put
  10 import qualified Data.ByteString.Lazy as B
  11 import Data.Word
  12 import Data.Char
  13 import Data.String
  14 import qualified Data.Set as S
  15 import qualified Data.Map as M
  16
  17 import JVM.ClassFile
  18
  19 instance IsString B.ByteString where
  20   fromString s = B.pack $ map (fromIntegral . ord) $ encodeString s
  21
  22 toString :: B.ByteString -> String
  23 toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr
  24
  25 -- | Constant pool
  26 type Pool = Array Word16 Constant
  27
  28 asize :: (Ix i) => Array i e -> Int
  29 asize = length . elems
  30
  31 showListIx :: (Show a) => [a] -> String
  32 showListIx list = unlines $ zipWith s [1..] list
  33   where s i x = show i ++ ":\t" ++ show x
  34
  35 class HasAttributes a where
  36   attributes :: a -> Attributes
  37
  38 -- | Java class
  39 data Class = Class {
  40   constantPool :: Pool,
  41   classAccess :: Access,
  42   this :: B.ByteString,        -- ^ this class name
  43   super :: Maybe B.ByteString, -- ^ super class name
  44   implements :: [B.ByteString], -- ^ implemented interfaces
  45   fields :: [Field],
  46   methods :: [Method],
  47   classAttrs :: Attributes
  48   }
  49   deriving (Eq, Show)
  50
  51 instance HasAttributes Class where
  52   attributes = classAttrs
  53
  54 class HasSignature a where
  55   type Signature a
  56
  57 -- | Name and signature pair. Used for methods and fields.
  58 data NameType a = NameType {
  59   ntName :: B.ByteString,
  60   ntSignature :: Signature a }
  61
  62 instance Show (Signature a) => Show (NameType a) where
  63   show (NameType n t) = toString n ++ ": " ++ show t
  64
  65 deriving instance Eq (Signature a) => Eq (NameType a)
  66
  67 -- | Constant pool item
  68 data Constant =
  69     CClass B.ByteString
  70   | CField {refClass :: B.ByteString, fieldNameType :: NameType Field}
  71   | CMethod {refClass :: B.ByteString, nameType :: NameType Method}
  72   | CIfaceMethod {refClass :: B.ByteString, nameType :: NameType Method}
  73   | CString B.ByteString
  74   | CInteger Word32
  75   | CFloat Float
  76   | CLong Integer
  77   | CDouble Double
  78   | CNameType B.ByteString B.ByteString
  79   | CUTF8 {getString :: B.ByteString}
  80   | CUnicode {getString :: B.ByteString}
  81   deriving (Eq)
  82
  83 className ::  Constant -> B.ByteString
  84 className (CClass s) = s
  85 className x = error $ "Not a class: " ++ show x
  86
  87 instance Show Constant where
  88   show (CClass name) = "class " ++ toString name
  89   show (CField cls nt) = "field " ++ toString cls ++ "." ++ show nt
  90   show (CMethod cls nt) = "method " ++ toString cls ++ "." ++ show nt
  91   show (CIfaceMethod cls nt) = "interface method " ++ toString cls ++ "." ++ show nt
  92   show (CString s) = "String \"" ++ toString s ++ "\""
  93   show (CInteger x) = show x
  94   show (CFloat x) = show x
  95   show (CLong x) = show x
  96   show (CDouble x) = show x
  97   show (CNameType name tp) = toString name ++ ": " ++ toString tp
  98   show (CUTF8 s) = "UTF8 \"" ++ toString s ++ "\""
  99   show (CUnicode s) = "Unicode \"" ++ toString s ++ "\""
 100
 101 -- | Class field
 102 data Field = Field {
 103   fieldAccess :: Access,
 104   fieldName :: B.ByteString,
 105   fieldSignature :: FieldSignature,
 106   fieldAttrs :: Attributes }
 107   deriving (Eq, Show)
 108
 109 instance HasSignature Field where
 110   type Signature Field = FieldSignature
 111
 112 instance HasAttributes Field where
 113   attributes = fieldAttrs
 114
 115 -- | Class method
 116 data Method = Method {
 117   methodAccess :: Access,
 118   methodName :: B.ByteString,
 119   methodSignature :: MethodSignature,
 120   methodAttrs :: Attributes }
 121   deriving (Eq, Show)
 122
 123 instance HasSignature Method where
 124   type Signature Method = MethodSignature
 125
 126 instance HasAttributes Method where
 127   attributes = methodAttrs
 128
 129 -- | Set of access flags
 130 type Access = S.Set AccessFlag
 131
 132 -- | Access flags. Used for classess, methods, variables.
 133 data AccessFlag =
 134     ACC_PUBLIC       -- ^ 0x0001 Visible for all
 135   | ACC_PRIVATE            -- ^ 0x0002 Visible only for defined class
 136   | ACC_PROTECTED        -- ^ 0x0004 Visible only for subclasses
 137   | ACC_STATIC       -- ^ 0x0008 Static method or variable
 138   | ACC_FINAL        -- ^ 0x0010 No further subclassing or assignments
 139   | ACC_SYNCHRONIZED -- ^ 0x0020 Uses monitors
 140   | ACC_VOLATILE           -- ^ 0x0040 Could not be cached
 141   | ACC_TRANSIENT        -- ^ 0x0080
 142   | ACC_NATIVE       -- ^ 0x0100 Implemented in other language
 143   | ACC_INTERFACE        -- ^ 0x0200 Class is interface
 144   | ACC_ABSTRACT           -- ^ 0x0400
 145   deriving (Eq, Show, Ord, Enum)
 146
 147 -- | Generic attribute
 148 data Attribute = Attribute {
 149   attrName :: B.ByteString,
 150   attrValue :: B.ByteString }
 151   deriving (Eq, Show)
 152
 153 -- | Set of attributes
 154 type Attributes = M.Map B.ByteString B.ByteString
 155
 156 instance (Binary (Signature a)) => Binary (NameType a) where
 157   put (NameType n t) = putLazyByteString n >> put t
 158
 159   get = NameType <$> get <*> get
 160
 161 byteString ::  (Binary t) => t -> B.ByteString
 162 byteString x = runPut (put x)
 163