Add a Rep type function for Generic

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
 

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
 

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
 

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

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

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
 

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

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))