Doc.hs

-- | Tests on automatic documentation generation.

module Test.Doc
  ( test_General_doc_scan
  , test_Dependencies_loops
  , test_Cutting_all_except_doc
  , test_fakeCoerce
  ) where

import qualified Data.Set as Set
import Fmt (build)
import Test.HUnit (assertBool, assertFailure, (@?=))
import Test.QuickCheck (total)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)
import Test.Tasty.QuickCheck (testProperty)

import Lorentz (( # ))
import qualified Lorentz as L
import Michelson.Doc
import Michelson.Typed
import Util.Named

-- General tests on contract doc scan
----------------------------------------------------------------------------

newtype MyType = MyType Integer
  deriving stock (Generic)
  deriving anyclass (IsoValue)

instance TypeHasDoc MyType where
  typeDocMdDescription = ""

data MyGroup = MyGroup Text SubDoc

instance DocItem MyGroup where
  type DocItemPosition MyGroup = 91232
  docItemSectionName = Nothing
  docItemToMarkdown lvl (MyGroup name subDoc) =
    build name <> subDocToMarkdown lvl subDoc

test_General_doc_scan :: [TestTree]
test_General_doc_scan =
  [ testCase "Type declaration is found" $
      let contract = L.doc $ DType (Proxy @MyType)
          doc = L.buildLorentzDoc contract
      in case lookupDocBlockSection @DType $ cdDefinitions doc of
            Just (toList -> ds) ->
              sort ds @?= sort [DType (Proxy @MyType), DType (Proxy @Integer)]
            Nothing ->
              assertFailure "DTypes not found"

  , testCase "Dependencies of polymorphic types are found" $
      -- There once was a bug which caused, in the following scenario,
      -- 'Integer' type to be found while 'Natural' to be not, doc items
      -- discovery thought that ":!" has already been traversed and didn't
      -- pick its dependencies the second time.
      let contract = L.doc $ L.mkDEntryPointArgSimple @("a" :! Integer, "b" :! Natural)
          doc = L.buildLorentzDoc contract
          defs = cdDefinitionsSet doc
      in do
         assertBool "'Integer' declaration is present" $
            Set.member (SomeDocDefinitionItem $ DType (Proxy @Integer)) defs
         assertBool "'Natural' declaration is present" $
            Set.member (SomeDocDefinitionItem $ DType (Proxy @Natural)) defs

  , testCase "Doc group is handled correctly" $
      let contract = L.docGroup (SomeDocItem . MyGroup "a") $
                     L.doc $ DDescription "a"
          doc = L.buildLorentzDoc contract
          contents = cdContents doc
      in case lookupDocBlockSection contents of
            Just (MyGroup "a" (SubDoc subcontents) :| []) ->
               case lookupDocBlockSection subcontents of
                 Just (DDescription "a" :| []) ->
                   pass
                 _ -> assertFailure $ "Unexpected subcontents: " <> show subcontents
            _ -> assertFailure $ "Unexpected contents: " <> show contents
  ]

-- Test on loops on dependency graph of doc items
----------------------------------------------------------------------------

-- | Type, documentation for which somehow depends on itself.
newtype MyLoopedType = MyLoopedType Integer
  deriving stock (Generic)
  deriving anyclass (IsoValue)

instance TypeHasDoc MyLoopedType where
  typeDocDependencies _ = [SomeTypeWithDoc (Proxy @MyLoopedType)]
  typeDocMdDescription = ""

newtype MyMutuallyDependentType1 = MyMutuallyDependentType1 Integer
  deriving stock (Generic)
  deriving anyclass (IsoValue)

newtype MyMutuallyDependentType2 = MyMutuallyDependentType2 Integer
  deriving stock (Generic)
  deriving anyclass (IsoValue)

instance TypeHasDoc MyMutuallyDependentType1 where
  typeDocDependencies _ = [SomeTypeWithDoc (Proxy @MyMutuallyDependentType2)]
  typeDocMdDescription = ""

instance TypeHasDoc MyMutuallyDependentType2 where
  typeDocDependencies _ = [SomeTypeWithDoc (Proxy @MyMutuallyDependentType1)]
  typeDocMdDescription = ""

test_Dependencies_loops :: [TestTree]
test_Dependencies_loops =
  [ testProperty "Type depending on itself" $
      let contract = L.doc $ DType (Proxy @MyLoopedType)
      in total . contractDocToMarkdown $ L.buildLorentzDoc contract
  , testProperty "Mutually dependent types" $
      let contract = L.doc $ DType (Proxy @MyMutuallyDependentType1)
      in total . contractDocToMarkdown $ L.buildLorentzDoc contract
  ]

-- Functions semantics
----------------------------------------------------------------------------

test_Cutting_all_except_doc :: [TestTree]
test_Cutting_all_except_doc =
  [ testCase "Cleaning simple code" $
      let contract =
            L.doc (DDescription "a") #
            L.push True #
            L.if_ (L.contractName "aaa" $ L.doc $ DDescription "b") (L.sender # L.drop)
            :: '[] L.:-> '[]
          cutContract =
            L.doc (DDescription "a") #
            L.contractName "aaa" (L.doc $ DDescription "b")
      in L.renderLorentzDoc (L.cutLorentzNonDoc contract)
         @?=
         L.renderLorentzDoc cutContract

  , testCase "DocGroup is handled correctly" $
      let contract =
            L.docGroup (SomeDocItem . MyGroup "b") $
              L.doc (DDescription "a") # L.nop
          cutContract =
            L.docGroup (SomeDocItem . MyGroup "b") $
              L.doc (DDescription "a")
      in L.renderLorentzDoc (L.cutLorentzNonDoc contract)
         @?=
         L.renderLorentzDoc cutContract
  ]

test_fakeCoerce :: [TestTree]
test_fakeCoerce =
  [ testCase "Does not truncate the following documentation" $
      let contract = L.doc (DDescription "a") :: '[] L.:-> '[]
      in L.renderLorentzDoc (L.fakeCoerce # contract)
         @?=
         L.renderLorentzDoc contract
  ]