Merge pull request #20 from tfausak/gh18-deriving-via

Add `Casting` type for deriving classes via

src/lib/Witch.hs

@@ -159,9 +159,14 @@ module Witch
   , Witch.Lift.liftedCast
   , Witch.Lift.liftedFrom
   , Witch.Lift.liftedInto
+
+  -- * Data types
+  -- ** Casting
+  , Witch.Casting.Casting(Casting)
   ) where
 
 import qualified Witch.Cast
+import qualified Witch.Casting
 import Witch.Instances ()
 import qualified Witch.Lift
 import qualified Witch.TryCast

src/lib/Witch/Casting.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Witch.Casting where
+
+import qualified Data.Bifunctor as Bifunctor
+import qualified Data.Function as Function
+import qualified Witch.Cast as Cast
+
+-- | This type mostly exists to make it easier to derive instances through
+-- some other type. It does this by leaning on the 'Cast.Cast' type class. For
+-- example, consider this data type:
+--
+-- > data Toggle = Off | On
+-- > instance Cast Toggle String where
+-- >   cast toggle = case toggle of
+-- >     Off -> "off"
+-- >     On -> "on"
+--
+-- If you wanted to implement a 'Show' instance for @Toggle@ by going through
+-- a 'String', you would need to write something like this:
+--
+-- > instance Show Toggle where
+-- >   show = show . into @String
+--
+-- That may not very complicated, but at the same time it is not very
+-- interesting. And it can be tricky if you want to keep other instances (like
+-- 'Read') in sync. That's where the 'Casting' type comes in! You can
+-- derive the above instance like so:
+--
+-- > data Toggle = Off | On
+-- >   deriving Show via Casting Toggle String
+newtype Casting source target
+  = Casting source
+
+-- | Uses @coerce@.
+instance Cast.Cast s (Casting s t)
+
+-- | Uses @coerce@.
+instance Cast.Cast (Casting s t) s
+
+instance (Cast.Cast t s, Bounded t) => Bounded (Casting s t) where
+  maxBound = Cast.cast $ Cast.cast @t @s maxBound
+  minBound = Cast.cast $ Cast.cast @t @s minBound
+
+instance (Cast.Cast s t, Cast.Cast t s, Enum t) => Enum (Casting s t) where
+  fromEnum = fromEnum . Cast.cast @s @t . Cast.cast
+  toEnum = Cast.cast . Cast.cast @t @s . toEnum
+
+instance (Cast.Cast s t, Eq t) => Eq (Casting s t) where
+  (==) = Function.on (==) $ Cast.cast @s @t . Cast.cast
+
+instance (Cast.Cast s t, Ord t) => Ord (Casting s t) where
+  compare = Function.on compare $ Cast.cast @s @t . Cast.cast
+
+instance (Cast.Cast t s, Read t) => Read (Casting s t) where
+  readsPrec = fmap (fmap . Bifunctor.first $ Cast.cast . Cast.cast @t @s) . readsPrec
+
+instance (Cast.Cast s t, Show t) => Show (Casting s t) where
+  show = show . Cast.cast @s @t . Cast.cast

src/test/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -23,6 +24,9 @@ import qualified Data.Text.Lazy as LazyText
 import qualified Data.Word as Word
 import qualified Numeric.Natural as Natural
 import qualified Test.Hspec as Hspec
+import qualified Test.Hspec.QuickCheck as Hspec
+import Test.QuickCheck ((===))
+import qualified Text.Read as Read
 import qualified Witch
 
 main :: IO ()
@@ -52,7 +56,7 @@ main = Hspec.hspec . Hspec.describe "Witch" $ do
       test $ Witch.into @Int.Int16 (1 :: Int.Int8) `Hspec.shouldBe` 1
 
     Hspec.describe "over" $ do
-      test $ Witch.over @String (<> "!") (Name "Kiki") `Hspec.shouldBe` Name "Kiki!"
+      test $ Witch.over @Int.Int8 (+ 1) (Age 1) `Hspec.shouldBe` Age 2
 
     Hspec.describe "via" $ do
       test $ Witch.via @Int.Int16 (1 :: Int.Int8) `Hspec.shouldBe` (1 :: Int.Int32)
@@ -1655,6 +1659,46 @@ main = Hspec.hspec . Hspec.describe "Witch" $ do
       let f = Witch.cast @(Witch.TryCastException Bool Int) @LazyText.Text
       test $ f (Witch.TryCastException False Nothing) `Hspec.shouldBe` LazyText.pack "TryCastException @Bool @Int False Nothing"
 
+  -- Casting
+
+  Hspec.describe "Casting" $ do
+
+    Hspec.describe "Bounded" $ do
+
+      Hspec.it "maxBound" $ do
+        maxBound `Hspec.shouldBe` Age maxBound
+
+      Hspec.it "minBound" $ do
+        minBound `Hspec.shouldBe` Age minBound
+
+    Hspec.describe "Enum" $ do
+
+      Hspec.prop "fromEnum" $ \x ->
+        fromEnum (Age x) === fromEnum x
+
+      Hspec.prop "toEnum" $ \x ->
+        toEnum x === Age (toEnum x)
+
+    Hspec.describe "Eq" $ do
+
+      Hspec.prop "==" $ \x ->
+        Age x === Age x
+
+    Hspec.describe "Ord" $ do
+
+      Hspec.prop "compare" $ \x y ->
+        compare (Age x) (Age y) === compare x y
+
+    Hspec.describe "Read" $ do
+
+      Hspec.prop "readMaybe" $ \x ->
+        Read.readMaybe x === fmap Age (Read.readMaybe x)
+
+    Hspec.describe "Show" $ do
+
+      Hspec.prop "show" $ \x ->
+        show (Age x) === show x
+
 test :: Hspec.Example a => a -> Hspec.SpecWith (Hspec.Arg a)
 test = Hspec.it ""
 
@@ -1670,10 +1714,10 @@ data Untested
 
 instance Exception.Exception Untested
 
-newtype Name
-  = Name String
-  deriving (Eq, Show)
+newtype Age
+  = Age Int.Int8
+  deriving (Bounded, Enum, Eq, Ord, Read, Show) via Witch.Casting Age Int.Int8
 
-instance Witch.Cast Name String
+instance Witch.Cast Age Int.Int8
 
-instance Witch.Cast String Name
+instance Witch.Cast Int.Int8 Age

witch.cabal

@@ -46,6 +46,7 @@ library
   exposed-modules:
     Witch
     Witch.Cast
+    Witch.Casting
     Witch.Identity
     Witch.Instances
     Witch.Lift
@@ -67,6 +68,7 @@ test-suite test
 
   build-depends:
     , hspec >= 2.7.9 && < 2.8
+    , QuickCheck >= 2.14.2 && < 2.15
     , witch
   ghc-options:
     -rtsopts