Doc.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Tests on autodoc for entrypoints.
module Test.Lorentz.EntryPoints.Doc
  ( test_ParamBuildingSteps_are_correct
  , test_Finalization_check
  , unit_Uncallables_detection
  ) where

import Control.Spoon (teaspoon)
import Test.HUnit (Assertion, assertBool, (@?=))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

import Lorentz ((:->), (/->))
import qualified Lorentz as L
import Lorentz.Doc
import Lorentz.EntryPoints
import Lorentz.EntryPoints.Doc
import Lorentz.Test.Doc
import Lorentz.TypeAnns
import Lorentz.Value
import Michelson.Untyped (EpName(..))

-- Parameters
----------------------------------------------------------------------------

data MySub
  = Dos1
  | Dos2
  deriving stock (Generic)
  deriving anyclass (IsoValue, HasTypeAnn)

instance TypeHasDoc MySub where
  typeDocMdDescription = "MySub"

mySubImpl :: '[MySub] :-> '[]
mySubImpl = L.entryCase (Proxy @PlainEntryPointsKind)
  ( #cDos1 /-> L.nop
  , #cDos2 /-> L.nop
  )

data MyPlainEps
  = Do1 Integer
  | Do2 MySub
  deriving stock (Generic)
  deriving anyclass (IsoValue, HasTypeAnn)

instance TypeHasDoc MyPlainEps where
  typeDocMdDescription = "MyPlainEps"

instance ParameterHasEntryPoints MyPlainEps where
  type ParameterEntryPointsDerivation MyPlainEps = EpdPlain

myPlainImplDumb :: '[MyPlainEps] :-> '[]
myPlainImplDumb = L.entryCase (Proxy @PlainEntryPointsKind)
  ( #cDo1 /-> L.drop
  , #cDo2 /-> mySubImpl
  )

myPlainImpl :: '[MyPlainEps] :-> '[]
myPlainImpl = finalizeParamCallingDoc myPlainImplDumb

data MyRecursiveEps
  = Dor1 Integer
  | Dor2 MySub
  deriving stock (Generic)
  deriving anyclass (IsoValue, HasTypeAnn)

instance ParameterHasEntryPoints MyRecursiveEps where
  type ParameterEntryPointsDerivation MyRecursiveEps = EpdRecursive

myRecursiveImpl :: '[MyRecursiveEps] :-> '[]
myRecursiveImpl = finalizeParamCallingDoc $
  L.entryCase (Proxy @PlainEntryPointsKind)
  ( #cDor1 /-> L.drop
  , #cDor2 /-> mySubImpl
  )

data MyDelegateEps
  = Dod1 Integer
  | Dod2 MyPlainEps
  deriving stock (Generic)
  deriving anyclass (IsoValue, HasTypeAnn)

instance ParameterHasEntryPoints MyDelegateEps where
  type ParameterEntryPointsDerivation MyDelegateEps = EpdDelegate

myDelegateImpl :: '[MyDelegateEps] :-> '[]
myDelegateImpl = finalizeParamCallingDoc $
  L.entryCase (Proxy @PlainEntryPointsKind)
  ( #cDod1 /-> L.drop
  , #cDod2 /-> myPlainImplDumb
  )

myDelegateImplFinalizedTwice :: '[MyDelegateEps] :-> '[]
myDelegateImplFinalizedTwice = finalizeParamCallingDoc $
  L.entryCase (Proxy @PlainEntryPointsKind)
  ( #cDod1 /-> L.drop
  , #cDod2 /-> myPlainImpl
  )

data MyDefEps
  = Do0
  | Default
  deriving stock (Generic)
  deriving anyclass (IsoValue, HasTypeAnn)

instance TypeHasDoc MyDefEps where
  typeDocMdDescription = "MyDefEps"

instance ParameterHasEntryPoints MyDefEps where
  type ParameterEntryPointsDerivation MyDefEps = EpdPlain

myDefImplDumb :: '[MyDefEps] :-> '[]
myDefImplDumb =
  L.entryCase (Proxy @PlainEntryPointsKind)
  ( #cDo0 /-> L.nop
  , #cDefault /-> L.nop
  )

myDefImpl :: '[MyDefEps] :-> '[]
myDefImpl = finalizeParamCallingDoc myDefImplDumb

data MyRecursiveDefEps
  = Dord1 MySub
  | Dord2 MyDefEps
  deriving stock (Generic)
  deriving anyclass (IsoValue, HasTypeAnn)

instance ParameterHasEntryPoints MyRecursiveDefEps where
  type ParameterEntryPointsDerivation MyRecursiveDefEps = EpdRecursive

myRecursiveDefImpl :: '[MyRecursiveDefEps] :-> '[]
myRecursiveDefImpl = finalizeParamCallingDoc $
  L.entryCase (Proxy @PlainEntryPointsKind)
  ( #cDord1 /-> mySubImpl
  , #cDord2 /-> myDefImplDumb
  )

-- Tests
----------------------------------------------------------------------------

-- Similar to 'ParamBuildingSteps', but without details irrelevant for testing
data ParamBuildingType
    -- | Wrap into constructor with given name
    -- NB: starts with capital letter
  = PbtWrapIn Text
    -- | Call given entrypoint
    -- NB: starts with lowercase letter
  | PbtCallEntrypoint Text
    -- | Does something weird
  | PbtCustom
    -- | Entrypoint cannot be called
  | PbtUncallable
  deriving stock (Show, Eq)

pbsType :: ParamBuildingStep -> ParamBuildingType
pbsType = \case
  PbsWrapIn ctor _ -> PbtWrapIn ctor
  PbsCallEntrypoint (unEpName -> ep) -> PbtCallEntrypoint ep
  PbsCustom _ -> PbtCustom
  PbsUncallable _ -> PbtUncallable

getAllBuildingSteps :: (i :-> o) -> [[ParamBuildingType]]
getAllBuildingSteps instr =
  forEachContractDocItem (L.buildLorentzDoc instr) (map pbsType . epaBuilding)

test_ParamBuildingSteps_are_correct :: [TestTree]
test_ParamBuildingSteps_are_correct =
  [ testCase "Simple entrypoints without direct calling" $
      getAllBuildingSteps myPlainImplDumb
        @?= [ [PbtWrapIn "Do1"]
            , [PbtWrapIn "Do2"]
            , [PbtWrapIn "Do2", PbtWrapIn "Dos1"]
            , [PbtWrapIn "Do2", PbtWrapIn "Dos2"]
            ]

  , testCase "Simple entrypoints" $
      getAllBuildingSteps myPlainImpl
        @?= [ [PbtCallEntrypoint "do1"]
            , [PbtCallEntrypoint "do2"]
            , [PbtCallEntrypoint "do2", PbtWrapIn "Dos1"]
            , [PbtCallEntrypoint "do2", PbtWrapIn "Dos2"]
            ]
  , testCase "Recursive entrypoints" $
      getAllBuildingSteps myRecursiveImpl
        @?= [ [PbtCallEntrypoint "dor1"]
            , [PbtCallEntrypoint "", PbtWrapIn "Dor2"]
            , [PbtCallEntrypoint "dos1"]
            , [PbtCallEntrypoint "dos2"]
            ]
  , testCase "Delegate entrypoints" $
      getAllBuildingSteps myDelegateImpl
        @?= [ [PbtCallEntrypoint "dod1"]
            , [PbtCallEntrypoint "dod2"]
            , [PbtCallEntrypoint "do1"]
            , [PbtCallEntrypoint "do2"]
            , [PbtCallEntrypoint "do2", PbtWrapIn "Dos1"]
            , [PbtCallEntrypoint "do2", PbtWrapIn "Dos2"]
            ]

  , testGroup "With explicit default"
    [ testCase "Simple" $
        getAllBuildingSteps myDefImpl
          @?= [ [PbtCallEntrypoint "do0"]
              , [PbtCallEntrypoint ""]
              ]
    , testCase "Recursive" $
        getAllBuildingSteps myRecursiveDefImpl
          @?= [ [PbtUncallable]  -- Dord1 itself
              , [PbtCallEntrypoint "dos1"]
              , [PbtCallEntrypoint "dos2"]
              , [PbtUncallable]  -- Dord2 itself
              , [PbtCallEntrypoint "do0"]
              , [PbtCallEntrypoint ""]
              ]
    ]
  ]

test_Finalization_check :: [TestTree]
test_Finalization_check =
  [ testCase "Cannot apply second time" $
      assertBool "Finalization unexpectedly didn't fail second time" $
        isNothing $ teaspoon myDelegateImplFinalizedTwice
  ]

-- | Note [doc for uncallable entrypoints]:
-- This test is a proof of that sometimes not all entrypoints are callable.
unit_Uncallables_detection :: Assertion
unit_Uncallables_detection =
  expectDocTestFailure testAllEntrypointsAreCallable $
    buildLorentzDoc myRecursiveDefImpl