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/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