Fix GHC warnings

GHC warns when using PartialTypeSignatures, so we just fill in the
inferred signature. It also now warns on the use of head, so we've
replaced those in the instances where we are able, with two (safe) uses
remaining in GenMonad.

Author: Tritlo

src/PropR/Configuration/Materializeable.hs

@@ -3,12 +3,13 @@
 module PropR.Configuration.Materializeable where
 
 import Data.Default
+import Data.Kind (Type)
 
 -- | The materializeable class defines the data we know how to materialize, i.e.
 -- bring from undefined data, and override
 -- TODO: We could definitely derive this
 class Default a => Materializeable a where
-  data Unmaterialized a :: *
+  data Unmaterialized a :: Type
   materialize :: Maybe (Unmaterialized a) -> a
   conjure :: Unmaterialized a
   override :: a -> Maybe (Unmaterialized a) -> a

src/PropR/Eval.hs

@@ -31,7 +31,7 @@ import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (mapConcurrently)
 import Control.Lens (Getting, to, universeOf, universeOn, universeOnOf)
 import Control.Lens.Combinators (Fold)
-import Control.Monad (forM, forM_, unless, void, when, zipWithM_, (>=>))
+import Control.Monad (forM, forM_, unless, void, when, zipWithM_, (>=>), join)
 import qualified GHC.Core.Utils as CoreUtils
 import qualified Data.Bifunctor
 import Data.Bits (complement)
@@ -40,7 +40,7 @@ import Data.Data.Lens (template, tinplate, uniplate)
 import Data.Dynamic (Dynamic, fromDynamic)
 import Data.Function (on)
 import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
-import Data.List (groupBy, intercalate, nub, partition, stripPrefix)
+import Data.List (groupBy, intercalate, nub, partition, stripPrefix, uncons)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (catMaybes, isJust, isNothing, mapMaybe)
@@ -212,7 +212,6 @@ addPreludeIfNotPresent decls =
   where
     isPrelude (IIModule mname) = mname == pRELUDE_NAME
     isPrelude (IIDecl ImportDecl {..}) = unLoc ideclName == pRELUDE_NAME
-    isPrelude _ = False
     prelImport = IIDecl $ simpleImportDecl pRELUDE_NAME
 
 justParseExpr :: CompileConfig -> RExpr -> Ghc (LHsExpr GhcPs)
@@ -585,7 +584,6 @@ moduleToProb baseCC@CompConf {tempDirBase = baseTempDir, ..} mod_path mb_target
                         fh@FunRhs {mc_fun = L l''' _} ->
                           fh {mc_fun = L l''' $ unLoc nfid}
                         o -> o
-                nalt alt = alt
                 nalts = map nalt alts
                 nvpat :: IdP GhcPs -> LPat GhcPs
                 nvpat t_name =
@@ -594,7 +592,6 @@ moduleToProb baseCC@CompConf {tempDirBase = baseTempDir, ..} mod_path mb_target
                       (noLocA $ VarPat noExtField $ noLocA t_name)
                       noHsTok)
                 nvpats = map nvpat $ filter (`Set.member` vars) targets
-            nmatches _ _ mg = mg
 
             wrapProp :: LHsBind GhcPs -> [(LHsBind GhcPs, [Sig GhcPs])]
             wrapProp prop@(L l fb@FunBind {..})
@@ -615,15 +612,11 @@ moduleToProb baseCC@CompConf {tempDirBase = baseTempDir, ..} mod_path mb_target
                     run_i_only mg@MG {mg_alts = (L l' alts)} = mg {mg_alts = L l' $ map nalt alts}
                       where
                         nalt (L l'' m@Match {..}) = L l'' m {m_grhss = n_grhss m_grhss}
-                        nalt m = m
                         n_grhss grhss@GRHSs {..} = grhss {grhssGRHSs = map nGRHSS grhssGRHSs}
-                        n_grhss g = g
                         nGRHSS (L l3 (GRHS x guards bod)) = L l3 (GRHS x guards nbod)
                           where
                             nbod = noLocA $ HsApp noAnn nthapp (noLocA $ HsPar noAnn noHsTok bod noHsTok)
                             nthapp = noLocA $ HsPar noAnn noHsTok (noLocA $ HsApp noAnn (tf "testTreeNthTest") (il $ fromIntegral i)) noHsTok
-                        nGRHSS xg = xg
-                    run_i_only mg = mg
             wrapProp prop@(L l fb@FunBind {..}) =
               [(L l fb {fun_id = nfid, fun_matches = nmatches prop_vars nfid fun_matches}, sig)]
               where
@@ -658,7 +651,6 @@ moduleToProb baseCC@CompConf {tempDirBase = baseTempDir, ..} mod_path mb_target
                     tyApps (ty : tys) = 
                         noLocA $ HsFunTy noAnn arr (noLocA ty) (tyApps tys)
                       where arr = HsUnrestrictedArrow noHsUniTok
-                toWrapSig e = e
             wrapped_props :: [EProp]
             prop_sigs :: [LSig GhcPs]
             (wrapped_props, prop_sigs) =
@@ -805,7 +797,7 @@ traceTarget ::
   EProp ->
   [RExpr] ->
   IO (Maybe TraceRes)
-traceTarget cc tp e fp ce = head <$> traceTargets cc tp e [(fp, ce)]
+traceTarget cc tp e fp ce = (join . fmap fst . uncons) <$> traceTargets cc tp e [(fp, ce)]
 
 toNonZeroInvokes :: Trace -> Map.Map (EExpr, SrcAnn AnnListItem) Integer
 toNonZeroInvokes (ex, res) = Map.fromList $ mapMaybe only_max $ flatten res
@@ -1195,7 +1187,7 @@ getExprFitCands expr_or_mod = do
                 let flat = flattenExpr tcd_context
                     -- We remove the ones already present and drop the first one
                     -- (since it will be the program itself)
-                    flat' = filter nonTriv $ tail flat
+                    flat' = filter nonTriv $ drop 1 flat
                  in toEsAnNames wc flat'
               _ -> []
       liftIO $ logStr TRACE "Getting the session..."

src/PropR/Repair.hs

@@ -36,7 +36,7 @@ import GHC.Tc.Types.Constraint
 import Control.Arrow (first, second, (***))
 import Control.Concurrent (getNumCapabilities, threadDelay, threadWaitRead)
 import Control.Concurrent.Async (mapConcurrently)
-import Control.Monad (forM_, void, when, (>=>), unless)
+import Control.Monad (forM_, void, when, (>=>), unless, join)
 import qualified Data.Bifunctor
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as BSC
@@ -51,7 +51,7 @@ import qualified Data.Functor
 import Data.IORef (IORef, modifyIORef, modifyIORef', newIORef, readIORef, writeIORef)
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
-import Data.List (groupBy, intercalate, nub, nubBy, partition, sort, sortOn, transpose)
+import Data.List (groupBy, intercalate, nub, nubBy, partition, sort, sortOn, transpose, uncons)
 import qualified Data.List as L
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -354,7 +354,7 @@ detranslate _ = error "Cannot detranlsate external problem!"
 -- | Get a list of strings which represent shrunk arguments to the property that
 -- makes it fail.
 propCounterExample :: CompileConfig -> EProblem -> EProp -> IO (Maybe [RExpr])
-propCounterExample cc ep prop = head <$> propCounterExamples (fakeDesc [] cc ep) [prop]
+propCounterExample cc ep prop = (join . fmap fst . uncons) <$> propCounterExamples (fakeDesc [] cc ep) [prop]
 
 -- | Get a list of strings which represent shrunk arguments to the property that
 -- makes it fail.
@@ -643,7 +643,10 @@ generateFixCandidates
             )
             (map ((subexprs Map.!) . fst)  nzh)
             raw_wrapped_fits
-        wrapped_holes = map (first head) wrapped_in_holes
+        wrapped_holes =
+          map (first $ \case (h:_) -> h
+                             [] -> error "generateFixCandidates: No locations in hole!")
+              wrapped_in_holes
     liftIO $ logStr TRACE "Hole fits were:"
     liftIO $ mapM_ (logOut DEBUG) hole_fits
 

src/PropR/Search/Genetic/GenMonad.hs

@@ -235,16 +235,22 @@ runGenMonad' conf desc gen fc action = do
       withGen = ST.runStateT withParams gen
   ST.runStateT withGen fc
 
-liftConf :: R.ReaderT GeneticConfiguration _ a -> GenMonad a
+type CacheM = ST.StateT FitnessCache IO
+type GenM = ST.StateT StdGen CacheM
+type DescM = R.ReaderT ProblemDescription GenM
+type ConfM = R.ReaderT GeneticConfiguration DescM
+
+liftConf :: ConfM a -> GenMonad a
 liftConf = id
 
-liftDesc :: R.ReaderT ProblemDescription _ a -> GenMonad a
+liftDesc :: DescM a -> GenMonad a
 liftDesc = lift
 
-liftGen :: ST.StateT StdGen _ a -> GenMonad a
+liftGen :: GenM a -> GenMonad a
 liftGen = lift . lift
 
-liftCache :: ST.StateT FitnessCache _ a -> GenMonad a
+
+liftCache :: CacheM a -> GenMonad a
 liftCache = lift . lift . lift
 
 -- Some getters and setters for the monad

src/PropR/Search/Genetic/Search.hs

@@ -336,13 +336,13 @@ geneticSearch = collectStats $ do
         sortPopByFitness shuffledIslandPop
       gen <- getGen
       let -- Select the best M species per island
-          migrators = [take (migrationSize iConf) pop | pop <- sortedIslands]
+          migrators@(m:ms) = [take (migrationSize iConf) pop | pop <- sortedIslands]
           -- Drop the worst M species per Island
           receivers = [drop (migrationSize iConf) pop | pop <- sortedIslands]
           -- Rearrange the migrating species either by moving one clockwise, or by shuffling them
           (migrators', gen') =
             if ringwiseMigration iConf
-              then (tail migrators ++ [head migrators], gen)
+              then (ms ++ [m], gen)
               else shuffle migrators gen
           islandMigrationPairs = zip receivers migrators'
           newIslands = map (uncurry (++)) islandMigrationPairs

src/PropR/Search/Genetic/Utils.hs

@@ -89,9 +89,8 @@ pickRandomElements :: (RandomGen g, Eq a) => Int -> g -> [a] -> ([a], g)
 pickRandomElements 0 g _ = ([], g)
 pickRandomElements _ g [] = ([], g)
 pickRandomElements n g as =
-  let (asShuffled, g') = shuffle as g
+  let ((x:_), g') = shuffle as g
       (recursiveResults, g'') = pickRandomElements (n - 1) g' as
-      x = head asShuffled
    in (x : recursiveResults, g'')
 
 -- | Picks a random pair of a given List.

src/PropR/Search/PseudoGenetic/Search.hs

@@ -31,6 +31,8 @@ import PropR.Traversals (replaceExpr)
 import PropR.Types
 import PropR.Util
 
+import qualified Data.List.NonEmpty as NE
+
 -- |
 --   An Individual consists of a "Fix", that is a change to be applied,
 --   and a list of properties they fulfill or fail, expressed as an boolean array.
@@ -165,4 +167,4 @@ deDupOn f as = map snd $ filter ((`Set.member` grouped) . fst) zas
   where
     zas = zip [(0 :: Int) ..] as
     zbs = zip [(0 :: Int) ..] $ map f as
-    grouped = Set.fromList $ map (fst . head) $ groupBy ((==) `on` snd) $ sortOn snd zbs
+    grouped = Set.fromList $ map (fst . NE.head) $ NE.groupBy ((==) `on` snd) $ sortOn snd zbs