feat[resolver]: datatype-generic resolving

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

package.yaml

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

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 "<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
+

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