feat: partial classfile staging

app/Main.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
 module Main (main) where
 
 import Data.ByteString.Lazy qualified as ByteString
@@ -7,8 +8,9 @@ import Data.ByteString.Lazy qualified as ByteString
 import Language.Java.Classfile (Classfile)
 import Language.Java.Classfile.Extract (runExtract)
 import Language.Java.Classfile.Extractable (extract)
+import Language.Java.Classfile.Stage (Stage(Parse))
 
 main :: IO ()
 main = do
   input <- ByteString.getContents
-  print $ runExtract input (extract @Classfile)
+  print $ runExtract input (extract @(Classfile Parse))

java-classfile.cabal

@@ -35,6 +35,7 @@ library
       Language.Java.Classfile.ConstantPool.References
       Language.Java.Classfile.Extract
       Language.Java.Classfile.Extractable
+      Language.Java.Classfile.Extractable.AsTag
       Language.Java.Classfile.Extractable.SizedBytes
       Language.Java.Classfile.Extractable.WithTag
       Language.Java.Classfile.Fields
@@ -44,6 +45,7 @@ library
       Language.Java.Classfile.Interfaces
       Language.Java.Classfile.Magic
       Language.Java.Classfile.Methods
+      Language.Java.Classfile.Stage
       Language.Java.Classfile.Version
   other-modules:
       Paths_java_classfile

src/Language/Java/Classfile.hs

@@ -1,9 +1,19 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies #-}
 module Language.Java.Classfile (Classfile(..)) where
 
 import GHC.Generics (Generic, Generically(Generically))
 
+import Data.Kind (Type)
+
+import Language.Java.Classfile.Stage (Stage(Parse))
 import Language.Java.Classfile.Version (Version)
 import Language.Java.Classfile.Magic (Magic)
 import Language.Java.Classfile.Extractable (Extractable)
@@ -17,11 +27,12 @@ import Language.Java.Classfile.Methods (Methods)
 import Language.Java.Classfile.Attributes (Attributes)
 
 
-data Classfile = Classfile
-  { magic        :: Magic
+type Classfile :: Stage -> Type
+data Classfile stage = Classfile
+  { magic        :: Magic stage
   , version      :: Version
-  , constantPool :: ConstantPool
-  , accessFlags  :: Flags ClassFlag
+  , constantPool :: ConstantPool stage
+  , accessFlags  :: ClassFlags stage
   , this         :: ClassReference
   , super        :: ClassReference
   , interfaces   :: Interfaces
@@ -29,5 +40,14 @@ data Classfile = Classfile
   , methods      :: Methods
   , attributes   :: Attributes
   }
+  deriving stock (Generic)
+
+deriving instance (Show (Magic stage), Show (ConstantPool stage), Show (ClassFlags stage)) => Show (Classfile stage)
+deriving via Generically (Classfile Parse) instance (Extractable (Classfile Parse))
+
+type ClassFlags :: Stage -> Type
+data family ClassFlags stage
+
+newtype instance ClassFlags Parse = ClassFlags (Flags ClassFlag)
   deriving stock (Show, Generic)
-  deriving Extractable via Generically Classfile
+  deriving Extractable via Generically (ClassFlags Parse)

src/Language/Java/Classfile/ConstantPool.hs

@@ -2,6 +2,10 @@
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Language.Java.Classfile.ConstantPool (ConstantPool(..)) where
 import Data.Word (Word16)
 import Data.Array.IArray (Array, listArray)
@@ -9,12 +13,19 @@ import Language.Java.Classfile.ConstantPool.Entry (Entry, StorageCount (..), sto
 import Language.Java.Classfile.Extractable (Extractable (extract))
 import Language.Java.Classfile.Extract (Extract, traceIndex, traceType)
 import qualified Data.Text as Text
+import Language.Java.Classfile.Stage (Stage(..))
+import Data.Kind (Type)
 
-newtype ConstantPool = ConstantPool (Array Word16 Entry)
+type ConstantPool :: Stage -> Type
+data family ConstantPool stage
+
+newtype instance ConstantPool Parse = ConstantPool (Array Word16 Entry)
   deriving stock (Show)
 
-instance Extractable ConstantPool where
-  extract :: Extract ConstantPool
+data instance ConstantPool Resolve = NoPool
+
+instance Extractable (ConstantPool Parse) where
+  extract :: Extract (ConstantPool Parse)
   extract = do
     count <- extract @Word16
 

src/Language/Java/Classfile/ConstantPool/References.hs

@@ -1,12 +1,14 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
 module Language.Java.Classfile.ConstantPool.References (Utf8Reference(..), ClassReference(..), NameAndTypeReference(..), MethodHandleReferenceKind(..), OpaqueReference(..), BootstrapMethodIndex(..)) where
-import Data.Word (Word16)
+import Data.Word (Word16, Word8)
 import Language.Java.Classfile.Extractable (Extractable)
-import Language.Java.Classfile.Extractable.WithTag (Word8Tag)
-import GHC.Generics (Generically(..), Generic)
+import Language.Java.Classfile.Extractable.AsTag
+    ( TagValue(..), AsTag, AsTag(..) )
 
 newtype Utf8Reference = Utf8Reference Word16
   deriving stock (Show)
@@ -29,14 +31,28 @@ newtype BootstrapMethodIndex = BootstrapMethodIndex Word16
   deriving newtype Extractable
 
 data MethodHandleReferenceKind
-  = GetField            (Word8Tag 1 ()) -- I kind of want to redo this
-  | GetStatic           (Word8Tag 2 ())
-  | PutField            (Word8Tag 3 ())
-  | PutStatic           (Word8Tag 4 ())
-  | InvokeVirtual       (Word8Tag 5 ())
-  | InvokeStatic        (Word8Tag 6 ())
-  | InvokeSpecial       (Word8Tag 7 ())
-  | NewInvokeSpecial    (Word8Tag 8 ())
-  | InvokeInterface     (Word8Tag 9 ())
-  deriving stock (Show, Generic)
-  deriving Extractable via Generically MethodHandleReferenceKind
+  = GetField
+  | GetStatic
+  | PutField
+  | PutStatic
+  | InvokeVirtual
+  | InvokeStatic
+  | InvokeSpecial
+  | NewInvokeSpecial
+  | InvokeInterface
+  deriving stock (Show, Enum, Bounded)
+  deriving Extractable via AsTag MethodHandleReferenceKind
+
+instance TagValue MethodHandleReferenceKind where
+  type TagType MethodHandleReferenceKind = Word8
+  tagOf :: MethodHandleReferenceKind -> TagType MethodHandleReferenceKind
+  tagOf = \case
+    GetField         -> 1
+    GetStatic        -> 2
+    PutField         -> 3
+    PutStatic        -> 4
+    InvokeVirtual    -> 5
+    InvokeStatic     -> 6
+    InvokeSpecial    -> 7
+    NewInvokeSpecial -> 8
+    InvokeInterface  -> 9

src/Language/Java/Classfile/Extractable/AsTag.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Language.Java.Classfile.Extractable.AsTag (AsTag(..), TagValue(..)) where
+import Data.Kind (Type)
+import Language.Java.Classfile.Extractable (Extractable (extract), expectConstant)
+import Language.Java.Classfile.Extract (Extract)
+import Data.Enum.Util (enumerate)
+import Control.Applicative (asum)
+import Data.Functor (($>))
+import Data.Typeable ( Typeable )
+
+newtype AsTag a = AsTag a
+  deriving Show
+
+instance (Extractable (TagType a), Bounded a, Enum a, Eq (TagType a), Show (TagType a), Typeable (TagType a), TagValue a ) => Extractable (AsTag a) where
+  extract :: Extract (AsTag a)
+  extract = do
+    let expectTag con = expectConstant (tagOf con) $> con
+    let allConstructors = expectTag <$> enumerate @a
+
+    AsTag <$> asum allConstructors
+
+
+class TagValue a where
+  type TagType a :: Type
+  tagOf :: a -> TagType a

src/Language/Java/Classfile/Flags.hs

@@ -5,13 +5,16 @@
 {-# LANGUAGE UndecidableInstances #-}
 module Language.Java.Classfile.Flags (Flags(..)) where
 
-import Data.Set (Set)
-import Language.Java.Classfile.Extractable (Extractable (extract))
-import Language.Java.Classfile.Extract (Extract)
-import Language.Java.Classfile.Flag (FlagMask(..))
-import Data.Enum.Util (enumerate)
-import qualified Data.Set as Set
+
 import Data.Bits (Bits((.&.)))
+import Data.Enum.Util (enumerate)
+import Data.Set (Set)
+
+import qualified Data.Set as Set
+
+import Language.Java.Classfile.Extract (Extract)
+import Language.Java.Classfile.Extractable (Extractable (extract))
+import Language.Java.Classfile.Flag (FlagMask(..))
 
 newtype Flags a = Flags (Set a)
   deriving (Show)

src/Language/Java/Classfile/Magic.hs

@@ -1,19 +1,31 @@
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Language.Java.Classfile.Magic (Magic(..)) where
 import Data.Word (Word32)
 import Language.Java.Classfile.Extractable (Extractable, extract, expectConstant)
 import Language.Java.Classfile.Extract (Extract)
 import Data.Hex (Hex (Hex))
+import Language.Java.Classfile.Stage (Stage(Parse, Resolve))
+import Data.Kind (Type)
 
-newtype Magic = Magic (Hex Word32)
+type Magic :: Stage -> Type
+data family Magic stage
+
+newtype instance Magic Parse   = Magic (Hex Word32)
   deriving Show
 
-instance Extractable Magic where
-  extract :: Extract Magic
+data instance Magic Resolve = Cafebabe
+  deriving Show
+
+instance Extractable (Magic Parse) where
+  extract :: Extract (Magic Parse)
   extract = Magic . Hex <$> expectConstant 0xCAFEBABE
 
 -- >>> :set -XOverloadedLists
 -- >>> import Language.Java.Classfile.Extract (runExtract)
 -- >>> runExtract [0xCA, 0xFE, 0xBA, 0xBE] (Hex <$> (extract :: Extract (Word32)))
--- Just ("",Hex 0xbebafeca)
+-- Right ("",Hex 0xcafebabe)
 

src/Language/Java/Classfile/Stage.hs

@@ -0,0 +1,6 @@
+{-# LANGUAGE DataKinds #-}
+module Language.Java.Classfile.Stage (Stage(..)) where
+
+data Stage
+  = Parse
+  | Resolve

src/Language/Java/Classfile/Version.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 module Language.Java.Classfile.Version (Version(..)) where