diff --git a/src/Data/Enum/Generic.purs b/src/Data/Enum/Generic.purs new file mode 100644 index 0000000..0d59cca --- /dev/null +++ b/src/Data/Enum/Generic.purs @@ -0,0 +1,118 @@ +module Data.Enum.Generic where + +import Prelude + +import Data.Enum (class BoundedEnum, class Enum, Cardinality(..), cardinality, fromEnum, pred, succ, toEnum) +import Data.Generic.Rep (class Generic, Argument(..), Constructor(..), NoArguments(..), Product(..), Sum(..), from, to) +import Data.Bounded.Generic (class GenericBottom, class GenericTop, genericBottom', genericTop') +import Data.Maybe (Maybe(..)) +import Data.Newtype (unwrap) + +class GenericEnum a where + genericPred' :: a -> Maybe a + genericSucc' :: a -> Maybe a + +instance genericEnumNoArguments :: GenericEnum NoArguments where + genericPred' _ = Nothing + genericSucc' _ = Nothing + +instance genericEnumArgument :: Enum a => GenericEnum (Argument a) where + genericPred' (Argument a) = Argument <$> pred a + genericSucc' (Argument a) = Argument <$> succ a + +instance genericEnumConstructor :: GenericEnum a => GenericEnum (Constructor name a) where + genericPred' (Constructor a) = Constructor <$> genericPred' a + genericSucc' (Constructor a) = Constructor <$> genericSucc' a + +instance genericEnumSum :: (GenericEnum a, GenericTop a, GenericEnum b, GenericBottom b) => GenericEnum (Sum a b) where + genericPred' = case _ of + Inl a -> Inl <$> genericPred' a + Inr b -> case genericPred' b of + Nothing -> Just (Inl genericTop') + Just b' -> Just (Inr b') + genericSucc' = case _ of + Inl a -> case genericSucc' a of + Nothing -> Just (Inr genericBottom') + Just a' -> Just (Inl a') + Inr b -> Inr <$> genericSucc' b + +instance genericEnumProduct :: (GenericEnum a, GenericTop a, GenericBottom a, GenericEnum b, GenericTop b, GenericBottom b) => GenericEnum (Product a b) where + genericPred' (Product a b) = case genericPred' b of + Just p -> Just $ Product a p + Nothing -> flip Product genericTop' <$> genericPred' a + genericSucc' (Product a b) = case genericSucc' b of + Just s -> Just $ Product a s + Nothing -> flip Product genericBottom' <$> genericSucc' a + + +-- | A `Generic` implementation of the `pred` member from the `Enum` type class. +genericPred :: forall a rep. Generic a rep => GenericEnum rep => a -> Maybe a +genericPred = map to <<< genericPred' <<< from + +-- | A `Generic` implementation of the `succ` member from the `Enum` type class. +genericSucc :: forall a rep. Generic a rep => GenericEnum rep => a -> Maybe a +genericSucc = map to <<< genericSucc' <<< from + +class GenericBoundedEnum a where + genericCardinality' :: Cardinality a + genericToEnum' :: Int -> Maybe a + genericFromEnum' :: a -> Int + +instance genericBoundedEnumNoArguments :: GenericBoundedEnum NoArguments where + genericCardinality' = Cardinality 1 + genericToEnum' i = if i == 0 then Just NoArguments else Nothing + genericFromEnum' _ = 0 + +instance genericBoundedEnumArgument :: BoundedEnum a => GenericBoundedEnum (Argument a) where + genericCardinality' = Cardinality (unwrap (cardinality :: Cardinality a)) + genericToEnum' i = Argument <$> toEnum i + genericFromEnum' (Argument a) = fromEnum a + +instance genericBoundedEnumConstructor :: GenericBoundedEnum a => GenericBoundedEnum (Constructor name a) where + genericCardinality' = Cardinality (unwrap (genericCardinality' :: Cardinality a)) + genericToEnum' i = Constructor <$> genericToEnum' i + genericFromEnum' (Constructor a) = genericFromEnum' a + +instance genericBoundedEnumSum :: (GenericBoundedEnum a, GenericBoundedEnum b) => GenericBoundedEnum (Sum a b) where + genericCardinality' = + Cardinality + $ unwrap (genericCardinality' :: Cardinality a) + + unwrap (genericCardinality' :: Cardinality b) + genericToEnum' n = to genericCardinality' + where + to :: Cardinality a -> Maybe (Sum a b) + to (Cardinality ca) + | n >= 0 && n < ca = Inl <$> genericToEnum' n + | otherwise = Inr <$> genericToEnum' (n - ca) + genericFromEnum' = case _ of + Inl a -> genericFromEnum' a + Inr b -> genericFromEnum' b + unwrap (genericCardinality' :: Cardinality a) + + +instance genericBoundedEnumProduct :: (GenericBoundedEnum a, GenericBoundedEnum b) => GenericBoundedEnum (Product a b) where + genericCardinality' = + Cardinality + $ unwrap (genericCardinality' :: Cardinality a) + * unwrap (genericCardinality' :: Cardinality b) + genericToEnum' n = to genericCardinality' + where to :: Cardinality b -> Maybe (Product a b) + to (Cardinality cb) = Product <$> (genericToEnum' $ n `div` cb) <*> (genericToEnum' $ n `mod` cb) + genericFromEnum' = from genericCardinality' + where from :: Cardinality b -> (Product a b) -> Int + from (Cardinality cb) (Product a b) = genericFromEnum' a * cb + genericFromEnum' b + + +-- | A `Generic` implementation of the `cardinality` member from the +-- | `BoundedEnum` type class. +genericCardinality :: forall a rep. Generic a rep => GenericBoundedEnum rep => Cardinality a +genericCardinality = Cardinality (unwrap (genericCardinality' :: Cardinality rep)) + +-- | A `Generic` implementation of the `toEnum` member from the `BoundedEnum` +-- | type class. +genericToEnum :: forall a rep. Generic a rep => GenericBoundedEnum rep => Int -> Maybe a +genericToEnum = map to <<< genericToEnum' + +-- | A `Generic` implementation of the `fromEnum` member from the `BoundedEnum` +-- | type class. +genericFromEnum :: forall a rep. Generic a rep => GenericBoundedEnum rep => a -> Int +genericFromEnum = genericFromEnum' <<< from diff --git a/test/Main.purs b/test/Main.purs index b8d6c38..c4a74e6 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -4,6 +4,9 @@ import Prelude import Effect (Effect) import Test.Data.Enum (testEnum) +import Test.Data.Enum.Generic (testGenericEnum) main :: Effect Unit -main = testEnum +main = do + testEnum + testGenericEnum diff --git a/test/Test/Data/Enum/Generic.purs b/test/Test/Data/Enum/Generic.purs new file mode 100644 index 0000000..7472119 --- /dev/null +++ b/test/Test/Data/Enum/Generic.purs @@ -0,0 +1,150 @@ +module Test.Data.Enum.Generic where + +import Prelude + +import Data.Enum (class BoundedEnum, class Enum, Cardinality(..), cardinality, fromEnum, pred, succ, toEnum, enumFromTo) +import Data.Generic.Rep as G +import Data.Bounded.Generic as GBounded +import Data.Enum.Generic as GEnum +import Data.Eq.Generic as GEq +import Data.Ord.Generic as GOrd +import Data.Show.Generic as GShow +import Data.Maybe (Maybe(..)) +import Effect (Effect) +import Effect.Console (log) +import Test.Assert (assert) + +data SimpleBounded = A | B | C | D +derive instance genericSimpleBounded :: G.Generic SimpleBounded _ +instance eqSimpleBounded :: Eq SimpleBounded where + eq x y = GEq.genericEq x y +instance ordSimpleBounded :: Ord SimpleBounded where + compare x y = GOrd.genericCompare x y +instance showSimpleBounded :: Show SimpleBounded where + show x = GShow.genericShow x +instance boundedSimpleBounded :: Bounded SimpleBounded where + bottom = GBounded.genericBottom + top = GBounded.genericTop +instance enumSimpleBounded :: Enum SimpleBounded where + pred = GEnum.genericPred + succ = GEnum.genericSucc +instance boundedEnumSimpleBounded :: BoundedEnum SimpleBounded where + cardinality = GEnum.genericCardinality + toEnum = GEnum.genericToEnum + fromEnum = GEnum.genericFromEnum + +data Option a = None | Some a +derive instance genericOption :: G.Generic (Option a) _ +instance eqOption :: Eq a => Eq (Option a) where + eq x y = GEq.genericEq x y +instance ordOption :: Ord a => Ord (Option a) where + compare x y = GOrd.genericCompare x y +instance showOption :: Show a => Show (Option a) where + show x = GShow.genericShow x +instance boundedOption :: Bounded a => Bounded (Option a) where + bottom = GBounded.genericBottom + top = GBounded.genericTop +instance enumOption :: (Bounded a, Enum a) => Enum (Option a) where + pred = GEnum.genericPred + succ = GEnum.genericSucc +instance boundedEnumOption :: BoundedEnum a => BoundedEnum (Option a) where + cardinality = GEnum.genericCardinality + toEnum = GEnum.genericToEnum + fromEnum = GEnum.genericFromEnum + +data Bit = Zero | One +derive instance genericBit :: G.Generic Bit _ +instance eqBit :: Eq Bit where + eq x y = GEq.genericEq x y +instance ordBit :: Ord Bit where + compare x y = GOrd.genericCompare x y +instance showBit :: Show Bit where + show x = GShow.genericShow x +instance boundedBit :: Bounded Bit where + bottom = GBounded.genericBottom + top = GBounded.genericTop +instance enumBit :: Enum Bit where + pred = GEnum.genericPred + succ = GEnum.genericSucc +instance boundedEnumBit :: BoundedEnum Bit where + cardinality = GEnum.genericCardinality + toEnum = GEnum.genericToEnum + fromEnum = GEnum.genericFromEnum + +data Pair a b = Pair a b +derive instance genericPair :: G.Generic (Pair a b) _ +instance eqPair :: (Eq a, Eq b) => Eq (Pair a b) where + eq = GEq.genericEq +instance ordPair :: (Ord a, Ord b) => Ord (Pair a b) where + compare = GOrd.genericCompare +instance showPair :: (Show a, Show b) => Show (Pair a b) where + show = GShow.genericShow +instance boundedPair :: (Bounded a, Bounded b) => Bounded (Pair a b) where + bottom = GBounded.genericBottom + top = GBounded.genericTop +instance enumPair :: (Bounded a, Enum a, Bounded b, Enum b) => Enum (Pair a b) where + pred = GEnum.genericPred + succ = GEnum.genericSucc +instance boundedEnumPair :: (BoundedEnum a, BoundedEnum b) => BoundedEnum (Pair a b) where + cardinality = GEnum.genericCardinality + toEnum = GEnum.genericToEnum + fromEnum = GEnum.genericFromEnum + +testGenericEnum :: Effect Unit +testGenericEnum = do + log "Checking simple pred bottom" + assert $ pred (bottom :: SimpleBounded) == Nothing + + log "Checking simple (pred =<< succ bottom)" + assert $ (pred =<< succ bottom) == Just A + + log "Checking simple succ top" + assert $ succ (top :: SimpleBounded) == Nothing + + log "Checking simple (succ =<< pred top)" + assert $ (succ =<< pred top) == Just D + + log "Checking composite pred bottom" + assert $ pred (bottom :: Option SimpleBounded) == Nothing + + log "Checking composite (pred =<< succ bottom)" + assert $ (pred =<< succ (bottom :: Option SimpleBounded)) == Just None + + log "Checking composite succ top" + assert $ succ (top :: Option SimpleBounded) == Nothing + + log "Checking composite (succ =<< pred top)" + assert $ (succ =<< pred top) == Just (Some D) + + log "Checking product pred bottom" + assert $ pred (bottom :: Pair Bit SimpleBounded) == Nothing + + log "Checking product (pred =<< succ bottom)" + assert $ (pred =<< succ (bottom :: Pair Bit SimpleBounded)) == Just (Pair Zero A) + + log "Checking product succ top" + assert $ succ (top :: Pair Bit SimpleBounded) == Nothing + + log "Checking product (succ =<< pred top)" + assert $ (succ =<< pred top) == Just (Pair One D) + + log "Checking simple cardinality" + assert $ (cardinality :: Cardinality SimpleBounded) == Cardinality 4 + + log "Checking composite cardinality" + assert $ (cardinality :: Cardinality (Option SimpleBounded)) == Cardinality 5 + + log "Checking product cardinality" + assert $ (cardinality :: Cardinality (Pair Bit SimpleBounded)) == Cardinality 8 + + log "Checking simple toEnum/fromEnum roundtrip" + assert $ toEnum (fromEnum A) == Just A + assert $ toEnum (fromEnum B) == Just B + + log "Checking composite toEnum/fromEnum roundtrip" + assert $ toEnum (fromEnum (None :: Option SimpleBounded)) == Just (None :: Option SimpleBounded) + assert $ toEnum (fromEnum (Some A)) == Just (Some A) + + log "Checking product toEnum/fromEnum roundtrip" + assert $ let allPairs = enumFromTo bottom top :: Array (Pair Bit SimpleBounded) + in (toEnum <<< fromEnum <$> allPairs) == (Just <$> allPairs)