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 #-}