Fixed modules

Author: Soupstraw

bin/Main.hs

@@ -4,7 +4,16 @@ module Main (main) where
 
 import Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm)
 import Codec.CBOR.Cuddle.CBOR.Validator
-import Codec.CBOR.Cuddle.CDDL (Name (..), fromRules, sortCDDL)
+import Codec.CBOR.Cuddle.CDDL (
+  CDDL (..),
+  Name (..),
+  TopLevel (..),
+  XRule,
+  XTerm,
+  XXType2,
+  fromRules,
+  sortCDDL,
+ )
 import Codec.CBOR.Cuddle.CDDL.Postlude (appendPostlude)
 import Codec.CBOR.Cuddle.CDDL.Resolve (
   fullResolveCDDL,
@@ -177,6 +186,15 @@ main = do
 
 run :: Opts -> IO ()
 run (Opts cmd cddlFile) = do
+  let
+    mapRule ::
+      ( IndexMappable XXType2 i j
+      , IndexMappable XTerm i j
+      , IndexMappable XRule i j
+      ) =>
+      TopLevel i -> [TopLevel j]
+    mapRule (TopLevelRule r) = [TopLevelRule $ mapIndex r]
+    mapRule (XXTopLevel _) = []
   parseFromFile pCDDL cddlFile >>= \case
     Left err -> do
       putStrLnErr $ errorBundlePretty err
@@ -192,24 +210,24 @@ run (Opts cmd cddlFile) = do
             putDocW 80 . pretty $ mapIndex @_ @_ @PrettyStage defs
         Validate vOpts ->
           let
-            res'
+            CDDL r tls _
               | vNoPrelude vOpts = res
               | otherwise = appendPostlude res
            in
-            case fullResolveCDDL $ mapIndex res' of
+            case fullResolveCDDL $ CDDL (mapIndex r) (foldMap mapRule tls) mempty of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right _ -> exitSuccess
         (GenerateCBOR gOpts) ->
           let
-            res'
+            CDDL r tls _
               | gNoPrelude gOpts = res
               | otherwise = appendPostlude res
            in
-            case fullResolveCDDL $ mapIndex res' of
+            case fullResolveCDDL $ CDDL (mapIndex r) (foldMap mapRule tls) mempty of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right mt -> do
                 stdGen <- getStdGen
-                let term = generateCBORTerm mt (Name (itemName gOpts) mempty) stdGen
+                let term = generateCBORTerm mt (Name $ itemName gOpts) stdGen
                  in case outputFormat gOpts of
                       AsTerm -> print term
                       AsFlatTerm -> print $ toFlatTerm (encodeTerm term)
@@ -219,15 +237,15 @@ run (Opts cmd cddlFile) = do
                       AsPrettyCBOR -> putStrLn . prettyHexEnc $ encodeTerm term
         ValidateCBOR vcOpts ->
           let
-            res'
+            CDDL r tls _
               | vcNoPrelude vcOpts = res
               | otherwise = res
            in
-            case fullResolveCDDL $ mapIndex res' of
+            case fullResolveCDDL $ CDDL (mapIndex r) (foldMap mapRule tls) mempty of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right mt -> do
                 cbor <- BSC.readFile (vcInput vcOpts)
-                validateCBOR cbor (Name (vcItemName vcOpts) mempty) mt
+                validateCBOR cbor (Name $ vcItemName vcOpts) (mapIndex mt)
 
 putStrLnErr :: String -> IO ()
 putStrLnErr = hPutStrLn stderr

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

@@ -11,6 +11,8 @@
 
 #if MIN_VERSION_random(1,3,0)
 {-# OPTIONS_GHC -Wno-deprecations #-} -- Due to usage of `split`
+{-# LANGUAGE TypeData #-}
+{-# LANGUAGE TypeFamilies #-}
 #endif
 -- | Generate example CBOR given a CDDL specification
 module Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm, generateCBORTerm') where
@@ -25,10 +27,10 @@ import Codec.CBOR.Cuddle.CDDL (
   Value (..),
   ValueVariant (..),
  )
-import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreePhase, CTreeRoot (..), PTerm (..))
+import Codec.CBOR.Cuddle.CDDL.CTree (CTree (..), CTreeRoot (..), PTerm (..), foldCTree)
 import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree
 import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
-import Codec.CBOR.Cuddle.CDDL.Resolve (MonoRef (..), MonoReferenced)
+import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, XXCTree (..))
 import Codec.CBOR.Term (Term (..))
 import Codec.CBOR.Term qualified as CBOR
 import Codec.CBOR.Write qualified as CBOR
@@ -60,8 +62,20 @@ import System.Random.Stateful (
   SplitGen (..)
   )
 import Codec.CBOR.Cuddle.CDDL.CBORGenerator (WrappedTerm (..))
+import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
 #endif
 
+type data MonoDropGen
+
+newtype instance XXCTree MonoDropGen = MDGRef Name
+  deriving (Show)
+
+instance IndexMappable CTree MonoReferenced MonoDropGen where
+  mapIndex = foldCTree mapExt mapIndex
+    where
+      mapExt (MRuleRef n) = CTreeE $ MDGRef n
+      mapExt (MGenerator _ x) = mapIndex x
+
 --------------------------------------------------------------------------------
 -- Generator infrastructure
 --------------------------------------------------------------------------------
@@ -233,6 +247,9 @@ pairTermList [] = Just []
 pairTermList (P x y : xs) = ((x, y) :) <$> pairTermList xs
 pairTermList _ = Nothing
 
+showDropGen :: CTree MonoReferenced -> String
+showDropGen = show . mapIndex @_ @_ @MonoDropGen
+
 --------------------------------------------------------------------------------
 -- Generator functions
 --------------------------------------------------------------------------------
@@ -270,9 +287,9 @@ genForCTree (CTree.KV key value _cut) = do
     _ ->
       error $
         "Non single-term generated outside of group context: "
-          <> show key
+          <> showDropGen key
           <> " => "
-          <> show value
+          <> showDropGen value
 genForCTree (CTree.Occur item occurs) =
   applyOccurenceIndicator occurs (genForCTree item)
 genForCTree (CTree.Range from to _bounds) = do
@@ -292,11 +309,11 @@ genForCTree (CTree.Control op target controller) = do
     (CtlOp.Le, CTree.Literal (Value (VUInt n) _)) -> case target of
       CTree.Postlude PTUInt -> S . TInteger <$> genUniformRM (0, fromIntegral n)
       _ -> error "Cannot apply le operator to target"
-    (CtlOp.Le, _) -> error $ "Invalid controller for .le operator: " <> show controller
+    (CtlOp.Le, _) -> error $ "Invalid controller for .le operator: " <> showDropGen controller
     (CtlOp.Lt, CTree.Literal (Value (VUInt n) _)) -> case target of
       CTree.Postlude PTUInt -> S . TInteger <$> genUniformRM (0, fromIntegral n - 1)
       _ -> error "Cannot apply lt operator to target"
-    (CtlOp.Lt, _) -> error $ "Invalid controller for .lt operator: " <> show controller
+    (CtlOp.Lt, _) -> error $ "Invalid controller for .lt operator: " <> showDropGen controller
     (CtlOp.Size, CTree.Literal (Value (VUInt n) _)) -> case target of
       CTree.Postlude PTText -> S . TString <$> genText (fromIntegral n)
       CTree.Postlude PTBytes -> S . TBytes <$> genBytes (fromIntegral n)
@@ -314,15 +331,15 @@ genForCTree (CTree.Control op target controller) = do
           CTree.Postlude PTUInt ->
             S . TInteger
               <$> genUniformRM (fromIntegral f1, fromIntegral t1)
-          _ -> error $ "Cannot apply size operator to target: " <> show target
+          _ -> error $ "Cannot apply size operator to target: " <> showDropGen target
         _ ->
           error $
             "Invalid controller for .size operator: "
-              <> show controller
+              <> showDropGen controller
     (CtlOp.Size, _) ->
       error $
         "Invalid controller for .size operator: "
-          <> show controller
+          <> showDropGen controller
     (CtlOp.Cbor, _) -> do
       enc <- genForCTree controller
       case enc of
@@ -356,6 +373,7 @@ resolveRef (MRuleRef n) = do
   case Map.lookup n cddl of
     Nothing -> error $ "Unbound reference: " <> show n
     Just val -> pure val
+resolveRef (MGenerator _ _) = undefined
 
 -- | Generate a CBOR Term corresponding to a top-level name.
 --
@@ -365,7 +383,7 @@ resolveRef (MRuleRef n) = do
 -- This will throw an error if the generated item does not correspond to a
 -- single CBOR term (e.g. if the name resolves to a group, which cannot be
 -- generated outside a context).
-genForName :: RandomGen g => Name CTreePhase -> M g Term
+genForName :: RandomGen g => Name -> M g Term
 genForName n = do
   (CTreeRoot cddl) <- ask @"cddl"
   case Map.lookup n cddl of
@@ -419,13 +437,13 @@ genValueVariant (VBool b) = pure $ TBool b
 -- Generator functions
 --------------------------------------------------------------------------------
 
-generateCBORTerm :: RandomGen g => CTreeRoot MonoReferenced -> Name CTreePhase -> g -> Term
+generateCBORTerm :: RandomGen g => CTreeRoot MonoReferenced -> Name -> g -> Term
 generateCBORTerm cddl n stdGen =
   let genEnv = GenEnv {cddl}
       genState = GenState {randomSeed = stdGen, depth = 1}
    in evalGen (genForName n) genEnv genState
 
-generateCBORTerm' :: RandomGen g => CTreeRoot MonoReferenced -> Name CTreePhase -> g -> (Term, g)
+generateCBORTerm' :: RandomGen g => CTreeRoot MonoReferenced -> Name -> g -> (Term, g)
 generateCBORTerm' cddl n stdGen =
   let genEnv = GenEnv {cddl}
       genState = GenState {randomSeed = stdGen, depth = 1}

src/Codec/CBOR/Cuddle/CBOR/Validator.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeData #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 
 module Codec.CBOR.Cuddle.CBOR.Validator (
@@ -12,7 +14,8 @@ module Codec.CBOR.Cuddle.CBOR.Validator (
 import Codec.CBOR.Cuddle.CDDL hiding (CDDL, Group, Rule)
 import Codec.CBOR.Cuddle.CDDL.CTree
 import Codec.CBOR.Cuddle.CDDL.CtlOp
-import Codec.CBOR.Cuddle.CDDL.Resolve
+import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, XXCTree (..))
+import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
 import Codec.CBOR.Read
 import Codec.CBOR.Term
 import Control.Exception
@@ -37,8 +40,25 @@ import System.Exit
 import System.IO
 import Text.Regex.TDFA
 
-type CDDL = CTreeRoot MonoReferenced
-type Rule = CTree MonoReferenced
+type data ValidatorStage
+
+data instance XTerm ValidatorStage = ValidatorXTerm
+  deriving (Show)
+
+newtype instance XXCTree ValidatorStage = VRuleRef Name
+  deriving (Show)
+
+instance IndexMappable CTreeRoot MonoReferenced ValidatorStage where
+  mapIndex (CTreeRoot m) = CTreeRoot $ mapIndex <$> m
+
+instance IndexMappable CTree MonoReferenced ValidatorStage where
+  mapIndex = foldCTree mapExt mapIndex
+    where
+      mapExt (MRuleRef n) = CTreeE $ VRuleRef n
+      mapExt (MGenerator _ x) = mapIndex x
+
+type CDDL = CTreeRoot ValidatorStage
+type Rule = CTree ValidatorStage
 
 data CBORTermResult = CBORTermResult Term CDDLResult
   deriving (Show)
@@ -114,7 +134,7 @@ data AMatchedItem = AMatchedItem
 --------------------------------------------------------------------------------
 -- Main entry point
 
-validateCBOR :: BS.ByteString -> Name CTreePhase -> CDDL -> IO ()
+validateCBOR :: BS.ByteString -> Name -> CDDL -> IO ()
 validateCBOR bs rule cddl =
   ( case validateCBOR' bs rule cddl of
       ok@(CBORTermResult _ (Valid _)) -> do
@@ -131,7 +151,7 @@ validateCBOR bs rule cddl =
             )
 
 validateCBOR' ::
-  BS.ByteString -> Name CTreePhase -> CDDL -> CBORTermResult
+  BS.ByteString -> Name -> CDDL -> CBORTermResult
 validateCBOR' bs rule cddl@(CTreeRoot tree) =
   case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of
     Left e -> error $ show e
@@ -1016,7 +1036,7 @@ validateChoice v rules = go rules
                 . ($ dummyRule)
 
 dummyRule :: Rule
-dummyRule = CTreeE $ MRuleRef (Name "dummy" mempty)
+dummyRule = CTreeE $ VRuleRef "dummy"
 
 --------------------------------------------------------------------------------
 -- Control helpers
@@ -1108,7 +1128,7 @@ getIndicesOfEnum g =
 -- Resolving rules from the CDDL spec
 
 resolveIfRef :: CDDL -> Rule -> Rule
-resolveIfRef ct@(CTreeRoot cddl) (CTreeE (MRuleRef n)) = do
+resolveIfRef ct@(CTreeRoot cddl) (CTreeE (VRuleRef n)) = do
   case Map.lookup n cddl of
     Nothing -> error $ "Unbound reference: " <> show n
     Just val -> resolveIfRef ct val

src/Codec/CBOR/Cuddle/CDDL.hs

@@ -154,30 +154,20 @@ deriving instance ForAllExtensions i ToExpr => ToExpr (TopLevel i)
 --
 --  *  Rule names (types or groups) do not appear in the actual CBOR
 --      encoding, but names used as "barewords" in member keys do.
-data Name i = Name
-  { name :: T.Text
-  , nameExt :: XTerm i
-  }
+newtype Name = Name {name :: T.Text}
   deriving (Generic)
+  deriving (Eq, Ord, Show)
+  deriving newtype (Semigroup, Monoid)
 
-deriving instance Eq (XTerm i) => Eq (Name i)
-
-deriving instance Ord (XTerm i) => Ord (Name i)
-
-deriving instance Show (XTerm i) => Show (Name i)
-
-deriving instance ToExpr (XTerm i) => ToExpr (Name i)
-
-instance Monoid (XTerm i) => IsString (Name i) where
-  fromString x = Name (T.pack x) mempty
+deriving anyclass instance ToExpr Name
 
-instance HasComment (XTerm i) => HasComment (Name i) where
-  commentL = #nameExt % commentL
+instance IsString Name where
+  fromString = Name . T.pack
 
-instance CollectComments (XTerm i) => CollectComments (Name i) where
-  collectComments (Name _ c) = collectComments c
+instance CollectComments Name where
+  collectComments _ = []
 
-instance Hashable (XTerm i) => Hashable (Name i)
+instance Hashable Name
 
 -- |
 --   assignt = "=" / "/="
@@ -212,7 +202,7 @@ data Assign = AssignEq | AssignExt
 --
 --   Generic rules can be used for establishing names for both types and
 --   groups.
-newtype GenericParam i = GenericParam (NE.NonEmpty (Name i))
+newtype GenericParam i = GenericParam (NE.NonEmpty Name)
   deriving (Generic)
   deriving newtype (Semigroup)
 
@@ -258,7 +248,7 @@ instance ForAllExtensions i CollectComments => CollectComments (GenericArg i)
 --   this semantic processing may need to span several levels of rule
 --   definitions before a determination can be made.)
 data Rule i = Rule
-  { ruleName :: Name i
+  { ruleName :: Name
   , ruleGenParam :: Maybe (GenericParam i)
   , ruleAssign :: Assign
   , ruleTerm :: TypeOrGroup i
@@ -405,7 +395,7 @@ data Type2 i
     T2Value Value
   | -- | 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 i) (Maybe (GenericArg i))
+    T2Name Name (Maybe (GenericArg i))
   | -- | or be defined in a parenthesized type expression (parentheses may be
     --   necessary to override some operator precedence),
     T2Group (Type0 i)
@@ -419,11 +409,11 @@ data Type2 i
     T2Array (Group i)
   | -- | an "unwrapped" group (see Section 3.7), which matches the group
     --  inside a type defined as a map or an array by wrapping the group, or
-    T2Unwrapped (Name i) (Maybe (GenericArg i))
+    T2Unwrapped Name (Maybe (GenericArg i))
   | -- | an enumeration expression, which matches any value that is within the
     --  set of values that the values of the group given can take, or
     T2Enum (Group i)
-  | T2EnumRef (Name i) (Maybe (GenericArg i))
+  | T2EnumRef Name (Maybe (GenericArg i))
   | -- | a tagged data item, tagged with the "uint" given and containing the
     --  type given as the tagged value, or
     T2Tag (Maybe Word64) (Type0 i)
@@ -529,7 +519,7 @@ instance ForAllExtensions i CollectComments => CollectComments (GroupEntry i) wh
 
 data GroupEntryVariant i
   = GEType (Maybe (MemberKey i)) (Type0 i)
-  | GERef (Name i) (Maybe (GenericArg i))
+  | GERef Name (Maybe (GenericArg i))
   | GEGroup (Group i)
   deriving (Generic)
 
@@ -557,7 +547,7 @@ instance ForAllExtensions i CollectComments => CollectComments (GroupEntryVarian
 --  presence of the cuts denoted by "^" or ":" in previous entries).
 data MemberKey i
   = MKType (Type1 i)
-  | MKBareword (Name i)
+  | MKBareword Name
   | MKValue Value
   deriving (Generic)