From 9ed33f463059239e247026c2d5290ac5a2f6c59b Mon Sep 17 00:00:00 2001 From: Chase Date: Tue, 18 Jan 2022 16:59:19 +0530 Subject: [PATCH] Basic scattered cleanup --- Plutarch/Bool.hs | 8 +++++++- Plutarch/Builtin.hs | 13 +++++++++++- Plutarch/ByteString.hs | 8 +++++++- Plutarch/DataRepr.hs | 4 ++-- Plutarch/Integer.hs | 8 +++++++- Plutarch/Internal.hs | 44 ++++++++++++++++++++++++++++++++--------- Plutarch/Lift.hs | 45 ++++++++++++++++++++++++++++++++++++++++-- Plutarch/Monadic.hs | 35 ++++++++++++++++++++++++++++++++ Plutarch/Rec.hs | 12 +++++++++-- Plutarch/String.hs | 8 +++++++- Plutarch/Unit.hs | 8 +++++++- 11 files changed, 172 insertions(+), 21 deletions(-) diff --git a/Plutarch/Bool.hs b/Plutarch/Bool.hs index 0d83d1a84..91c0325a7 100644 --- a/Plutarch/Bool.hs +++ b/Plutarch/Bool.hs @@ -17,7 +17,13 @@ module Plutarch.Bool ( ) where import Plutarch (PlutusType (PInner, pcon', pmatch'), punsafeBuiltin) -import Plutarch.Lift (DerivePConstantViaCoercible (DerivePConstantViaCoercible), PConstant, PLifted, PUnsafeLiftDecl, pconstant) +import Plutarch.Lift ( + DerivePConstantViaCoercible (DerivePConstantViaCoercible), + PConstant, + PLifted, + PUnsafeLiftDecl, + pconstant, + ) import Plutarch.Prelude import qualified PlutusCore as PLC diff --git a/Plutarch/Builtin.hs b/Plutarch/Builtin.hs index 0d2440352..fc7776a72 100644 --- a/Plutarch/Builtin.hs +++ b/Plutarch/Builtin.hs @@ -27,7 +27,18 @@ import Plutarch (PlutusType (..), punsafeBuiltin, punsafeCoerce) import Plutarch.Bool (PBool (..), PEq, pif', (#==)) import Plutarch.ByteString (PByteString) import Plutarch.Integer (PInteger) -import Plutarch.Lift (DerivePConstantViaCoercible (DerivePConstantViaCoercible), PConstant, PConstantRepr, PConstanted, PLift, PLifted, PUnsafeLiftDecl, pconstant, pconstantFromRepr, pconstantToRepr) +import Plutarch.Lift ( + DerivePConstantViaCoercible (DerivePConstantViaCoercible), + PConstant, + PConstantRepr, + PConstanted, + PLift, + PLifted, + PUnsafeLiftDecl, + pconstant, + pconstantFromRepr, + pconstantToRepr, + ) import Plutarch.List (PListLike (..), plistEquals) import Plutarch.Prelude import qualified PlutusCore as PLC diff --git a/Plutarch/ByteString.hs b/Plutarch/ByteString.hs index 281f763e9..e6e790b7b 100644 --- a/Plutarch/ByteString.hs +++ b/Plutarch/ByteString.hs @@ -19,7 +19,13 @@ import GHC.Stack (HasCallStack) import Plutarch (punsafeBuiltin) import Plutarch.Bool (PEq, POrd, (#<), (#<=), (#==)) import Plutarch.Integer (PInteger) -import Plutarch.Lift (DerivePConstantViaCoercible (DerivePConstantViaCoercible), PConstant, PLifted, PUnsafeLiftDecl, pconstant) +import Plutarch.Lift ( + DerivePConstantViaCoercible (DerivePConstantViaCoercible), + PConstant, + PLifted, + PUnsafeLiftDecl, + pconstant, + ) import Plutarch.Prelude import qualified PlutusCore as PLC diff --git a/Plutarch/DataRepr.hs b/Plutarch/DataRepr.hs index 7f907ccb5..e3aa85271 100644 --- a/Plutarch/DataRepr.hs +++ b/Plutarch/DataRepr.hs @@ -58,7 +58,7 @@ pindexDataRepr n = phoistAcyclic $ plet (pasConstr #$ pasData t) $ \d -> let i :: Term _ PInteger = pfstBuiltin # d in pif - (i #== (fromInteger $ toInteger $ natVal $ n)) + (i #== fromInteger (natVal n)) (punsafeCoerce $ psndBuiltin # d :: Term _ (PDataList _)) perror @@ -70,7 +70,7 @@ pindexDataList n = punsafeIndex @PBuiltinList @PData # ind where ind :: Term s PInteger - ind = fromInteger $ toInteger $ natVal n + ind = fromInteger $ natVal n data DataReprHandlers (out :: PType) (def :: [[PType]]) (s :: S) where DRHNil :: DataReprHandlers out '[] s diff --git a/Plutarch/Integer.hs b/Plutarch/Integer.hs index 710d7e4d2..56cd93f6b 100644 --- a/Plutarch/Integer.hs +++ b/Plutarch/Integer.hs @@ -5,7 +5,13 @@ module Plutarch.Integer (PInteger, PIntegral (..)) where import Plutarch (punsafeBuiltin) import Plutarch.Bool (PEq, POrd, pif, (#<), (#<=), (#==)) -import Plutarch.Lift (DerivePConstantViaCoercible (DerivePConstantViaCoercible), PConstant, PLifted, PUnsafeLiftDecl, pconstant) +import Plutarch.Lift ( + DerivePConstantViaCoercible (DerivePConstantViaCoercible), + PConstant, + PLifted, + PUnsafeLiftDecl, + pconstant, + ) import Plutarch.Prelude import qualified PlutusCore as PLC diff --git a/Plutarch/Internal.hs b/Plutarch/Internal.hs index 2891a6dcc..851dda3e8 100644 --- a/Plutarch/Internal.hs +++ b/Plutarch/Internal.hs @@ -82,8 +82,10 @@ data RawTerm hashRawTerm' :: HashAlgorithm alg => RawTerm -> Context alg -> Context alg hashRawTerm' (RVar x) = flip hashUpdate ("0" :: BS.ByteString) . flip hashUpdate (F.flat (fromIntegral x :: Integer)) -hashRawTerm' (RLamAbs n x) = flip hashUpdate ("1" :: BS.ByteString) . flip hashUpdate (F.flat (fromIntegral n :: Integer)) . hashRawTerm' x -hashRawTerm' (RApply x y) = flip hashUpdate ("2" :: BS.ByteString) . hashRawTerm' x . flip (foldl' $ flip hashRawTerm') y +hashRawTerm' (RLamAbs n x) = + flip hashUpdate ("1" :: BS.ByteString) . flip hashUpdate (F.flat (fromIntegral n :: Integer)) . hashRawTerm' x +hashRawTerm' (RApply x y) = + flip hashUpdate ("2" :: BS.ByteString) . hashRawTerm' x . flip (foldl' $ flip hashRawTerm') y hashRawTerm' (RForce x) = flip hashUpdate ("3" :: BS.ByteString) . hashRawTerm' x hashRawTerm' (RDelay x) = flip hashUpdate ("4" :: BS.ByteString) . hashRawTerm' x hashRawTerm' (RConstant x) = flip hashUpdate ("5" :: BS.ByteString) . flip hashUpdate (F.flat x) @@ -105,7 +107,7 @@ mapTerm f (TermResult t d) = TermResult (f t) d mkTermRes :: RawTerm -> TermResult mkTermRes r = TermResult r [] --- | Type of `s`. +-- | Type of `s` in `Term s a`. See: "What is the `s`?" section on the Plutarch guide. data S -- | Shorthand for Plutarch types. @@ -313,10 +315,20 @@ phoistAcyclic t = Term $ \_ -> case asRawTerm t 0 of in TermResult (RHoisted hoisted) (hoisted : getDeps t') Left e -> error $ "Hoisted term errs! " <> show e -rawTermToUPLC :: (HoistedTerm -> Natural -> UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) -> Natural -> RawTerm -> UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun () +rawTermToUPLC :: + (HoistedTerm -> Natural -> UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) -> + Natural -> + RawTerm -> + UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun () rawTermToUPLC _ _ (RVar i) = UPLC.Var () (DeBruijn . Index $ i + 1) -- Why the fuck does it start from 1 and not 0? -rawTermToUPLC m l (RLamAbs n t) = foldr (.) id (replicate (fromIntegral $ n + 1) $ UPLC.LamAbs () (DeBruijn . Index $ 0)) $ (rawTermToUPLC m (l + n + 1) t) -rawTermToUPLC m l (RApply x y) = foldr (.) id ((\y' t -> UPLC.Apply () t (rawTermToUPLC m l y')) <$> y) $ (rawTermToUPLC m l x) +rawTermToUPLC m l (RLamAbs n t) = + foldr + (.) + id + (replicate (fromIntegral $ n + 1) $ UPLC.LamAbs () (DeBruijn . Index $ 0)) + $ (rawTermToUPLC m (l + n + 1) t) +rawTermToUPLC m l (RApply x y) = + foldr (.) id ((\y' t -> UPLC.Apply () t (rawTermToUPLC m l y')) <$> y) $ (rawTermToUPLC m l x) rawTermToUPLC m l (RDelay t) = UPLC.Delay () (rawTermToUPLC m l t) rawTermToUPLC m l (RForce t) = UPLC.Force () (rawTermToUPLC m l t) rawTermToUPLC _ _ (RBuiltin f) = UPLC.Builtin () f @@ -335,13 +347,23 @@ compile' t = f n Nothing = (True, Just n) f _ (Just n) = (False, Just n) - g :: HoistedTerm -> (M.Map Dig Natural, [(Natural, RawTerm)], Natural) -> (M.Map Dig Natural, [(Natural, RawTerm)], Natural) + g :: + HoistedTerm -> + (M.Map Dig Natural, [(Natural, RawTerm)], Natural) -> + (M.Map Dig Natural, [(Natural, RawTerm)], Natural) g (HoistedTerm hash term) (map, defs, n) = case M.alterF (f n) hash map of (True, map) -> (map, (n, term) : defs, n + 1) (False, map) -> (map, defs, n) toInline :: S.Set Dig - toInline = S.fromList . fmap (\(HoistedTerm hash _) -> hash) . (head <$>) . filter ((== 1) . length) . groupBy (\(HoistedTerm x _) (HoistedTerm y _) -> x == y) . sortOn (\(HoistedTerm hash _) -> hash) $ deps + toInline = + S.fromList + . fmap (\(HoistedTerm hash _) -> hash) + . (head <$>) + . filter ((== 1) . length) + . groupBy (\(HoistedTerm x _) (HoistedTerm y _) -> x == y) + . sortOn (\(HoistedTerm hash _) -> hash) + $ deps -- map: term -> de Bruijn level -- defs: the terms, level 0 is last @@ -354,7 +376,11 @@ compile' t = body = rawTermToUPLC map' n t' - wrapped = foldl' (\b (lvl, def) -> UPLC.Apply () (UPLC.LamAbs () (DeBruijn . Index $ 0) b) (rawTermToUPLC map' lvl def)) body defs + wrapped = + foldl' + (\b (lvl, def) -> UPLC.Apply () (UPLC.LamAbs () (DeBruijn . Index $ 0) b) (rawTermToUPLC map' lvl def)) + body + defs in wrapped -- | Compile a (closed) Plutus Term to a usable script diff --git a/Plutarch/Lift.hs b/Plutarch/Lift.hs index b40660923..c340366de 100644 --- a/Plutarch/Lift.hs +++ b/Plutarch/Lift.hs @@ -3,7 +3,22 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} -module Plutarch.Lift (PConstant (..), PUnsafeLiftDecl (..), PLift, pconstant, plift, plift', LiftError, DerivePConstantViaCoercible (..), DerivePConstantViaNewtype (..)) where +module Plutarch.Lift ( + -- * Converstion between Plutarch terms and Haskell types + pconstant, + plift, + plift', + LiftError, + + -- * Define your own conversion + PConstant (..), + PLift, + DerivePConstantViaCoercible (..), + DerivePConstantViaNewtype (..), + + -- * Internal use + PUnsafeLiftDecl (..), +) where import Data.Coerce import Data.Kind (Type) @@ -19,14 +34,31 @@ import qualified UntypedPlutusCore as UPLC class (PConstant (PLifted p), PConstanted (PLifted p) ~ p) => PUnsafeLiftDecl (p :: PType) where type PLifted p :: Type +{- | Class of Haskell types `h` that can be represented as a Plutus core builtin +and converted to a Plutarch type. + +The Plutarch type is determined by `PConstanted h`. Its Plutus Core representation is given by `PConstantRepr h`. + +This typeclass is closely tied with 'PLift'. +-} class (PUnsafeLiftDecl (PConstanted h), PLC.DefaultUni `PLC.Includes` PConstantRepr h) => PConstant (h :: Type) where type PConstantRepr h :: Type type PConstanted h :: PType pconstantToRepr :: h -> PConstantRepr h pconstantFromRepr :: PConstantRepr h -> Maybe h +{- | Class of Plutarch types `p` that can be converted to/from a Haskell type. + +The Haskell type is determined by `PLifted p`. + +This typeclass is closely tied with 'PConstant'. +-} type PLift = PUnsafeLiftDecl +{- | Create a Plutarch-level constant, from a Haskell value. +Example: +> pconstant @PInteger 42 +-} pconstant :: forall p s. PLift p => PLifted p -> Term s p pconstant x = punsafeConstantInternal $ PLC.someValue @(PConstantRepr (PLifted p)) @PLC.DefaultUni $ pconstantToRepr x @@ -38,6 +70,9 @@ data LiftError | LiftError_WrongRepr deriving stock (Eq, Show) +{- | Convert a Plutarch term to the associated Haskell value. Fail otherwise. +This will fully evaluate the arbitrary closed expression, and convert the resulting value. +-} plift' :: forall p. PUnsafeLiftDecl p => ClosedTerm p -> Either LiftError (PLifted p) plift' prog = case evaluateScript (compile prog) of Right (_, _, Scripts.unScript -> UPLC.Program _ _ term) -> @@ -48,19 +83,25 @@ plift' prog = case evaluateScript (compile prog) of Left e -> Left $ LiftError_EvalException e Left e -> Left $ LiftError_ScriptError e +-- | Like `plift'` but fails on error. plift :: forall p. (HasCallStack, PLift p) => ClosedTerm p -> (PLifted p) plift prog = case plift' prog of Right x -> x Left e -> error $ "plift failed: " <> show e +-- TODO: Add haddock newtype DerivePConstantViaCoercible (h :: Type) (p :: PType) (r :: Type) = DerivePConstantViaCoercible h -instance (PLift p, Coercible h r, PLC.DefaultUni `PLC.Includes` r) => PConstant (DerivePConstantViaCoercible h p r) where +instance + (PLift p, Coercible h r, PLC.DefaultUni `PLC.Includes` r) => + PConstant (DerivePConstantViaCoercible h p r) + where type PConstantRepr (DerivePConstantViaCoercible h p r) = r type PConstanted (DerivePConstantViaCoercible h p r) = p pconstantToRepr = coerce pconstantFromRepr = Just . coerce +-- TODO: Add haddock newtype DerivePConstantViaNewtype (h :: Type) (p :: PType) (p' :: PType) = DerivePConstantViaNewtype h instance (PLift p, PLift p', Coercible h (PLifted p')) => PConstant (DerivePConstantViaNewtype h p p') where diff --git a/Plutarch/Monadic.hs b/Plutarch/Monadic.hs index d7a5781f7..484d44fe7 100644 --- a/Plutarch/Monadic.hs +++ b/Plutarch/Monadic.hs @@ -6,11 +6,46 @@ import Data.String (fromString) import Plutarch.Prelude import Plutarch.Trace (ptraceError) +{- | Bind function used within do syntax. + +Enables elegant usage of 'pmatch' and similar. + +@ + import qualified Plutarch.Monadic as P + + f :: Term s (PTxInfo :--> PBuiltinList (PAsData PTxInInfo)) + f = plam $ \x -> P.do + PTxInfo txInfoFields <- pmatch x + pfromData $ pdhead # txInfoFields +@ +-} (>>=) :: (x -> Term s a) -> x -> Term s a (>>=) = id +{- | Forgetful bind function used within do syntax. + +Enables elegant usage of 'ptrace' and similar. + +@ + import qualified Plutarch.Monadic as P + + P.do + ptrace "yielding unit" + pconstant () +@ +-} (>>) :: (x -> Term s a) -> x -> Term s a (>>) = id +{- | Implicitly invoked upon pattern match failure within do syntax. + +@ + import qualified Plutarch.Monadic as P + + P.do + -- calls 'P.fail', traces an error message, and invokes 'perror'. + PTrue <- pconstant False +@ +-} fail :: String -> Term s a fail msg = ptraceError (fromString msg) diff --git a/Plutarch/Rec.hs b/Plutarch/Rec.hs index 0f34c5b01..6e47a01ad 100644 --- a/Plutarch/Rec.hs +++ b/Plutarch/Rec.hs @@ -60,7 +60,11 @@ pletrec :: forall r s. (Rank2.Distributive r, Rank2.Traversable r) => (r (Term s pletrec = punsafeCoerce . letrec -- | Recursive let construct, tying into knot the recursive equations specified in the record fields. -letrec :: forall r s t. (Rank2.Distributive r, Rank2.Traversable r) => (r (Term s) -> r (Term s)) -> Term s (ScottEncoding r t) +letrec :: + forall r s t. + (Rank2.Distributive r, Rank2.Traversable r) => + (r (Term s) -> r (Term s)) -> + Term s (ScottEncoding r t) letrec r = Term term where term n = TermResult {getTerm = RApply rfix [RLamAbs 1 $ RApply (RVar 0) $ rawTerms], getDeps = deps} @@ -188,4 +192,8 @@ fieldCount = getSum . Rank2.foldMap (const $ Sum 1) rfix :: RawTerm -- The simplest variant of the Y combinator hangs the interpreter, so we use an eta-expanded version instead. -- rfix = RLamAbs 0 $ RApply (RLamAbs 0 $ RApply (RVar 1) [RApply (RVar 0) [RVar 0]]) [RLamAbs 0 $ RApply (RVar 1) [RApply (RVar 0) [RVar 0]]] -rfix = RLamAbs 0 $ RApply (RLamAbs 0 $ RApply (RVar 1) [RLamAbs 0 $ RApply (RVar 1) [RVar 0, RVar 1]]) [RLamAbs 0 $ RApply (RVar 1) [RLamAbs 0 $ RApply (RVar 1) [RVar 0, RVar 1]]] +rfix = + RLamAbs 0 $ + RApply + (RLamAbs 0 $ RApply (RVar 1) [RLamAbs 0 $ RApply (RVar 1) [RVar 0, RVar 1]]) + [RLamAbs 0 $ RApply (RVar 1) [RLamAbs 0 $ RApply (RVar 1) [RVar 0, RVar 1]]] diff --git a/Plutarch/String.hs b/Plutarch/String.hs index ff4d36edd..fde0d6331 100644 --- a/Plutarch/String.hs +++ b/Plutarch/String.hs @@ -9,7 +9,13 @@ import qualified Data.Text as Txt import Plutarch (punsafeBuiltin) import Plutarch.Bool (PEq, (#==)) import Plutarch.ByteString (PByteString) -import Plutarch.Lift (DerivePConstantViaCoercible (DerivePConstantViaCoercible), PConstant, PLifted, PUnsafeLiftDecl, pconstant) +import Plutarch.Lift ( + DerivePConstantViaCoercible (DerivePConstantViaCoercible), + PConstant, + PLifted, + PUnsafeLiftDecl, + pconstant, + ) import Plutarch.Prelude import qualified PlutusCore as PLC diff --git a/Plutarch/Unit.hs b/Plutarch/Unit.hs index 0a254668d..5f1460887 100644 --- a/Plutarch/Unit.hs +++ b/Plutarch/Unit.hs @@ -5,7 +5,13 @@ module Plutarch.Unit (PUnit (..)) where import Plutarch (PlutusType (PInner, pcon', pmatch'), Term, pcon) import Plutarch.Bool (PBool (PFalse, PTrue), PEq, POrd, (#<), (#<=), (#==)) -import Plutarch.Lift (DerivePConstantViaCoercible (DerivePConstantViaCoercible), PConstant, PLifted, PUnsafeLiftDecl, pconstant) +import Plutarch.Lift ( + DerivePConstantViaCoercible (DerivePConstantViaCoercible), + PConstant, + PLifted, + PUnsafeLiftDecl, + pconstant, + ) data PUnit s = PUnit instance PUnsafeLiftDecl PUnit where type PLifted PUnit = ()