Merge pull request #2 from ElaraLang:polysemy

Polysemy-ify everything

h2jvm.cabal

@@ -58,14 +58,16 @@ common warnings
 
 common extensions
   default-extensions:
+    DataKinds
+    GADTs
     NoFieldSelectors
     OverloadedRecordDot
     OverloadedStrings
     TypeFamilies
 
 library
   import:           warnings, extensions
-  ghc-options:      -Werror=incomplete-patterns
+  ghc-options:      -Werror=incomplete-patterns -fplugin=Polysemy.Plugin
 
   -- Modules exported by the library.
   -- cabal-fmt: expand src
@@ -113,13 +115,14 @@ library
 
   -- Other library packages from which modules are imported.
   build-depends:
-    , base           >=4.17.1.0
+    , base             >=4.17.1.0
     , binary
     , bytestring
     , containers
     , generic-lens
-    , lens           >=5.0
-    , mtl
+    , lens             >=5.0
+    , polysemy
+    , polysemy-plugin
     , prettyprinter
     , split
     , text
@@ -160,10 +163,12 @@ test-suite h2jvm-test
 
   -- Test dependencies.
   build-depends:
-    , base            ^>=4.17.1.0
+    , base             ^>=4.17.1.0
     , binary
     , bytestring
     , h2jvm
-    , hedgehog        ^>=1.4
+    , hedgehog         ^>=1.4
     , hspec
     , hspec-hedgehog
+    , polysemy
+    , polysemy-plugin

src/Data/IndexedMap.hs

@@ -6,14 +6,16 @@ Because of the specialised nature, its indexes start at 1, not 0. I would apolog
 -}
 module Data.IndexedMap where
 
-import Control.Lens (Lens', assign, use)
+import Control.Lens (Lens', set, view)
 import Control.Monad (forM_)
-import Control.Monad.State (MonadState, execState)
+
 import Data.IntMap qualified as IM
 import Data.Map qualified as M
 import Data.Vector (Vector)
 import Data.Vector qualified as V
 import GHC.Exts (IsList (..))
+import Polysemy
+import Polysemy.State
 import Prelude hiding (lookup)
 
 data IndexedMap a = IndexedMap !(IM.IntMap a) !(M.Map a Int)
@@ -70,14 +72,14 @@ lookupOrInsert a (IndexedMap m m') = case M.lookup a m' of
     Just i -> (i, IndexedMap m m')
     Nothing -> insert a (IndexedMap m m')
 
-lookupOrInsertM :: (Ord a, MonadState (IndexedMap a) m) => a -> m Int
+lookupOrInsertM :: (Member (State (IndexedMap a)) r, Ord a) => a -> Sem r Int
 lookupOrInsertM = lookupOrInsertMOver id
 
-lookupOrInsertMOver :: (MonadState a m, Ord b) => Lens' a (IndexedMap b) -> b -> m Int
+lookupOrInsertMOver :: (Member (State a) r, Ord b) => Lens' a (IndexedMap b) -> b -> Sem r Int
 lookupOrInsertMOver lens a = do
-    i <- use lens
+    i <- gets (view lens)
     let (idx, new) = lookupOrInsert a i
-    assign lens new
+    modify (set lens new)
     pure idx
 
 isEmpty :: IndexedMap a -> Bool
@@ -127,7 +129,7 @@ instance (Ord a) => IsList (IndexedMap a) where
 -}
 instance (Ord a) => Semigroup (IndexedMap a) where
     l <> r =
-        flip execState empty $ do
+        run $ execState empty $ do
             forM_ (toVector l) lookupOrInsertM
             forM_ (toVector r) lookupOrInsertM
 

src/JVM/Data/Abstract/Builder.hs

@@ -1,11 +1,11 @@
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 -- | Provides a monadic interface for building class files in a high-level format.
 module JVM.Data.Abstract.Builder where
 
-import Control.Monad.State
-import Data.Functor.Identity
 import Data.TypeMergingList qualified as TML
 import JVM.Data.Abstract.ClassFile (ClassFile (..), ClassFileAttribute (BootstrapMethods), methods)
 import JVM.Data.Abstract.ClassFile.AccessFlags (ClassAccessFlag)
@@ -14,46 +14,39 @@ import JVM.Data.Abstract.ClassFile.Method
 import JVM.Data.Abstract.ConstantPool
 import JVM.Data.Abstract.Name
 import JVM.Data.JVMVersion
+import Polysemy
+import Polysemy.State
 
-newtype ClassBuilderT m a = ClassBuilderT (StateT ClassFile m a)
-    deriving newtype (Functor, Applicative, Monad, MonadState ClassFile, MonadTrans)
+data ClassBuilder m a where
+    ModifyClass :: (ClassFile -> ClassFile) -> ClassBuilder m ()
 
-unClassBuilderT :: ClassBuilderT m a -> StateT ClassFile m a
-unClassBuilderT (ClassBuilderT m) = m
+makeSem ''ClassBuilder
 
-type ClassBuilder = ClassBuilderT Identity
+addAccessFlag :: (Member ClassBuilder r) => ClassAccessFlag -> Sem r ()
+addAccessFlag flag = modifyClass (\c -> c{accessFlags = flag : c.accessFlags})
 
-addAccessFlag :: (Monad m) => ClassAccessFlag -> ClassBuilderT m ()
-addAccessFlag flag = modify (\c -> c{accessFlags = flag : c.accessFlags})
+setName :: (Member ClassBuilder r) => QualifiedClassName -> Sem r ()
+setName n = modifyClass (\c -> c{name = n})
 
-setName :: (Monad m) => QualifiedClassName -> ClassBuilderT m ()
-setName n = modify (\c -> c{name = n})
+setVersion :: (Member ClassBuilder r) => JVMVersion -> Sem r ()
+setVersion v = modifyClass (\c -> c{version = v})
 
-setVersion :: (Monad m) => JVMVersion -> ClassBuilderT m ()
-setVersion v = modify (\c -> c{version = v})
+setSuperClass :: (Member ClassBuilder r) => QualifiedClassName -> Sem r ()
+setSuperClass s = modifyClass (\c -> c{superClass = Just s})
 
-setSuperClass :: (Monad m) => QualifiedClassName -> ClassBuilderT m ()
-setSuperClass s = modify (\c -> c{superClass = Just s})
+addInterface :: (Member ClassBuilder r) => QualifiedClassName -> Sem r ()
+addInterface i = modifyClass (\c -> c{interfaces = i : c.interfaces})
 
-addInterface :: (Monad m) => QualifiedClassName -> ClassBuilderT m ()
-addInterface i = modify (\c -> c{interfaces = i : c.interfaces})
+addField :: (Member ClassBuilder r) => ClassFileField -> Sem r ()
+addField f = modifyClass (\c -> c{fields = f : c.fields})
 
-addField :: (Monad m) => ClassFileField -> ClassBuilderT m ()
-addField f = modify (\c -> c{fields = f : c.fields})
+addMethod :: (Member ClassBuilder r) => ClassFileMethod -> Sem r ()
+addMethod m = modifyClass (\c -> c{methods = m : c.methods})
 
-buildAndAddField :: (Monad m) => ClassBuilderT m ClassFileField -> ClassBuilderT m ()
-buildAndAddField f = f >>= addField
+addAttribute :: (Member ClassBuilder r) => ClassFileAttribute -> Sem r ()
+addAttribute a = modifyClass (\c -> c{attributes = c.attributes `TML.snoc` a})
 
-addMethod :: (Monad m) => ClassFileMethod -> ClassBuilderT m ()
-addMethod m = modify (\c -> c{methods = m : c.methods})
-
-buildAndAddMethod :: (Monad m) => ClassBuilderT m ClassFileMethod -> ClassBuilderT m ()
-buildAndAddMethod m = m >>= addMethod
-
-addAttribute :: (Monad m) => ClassFileAttribute -> ClassBuilderT m ()
-addAttribute a = modify (\c -> c{attributes = c.attributes `TML.snoc` a})
-
-addBootstrapMethod :: (Monad m) => BootstrapMethod -> ClassBuilderT m ()
+addBootstrapMethod :: (Member ClassBuilder r) => BootstrapMethod -> Sem r ()
 addBootstrapMethod b = addAttribute (BootstrapMethods [b])
 
 dummyClass :: QualifiedClassName -> JVMVersion -> ClassFile
@@ -69,10 +62,12 @@ dummyClass name version =
         , attributes = mempty
         }
 
-runClassBuilderT :: (Monad m) => QualifiedClassName -> JVMVersion -> ClassBuilderT m a -> m (a, ClassFile)
-runClassBuilderT n v m =
-    runStateT (unClassBuilderT m) (dummyClass n v)
+classBuilderToState :: (Member (State ClassFile) r) => Sem (ClassBuilder ': r) a -> Sem r a
+classBuilderToState = interpret $ \case
+    ModifyClass f -> modify f
 
-runClassBuilder :: QualifiedClassName -> JVMVersion -> ClassBuilder a -> (a, ClassFile)
-runClassBuilder n v m =
-    runIdentity $ runClassBuilderT n v m
+runClassBuilder :: QualifiedClassName -> JVMVersion -> Sem (ClassBuilder : r) a -> Sem r (ClassFile, a)
+runClassBuilder n v =
+    runState (dummyClass n v)
+        . classBuilderToState
+        . raiseUnder

src/JVM/Data/Abstract/Builder/Code.hs

@@ -1,23 +1,23 @@
-module JVM.Data.Abstract.Builder.Code (CodeBuilderT (..), unCodeBuilderT, runCodeBuilderT, runCodeBuilderT', CodeBuilder, newLabel, emit, emit', runCodeBuilder, runCodeBuilder', addCodeAttribute, appendStackMapFrame, getCode) where
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module JVM.Data.Abstract.Builder.Code where
 
-import Control.Monad.Identity
-import Control.Monad.State
 import Data.TypeMergingList (TypeMergingList)
 import Data.TypeMergingList qualified as TML
 import JVM.Data.Abstract.Builder.Label
 import JVM.Data.Abstract.ClassFile.Method hiding (code)
 import JVM.Data.Abstract.Instruction
+import Polysemy
+import Polysemy.State
 
-newtype CodeBuilderT m a = CodeBuilder (StateT CodeState m a)
-    deriving (Functor, Applicative, Monad, MonadState CodeState)
-
-unCodeBuilderT :: CodeBuilderT m a -> StateT CodeState m a
-unCodeBuilderT (CodeBuilder m) = m
+data CodeBuilder m a where
+    AddCodeAttribute :: CodeAttribute -> CodeBuilder m ()
+    NewLabel :: CodeBuilder m Label
+    Emit' :: [Instruction] -> CodeBuilder m ()
+    GetCode :: CodeBuilder m [Instruction]
 
-instance MonadTrans CodeBuilderT where
-    lift = CodeBuilder . lift
-
-type CodeBuilder = CodeBuilderT Identity
+makeSem ''CodeBuilder
 
 data CodeState = CodeState
     { labelSource :: [Label]
@@ -28,51 +28,34 @@ data CodeState = CodeState
 initialCodeState :: CodeState
 initialCodeState = CodeState{labelSource = MkLabel <$> [0 ..], attributes = mempty, code = []}
 
-newLabel :: CodeBuilder Label
-newLabel = do
-    s@CodeState{labelSource = ls} <- get
-    case ls of
-        [] -> error "No more labels"
-        l : ls' -> do
-            put (s{labelSource = ls'})
-            pure l
-
-emit :: (Monad m) => Instruction -> CodeBuilderT m ()
-emit i = emit' [i]
-
-emit' :: (Monad m) => [Instruction] -> CodeBuilderT m ()
-emit' is = do
-    modify (\s -> s{code = reverse is <> s.code})
-
-addCodeAttribute :: (Monad m) => CodeAttribute -> CodeBuilderT m ()
-addCodeAttribute ca = do
-    s@CodeState{attributes = attrs} <- get
-    put (s{attributes = attrs `TML.snoc` ca})
-    pure ()
-
-appendStackMapFrame :: (Monad m) => StackMapFrame -> CodeBuilderT m ()
-appendStackMapFrame f = addCodeAttribute (StackMapTable [f])
-
-getCode :: (Monad m) => CodeBuilderT m [Instruction]
-getCode = gets (.code)
-
-rr :: (a, CodeState) -> (a, [CodeAttribute], [Instruction])
-rr (a, s) =
-    ( a
-    , TML.toList s.attributes
-    , reverse s.code
-    )
-
 -- snoc list
 
-runCodeBuilder :: CodeBuilder a -> ([CodeAttribute], [Instruction])
-runCodeBuilder = (\(_, b, c) -> (b, c)) . runCodeBuilder'
-
-runCodeBuilderT :: (Monad m) => CodeBuilderT m a -> m (a, [CodeAttribute], [Instruction])
-runCodeBuilderT = fmap rr . flip runStateT initialCodeState . unCodeBuilderT
-
-runCodeBuilder' :: CodeBuilder a -> (a, [CodeAttribute], [Instruction])
-runCodeBuilder' = rr . runIdentity . flip runStateT initialCodeState . unCodeBuilderT
-
-runCodeBuilderT' :: (Monad m) => CodeBuilderT m a -> m (a, [CodeAttribute], [Instruction])
-runCodeBuilderT' = fmap rr . flip runStateT initialCodeState . unCodeBuilderT
+emit :: (Member CodeBuilder r) => Instruction -> Sem r ()
+emit = emit' . pure
+
+codeBuilderToState :: (Member (State CodeState) r) => Sem (CodeBuilder ': r) a -> Sem r a
+codeBuilderToState = interpret $ \case
+    AddCodeAttribute ca -> modify (\s -> s{attributes = s.attributes `TML.snoc` ca})
+    NewLabel -> do
+        s@CodeState{labelSource = ls} <- get
+        case ls of
+            [] -> error "No more labels"
+            l : ls' -> do
+                put (s{labelSource = ls'})
+                pure l
+    Emit' is -> modify (\s -> s{code = reverse is <> s.code})
+    -- code is a snoc list (kind of)
+    GetCode -> gets (.code)
+
+runCodeBuilder :: forall r a. Sem (CodeBuilder ': r) a -> Sem r (a, [CodeAttribute], [Instruction])
+runCodeBuilder =
+    fmap rr
+        . runState initialCodeState
+        . codeBuilderToState
+        . raiseUnder
+  where
+    rr (s, a) =
+        ( a
+        , TML.toList s.attributes
+        , reverse s.code
+        )

src/JVM/Data/Convert.hs

@@ -17,16 +17,17 @@ import JVM.Data.Convert.AccessFlag (accessFlagsToWord16)
 import JVM.Data.Convert.ConstantPool
 import JVM.Data.Convert.Field (convertField)
 import JVM.Data.Convert.Method (convertMethod)
-import JVM.Data.Convert.Monad (CodeConverterError, ConvertM, runConvertM)
+import JVM.Data.Convert.Monad
 import JVM.Data.JVMVersion (getMajor, getMinor)
 import JVM.Data.Raw.ClassFile (Attribute (BootstrapMethodsAttribute))
 import JVM.Data.Raw.ClassFile qualified as Raw
 import JVM.Data.Raw.MagicNumbers qualified as MagicNumbers
+import Polysemy
 
 jloName :: QualifiedClassName
 jloName = parseQualifiedClassName "java.lang.Object"
 
-convertClassAttributes :: [Abs.ClassFileAttribute] -> ConvertM [Raw.AttributeInfo]
+convertClassAttributes :: ConvertEff r => [Abs.ClassFileAttribute] -> Sem r [Raw.AttributeInfo]
 convertClassAttributes = traverse convertClassAttribute
   where
     convertClassAttribute (Abs.SourceFile text) = do
@@ -37,7 +38,7 @@ convertClassAttributes = traverse convertClassAttribute
 
 convert :: Abs.ClassFile -> Either CodeConverterError Raw.ClassFile
 convert Abs.ClassFile{..} = do
-    (tempClass, cpState) <- runConvertM $ do
+    (tempClass, cpState) <- run $ runConvertM $ do
         nameIndex <- findIndexOf (CPClassEntry $ ClassInfoType name)
         superIndex <- findIndexOf (CPClassEntry $ ClassInfoType (fromMaybe jloName superClass))
         let flags = accessFlagsToWord16 accessFlags
@@ -60,9 +61,9 @@ convert Abs.ClassFile{..} = do
                 (V.fromList methods')
                 (V.fromList attributes')
 
-    let (bmIndex, finalConstantPool) = runConstantPoolMWith cpState $ do
-            let bootstrapAttr = BootstrapMethodsAttribute (IM.toVector $ cpState.bootstrapMethods)
+    let (bmIndex, finalConstantPool) = run $ runConstantPoolWith cpState $ do
+            let bootstrapAttr = BootstrapMethodsAttribute (IM.toVector  cpState.bootstrapMethods)
             attrNameIndex <- findIndexOf (CPUTF8Entry "BootstrapMethods")
             pure $ Raw.AttributeInfo attrNameIndex bootstrapAttr
 
-    pure $ tempClass{Raw.constantPool = IM.toVector finalConstantPool.constantPool, Raw.attributes = bmIndex `V.cons` (tempClass.attributes)}
+    pure $ tempClass{Raw.constantPool = IM.toVector finalConstantPool.constantPool, Raw.attributes = bmIndex `V.cons` tempClass.attributes}