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
15+
16+ -- TODO
17+ -- (HasSpine (..), deriveSpine, OfSpine (..))
718
819import Prelude
920
21+ import Data.Data (Proxy )
22+ import Data.List (elemIndex )
23+ import Data.Map qualified as Map
24+ import Data.Maybe (mapMaybe )
25+ import GHC.Natural (Natural )
26+ import GHC.TypeLits (KnownSymbol , SomeSymbol , Symbol , symbolVal )
1027import Language.Haskell.TH
1128import Language.Haskell.TH.Syntax
1229
30+ import PlutusTx (FromData , ToData , UnsafeFromData , unstableMakeIsData )
31+
1332-- | Definitions
1433
1534{- | Spine is datatype, which tags constructors of ADT.
@@ -19,29 +38,66 @@ import Language.Haskell.TH.Syntax
1938class
2039 ( Ord Spine sop )
2140 , Show Spine sop )
41+ , Enum Spine sop )
42+ , Bounded Spine sop )
2243 ) =>
2344 HasSpine sop
2445 where
25- type Spine sop
46+ type Spine sop = spine | spine -> sop
2647 getSpine :: sop -> Spine sop
2748
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)
49+ -- | Version of `HasSpine` knowing its Plutus Data encoding
50+ class
51+ ( HasSpine sop
52+ , UnsafeFromData sop
53+ , ToData sop
54+ , FromData sop
55+ ) =>
56+ HasPlutusSpine sop
57+ where
58+ fieldsMap :: Map. MapSpine sop ) [String
59+
60+ toNat :: Int -> Natural
61+ toNat = fromInteger . toInteger
62+
63+ spineFieldsNum :: forall sop . (HasPlutusSpine sop ) => Spine sop -> Natural
64+ spineFieldsNum spine =
65+ toNat $ length $ (fieldsMap @ sop ) Map. !
66+
67+ -- TODO: use spine do discriminate
68+ fieldNum ::
69+ forall sop label .
70+ (HasPlutusSpine sop , KnownSymbol label ) =>
71+ Proxy label ->
72+ Natural
73+ fieldNum proxyLabel =
74+ head $ mapMaybe fieldIndex x
75+ where
76+ x = Map. elems $ fieldsMap @ sop
77+ fieldName = symbolVal proxyLabel
78+ fieldIndex dict = toNat <$> elemIndex fieldName dict
79+
80+ allSpines :: forall sop . (HasPlutusSpine sop ) => [Spine sop ]
81+ allSpines = [Prelude. minBound .. Prelude. maxBound ]
82+
83+ -- | Phantom type param is required for `HasSpine` injectivity
84+ data MaybeSpine a = JustSpine | NothingSpine
85+ deriving stock (Eq , Ord , Show , Bounded , Enum )
3186
32- instance (HasSpine sop ) => HasSpine (Maybe sop ) where
33- type Spine (Maybe sop ) = Maybe Spine sop )
34- getSpine = fmap getSpine
87+ -- FIXME: could such types be derived?
88+ instance HasSpine (Maybe x ) where
89+ type Spine (Maybe x ) = MaybeSpine x
90+ getSpine Just {} = JustSpine
91+ getSpine Nothing = NothingSpine
3592
36- -- | Newtype encoding sop value of fixed known spine
37- newtype OfSpine (x :: Spine datatype ) = UnsafeMkOfSpine { getValue :: datatype }
93+ -- Deriving utils
3894
39- -- | Deriving utils
4095addSuffix :: Name -> String -> Name
4196addSuffix (Name (OccName name) flavour) suffix =
4297 Name (OccName $ name <> suffix) flavour
4398
44- reifyDatatype :: Name -> Q (Name , [Name ])
99+ -- FIXME: cleaner return type
100+ reifyDatatype :: Name -> Q (Name , [Name ], [[Name ]])
45101reifyDatatype ty = do
46102 (TyConI tyCon) <- reify ty
47103 (name, cs :: [Con ]) <-
@@ -50,7 +106,17 @@ reifyDatatype ty = do
50106 NewtypeD _ n _ _ cs _ -> pure (n, [cs])
51107 _ -> fail " deriveTags: only 'data' and 'newtype' are supported"
52108 csNames <- mapM consName cs
53- return (name, csNames)
109+ csFields <- mapM consFields cs
110+ return (name, csNames, csFields)
111+ where
112+ fieldName (name, _, _) = name
113+ consFields (RecC _ fields) = return $ map fieldName fields
114+ consFields (NormalC _ fields) | length fields == 0 = return []
115+ consFields _ =
116+ fail $
117+ " Spine: only Sum-of-Products are supported, but "
118+ <> show ty
119+ <> " is not"
54120
55121consName :: (MonadFail m ) => Con -> m Name
56122consName cons =
@@ -61,7 +127,7 @@ consName cons =
61127
62128deriveTags :: Name -> String -> [Name ] -> Q [Dec ]
63129deriveTags ty suff classes = do
64- (tyName, csNames) <- reifyDatatype ty
130+ (tyName, csNames, _ ) <- reifyDatatype ty
65131 -- XXX: Quasi-quote splice does not work for case matches list
66132 let cs = map (\ name -> NormalC (addSuffix name suff) [] ) csNames
67133 v =
@@ -70,7 +136,7 @@ deriveTags ty suff classes = do
70136
71137deriveMapping :: Name -> String -> Q Exp
72138deriveMapping ty suff = do
73- (_, csNames) <- reifyDatatype ty
139+ (_, csNames, _ ) <- reifyDatatype ty
74140 -- XXX: Quasi-quote splice does not work for case matches list
75141 let
76142 matches =
@@ -87,9 +153,7 @@ deriveSpine name = do
87153 let
88154 suffix = " Spine"
89155 spineName = addSuffix name suffix
90- spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum, ''Show]
91- -- TODO: derive Sing
92- -- TODO: derive HasField (OfSpine ...)
156+ spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum, ''Show, ''Bounded]
93157
94158 decls <-
95159 [d |
@@ -98,3 +162,19 @@ deriveSpine name = do
98162 getSpine = $(deriveMapping name suffix)
99163 |]
100164 return $ spineDec <> decls
165+
166+ derivePlutusSpine :: Name -> Q [Dec ]
167+ derivePlutusSpine name = do
168+ decls <- deriveSpine name
169+ isDataDecls <- unstableMakeIsData name
170+
171+ (_, _, fieldsNames') <- reifyDatatype name
172+ let fieldsNames = map (map nameBase) fieldsNames'
173+ instanceDecls <-
174+ [d |
175+ instance HasPlutusSpine $(conT name) where
176+ fieldsMap =
177+ Map.fromList $ zip (allSpines @($(conT name))) fieldsNames
178+ |]
179+
180+ return $ decls <> isDataDecls <> instanceDecls
0 commit comments