diff --git a/generics-sop/src/Generics/SOP.hs b/generics-sop/src/Generics/SOP.hs index 9b13241..f85ccb5 100644 --- a/generics-sop/src/Generics/SOP.hs +++ b/generics-sop/src/Generics/SOP.hs @@ -227,6 +227,10 @@ module Generics.SOP ( , ProductCode , productTypeFrom , productTypeTo + , IsSumType + , SumCode + , sumTypeFrom + , sumTypeTo , IsEnumType , enumTypeFrom , enumTypeTo diff --git a/generics-sop/src/Generics/SOP/Universe.hs b/generics-sop/src/Generics/SOP/Universe.hs index 4b67a48..4633fbb 100644 --- a/generics-sop/src/Generics/SOP/Universe.hs +++ b/generics-sop/src/Generics/SOP/Universe.hs @@ -185,6 +185,47 @@ productTypeTo :: IsProductType a xs => NP I xs -> a productTypeTo = to . SOP . Z {-# INLINE productTypeTo #-} +-- | Constraint that captures that a datatype is a (simple) sum type, +-- i.e., a type with some number of constructors, each of which +-- has a single argument. +-- +-- It also gives access to the list of types which make up the union. +-- +-- @since 0.5.2.0 +-- +type IsSumType (a :: Type) (xs :: [Type]) = + (Generic a, AllZip IsSingletonOf xs (Code a)) + +-- | Direct access to the list of types that makes up a sum type. +-- +-- @since 0.5.2.0 +-- +type SumCode (a :: Type) = Heads (Code a) + +-- | Convert from a sum type to its sum representation. +-- +-- @since 0.5.2.0 +-- +sumTypeTo :: IsSumType a xs => a -> NS I xs +sumTypeTo = go . unSOP . from + where + go :: AllZip IsSingletonOf xs xss => NS (NP I) xss -> NS I xs + go (Z (x :* Nil)) = Z x + go (S xss) = S $ go xss +{-# INLINE sumTypeTo #-} + +-- | Convert a sum representation to the original type. +-- +-- @since 0.5.2.0 +-- +sumTypeFrom :: IsSumType a xs => NS I xs -> a +sumTypeFrom = to . SOP . go + where + go :: AllZip IsSingletonOf xs xss => NS I xs -> NS (NP I) xss + go (Z x) = Z (x :* Nil) + go (S xss) = S $ go xss +{-# INLINE sumTypeFrom #-} + -- | Constraint that captures that a datatype is an enumeration type, -- i.e., none of the constructors have any arguments. -- @@ -201,7 +242,7 @@ enumTypeFrom :: IsEnumType a => a -> NS (K ()) (Code a) enumTypeFrom = map_NS (const (K ())) . unSOP . from {-# INLINE enumTypeFrom #-} --- | Convert a sum representation to ihe original type. +-- | Convert a enum representation to ihe original type. -- enumTypeTo :: IsEnumType a => NS (K ()) (Code a) -> a enumTypeTo = to . SOP . cmap_NS (Proxy :: Proxy ((~) '[])) (const Nil) diff --git a/generics-sop/test/Example.hs b/generics-sop/test/Example.hs index f10c3d8..01a19b6 100644 --- a/generics-sop/test/Example.hs +++ b/generics-sop/test/Example.hs @@ -8,6 +8,12 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Main (main, toTreeC, toDataFamC) where @@ -206,6 +212,22 @@ instance Enumerable ABCC where instance Enumerable VoidC where enum = fmap toVoidC genumS +-- Use with derving via: much better than trying to write an overlapping +-- `(xs ~ SumCode a, IsSumType a xs, All Show xs) => Show a` instance +newtype AsSum a = AsSum a +instance (xs ~ SumCode a, IsSumType a xs, All Show xs) => Show (AsSum a) where + show (AsSum a) = go @xs $ sumTypeTo a + where + go :: (All Show xs') => NS I xs' -> String + go (Z (I x)) = show x + go (S xss) = go xss + +data UnionType = C1 Tree | C2 TreeB + deriving stock (GHC.Generic) + -- Use anyclass deriving via GHC generics to fit this all in one deriving clause + deriving anyclass (Generic) + deriving Show via (AsSum UnionType) + -- Tests main :: IO () main = do @@ -238,3 +260,5 @@ main = do print (voidDatatypeInfo == demotedVoidDatatypeInfo) print (dataFamDatatypeInfo == demotedDataFamDatatypeInfo) print $ convertFull tree + print $ C1 $ Leaf 1 + print $ C2 $ LeafB 2 diff --git a/sop-core/src/Data/SOP/Constraint.hs b/sop-core/src/Data/SOP/Constraint.hs index 80d65e4..e15cb50 100644 --- a/sop-core/src/Data/SOP/Constraint.hs +++ b/sop-core/src/Data/SOP/Constraint.hs @@ -210,6 +210,16 @@ type family type family Head (xs :: [a]) :: a where Head (x ': xs) = x +-- We can't do this with a 'Map' family and 'Head' without unsaturated type families. + +-- | Utility function to compute the heads of a type-level lists of type-level lists. +-- +-- @since 0.5.2.0 +-- +type family Heads (xss :: [[k]]) :: [k] where + Heads '[] = '[] + Heads (x ': xs) = Head x ': Heads xs + -- | Utility function to compute the tail of a type-level list. -- -- @since 0.3.1.0 @@ -284,3 +294,11 @@ type family AllZipN (h :: (k -> Type) -> (l -> Type)) (c :: k1 -> k2 -> Constrai -- on whether the argument is indexed by a list or a list of lists. -- type family SListIN (h :: (k -> Type) -> (l -> Type)) :: l -> Constraint + +-- | Constraint that captures that a type-level list is a singleton of the given element. +-- +-- This is a class rather than a type synonym so it can be passed as a type argument to types that take +-- a constraint, such as 'AllZip'. +-- +class (as ~ '[a]) => IsSingletonOf (a :: k) (as :: [k]) +instance (as ~ '[a]) => IsSingletonOf (a :: k) (as :: [k])