Support GHC 9.8.1

flake.nix

@@ -31,7 +31,6 @@
                 # haskell-language-server = {};
                 # hlint = {};
               };
-              modules = [{ghcOptions = ["-Wno-error=x-partial"];}];
               shell.buildInputs = with pkgs; [
                 zlib
                 z3

src-tool/Pact/Analyze/Eval/Term.hs

@@ -904,7 +904,10 @@ format s tms = do
   then Right (literalS (Str s))
   else if plen - length tms > 1
        then Left (AnalyzeFailure dummyInfo "format: not enough arguments for template")
-       else Right $ foldl'
-              (\r (e, t) -> r .++ rep e .++ t)
-              (head parts)
-              (zip tms (tail parts))
+       else case parts of
+              partsHead:partsTail ->
+                Right $ foldl'
+                (\r (e, t) -> r .++ rep e .++ t)
+                partsHead
+                (zip tms partsTail)
+              [] -> error "Impossible case: We checked that this list is nonempty"

src-tool/Pact/Analyze/Translate.hs

@@ -754,7 +754,12 @@ translatePact nodes = do
     -- The proper fix is recognizing the nested defpact dyn invoke and replacing it with
     -- the default value of what the invocation would return.
     -- For now, this unblocks the problem.
-    (if null protoSteps then [] else tail $ reverse protoSteps)
+    (if null protoSteps
+     then []
+     else (\case
+              _:xs -> xs
+              [] -> error "Expected nonempty list"
+          ) $ reverse protoSteps)
 
   let steps = zipWith3
         (\(Step exec p e _ _) mCancel mRb -> Step exec p e mCancel mRb)

src/Pact/ApiReq.hs

@@ -275,7 +275,9 @@ combineSigDatas sds outputLocal = do
   when (S.size hashes /= 1 || S.size cmds /= 1) $ do
     error "SigData files must contain exactly one unique hash and command.  Aborting..."
   let sigs = foldl1 f $ map _sigDataSigs sds
-  returnCommandIfDone outputLocal $ SigData (head $ S.toList hashes) sigs (Just $ head $ S.toList cmds)
+  case (S.toList cmds, S.toList hashes) of
+    (cmd:_, hash':_) -> returnCommandIfDone outputLocal $ SigData hash' sigs (Just cmd)
+    _ -> error "Expected nonempty lists of commands and hashes"
   where
     f accum sigs
       | length accum /= length sigs = error "Sig lists have different lengths"

src/Pact/Eval.hs

@@ -659,8 +659,9 @@ enforceAcyclic
   -> Eval e [(Term (Either l r), key, [key])]
 enforceAcyclic info cs = forM cs $ \c -> case c of
   AcyclicSCC v -> return v
-  CyclicSCC vs -> do
-    let i = if null vs then info else _tInfo $ view _1 $ head vs
+  CyclicSCC [] -> error "Expected nonempty list"
+  CyclicSCC vs@(v:_) -> do
+    let i = if null vs then info else _tInfo $ view _1 $ v
         pl = over (traverse . _3) (SomeDoc . prettyList)
           $ over (traverse . _1) (fmap mkSomeDoc)
           $ vs

src/Pact/PersistPactDb/Regression.hs

@@ -111,11 +111,13 @@ runRegression p = do
     (commit v)
   void $ begin v
   tids <- _txids pactdb user1 t1 v
-  assertEquals "user txids" [1] tids
-  assertEquals' "user txlogs"
-    [TxLog "USER_user1" "key1" row,
-     TxLog "USER_user1" "key1" row'] $
-    _getTxLog pactdb usert (head tids) v
+  case tids of
+   tid:_ ->
+    assertEquals' "user txlogs"
+      [TxLog "USER_user1" "key1" row,
+      TxLog "USER_user1" "key1" row'] $
+      _getTxLog pactdb usert tid v
+   _ -> error "Expected nonempty list of tids"
   _writeRow pactdb Insert usert "key2" row v
   assertEquals' "user insert key2 pre-rollback" (Just row) (_readRow pactdb usert "key2" v)
   assertEquals' "keys pre-rollback" ["key1","key2"] $ _keys pactdb (UserTables user1) v

src/Pact/Server/History/Persistence.hs

@@ -148,8 +148,8 @@ selectCompletedCommands e v = foldM f HashMap.empty v
       rs <- qrys (_qryCompletedStmt e) [hashToField $ unRequestKey rk] [RText,RInt,RInt]
       if null rs
       then return m
-      else case head rs of
-          [SText (Utf8 cr),SInt _, SInt _] ->
+      else case rs of
+          [SText (Utf8 cr),SInt _, SInt _]:_ ->
             return $ HashMap.insert rk (crFromField cr) m
           r -> dbError $ "Invalid result from query: " ++ show r
 

src/Pact/Typechecker.hs

@@ -1005,10 +1005,11 @@ toAST (TApp Term.App{..} _) = do
               return app'
             Resume -> do
               app' <- specialBind
-              case head args' of -- 'specialBind' ensures non-empty args
-                (Binding _ _ _ (AstBindSchema sty)) ->
+              case Data.List.uncons args' of -- 'specialBind' ensures non-empty args
+                Just (Binding _ _ _ (AstBindSchema sty), _) ->
                   setOrAssocYR yrResume sty
-                a -> die'' a "Expected binding"
+                Just (a,_) -> die'' a "Expected binding"
+                Nothing -> error "Impossible case"
               return app'
             _ -> mkApp fun' args'
 
@@ -1204,7 +1205,10 @@ showFails = do
 
 -- | unsafe lens for using `typecheckBody` with const
 singLens :: Iso' a [a]
-singLens = iso pure head
+singLens = iso pure (\case
+                        x:_ -> x
+                        [] -> error "Expected nonempty list"
+                    )
 
 -- | Typecheck a top-level production.
 typecheck :: TopLevel Node -> TC (TopLevel Node)