Avoid new warnings introduced in GHC 9.8

GHC 9.8 adds the `-Wx-partial` warning to `-Wall`, which is triggered upon any
use of the partial `head` or `tail` functions from `Prelude`. This patch
rewrites some code in `singletons` to avoid `head`/`tail`, and thereby avoid
new warnings with GHC 9.8. Sometimes, this can be achieved by some mild
refactoring, but in other cases, we simply have to accept the partiality
inherent in some code and make the error cases more explicit.

In addition, `-Worphans` now checks for orphan type _family_ instances in GHC
9.8 in addition to orphan type _class_ instances. The `singletons` test suite
defines some orphan type family instances, so we disable this warning there.

singletons-base/tests/compile-and-dump/GradingClient/Database.hs

@@ -215,12 +215,12 @@ readRow id (SSch (SCons (SAttr _ u) at)) (sh:st) = do
   (rowTail, strTail) <- readRow id (SSch at) st
   case elUReadInstance u of
     ElUReadInstance ->
-      let results = readsPrec 0 sh in
-      if null results
-        then throwError $ "No parse of " ++ sh ++ " as a " ++
-                          (show (fromSing u))
-        else
-          let item = fst $ head results in
+      case readsPrec 0 sh of
+        [] ->
+          throwError $ "No parse of " ++ sh ++ " as a " ++
+                       (show (fromSing u))
+        result:_ ->
+          let item = fst result in
           case elUShowInstance u of
             ElUShowInstance -> return (ConsRow item rowTail, strTail)
 

singletons-th/src/Data/Singletons/TH/Deriving/Bounded.hs

@@ -30,15 +30,23 @@ mkBoundedInstance mb_ctxt ty (DataDecl _ _ _ cons) = do
   -- constructors must be nullary) or has only one constructor. See Section 11
   -- of Haskell 2010 Language Report.
   -- Note that order of conditions below is important.
-  when (null cons
-       || (any (\(DCon _ _ _ f _) -> not . null . tysOfConFields $ f) cons
-            && (not . null . tail $ cons))) $
+  let illegal_bounded_inst =
+        case cons of
+          [] -> True
+          _:cons' ->
+            any (\(DCon _ _ _ f _) -> not . null . tysOfConFields $ f) cons
+             && not (null cons')
+  when illegal_bounded_inst $
        fail ("Can't derive Bounded instance for "
              ++ pprint (typeToTH ty) ++ ".")
   -- at this point we know that either we have a datatype that has only one
   -- constructor or a datatype where each constructor is nullary
-  let (DCon _ _ minName fields _) = head cons
-      (DCon _ _ maxName _ _)      = last cons
+  let internal_err = fail "Internal error (mkBoundedInstance): non-empty list of constructors"
+  DCon _ _ minName fields _ <-
+    case cons of
+      (c:_) -> pure c
+      [] -> internal_err
+  let (_, DCon _ _ maxName _ _) = snocView cons
       fieldsCount   = length $ tysOfConFields fields
       (minRHS, maxRHS) = case fieldsCount of
         0 -> (DConE minName, DConE maxName)

singletons-th/src/Data/Singletons/TH/Names.hs

@@ -175,7 +175,7 @@ liftA2Name = 'liftA2
 mkTyName :: Quasi q => Name -> q Name
 mkTyName tmName = do
   let nameStr  = nameBase tmName
-      symbolic = not (isHsLetter (head nameStr))
+      symbolic = not (isHsLetter (headNameStr nameStr))
   qNewName (if symbolic then "ty" else nameStr)
 
 mkTyConName :: Int -> Name

singletons-th/src/Data/Singletons/TH/Options.hs

@@ -248,7 +248,7 @@ promoteTySym name sat
     default_case :: Name -> Name
     default_case name' =
       let capped = toUpcaseStr noPrefix name' in
-      if isHsLetter (head capped)
+      if isHsLetter (headNameStr capped)
       then mkName (capped ++ "Sym" ++ (show sat))
       else mkName (capped ++ "@#@" -- See Note [Defunctionalization symbol suffixes]
                           ++ (replicate (sat + 1) '$'))

singletons-th/src/Data/Singletons/TH/Util.hs

@@ -86,7 +86,7 @@ isInfixDataCon _       = False
 -- | Is an identifier a legal data constructor name in Haskell? That is, is its
 -- first character an uppercase letter (prefix) or a colon (infix)?
 isDataConName :: Name -> Bool
-isDataConName n = let first = head (nameBase n) in isUpper first || first == ':'
+isDataConName n = let first = headNameStr (nameBase n) in isUpper first || first == ':'
 
 -- | Is an identifier uppercase?
 --
@@ -95,7 +95,7 @@ isDataConName n = let first = head (nameBase n) in isUpper first || first == ':'
 -- If you want to check if a name is legal as a data constructor, use the
 -- 'isDataConName' function.
 isUpcase :: Name -> Bool
-isUpcase n = let first = head (nameBase n) in isUpper first
+isUpcase n = let first = headNameStr (nameBase n) in isUpper first
 
 -- Make an identifier uppercase. If the identifier is infix, this acts as the
 -- identity function.
@@ -114,9 +114,9 @@ toUpcaseStr (alpha, symb) n
 
   where
     str   = nameBase n
-    first = head str
+    first = headNameStr str
 
-    upcase_alpha = alpha ++ (toUpper first) : tail str
+    upcase_alpha = alpha ++ (toUpper first) : tailNameStr str
     upcase_symb = symb ++ str
 
 noPrefix :: (String, String)
@@ -138,7 +138,7 @@ prefixConName pre tyPre n = case (nameBase n) of
 prefixName :: String -> String -> Name -> Name
 prefixName pre tyPre n =
   let str = nameBase n
-      first = head str in
+      first = headNameStr str in
     if isHsLetter first
      then mkName (pre ++ str)
      else mkName (tyPre ++ str)
@@ -148,11 +148,27 @@ prefixName pre tyPre n =
 suffixName :: String -> String -> Name -> Name
 suffixName ident symb n =
   let str = nameBase n
-      first = head str in
+      first = headNameStr str in
   if isHsLetter first
   then mkName (str ++ ident)
   else mkName (str ++ symb)
 
+-- Return the first character in a Name's string (i.e., nameBase).
+-- Precondition: the string is non-empty.
+headNameStr :: String -> Char
+headNameStr str =
+  case str of
+    (c:_) -> c
+    [] -> error "headNameStr: Expected non-empty string"
+
+-- Drop the first character in a Name's string (i.e., nameBase).
+-- Precondition: the string is non-empty.
+tailNameStr :: String -> String
+tailNameStr str =
+  case str of
+    (_:cs) -> cs
+    [] -> error "tailNameStr: Expected non-empty string"
+
 -- convert a number into both alphanumeric and symoblic forms
 uniquePrefixes :: String   -- alphanumeric prefix
                -> String   -- symbolic prefix

singletons/tests/ByHand2.hs

@@ -2,7 +2,7 @@
              DefaultSignatures, ScopedTypeVariables, InstanceSigs,
              MultiParamTypeClasses, FunctionalDependencies,
              UndecidableInstances, CPP #-}
-{-# OPTIONS_GHC -Wno-missing-signatures #-}
+{-# OPTIONS_GHC -Wno-missing-signatures -Wno-orphans #-}
 
 #if __GLASGOW_HASKELL__ < 806
 {-# LANGUAGE TypeInType #-}