Parametrise CDDL AST over decorations

Author: Soupstraw

src/Codec/CBOR/Cuddle/CDDL.hs

@@ -1,13 +1,15 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Codec.CBOR.Cuddle.CDDL.Prelude (prependPrelude) where
 
 import Codec.CBOR.Cuddle.CDDL (CDDL (..))
+import Codec.CBOR.Cuddle.Comments (Comment)
 import Codec.CBOR.Cuddle.Parser (pCDDL)
 import Text.Megaparsec (errorBundlePretty, parse)
 
 -- TODO switch to quasiquotes
-cddlPrelude :: CDDL
+cddlPrelude :: CDDL Comment
 cddlPrelude =
   either (error . errorBundlePretty) id $
     parse
@@ -57,5 +59,5 @@ cddlPrelude =
       \ null = nil \
       \ undefined = #7.23"
 
-prependPrelude :: CDDL -> CDDL
+prependPrelude :: CDDL Comment -> CDDL Comment
 prependPrelude = (cddlPrelude <>)

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

@@ -70,7 +70,7 @@ import Optics.Core
 -- 1. Rule extensions
 --------------------------------------------------------------------------------
 
-type CDDLMap = Map.Map Name (Parametrised TypeOrGroup)
+type CDDLMap i = Map.Map Name (Parametrised (TypeOrGroup i))
 
 type Parametrised a = ParametrisedWith [Name] a
 
@@ -82,24 +82,24 @@ parameters :: Parametrised a -> [Name]
 parameters (Unparametrised _) = mempty
 parameters (Parametrised _ ps) = ps
 
-asMap :: CDDL -> CDDLMap
+asMap :: CDDL i -> CDDLMap i
 asMap cddl = foldl' go Map.empty rules
   where
     rules = cddlTopLevel cddl
     go x (TopLevelComment _) = x
     go x (TopLevelRule r) = assignOrExtend x r
 
-    assignOrExtend :: CDDLMap -> Rule -> CDDLMap
+    assignOrExtend :: CDDLMap i -> Rule i -> CDDLMap i
     assignOrExtend m (Rule n gps assign tog _) = case assign of
       -- Equals assignment
       AssignEq -> Map.insert n (toParametrised tog gps) m
       AssignExt -> Map.alter (extend tog gps) n m
 
     extend ::
-      TypeOrGroup ->
+      TypeOrGroup i ->
       Maybe GenericParam ->
-      Maybe (Parametrised TypeOrGroup) ->
-      Maybe (Parametrised TypeOrGroup)
+      Maybe (Parametrised (TypeOrGroup i)) ->
+      Maybe (Parametrised (TypeOrGroup i))
     extend tog _gps (Just existing) = case (underlying existing, tog) of
       (TOGType _, TOGType (Type0 new)) ->
         Just $
@@ -139,23 +139,23 @@ deriving instance Show (CTreeRoot OrRef)
 -- | Build a CTree incorporating references.
 --
 -- This translation cannot fail.
-buildRefCTree :: CDDLMap -> RefCTree
+buildRefCTree :: CDDLMap i -> RefCTree
 buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules
   where
     toCTreeRule ::
-      Parametrised TypeOrGroup ->
+      Parametrised (TypeOrGroup i) ->
       ParametrisedWith [Name] (CTree.Node OrRef)
     toCTreeRule = fmap toCTreeTOG
 
-    toCTreeTOG :: TypeOrGroup -> CTree.Node OrRef
+    toCTreeTOG :: TypeOrGroup i -> CTree.Node OrRef
     toCTreeTOG (TOGType t0) = toCTreeT0 t0
     toCTreeTOG (TOGGroup ge) = toCTreeGroupEntry ge
 
-    toCTreeT0 :: Type0 -> CTree.Node OrRef
+    toCTreeT0 :: Type0 i -> CTree.Node OrRef
     toCTreeT0 (Type0 (t1 NE.:| [])) = toCTreeT1 t1
     toCTreeT0 (Type0 xs) = It . CTree.Choice $ toCTreeT1 <$> xs
 
-    toCTreeT1 :: Type1 -> CTree.Node OrRef
+    toCTreeT1 :: Type1 i -> 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 -> CTree.Node OrRef
+    toCTreeT2 :: Type2 i -> CTree.Node OrRef
     toCTreeT2 (T2Value v) = It $ CTree.Literal v
     toCTreeT2 (T2Name n garg) =
       Ref n (fromGenArgs garg)
@@ -215,35 +215,35 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules
     toCTreeDataItem _ =
       It $ CTree.Postlude PTAny
 
-    toCTreeGroupEntry :: GroupEntry -> CTree.Node OrRef
-    toCTreeGroupEntry (GroupEntry (Just occi) _ (GEType mmkey t0)) =
+    toCTreeGroupEntry :: GroupEntry i -> CTree.Node OrRef
+    toCTreeGroupEntry (GroupEntry (Just occi) (GEType mmkey t0) _) =
       It $
         CTree.Occur
           { CTree.item = toKVPair mmkey t0
           , CTree.occurs = occi
           }
-    toCTreeGroupEntry (GroupEntry Nothing _ (GEType mmkey t0)) = toKVPair mmkey t0
-    toCTreeGroupEntry (GroupEntry (Just occi) _ (GERef n margs)) =
+    toCTreeGroupEntry (GroupEntry Nothing (GEType mmkey t0) _) = toKVPair mmkey t0
+    toCTreeGroupEntry (GroupEntry (Just occi) (GERef n margs) _) =
       It $
         CTree.Occur
           { CTree.item = Ref n (fromGenArgs margs)
           , CTree.occurs = occi
           }
-    toCTreeGroupEntry (GroupEntry Nothing _ (GERef n margs)) = Ref n (fromGenArgs margs)
-    toCTreeGroupEntry (GroupEntry (Just occi) _ (GEGroup g)) =
+    toCTreeGroupEntry (GroupEntry Nothing (GERef n margs) _) = Ref n (fromGenArgs margs)
+    toCTreeGroupEntry (GroupEntry (Just occi) (GEGroup g) _) =
       It $
         CTree.Occur
           { CTree.item = groupToGroup g
           , CTree.occurs = occi
           }
-    toCTreeGroupEntry (GroupEntry Nothing _ (GEGroup g)) = groupToGroup g
+    toCTreeGroupEntry (GroupEntry Nothing (GEGroup g) _) = groupToGroup g
 
-    fromGenArgs :: Maybe GenericArg -> [CTree.Node OrRef]
+    fromGenArgs :: Maybe (GenericArg i) -> [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 -> CTree.Node OrRef
+    toCTreeEnum :: Group i -> 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 -> CTree.Node OrRef
+    groupToGroup :: Group i -> 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 -> Type0 -> CTree.Node OrRef
+    toKVPair :: Maybe (MemberKey i) -> Type0 i -> 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 -> CTree.Node OrRef
+    toCTreeMap :: Group i -> 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 -> CTree.Node OrRef
+    toCTreeArray :: Group i -> 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 -> CTree.Node OrRef
+    toCTreeMemberKey :: MemberKey i -> 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 -> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
+fullResolveCDDL :: CDDL i -> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
 fullResolveCDDL cddl = do
   let refCTree = buildRefCTree (asMap cddl)
   rCTree <- buildResolvedCTree refCTree

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

@@ -108,6 +108,7 @@ import GHC.Exts (IsList (Item, fromList, toList))
 import GHC.Generics (Generic)
 import Optics.Core (lens, view, (%~), (&), (.~), (^.))
 import Prelude hiding ((/))
+import Codec.CBOR.Cuddle.Comments (Comment)
 
 data Named a = Named
   { name :: T.Text
@@ -432,7 +433,7 @@ unconstrained v = Constrained (CValue v) def []
 -- | A constraint on a 'Value' is something applied via CtlOp or RangeOp on a
 -- Type2, forming a Type1.
 data ValueConstraint a = ValueConstraint
-  { applyConstraint :: C.Type2 -> C.Type1
+  { applyConstraint :: C.Type2 Comment -> C.Type1 Comment
   , showConstraint :: String
   }
 
@@ -462,7 +463,7 @@ instance IsSizeable CGRefType
 
 -- | Things which can be used on the RHS of the '.size' operator.
 class IsSize a where
-  sizeAsCDDL :: a -> C.Type2
+  sizeAsCDDL :: a -> C.Type2 Comment
   sizeAsString :: a -> String
 
 instance IsSize Word where
@@ -1062,15 +1063,15 @@ collectFromInit rules =
 --------------------------------------------------------------------------------
 
 -- | Convert from Huddle to CDDL, generating a top level root element.
-toCDDL :: Huddle -> CDDL
+toCDDL :: Huddle -> CDDL Comment
 toCDDL = toCDDL' True
 
 -- | Convert from Huddle to CDDL, skipping a root element.
-toCDDLNoRoot :: Huddle -> CDDL
+toCDDLNoRoot :: Huddle -> CDDL Comment
 toCDDLNoRoot = toCDDL' False
 
 -- | Convert from Huddle to CDDL for the purpose of pretty-printing.
-toCDDL' :: Bool -> Huddle -> CDDL
+toCDDL' :: Bool -> Huddle -> CDDL Comment
 toCDDL' mkPseudoRoot hdl =
   C.fromRules
     $ ( if mkPseudoRoot
@@ -1082,12 +1083,12 @@ toCDDL' mkPseudoRoot hdl =
     toCDDLItem (HIRule r) = toCDDLRule r
     toCDDLItem (HIGroup g) = toCDDLGroup g
     toCDDLItem (HIGRule g) = toGenRuleDef g
-    toTopLevelPseudoRoot :: [Rule] -> C.Rule
+    toTopLevelPseudoRoot :: [Rule] -> C.Rule Comment
     toTopLevelPseudoRoot topRs =
       toCDDLRule $
         comment "Pseudo-rule introduced by Cuddle to collect root elements" $
           "huddle_root_defs" =:= arr (fromList (fmap a topRs))
-    toCDDLRule :: Rule -> C.Rule
+    toCDDLRule :: Rule -> C.Rule Comment
     toCDDLRule (Named n t0 c) =
       (\x -> C.Rule (C.Name n mempty) Nothing C.AssignEq x (foldMap C.Comment c))
         . C.TOGType
@@ -1103,18 +1104,18 @@ toCDDL' mkPseudoRoot hdl =
     toCDDLValue' (LText t) = C.VText t
     toCDDLValue' (LBytes b) = C.VBytes b
 
-    mapToCDDLGroup :: Map -> C.Group
+    mapToCDDLGroup :: Map -> C.Group Comment
     mapToCDDLGroup xs = C.Group $ mapChoiceToCDDL <$> choiceToNE xs
 
-    mapChoiceToCDDL :: MapChoice -> C.GrpChoice
+    mapChoiceToCDDL :: MapChoice -> C.GrpChoice Comment
     mapChoiceToCDDL (MapChoice entries) = C.GrpChoice (fmap mapEntryToCDDL entries) mempty
 
-    mapEntryToCDDL :: MapEntry -> C.GroupEntry
+    mapEntryToCDDL :: MapEntry -> C.GroupEntry Comment
     mapEntryToCDDL (MapEntry k v occ cmnt) =
       C.GroupEntry
         (toOccurrenceIndicator occ)
-        cmnt
         (C.GEType (Just $ toMemberKey k) (toCDDLType0 v))
+        cmnt
 
     toOccurrenceIndicator :: Occurs -> Maybe C.OccurrenceIndicator
     toOccurrenceIndicator (Occurs Nothing Nothing) = Nothing
@@ -1123,7 +1124,7 @@ toCDDL' mkPseudoRoot hdl =
     toOccurrenceIndicator (Occurs (Just 1) Nothing) = Just C.OIOneOrMore
     toOccurrenceIndicator (Occurs lb ub) = Just $ C.OIBounded lb ub
 
-    toCDDLType1 :: Type2 -> C.Type1
+    toCDDLType1 :: Type2 -> C.Type1 Comment
     toCDDLType1 = \case
       T2Constrained (Constrained x constr _) ->
         -- TODO Need to handle choices at the top level
@@ -1142,26 +1143,26 @@ toCDDL' mkPseudoRoot hdl =
       T2Generic g -> C.Type1 (toGenericCall g) Nothing mempty
       T2GenericRef (GRef n) -> C.Type1 (C.T2Name (C.Name n mempty) Nothing) Nothing mempty
 
-    toMemberKey :: Key -> C.MemberKey
+    toMemberKey :: Key -> C.MemberKey Comment
     toMemberKey (LiteralKey (Literal (LText t) _)) = C.MKBareword (C.Name t mempty)
     toMemberKey (LiteralKey v) = C.MKValue $ toCDDLValue v
     toMemberKey (TypeKey t) = C.MKType (toCDDLType1 t)
 
-    toCDDLType0 :: Type0 -> C.Type0
+    toCDDLType0 :: Type0 -> C.Type0 Comment
     toCDDLType0 = C.Type0 . fmap toCDDLType1 . choiceToNE
 
-    arrayToCDDLGroup :: Array -> C.Group
+    arrayToCDDLGroup :: Array -> C.Group Comment
     arrayToCDDLGroup xs = C.Group $ arrayChoiceToCDDL <$> choiceToNE xs
 
-    arrayChoiceToCDDL :: ArrayChoice -> C.GrpChoice
+    arrayChoiceToCDDL :: ArrayChoice -> C.GrpChoice Comment
     arrayChoiceToCDDL (ArrayChoice entries cmt) = C.GrpChoice (fmap arrayEntryToCDDL entries) cmt
 
-    arrayEntryToCDDL :: ArrayEntry -> C.GroupEntry
+    arrayEntryToCDDL :: ArrayEntry -> C.GroupEntry Comment
     arrayEntryToCDDL (ArrayEntry k v occ cmnt) =
       C.GroupEntry
         (toOccurrenceIndicator occ)
-        cmnt
         (C.GEType (fmap toMemberKey k) (toCDDLType0 v))
+        cmnt
 
     toCDDLPostlude :: Value a -> C.Name
     toCDDLPostlude VBool = C.Name "bool" mempty
@@ -1181,7 +1182,7 @@ toCDDL' mkPseudoRoot hdl =
       CRef r -> C.Name (name r) mempty
       CGRef (GRef n) -> C.Name n mempty
 
-    toCDDLRanged :: Ranged -> C.Type1
+    toCDDLRanged :: Ranged -> C.Type1 Comment
     toCDDLRanged (Unranged x) =
       C.Type1 (C.T2Value $ toCDDLValue x) Nothing mempty
     toCDDLRanged (Ranged lb ub rop) =
@@ -1190,18 +1191,18 @@ toCDDL' mkPseudoRoot hdl =
         (Just (C.RangeOp rop, toCDDLRangeBound ub))
         mempty
 
-    toCDDLRangeBound :: RangeBound -> C.Type2
+    toCDDLRangeBound :: RangeBound -> C.Type2 Comment
     toCDDLRangeBound (RangeBoundLiteral l) = C.T2Value $ toCDDLValue l
     toCDDLRangeBound (RangeBoundRef (Named n _ _)) = C.T2Name (C.Name n mempty) Nothing
 
-    toCDDLGroup :: Named Group -> C.Rule
+    toCDDLGroup :: Named Group -> C.Rule Comment
     toCDDLGroup (Named n (Group t0s) c) =
       C.Rule
         (C.Name n mempty)
         Nothing
         C.AssignEq
         ( C.TOGGroup
-            . C.GroupEntry Nothing mempty
+            . (\x -> C.GroupEntry Nothing x mempty)
             . C.GEGroup
             . C.Group
             . (NE.:| [])
@@ -1212,13 +1213,13 @@ toCDDL' mkPseudoRoot hdl =
         )
         (foldMap C.Comment c)
 
-    toGenericCall :: GRuleCall -> C.Type2
+    toGenericCall :: GRuleCall -> C.Type2 Comment
     toGenericCall (Named n gr _) =
       C.T2Name
         (C.Name n mempty)
         (Just . C.GenericArg $ fmap toCDDLType1 (args gr))
 
-    toGenRuleDef :: GRuleDef -> C.Rule
+    toGenRuleDef :: GRuleDef -> C.Rule Comment
     toGenRuleDef (Named n gr c) =
       C.Rule
         (C.Name n mempty)