Rewrite StackMapTable solver

.gitignore

@@ -21,6 +21,7 @@ cabal.project.local
 cabal.project.local~
 .HTF/
 .ghc.environment.*
+result
 
 .vscode/
 
@@ -29,4 +30,4 @@ cabal.project.local~
 .direnv/
 
 
-.DS_Store
+.DS_Store

README.MD

@@ -5,7 +5,7 @@ It handles the messy details such as jump offsets, stack map frames, and more.
 
 H2JVM does its processing in a pipeline:
 1. The user writes a class as a `JVM.Data.Abstract.ClassFile`, potentially using the `JVM.Data.Abstract.Builder` monads
-2. This class is analysed using code in the `JVM.Data.Analyse` modules - adding stack map frames, calculating jump offsets, etc.
+2. This class is analysed using code in the `JVM.Data.HLAnalyse` modules - calculating jump offsets, etc.
    This stage may also do some optimisations, such as removing dead code.
 3. The class is converted to a low level format (`JVM.Data.Raw`) using the `JVM.Data.Convert` module
 4. The low level format is converted to a `ByteString` using the `JVM.Data.Raw` modules, which can be written to a file. or used in a JVM.

flake.nix

@@ -38,12 +38,21 @@
             hlsCheck.enable = false;
           };
 
+          packages = {
+            # fourmolu.source = "0.11.0.0";
+            hedgehog.source = "1.4";
+            tasty-hedgehog.source = "1.4.0.2";
+
+          };
+
           settings = {
             ghcid = {
               separateBinOutput = false;
               check = false;
             };
-
+            fourmolu.check = false;
+            hw-fingertree.check = false;
+            hw-prim.check = false;
           };
         };
 

h2jvm.cabal

@@ -21,7 +21,7 @@ name:            h2jvm
 -- PVP summary:     +-+------- breaking API changes
 --                  | | +----- non-breaking API additions
 --                  | | | +--- code changes with no API change
-version:         0.4.4.2
+version:         0.4.4.3
 
 -- A short (one-line) description of the package.
 synopsis:
@@ -85,7 +85,7 @@ library
     JVM.Data.Abstract.Instruction
     JVM.Data.Abstract.Name
     JVM.Data.Abstract.Type
-    JVM.Data.Analyse.Instruction
+    JVM.Data.Analyse.StackMap
     JVM.Data.Convert
     JVM.Data.Convert.AccessFlag
     JVM.Data.Convert.ConstantPool
@@ -117,6 +117,7 @@ library
     , binary
     , bytestring
     , containers
+    , generic-lens
     , lens           >=5.0
     , mtl
     , prettyprinter
@@ -152,6 +153,7 @@ test-suite h2jvm-test
   -- The entrypoint to the test suite.
   main-is:          Main.hs
   other-modules:
+    Analyse
     Builder
     Convert
     Util

src/Data/IndexedMap.hs

@@ -117,7 +117,7 @@ instance (Ord a) => Ord (IndexedMap a) where
 instance Foldable IndexedMap where
     foldMap f (IndexedMap im _) = foldMap f im
 
-instance Ord a => IsList (IndexedMap a) where
+instance (Ord a) => IsList (IndexedMap a) where
     type Item (IndexedMap a) = a
     fromList = foldr (\a b -> snd $ insert a b) empty
     toList = toList . toVector

src/Data/TypeMergingList.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 {- | A Snoc List type that merges elements of the same constructor using the Semigroup instance.
@@ -16,8 +18,13 @@ Then we can do:
 -}
 module Data.TypeMergingList where
 
+import Control.Lens ((^?))
 import Data.Data
+import Data.Generics.Sum.Constructors
 import Data.List (foldl')
+import Data.Vector (Vector)
+import Data.Vector qualified as V
+import GHC.Generics (Generic)
 import GHC.IsList qualified as L
 
 newtype TypeMergingList a = TypeMergingList [a]
@@ -27,15 +34,23 @@ newtype TypeMergingList a = TypeMergingList [a]
 Instances of this class may assume that the constructors of the two arguments are the same (i.e. @toConstr x == toConstr y@), and
 are permitted to be partial if this is not the case.
 -}
-class Data a => DataMergeable a where
+class (Data a) => DataMergeable a where
     merge :: a -> a -> a
 
-errorDifferentConstructors :: Data a => a -> a -> b
+errorDifferentConstructors :: (Data a) => a -> a -> b
 errorDifferentConstructors x y = error $ "Cannot merge values as they have different data constructors: " <> showConstr (toConstr x) <> " and " <> showConstr (toConstr y)
 
 instance {-# OVERLAPPABLE #-} (Data a, Semigroup a) => DataMergeable a where
     merge = (<>)
 
+getByCtor :: forall ctor s a. (Generic s, AsConstructor ctor s s a a) => TypeMergingList s -> Maybe a
+getByCtor (TypeMergingList xs) = go xs
+  where
+    go [] = Nothing
+    go (x : xs') = case x ^? _Ctor @ctor of
+        Just a -> Just a
+        Nothing -> go xs'
+
 snoc :: (DataMergeable a) => TypeMergingList a -> a -> TypeMergingList a
 snoc xs x = append xs (TypeMergingList [x])
 
@@ -49,12 +64,15 @@ append (TypeMergingList xs) (TypeMergingList ys) = TypeMergingList (go xs ys)
         | toConstr x == toConstr y = (x `merge` y) : go xs' ys'
         | otherwise = y : go (x : xs') ys'
 
-fromList :: DataMergeable a => Data a => [a] -> TypeMergingList a
+fromList :: (DataMergeable a) => (Data a) => [a] -> TypeMergingList a
 fromList = foldl' snoc (TypeMergingList [])
 
 toList :: TypeMergingList a -> [a]
 toList (TypeMergingList xs) = reverse xs -- snoc list to cons list
 
+toVector :: TypeMergingList a -> Vector a
+toVector (TypeMergingList xs) = V.fromList (reverse xs)
+
 instance (DataMergeable a) => Semigroup (TypeMergingList a) where
     (<>) = append
 
@@ -65,3 +83,6 @@ instance (DataMergeable a) => L.IsList (TypeMergingList a) where
     type Item (TypeMergingList a) = a
     fromList = fromList
     toList = toList
+
+instance Foldable TypeMergingList where
+    foldMap f (TypeMergingList xs) = foldMap f xs

src/JVM/Data/Abstract/Builder.hs

@@ -23,37 +23,37 @@ unClassBuilderT (ClassBuilderT m) = m
 
 type ClassBuilder = ClassBuilderT Identity
 
-addAccessFlag :: Monad m => ClassAccessFlag -> ClassBuilderT m ()
+addAccessFlag :: (Monad m) => ClassAccessFlag -> ClassBuilderT m ()
 addAccessFlag flag = modify (\c -> c{accessFlags = flag : c.accessFlags})
 
-setName :: Monad m => QualifiedClassName -> ClassBuilderT m ()
+setName :: (Monad m) => QualifiedClassName -> ClassBuilderT m ()
 setName n = modify (\c -> c{name = n})
 
-setVersion :: Monad m => JVMVersion -> ClassBuilderT m ()
+setVersion :: (Monad m) => JVMVersion -> ClassBuilderT m ()
 setVersion v = modify (\c -> c{version = v})
 
-setSuperClass :: Monad m => QualifiedClassName -> ClassBuilderT m ()
+setSuperClass :: (Monad m) => QualifiedClassName -> ClassBuilderT m ()
 setSuperClass s = modify (\c -> c{superClass = Just s})
 
-addInterface :: Monad m => QualifiedClassName -> ClassBuilderT m ()
+addInterface :: (Monad m) => QualifiedClassName -> ClassBuilderT m ()
 addInterface i = modify (\c -> c{interfaces = i : c.interfaces})
 
-addField :: Monad m => ClassFileField -> ClassBuilderT m ()
+addField :: (Monad m) => ClassFileField -> ClassBuilderT m ()
 addField f = modify (\c -> c{fields = f : c.fields})
 
-buildAndAddField :: Monad m => ClassBuilderT m ClassFileField -> ClassBuilderT m ()
+buildAndAddField :: (Monad m) => ClassBuilderT m ClassFileField -> ClassBuilderT m ()
 buildAndAddField f = f >>= addField
 
-addMethod :: Monad m => ClassFileMethod -> ClassBuilderT m ()
+addMethod :: (Monad m) => ClassFileMethod -> ClassBuilderT m ()
 addMethod m = modify (\c -> c{methods = m : c.methods})
 
-buildAndAddMethod :: Monad m => ClassBuilderT m ClassFileMethod -> ClassBuilderT m ()
+buildAndAddMethod :: (Monad m) => ClassBuilderT m ClassFileMethod -> ClassBuilderT m ()
 buildAndAddMethod m = m >>= addMethod
 
-addAttribute :: Monad m => ClassFileAttribute -> ClassBuilderT m ()
+addAttribute :: (Monad m) => ClassFileAttribute -> ClassBuilderT m ()
 addAttribute a = modify (\c -> c{attributes = c.attributes `TML.snoc` a})
 
-addBootstrapMethod :: Monad m => BootstrapMethod -> ClassBuilderT m ()
+addBootstrapMethod :: (Monad m) => BootstrapMethod -> ClassBuilderT m ()
 addBootstrapMethod b = addAttribute (BootstrapMethods [b])
 
 dummyClass :: QualifiedClassName -> JVMVersion -> ClassFile
@@ -69,7 +69,7 @@ dummyClass name version =
         , attributes = mempty
         }
 
-runClassBuilderT :: Monad m => QualifiedClassName -> JVMVersion -> ClassBuilderT m a -> m (a, ClassFile)
+runClassBuilderT :: (Monad m) => QualifiedClassName -> JVMVersion -> ClassBuilderT m a -> m (a, ClassFile)
 runClassBuilderT n v m =
     runStateT (unClassBuilderT m) (dummyClass n v)
 

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

@@ -37,23 +37,23 @@ newLabel = do
             put (s{labelSource = ls'})
             pure l
 
-emit :: Monad m => Instruction -> CodeBuilderT m ()
+emit :: (Monad m) => Instruction -> CodeBuilderT m ()
 emit i = emit' [i]
 
-emit' :: Monad m => [Instruction] -> CodeBuilderT m ()
+emit' :: (Monad m) => [Instruction] -> CodeBuilderT m ()
 emit' is = do
     modify (\s -> s{code = reverse is <> s.code})
 
-addCodeAttribute :: Monad m => CodeAttribute -> CodeBuilderT m ()
+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 :: (Monad m) => StackMapFrame -> CodeBuilderT m ()
 appendStackMapFrame f = addCodeAttribute (StackMapTable [f])
 
-getCode :: Monad m => CodeBuilderT m [Instruction]
+getCode :: (Monad m) => CodeBuilderT m [Instruction]
 getCode = gets (.code)
 
 rr :: (a, CodeState) -> (a, [CodeAttribute], [Instruction])
@@ -68,11 +68,11 @@ rr (a, s) =
 runCodeBuilder :: CodeBuilder a -> ([CodeAttribute], [Instruction])
 runCodeBuilder = (\(_, b, c) -> (b, c)) . runCodeBuilder'
 
-runCodeBuilderT :: Monad m => CodeBuilderT m a -> m (a, [CodeAttribute], [Instruction])
+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' :: (Monad m) => CodeBuilderT m a -> m (a, [CodeAttribute], [Instruction])
 runCodeBuilderT' = fmap rr . flip runStateT initialCodeState . unCodeBuilderT