diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +# 0.3.0.0 + +- Add generic implementations of `enumFrom`, `enumFromThen`, `enumFromTo`, + `enumFromThenTo`. They are actually required to be explicit for correct + `Enum` instances. Thanks to Topsii. +- Parameterize `GEnum` by a type-level option, and add `FiniteEnum` option + to allow `Enum` to be derived for composite types. Thanks to Topsii. + # 0.2.0.0 - Remove `Generic.Data.Types.Map` diff --git a/generic-data.cabal b/generic-data.cabal --- a/generic-data.cabal +++ b/generic-data.cabal @@ -1,5 +1,5 @@ name: generic-data -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Utilities for GHC.Generics description: This package provides common functions on generic types. See README. diff --git a/src/Generic/Data.hs b/src/Generic/Data.hs --- a/src/Generic/Data.hs +++ b/src/Generic/Data.hs @@ -36,10 +36,24 @@ , GShow0 -- ** 'Enum' + , GEnum() + -- *** StandardEnum option -- | Can also be derived by GHC as part of the standard. - , gfromEnum + , StandardEnum() , gtoEnum - , GEnum() + , gfromEnum + , genumFrom + , genumFromThen + , genumFromTo + , genumFromThenTo + -- *** FiniteEnum option + , FiniteEnum() + , gtoFiniteEnum + , gfromFiniteEnum + , gfiniteEnumFrom + , gfiniteEnumFromThen + , gfiniteEnumFromTo + , gfiniteEnumFromThenTo -- ** 'Bounded' -- | Can also be derived by GHC as part of the standard. @@ -90,6 +104,7 @@ -- * Carriers of generic instances , Generically(..) + , FiniteEnumeration(..) , Generically1(..) -- * Newtype diff --git a/src/Generic/Data/Internal/Data.hs b/src/Generic/Data/Internal/Data.hs --- a/src/Generic/Data/Internal/Data.hs +++ b/src/Generic/Data/Internal/Data.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -54,9 +55,9 @@ instance GShow1 r => Show1 (Data r) where liftShowsPrec = (fmap . fmap) (flip . (. unData)) gLiftPrecShows -instance GEnum r => Enum (Data r p) where - toEnum = Data . gToEnum - fromEnum = gFromEnum . unData +instance GEnum StandardEnum r => Enum (Data r p) where + toEnum = Data . gToEnum @StandardEnum + fromEnum = gFromEnum @StandardEnum . unData instance GBounded r => Bounded (Data r p) where minBound = Data gMinBound diff --git a/src/Generic/Data/Internal/Enum.hs b/src/Generic/Data/Internal/Enum.hs --- a/src/Generic/Data/Internal/Enum.hs +++ b/src/Generic/Data/Internal/Enum.hs @@ -1,36 +1,166 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Generic.Data.Internal.Enum where import GHC.Generics -import Data.Proxy --- | Generic 'toEnum'. +-- | Generic 'toEnum' generated with the 'StandardEnum' option. -- -- @ -- instance 'Enum' MyType where -- 'toEnum' = 'gtoEnum' -- 'fromEnum' = 'gfromEnum' +-- 'enumFrom' = 'genumFrom' +-- 'enumFromThen' = 'genumFromThen' +-- 'enumFromTo' = 'genumFromTo' +-- 'enumFromThenTo' = 'genumFromThenTo' -- @ -gtoEnum :: forall a. (Generic a, GEnum (Rep a)) => Int -> a -gtoEnum n - | 0 <= n && n < card = to (gToEnum n) - | otherwise = error $ - "gtoEnum: out of bounds, index " ++ show n ++ ", card " ++ show card - where - card = gCardinality (Proxy :: Proxy (Rep a)) +gtoEnum :: forall a. (Generic a, GEnum StandardEnum (Rep a)) => Int -> a +gtoEnum = gtoEnum' @StandardEnum "gtoEnum" --- | Generic 'fromEnum'. +-- | Generic 'fromEnum' generated with the 'StandardEnum' option. -- -- See also 'gtoEnum'. -gfromEnum :: (Generic a, GEnum (Rep a)) => a -> Int -gfromEnum = gFromEnum . from +gfromEnum :: (Generic a, GEnum StandardEnum (Rep a)) => a -> Int +gfromEnum = gfromEnum' @StandardEnum +-- | Generic 'enumFrom' generated with the 'StandardEnum' option. +-- +-- See also 'gtoEnum'. +genumFrom :: (Generic a, GEnum StandardEnum (Rep a)) => a -> [a] +genumFrom = genumFrom' @StandardEnum + +-- | Generic 'enumFromThen' generated with the 'StandardEnum' option. +-- +-- See also 'gtoEnum'. +genumFromThen :: (Generic a, GEnum StandardEnum (Rep a)) => a -> a -> [a] +genumFromThen = genumFromThen' @StandardEnum + +-- | Generic 'enumFromTo' generated with the 'StandardEnum' option. +-- +-- See also 'gtoEnum'. +genumFromTo :: (Generic a, GEnum StandardEnum (Rep a)) => a -> a -> [a] +genumFromTo = genumFromTo' @StandardEnum + +-- | Generic 'enumFromThenTo' generated with the 'StandardEnum' option. +-- +-- See also 'gtoEnum'. +genumFromThenTo :: (Generic a, GEnum StandardEnum (Rep a)) => a -> a -> a -> [a] +genumFromThenTo = genumFromThenTo' @StandardEnum + + +-- | Generic 'toEnum' generated with the 'FiniteEnum' option. +-- +-- @ +-- instance 'Enum' MyType where +-- 'toEnum' = 'gtoFiniteEnum' +-- 'fromEnum' = 'gfromFiniteEnum' +-- 'enumFrom' = 'gfiniteEnumFrom' +-- 'enumFromThen' = 'gfiniteEnumFromThen' +-- 'enumFromTo' = 'gfiniteEnumFromTo' +-- 'enumFromThenTo' = 'gfiniteEnumFromThenTo' +-- @ +gtoFiniteEnum :: forall a. (Generic a, GEnum FiniteEnum (Rep a)) => Int -> a +gtoFiniteEnum = gtoEnum' @FiniteEnum "gtoFiniteEnum" + +-- | Generic 'fromEnum' generated with the 'FiniteEnum' option. +-- +-- See also 'gtoFiniteEnum'. +gfromFiniteEnum :: (Generic a, GEnum FiniteEnum (Rep a)) => a -> Int +gfromFiniteEnum = gfromEnum' @FiniteEnum + +-- | Generic 'enumFrom' generated with the 'FiniteEnum' option. +-- +-- See also 'gtoFiniteEnum'. +gfiniteEnumFrom :: (Generic a, GEnum FiniteEnum (Rep a)) => a -> [a] +gfiniteEnumFrom = genumFrom' @FiniteEnum + +-- | Generic 'enumFromThen' generated with the 'FiniteEnum' option. +-- +-- See also 'gtoFiniteEnum'. +gfiniteEnumFromThen :: (Generic a, GEnum FiniteEnum (Rep a)) => a -> a -> [a] +gfiniteEnumFromThen = genumFromThen' @FiniteEnum + +-- | Generic 'enumFromTo' generated with the 'FiniteEnum' option. +-- +-- See also 'gtoFiniteEnum'. +gfiniteEnumFromTo :: (Generic a, GEnum FiniteEnum (Rep a)) => a -> a -> [a] +gfiniteEnumFromTo = genumFromTo' @FiniteEnum + +-- | Generic 'enumFromThenTo' generated with the 'FiniteEnum' option. +-- +-- See also 'gtoFiniteEnum'. +gfiniteEnumFromThenTo :: (Generic a, GEnum FiniteEnum (Rep a)) => a -> a -> a -> [a] +gfiniteEnumFromThenTo = genumFromThenTo' @FiniteEnum + +-- | Unsafe generic 'toEnum'. Does not check whether the argument is within +-- valid bounds. Use 'gtoEnum' or 'gtoFiniteEnum' instead. +gtoEnumRaw' :: forall opts a. (Generic a, GEnum opts (Rep a)) => Int -> a +gtoEnumRaw' = to . gToEnum @opts + +-- | Generic 'toEnum'. Use 'gfromEnum' or 'gfromFiniteEnum' instead. +gtoEnum' :: forall opts a. (Generic a, GEnum opts (Rep a)) => String -> Int -> a +gtoEnum' name n + | 0 <= n && n < card = gtoEnumRaw' @opts n + | otherwise = error $ + name ++ ": out of bounds, index " ++ show n ++ ", cardinality " ++ show card + where + card = gCardinality @opts @(Rep a) + +-- | Generic 'fromEnum'. Use 'gfromEnum' or 'gfromFiniteEnum' instead. +gfromEnum' :: forall opts a. (Generic a, GEnum opts (Rep a)) => a -> Int +gfromEnum' = gFromEnum @opts . from + +-- | > genumMin == gfromEnum gminBound +genumMin :: Int +genumMin = 0 + +-- | > genumMin == gfromEnum gmaxBound +genumMax :: forall opts a. (Generic a, GEnum opts (Rep a)) => Int +genumMax = gCardinality @opts @(Rep a) - 1 + +-- | Generic 'enumFrom'. Use 'genumFrom' or 'gfiniteEnumFrom' instead. +genumFrom' :: forall opts a. (Generic a, GEnum opts (Rep a)) => a -> [a] +genumFrom' x = map toE [ i_x .. genumMax @opts @a ] + where + toE = gtoEnumRaw' @opts + i_x = gfromEnum' @opts x + +-- | Generic 'enumFromThen'. Use 'genumFromThen' or 'gfiniteEnumFromThen' instead. +genumFromThen' :: forall opts a. (Generic a, GEnum opts (Rep a)) => a -> a -> [a] +genumFromThen' x1 x2 = map toE [ i_x1, i_x2 .. bound ] + where + toE = gtoEnumRaw' @opts + i_x1 = gfromEnum' @opts x1 + i_x2 = gfromEnum' @opts x2 + bound | i_x1 >= i_x2 = genumMin + | otherwise = genumMax @opts @a + +-- | Generic 'enumFromTo'. Use 'genumFromTo' or 'gfiniteEnumFromTo' instead. +genumFromTo' :: forall opts a. (Generic a, GEnum opts (Rep a)) => a -> a -> [a] +genumFromTo' x y = map toE [ i_x .. i_y ] + where + toE = gtoEnumRaw' @opts + i_x = gfromEnum' @opts x + i_y = gfromEnum' @opts y + +-- | Generic 'enumFromThenTo'. Use 'genumFromThenTo' or 'gfiniteEnumFromThenTo' instead. +genumFromThenTo' :: forall opts a. (Generic a, GEnum opts (Rep a)) => a -> a -> a -> [a] +genumFromThenTo' x1 x2 y = map toE [ i_x1, i_x2 .. i_y ] + where + toE = gtoEnumRaw' @opts + i_x1 = gfromEnum' @opts x1 + i_x2 = gfromEnum' @opts x2 + i_y = gfromEnum' @opts y + -- | Generic 'minBound'. -- -- @ @@ -48,32 +178,95 @@ gmaxBound = to gMaxBound -- | Generic representation of 'Enum' types. -class GEnum f where - gCardinality :: proxy f -> Int +-- +-- The @opts@ parameter is a type-level option to select different +-- implementations. +class GEnum opts f where + gCardinality :: Int gFromEnum :: f p -> Int gToEnum :: Int -> f p -instance GEnum f => GEnum (M1 i c f) where - gCardinality _ = gCardinality (Proxy :: Proxy f) - gFromEnum = gFromEnum . unM1 - gToEnum = M1 . gToEnum +-- | Standard option for 'GEnum': derive 'Enum' for types with only nullary +-- constructors (the same restrictions as in the [Haskell 2010 +-- report](https://www.haskell.org/onlinereport/haskell2010/haskellch11.html#x18-18400011.2)). +data StandardEnum -instance (GEnum f, GEnum g) => GEnum (f :+: g) where - gCardinality _ = gCardinality (Proxy :: Proxy f) + gCardinality (Proxy :: Proxy g) - gFromEnum (L1 x) = gFromEnum x - gFromEnum (R1 y) = cardF + gFromEnum y +-- | Extends the 'StandardEnum' option for 'GEnum' to allow all constructors to +-- have arbitrary many fields. Each field type must be an instance of +-- both 'Enum' and 'Bounded'. Two restrictions require the user's caution: +-- +-- * The 'Enum' instances of the field types need to start enumerating from 0. +-- Particularly 'Int' is an unfit field type, because the enumeration of the +-- negative values starts before 0. +-- +-- * Since 'GEnum' represents the cardinality explicitly as an 'Int', there can +-- only be up to 'maxBound' values. This restriction makes 'Word' an invalid field +-- type. Notably it is insufficient for each individual field types to stay +-- below this limit. Instead it applies to the generic type as a whole. +-- +-- The resulting 'GEnum' instance starts enumerating from @0@ up to +-- @(cardinality - 1)@ and respects the generic 'Ord' instance. +-- Implied by this the values from different constructors are enumerated +-- sequentially. They are not interleaved. +-- +-- To be very exact: The aforementioned generic 'Ord' instance can be determined +-- by constraining the field types to 'Enum' instead of 'Ord'. Each field's +-- order on its values is given by their enumeration. +-- +-- > data Example = C0 Bool Bool | C1 Bool +-- > deriving (Eq, Ord, Show, Generic) +-- > +-- > gCardinality == 6 -- 2 * 2 + 2 +-- > +-- > enumeration = +-- > [ C0 False False +-- > , C0 False True +-- > , C0 True False +-- > , C0 True True +-- > , C1 False +-- > , C1 True +-- > ] +-- > +-- > enumeration == map gtoFiniteEnum [0 .. 5] +-- > [0 .. 5] == map gfromFiniteEnum enumeration +data FiniteEnum + +instance GEnum opts f => GEnum opts (M1 i c f) where + gCardinality = gCardinality @opts @f + gFromEnum = gFromEnum @opts . unM1 + gToEnum = M1 . gToEnum @opts + +instance (GEnum opts f, GEnum opts g) => GEnum opts (f :+: g) where + gCardinality = gCardinality @opts @f + gCardinality @opts @g + gFromEnum (L1 x) = gFromEnum @opts x + gFromEnum (R1 y) = cardF + gFromEnum @opts y where - cardF = gCardinality (Proxy :: Proxy f) + cardF = gCardinality @opts @f gToEnum n - | n < cardF = L1 (gToEnum n) - | otherwise = R1 (gToEnum (n - cardF)) + | n < cardF = L1 (gToEnum @opts n) + | otherwise = R1 (gToEnum @opts (n - cardF)) where - cardF = gCardinality (Proxy :: Proxy f) + cardF = gCardinality @opts @f -instance GEnum U1 where - gCardinality _ = 1 +instance (GEnum FiniteEnum f, GEnum FiniteEnum g) => GEnum FiniteEnum (f :*: g) where + gCardinality = gCardinality @FiniteEnum @f * gCardinality @FiniteEnum @g + gFromEnum (x :*: y) = gFromEnum @FiniteEnum x * cardG + gFromEnum @FiniteEnum y + where + cardG = gCardinality @FiniteEnum @g + gToEnum n = gToEnum @FiniteEnum x :*: gToEnum @FiniteEnum y + where + (x, y) = n `quotRem` cardG + cardG = gCardinality @FiniteEnum @g + +instance GEnum opts U1 where + gCardinality = 1 gFromEnum U1 = 0 gToEnum _ = U1 + +instance (Bounded c, Enum c) => GEnum FiniteEnum (K1 i c) where + gCardinality = fromEnum (maxBound :: c) + 1 + gFromEnum = fromEnum . unK1 + gToEnum = K1 . toEnum -- | Generic representation of 'Bounded' types. class GBounded f where diff --git a/src/Generic/Data/Internal/Generically.hs b/src/Generic/Data/Internal/Generically.hs --- a/src/Generic/Data/Internal/Generically.hs +++ b/src/Generic/Data/Internal/Generically.hs @@ -40,13 +40,33 @@ mempty = gmempty mappend = gmappend' -instance (Generic a, GEnum (Rep a)) => Enum (Generically a) where - fromEnum = gfromEnum +instance (Generic a, GEnum StandardEnum (Rep a)) => Enum (Generically a) where toEnum = gtoEnum + fromEnum = gfromEnum + enumFrom = genumFrom + enumFromThen = genumFromThen + enumFromTo = genumFromTo + enumFromThenTo = genumFromThenTo instance (Generic a, GBounded (Rep a)) => Bounded (Generically a) where minBound = gminBound maxBound = gmaxBound + +-- | Type with 'Enum' instance derived via 'Generic' with 'FiniteEnum' option. +newtype FiniteEnumeration a = FiniteEnumeration { unFiniteEnumeration :: a } + +instance Generic a => Generic (FiniteEnumeration a) where + type Rep (FiniteEnumeration a) = Rep a + to = FiniteEnumeration . to + from = from . unFiniteEnumeration + +instance (Generic a, GEnum FiniteEnum (Rep a)) => Enum (FiniteEnumeration a) where + toEnum = gtoFiniteEnum + fromEnum = gfromFiniteEnum + enumFrom = gfiniteEnumFrom + enumFromThen = gfiniteEnumFromThen + enumFromTo = gfiniteEnumFromTo + enumFromThenTo = gfiniteEnumFromThenTo -- | Type with instances derived via 'Generic1'. newtype Generically1 f a = Generically1 { unGenerically1 :: f a } diff --git a/test/unit.hs b/test/unit.hs --- a/test/unit.hs +++ b/test/unit.hs @@ -40,9 +40,27 @@ pl1 :: PTy1 [Int] pl1 = p1 -data E = E0 | E1 | E2 +data E = E0 | E1 | E2 | E3 deriving (Eq, Show, Generic) +data FiniteE = SE0 Bool Bool | SE1 Bool + deriving (Eq, Ord, Show, Generic) + +e0, e1, eLast :: FiniteE +e0 = allEs !! 0 +e1 = allEs !! 1 +eLast = last allEs + +allEs :: [FiniteE] +allEs = + [ SE0 False False + , SE0 False True + , SE0 True False + , SE0 True True + , SE1 False + , SE1 True + ] + maybeModuleName :: String #if MIN_VERSION_base(4,12,0) maybeModuleName = "GHC.Maybe" @@ -93,13 +111,23 @@ ] , testGroup "Bounded" [ testCase "minBound @E" $ E0 @?= gminBound - , testCase "maxBound @E" $ E2 @?= gmaxBound + , testCase "maxBound @E" $ E3 @?= gmaxBound , testCase "minBound @(P Int)" $ p' minBound minBound @?= gminBound , testCase "maxBound @(P Int)" $ p' maxBound maxBound @?= gmaxBound ] , testGroup "Enum" - [ testCase "toEnum" $ [E0, E1, E2] @?= fmap gtoEnum [0, 1, 2] - , testCase "fromEnum" $ [0, 1, 2] @?= fmap gfromEnum [E0, E1, E2] + [ testCase "toEnum" $ [E0, E1, E2, E3] @?= fmap gtoEnum [0, 1, 2, 3] + , testCase "fromEnum" $ [0, 1, 2, 3] @?= fmap gfromEnum [E0, E1, E2, E3] + , testCase "enumFrom" $ [E0, E1, E2, E3] @?= genumFrom E0 + , testCase "enumFromThen" $ [E0, E1, E2, E3] @?= genumFromThen E0 E1 + , testCase "enumFromTo" $ [E0, E1, E2, E3] @?= genumFromTo E0 E3 + , testCase "enumFromThenTo" $ [E0, E1, E2, E3] @?= genumFromThenTo E0 E1 E3 + , testCase "toEnum (FiniteEnum)" $ allEs @?= fmap gtoFiniteEnum [0 .. 5] + , testCase "fromEnum (FiniteEnum)" $ [0 .. 5] @?= fmap gfromFiniteEnum allEs + , testCase "enumFrom (FiniteEnum)" $ allEs @?= gfiniteEnumFrom e0 + , testCase "enumFromThen (FiniteEnum)" $ allEs @?= gfiniteEnumFromThen e0 e1 + , testCase "enumFromTo (FiniteEnum)" $ allEs @?= gfiniteEnumFromTo e0 eLast + , testCase "enumFromThenTo (FiniteEnum)" $ allEs @?= gfiniteEnumFromThenTo e0 e1 eLast ] , testGroup "Show" [ testCase "show" $ "P 1 2" @?= show (p' 1 2)