Switched Resolve to TTG

Author: Soupstraw

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Codec.CBOR.Cuddle.CDDL.CTree where
 
@@ -11,7 +12,6 @@ import Codec.CBOR.Cuddle.CDDL (
  )
 import Codec.CBOR.Cuddle.CDDL.CtlOp
 import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm)
-import Data.Hashable (Hashable)
 import Data.List.NonEmpty qualified as NE
 import Data.Map.Strict qualified as Map
 import Data.Word (Word64)
@@ -27,68 +27,69 @@ import GHC.Generics (Generic)
 -- to manipulate.
 --------------------------------------------------------------------------------
 
+type family CTreeExt i
+
+data Parametrisation a = Parametrisation
+  { parameters :: [Name]
+  , underlying :: a
+  }
+  deriving (Generic, Functor)
+
+data Parametrised
+
+type instance CTreeExt Parametrised = Parametrisation (CTree Parametrised)
+
 -- | CDDL Tree, parametrised over a functor
 --
 --   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
+data CTree i
   = Literal Value
   | Postlude PTerm
-  | Map [Node f]
-  | Array [Node f]
-  | Choice (NE.NonEmpty (Node f))
-  | Group [Node f]
-  | KV {key :: Node f, value :: Node f, cut :: Bool}
-  | Occur {item :: Node f, occurs :: OccurrenceIndicator}
-  | Range {from :: Node f, to :: Node f, inclusive :: RangeBound}
-  | Control {op :: CtlOp, target :: Node f, controller :: Node f}
-  | Enum (Node f)
-  | Unwrap (Node f)
-  | Tag Word64 (Node f)
+  | Map [CTree i]
+  | Array [CTree i]
+  | Choice (NE.NonEmpty (CTree i))
+  | Group [CTree i]
+  | KV {key :: CTree i, value :: CTree i, cut :: Bool}
+  | Occur {item :: CTree i, occurs :: OccurrenceIndicator}
+  | Range {from :: CTree i, to :: CTree i, inclusive :: RangeBound}
+  | Control {op :: CtlOp, target :: CTree i, controller :: CTree i}
+  | Enum (CTree i)
+  | Unwrap (CTree i)
+  | Tag Word64 (CTree i)
+  | CTreeE (CTreeExt i)
   deriving (Generic)
 
 deriving instance Eq (Node f) => Eq (CTree f)
 
 -- | Traverse the CTree, carrying out the given operation at each node
-traverseCTree :: Monad m => (Node f -> m (Node g)) -> CTree f -> m (CTree g)
-traverseCTree _ (Literal a) = pure $ Literal a
-traverseCTree _ (Postlude a) = pure $ Postlude a
-traverseCTree atNode (Map xs) = Map <$> traverse atNode xs
-traverseCTree atNode (Array xs) = Array <$> traverse atNode xs
-traverseCTree atNode (Group xs) = Group <$> traverse atNode xs
-traverseCTree atNode (Choice xs) = Choice <$> traverse atNode xs
-traverseCTree atNode (KV k v c) = do
+traverseCTree ::
+  Monad m => (CTreeExt i -> m (CTreeExt j)) -> (CTree i -> m (CTree j)) -> CTree i -> m (CTree j)
+traverseCTree _ _ (Literal a) = pure $ Literal a
+traverseCTree _ _ (Postlude a) = pure $ Postlude a
+traverseCTree _ atNode (Map xs) = Map <$> traverse atNode xs
+traverseCTree _ atNode (Array xs) = Array <$> traverse atNode xs
+traverseCTree _ atNode (Group xs) = Group <$> traverse atNode xs
+traverseCTree _ atNode (Choice xs) = Choice <$> traverse atNode xs
+traverseCTree _ atNode (KV k v c) = do
   k' <- atNode k
   v' <- atNode v
   pure $ KV k' v' c
-traverseCTree atNode (Occur i occ) = flip Occur occ <$> atNode i
-traverseCTree atNode (Range f t inc) = do
+traverseCTree _ atNode (Occur i occ) = flip Occur occ <$> atNode i
+traverseCTree _ atNode (Range f t inc) = do
   f' <- atNode f
   t' <- atNode t
   pure $ Range f' t' inc
-traverseCTree atNode (Control o t c) = do
+traverseCTree _ atNode (Control o t c) = do
   t' <- atNode t
   c' <- atNode c
   pure $ Control o t' c'
-traverseCTree atNode (Enum ref) = Enum <$> atNode ref
-traverseCTree atNode (Unwrap ref) = Unwrap <$> atNode ref
-traverseCTree atNode (Tag i ref) = Tag i <$> atNode ref
+traverseCTree _ atNode (Enum ref) = Enum <$> atNode ref
+traverseCTree _ atNode (Unwrap ref) = Unwrap <$> atNode ref
+traverseCTree _ atNode (Tag i ref) = Tag i <$> atNode ref
+traverseCTree atExt _ (CTreeE x) = CTreeE <$> atExt x
 
-type Node f = f (CTree f)
+type Node i = CTreeExt i
 
-newtype CTreeRoot' poly f
-  = CTreeRoot
-      (Map.Map Name (poly (Node f)))
+newtype CTreeRoot i = CTreeRoot (Map.Map Name (Parametrisation (Node i)))
   deriving (Generic)
-
-type CTreeRoot f = CTreeRoot' (ParametrisedWith [Name]) f
-
-data ParametrisedWith w a
-  = Unparametrised {underlying :: a}
-  | Parametrised
-      { underlying :: a
-      , params :: w
-      }
-  deriving (Eq, Functor, Generic, Foldable, Traversable, Show)
-
-instance (Hashable w, Hashable a) => Hashable (ParametrisedWith w a)