33{-# LANGUAGE DefaultSignatures #-}
44{-# LANGUAGE PolyKinds #-}
55
6- module Data.Spine (HasSpine (.. ), deriveSpine , OfSpine (.. )) where
6+ {- |
7+ Note about design decision on nested spines.
8+ `getSpine (Just Value) = JustSpine ValueSpine` - looks more usable,
9+ than `getSpine (Just Value) = JustSpine`.
10+ But it seem to break deriving for parametised types like `Maybe a`,
11+ and can be done with `fmap getSpine mValue`. Probably it actually
12+ works exaclty for functorial parameters.
13+ -}
14+ module Data.Spine where
715
816import Prelude
917
18+ import Data.Data (Proxy )
19+ import Data.List (elemIndex )
20+ import Data.Map qualified as Map
21+ import Data.Maybe (mapMaybe )
22+ import GHC.Natural (Natural )
23+ import GHC.TypeLits (KnownSymbol , symbolVal )
1024import Language.Haskell.TH
1125import Language.Haskell.TH.Syntax
1226
27+ import PlutusTx (FromData , ToData , UnsafeFromData , unstableMakeIsData )
28+
1329-- | Definitions
1430
1531{- | Spine is datatype, which tags constructors of ADT.
@@ -19,29 +35,66 @@ import Language.Haskell.TH.Syntax
1935class
2036 ( Ord Spine sop )
2137 , Show Spine sop )
38+ , Enum Spine sop )
39+ , Bounded Spine sop )
2240 ) =>
2341 HasSpine sop
2442 where
25- type Spine sop
43+ type Spine sop = spine | spine -> sop
2644 getSpine :: sop -> Spine sop
2745
28- instance (HasSpine sop1 , HasSpine sop2 ) => HasSpine (sop1 , sop2 ) where
29- type Spine (sop1 , sop2 ) = (Spine sop1 , Spine sop2 )
30- getSpine (d1, d2) = (getSpine d1, getSpine d2)
46+ -- | Version of `HasSpine` knowing its Plutus Data encoding
47+ class
48+ ( HasSpine sop
49+ , UnsafeFromData sop
50+ , ToData sop
51+ , FromData sop
52+ ) =>
53+ HasPlutusSpine sop
54+ where
55+ fieldsMap :: Map. MapSpine sop ) [String
56+
57+ toNat :: Int -> Natural
58+ toNat = fromInteger . toInteger
59+
60+ spineFieldsNum :: forall sop . (HasPlutusSpine sop ) => Spine sop -> Natural
61+ spineFieldsNum spine =
62+ toNat $ length $ (fieldsMap @ sop ) Map. !
63+
64+ -- FIXME: use spine do discriminate
65+ fieldNum ::
66+ forall sop label .
67+ (HasPlutusSpine sop , KnownSymbol label ) =>
68+ Proxy label ->
69+ Natural
70+ fieldNum proxyLabel =
71+ head $ mapMaybe fieldIndex x
72+ where
73+ x = Map. elems $ fieldsMap @ sop
74+ fieldName = symbolVal proxyLabel
75+ fieldIndex dict = toNat <$> elemIndex fieldName dict
3176
32- instance (HasSpine sop ) => HasSpine (Maybe sop ) where
33- type Spine (Maybe sop ) = Maybe Spine sop )
34- getSpine = fmap getSpine
77+ allSpines :: forall sop . (HasPlutusSpine sop ) => [Spine sop ]
78+ allSpines = [Prelude. minBound .. Prelude. maxBound ]
3579
36- -- | Newtype encoding sop value of fixed known spine
37- newtype OfSpine (x :: Spine datatype ) = UnsafeMkOfSpine { getValue :: datatype }
80+ -- | Phantom type param is required for `HasSpine` injectivity
81+ data MaybeSpine a = JustSpine | NothingSpine
82+ deriving stock (Eq , Ord , Show , Bounded , Enum )
83+
84+ -- FIXME: could such types be derived?
85+ instance HasSpine (Maybe x ) where
86+ type Spine (Maybe x ) = MaybeSpine x
87+ getSpine Just {} = JustSpine
88+ getSpine Nothing = NothingSpine
89+
90+ -- Deriving utils
3891
39- -- | Deriving utils
4092addSuffix :: Name -> String -> Name
4193addSuffix (Name (OccName name) flavour) suffix =
4294 Name (OccName $ name <> suffix) flavour
4395
44- reifyDatatype :: Name -> Q (Name , [Name ])
96+ -- FIXME: cleaner return type
97+ reifyDatatype :: Name -> Q (Name , [Name ], [[Name ]])
4598reifyDatatype ty = do
4699 (TyConI tyCon) <- reify ty
47100 (name, cs :: [Con ]) <-
@@ -50,7 +103,17 @@ reifyDatatype ty = do
50103 NewtypeD _ n _ _ cs _ -> pure (n, [cs])
51104 _ -> fail " deriveTags: only 'data' and 'newtype' are supported"
52105 csNames <- mapM consName cs
53- return (name, csNames)
106+ csFields <- mapM consFields cs
107+ return (name, csNames, csFields)
108+ where
109+ fieldName (name, _, _) = name
110+ consFields (RecC _ fields) = return $ map fieldName fields
111+ consFields (NormalC _ fields) | length fields == 0 = return []
112+ consFields _ =
113+ fail $
114+ " Spine: only Sum-of-Products are supported, but "
115+ <> show ty
116+ <> " is not"
54117
55118consName :: (MonadFail m ) => Con -> m Name
56119consName cons =
@@ -61,7 +124,7 @@ consName cons =
61124
62125deriveTags :: Name -> String -> [Name ] -> Q [Dec ]
63126deriveTags ty suff classes = do
64- (tyName, csNames) <- reifyDatatype ty
127+ (tyName, csNames, _ ) <- reifyDatatype ty
65128 -- XXX: Quasi-quote splice does not work for case matches list
66129 let cs = map (\ name -> NormalC (addSuffix name suff) [] ) csNames
67130 v =
@@ -70,7 +133,7 @@ deriveTags ty suff classes = do
70133
71134deriveMapping :: Name -> String -> Q Exp
72135deriveMapping ty suff = do
73- (_, csNames) <- reifyDatatype ty
136+ (_, csNames, _ ) <- reifyDatatype ty
74137 -- XXX: Quasi-quote splice does not work for case matches list
75138 let
76139 matches =
@@ -87,9 +150,7 @@ deriveSpine name = do
87150 let
88151 suffix = " Spine"
89152 spineName = addSuffix name suffix
90- spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum, ''Show]
91- -- TODO: derive Sing
92- -- TODO: derive HasField (OfSpine ...)
153+ spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum, ''Show, ''Bounded]
93154
94155 decls <-
95156 [d |
@@ -98,3 +159,19 @@ deriveSpine name = do
98159 getSpine = $(deriveMapping name suffix)
99160 |]
100161 return $ spineDec <> decls
162+
163+ derivePlutusSpine :: Name -> Q [Dec ]
164+ derivePlutusSpine name = do
165+ decls <- deriveSpine name
166+ isDataDecls <- unstableMakeIsData name
167+
168+ (_, _, fieldsNames') <- reifyDatatype name
169+ let fieldsNames = map (map nameBase) fieldsNames'
170+ instanceDecls <-
171+ [d |
172+ instance HasPlutusSpine $(conT name) where
173+ fieldsMap =
174+ Map.fromList $ zip (allSpines @($(conT name))) fieldsNames
175+ |]
176+
177+ return $ decls <> isDataDecls <> instanceDecls
0 commit comments