From 857f052db0a72ebdb69f9003a8444c5407f14fb2 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Fri, 30 Apr 2021 02:19:19 +0000 Subject: [PATCH] Add `Casting` type for deriving classes via --- src/lib/Witch.hs | 5 ++++ src/lib/Witch/Casting.hs | 62 ++++++++++++++++++++++++++++++++++++++++ src/test/Main.hs | 56 ++++++++++++++++++++++++++++++++---- witch.cabal | 2 ++ 4 files changed, 119 insertions(+), 6 deletions(-) create mode 100644 src/lib/Witch/Casting.hs diff --git a/src/lib/Witch.hs b/src/lib/Witch.hs index bb9f137..390409a 100644 --- a/src/lib/Witch.hs +++ b/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 diff --git a/src/lib/Witch/Casting.hs b/src/lib/Witch/Casting.hs new file mode 100644 index 0000000..a3e0138 --- /dev/null +++ b/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 diff --git a/src/test/Main.hs b/src/test/Main.hs index 1696d25..cdc0b4a 100644 --- a/src/test/Main.hs +++ b/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 diff --git a/witch.cabal b/witch.cabal index f4f96fa..aa128ad 100644 --- a/witch.cabal +++ b/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