Fixed tests

Author: Soupstraw

src/Codec/CBOR/Cuddle/Huddle.hs

@@ -27,6 +27,7 @@ module Codec.CBOR.Cuddle.Huddle (
   HuddleStage,
   C.XCddl (..),
   C.XTerm (..),
+  C.XRule (..),
   C.XXTopLevel (..),
   C.XXType2 (..),
 
@@ -139,6 +140,8 @@ data instance C.XRule HuddleStage = HuddleXRule
   }
   deriving (Generic)
 
+instance Default (XRule HuddleStage)
+
 newtype instance C.XXTopLevel HuddleStage = HuddleXXTopLevel C.Comment
   deriving (Generic, Semigroup, Monoid, Show, Eq)
 
@@ -757,7 +760,7 @@ infixl 8 ==>
 
 -- | Assign a rule
 (=:=) :: IsType0 a => T.Text -> a -> Rule
-n =:= b = Rule (Named n (toType0 b) Nothing) (HuddleXRule undefined undefined)
+n =:= b = Rule (Named n (toType0 b) Nothing) def
 
 infixl 1 =:=
 
@@ -1069,7 +1072,7 @@ collectFrom topRs =
     goT2 (T2Constrained (Constrained c _ refs)) =
       ( case c of
           CValue _ -> pure ()
-          CRef r -> goRule $ Rule r undefined
+          CRef r -> goRule $ Rule r def
           CGRef _ -> pure ()
       )
         >> mapM_ goRule refs

src/Codec/CBOR/Cuddle/Pretty.hs

@@ -24,6 +24,7 @@ import Codec.CBOR.Cuddle.Pretty.Columnar (
  )
 import Codec.CBOR.Cuddle.Pretty.Utils (renderedLen, softspace)
 import Data.ByteString.Char8 qualified as BS
+import Data.Default.Class (Default)
 import Data.Foldable (Foldable (..))
 import Data.List.NonEmpty qualified as NE
 import Data.String (IsString, fromString)
@@ -50,6 +51,7 @@ newtype instance XCddl PrettyStage = PrettyXCddl [Comment]
 
 newtype instance XRule PrettyStage = PrettyXRule {unPrettyXRule :: Comment}
   deriving (Generic, CollectComments, ToExpr, Show, Eq)
+  deriving newtype (Default)
 
 instance HasComment (XTerm PrettyStage) where
   commentL = #unPrettyXTerm

test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs

@@ -10,7 +10,7 @@ import Codec.CBOR.Cuddle.CDDL
 import Codec.CBOR.Cuddle.CDDL.CtlOp
 import Codec.CBOR.Cuddle.Comments (Comment (..))
 import Codec.CBOR.Cuddle.Parser (ParserStage, XTerm (..))
-import Codec.CBOR.Cuddle.Pretty (PrettyStage, XTerm (..), XXTopLevel (..))
+import Codec.CBOR.Cuddle.Pretty (PrettyStage, XRule (..), XTerm (..), XXTopLevel (..))
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
 import Data.List.NonEmpty qualified as NE
@@ -27,6 +27,8 @@ deriving newtype instance Arbitrary (XXTopLevel PrettyStage)
 
 deriving newtype instance Arbitrary (XTerm PrettyStage)
 
+deriving newtype instance Arbitrary (XRule PrettyStage)
+
 instance Arbitrary (TopLevel PrettyStage) where
   arbitrary =
     Gen.oneof
@@ -91,7 +93,13 @@ instance (Arbitrary (XTerm i), Monoid (XTerm i)) => Arbitrary (GenericArg i) whe
   arbitrary = GenericArg <$> nonEmpty arbitrary
   shrink (GenericArg neArg) = GenericArg <$> shrinkNE neArg
 
-instance (Monoid (XTerm i), Arbitrary (XTerm i)) => Arbitrary (Rule i) where
+instance
+  ( Monoid (XTerm i)
+  , Arbitrary (XTerm i)
+  , Arbitrary (XRule i)
+  ) =>
+  Arbitrary (Rule i)
+  where
   arbitrary =
     Rule
       <$> arbitrary

test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs

@@ -23,6 +23,7 @@ import Codec.CBOR.Cuddle.CDDL (
   value,
  )
 import Codec.CBOR.Cuddle.Pretty (PrettyStage)
+import Data.Default.Class (Default (..))
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Text qualified as T
 import Data.TreeDiff (ToExpr (..), prettyExpr)
@@ -120,7 +121,7 @@ drep =
             )
         )
     )
-    mempty
+    def
 
 unitSpec :: Spec
 unitSpec = describe "HUnit" $ do
@@ -185,7 +186,7 @@ unitSpec = describe "HUnit" $ do
         Nothing
         AssignEq
         (TOGType (Type0 (Type1 (T2Name (Name "b" mempty) mempty) Nothing mempty :| [])))
-        mempty
+        def
         `prettyPrintsTo` "a = b"
     xit "drep" $
       drep

test/Test/Codec/CBOR/Cuddle/Huddle.hs

@@ -1,21 +1,73 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeData #-}
+{-# LANGUAGE TypeFamilies #-}
 
 {- HLINT ignore "Redundant bracket" -}
 
 module Test.Codec.CBOR.Cuddle.Huddle where
 
 import Codec.CBOR.Cuddle.CDDL (CDDL, fromRules, sortCDDL)
+import Codec.CBOR.Cuddle.Comments (Comment)
 import Codec.CBOR.Cuddle.Huddle
 import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
 import Codec.CBOR.Cuddle.Parser
 import Data.Text qualified as T
+import Data.Void (Void)
+import GHC.Generics (Generic)
 import Test.Codec.CBOR.Cuddle.CDDL.Pretty qualified as Pretty
 import Test.Hspec
 import Test.Hspec.Megaparsec
 import Text.Megaparsec
 import Prelude hiding ((/))
 
+type data TestStage
+
+newtype instance XCddl TestStage = TestXCddl [Comment]
+  deriving (Generic, Show, Eq)
+
+instance IndexMappable XCddl ParserStage TestStage where
+  mapIndex (ParserXCddl x) = TestXCddl x
+
+instance IndexMappable XCddl HuddleStage TestStage where
+  mapIndex (HuddleXCddl x) = TestXCddl x
+
+newtype instance XTerm TestStage = TestXTerm Comment
+  deriving (Generic, Show, Eq)
+
+instance IndexMappable XTerm ParserStage TestStage where
+  mapIndex (ParserXTerm x) = TestXTerm x
+
+instance IndexMappable XTerm HuddleStage TestStage where
+  mapIndex (HuddleXTerm x) = TestXTerm x
+
+newtype instance XRule TestStage = TestXRule Comment
+  deriving (Generic, Show, Eq)
+
+instance IndexMappable XRule ParserStage TestStage where
+  mapIndex (ParserXRule x) = TestXRule x
+
+instance IndexMappable XRule HuddleStage TestStage where
+  mapIndex (HuddleXRule x _) = TestXRule x
+
+newtype instance XXTopLevel TestStage = TestXXTopLevel Comment
+  deriving (Generic, Show, Eq)
+
+instance IndexMappable XXTopLevel ParserStage TestStage where
+  mapIndex (ParserXXTopLevel x) = TestXXTopLevel x
+
+instance IndexMappable XXTopLevel HuddleStage TestStage where
+  mapIndex (HuddleXXTopLevel x) = TestXXTopLevel x
+
+newtype instance XXType2 TestStage = TestXXType2 Void
+  deriving (Generic, Show, Eq)
+
+instance IndexMappable XXType2 ParserStage TestStage where
+  mapIndex (ParserXXType2 x) = TestXXType2 x
+
+instance IndexMappable XXType2 HuddleStage TestStage where
+  mapIndex (HuddleXXType2 x) = TestXXType2 x
+
 huddleSpec :: Spec
 huddleSpec = describe "huddle" $ do
   basicAssign
@@ -156,10 +208,10 @@ shouldMatchParse ::
 shouldMatchParse x parseFun input = parse parseFun "" (T.pack input) `shouldParse` x
 
 shouldMatchParseCDDL ::
-  CDDL HuddleStage ->
+  CDDL TestStage ->
   String ->
   Expectation
 shouldMatchParseCDDL x = shouldMatchParse x . fmap mapIndex $ pCDDL
 
-toSortedCDDL :: Huddle -> CDDL HuddleStage
-toSortedCDDL = fromRules . sortCDDL . toCDDLNoRoot
+toSortedCDDL :: Huddle -> CDDL TestStage
+toSortedCDDL = mapIndex . fromRules . sortCDDL . toCDDLNoRoot