Fix -Wx-partial warnings uncovered by GHC 9.8

crucible-go/src/Lang/Crucible/Go/Types.hs

@@ -24,6 +24,7 @@ import           Control.Monad.State
 
 import           Data.Default.Class
 import           Data.HashMap.Strict as HM
+import qualified Data.Kind as Kind
 import           Data.Maybe (fromJust)
 import           Data.Text (Text)
 
@@ -223,7 +224,7 @@ goExprType :: GoExpr a tp -> TypeRepr tp
 goExprType (GoExpr _loc e) = exprType e
 
 -- | Pair of things with the same type index.
-data PairIx (f :: * -> CrucibleType -> *) s tp where
+data PairIx (f :: Kind.Type -> CrucibleType -> Kind.Type) s tp where
   PairIx :: forall f s tp. f s tp -> f s tp -> PairIx f s tp
 
 -- | Pair of things with the same type index.

crucible-jvm/src/Lang/Crucible/JVM/Overrides.hs

@@ -636,7 +636,13 @@ printStream name showNewline descr t =
                   { C.typedOverrideHandler=
                     \args -> do
                       let reg = C.unRV (Ctx.last args)
-                      str <- showReg @sym (head (J.methodKeyParameterTypes mk)) t reg
+                      let paramTy =
+                            case J.methodKeyParameterTypes mk of
+                              ty:_ -> ty
+                              []   -> panic
+                                        "printStream"
+                                        ["Expected a parameter type, but none found"]
+                      str <- showReg @sym paramTy t reg
                       h   <- C.printHandle <$> C.getContext
                       liftIO $ (if showNewline then hPutStrLn else hPutStr) h str
                       liftIO $ hFlush h

crucible-llvm/src/Lang/Crucible/LLVM/Printf.hs

@@ -47,6 +47,8 @@ import qualified Data.Set as Set
 import           Data.Word
 import qualified GHC.Stack as GHC
 
+import           Lang.Crucible.Panic (panic)
+
 data PrintfFlag
   = PrintfAlternateForm   -- #
   | PrintfZeroPadding     -- 0
@@ -234,7 +236,13 @@ formatOctal
 formatOctal i minwidth prec flags = do
   let digits = N.showOct (abs i) []
   let precdigits = addLeadingZeros prec digits
-  let altdigits = if Set.member PrintfAlternateForm flags && head precdigits /= '0' then
+  let leadingPrecDigit =
+        case precdigits of
+          d:_ -> d
+          [] -> panic
+                  "formatOctal"
+                  ["Octal-formatted number with no digits"]
+  let altdigits = if Set.member PrintfAlternateForm flags && leadingPrecDigit /= '0' then
                      '0':precdigits
                   else
                      precdigits

crucible-mir/src/Mir/Generator.hs

@@ -100,6 +100,7 @@ import qualified Lang.Crucible.CFG.Generator as G
 import qualified Lang.Crucible.CFG.Reg as R
 import qualified Lang.Crucible.CFG.Expr as E
 import qualified Lang.Crucible.CFG.Core as Core
+import qualified Lang.Crucible.Panic as P
 import qualified Lang.Crucible.Syntax as S
 
 
@@ -589,8 +590,15 @@ resolveCustom instDefId = do
 
 freshVarName :: Text -> Map Text a -> Text
 freshVarName base vm =
-    head $ filter (\n -> not $ n `Map.member` vm) $
-        base : [base <> "_" <> Text.pack (show i) | i <- [0 :: Integer ..]]
+  case varNamesInfList of
+    varName:_ -> varName
+    [] -> P.panic
+            "freshVarName"
+            ["Expected infinite list, but list was empty"]
+  where
+    varNamesInfList =
+      filter (\n -> not $ n `Map.member` vm) $
+      base : [base <> "_" <> Text.pack (show i) | i <- [0 :: Integer ..]]
 
 -- Generate a fresh name of the form `_temp123`
 freshTempName :: Map Text a -> Text

crucible-mir/src/Mir/Pass/AllocateEnum.hs

@@ -99,6 +99,6 @@ pcr :: HasCallStack => (?col :: Collection) => BasicBlock -> BasicBlock
 pcr (BasicBlock inf (BasicBlockData stmts term)) = BasicBlock inf (BasicBlockData (go stmts) term) where
    go :: [Statement] -> [Statement]
    go [] = []
-   go s  | Just (s', ss) <- findAllocEnum s = s' : go ss
-         | otherwise = head s : go (tail s)
-
+   go stmtss@(stmt:stmts)
+     | Just (stmt', stmts') <- findAllocEnum stmtss = stmt' : go stmts'
+     | otherwise = stmt : go stmts

crucible-mir/src/Mir/Trans.hs

@@ -1893,7 +1893,9 @@ transVtableShim colState vtableName (VtableItem fnName defName)
         $ \implFn ->
     withMethodHandle fnName (die ["failed to look up implementation", show fnName])
         $ \implFH ->
-    let implMirArg0 = head $ implFn ^. M.fsig . M.fsarg_tys in
+    let implMirArg0 = case implFn ^. M.fsig . M.fsarg_tys of
+                        arg_ty:_ -> arg_ty
+                        [] -> die ["shim has no argument types"] in
     let implArgs = FH.handleArgTypes implFH in
     let implRet = FH.handleReturnType implFH in
 

crux-llvm/src/Crux/LLVM/Compile.hs

@@ -30,6 +30,7 @@ import           System.Process ( readProcessWithExitCode )
 import           What4.Interface
 import           What4.ProgramLoc
 
+import           Lang.Crucible.Panic ( panic )
 import           Lang.Crucible.Simulator.SimError
 
 import           Crux
@@ -124,13 +125,20 @@ genBitCode ::
   Log.SupportsCruxLLVMLogMessage msgs =>
   CruxOptions -> LLVMOptions -> IO FilePath
 genBitCode cruxOpts llvmOpts =
-  -- n.b. use of head here is OK because inputFiles should not be
-  -- empty (and was previously verified as such in CruxLLVMMain).
   if noCompile llvmOpts
-  then return (head (Crux.inputFiles cruxOpts))
+  then return headInputFile
   else do
-    let ofn = "crux~" <> (takeFileName $ head $ Crux.inputFiles cruxOpts) -<.> ".bc"
+    let ofn = "crux~" <> takeFileName headInputFile -<.> ".bc"
     genBitCodeToFile ofn (Crux.inputFiles cruxOpts) cruxOpts llvmOpts False
+  where
+    -- n.b. the use of partiality here is OK because inputFiles should not be
+    -- empty (and was previously verified as such in CruxLLVMMain).
+    headInputFile =
+      case Crux.inputFiles cruxOpts of
+        inputFile:_ -> inputFile
+        [] -> panic
+                "genBitCode"
+                ["Unexpected empty list of files"]
 
 -- | Given the target filename and a list of input files, along with
 -- the crux and llvm options, bitcode-compile each input .c file and

crux-llvm/test/Test.hs

@@ -12,7 +12,7 @@ import           Data.Bifunctor ( first )
 import qualified Data.ByteString.Lazy as BSIO
 import qualified Data.ByteString.Lazy.Char8 as BSC
 import           Data.Char ( isLetter, isSpace )
-import           Data.List.Extra ( isInfixOf, isPrefixOf )
+import           Data.List.Extra ( isInfixOf )
 import           Data.Maybe ( catMaybes, fromMaybe )
 import qualified Data.Text as T
 import           Data.Versions ( Versioning, versioning, prettyV, major )
@@ -32,6 +32,8 @@ import qualified Test.Tasty as TT
 import           Test.Tasty.HUnit ( testCase, assertFailure )
 import qualified Test.Tasty.Sugar as TS
 
+import qualified Lang.Crucible.Panic as P
+
 import qualified CruxLLVMMain as C
 
 
@@ -103,7 +105,7 @@ getClangVersion :: IO VersionCheck
 getClangVersion = do
   -- Determine which version of clang will be used for these tests.
   -- An exception (E.g. in the readProcess if clang is not found) will
-  -- result in termination (test failure).  Uses partial 'head' but
+  -- result in termination (test failure).  Uses partiality, but
   -- this is just tests, and failure is captured.
   clangBin <- fromMaybe "clang" <$> lookupEnv "CLANG"
   let isVerLine = isInfixOf "clang version"
@@ -112,10 +114,27 @@ getClangVersion = do
       -- as tildes (cf. https://github.com/fosskers/versions/issues/62).
       -- These have been observed in the wild (e.g., 12.0.0-3ubuntu1~20.04.5).
       scrubProblemChars = filter (/= '~')
+
+      headVersionLine :: [String] -> String
+      headVersionLine ls =
+        case ls of
+          l:_ -> l
+          [] -> P.panic
+                  "getClangVersion"
+                  ["`clang --version` output does not contain line with version"]
+
+      headVersionWord :: [String] -> String
+      headVersionWord ws =
+        case ws of
+          w:_ -> w
+          [] -> P.panic
+                  "getClangVersion"
+                  ["`clang --version` output does not contain numeric version"]
+
       getVer (Right inp) =
         -- example inp: "clang version 10.0.1"
-        scrubProblemChars $ head $ dropLetter $ words $
-        head $ filter isVerLine $ lines inp
+        scrubProblemChars $ headVersionWord $ dropLetter $ words $
+        headVersionLine $ filter isVerLine $ lines inp
       getVer (Left full) = full
   mkVC "clang" . getVer <$> readProcessVersion clangBin
 
@@ -124,8 +143,10 @@ getZ3Version =
   let getVer (Right inp) =
         -- example inp: "Z3 version 4.8.7 - 64 bit"
         let w = words inp
-        in if and [ length w > 2, head w == "Z3" ]
-           then w !! 2 else "?"
+        in if |  ("Z3":_:verNum:_) <- w
+              -> verNum
+              |  otherwise
+              -> "?"
       getVer (Left full) = full
   in mkVC "z3" . getVer <$> readProcessVersion "z3"
 
@@ -134,8 +155,10 @@ getYicesVersion =
   let getVer (Right inp) =
         -- example inp: "Yices 2.6.1\nCopyright ..."
         let w = words inp
-        in if and [ length w > 1, head w == "Yices" ]
-           then w !! 1 else "?"
+        in if |  ("Yices":verNum:_) <- w
+              -> verNum
+              |  otherwise
+              -> "?"
       getVer (Left full) = full
   in mkVC "yices" . getVer <$> readProcessVersion "yices"
 
@@ -144,10 +167,10 @@ getSTPVersion =
   let getVer (Right inp) =
         -- example inp: "STP version 2.3.3\n..."
         let w = words inp
-        in if and [ length w > 2
-                  , head w == "STP"
-                  , w !! 1 == "version" ]
-           then w !! 2 else "?"
+        in if |  ("STP":"version":verNum:_) <- w
+              -> verNum
+              |  otherwise
+              -> "?"
       getVer (Left full) = full
   in mkVC "stp" . getVer <$> readProcessVersion "stp"
 
@@ -156,10 +179,10 @@ getCVC4Version =
   let getVer (Right inp) =
         -- example inp: "This is CVC4 version 1.8\ncompiled ..."
         let w = words inp
-        in if and [ length w > 4
-                  , "This is CVC4 version" `isPrefixOf` inp
-                  ]
-           then w !! 4 else "?"
+        in if |  ("This":"is":"CVC4":"version":verNum:_) <- w
+              -> verNum
+              |  otherwise
+              -> "?"
       getVer (Left full) = full
   in mkVC "cvc4" . getVer <$> readProcessVersion "cvc4"
 
@@ -168,10 +191,10 @@ getCVC5Version =
   let getVer (Right inp) =
         -- example inp: "This is cvc5 version 1.0.2\ncompiled ..."
         let w = words inp
-        in if and [ length w > 4
-                  , "This is cvc5 version" `isPrefixOf` inp
-                  ]
-           then w !! 4 else "?"
+        in if |  ("This":"is":"cvc5":"version":verNum:_) <- w
+              -> verNum
+              |  otherwise
+              -> "?"
       getVer (Left full) = full
   in mkVC "cvc5" . getVer <$> readProcessVersion "cvc5"
 
@@ -180,7 +203,9 @@ getBoolectorVersion =
   let getVer (Right inp) =
         -- example inp: "3.2.1"
         let w = words inp
-        in if not (null w) then head w else "?"
+        in case w of
+             verNum:_ -> verNum
+             [] -> "?"
       getVer (Left full) = full
   in mkVC "boolector" . getVer <$> readProcessVersion "boolector"
 

uc-crux-llvm/test/VersionCheck.hs

@@ -32,6 +32,8 @@ import           Data.Versions (Versioning, versioning, prettyV, major)
 import qualified GHC.IO.Exception as GE
 import           System.Process (readProcess)
 
+import           UCCrux.LLVM.Errors.Panic (panic)
+
 -- lack of decipherable version is not fatal to running the tests
 data VersionCheck = VC String (Either Text Versioning)
 
@@ -59,18 +61,35 @@ getClangVersion :: FilePath -> IO VersionCheck
 getClangVersion clangBin = do
   -- Determine which version of clang will be used for these tests.
   -- An exception (E.g. in the readProcess if clang is not found) will
-  -- result in termination (test failure).  Uses partial 'head' but
+  -- result in termination (test failure).  Uses partiality, but
   -- this is just tests, and failure is captured.
   let isVerLine = isInfixOf "clang version"
       dropLetter = dropWhile (all isLetter)
       -- Remove any characters that give `versions` parsers a hard time, such
       -- as tildes (cf. https://github.com/fosskers/versions/issues/62).
       -- These have been observed in the wild (e.g., 12.0.0-3ubuntu1~20.04.5).
       scrubProblemChars = filter (/= '~')
+
+      headVersionLine :: [String] -> String
+      headVersionLine ls =
+        case ls of
+          l:_ -> l
+          [] -> panic
+                  "getClangVersion"
+                  ["`clang --version` output does not contain line with version"]
+
+      headVersionWord :: [String] -> String
+      headVersionWord ws =
+        case ws of
+          w:_ -> w
+          [] -> panic
+                  "getClangVersion"
+                  ["`clang --version` output does not contain numeric version"]
+
       getVer (Right inp) =
         -- example inp: "clang version 10.0.1"
-        scrubProblemChars $ head $ dropLetter $ words $
-        head $ filter isVerLine $ lines inp
+        scrubProblemChars $ headVersionWord $ dropLetter $ words $
+        headVersionLine $ filter isVerLine $ lines inp
       getVer (Left full) = full
   mkVC "clang" . getVer <$> readProcessVersion clangBin