Fix all warnings, GHC 8.0 to 8.4

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

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
 

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 {

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

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,18 +53,23 @@ 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
         (# x, s' #) ->
           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

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