WIP

Author: Soupstraw

bin/Main.hs

@@ -17,6 +17,7 @@ import Codec.CBOR.Term (encodeTerm)
 import Codec.CBOR.Write (toStrictByteString)
 import Data.ByteString.Base16 qualified as Base16
 import Data.ByteString.Char8 qualified as BSC
+import Data.Functor (($>))
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Options.Applicative
@@ -195,7 +196,7 @@ run (Opts cmd cddlFile) = do
               | vNoPrelude vOpts = res
               | otherwise = prependPrelude res
            in
-            case fullResolveCDDL res' of
+            case fullResolveCDDL (res' $> ()) of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right _ -> exitSuccess
         (GenerateCBOR gOpts) ->
@@ -204,7 +205,7 @@ run (Opts cmd cddlFile) = do
               | gNoPrelude gOpts = res
               | otherwise = prependPrelude res
            in
-            case fullResolveCDDL res' of
+            case fullResolveCDDL (res' $> ()) of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right mt -> do
                 stdGen <- getStdGen
@@ -222,7 +223,7 @@ run (Opts cmd cddlFile) = do
               | vcNoPrelude vcOpts = res
               | otherwise = prependPrelude res
            in
-            case fullResolveCDDL res' of
+            case fullResolveCDDL (res' $> ()) of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right mt -> do
                 cbor <- BSC.readFile (vcInput vcOpts)

cuddle.cabal

@@ -55,7 +55,6 @@ library
     Codec.CBOR.Cuddle.Comments
     Codec.CBOR.Cuddle.Huddle
     Codec.CBOR.Cuddle.Huddle.HuddleM
-    Codec.CBOR.Cuddle.Huddle.Optics
     Codec.CBOR.Cuddle.Parser
     Codec.CBOR.Cuddle.Parser.Lexer
     Codec.CBOR.Cuddle.Pretty

src/Codec/CBOR/Cuddle/CBOR/Gen.hs

@@ -385,7 +385,7 @@ applyOccurenceIndicator (OIBounded mlb mub) oldGen =
   genDepthBiasedRM (fromMaybe 0 mlb :: Word64, fromMaybe 10 mub)
     >>= \i -> G <$> replicateM (fromIntegral i) oldGen
 
-genValue :: RandomGen g => Value -> M g Term
+genValue :: RandomGen g => Value () -> M g Term
 genValue (Value x _) = genValueVariant x
 
 genValueVariant :: RandomGen g => ValueVariant -> M g Term

src/Codec/CBOR/Cuddle/CDDL.hs

@@ -428,7 +428,7 @@ data Type2 i
   = -- | A type can be just a single value (such as 1 or "icecream" or
     --   h'0815'), which matches only a data item with that specific value
     --   (no conversions defined),
-    T2Value Value
+    T2Value (Value i)
   | -- | or be defined by a rule giving a meaning to a name (possibly after
     --   supplying generic arguments as required by the generic parameters)
     T2Name Name (Maybe (GenericArg i))
@@ -583,7 +583,7 @@ instance CollectComments (GroupEntryVariant Comment) where
 data MemberKey i
   = MKType (Type1 i)
   | MKBareword Name
-  | MKValue Value
+  | MKValue (Value i)
   deriving (Generic, Functor)
 
 deriving instance Eq i => Eq (MemberKey i)
@@ -592,12 +592,12 @@ deriving instance Show i => Show (MemberKey i)
 
 deriving instance ToExpr i => ToExpr (MemberKey i)
 
-data Value = Value ValueVariant Comment
-  deriving (Eq, Generic, Show, Default)
+data Value i = Value ValueVariant i
+  deriving (Eq, Generic, Show, Default, Functor)
   deriving anyclass (ToExpr, Hashable, CollectComments)
 
-value :: ValueVariant -> Value
-value x = Value x mempty
+value :: Default i => ValueVariant -> Value i
+value x = Value x def
 
 data ValueVariant
   = VUInt Word64

src/Codec/CBOR/Cuddle/CDDL/CTree.hs

@@ -31,7 +31,7 @@ import GHC.Generics (Generic)
 --   We principally use this functor to represent references - thus, every 'f a'
 --   may be either an a or a reference to another CTree.
 data CTree f
-  = Literal Value
+  = Literal (Value ())
   | Postlude PTerm
   | Map [Node f]
   | Array [Node f]

src/Codec/CBOR/Cuddle/CDDL/Resolve.hs

@@ -139,23 +139,23 @@ deriving instance Show (CTreeRoot OrRef)
 -- | Build a CTree incorporating references.
 --
 -- This translation cannot fail.
-buildRefCTree :: CDDLMap i -> RefCTree
+buildRefCTree :: CDDLMap () -> RefCTree
 buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules
   where
     toCTreeRule ::
-      Parametrised (TypeOrGroup i) ->
+      Parametrised (TypeOrGroup ()) ->
       ParametrisedWith [Name] (CTree.Node OrRef)
     toCTreeRule = fmap toCTreeTOG
 
-    toCTreeTOG :: TypeOrGroup i -> CTree.Node OrRef
+    toCTreeTOG :: TypeOrGroup () -> CTree.Node OrRef
     toCTreeTOG (TOGType t0) = toCTreeT0 t0
     toCTreeTOG (TOGGroup ge) = toCTreeGroupEntry ge
 
-    toCTreeT0 :: Type0 i -> CTree.Node OrRef
+    toCTreeT0 :: Type0 () -> CTree.Node OrRef
     toCTreeT0 (Type0 (t1 NE.:| [])) = toCTreeT1 t1
     toCTreeT0 (Type0 xs) = It . CTree.Choice $ toCTreeT1 <$> xs
 
-    toCTreeT1 :: Type1 i -> CTree.Node OrRef
+    toCTreeT1 :: Type1 () -> CTree.Node OrRef
     toCTreeT1 (Type1 t2 Nothing _) = toCTreeT2 t2
     toCTreeT1 (Type1 t2 (Just (op, t2')) _) = case op of
       RangeOp bound ->
@@ -173,7 +173,7 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules
             , CTree.controller = toCTreeT2 t2'
             }
 
-    toCTreeT2 :: Type2 i -> CTree.Node OrRef
+    toCTreeT2 :: Type2 () -> CTree.Node OrRef
     toCTreeT2 (T2Value v) = It $ CTree.Literal v
     toCTreeT2 (T2Name n garg) =
       Ref n (fromGenArgs garg)
@@ -215,7 +215,7 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules
     toCTreeDataItem _ =
       It $ CTree.Postlude PTAny
 
-    toCTreeGroupEntry :: GroupEntry i -> CTree.Node OrRef
+    toCTreeGroupEntry :: GroupEntry () -> CTree.Node OrRef
     toCTreeGroupEntry (GroupEntry (Just occi) (GEType mmkey t0) _) =
       It $
         CTree.Occur
@@ -238,12 +238,12 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules
           }
     toCTreeGroupEntry (GroupEntry Nothing (GEGroup g) _) = groupToGroup g
 
-    fromGenArgs :: Maybe (GenericArg i) -> [CTree.Node OrRef]
+    fromGenArgs :: Maybe (GenericArg ()) -> [CTree.Node OrRef]
     fromGenArgs = maybe [] (\(GenericArg xs) -> NE.toList $ fmap toCTreeT1 xs)
 
     -- Interpret a group as an enumeration. Note that we float out the
     -- choice options
-    toCTreeEnum :: Group i -> CTree.Node OrRef
+    toCTreeEnum :: Group () -> CTree.Node OrRef
     toCTreeEnum (Group (a NE.:| [])) =
       It . CTree.Enum . It . CTree.Group $ toCTreeGroupEntry <$> gcGroupEntries a
     toCTreeEnum (Group xs) =
@@ -253,14 +253,14 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules
         groupEntries = fmap gcGroupEntries xs
 
     -- Embed a group in another group, again floating out the choice options
-    groupToGroup :: Group i -> CTree.Node OrRef
+    groupToGroup :: Group () -> CTree.Node OrRef
     groupToGroup (Group (a NE.:| [])) =
       It . CTree.Group $ fmap toCTreeGroupEntry (gcGroupEntries a)
     groupToGroup (Group xs) =
       It . CTree.Choice $
         fmap (It . CTree.Group . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs)
 
-    toKVPair :: Maybe (MemberKey i) -> Type0 i -> CTree.Node OrRef
+    toKVPair :: Maybe (MemberKey ()) -> Type0 () -> CTree.Node OrRef
     toKVPair Nothing t0 = toCTreeT0 t0
     toKVPair (Just mkey) t0 =
       It $
@@ -272,7 +272,7 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules
           }
 
     -- Interpret a group as a map. Note that we float out the choice options
-    toCTreeMap :: Group i -> CTree.Node OrRef
+    toCTreeMap :: Group () -> CTree.Node OrRef
     toCTreeMap (Group (a NE.:| [])) = It . CTree.Map $ fmap toCTreeGroupEntry (gcGroupEntries a)
     toCTreeMap (Group xs) =
       It
@@ -281,14 +281,14 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules
 
     -- Interpret a group as an array. Note that we float out the choice
     -- options
-    toCTreeArray :: Group i -> CTree.Node OrRef
+    toCTreeArray :: Group () -> CTree.Node OrRef
     toCTreeArray (Group (a NE.:| [])) =
       It . CTree.Array $ fmap toCTreeGroupEntry (gcGroupEntries a)
     toCTreeArray (Group xs) =
       It . CTree.Choice $
         fmap (It . CTree.Array . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs)
 
-    toCTreeMemberKey :: MemberKey i -> CTree.Node OrRef
+    toCTreeMemberKey :: MemberKey () -> CTree.Node OrRef
     toCTreeMemberKey (MKValue v) = It $ CTree.Literal v
     toCTreeMemberKey (MKBareword (Name n _)) = It $ CTree.Literal (Value (VText n) mempty)
     toCTreeMemberKey (MKType t1) = toCTreeT1 t1
@@ -556,7 +556,7 @@ buildMonoCTree (CTreeRoot ct) = do
 -- Combined resolution
 --------------------------------------------------------------------------------
 
-fullResolveCDDL :: CDDL i -> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
+fullResolveCDDL :: CDDL () -> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
 fullResolveCDDL cddl = do
   let refCTree = buildRefCTree (asMap cddl)
   rCTree <- buildResolvedCTree refCTree