From 0b5226a1a14848e8a94bdf59723f7120db649d5c Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Sat, 30 Sep 2023 20:15:24 -0400 Subject: [PATCH] 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. --- .../GradingClient/Database.hs | 12 ++++---- .../Data/Singletons/TH/Deriving/Bounded.hs | 18 ++++++++---- singletons-th/src/Data/Singletons/TH/Names.hs | 2 +- .../src/Data/Singletons/TH/Options.hs | 2 +- singletons-th/src/Data/Singletons/TH/Util.hs | 28 +++++++++++++++---- singletons/tests/ByHand2.hs | 2 +- 6 files changed, 44 insertions(+), 20 deletions(-) diff --git a/singletons-base/tests/compile-and-dump/GradingClient/Database.hs b/singletons-base/tests/compile-and-dump/GradingClient/Database.hs index 4b7d8242..a1bb9ecb 100644 --- a/singletons-base/tests/compile-and-dump/GradingClient/Database.hs +++ b/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) diff --git a/singletons-th/src/Data/Singletons/TH/Deriving/Bounded.hs b/singletons-th/src/Data/Singletons/TH/Deriving/Bounded.hs index 4379af76..798122a9 100644 --- a/singletons-th/src/Data/Singletons/TH/Deriving/Bounded.hs +++ b/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) diff --git a/singletons-th/src/Data/Singletons/TH/Names.hs b/singletons-th/src/Data/Singletons/TH/Names.hs index 7571289d..b1fa653b 100644 --- a/singletons-th/src/Data/Singletons/TH/Names.hs +++ b/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 diff --git a/singletons-th/src/Data/Singletons/TH/Options.hs b/singletons-th/src/Data/Singletons/TH/Options.hs index 8a04b8bb..7119446b 100644 --- a/singletons-th/src/Data/Singletons/TH/Options.hs +++ b/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) '$')) diff --git a/singletons-th/src/Data/Singletons/TH/Util.hs b/singletons-th/src/Data/Singletons/TH/Util.hs index 4b995a49..f9b96ca3 100644 --- a/singletons-th/src/Data/Singletons/TH/Util.hs +++ b/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 diff --git a/singletons/tests/ByHand2.hs b/singletons/tests/ByHand2.hs index f5b1a599..3ebe2033 100644 --- a/singletons/tests/ByHand2.hs +++ b/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 #-}