diff --git a/codec-jvm.cabal b/codec-jvm.cabal index 973f7cc..1e8170e 100644 --- a/codec-jvm.cabal +++ b/codec-jvm.cabal @@ -32,6 +32,11 @@ library Codec.JVM.Method Codec.JVM.Opcode Codec.JVM.Types + + -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0 + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + build-depends: base >= 4.6.0.1 && < 5 , binary >= 0.7 && < 0.9 @@ -42,8 +47,10 @@ library , mtl , array , transformers - default-extensions: NamedFieldPuns + if !impl(ghc >= 8) + build-depends: semigroups >= 0.10 && < 0.19 + , fail == 4.9.* executable example hs-source-dirs: example diff --git a/example/Main.hs b/example/Main.hs index c81f8ef..348f94a 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -21,14 +21,14 @@ classFile = mkClassFileWithAttrs java7 [Public, Super] mainClass Nothing [] [] [ mkMethodDef mainClass [Public, Static] "main" [jarray jstring] void $ startLabel loop <> markStackMap - <> emitLineNumber (ln 5) + <> emitLineNumber (ln 5) <> iconst jint 1 <> iconst jint 1 <> iadd <> ifeq (goto loop) mempty <> vreturn ] (const False) - where srcFile = mkSourceFileAttr "Main.hs" + where srcFile = mkSourceFileAttr "Main.hs" loop = mkLabel 1 ln = mkLineNumber diff --git a/src/Codec/JVM/ASM.hs b/src/Codec/JVM/ASM.hs index 27edbfd..b26b6cd 100644 --- a/src/Codec/JVM/ASM.hs +++ b/src/Codec/JVM/ASM.hs @@ -6,30 +6,34 @@ -- -- @ -- {-# LANGUAGE OverloadedStrings #-} --- import Data.Binary.Put (runPut) --- import Data.Foldable (fold) --- import qualified Data.ByteString.Lazy as BS +-- module Main where -- --- import Codec.JVM.ASM (mkClassFile, mkMethodDef) --- import Codec.JVM.ASM.Code --- import Codec.JVM.Class (ClassFile, putClassFile) --- import Codec.JVM.Method (AccessFlag(..)) --- import Codec.JVM.Types +-- import Codec.JVM +-- import Codec.JVM.ASM.Code.Instr +-- import Codec.JVM.ConstPool +-- import Data.Monoid((<>)) -- --- mainClass :: ClassFile --- mainClass = mkClassFile java8 [] "HelloWorld" Nothing --- [ mkMethodDef [Public, Static] "main" [arr.obj $ "java/lang/String"] void $ fold --- [ getstatic systemOut --- , bipush jint 42 --- , invokevirtual printlnI --- , vreturn ] --- ] --- where --- systemOut = mkFieldRef "java/lang/System" "out" (obj "java/io/PrintStream") --- printlnI = mkMethodRef "java/io/PrintStream" "println" [prim JInt] void +-- import Data.Text (Text) +-- import qualified Data.ByteString as BS -- -- main :: IO () --- main = BS.writeFile "HelloWorld.class" $ runPut . putClassFile $ mainClass +-- main = BS.writeFile "HelloWorld.class" $ classFileBS classFile +-- +-- mainClass :: Text +-- mainClass = "HelloWorld" +-- +-- classFile :: ClassFile +-- classFile = mkClassFileWithAttrs java8 [Public, Super] mainClass Nothing [] [] [srcFile] +-- [ +-- mkMethodDef mainClass [Public, Static] "main" [jarray jstring] void $ +-- getstatic systemOut +-- <> bipush jint 42 +-- <> invokevirtual printlnI +-- <> vreturn +-- ] (const False) +-- where srcFile = mkSourceFileAttr "Main.hs" +-- systemOut = mkFieldRef "java/lang/System" "out" (obj "java/io/PrintStream") +-- printlnI = mkMethodRef "java/io/PrintStream" "println" [prim JInt] void -- @ -- module Codec.JVM.ASM where @@ -62,7 +66,7 @@ mkClassFile :: Version -> [MethodDef] -> ClassFile mkClassFile v afs tc' sc' is' fds mds = mkClassFileWithAttrs v afs tc' sc' is' fds [] mds (const False) - + mkClassFileWithAttrs :: Version -> [AccessFlag] -> Text -- class name @@ -92,12 +96,12 @@ mkClassFileWithAttrs v afs tc' sc' is' fds attrs' mds f = acs = concatMap unpackAttr attrs'' attrs = Map.fromList . map (\attr -> (attrName attr, attr)) $ attrs'' cs = cs'' ++ cs' ++ acs - mis = f <$> mds where - f (MethodDef afs' n' (MethodDesc d) code ats) = + mis = f' <$> mds where + f' (MethodDef afs' n' (MethodDesc d) code ats) = MethodInfo (Set.fromList afs') n' (Desc d) code ats - fis = f <$> fds where - f (FieldDef afs' n' (FieldDesc d)) = + fis = f' <$> fds where + f' (FieldDef afs' n' (FieldDesc d)) = FieldInfo (Set.fromList afs') n' (Desc d) [] data MethodDef = MethodDef { diff --git a/src/Codec/JVM/ASM/Code.hs b/src/Codec/JVM/ASM/Code.hs index d859038..b97c996 100644 --- a/src/Codec/JVM/ASM/Code.hs +++ b/src/Codec/JVM/ASM/Code.hs @@ -5,7 +5,7 @@ import Control.Monad.Reader import Data.Text (Text) import Data.ByteString (ByteString) import Data.Foldable (fold) -import Data.Monoid ((<>)) +import Data.Semigroup import Data.Word (Word8, Word16) import Data.Int (Int32, Int64) @@ -29,19 +29,19 @@ import qualified Data.IntMap.Strict as IntMap import Data.Maybe (maybeToList, catMaybes) +import Prelude + data Code = Code { consts :: [Const] , instr :: Instr } deriving Show -instance Monoid Code where - mempty = Code mempty mempty - mappend (Code cs0 i0) (Code cs1 i1) = Code (mappend cs0 cs1) (mappend i0 i1) - -#if MIN_VERSION_base(4,10,0) instance Semigroup Code where (<>) (Code cs0 i0) (Code cs1 i1) = Code ((<>) cs0 cs1) ((<>) i0 i1) -#endif + +instance Monoid Code where + mempty = Code mempty mempty + mappend = (<>) mkCode :: [Const] -> Instr -> Code mkCode = Code @@ -548,9 +548,9 @@ gldc ft c = mkCode cs $ loadCode gconv :: FieldType -> FieldType -> Code gconv ft1 ft2 | Just opCode <- convOpcode - = mkCode (cs ft2) $ opCode <> mod + = mkCode (cs ft2) $ opCode <> modify | otherwise = mempty - where mod = modifyStack (CF.push ft2 . CF.pop ft1) + where modify = modifyStack (CF.push ft2 . CF.pop ft1) convOpcode = case (ft1, ft2) of (BaseType bt1, BaseType bt2) -> case (bt1, bt2) of diff --git a/src/Codec/JVM/ASM/Code/Instr.hs b/src/Codec/JVM/ASM/Code/Instr.hs index 0291bcf..b178cda 100644 --- a/src/Codec/JVM/ASM/Code/Instr.hs +++ b/src/Codec/JVM/ASM/Code/Instr.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, CPP, UnboxedTuples, RecordWildCards, MultiParamTypeClasses, FlexibleContexts, NamedFieldPuns, MagicHash, OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, CPP, UnboxedTuples, RecordWildCards, MultiParamTypeClasses, FlexibleContexts, NamedFieldPuns, MagicHash #-} module Codec.JVM.ASM.Code.Instr where import Control.Monad.IO.Class +import qualified Control.Monad.Fail as Fail import Control.Monad.State import Control.Monad.Reader import Data.ByteString (ByteString) -import Data.Monoid ((<>)) -import Data.Text (Text) +import Data.Text (Text, pack) import Data.Maybe(fromMaybe) import Data.List(sortBy) import Data.Int(Int32) import Data.Ord(comparing) +import Data.Semigroup + import GHC.Base import qualified Data.ByteString as BS @@ -29,6 +31,8 @@ import qualified Codec.JVM.ASM.Code.CtrlFlow as CF import qualified Codec.JVM.ConstPool as CP import qualified Codec.JVM.Opcode as OP +import Prelude + data InstrState = InstrState { isByteCode :: !ByteString , isStackMapTable :: StackMapTable @@ -49,11 +53,11 @@ instance Functor InstrM where fmap = liftM instance Applicative InstrM where - pure = return + pure x = InstrM $ \_ s -> (# x, s #) (<*>) = ap instance Monad InstrM where - return x = InstrM $ \_ s -> (# x, s #) + return = pure (InstrM m) >>= f = InstrM $ \e s -> case m e s of @@ -61,6 +65,11 @@ instance Monad InstrM where case runInstrM (f x) e s' of (# x', s'' #) -> (# x', s'' #) + fail = Fail.fail + +instance Fail.MonadFail InstrM where + fail = error + instance MonadIO InstrM where liftIO (IO io) = InstrM $ \_ s -> case io realWorld# of @@ -74,18 +83,14 @@ instance MonadReader ConstPool InstrM where ask = InstrM $ \e s -> (# e, s #) local f (InstrM m) = InstrM $ \e s -> m (f e) s -instance Monoid Instr where - mempty = Instr $ return () - mappend (Instr rws0) (Instr rws1) = Instr $ do - rws0 - rws1 - -#if MIN_VERSION_base(4,10,0) instance Semigroup Instr where (<>) (Instr rws0) (Instr rws1) = Instr $ do rws0 rws1 -#endif + +instance Monoid Instr where + mempty = Instr $ return () + mappend = (<>) instance Show Instr where show _ = "Instructions" @@ -478,11 +483,11 @@ updateRunAgain = (||) toETEs :: ExceptionTable -> LabelTable -> [ExceptionTableEntry] toETEs et lt = - map (\(start, end, handler, const) -> + map (\(start, end, handler, constant) -> ExceptionTableEntry { eteStartPc = unOffset $ lookupLT start lt , eteEndPc = unOffset $ lookupLT end lt , eteHandlerPc = unOffset $ lookupLT handler lt - , eteCatchType = fmap (CClass . IClassName) const }) + , eteCatchType = fmap (CClass . IClassName) constant }) $ toListET et data ExceptionTableEntry @@ -549,7 +554,7 @@ synchronized (storeCode, loadCode, throwCode, monEnter, monExit) syncCode = Inst resetLastBranch $ fromMaybe lb (selectLatestLB mtryLB mfinallyLB) throwable :: Text -throwable = "java/lang/Throwable" +throwable = pack "java/lang/Throwable" jthrowable :: FieldType jthrowable = T.obj throwable diff --git a/src/Codec/JVM/ASM/Code/Types.hs b/src/Codec/JVM/ASM/Code/Types.hs index a45a8ae..952ac76 100644 --- a/src/Codec/JVM/ASM/Code/Types.hs +++ b/src/Codec/JVM/ASM/Code/Types.hs @@ -3,10 +3,13 @@ module Codec.JVM.ASM.Code.Types where import Codec.JVM.ASM.Code.CtrlFlow (CtrlFlow) +import Data.Semigroup import Data.Text (Text) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap +import Prelude + newtype Label = Label Int deriving Show @@ -23,17 +26,14 @@ newtype StackMapTable = StackMapTable (IntMap CtrlFlow) union' :: IntMap a -> IntMap a -> IntMap a union' = IntMap.unionWith (flip const) --- TODO: Implement a strict fold for mconcat -instance Monoid StackMapTable where - mempty = StackMapTable mempty - mappend (StackMapTable x) (StackMapTable y) - = StackMapTable $ union' x y - -#if MIN_VERSION_base(4,10,0) instance Semigroup StackMapTable where (<>) (StackMapTable x) (StackMapTable y) = StackMapTable $ union' x y -#endif + +-- TODO: Implement a strict fold for mconcat +instance Monoid StackMapTable where + mempty = StackMapTable mempty + mappend = (<>) insertSMT :: Int -> CtrlFlow -> StackMapTable -> StackMapTable insertSMT k v (StackMapTable sm) = StackMapTable $ IntMap.insert k v sm @@ -47,16 +47,13 @@ mkLineNumber = LineNumber newtype LineNumberTable = LineNumberTable (IntMap LineNumber) deriving (Show, Eq) -instance Monoid LineNumberTable where - mempty = LineNumberTable mempty - mappend (LineNumberTable x) (LineNumberTable y) - = LineNumberTable $ union' x y - -#if MIN_VERSION_base(4,10,0) instance Semigroup LineNumberTable where (<>) (LineNumberTable x) (LineNumberTable y) = LineNumberTable $ union' x y -#endif + +instance Monoid LineNumberTable where + mempty = LineNumberTable mempty + mappend = (<>) toListLNT :: LineNumberTable -> [(Offset,LineNumber)] toListLNT (LineNumberTable m) = map (\(off,ln) -> (Offset off,ln)) $ IntMap.assocs m @@ -68,16 +65,13 @@ insertLNT (Offset off) ln (LineNumberTable lnt) = newtype LabelTable = LabelTable { unLabelTable :: IntMap Offset } deriving Show -instance Monoid LabelTable where - mempty = LabelTable mempty - mappend (LabelTable x) (LabelTable y) - = LabelTable $ union' x y - -#if MIN_VERSION_base(4,10,0) instance Semigroup LabelTable where (<>) (LabelTable x) (LabelTable y) = LabelTable $ union' x y -#endif + +instance Monoid LabelTable where + mempty = LabelTable mempty + mappend = (<>) toLT :: [(Label, Offset)] -> LabelTable toLT labels = LabelTable $ IntMap.fromList labels' @@ -118,19 +112,17 @@ foldlStrict f = go newtype ExceptionTable = ExceptionTable [(Label, Label, Label, Maybe Text)] -instance Monoid ExceptionTable where - mempty = ExceptionTable mempty - mappend (ExceptionTable x) (ExceptionTable y) - = ExceptionTable $ x ++ y -#if MIN_VERSION_base(4,10,0) instance Semigroup ExceptionTable where (<>) (ExceptionTable x) (ExceptionTable y) = ExceptionTable $ x ++ y -#endif + +instance Monoid ExceptionTable where + mempty = ExceptionTable mempty + mappend = (<>) insertIntoET :: Label -> Label -> Label -> Maybe Text -> ExceptionTable -> ExceptionTable -insertIntoET start end handler const (ExceptionTable etes) = - ExceptionTable $ (start, end, handler, const) : etes +insertIntoET start end handler constant (ExceptionTable etes) = + ExceptionTable $ (start, end, handler, constant) : etes toListET :: ExceptionTable -> [(Label, Label, Label, Maybe Text)] toListET (ExceptionTable etes) = reverse etes diff --git a/src/Codec/JVM/Attr.hs b/src/Codec/JVM/Attr.hs index 821a77a..9fcec8b 100644 --- a/src/Codec/JVM/Attr.hs +++ b/src/Codec/JVM/Attr.hs @@ -2,7 +2,7 @@ module Codec.JVM.Attr where import Data.Maybe (mapMaybe, fromMaybe) -import Data.Monoid ((<>)) +import Data.Semigroup import Data.Map.Strict (Map) import Data.ByteString (ByteString) import Data.Foldable (traverse_) @@ -30,6 +30,8 @@ import Codec.JVM.Internal import Codec.JVM.Types (PrimType(..), IClassName(..), AccessFlag(..), mkFieldDesc', putAccessFlags, prim) +import Prelude + type ParameterName = Text type MParameter = (ParameterName, S.Set AccessFlag) @@ -214,17 +216,14 @@ newtype InnerClassMap = InnerClassMap (Map Text InnerClass) innerClassElems :: InnerClassMap -> [InnerClass] innerClassElems (InnerClassMap m) = Map.elems m --- Left-biased monoid. Not commutative -instance Monoid InnerClassMap where - mempty = InnerClassMap mempty - mappend (InnerClassMap x) (InnerClassMap y) = - InnerClassMap $ x `Map.union` y - -#if MIN_VERSION_base(4,10,0) +-- Left-biased semigroup. Not commutative instance Semigroup InnerClassMap where (<>) (InnerClassMap x) (InnerClassMap y) = InnerClassMap $ x `Map.union` y -#endif + +instance Monoid InnerClassMap where + mempty = InnerClassMap mempty + mappend = (<>) instance Show Attr where show (AInnerClasses icm) = "AInnerClasses = " ++ show icm diff --git a/src/Codec/JVM/Class.hs b/src/Codec/JVM/Class.hs index 10806a4..1cc6e83 100644 --- a/src/Codec/JVM/Class.hs +++ b/src/Codec/JVM/Class.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns #-} module Codec.JVM.Class where import Data.Binary.Get