Pretty.hs

{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Test.Codec.CBOR.Cuddle.CDDL.Pretty (
  spec,
) where

import Codec.CBOR.Cuddle.CDDL (
  Assign (..),
  CDDL,
  Group (..),
  GroupEntry (..),
  GroupEntryVariant (..),
  GrpChoice (..),
  Name (..),
  Rule (..),
  Type0 (..),
  Type1 (..),
  Type2 (..),
  TypeOrGroup (..),
  ValueVariant (..),
  value,
 )
import Codec.CBOR.Cuddle.Huddle (HuddleItem (..), a, bstr, (<+), (=:=), (=:~))
import Codec.CBOR.Cuddle.Huddle qualified as H
import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
import Codec.CBOR.Cuddle.Pretty (PrettyStage, XRule (..))
import Data.Default.Class (Default (..))
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text qualified as T
import Data.TreeDiff (ToExpr (..), prettyExpr)
import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty)
import Prettyprinter.Render.String (renderString)
import Test.Codec.CBOR.Cuddle.CDDL.Gen ()
import Test.HUnit (assertEqual)
import Test.Hspec (Expectation, Spec, describe, it, shouldBe, xit)
import Test.Hspec.QuickCheck (xprop)
import Test.QuickCheck (counterexample)
import Prelude hiding ((/))

prettyPrintsTo :: (Pretty a, ToExpr a) => a -> String -> Expectation
prettyPrintsTo x s = assertEqual (show . prettyExpr $ toExpr x) s rendered
  where
    rendered = renderString (layoutPretty defaultLayoutOptions (pretty x))

t2Name :: Type2 PrettyStage
t2Name = T2Name (Name "a") mempty

t1Name :: Type1 PrettyStage
t1Name = Type1 t2Name Nothing mempty

mkType0 :: Type2 PrettyStage -> Type0 PrettyStage
mkType0 t2 = Type0 $ Type1 t2 Nothing mempty :| []

spec :: Spec
spec = describe "Pretty printer" $ do
  unitSpec
  qcSpec

qcSpec :: Spec
qcSpec = describe "QuickCheck" $ do
  xprop "CDDL prettyprinter leaves no trailing spaces" $ \(cddl :: CDDL PrettyStage) -> do
    let
      prettyStr = T.pack . renderString . layoutPretty defaultLayoutOptions $ pretty cddl
      stripLines = T.unlines . fmap T.stripEnd . T.lines
    counterexample (show . prettyExpr $ toExpr cddl) $
      prettyStr `shouldBe` stripLines prettyStr

drep :: Rule PrettyStage
drep =
  Rule
    "drep"
    Nothing
    AssignEq
    ( TOGType
        ( Type0
            ( Type1
                ( T2Array
                    ( Group
                        ( GrpChoice
                            [ GroupEntry
                                Nothing
                                (GEType Nothing (Type0 $ Type1 (T2Value . value $ VUInt 0) Nothing mempty :| []))
                                mempty
                            , GroupEntry
                                Nothing
                                (GEType Nothing (Type0 $ Type1 (T2Name "addr_keyhash" Nothing) Nothing mempty :| []))
                                mempty
                            ]
                            mempty
                            :| [ GrpChoice
                                   [ GroupEntry
                                       Nothing
                                       (GEType Nothing (Type0 $ Type1 (T2Value . value $ VUInt 1) Nothing mempty :| []))
                                       mempty
                                   , GroupEntry
                                       Nothing
                                       (GEType Nothing (Type0 $ Type1 (T2Name "script_hash" Nothing) Nothing mempty :| []))
                                       mempty
                                   ]
                                   mempty
                               , GrpChoice
                                   [ GroupEntry
                                       Nothing
                                       (GEType Nothing (Type0 $ Type1 (T2Value . value $ VUInt 2) Nothing mempty :| []))
                                       mempty
                                   ]
                                   mempty
                               , GrpChoice
                                   [ GroupEntry
                                       Nothing
                                       (GEType Nothing (Type0 $ Type1 (T2Value . value $ VUInt 3) Nothing mempty :| []))
                                       mempty
                                   ]
                                   mempty
                               ]
                        )
                    )
                )
                Nothing
                mempty
                :| []
            )
        )
    )
    def

unitSpec :: Spec
unitSpec = describe "HUnit" $ do
  describe "CDDL" $ do
    describe "Name" $ do
      it "names" $ Name "a" `prettyPrintsTo` "a"
    describe "Type0" $ do
      it "name" $ Type0 @PrettyStage (t1Name :| []) `prettyPrintsTo` "a"
    describe "Type1" $ do
      it "name" $ t1Name `prettyPrintsTo` "a"
    describe "Type2" $ do
      it "T2Name" $ t2Name `prettyPrintsTo` "a"
      describe "T2Array" $ do
        let groupEntryName = GroupEntry Nothing (GERef (Name "a") Nothing) ""
        it "one element" $
          T2Array (Group (GrpChoice [groupEntryName] mempty :| [])) `prettyPrintsTo` "[a]"
        it "two elements" $
          T2Array
            ( Group
                ( GrpChoice
                    [ GroupEntry Nothing (GEType Nothing (mkType0 . T2Value . value $ VUInt 1)) ""
                    , groupEntryName
                    ]
                    mempty
                    :| []
                )
            )
            `prettyPrintsTo` "[1, a]"
        it "two elements with comments" $
          T2Array
            ( Group
                ( GrpChoice
                    [ GroupEntry Nothing (GEType Nothing (mkType0 . T2Value . value $ VUInt 1)) "one"
                    , GroupEntry Nothing (GEType Nothing (mkType0 . T2Value . value $ VUInt 2)) "two"
                    ]
                    mempty
                    :| []
                )
            )
            `prettyPrintsTo` "[ 1 ; one\n, 2 ; two\n]"
        it "two elements with multiline comments" $
          T2Array
            ( Group
                ( GrpChoice
                    [ GroupEntry
                        Nothing
                        (GEType Nothing (mkType0 . T2Value . value $ VUInt 1))
                        "first\nmultiline comment"
                    , GroupEntry
                        Nothing
                        (GEType Nothing (mkType0 . T2Value . value $ VUInt 2))
                        "second\nmultiline comment"
                    ]
                    mempty
                    :| []
                )
            )
            `prettyPrintsTo` "[ 1 ; first\n    ; multiline comment\n, 2 ; second\n    ; multiline comment\n]"
    describe "Rule" $ do
      it "simple assignment" $
        Rule @PrettyStage
          (Name "a")
          Nothing
          AssignEq
          (TOGType (Type0 (Type1 (T2Name (Name "b") mempty) Nothing mempty :| [])))
          def
          `prettyPrintsTo` "a = b"
      it "simple assignment with comment" $
        Rule @PrettyStage
          (Name "a")
          Nothing
          AssignEq
          (TOGType (Type0 (Type1 (T2Name (Name "b") mempty) Nothing mempty :| [])))
          (PrettyXRule "comment")
          `prettyPrintsTo` "; comment\na = b"
      xit "drep" $
        drep
          `prettyPrintsTo` "drep = [0, addr_keyhash // 1, script_hash // 2 // 3]"
  describe "Huddle" $ do
    let
      huddlePrettyPrintsTo rs str =
        mapIndex @_ @_ @PrettyStage (H.toCDDLNoRoot $ H.collectFrom rs) `prettyPrintsTo` str
    describe "Rule" $ do
      -- TODO get rid of trailing newline
      it "simple assignment" $
        [HIRule $ "a" =:= H.bool True]
          `huddlePrettyPrintsTo` "a = true\n"
      it "simple assignment with comment" $
        [HIRule $ H.comment "comment" $ "a" =:= H.bool True]
          `huddlePrettyPrintsTo` "; comment\na = true\n"
      it "comment and reference" $
        let
          b = H.comment "this is rule 'b'" $ "b" =:= H.text "bee"
         in
          [ HIRule $ H.comment "comment" $ "a" =:= b
          ]
            `huddlePrettyPrintsTo` "; comment\na = b\n\n; this is rule 'b'\nb = \"bee\"\n"
      it "bstr expects hex, not bytes" $
        [ HIRule $ "a" =:= bstr "010200ff"
        ]
          `huddlePrettyPrintsTo` "a = h'010200ff'\n"
    describe "Generic rule" $ do
      it "comment and generic reference" $
        let
          b :: H.IsType0 a => a -> H.GRuleCall
          b = H.binding $ \x -> H.comment "bar" $ "b" =:= H.arr [0 <+ a x]
         in
          [ HIRule . H.comment "foo" $ "a" =:= b (H.bool True)
          ]
            `huddlePrettyPrintsTo` "; foo\na = b<true>\n\n; bar\nb<a0> = [* a0]\n"
    describe "GroupDef" $ do
      it "simple pair" $
        [HIGroup $ "a" =:~ [a $ H.bool True, a $ H.int 3]]
          `huddlePrettyPrintsTo` "a = (true, 3)\n"
      it "simple pair with comment" $
        [HIGroup $ H.comment "comment" $ "a" =:~ [a $ H.bool True, a $ H.int 3]]
          `huddlePrettyPrintsTo` "; comment\na = (true, 3)\n"
      it "comment and reference" $
        let
          b = H.comment "bar" $ "b" =:~ [a $ H.int 2, a $ H.text "bee"]
         in
          [ HIGroup . H.comment "foo" $ "a" =:~ [a $ H.bool True, a b]
          ]
            `huddlePrettyPrintsTo` "; foo\na = (true, b)\n\n; bar\nb = (2, \"bee\")\n"