diff --git a/source/library/Witch.hs b/source/library/Witch.hs index 1822d3f..9eeaafb 100644 --- a/source/library/Witch.hs +++ b/source/library/Witch.hs @@ -302,6 +302,7 @@ where import qualified Witch.Encoding import qualified Witch.From +import Witch.Generic () import Witch.Instances () import qualified Witch.Lift import qualified Witch.TryFrom diff --git a/source/library/Witch/Generic.hs b/source/library/Witch/Generic.hs new file mode 100644 index 0000000..4a78fc1 --- /dev/null +++ b/source/library/Witch/Generic.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Witch.Generic where + +import qualified GHC.Generics as Generics +import qualified Witch.From as From + +-- | This type class is used to implement generic conversions using the 'Generics.Generically' helper. +-- This is an advanced use case. +-- Most users will not need to know about this type class. +-- And even for those that want to derive 'Generics.Generically', this type class should be an implementation detail. +-- +-- This type class can convert between any two types as long as they have 'Generics.Generic' instances and they are structurally similar. +-- For example, if you define your own empty type you could convert it to the typical 'Data.Void.Void' type: +-- +-- > data Empty deriving Generic +-- > deriving via Generically Void instance From Empty Void +-- +-- Or your own unit type: +-- +-- > data Unit = MkUnit deriving Generic +-- > deriving via Generically () instance From Unit () +-- +-- Note that this looks superficially similar to @newtype Unit = MkUnit ()@ together with @instance From Unit ()@, but that goes through 'Data.Coerce.Coercible' and requires the types to be representationally equal. +-- This approach (with 'Generics.Generically') only requires the types to be /structurally/ equal. +-- In this case, @Unit@ is structurally equal to @()@ since they both have a single constructor with no arguments. +-- +-- This also works with arbitrary sum types, like a custom pair type: +-- +-- > data Pair a b = MkPair a b deriving Generic +-- > deriving via Generically (Pair c d) +-- > instance (From a c, From b d) => From (a, b) (Pair c d) +-- +-- Note that this can also convert the type variables as long as they have 'From.From' instances as well. +-- This allows converting from @(Int, Int)@ to @Pair Integer Integer@ in one step, for example. +-- +-- And this works with arbitrary product types as well: +-- +-- > data Result a b = Failure a | Success b deriving Generic +-- > deriving via Generically (Result c d) +-- > instance (From a c, From b d) => From (Either a b) (Result c d) +-- +-- Note that these conversions are all /structural/ not semantic. +-- That means if you had defined @Result@ as @Success b | Failure a@, then converting from 'Either' would be "wrong". +-- 'Left' would convert into @Success@ and 'Right' would convert into @Failure@. +class GFrom s t where + gFrom :: s x -> t x + +instance GFrom Generics.V1 Generics.V1 where + gFrom = id + +instance GFrom Generics.U1 Generics.U1 where + gFrom = id + +instance (From.From s t) => GFrom (Generics.K1 a s) (Generics.K1 b t) where + gFrom = Generics.K1 . From.from . Generics.unK1 + +instance (GFrom s t) => GFrom (Generics.M1 a b s) (Generics.M1 c d t) where + gFrom = Generics.M1 . gFrom . Generics.unM1 + +instance (GFrom s1 t1, GFrom s2 t2) => GFrom (s1 Generics.:+: s2) (t1 Generics.:+: t2) where + gFrom x = case x of + Generics.L1 l -> Generics.L1 $ gFrom l + Generics.R1 r -> Generics.R1 $ gFrom r + +instance (GFrom s1 t1, GFrom s2 t2) => GFrom (s1 Generics.:*: s2) (t1 Generics.:*: t2) where + gFrom (l Generics.:*: r) = gFrom l Generics.:*: gFrom r + +-- | See the 'GFrom' type class for an explanation of this instance. +instance + ( Generics.Generic s, + Generics.Generic t, + GFrom (Generics.Rep s) (Generics.Rep t) + ) => + From.From s (Generics.Generically t) + where + from = Generics.Generically . Generics.to . gFrom . Generics.from diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index 1020854..bf89871 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -1,6 +1,9 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-error=overflowed-literals #-} @@ -28,7 +31,10 @@ import qualified Data.Time as Time import qualified Data.Time.Clock.POSIX as Time import qualified Data.Time.Clock.System as Time import qualified Data.Time.Clock.TAI as Time +import qualified Data.Tuple as Tuple +import qualified Data.Void as Void import qualified Data.Word as Word +import qualified GHC.Generics as Generics import qualified GHC.Stack as Stack import qualified Numeric.Natural as Natural import qualified Test.HUnit as HUnit @@ -64,7 +70,7 @@ spec = describe "Witch" $ do describe "over" $ do it "works" $ do - Utility.over @Int.Int8 (+ 1) (Age 1) `shouldBe` Age 2 + Utility.over @Int.Int8 (+ 1) (MkAge 1) `shouldBe` MkAge 2 describe "via" $ do it "works" $ do @@ -2439,8 +2445,86 @@ spec = describe "Witch" $ do it "works" $ do f "a" `shouldBe` Tagged.Tagged (LazyByteString.pack [0x00, 0x00, 0x00, 0x61]) + describe "Generically" $ do + it "converts into empty" $ do + -- This only needs to type check. + let _ = Witch.from @Void.Void @Empty + pure () + + it "converts into unit" $ do + let f = Witch.from @() @Unit + f () `shouldBe` MkUnit + + it "converts into only" $ do + let f = Witch.from @(Tuple.Solo Int) @(Only Integer) + f (Tuple.MkSolo 1) `shouldBe` MkOnly 1 + + it "converts into pair" $ do + let f = Witch.from @(Int, Int.Int8) @(Pair Integer Age) + f (1, 2) `shouldBe` MkPair 1 (MkAge 2) + + it "converts into result" $ do + let f = Witch.from @(Either Int Int.Int8) @(Result Integer Age) + f (Left 1) `shouldBe` Failure 1 + f (Right 2) `shouldBe` Success (MkAge 2) + + it "converts into list" $ do + let f = Witch.from @[Int] @(List Integer) + f [] `shouldBe` Nil + f [1] `shouldBe` Cons 1 Nil + f [1, 2] `shouldBe` Cons 1 (Cons 2 Nil) + +data Empty + deriving (Generics.Generic) + +deriving via Generics.Generically Empty instance Witch.From Void.Void Empty + +data Unit + = MkUnit + deriving (Eq, Generics.Generic, Show) + +deriving via Generics.Generically Unit instance Witch.From () Unit + +newtype Only a + = MkOnly a + deriving (Eq, Generics.Generic, Show) + +deriving via + Generics.Generically (Only b) + instance + (Witch.From a b) => Witch.From (Tuple.Solo a) (Only b) + +data Pair a b + = MkPair a b + deriving (Eq, Generics.Generic, Show) + +deriving via + Generics.Generically (Pair c d) + instance + (Witch.From a c, Witch.From b d) => Witch.From (a, b) (Pair c d) + +data Result a b + = Failure a + | Success b + deriving (Eq, Generics.Generic, Show) + +deriving via + Generics.Generically (Result c d) + instance + (Witch.From a c, Witch.From b d) => Witch.From (Either a b) (Result c d) + +data List a + = Nil + | Cons a (List a) + deriving (Eq, Generics.Generic, Show) + +deriving via + Generics.Generically (List b) + instance + (Witch.From a b) => Witch.From [a] (List b) + newtype Age - = Age Int.Int8 + = MkAge Int.Int8 deriving (Eq, Show) instance Witch.From Age Int.Int8 diff --git a/witch.cabal b/witch.cabal index cff0849..147fa30 100644 --- a/witch.cabal +++ b/witch.cabal @@ -70,6 +70,7 @@ library Witch Witch.Encoding Witch.From + Witch.Generic Witch.Instances Witch.Lift Witch.TryFrom