Doc.hs

{-# LANGUAGE DeriveAnyClass, DerivingStrategies #-}

-- | 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.Map as Map
import qualified Data.Set as Set
import Data.Typeable (cast)
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
          mTypeDecls = Map.lookup (docItemPosition @DType) (cdDefinitions doc)
         --- Type declarations should include 'MyType' and 'Integer'
      in fmap length mTypeDecls @?= Just 2

  , 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 $ DVersion 1
          doc = L.buildLorentzDoc contract
          contents = cdContents doc
      in case toList contents of
            [SomeDocItem (cast -> Just (MyGroup "a" (SubDoc subcontents))) :| []] ->
               case toList subcontents of
                 [SomeDocItem (cast -> Just (DVersion 1)) :| []] ->
                   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 (DVersion 1) #
            L.push True #
            L.if_ (L.contractName "aaa" $ L.doc $ DDescription "a") (L.sender # L.drop)
            :: '[] L.:-> '[]
          cutContract =
            L.doc (DVersion 1) #
            L.contractName "aaa" (L.doc $ DDescription "a")
      in L.renderLorentzDoc (L.cutLorentzNonDoc contract)
         @?=
         L.renderLorentzDoc cutContract

  , testCase "DocGroup is handled correctly" $
      let contract =
            L.docGroup (SomeDocItem . MyGroup "b") $
              L.doc (DVersion 1) # L.nop
          cutContract =
            L.docGroup (SomeDocItem . MyGroup "b") $
              L.doc (DVersion 1)
      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 (DVersion 1) :: '[] L.:-> '[]
      in L.renderLorentzDoc (L.fakeCoerce # contract)
         @?=
         L.renderLorentzDoc contract
  ]