vegowotenks/java-classfile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Compare commits

base: vegowotenks:fcedb1b057dedf6f5f6ed462acee6f832ffb18ab
Branches Tags
vegowotenks:trunk
..
compare: vegowotenks:500bfa349ea782011b26546d98b1b9888adcb731
Branches Tags
vegowotenks:trunk

No commits in common. "fcedb1b057dedf6f5f6ed462acee6f832ffb18ab" and "500bfa349ea782011b26546d98b1b9888adcb731" have entirely different histories.
fcedb1b057 ... 500bfa349e

11 changed files with 57 additions and 283 deletions
Download patch file Download diff file Expand all files Collapse all files

3
java-classfile.cabal
View file

@ -38,8 +38,6 @@ library
Language.Java.Classfile.Interfaces
Language.Java.Classfile.Magic
Language.Java.Classfile.Methods
Language.Java.Classfile.Resolvable
Language.Java.Classfile.Resolver
Language.Java.Classfile.Stage
Language.Java.Classfile.Version
other-modules:
@ -52,7 +50,6 @@ library
, base >=4.7 && <5
, bytestring
, containers
, mtl
, pretty-parse
, text
default-language: Haskell2010

1
package.yaml
View file

@ -39,7 +39,6 @@ library:
dependencies:
- array
- containers
- mtl
- pretty-parse
- text

19
src/Language/Java/Classfile.hs
View file

@ -17,9 +17,6 @@ module Language.Java.Classfile (Classfile(..)) where
import GHC.Generics (Generic, Generically(Generically))
import Data.Kind (Type)
import Data.Word (Word16)
import Pretty.Serialize (PrettySerialize)
import Language.Java.Classfile.Stage (Stage(Parse))
import Language.Java.Classfile.Version (Version)
@ -27,11 +24,13 @@ import Language.Java.Classfile.Magic (Magic)
import Language.Java.Classfile.Extractable (Extractable)
import Language.Java.Classfile.ConstantPool (ConstantPool)
import Language.Java.Classfile.Flags (Flags, FlagMask (..))
import Language.Java.Classfile.ConstantPool.References (Class, Utf8)
import Language.Java.Classfile.ConstantPool.References (Class)
import Language.Java.Classfile.Interfaces (Interfaces)
import Language.Java.Classfile.Fields (Fields)
import Language.Java.Classfile.Methods (Methods)
import Language.Java.Classfile.Attributes (Attributes, Attribute)
import Language.Java.Classfile.Attributes (Attributes)
import Data.Word (Word16)
import Pretty.Serialize (PrettySerialize)
-- | 'Stage'-indexed classfile. It can represent a class, an interface or a module.
@ -44,14 +43,14 @@ data Classfile stage = Classfile
, accessFlags :: ClassFlags stage
, this :: Class stage
, super :: Class stage
, interfaces :: Interfaces stage
, fields :: Fields stage
, methods :: Methods stage
, attributes :: Attributes stage
, interfaces :: Interfaces
, fields :: Fields
, methods :: Methods
, attributes :: Attributes
}
deriving stock (Generic)
deriving instance (Show (Attribute stage), Show (Utf8 stage), Show (Magic stage), Show (ConstantPool stage), Show (ClassFlags stage), Show (Class stage)) => Show (Classfile stage)
deriving instance (Show (Magic stage), Show (ConstantPool stage), Show (ClassFlags stage), Show (Class stage)) => Show (Classfile stage)
deriving via Generically (Classfile Parse) instance (Extractable (Classfile Parse))
deriving via Generically (Classfile Parse) instance (PrettySerialize (Classfile Parse))

29
src/Language/Java/Classfile/Attributes.hs
View file

@ -3,43 +3,28 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.Java.Classfile.Attributes (Attributes(..), Attribute(..)) where
import Data.Array.IArray (Array)
import Data.Word (Word16, Word32)
import Language.Java.Classfile.Extractable (Extractable)
import Language.Java.Classfile.ConstantPool.References (Utf8)
import Language.Java.Classfile.ConstantPool.References (Utf8Reference)
import Language.Java.Classfile.Extractable.SizedBytes (SizedBytes)
import GHC.Generics ( Generic, Generically(..) )
import Pretty.Serialize (PrettySerialize)
import Language.Java.Classfile.Stage (Stage(Parse))
import Data.Kind (Type)
import Data.Typeable (Typeable)
-- | Generic Attribute array used everywhere.
--
-- Will not respect Attribute location restrictions, does not attempt to parse anything specific.
type Attributes :: Stage -> Type
newtype Attributes stage = Attributes (Array Word16 (Attribute stage))
deriving stock instance Show (Attribute stage) => Show (Attributes stage)
deriving newtype instance (Extractable (Attribute stage), Typeable stage) => Extractable (Attributes stage)
deriving newtype instance (PrettySerialize (Attribute stage), Typeable stage) => PrettySerialize (Attributes stage)
newtype Attributes = Attributes (Array Word16 Attribute)
deriving stock (Show)
deriving newtype (Extractable, PrettySerialize)
-- | Unknown Attribute
type Attribute :: Stage -> Type
data family Attribute stage
data instance Attribute Parse = RawAttribute
{ name :: Utf8 Parse
data Attribute = Attribute
{ name :: Utf8Reference
, info :: SizedBytes Word32
}
deriving stock (Show, Generic)
deriving (Extractable, PrettySerialize) via Generically (Attribute Parse)
deriving (Extractable, PrettySerialize) via Generically Attribute

21
src/Language/Java/Classfile/ConstantPool/Entry.hs
View file

@ -11,10 +11,9 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.Java.Classfile.ConstantPool.Entry (Entry(..), StorageCount(..), storageCount, MethodHandleInfo(..)) where
import GHC.Generics (Generic, Generically(..))
import Language.Java.Classfile.Stage (Stage(Parse))
import Language.Java.Classfile.Extractable (Extractable (extract))
import Language.Java.Classfile.Extractable.WithTag (Word8Tag)
import Language.Java.Classfile.ConstantPool.References (Class, NameAndTypeReference, MethodHandleReferenceKind, OpaqueReference, BootstrapMethodIndex, Utf8)
import Language.Java.Classfile.ConstantPool.References (ClassReference, NameAndTypeReference, MethodHandleReferenceKind, OpaqueReference, BootstrapMethodIndex, Utf8Reference)
import Data.Int (Int32, Int64)
import Data.Word (Word16)
import Data.Text (Text)
@ -37,29 +36,29 @@ data Entry
-- ^ Constant value for ldc
| Double (Word8Tag 6 Double)
-- ^ Constant value for ldc
| Class (Word8Tag 7 (Utf8 Parse))
| Class (Word8Tag 7 Utf8Reference)
-- ^ Reference to another class: full name
| String (Word8Tag 8 (Utf8 Parse))
| String (Word8Tag 8 Utf8Reference)
-- ^ Constant value for ldc or ConstantValue attributes.
| FieldRef (Word8Tag 9 (Class Parse, NameAndTypeReference))
| FieldRef (Word8Tag 9 (ClassReference, NameAndTypeReference))
-- ^ Reference to a field: (containing class, descriptor)
| MethodRef (Word8Tag 10 (Class Parse, NameAndTypeReference))
| MethodRef (Word8Tag 10 (ClassReference, NameAndTypeReference))
-- ^ Reference to a method: (containing class, descriptor)
| InterfaceMethodRef (Word8Tag 11 (Class Parse, NameAndTypeReference))
| InterfaceMethodRef (Word8Tag 11 (ClassReference, NameAndTypeReference))
-- ^ Reference to an interface method: (containing class, descriptor)
| NameAndType (Word8Tag 12 (Utf8 Parse, Utf8 Parse))
| NameAndType (Word8Tag 12 (Utf8Reference, Utf8Reference))
-- ^ Name and Type: (name, type)
| MethodHandle (Word8Tag 15 MethodHandleInfo)
-- ^ Reference to a Method, but more *dynamic*
| MethodType (Word8Tag 16 (Utf8 Parse))
| MethodType (Word8Tag 16 Utf8Reference)
-- ^ Descriptor of a Method
| Dynamic (Word8Tag 17 (BootstrapMethodIndex, NameAndTypeReference))
-- ^ Unspeakable horrors: index into the bootstrapmethod attribute array, NameAndType must refer to a field
| InvokeDynamic (Word8Tag 18 (BootstrapMethodIndex, NameAndTypeReference))
-- ^ Unspeakable horrors: index into the bootstrapmethod attribute array, NameAndType must refer to a method
| Module (Word8Tag 19 (Utf8 Parse))
| Module (Word8Tag 19 Utf8Reference)
-- ^ Some module description
| Package (Word8Tag 20 (Utf8 Parse))
| Package (Word8Tag 20 Utf8Reference)
-- ^ Some package description
deriving stock (Show, Generic)
deriving Extractable via Generically Entry

16
src/Language/Java/Classfile/ConstantPool/References.hs
View file

@ -8,7 +8,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
module Language.Java.Classfile.ConstantPool.References (Utf8(..), Class(..), NameAndTypeReference(..), MethodHandleReferenceKind(..), OpaqueReference(..), BootstrapMethodIndex(..), ) where
module Language.Java.Classfile.ConstantPool.References (Utf8Reference(..), ClassReference(..), NameAndTypeReference(..), MethodHandleReferenceKind(..), OpaqueReference(..), BootstrapMethodIndex(..), Class) where
import Data.Word (Word16, Word8)
import Language.Java.Classfile.Extractable (Extractable)
import Language.Java.Classfile.Extractable.AsTag
@ -20,25 +20,23 @@ import GHC.Generics (Generically(..), Generic)
-- | Wrapper for constant-pool reference to text.
type Utf8 :: Stage -> Type
data family Utf8 stage
newtype instance Utf8 Parse = Utf8Reference Word16
newtype Utf8Reference = Utf8Reference Word16
deriving stock (Show, Generic)
deriving newtype Extractable
deriving PrettySerialize via Generically (Utf8 Parse)
deriving PrettySerialize via Generically Utf8Reference
-- | 'Stage'-indexed type, either a Class or only a t'ClassReference'.
type Class :: Stage -> Type
data family Class stage
type family Class stage where
Class Parse = ClassReference
-- | Reference to a class in a constant-pool. This will resolve into a class.
newtype instance Class Parse = ClassReference Word16
newtype ClassReference = ClassReference Word16
deriving stock (Show, Generic)
deriving newtype Extractable
deriving PrettySerialize via Generically (Class Parse)
deriving PrettySerialize via Generically ClassReference
-- | Reference to a class in a constant-pool. This will resolve to Name and Type.

35
src/Language/Java/Classfile/Fields.hs
View file

@ -6,32 +6,21 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.Java.Classfile.Fields (Fields(..)) where
import Data.Array.IArray (Array)
import Data.Word (Word16)
import Language.Java.Classfile.Extractable (Extractable)
import GHC.Generics ( Generically, Generic, Generically(..) )
import Language.Java.Classfile.Flags (Flags, FlagMask (..))
import Language.Java.Classfile.ConstantPool.References (Utf8)
import Language.Java.Classfile.ConstantPool.References (Utf8Reference)
import Language.Java.Classfile.Attributes (Attributes)
import Pretty.Serialize (PrettySerialize)
import Language.Java.Classfile.Stage (Stage)
import Data.Kind (Type)
import Data.Typeable (Typeable)
-- | Word16-Array of Fields.
type Fields :: Stage -> Type
newtype Fields stage = Fields (Array Word16 (Field stage))
deriving stock instance (Show (Field stage)) => Show (Fields stage)
deriving newtype instance (Typeable stage, Extractable (Utf8 stage), Extractable (Attributes stage)) => Extractable (Fields stage)
deriving newtype instance (Typeable stage, PrettySerialize (Utf8 stage), PrettySerialize (Attributes stage)) => PrettySerialize (Fields stage)
newtype Fields = Fields (Array Word16 Field)
deriving stock Show
deriving newtype (Extractable, PrettySerialize)
-- | All the access flags a field can have
@ -64,15 +53,11 @@ instance FlagMask FieldFlag where
-- | A singular field of a class.
type Field :: Stage -> Type
data Field stage = Field
data Field = Field
{ flags :: Flags FieldFlag
, name :: Utf8 stage
, descriptor :: Utf8 stage
, attribute :: Attributes stage
, name :: Utf8Reference
, descriptor :: Utf8Reference
, attribute :: Attributes
}
deriving stock (Generic)
deriving stock instance (Show (Utf8 stage), Show (Attributes stage)) => Show (Field stage)
deriving via Generically (Field stage) instance (Extractable (Utf8 stage), Extractable (Attributes stage)) => Extractable (Field stage)
deriving via Generically (Field stage) instance (PrettySerialize (Utf8 stage), PrettySerialize (Attributes stage)) => PrettySerialize (Field stage)
deriving stock (Show, Generic)
deriving (Extractable, PrettySerialize) via Generically Field

20
src/Language/Java/Classfile/Interfaces.hs
View file

@ -2,28 +2,16 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE DataKinds #-}
module Language.Java.Classfile.Interfaces (Interfaces(..)) where
import Data.Array.IArray (Array)
import Data.Word (Word16)
import Language.Java.Classfile.ConstantPool.References (Class)
import Language.Java.Classfile.ConstantPool.References (ClassReference)
import Language.Java.Classfile.Extractable (Extractable)
import GHC.Generics ( Generic, Generically, Generically(..) )
import Pretty.Serialize (PrettySerialize)
import Language.Java.Classfile.Stage (Stage)
import Data.Kind (Type)
import Data.Typeable (Typeable)
-- | A list of classes something implements.
type Interfaces :: Stage -> Type
newtype Interfaces stage = Interfaces (Array Word16 (Class stage))
deriving stock (Generic)
deriving stock instance (Show (Class stage)) => Show (Interfaces stage)
deriving via Generically (Interfaces stage) instance (Extractable (Class stage), Typeable stage) => Extractable (Interfaces stage)
deriving via Generically (Interfaces stage) instance (PrettySerialize (Class stage), Typeable stage) => PrettySerialize (Interfaces stage)
newtype Interfaces = Interfaces (Array Word16 ClassReference)
deriving stock (Show, Generic)
deriving (Extractable, PrettySerialize) via Generically Interfaces

34
src/Language/Java/Classfile/Methods.hs
View file

@ -6,46 +6,32 @@
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.Java.Classfile.Methods (Methods(..), Method(..), MethodFlag(..)) where
import Data.Array.IArray (Array)
import Data.Word (Word16)
import Language.Java.Classfile.Flags (Flags, FlagMask (..))
import Language.Java.Classfile.Extractable (Extractable)
import GHC.Generics ( Generically, Generic, Generically(..) )
import Language.Java.Classfile.ConstantPool.References (Utf8)
import Language.Java.Classfile.ConstantPool.References (Utf8Reference)
import Language.Java.Classfile.Attributes (Attributes)
import Pretty.Serialize (PrettySerialize)
import Language.Java.Classfile.Stage (Stage)
import Data.Kind (Type)
import Data.Typeable (Typeable)
-- | Alias for the methods structure from the constant-pool.
newtype Methods stage = Methods (Array Word16 (Method stage))
deriving stock instance (Show (Utf8 stage), Show (Attributes stage)) => Show (Methods stage)
deriving newtype instance (Typeable stage, Extractable (Utf8 stage), Extractable (Attributes stage)) => Extractable (Methods stage)
deriving newtype instance (Typeable stage, PrettySerialize (Utf8 stage), PrettySerialize (Attributes stage)) => PrettySerialize (Methods stage)
newtype Methods = Methods (Array Word16 Method)
deriving stock (Show)
deriving newtype (Extractable, PrettySerialize)
-- | A single method record, contains attributes, name and access flags.
type Method :: Stage -> Type
data Method stage = Method
data Method = Method
{ flags :: Flags MethodFlag
, name :: Utf8 stage
, descriptor :: Utf8 stage
, attributes :: Attributes stage
, name :: Utf8Reference
, descriptor :: Utf8Reference
, attributes :: Attributes
}
deriving stock (Generic)
deriving stock instance (Show (Utf8 stage), Show (Attributes stage)) => Show (Method stage)
deriving via Generically (Method stage) instance (Extractable (Utf8 stage), Extractable (Attributes stage)) => Extractable (Method stage)
deriving via Generically (Method stage) instance (PrettySerialize (Utf8 stage), PrettySerialize (Attributes stage)) => PrettySerialize (Method stage)
deriving stock (Show, Generic)
deriving (Extractable, PrettySerialize) via Generically Method
-- | Flags for the method, such as abstract, public or static.

103
src/Language/Java/Classfile/Resolvable.hs
View file

@ -1,103 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Change a datatype from the parsed representation to the Resolved representation.
module Language.Java.Classfile.Resolvable (Resolver, Resolvable(..), Stageable(..)) where
import Data.Kind (Type)
import Language.Java.Classfile.Resolver (Resolver, enterDatatype, enterConstructor, enterField)
import GHC.Generics (K1 (K1), U1 (U1), (:*:) ((:*:)), (:+:) (..), M1 (M1), Meta(MetaData, MetaCons, MetaSel), Generic, Generically (Generically))
import GHC.TypeLits (symbolVal, KnownSymbol)
import qualified Data.Text as Text
import Data.Proxy (Proxy(Proxy))
import qualified GHC.Generics as Generics
import Language.Java.Classfile.Stage (Stage(Parse, Resolve))
class GenericResolvable a where
type GenericResolved a :: Type -> Type
genericResolve :: a i -> Resolver (GenericResolved a i)
instance (Resolvable c) => GenericResolvable (K1 i c) where
type GenericResolved (K1 i c) = K1 i (Resolved c)
genericResolve :: K1 i c x -> Resolver (GenericResolved (K1 i c) x)
genericResolve (K1 x)= K1 <$> resolve x
instance GenericResolvable U1 where
type GenericResolved U1 = U1
genericResolve :: U1 i -> Resolver (GenericResolved U1 x)
genericResolve U1 = pure U1
instance (GenericResolvable l, GenericResolvable r) => GenericResolvable (l :*: r) where
type GenericResolved (l :*: r) = (GenericResolved l :*: GenericResolved r)
genericResolve :: (:*:) l r x -> Resolver (GenericResolved ((:*:) l r) x)
genericResolve (l :*: r) = do
resolvedL <- genericResolve l
resolvedR <- genericResolve r
pure $ resolvedL :*: resolvedR
instance (GenericResolvable l, GenericResolvable r) => GenericResolvable (l :+: r) where
type GenericResolved (l :+: r) = (GenericResolved l :+: GenericResolved r)
genericResolve :: (:+:) l r i -> Resolver (GenericResolved (l :+: r) i)
genericResolve = \case
L1 left -> L1 <$> genericResolve left
R1 right -> R1 <$> genericResolve right
-- data type meta information
instance (KnownSymbol name, GenericResolvable a) => GenericResolvable (M1 tag (MetaData name module_ package isNewtype) a) where
type GenericResolved (M1 tag (MetaData name module_ package isNewtype) a) = (M1 tag (MetaData name module_ package isNewtype) (GenericResolved a))
genericResolve :: M1 tag (MetaData name module_ package isNewtype) a i -> Resolver (GenericResolved (M1 tag (MetaData name module_ package isNewtype) a) i)
genericResolve (M1 x) = enterDatatype typeName $ M1 <$> genericResolve x
where
typeName = Text.pack . symbolVal $ Proxy @name
-- data constructor meta information
instance (KnownSymbol name, GenericResolvable a) => GenericResolvable (M1 tag (MetaCons name fixity isRecord) a) where
type GenericResolved (M1 tag (MetaCons name fixity isRecord) a) = (M1 tag (MetaCons name fixity isRecord) (GenericResolved a))
genericResolve :: M1 tag (MetaCons name fixity isRecord) a i -> Resolver (GenericResolved (M1 tag (MetaCons name fixity isRecord) a) i)
genericResolve (M1 x) = enterConstructor constructorName $ M1 <$> genericResolve x
where
constructorName = Text.pack . symbolVal $ Proxy @name
-- field meta information
instance (KnownSymbol name, GenericResolvable a) => GenericResolvable (M1 tag (MetaSel (Just name) isUnpacked isStrictSource isStrictCompiler) a) where
type GenericResolved (M1 tag (MetaSel (Just name) isUnpacked isStrictSource isStrictCompiler) a) = (M1 tag (MetaSel (Just name) isUnpacked isStrictSource isStrictCompiler) (GenericResolved a))
genericResolve :: M1 tag (MetaSel (Just name) isUnpacked isStrictSource isStrictCompiler) a i -> Resolver (GenericResolved (M1 tag (MetaSel (Just name) isUnpacked isStrictSource isStrictCompiler) a) i)
genericResolve (M1 x) = enterField fieldName $ M1 <$> genericResolve x
where
fieldName = Text.pack . symbolVal $ Proxy @name
instance (GenericResolvable a) => GenericResolvable (M1 tag (MetaSel Nothing isUnpacked isStrictSource isStrictCompiler) a) where
type GenericResolved (M1 tag (MetaSel Nothing isUnpacked isStrictSource isStrictCompiler) a) = (M1 tag (MetaSel Nothing isUnpacked isStrictSource isStrictCompiler) (GenericResolved a))
genericResolve :: M1 tag (MetaSel Nothing isUnpacked isStrictSource isStrictCompiler) a i -> Resolver (GenericResolved (M1 tag (MetaSel Nothing isUnpacked isStrictSource isStrictCompiler) a) i)
genericResolve (M1 x) = enterField "<unknown field>" $ M1 <$> genericResolve x
class Resolvable a where
type Resolved a :: Type
resolve :: a -> Resolver (Resolved a)
type Stageable :: (Stage -> Type) -> Stage -> Type
newtype Stageable a stage = Stageable (a stage)
instance (Generic (a Parse), Generic (a Resolve), GenericResolvable (Generics.Rep (a Parse)), GenericResolved (Generics.Rep (a Parse)) ~ Generics.Rep (a Resolve)) => Resolvable (Stageable a Parse) where
type Resolved (Stageable a Parse) = Stageable a Resolve
resolve :: Stageable a Parse -> Resolver (Resolved (Stageable a Parse))
resolve (Stageable x) = do
resolvedRep <- genericResolve $ Generics.from x
pure . Stageable $ Generics.to resolvedRep

59
src/Language/Java/Classfile/Resolver.hs
View file

@ -1,59 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedRecordDot #-}
-- | Monad for the resolvable computation.
module Language.Java.Classfile.Resolver (Resolver, State(..), Reply(..), runResolver, enterDatatype, enterConstructor, enterField) where
import Language.Java.Classfile.ConstantPool (ConstantPool)
import Language.Java.Classfile.Stage ( Stage(Parse) )
import Data.Text (Text)
-- | Fed to the Resolver Monad
newtype State = State
{ pool :: ConstantPool Parse
}
-- | Produced by the resolver monad
data Reply a = Reply
{ nextState :: State
, result :: a
}
deriving stock (Functor)
newtype Resolver a = Resolver (State -> Reply a)
deriving stock (Functor)
runResolver :: State -> Resolver a -> Reply a
runResolver state (Resolver computeReply) = computeReply state
instance Applicative Resolver where
pure :: a -> Resolver a
pure = Resolver . flip Reply
(<*>) :: Resolver (a -> b) -> Resolver a -> Resolver b
(<*>) (Resolver computeF) (Resolver computeA) = Resolver $ \ input -> let
replyF = computeF input
replyA = computeA replyF.nextState
in Reply replyA.nextState (replyF.result replyA.result)
instance Monad Resolver where
(>>=) :: Resolver a -> (a -> Resolver b) -> Resolver b
(>>=) (Resolver computeA) f = Resolver $ \ input -> let
replyA = computeA input
(Resolver computeB) = f replyA.result
in computeB replyA.nextState
enterDatatype, enterConstructor, enterField :: Text -> Resolver a -> Resolver a
enterDatatype name body = body
enterConstructor name body = body
enterField name body = body