diff --git a/src/Libraries/Base1/CShow.bs b/src/Libraries/Base1/CShow.bs index f0e8a59e9..12f6f54d2 100644 --- a/src/Libraries/Base1/CShow.bs +++ b/src/Libraries/Base1/CShow.bs @@ -56,7 +56,7 @@ instance (CShow a) => CShowTuple a where cshowTuple = cshow -- Default generic instance uses the CShow' type class over generic representations -instance (Generic a r, CShow' r) => CShow a where +instance (CShow' (Rep a)) => CShow a where cshow x = cshow' $ from x cshowP x = cshowP' $ from x diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index 4a2b65ba5..3dce90181 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -866,7 +866,7 @@ instance PrimDeepSeqCond (a -> b) where -- for each constructor arg, calling primDeepSeqCond (if the type arguments -- are known), or primSeqCond (if they are not known) in which case the -- correct function is called at elaboation time. -instance (Generic a r, PrimDeepSeqCond' r) => PrimDeepSeqCond a where +instance (PrimDeepSeqCond' (Rep a)) => PrimDeepSeqCond a where primDeepSeqCond x = primDeepSeqCond' (from x) class PrimDeepSeqCond' r where @@ -3975,8 +3975,8 @@ instance PrimMakeUninitialized (a -> b) where primMakeUninitialized = primMakeRawUninitialized -- Default generic instance covers data and structs -instance (Generic a r, PrimMakeUninitialized' a r) => PrimMakeUninitialized a where - primMakeUninitialized pos f = primMakeUninitialized' ((error "proxy") :: r) pos f +instance (PrimMakeUninitialized' a (Rep a)) => PrimMakeUninitialized a where + primMakeUninitialized pos f = primMakeUninitialized' ((error "proxy") :: Rep a) pos f -- Extra intermediate helper type class allows coherent dispatch on number of constructors class PrimMakeUninitialized' a r where @@ -3989,7 +3989,7 @@ class PrimMakeUninitialized' a r where -- constructor: a struct value is returned with uninitialized values in its -- fields. -- -instance (Generic a r, PrimMakeUninitialized'' r) => +instance (PrimMakeUninitialized'' (Rep a)) => PrimMakeUninitialized' a (Meta (MetaData n p ta 1) r') where primMakeUninitialized' _ pos f = to $ primMakeUninitialized'' False pos f @@ -4124,8 +4124,8 @@ instance PrimMakeUndefined (Array a) where primMakeUndefined = primMakeRawUndefined -- Default generic instance covers data and structs -instance (Generic a r, PrimMakeUndefined' a r) => PrimMakeUndefined a where - primMakeUndefined pos i = primMakeUndefined' ((error "proxy") :: r) pos i +instance (PrimMakeUndefined' a (Rep a)) => PrimMakeUndefined a where + primMakeUndefined pos i = primMakeUndefined' ((error "proxy") :: Rep a) pos i -- Extra intermediate helper type class allows coherent dispatch on number of constructors class PrimMakeUndefined' a r where @@ -4135,7 +4135,7 @@ class PrimMakeUndefined' a r where -- The derived instance for structs is like for data types with a single -- constructor: a struct value is returned with undefined values in its -- fields. -instance (Generic a r, PrimMakeUndefined'' r) => +instance (PrimMakeUndefined'' (Rep a)) => PrimMakeUndefined' a (Meta (MetaData n p ta 1) r') where primMakeUndefined' _ pos i = to $ primMakeUndefined'' pos i @@ -4526,6 +4526,7 @@ instance (Literal t) => DefaultValue t where -- Representable types of kind * class Generic a r | a -> r where + type Rep a = r from :: a -> r to :: r -> a diff --git a/src/Libraries/Base1/SShow.bs b/src/Libraries/Base1/SShow.bs index 7749ba5ba..1eb6d18a1 100644 --- a/src/Libraries/Base1/SShow.bs +++ b/src/Libraries/Base1/SShow.bs @@ -73,7 +73,7 @@ instance (SShow a) => SShowTuple a where sshowTuple = sshow -- Default generic instance uses the SShow' type class over generic representations -instance (Generic a r, SShow' r) => SShow a where +instance (SShow' (Rep a)) => SShow a where sshow x = sshow' $ from x sshowP x = sshowP' $ from x diff --git a/src/Libraries/Base1/SplitPorts.bs b/src/Libraries/Base1/SplitPorts.bs index dd15071f8..01c82f1ae 100644 --- a/src/Libraries/Base1/SplitPorts.bs +++ b/src/Libraries/Base1/SplitPorts.bs @@ -34,11 +34,10 @@ class ShallowSplitPorts a p | a -> p where shallowUnsplitPorts :: p -> a shallowSplitPortNames :: a -> String -> List String -instance (Generic a r, ShallowSplitPorts' r p) => - ShallowSplitPorts a p where +instance (ShallowSplitPorts' (Rep a) p) => ShallowSplitPorts a p where shallowSplitPorts = shallowSplitPorts' ∘ from shallowUnsplitPorts = to ∘ shallowUnsplitPorts' - shallowSplitPortNames _ = shallowSplitPortNames' (_ :: r) + shallowSplitPortNames _ = shallowSplitPortNames' (_ :: (Rep a)) class ShallowSplitPorts' r p | r -> p where shallowSplitPorts' :: r -> p @@ -132,10 +131,10 @@ instance (DeepSplitPorts a p) => DeepSplitTuplePorts a p where deepSplitTuplePortNames i _ base = deepSplitPortNames (_ :: a) $ base +++ "_" +++ integerToString i -instance (Generic a r, DeepSplitPorts' r a p) => DeepSplitPorts a p where - deepSplitPorts = deepSplitPorts' (_ :: r) - deepUnsplitPorts = deepUnsplitPorts' (_ :: r) - deepSplitPortNames = deepSplitPortNames' (_ :: r) +instance (DeepSplitPorts' (Rep a) a p) => DeepSplitPorts a p where + deepSplitPorts = deepSplitPorts' (_ :: Rep a) + deepUnsplitPorts = deepUnsplitPorts' (_ :: Rep a) + deepSplitPortNames = deepSplitPortNames' (_ :: Rep a) class DeepSplitPorts' r a p | r a -> p where deepSplitPorts' :: r -> a -> p @@ -149,10 +148,10 @@ instance (SplitPorts a p) => DeepSplitPorts' r a p where deepSplitPortNames' _ = portNames -- Recurse into the fields of a struct -instance (Generic a r, DeepSplitPorts'' r p) => DeepSplitPorts' (Meta (MetaData name pkg args 1) r') a p where +instance (DeepSplitPorts'' (Rep a) p) => DeepSplitPorts' (Meta (MetaData name pkg args 1) r') a p where deepSplitPorts' _ = deepSplitPorts'' ∘ from deepUnsplitPorts' _ = to ∘ deepUnsplitPorts'' - deepSplitPortNames' _ _ = deepSplitPortNames'' (_ :: r) + deepSplitPortNames' _ _ = deepSplitPortNames'' (_ :: Rep a) class DeepSplitPorts'' r p | r -> p where deepSplitPorts'' :: r -> p diff --git a/testsuite/bsc.typechecker/generics/CPrintType.bs b/testsuite/bsc.typechecker/generics/CPrintType.bs index 87f3a971d..bfe3539a5 100644 --- a/testsuite/bsc.typechecker/generics/CPrintType.bs +++ b/testsuite/bsc.typechecker/generics/CPrintType.bs @@ -22,9 +22,9 @@ instance (CPrintType a, CPrintTuple b) => CPrintTuple (a, b) where instance (CPrintType a) => CPrintTuple a where cPrintTuple = cPrintType -instance (Generic a r, CPrintType' r) => CPrintType a where - cPrintType _ = cPrintType' (_ :: r) - cPrintTypeP _ = cPrintTypeP' (_ :: r) +instance (CPrintType' (Rep a)) => CPrintType a where + cPrintType _ = cPrintType' (_ :: Rep a) + cPrintTypeP _ = cPrintTypeP' (_ :: Rep a) class CPrintType' a where cPrintType' :: a -> String @@ -77,8 +77,8 @@ instance CPrintTypeArg OtherConArg where class CPrintConType c where cPrintConType :: c -> String -instance (Generic c r, CPrintConType' r) => CPrintConType c where - cPrintConType _ = cPrintConType' (_ :: r) +instance (CPrintConType' (Rep c)) => CPrintConType c where + cPrintConType _ = cPrintConType' (_ :: Rep c) class CPrintConType' r where cPrintConType' :: r -> String diff --git a/testsuite/bsc.typechecker/generics/CustomBits.bs b/testsuite/bsc.typechecker/generics/CustomBits.bs index ee4c12b47..e8a3c8da5 100644 --- a/testsuite/bsc.typechecker/generics/CustomBits.bs +++ b/testsuite/bsc.typechecker/generics/CustomBits.bs @@ -14,7 +14,7 @@ instance MyBits (Bit n) n where myunpack = id -- Generic default instance -instance (Generic a r, MyBits' r n) => MyBits a n where +instance (MyBits' (Rep a) n) => MyBits a n where mypack x = mypack' $ from x myunpack bs = to $ myunpack' bs diff --git a/testsuite/bsc.typechecker/generics/GenericNegativeTests.bs b/testsuite/bsc.typechecker/generics/GenericNegativeTests.bs index 607b38129..a133231dc 100644 --- a/testsuite/bsc.typechecker/generics/GenericNegativeTests.bs +++ b/testsuite/bsc.typechecker/generics/GenericNegativeTests.bs @@ -33,7 +33,7 @@ class Trans a where instance Trans (UInt n) where trans x = x + 1 -instance (Generic a r, Trans' r) => Trans a where +instance (Trans' (Rep a)) => Trans a where trans = to `compose` trans' `compose` from class Trans' r where diff --git a/testsuite/bsc.typechecker/generics/GenericTests.bs b/testsuite/bsc.typechecker/generics/GenericTests.bs index 0eceaf2ce..0555dcfd6 100644 --- a/testsuite/bsc.typechecker/generics/GenericTests.bs +++ b/testsuite/bsc.typechecker/generics/GenericTests.bs @@ -55,6 +55,8 @@ instance FShow Kax where fshow (K2 x) = $format "K2 " x -- Test generic representations +-- Not using the Rep type function here because we want the error message to +-- show the expanded type when there is a mismatch. fooRepr :: (Generic Foo r) => TypeEq r (Meta (MetaData "Foo" "GenericTests" () 4) (Either @@ -145,7 +147,7 @@ class Trans a where instance Trans (UInt n) where trans x = x + 1 -instance (Generic a r, Trans' r) => Trans a where +instance (Trans' (Rep a)) => Trans a where trans = to `compose` trans' `compose` from class Trans' r where @@ -168,7 +170,7 @@ instance (Trans a) => Trans' (Conc a) where trans' (Conc x) = Conc $ trans x -- Test to/from -actTestGeneric :: (Generic a r, FShow a, FShow r, Eq a) => a -> Action +actTestGeneric :: (FShow a, FShow (Rep a), Eq a) => a -> Action actTestGeneric x = do $display "Representation for " (fshow x) $display (fshow (from x))