-
Notifications
You must be signed in to change notification settings - Fork 63
/
DataRepr.hs
158 lines (136 loc) · 5.37 KB
/
DataRepr.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans -Wno-redundant-constraints #-}
module Plutarch.DataRepr (
PDataRepr,
punDataRepr,
pindexDataRepr,
pmatchDataRepr,
DataReprHandlers (..),
PDataList,
pdhead,
pdtail,
PIsDataRepr (..),
PIsDataReprInstances (..),
punsafeIndex,
pindexDataList,
DerivePConstantViaData (..),
) where
import Data.List (groupBy, maximumBy, sortOn)
import Data.Proxy (Proxy)
import GHC.TypeLits (KnownNat, Nat, natVal, type (-))
import Plutarch (Dig, PMatch, TermCont, hashOpenTerm, punsafeBuiltin, punsafeCoerce, runTermCont)
import Plutarch.Bool (pif, (#==))
import Plutarch.Builtin (
PAsData,
PBuiltinList,
PData,
PIsData,
pasConstr,
pdata,
pfromData,
pfstBuiltin,
psndBuiltin,
)
import Plutarch.Integer (PInteger)
import Plutarch.Lift (PConstant, PConstantRepr, PConstanted, PLift, pconstantFromRepr, pconstantToRepr)
import Plutarch.List (punsafeIndex)
import Plutarch.Prelude
import qualified Plutus.V1.Ledger.Api as Ledger
import qualified PlutusCore as PLC
data PDataList (as :: [PType]) (s :: S)
pdhead :: Term s (PDataList (a : as) :--> PAsData a)
pdhead = phoistAcyclic $ pforce $ punsafeBuiltin PLC.HeadList
pdtail :: Term s (PDataList (a : as) :--> PDataList as)
pdtail = phoistAcyclic $ pforce $ punsafeBuiltin PLC.TailList
type PDataRepr :: [[PType]] -> PType
data PDataRepr (defs :: [[PType]]) (s :: S)
pasData :: Term s (PDataRepr _) -> Term s PData
pasData = punsafeCoerce
type family IndexList (n :: Nat) (l :: [k]) :: k where
IndexList 0 (x ': _) = x
IndexList n (x : xs) = IndexList (n - 1) xs
punDataRepr :: Term s (PDataRepr '[def] :--> PDataList def)
punDataRepr = phoistAcyclic $
plam $ \t ->
plet (pasConstr #$ pasData t) $ \d ->
(punsafeCoerce $ psndBuiltin # d :: Term _ (PDataList def))
pindexDataRepr :: (KnownNat n) => Proxy n -> Term s (PDataRepr (def : defs) :--> PDataList (IndexList n (def : defs)))
pindexDataRepr n = phoistAcyclic $
plam $ \t ->
plet (pasConstr #$ pasData t) $ \d ->
let i :: Term _ PInteger = pfstBuiltin # d
in pif
(i #== fromInteger (natVal n))
(punsafeCoerce $ psndBuiltin # d :: Term _ (PDataList _))
perror
-- | Safely index a DataList
pindexDataList :: (KnownNat n) => Proxy n -> Term s (PDataList xs :--> PAsData (IndexList n xs))
pindexDataList n =
phoistAcyclic $
punsafeCoerce $
punsafeIndex @PBuiltinList @PData # ind
where
ind :: Term s PInteger
ind = fromInteger $ natVal n
data DataReprHandlers (out :: PType) (def :: [[PType]]) (s :: S) where
DRHNil :: DataReprHandlers out '[] s
DRHCons :: (Term s (PDataList def) -> Term s out) -> DataReprHandlers out defs s -> DataReprHandlers out (def : defs) s
pmatchDataRepr :: Term s (PDataRepr (def : defs)) -> DataReprHandlers out (def : defs) s -> Term s out
pmatchDataRepr d handlers =
plet (pasConstr #$ pasData d) $ \d' ->
plet (pfstBuiltin # d') $ \constr ->
plet (psndBuiltin # d') $ \args ->
let handlers' = applyHandlers args handlers
in runTermCont (findCommon handlers') $ \common ->
go
common
0
handlers'
constr
where
hashHandlers :: [Term s out] -> TermCont s [(Dig, Term s out)]
hashHandlers [] = pure []
hashHandlers (handler : rest) = do
hash <- hashOpenTerm handler
hashes <- hashHandlers rest
pure $ (hash, handler) : hashes
findCommon :: [Term s out] -> TermCont s (Dig, Term s out)
findCommon handlers = do
l <- hashHandlers handlers
pure $ head . maximumBy (\x y -> length x `compare` length y) . groupBy (\x y -> fst x == fst y) . sortOn fst $ l
applyHandlers :: Term s (PBuiltinList PData) -> DataReprHandlers out defs s -> [Term s out]
applyHandlers _ DRHNil = []
applyHandlers args (DRHCons handler rest) = handler (punsafeCoerce args) : applyHandlers args rest
go ::
(Dig, Term s out) ->
Integer ->
[Term s out] ->
Term s PInteger ->
Term s out
go common _ [] _ = snd common
go common idx (handler : rest) constr =
runTermCont (hashOpenTerm handler) $ \hhash ->
if hhash == fst common
then go common (idx + 1) rest constr
else
pif
(fromInteger idx #== constr)
handler
$ go common (idx + 1) rest constr
newtype PIsDataReprInstances (a :: PType) (s :: S) = PIsDataReprInstances (a s)
class (PMatch a, PIsData a) => PIsDataRepr (a :: PType) where
type PIsDataReprRepr a :: [[PType]]
pmatchRepr :: forall s b. Term s (PDataRepr (PIsDataReprRepr a)) -> (a s -> Term s b) -> Term s b
instance PIsDataRepr a => PIsData (PIsDataReprInstances a) where
pdata = punsafeCoerce
pfromData = punsafeCoerce
instance PIsDataRepr a => PMatch (PIsDataReprInstances a) where
pmatch x f = pmatchRepr (punsafeCoerce x) (f . PIsDataReprInstances)
newtype DerivePConstantViaData (h :: Type) (p :: PType) = DerivePConstantViaData h
instance (PIsDataRepr p, PLift p, Ledger.FromData h, Ledger.ToData h) => PConstant (DerivePConstantViaData h p) where
type PConstantRepr (DerivePConstantViaData h p) = Ledger.Data
type PConstanted (DerivePConstantViaData h p) = p
pconstantToRepr (DerivePConstantViaData x) = Ledger.toData x
pconstantFromRepr x = DerivePConstantViaData <$> Ledger.fromData x