[#69] Replace `Wrapped` with custom typeclass that allows `deriving anyclass`

Problem: `Wrapped` is a thing from `lens` which allows understanding newtype content.
It would be nice to replace it with a custom typeclass for a couple of reasons:

1. `Wrapped` cannot be used within `deriving anyclass` clause, one has to declare a
standalone instance, and if we make a copy of `Wrapped` with the type family but without
methods, then the problem will be resolved.

2. Our custom typeclass can be documented, it would be nice to have exact use cases for it
described.

Solution:  Replace `Wrapped` with custom typeclass that is the same as
`Wrapped` without its method.
parent 2cfcd2de
Pipeline #160065545 passed with stages
in 16 minutes and 3 seconds
......@@ -4,7 +4,7 @@ cabal-version: 2.2
--
-- see: https://github.com/sol/hpack
--
-- hash: f55211a075e6c4d90990ff69c17cea961dcf295207e1bbeb5f127b75ecc3c153
-- hash: 70968a0271254e6ec94a6f47dad917925ae7354d41edc2f2f95627be1fd9a0a3
name: lorentz
version: 0.4.0
......@@ -88,6 +88,7 @@ library
Lorentz.UStore.Traversal
Lorentz.UStore.Types
Lorentz.Value
Lorentz.Wrappable
Lorentz.Zip
other-modules:
Paths_lorentz
......
......@@ -27,10 +27,9 @@ module Lorentz.Coercions
, fakeCoercing
-- * Re-exports
, Wrapped (..)
, Wrappable (..)
) where
import Control.Lens (Wrapped(..))
import qualified Data.Coerce as Coerce
import Data.Constraint ((\\))
import qualified GHC.Generics as G
......@@ -43,7 +42,7 @@ import Lorentz.Instr
import Lorentz.Value
import Lorentz.Zip
import Michelson.Typed
import Lorentz.Wrappable (Wrappable(..))
----------------------------------------------------------------------------
-- Unsafe coercions
----------------------------------------------------------------------------
......@@ -89,16 +88,14 @@ fakeCoercing i = fakeCoerce # iForceNotFail i # fakeCoerce
-- | Specialized version of 'coerce_' to wrap into a haskell newtype.
coerceWrap
:: forall newtyp inner s.
(inner ~ Unwrapped newtyp, MichelsonCoercible newtyp (Unwrapped newtyp))
=> inner : s :-> newtyp : s
:: forall a s. Wrappable a
=> Unwrappable a : s :-> a : s
coerceWrap = forcedCoerce_
-- | Specialized version of 'coerce_' to unwrap a haskell newtype.
coerceUnwrap
:: forall newtyp inner s.
(inner ~ Unwrapped newtyp, MichelsonCoercible newtyp (Unwrapped newtyp))
=> newtyp : s :-> inner : s
:: forall a s. Wrappable a
=> a : s :-> Unwrappable a : s
coerceUnwrap = forcedCoerce_
-- | Lift given value to a named value.
......
......@@ -8,20 +8,18 @@ module Lorentz.EntryPoints.Manual
( ParameterWrapper (..)
) where
import Control.Lens (Wrapped)
import qualified Data.Kind as Kind
import Lorentz.Constraints
import Lorentz.EntryPoints.Core
import Michelson.Typed
import Lorentz.Wrappable (Wrappable)
-- | Wrap parameter into this to locally assign a way to derive entrypoints for
-- it.
newtype ParameterWrapper (deriv :: Kind.Type) cp = ParameterWrapper { unParameterWraper :: cp }
deriving stock Generic
deriving anyclass IsoValue
instance Wrapped (ParameterWrapper deriv cp)
deriving anyclass (IsoValue, Wrappable)
-- Helper for implementing @instance ParameterHasEntryPoints [email protected]
data PwDeriv deriv
......
......@@ -79,9 +79,7 @@ import Util.TypeLits
newtype Extensible x = Extensible (Natural, ByteString)
deriving stock (Generic, Eq, Show)
deriving anyclass (IsoValue, HasTypeAnn)
instance Wrapped (Extensible x)
deriving anyclass (IsoValue, HasTypeAnn, Wrappable)
type ExtVal x = (Generic x, GExtVal x (G.Rep x))
type GetCtors x = GGetCtors (G.Rep x)
......
......@@ -86,9 +86,7 @@ type (n :: Symbol) ?: (a :: k) = '(n, a)
-- to one of entry points from @[email protected] list.
newtype UParam (entries :: [EntryPointKind]) = UParamUnsafe (MText, ByteString)
deriving stock (Generic, Eq, Show)
deriving anyclass (IsoValue, HasTypeAnn)
instance Wrapped (UParam entries)
deriving anyclass (IsoValue, HasTypeAnn, Wrappable)
-- Casting to homomorphic value
----------------------------------------------------------------------------
......
......@@ -97,7 +97,7 @@ module Lorentz.UStore.Migration.Base
, formMigrationAtom
) where
import Control.Lens (traversed)
import Control.Lens (iso, traversed)
import qualified Data.Foldable as Foldable
import qualified Data.Kind as Kind
import Data.Singletons (SingI(..), demote)
......@@ -165,9 +165,7 @@ newtype MigrationScript (oldStore :: Kind.Type) (newStore :: Kind.Type) =
MigrationScript
{ unMigrationScript :: Lambda UStore_ UStore_
} deriving stock (Show, Generic)
deriving anyclass (IsoValue, HasTypeAnn)
instance Wrapped (MigrationScript oldStore newStore)
deriving anyclass (IsoValue, HasTypeAnn, Wrappable)
instance (Each [Typeable, UStoreTemplateHasDoc] [oldStore, newStore]) =>
TypeHasDoc (MigrationScript oldStore newStore) where
......@@ -320,7 +318,9 @@ migrationToLambda (UStoreMigration atoms) =
instance MapLorentzInstr (UStoreMigration os ns) where
mapLorentzInstr f (UStoreMigration atoms) =
UStoreMigration $
atoms & traversed . maScriptL . _Wrapped' %~ f
atoms & traversed . maScriptL . wrapped %~ f
where
wrapped = iso unMigrationScript MigrationScript
-- | Modify all code in migration.
mapMigrationCode
......
......@@ -41,7 +41,6 @@ module Lorentz.UStore.Types
, genUStoreFieldExt
) where
import Control.Lens (Wrapped)
import qualified Data.Kind as Kind
import GHC.Generics ((:*:)(..), (:+:)(..))
import qualified GHC.Generics as G
......@@ -51,6 +50,7 @@ import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.QuickCheck (Arbitrary)
import Lorentz.Coercions (Wrappable)
import Lorentz.Pack
import Lorentz.TypeAnns (HasTypeAnn)
import Lorentz.Polymorphic
......@@ -73,9 +73,7 @@ newtype UStore (a :: Kind.Type) = UStore
} deriving stock (Eq, Show, Generic)
deriving newtype (Default, Semigroup, Monoid, IsoValue,
MemOpHs, GetOpHs, UpdOpHs)
deriving anyclass HasTypeAnn
instance Wrapped (UStore a)
deriving anyclass (HasTypeAnn, Wrappable)
-- | Describes one virtual big map in the storage.
newtype k |~> v = UStoreSubMap { unUStoreSubMap :: Map k v }
......
-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ
module Lorentz.Wrappable
( Wrappable
, Unwrappable
) where
import Data.Kind (Type)
import GHC.Generics
import GHC.TypeLits
import Named (NamedF(..))
import Michelson.Typed (ToT)
-- | 'Wrappable' is similar to lens 'Wrapped' class without the method.
-- It provides type family that is mainly used as constraint when
-- unwrapping Lorentz instruction into a Haskell newtype and vice versa.
class ToT s ~ ToT (Unwrappable s) => Wrappable (s :: Type) where
type Unwrappable s :: Type
type Unwrappable s = GUnwrappable (Rep s)
type family GUnwrappable (rep :: Type -> Type) :: Type where
GUnwrappable (D1 ('MetaData _ _ _ 'True) (C1 _ (S1 _ (Rec0 a)))) = a
GUnwrappable _ = TypeError ('Text "Type is not a newtype")
instance Wrappable (NamedF Identity a name) where
type Unwrappable (NamedF Identity a name) = a
instance Wrappable (NamedF Maybe a name) where
type Unwrappable (NamedF Maybe a name) = Maybe a
......@@ -64,9 +64,7 @@ newtype Threshold = Threshold Natural
deriving stock Generic
deriving stock Show
deriving newtype (Num, IsoValue)
deriving anyclass HasTypeAnn
instance Wrapped Threshold
deriving anyclass (HasTypeAnn, Wrappable)
instance TypeHasDoc Threshold where
typeDocName _ = "Multisig.Threshold"
......@@ -101,9 +99,7 @@ newtype Keys = Keys [PublicKey]
deriving stock Generic
deriving stock Show
deriving newtype (IsoValue)
deriving anyclass HasTypeAnn
instance Wrapped Keys
deriving anyclass (HasTypeAnn, Wrappable)
instance TypeHasDoc Keys where
typeDocName _ = "Multisig.Keys"
......
......@@ -146,11 +146,9 @@ newtype UContractRouter (ver :: VersionKind) =
([Operation], VerUStore ver)
}
deriving stock (Generic, Show)
deriving anyclass (IsoValue, HasTypeAnn)
deriving anyclass (IsoValue, HasTypeAnn, Wrappable)
deriving newtype (MapLorentzInstr)
instance Wrapped (UContractRouter ver)
instance ( Typeable ver
, Typeable (VerInterface ver), Typeable (VerUStoreTemplate ver)
, TypeHasDoc (VerUStore ver)
......@@ -214,13 +212,12 @@ newtype PermanentImpl ver = PermanentImpl
}
deriving stock (Generic, Show)
deriving newtype (MapLorentzInstr)
deriving anyclass (Wrappable)
deriving anyclass instance (WellTypedIsoValue (VerPermanent ver)) => IsoValue (PermanentImpl ver)
instance HasTypeAnn (VerPermanent ver) => HasTypeAnn (PermanentImpl ver)
instance Wrapped (PermanentImpl ver)
instance ( Typeable ver, Typeable (VerUStoreTemplate ver)
, TypeHasDoc (VerUStore ver)
, TypeHasDoc (VerPermanent ver), KnownValue (VerPermanent ver)
......
......@@ -65,9 +65,7 @@ type SduEntryPointUntyped store =
newtype SduEntryPoint (store :: Kind.Type) (arg :: Kind.Type) = SduEntryPoint
{ unSduEntryPoint :: SduEntryPointUntyped store
} deriving stock (Eq, Generic)
deriving anyclass IsoValue
instance Wrapped (SduEntryPoint arg store)
deriving anyclass (IsoValue, Wrappable)
instance ( Typeable store, Typeable arg
, TypeHasDoc (UStore store), TypeHasDoc arg
......
......@@ -25,6 +25,7 @@ import Fmt (Buildable(..))
import GHC.TypeLits (KnownSymbol, symbolVal)
import Named ((:!), (:?), Name, NamedF(..))
import qualified Text.Show
import Util.Label (Label)
(.!) :: Name name -> a -> NamedF Identity a name
......@@ -65,14 +66,6 @@ instance KnownNamedFunctor Maybe where
-- Instances
----------------------------------------------------------------------------
instance Wrapped (NamedF Identity a name) where
type Unwrapped (NamedF Identity a name) = a
_Wrapped' = iso (\(ArgF a) -> runIdentity a) (ArgF . Identity)
instance Wrapped (NamedF Maybe a name) where
type Unwrapped (NamedF Maybe a name) = Maybe a
_Wrapped' = iso (\(ArgF a) -> a) ArgF
deriving stock instance Eq (f a) => Eq (NamedF f a name)
deriving stock instance Ord (f a) => Ord (NamedF f a name)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment