-
Notifications
You must be signed in to change notification settings - Fork 158
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Make tests polymorphic over the Value type #1913
Changes from all commits
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -19,6 +19,7 @@ flag development | |
library | ||
exposed-modules: | ||
Cardano.Ledger.Core | ||
Cardano.Ledger.Compactible | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. 👍 |
||
Cardano.Ledger.Crypto | ||
Cardano.Ledger.Era | ||
Cardano.Ledger.Shelley | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,49 @@ | ||
{-# LANGUAGE FlexibleContexts #-} | ||
{-# LANGUAGE FlexibleInstances #-} | ||
{-# LANGUAGE StandaloneDeriving #-} | ||
{-# LANGUAGE TypeFamilies #-} | ||
{-# LANGUAGE UndecidableInstances #-} | ||
|
||
module Cardano.Ledger.Compactible | ||
( -- * Compactible | ||
Compactible (..), | ||
Compact (..), | ||
) | ||
where | ||
|
||
import Cardano.Binary (FromCBOR (..), ToCBOR (..)) | ||
import Data.Kind (Type) | ||
import Data.Typeable (Typeable) | ||
|
||
-------------------------------------------------------------------------------- | ||
|
||
-- * Compactible | ||
|
||
-- | ||
-- Certain types may have a "presentation" form and a more compact | ||
-- representation that allows for more efficient memory usage. In this case, | ||
-- one should make instances of the 'Compactible' class for them. | ||
-------------------------------------------------------------------------------- | ||
|
||
class Compactible a where | ||
data CompactForm a :: Type | ||
toCompact :: a -> CompactForm a | ||
fromCompact :: CompactForm a -> a | ||
|
||
newtype Compact a = Compact {unCompact :: a} | ||
|
||
instance | ||
(Typeable a, Compactible a, ToCBOR (CompactForm a)) => | ||
ToCBOR (Compact a) | ||
where | ||
toCBOR = toCBOR . toCompact . unCompact | ||
|
||
instance | ||
(Typeable a, Compactible a, FromCBOR (CompactForm a)) => | ||
FromCBOR (Compact a) | ||
where | ||
fromCBOR = Compact . fromCompact <$> fromCBOR | ||
|
||
-- TODO: consider if this is better the other way around | ||
instance (Eq a, Compactible a) => Eq (CompactForm a) where | ||
a == b = fromCompact a == fromCompact b |
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -1,5 +1,7 @@ | ||
{-# LANGUAGE FlexibleContexts #-} | ||
{-# LANGUAGE FlexibleInstances #-} | ||
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
{-# LANGUAGE StandaloneDeriving #-} | ||
{-# LANGUAGE TypeFamilies #-} | ||
{-# LANGUAGE UndecidableInstances #-} | ||
|
||
|
@@ -11,53 +13,65 @@ | |
-- It is intended for qualified import: | ||
-- > import qualified Cardano.Ledger.Core as Core | ||
module Cardano.Ledger.Core | ||
( -- * Compactible | ||
Compactible (..), | ||
Compact (..), | ||
TxBody, | ||
Value, | ||
( TxBody, | ||
Value (..), | ||
VALUE, | ||
) | ||
where | ||
|
||
import Cardano.Binary (FromCBOR (..), ToCBOR (..)) | ||
import Cardano.Ledger.Compactible | ||
import Cardano.Ledger.Val (Val) | ||
import Control.DeepSeq (NFData) | ||
import Data.Group (Abelian, Group) | ||
import Data.Kind (Type) | ||
import Data.PartialOrd (PartialOrd (..)) | ||
import Data.Typeable (Typeable) | ||
import NoThunks.Class (NoThunks) | ||
|
||
-- | A value is something which quantifies a transaction output. | ||
type family Value era :: Type | ||
type family VALUE era :: Type | ||
|
||
-- | The body of a transaction. | ||
type family TxBody era :: Type | ||
|
||
-------------------------------------------------------------------------------- | ||
-- Wrap the type family as a newtype because : | ||
-- the genericShrink has something that | ||
-- detects that the immediate subterms of a type are the same as the parent type | ||
-- when there is a type family in that position, the instance resolution fails | ||
newtype Value era = Value {unVl :: VALUE era} | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Ah, I see. Somehow I seem to have got around this issue in #1908, though in honesty I haven't the foggiest how. It seems an unfortunate hack, so I'd hope we could avoid it, but maybe that just causes more trouble... There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. I think it is because you have put There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. maybe rewrite the shrinker to a manual shrinker? to avoid this There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. leaving shrinker as is for now |
||
|
||
-- * Compactible | ||
deriving instance (Typeable (VALUE era)) => Typeable (Value era) | ||
|
||
-- | ||
-- Certain types may have a "presentation" form and a more compact | ||
-- representation that allows for more efficient memory usage. In this case, | ||
-- one should make instances of the 'Compactible' class for them. | ||
-------------------------------------------------------------------------------- | ||
|
||
class Compactible a where | ||
data CompactForm a :: Type | ||
toCompact :: a -> CompactForm a | ||
fromCompact :: CompactForm a -> a | ||
|
||
newtype Compact a = Compact {unCompact :: a} | ||
|
||
instance | ||
(Typeable a, Compactible a, ToCBOR (CompactForm a)) => | ||
ToCBOR (Compact a) | ||
where | ||
toCBOR = toCBOR . toCompact . unCompact | ||
|
||
instance | ||
(Typeable a, Compactible a, FromCBOR (CompactForm a)) => | ||
FromCBOR (Compact a) | ||
where | ||
fromCBOR = Compact . fromCompact <$> fromCBOR | ||
|
||
-- TODO: consider if this is better the other way around | ||
instance (Eq a, Compactible a) => Eq (CompactForm a) where | ||
a == b = fromCompact a == fromCompact b | ||
deriving instance (ToCBOR (VALUE era), Typeable era) => ToCBOR (Value era) | ||
|
||
deriving instance (FromCBOR (VALUE era), Typeable era) => FromCBOR (Value era) | ||
|
||
deriving instance (Eq (VALUE era)) => Eq (Value era) | ||
|
||
deriving instance (Show (VALUE era)) => Show (Value era) | ||
|
||
deriving instance (NoThunks (VALUE era)) => NoThunks (Value era) | ||
|
||
deriving instance (NFData (VALUE era)) => NFData (Value era) | ||
|
||
deriving instance (Val (VALUE era)) => Val (Value era) | ||
|
||
deriving instance (Abelian (VALUE era)) => Abelian (Value era) | ||
|
||
deriving instance (PartialOrd (VALUE era)) => PartialOrd (Value era) | ||
|
||
deriving instance (Group (VALUE era)) => Group (Value era) | ||
|
||
deriving instance (Monoid (VALUE era)) => Monoid (Value era) | ||
|
||
deriving instance (Semigroup (VALUE era)) => Semigroup (Value era) | ||
|
||
deriving instance (ToCBOR (CompactForm (VALUE era)), Typeable era) => ToCBOR (CompactForm (Value era)) | ||
|
||
deriving instance (FromCBOR (CompactForm (VALUE era)), Typeable era) => FromCBOR (CompactForm (Value era)) | ||
|
||
instance (Compactible (VALUE era)) => Compactible (Value era) where | ||
newtype CompactForm (Value era) = ValueC (CompactForm (VALUE era)) | ||
toCompact (Value v) = ValueC (toCompact v) | ||
fromCompact (ValueC v) = Value (fromCompact v) |
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Why is
Value
now in ALLCAPS?There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
ha! we (Alex, Tim and I) discussed type families being in all caps (there is already some attempt to make this a convention it looks like from before), then wrapped in a newtype.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
leaving for this PR