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