Skip to content

Commit e7f5327

Browse files
nc6Soupstraw
nc6
authored and
Soupstraw
committed
Generics, take 2
This commit adds an alternative attempt at generics. It has both advantages and disadvantages. The principal advantage is that it really allows generics to work with HuddleM - see the example in example/Monad.hs for a demonstration. The previous way of writing this was quite horrible. There are two main disadvantages: - Now, rather than treating a generic function as a regular Haskell function, we have to treat it specially and call it with the special syntax (<--). - Only one generic parameter is supported. We can potentially fix this, but it's always going to play unkindly with the (<--) syntax. That having been said, we had only implemented up to two parameters before. For these reasons, these new-style generics are currently implemented alongside the existing ones for consideration.
1 parent 70675b5 commit e7f5327

File tree

5 files changed

+134
-23
lines changed

5 files changed

+134
-23
lines changed

‎cuddle.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,7 @@ library
5151
Codec.CBOR.Cuddle.CDDL.Prelude
5252
Codec.CBOR.Cuddle.CDDL.Resolve
5353
Codec.CBOR.Cuddle.Huddle
54+
Codec.CBOR.Cuddle.Huddle.Generic
5455
Codec.CBOR.Cuddle.Huddle.HuddleM
5556
Codec.CBOR.Cuddle.Huddle.Optics
5657
Codec.CBOR.Cuddle.Parser

‎example/Monad.hs‎

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -19,8 +19,8 @@ spec = huddleDef $ mdo
1919
transaction <-
2020
"transaction"
2121
=:= mp
22-
[ idx 0 ==> set txIn
23-
, idx 1 ==> set txOut
22+
[ idx 0 ==> set txIn,
23+
idx 1 ==> set' <-- txOut
2424
]
2525
txIn <- "txIn" =:= arr ["transaction_id" ==> hash32, "index" ==> txId]
2626
txOut <- "txOut" =:= arr [idx 0 ==> address, idx 1 ==> value]
@@ -29,6 +29,7 @@ spec = huddleDef $ mdo
2929
hash32 <- "hash32" =:= VBytes `sized` (32 :: Word64)
3030
value <- "value" =:= VUInt
3131
set <- include hdl_set
32+
set' <- binding' $ \x -> "set'" Huddle.=:= arr [0 <+ a x]
3233

3334
setRootRules [transaction]
3435

@@ -37,15 +38,15 @@ spec2 =
3738
spec
3839
<> huddleDef
3940
( mdo
40-
set <- include hdl_set
41+
set <- unsafeIncludeFromHuddle spec "set'"
4142
txIn <- unsafeIncludeFromHuddle spec "txIn"
4243
txOut <- unsafeIncludeFromHuddle spec "txOut"
4344
_transaction <-
4445
"transaction"
4546
=:= mp
46-
[ comment "Transaction inputs" $ idx 0 ==> set txIn
47-
, comment "Transaction outputs" $ idx 1 ==> set txOut
48-
, comment "Metadata" $ idx 2 ==> metadata
47+
[ comment "Transaction inputs" $ idx 0 ==> set <-- txIn,
48+
comment "Transaction outputs" $ idx 1 ==> set <-- txOut,
49+
comment "Metadata" $ idx 2 ==> metadata
4950
]
5051
metadata <- "metadata" =:= VBytes
5152
_value <- "value" =:= mp ["token" ==> VText, "quantity" ==> VUInt]

‎src/Codec/CBOR/Cuddle/Huddle.hs‎

Lines changed: 89 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@
88
{-# LANGUAGE TypeApplications #-}
99
{-# LANGUAGE TypeFamilies #-}
1010
{-# LANGUAGE UndecidableInstances #-}
11+
{-# LANGUAGE ViewPatterns #-}
1112
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
1213

1314
-- | Module for building CDDL in Haskell
@@ -76,10 +77,14 @@ module Codec.CBOR.Cuddle.Huddle (
7677
-- * Generics
7778
GRef,
7879
GRuleDef,
80+
GRuleDef',
7981
GRuleCall,
82+
GRuleCall',
8083
binding,
8184
binding2,
85+
binding',
8286
callToDef,
87+
(<--),
8388

8489
-- * Conversion to CDDL
8590
collectFrom,
@@ -91,6 +96,7 @@ where
9196
import Codec.CBOR.Cuddle.CDDL (CDDL, TopLevel (..), WithComments (..))
9297
import Codec.CBOR.Cuddle.CDDL qualified as C
9398
import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
99+
import Codec.CBOR.Cuddle.Huddle.Generic (FnWithArg (..), result)
94100
import Control.Monad (when)
95101
import Control.Monad.State (MonadState (get), execState, modify)
96102
import Data.ByteString (ByteString)
@@ -128,6 +134,7 @@ type Rule = Named Type0
128134
data HuddleItem
129135
= HIRule Rule
130136
| HIGRule GRuleDef
137+
| HIGRule' GRuleDef'
131138
| HIGroup (Named Group)
132139
deriving (Generic, Show)
133140

@@ -273,6 +280,7 @@ data Type2
273280
| T2Group (Named Group)
274281
| -- | Call to a generic rule, binding arguments
275282
T2Generic GRuleCall
283+
| T2Generic' GRuleCall'
276284
| -- | Reference to a generic parameter within the body of the definition
277285
T2GenericRef GRef
278286
deriving (Show)
@@ -475,9 +483,12 @@ sized v sz =
475483
[]
476484

477485
class IsCborable a
486+
478487
instance IsCborable ByteString
479-
instance IsCborable (AnyRef a)
480-
instance IsCborable GRef
488+
489+
instance IsCborable CRef
490+
491+
instance IsCborable CGRef
481492

482493
cbor :: (IsCborable b, IsConstrainable c b) => c -> Rule -> Constrained
483494
cbor v r@(Named n _ _) =
@@ -493,9 +504,12 @@ cbor v r@(Named n _ _) =
493504
[r]
494505

495506
class IsComparable a
507+
496508
instance IsComparable Int
497-
instance IsComparable (AnyRef a)
498-
instance IsComparable GRef
509+
510+
instance IsComparable CRef
511+
512+
instance IsComparable CGRef
499513

500514
le :: (IsComparable a, IsConstrainable c a) => c -> Word64 -> Constrained
501515
le v bound =
@@ -605,6 +619,9 @@ instance IsType0 (Named Group) where
605619
instance IsType0 GRuleCall where
606620
toType0 = NoChoice . T2Generic
607621

622+
instance IsType0 GRuleCall' where
623+
toType0 = NoChoice . T2Generic'
624+
608625
instance IsType0 GRef where
609626
toType0 = NoChoice . T2GenericRef
610627

@@ -617,6 +634,9 @@ instance IsType0 HuddleItem where
617634
toType0 (HIGRule g) =
618635
error $
619636
"Attempt to reference generic rule from HuddleItem not supported: " <> show g
637+
toType0 (HIGRule' g) =
638+
error $
639+
"Attempt to reference generic rule from HuddleItem not supported: " <> show g
620640

621641
class CanQuantify a where
622642
-- | Apply a lower bound
@@ -933,6 +953,50 @@ binding2 fRule t0 t1 =
933953
NoChoice x -> x
934954
_ -> error "Cannot use a choice of types as a generic argument"
935955

956+
--------------------------------------------------------------------------------
957+
-- Generics (Take 2)
958+
--------------------------------------------------------------------------------
959+
960+
type GRuleDef' = Named (FnWithArg GRef Type0)
961+
962+
data GRuleCallAux = GRuleCallAux
963+
{ defFn :: FnWithArg GRef Type0,
964+
callArg :: Type2
965+
}
966+
967+
type GRuleCall' = Named GRuleCallAux
968+
969+
binding' :: (GRef -> Rule) -> GRuleDef'
970+
binding' fRule =
971+
Named
972+
(getField @"name" $ result defFn)
973+
(getField @"value" <$> defFn)
974+
Nothing
975+
where
976+
defFn = FnWithArg fRule (freshName 0)
977+
978+
class IsGRuleDef f where
979+
toGRuleDef :: f -> GRuleDef'
980+
981+
instance IsGRuleDef GRuleDef' where
982+
toGRuleDef = id
983+
984+
instance IsGRuleDef HuddleItem where
985+
toGRuleDef (HIGRule' gd) = gd
986+
toGRuleDef _ = error "Attempt to use a non-generic rule as a GRuleDef"
987+
988+
(<--) :: (IsType0 t0, IsGRuleDef gd) => gd -> t0 -> GRuleCall'
989+
(toGRuleDef -> f) <-- t0 = fmap toCall f
990+
where
991+
toCall rd =
992+
GRuleCallAux
993+
{ defFn = rd,
994+
callArg = t2
995+
}
996+
t2 = case toType0 t0 of
997+
NoChoice x -> x
998+
_ -> error "Cannot use a choice of types as a generic argument"
999+
9361000
--------------------------------------------------------------------------------
9371001
-- Collecting all top-level rules
9381002
--------------------------------------------------------------------------------
@@ -1022,6 +1086,7 @@ toCDDL' mkPseudoRoot hdl =
10221086
toCDDLItem (HIRule r) = toCDDLRule r
10231087
toCDDLItem (HIGroup g) = toCDDLGroup g
10241088
toCDDLItem (HIGRule g) = toGenRuleDef g
1089+
toCDDLItem (HIGRule' g) = toGenRuleDef' g
10251090
toTopLevelPseudoRoot :: [Rule] -> C.WithComments C.Rule
10261091
toTopLevelPseudoRoot topRs =
10271092
toCDDLRule $
@@ -1084,6 +1149,7 @@ toCDDL' mkPseudoRoot hdl =
10841149
T2Ref (Named n _ _) -> C.Type1 (C.T2Name (C.Name n) Nothing) Nothing
10851150
T2Group (Named n _ _) -> C.Type1 (C.T2Name (C.Name n) Nothing) Nothing
10861151
T2Generic g -> C.Type1 (toGenericCall g) Nothing
1152+
T2Generic' g -> C.Type1 (toGenericCall' g) Nothing
10871153
T2GenericRef (GRef n) -> C.Type1 (C.T2Name (C.Name n) Nothing) Nothing
10881154

10891155
toMemberKey :: Key -> C.MemberKey
@@ -1158,6 +1224,12 @@ toCDDL' mkPseudoRoot hdl =
11581224
(C.Name n)
11591225
(Just . C.GenericArg $ fmap toCDDLType1 (args gr))
11601226

1227+
toGenericCall' :: GRuleCall' -> C.Type2
1228+
toGenericCall' (Named n gr _) =
1229+
C.T2Name
1230+
(C.Name n)
1231+
(Just . C.GenericArg $ NE.singleton (toCDDLType1 (callArg gr)))
1232+
11611233
toGenRuleDef :: GRuleDef -> C.WithComments C.Rule
11621234
toGenRuleDef (Named n gr c) =
11631235
C.WithComments
@@ -1170,3 +1242,16 @@ toCDDL' mkPseudoRoot hdl =
11701242
where
11711243
gps =
11721244
C.GenericParam $ fmap (\(GRef t) -> C.Name t) (args gr)
1245+
1246+
toGenRuleDef' :: GRuleDef' -> C.WithComments C.Rule
1247+
toGenRuleDef' (Named n g c) =
1248+
C.WithComments
1249+
( C.Rule (C.Name n) (Just gps) C.AssignEq
1250+
. C.TOGType
1251+
$ C.Type0
1252+
$ toCDDLType1 <$> choiceToNE (fn g (arg g))
1253+
)
1254+
(C.comment <$> c)
1255+
where
1256+
gps =
1257+
C.GenericParam $ fmap (\(GRef t) -> C.Name t) (NE.singleton $ arg g)

‎src/Codec/CBOR/Cuddle/Huddle/Generic.hs‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
module Codec.CBOR.Cuddle.Huddle.Generic where
2+
3+
-- | Function carrying its argument
4+
data FnWithArg a result = FnWithArg
5+
{ fn :: a -> result,
6+
arg :: a
7+
}
8+
deriving (Functor)
9+
10+
-- | Evaluate a function carrying its argument to its result
11+
result :: FnWithArg a result -> result
12+
result a = fn a (arg a)

‎src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs‎

Lines changed: 25 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,20 @@
11
-- | Monad for declaring Huddle constructs
2-
module Codec.CBOR.Cuddle.Huddle.HuddleM (
3-
module Huddle,
4-
(=:=),
5-
(=:~),
6-
(=::=),
7-
binding,
8-
setRootRules,
9-
huddleDef,
10-
huddleDef',
11-
include,
12-
unsafeIncludeFromHuddle,
13-
)
2+
module Codec.CBOR.Cuddle.Huddle.HuddleM
3+
( module Huddle,
4+
(=:=),
5+
(=:~),
6+
(=::=),
7+
binding,
8+
binding',
9+
setRootRules,
10+
huddleDef,
11+
huddleDef',
12+
include,
13+
unsafeIncludeFromHuddle,
14+
)
1415
where
1516

16-
import Codec.CBOR.Cuddle.Huddle hiding (binding, (=:=), (=:~))
17+
import Codec.CBOR.Cuddle.Huddle hiding (binding, binding', (=:=), (=:~))
1718
import Codec.CBOR.Cuddle.Huddle qualified as Huddle
1819
import Control.Monad.State.Strict (State, modify, runState)
1920
import Data.Default.Class (def)
@@ -43,6 +44,11 @@ binding ::
4344
HuddleM (t0 -> GRuleCall)
4445
binding fRule = include (Huddle.binding fRule)
4546

47+
binding' ::
48+
(GRef -> Rule) ->
49+
HuddleM GRuleDef'
50+
binding' fRule = include (Huddle.binding' fRule)
51+
4652
-- | Renamed version of Huddle's underlying '=:=' for use in generic bindings
4753
(=::=) :: IsType0 a => T.Text -> a -> Rule
4854
n =::= b = n Huddle.=:= b
@@ -84,9 +90,15 @@ instance IsType0 t0 => Includable (t0 -> GRuleCall) where
8490
modify (field @"items" %~ (OMap.|> (n, HIGRule grDef)))
8591
pure gr
8692

93+
instance Includable GRuleDef' where
94+
include r =
95+
modify (field @"items" %~ (OMap.|> (r ^. field @"name", HIGRule' r)))
96+
>> pure r
97+
8798
instance Includable HuddleItem where
8899
include x@(HIRule r) = include r >> pure x
89100
include x@(HIGroup g) = include g >> pure x
101+
include x@(HIGRule' g) = include g >> pure x
90102
include x@(HIGRule g) =
91103
let n = g ^. field @"name"
92104
in do

0 commit comments

Comments
 (0)