diff --git a/java-classfile.cabal b/java-classfile.cabal index 20de1a3..19c5bdc 100644 --- a/java-classfile.cabal +++ b/java-classfile.cabal @@ -38,6 +38,8 @@ 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: @@ -50,6 +52,7 @@ library , base >=4.7 && <5 , bytestring , containers + , mtl , pretty-parse , text default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 022edb1..1fa0674 100644 --- a/package.yaml +++ b/package.yaml @@ -39,6 +39,7 @@ library: dependencies: - array - containers + - mtl - pretty-parse - text diff --git a/src/Language/Java/Classfile.hs b/src/Language/Java/Classfile.hs index 7f1c727..32afd59 100644 --- a/src/Language/Java/Classfile.hs +++ b/src/Language/Java/Classfile.hs @@ -17,6 +17,9 @@ 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) @@ -24,13 +27,11 @@ 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) +import Language.Java.Classfile.ConstantPool.References (Class, Utf8) import Language.Java.Classfile.Interfaces (Interfaces) import Language.Java.Classfile.Fields (Fields) import Language.Java.Classfile.Methods (Methods) -import Language.Java.Classfile.Attributes (Attributes) -import Data.Word (Word16) -import Pretty.Serialize (PrettySerialize) +import Language.Java.Classfile.Attributes (Attributes, Attribute) -- | 'Stage'-indexed classfile. It can represent a class, an interface or a module. @@ -43,14 +44,14 @@ data Classfile stage = Classfile , accessFlags :: ClassFlags stage , this :: Class stage , super :: Class stage - , interfaces :: Interfaces - , fields :: Fields - , methods :: Methods - , attributes :: Attributes + , interfaces :: Interfaces stage + , fields :: Fields stage + , methods :: Methods stage + , attributes :: Attributes stage } deriving stock (Generic) -deriving instance (Show (Magic stage), Show (ConstantPool stage), Show (ClassFlags stage), Show (Class stage)) => Show (Classfile stage) +deriving instance (Show (Attribute stage), Show (Utf8 stage), 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)) diff --git a/src/Language/Java/Classfile/Attributes.hs b/src/Language/Java/Classfile/Attributes.hs index 6d3d586..d1c79cb 100644 --- a/src/Language/Java/Classfile/Attributes.hs +++ b/src/Language/Java/Classfile/Attributes.hs @@ -3,28 +3,43 @@ {-# 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 (Utf8Reference) +import Language.Java.Classfile.ConstantPool.References (Utf8) 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. -newtype Attributes = Attributes (Array Word16 Attribute) - deriving stock (Show) - deriving newtype (Extractable, PrettySerialize) +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) -- | Unknown Attribute -data Attribute = Attribute - { name :: Utf8Reference +type Attribute :: Stage -> Type +data family Attribute stage + +data instance Attribute Parse = RawAttribute + { name :: Utf8 Parse , info :: SizedBytes Word32 } deriving stock (Show, Generic) - deriving (Extractable, PrettySerialize) via Generically Attribute + deriving (Extractable, PrettySerialize) via Generically (Attribute Parse) diff --git a/src/Language/Java/Classfile/ConstantPool/Entry.hs b/src/Language/Java/Classfile/ConstantPool/Entry.hs index 8c6e07b..3501e93 100644 --- a/src/Language/Java/Classfile/ConstantPool/Entry.hs +++ b/src/Language/Java/Classfile/ConstantPool/Entry.hs @@ -11,9 +11,10 @@ {-# 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 (ClassReference, NameAndTypeReference, MethodHandleReferenceKind, OpaqueReference, BootstrapMethodIndex, Utf8Reference) +import Language.Java.Classfile.ConstantPool.References (Class, NameAndTypeReference, MethodHandleReferenceKind, OpaqueReference, BootstrapMethodIndex, Utf8) import Data.Int (Int32, Int64) import Data.Word (Word16) import Data.Text (Text) @@ -36,29 +37,29 @@ data Entry -- ^ Constant value for ldc | Double (Word8Tag 6 Double) -- ^ Constant value for ldc - | Class (Word8Tag 7 Utf8Reference) + | Class (Word8Tag 7 (Utf8 Parse)) -- ^ Reference to another class: full name - | String (Word8Tag 8 Utf8Reference) + | String (Word8Tag 8 (Utf8 Parse)) -- ^ Constant value for ldc or ConstantValue attributes. - | FieldRef (Word8Tag 9 (ClassReference, NameAndTypeReference)) + | FieldRef (Word8Tag 9 (Class Parse, NameAndTypeReference)) -- ^ Reference to a field: (containing class, descriptor) - | MethodRef (Word8Tag 10 (ClassReference, NameAndTypeReference)) + | MethodRef (Word8Tag 10 (Class Parse, NameAndTypeReference)) -- ^ Reference to a method: (containing class, descriptor) - | InterfaceMethodRef (Word8Tag 11 (ClassReference, NameAndTypeReference)) + | InterfaceMethodRef (Word8Tag 11 (Class Parse, NameAndTypeReference)) -- ^ Reference to an interface method: (containing class, descriptor) - | NameAndType (Word8Tag 12 (Utf8Reference, Utf8Reference)) + | NameAndType (Word8Tag 12 (Utf8 Parse, Utf8 Parse)) -- ^ Name and Type: (name, type) | MethodHandle (Word8Tag 15 MethodHandleInfo) -- ^ Reference to a Method, but more *dynamic* - | MethodType (Word8Tag 16 Utf8Reference) + | MethodType (Word8Tag 16 (Utf8 Parse)) -- ^ 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 Utf8Reference) + | Module (Word8Tag 19 (Utf8 Parse)) -- ^ Some module description - | Package (Word8Tag 20 Utf8Reference) + | Package (Word8Tag 20 (Utf8 Parse)) -- ^ Some package description deriving stock (Show, Generic) deriving Extractable via Generically Entry diff --git a/src/Language/Java/Classfile/ConstantPool/References.hs b/src/Language/Java/Classfile/ConstantPool/References.hs index 10829b5..63d853b 100644 --- a/src/Language/Java/Classfile/ConstantPool/References.hs +++ b/src/Language/Java/Classfile/ConstantPool/References.hs @@ -8,7 +8,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE DeriveGeneric #-} -module Language.Java.Classfile.ConstantPool.References (Utf8Reference(..), ClassReference(..), NameAndTypeReference(..), MethodHandleReferenceKind(..), OpaqueReference(..), BootstrapMethodIndex(..), Class) where +module Language.Java.Classfile.ConstantPool.References (Utf8(..), Class(..), NameAndTypeReference(..), MethodHandleReferenceKind(..), OpaqueReference(..), BootstrapMethodIndex(..), ) where import Data.Word (Word16, Word8) import Language.Java.Classfile.Extractable (Extractable) import Language.Java.Classfile.Extractable.AsTag @@ -20,23 +20,25 @@ import GHC.Generics (Generically(..), Generic) -- | Wrapper for constant-pool reference to text. -newtype Utf8Reference = Utf8Reference Word16 +type Utf8 :: Stage -> Type +data family Utf8 stage + +newtype instance Utf8 Parse = Utf8Reference Word16 deriving stock (Show, Generic) deriving newtype Extractable - deriving PrettySerialize via Generically Utf8Reference + deriving PrettySerialize via Generically (Utf8 Parse) -- | 'Stage'-indexed type, either a Class or only a t'ClassReference'. type Class :: Stage -> Type -type family Class stage where - Class Parse = ClassReference +data family Class stage -- | Reference to a class in a constant-pool. This will resolve into a class. -newtype ClassReference = ClassReference Word16 +newtype instance Class Parse = ClassReference Word16 deriving stock (Show, Generic) deriving newtype Extractable - deriving PrettySerialize via Generically ClassReference + deriving PrettySerialize via Generically (Class Parse) -- | Reference to a class in a constant-pool. This will resolve to Name and Type. diff --git a/src/Language/Java/Classfile/Fields.hs b/src/Language/Java/Classfile/Fields.hs index 79af340..3d6f710 100644 --- a/src/Language/Java/Classfile/Fields.hs +++ b/src/Language/Java/Classfile/Fields.hs @@ -6,21 +6,32 @@ {-# 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 (Utf8Reference) +import Language.Java.Classfile.ConstantPool.References (Utf8) 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. -newtype Fields = Fields (Array Word16 Field) - deriving stock Show - deriving newtype (Extractable, PrettySerialize) +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) -- | All the access flags a field can have @@ -53,11 +64,15 @@ instance FlagMask FieldFlag where -- | A singular field of a class. -data Field = Field +type Field :: Stage -> Type +data Field stage = Field { flags :: Flags FieldFlag - , name :: Utf8Reference - , descriptor :: Utf8Reference - , attribute :: Attributes + , name :: Utf8 stage + , descriptor :: Utf8 stage + , attribute :: Attributes stage } - deriving stock (Show, Generic) - deriving (Extractable, PrettySerialize) via Generically Field + 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) diff --git a/src/Language/Java/Classfile/Interfaces.hs b/src/Language/Java/Classfile/Interfaces.hs index f1af737..e545bbe 100644 --- a/src/Language/Java/Classfile/Interfaces.hs +++ b/src/Language/Java/Classfile/Interfaces.hs @@ -2,16 +2,28 @@ {-# 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 (ClassReference) +import Language.Java.Classfile.ConstantPool.References (Class) 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. -newtype Interfaces = Interfaces (Array Word16 ClassReference) - deriving stock (Show, Generic) - deriving (Extractable, PrettySerialize) via Generically Interfaces +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) diff --git a/src/Language/Java/Classfile/Methods.hs b/src/Language/Java/Classfile/Methods.hs index fe6970f..2bae462 100644 --- a/src/Language/Java/Classfile/Methods.hs +++ b/src/Language/Java/Classfile/Methods.hs @@ -6,32 +6,46 @@ {-# 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 (Utf8Reference) +import Language.Java.Classfile.ConstantPool.References (Utf8) 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 = Methods (Array Word16 Method) - deriving stock (Show) - deriving newtype (Extractable, PrettySerialize) +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) -- | A single method record, contains attributes, name and access flags. -data Method = Method +type Method :: Stage -> Type +data Method stage = Method { flags :: Flags MethodFlag - , name :: Utf8Reference - , descriptor :: Utf8Reference - , attributes :: Attributes + , name :: Utf8 stage + , descriptor :: Utf8 stage + , attributes :: Attributes stage } - deriving stock (Show, Generic) - deriving (Extractable, PrettySerialize) via Generically Method + 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) -- | Flags for the method, such as abstract, public or static. diff --git a/src/Language/Java/Classfile/Resolvable.hs b/src/Language/Java/Classfile/Resolvable.hs new file mode 100644 index 0000000..e6eba2a --- /dev/null +++ b/src/Language/Java/Classfile/Resolvable.hs @@ -0,0 +1,103 @@ +{-# 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 "" $ 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 + diff --git a/src/Language/Java/Classfile/Resolver.hs b/src/Language/Java/Classfile/Resolver.hs new file mode 100644 index 0000000..d1698c9 --- /dev/null +++ b/src/Language/Java/Classfile/Resolver.hs @@ -0,0 +1,59 @@ +{-# 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