-
Notifications
You must be signed in to change notification settings - Fork 483
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
[Test] [Builtins] Ensure 'Typeable', 'Lift' etc instances are present #5547
Closed
effectfully
wants to merge
4
commits into
master
from
effectfully/test/builtins/ensure-Typeable-Lift-etc-instances-are-present
Closed
Changes from 1 commit
Commits
Show all changes
4 commits
Select commit
Hold shift + click to select a range
58d7495
[Test] [Builtins] Ensure 'Typeable', 'Lift' etc instances are present
effectfully 79d56d3
[Test] [Builtins] Ensure 'Typeable', 'Lift' etc instances are present
effectfully 91ddee0
Merge branch 'master' of https://github.com/input-output-hk/plutus in…
effectfully 2928b39
Merge branch 'effectfully/test/builtins/ensure-Typeable-Lift-etc-inst…
effectfully File filter
Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change | ||||
---|---|---|---|---|---|---|
@@ -0,0 +1,110 @@ | ||||||
{-# LANGUAGE ConstraintKinds #-} | ||||||
{-# LANGUAGE DataKinds #-} | ||||||
{-# LANGUAGE FlexibleContexts #-} | ||||||
{-# LANGUAGE FlexibleInstances #-} | ||||||
{-# LANGUAGE MultiParamTypeClasses #-} | ||||||
{-# LANGUAGE PolyKinds #-} | ||||||
{-# LANGUAGE QuantifiedConstraints #-} | ||||||
{-# LANGUAGE StandaloneKindSignatures #-} | ||||||
{-# LANGUAGE TypeFamilies #-} | ||||||
{-# LANGUAGE TypeOperators #-} | ||||||
{-# LANGUAGE UndecidableInstances #-} | ||||||
{-# LANGUAGE UndecidableSuperClasses #-} | ||||||
|
||||||
module PlutusTx.Lift.TestInstances () where | ||||||
|
||||||
import PlutusCore qualified as PLC | ||||||
import PlutusCore.Builtin qualified as PLC | ||||||
import PlutusCore.Crypto.BLS12_381.G1 as G1 (Element) | ||||||
import PlutusCore.Crypto.BLS12_381.G2 as G2 (Element) | ||||||
import PlutusCore.Crypto.BLS12_381.Pairing (MlResult) | ||||||
import PlutusCore.Data | ||||||
import PlutusTx.Builtins | ||||||
import PlutusTx.Builtins.Class (FromBuiltin) | ||||||
import PlutusTx.Builtins.Internal (BuiltinBool, BuiltinList, BuiltinPair, BuiltinUnit) | ||||||
import PlutusTx.Lift.Class | ||||||
|
||||||
import Data.ByteString qualified as BS | ||||||
import Data.Kind qualified as GHC | ||||||
import Data.Text qualified as T | ||||||
|
||||||
import Prelude (Bool) | ||||||
|
||||||
-- | A class for converting each type from the universe to its @Builtin*@ counterpart. E.g. | ||||||
-- 'Bool' to 'BuiltinBool'. | ||||||
type IsBuiltin :: (GHC.Type -> GHC.Type) -> GHC.Type -> GHC.Constraint | ||||||
class FromBuiltin (AsBuiltin uni a) a => IsBuiltin uni a where | ||||||
type AsBuiltin uni a | ||||||
|
||||||
type BuiltinSatisfies | ||||||
:: (GHC.Type -> GHC.Constraint) | ||||||
-> (GHC.Type -> GHC.Constraint) | ||||||
-> (GHC.Type -> GHC.Type) | ||||||
-> GHC.Type | ||||||
-> GHC.Constraint | ||||||
class (pre a => post (AsBuiltin uni a)) => BuiltinSatisfies pre post uni a | ||||||
instance (pre a => post (AsBuiltin uni a)) => BuiltinSatisfies pre post uni a | ||||||
|
||||||
type MemberOrGo :: forall a. (a -> GHC.Constraint) -> [a] -> a -> GHC.Constraint | ||||||
type family MemberOrGo constr xs x where | ||||||
MemberOrGo constr '[] x = constr x | ||||||
MemberOrGo constr (x ': _) x = () | ||||||
MemberOrGo constr (_ ': xs) x = MemberOrGo constr xs x | ||||||
|
||||||
-- | @MemberOrGo constr xs x@ means that either @x@ is a member of @xs@ or @constr xs@ holds. | ||||||
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.
Suggested change
|
||||||
type MemberOr :: forall a. (a -> GHC.Constraint) -> [a] -> a -> GHC.Constraint | ||||||
class MemberOrGo constr xs x => MemberOr constr xs x | ||||||
instance MemberOrGo constr xs x => MemberOr constr xs x | ||||||
|
||||||
type AllBuiltinsSatisfyExcluding | ||||||
:: [GHC.Type] | ||||||
-> (GHC.Type -> GHC.Constraint) | ||||||
-> (GHC.Type -> GHC.Constraint) | ||||||
-> (GHC.Type -> GHC.Type) | ||||||
-> GHC.Constraint | ||||||
class uni `PLC.Everywhere` MemberOr (BuiltinSatisfies pre post uni) excl => | ||||||
AllBuiltinsSatisfyExcluding excl pre post uni | ||||||
|
||||||
class Typeable uni (AsBuiltin uni a) => TypeableBuiltin uni a | ||||||
instance Typeable uni (AsBuiltin uni a) => TypeableBuiltin uni a | ||||||
|
||||||
class (PLC.AllBuiltinArgs uni (TypeableBuiltin uni) a, uni `PLC.HasTypeLevel` a) => | ||||||
TypeablePre uni a | ||||||
instance (PLC.AllBuiltinArgs uni (TypeableBuiltin uni) a, uni `PLC.HasTypeLevel` a) => | ||||||
TypeablePre uni a | ||||||
|
||||||
class (PLC.AllBuiltinArgs uni (IsBuiltin uni) a, uni `PLC.HasTermLevel` a) => LiftPre uni a | ||||||
instance (PLC.AllBuiltinArgs uni (IsBuiltin uni) a, uni `PLC.HasTermLevel` a) => LiftPre uni a | ||||||
|
||||||
-------------------- | ||||||
|
||||||
instance IsBuiltin PLC.DefaultUni Integer where | ||||||
type AsBuiltin PLC.DefaultUni Integer = Integer | ||||||
instance IsBuiltin PLC.DefaultUni BS.ByteString where | ||||||
type AsBuiltin PLC.DefaultUni BS.ByteString = BuiltinByteString | ||||||
instance IsBuiltin PLC.DefaultUni T.Text where | ||||||
type AsBuiltin PLC.DefaultUni T.Text = BuiltinString | ||||||
instance IsBuiltin PLC.DefaultUni () where | ||||||
type AsBuiltin PLC.DefaultUni () = BuiltinUnit | ||||||
instance IsBuiltin PLC.DefaultUni Bool where | ||||||
type AsBuiltin PLC.DefaultUni Bool = BuiltinBool | ||||||
instance IsBuiltin PLC.DefaultUni a => IsBuiltin PLC.DefaultUni [a] where | ||||||
type AsBuiltin PLC.DefaultUni [a] = BuiltinList (AsBuiltin PLC.DefaultUni a) | ||||||
instance (IsBuiltin PLC.DefaultUni a, IsBuiltin PLC.DefaultUni b) => | ||||||
IsBuiltin PLC.DefaultUni (a, b) where | ||||||
type AsBuiltin PLC.DefaultUni (a, b) = | ||||||
BuiltinPair (AsBuiltin PLC.DefaultUni a) (AsBuiltin PLC.DefaultUni b) | ||||||
-- No instance for 'Data', because there's no 'FromBuiltin' instance for 'Data' | ||||||
-- (we could add @FromBuiltin Data Data@, but it would be weird to have a pointless instance just | ||||||
-- for the tests here). | ||||||
instance IsBuiltin PLC.DefaultUni G1.Element where | ||||||
type AsBuiltin PLC.DefaultUni G1.Element = BuiltinBLS12_381_G1_Element | ||||||
instance IsBuiltin PLC.DefaultUni G2.Element where | ||||||
type AsBuiltin PLC.DefaultUni G2.Element = BuiltinBLS12_381_G2_Element | ||||||
instance IsBuiltin PLC.DefaultUni MlResult where | ||||||
type AsBuiltin PLC.DefaultUni MlResult = BuiltinBLS12_381_MlResult | ||||||
|
||||||
instance AllBuiltinsSatisfyExcluding | ||||||
'[Data] (LiftPre PLC.DefaultUni) (Lift PLC.DefaultUni) PLC.DefaultUni | ||||||
instance AllBuiltinsSatisfyExcluding | ||||||
'[Data] (TypeablePre PLC.DefaultUni) (Typeable PLC.DefaultUni) PLC.DefaultUni |
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
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.
If this is useful maybe we should just make
FromBuiltin
stronger so it can encompass this?