Merge pull request #14 from purescript/generic-enum

Add classes for Enum deriving

Author: garyb

bower.json

@@ -12,12 +12,14 @@
     "url": "git://github.com/purescript/purescript-generics-rep.git"
   },
   "dependencies": {
-    "purescript-prelude": "^3.0.0",
+    "purescript-enums": "^3.2.1",
+    "purescript-foldable-traversable": "^3.0.0",
     "purescript-monoid": "^3.0.0",
-    "purescript-symbols": "^3.0.0",
-    "purescript-foldable-traversable": "^3.0.0"
+    "purescript-prelude": "^3.0.0",
+    "purescript-symbols": "^3.0.0"
   },
   "devDependencies": {
+    "purescript-assert": "^3.0.0",
     "purescript-console": "^3.0.0"
   }
 }

src/Data/Generic/Rep/Bounded.purs

@@ -9,12 +9,17 @@ module Data.Generic.Rep.Bounded
 
 import Data.Generic.Rep
 
+import Data.Bounded (class Bounded, bottom, top)
+
 class GenericBottom a where
   genericBottom' :: a
 
 instance genericBottomNoArguments :: GenericBottom NoArguments where
   genericBottom' = NoArguments
 
+instance genericBottomArgument :: Bounded a => GenericBottom (Argument a) where
+  genericBottom' = Argument bottom
+
 instance genericBottomSum :: GenericBottom a => GenericBottom (Sum a b) where
   genericBottom' = Inl genericBottom'
 
@@ -27,6 +32,9 @@ class GenericTop a where
 instance genericTopNoArguments :: GenericTop NoArguments where
   genericTop' = NoArguments
 
+instance genericTopArgument :: Bounded a => GenericTop (Argument a) where
+  genericTop' = Argument top
+
 instance genericTopSum :: GenericTop b => GenericTop (Sum a b) where
   genericTop' = Inr genericTop'
 

src/Data/Generic/Rep/Enum.purs

@@ -0,0 +1,95 @@
+module Data.Generic.Rep.Enum 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(..), Sum(..), from, to)
+import Data.Generic.Rep.Bounded (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
+
+-- | 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)
+
+-- | 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

test/Main.purs

@@ -1,13 +1,18 @@
 module Test.Main where
 
 import Prelude
+
 import Control.Monad.Eff (Eff)
-import Control.Monad.Eff.Console (CONSOLE, logShow)
+import Control.Monad.Eff.Console (CONSOLE, log, logShow)
+import Data.Enum (class BoundedEnum, class Enum, Cardinality(..), cardinality, fromEnum, pred, succ, toEnum)
 import Data.Generic.Rep as G
+import Data.Generic.Rep.Bounded as GBounded
+import Data.Generic.Rep.Enum as GEnum
 import Data.Generic.Rep.Eq as GEq
 import Data.Generic.Rep.Ord as GOrd
 import Data.Generic.Rep.Show as GShow
-import Data.Generic.Rep.Bounded as GBounded
+import Data.Maybe (Maybe(..))
+import Test.Assert (ASSERT, assert)
 
 data List a = Nil | Cons { head :: a, tail :: List a }
 
@@ -36,16 +41,98 @@ instance showSimpleBounded :: Show SimpleBounded where
 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
 
-main :: Eff (console :: CONSOLE) Unit
+main :: Eff (console :: CONSOLE, assert :: ASSERT) Unit
 main = do
   logShow (cons 1 (cons 2 Nil))
 
-  logShow (cons 1 (cons 2 Nil) == cons 1 (cons 2 Nil))
-  logShow (cons 1 (cons 2 Nil) == cons 1 Nil)
+  log "Checking equality"
+  assert $ cons 1 (cons 2 Nil) == cons 1 (cons 2 Nil)
+
+  log "Checking inequality"
+  assert $ cons 1 (cons 2 Nil) /= cons 1 Nil
+
+  log "Checking comparison EQ"
+  assert $ (cons 1 (cons 2 Nil) `compare` cons 1 (cons 2 Nil)) == EQ
+
+  log "Checking comparison GT"
+  assert $ (cons 1 (cons 2 Nil) `compare` cons 1 Nil) == GT
+
+  log "Checking comparison LT"
+  assert $ (cons 1 Nil `compare` cons 1 (cons 2 Nil)) == LT
+
+  log "Checking simple bottom"
+  assert $ bottom == A
+
+  log "Checking simple top"
+  assert $ top == D
+
+  log "Checking composite bottom"
+  assert $ bottom == None :: Option SimpleBounded
+
+  log "Checking composite top"
+  assert $ top == Some D
+
+  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 simple cardinality"
+  assert $ (cardinality :: Cardinality SimpleBounded) == Cardinality 4
+
+  log "Checking composite cardinality"
+  assert $ (cardinality :: Cardinality (Option SimpleBounded)) == Cardinality 5
 
-  logShow (cons 1 (cons 2 Nil) `compare` cons 1 (cons 2 Nil))
-  logShow (cons 1 (cons 2 Nil) `compare` cons 1 Nil)
+  log "Checking simple toEnum/fromEnum roundtrip"
+  assert $ toEnum (fromEnum A) == Just A
+  assert $ toEnum (fromEnum B) == Just B
 
-  logShow (bottom :: SimpleBounded)
-  logShow (top :: SimpleBounded)
+  log "Checking composite toEnum/fromEnum roundtrip"
+  assert $ toEnum (fromEnum (None :: Option SimpleBounded)) == Just (None :: Option SimpleBounded)
+  assert $ toEnum (fromEnum (Some A)) == Just (Some A)