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

{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

-- | Utilities for declaring and documenting entry points.
module Lorentz.Entrypoints.Doc
  ( DEntrypoint (..)
  , pattern DEntrypointDocItem
  , EntrypointKindHasDoc (..)
  , entrypointSection
  , DEntrypointReference (..)
  , EntryArrow (..)
  , PlainEntrypointsKind
  , CommonContractBehaviourKind
  , CommonEntrypointsBehaviourKind
  , diEntrypointToMarkdown
  , SomeEntrypointArg (..)
  , DEntrypointArg (..)
  , DType (..)
  , DeriveCtorFieldDoc (..)
  , ParamBuilder (..)
  , ParamBuildingDesc (..)
  , ParamBuildingStep (..)
  , mkPbsWrapIn
  , clarifyParamBuildingSteps
  , constructDEpArg
  , emptyDEpArg
  , mkUType
  , mkDEpUType
  , mkDEntrypointArgSimple
  , DocumentEntrypoints
  , documentEntrypoint
  , entryCase
  , entryCase_
  , finalizeParamCallingDoc
  , finalizeParamCallingDoc'
  , areFinalizedParamBuildingSteps
  , entryCaseSimple_
  , entryCaseSimple
  , RequireFlatParamEps
  , RequireFlatEpDerivation
  ) where

import Control.Lens.Cons (_head)
import Data.Char (toLower)
import Data.Constraint (Dict(..))
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Vinyl.Core (RMap, rappend)
import Fmt (Buildable(..), build, fmt, listF)
import GHC.Generics ((:+:))
import qualified GHC.Generics as G
import qualified Text.Show

import Lorentz.ADT
import Lorentz.Annotation
import Lorentz.Base
import Lorentz.Constraints
import Lorentz.Doc
import Lorentz.Entrypoints.Core
import Lorentz.Entrypoints.Helpers
import Lorentz.Entrypoints.Impl
import Michelson.Printer (printTypedValue)
import Michelson.Printer.Util (RenderDoc(..), needsParens, printDocB)
import Michelson.Typed (EpName, ToT, mkUType, pattern DefEpName, sampleTypedValue, sing)
import qualified Michelson.Typed as T
import Michelson.Typed.Haskell.Doc
import Michelson.Typed.Haskell.Instr
import qualified Michelson.Untyped as Untyped
import Util.Label (Label)
import Util.Markdown
import Util.Type
import Util.TypeLits
import Util.TypeTuple
import Util.Typeable

-- | Gathers information about single entrypoint.
--
-- We assume that entry points might be of different kinds,
-- which is designated by phantom type parameter.
-- For instance, you may want to have several groups of entry points
-- corresponding to various parts of a contract - specifying different @kind@
-- type argument for each of those groups will allow you defining different
-- 'DocItem' instances with appropriate custom descriptions for them.
data DEntrypoint (kind :: Type) = DEntrypoint
  { DEntrypoint kind -> Text
depName :: Text
  , DEntrypoint kind -> SubDoc
depSub :: SubDoc
  }

-- | Pattern that checks whether given 'SomeDocItem' hides 'DEntrypoint' inside
-- (of any entrypoint kind).
--
-- In case a specific kind is necessary, use plain @(cast -> Just DEntrypoint{..})@
-- construction instead.
pattern DEntrypointDocItem :: DEntrypoint kind -> SomeDocItem
pattern $mDEntrypointDocItem :: forall r.
SomeDocItem
-> (forall kind. DEntrypoint kind -> r) -> (Void# -> r) -> r
DEntrypointDocItem dep <- SomeDocItem (castIgnoringPhantom -> Just dep)

-- | Default implementation of 'docItemToMarkdown' for entrypoints.
diEntrypointToMarkdown :: HeaderLevel -> DEntrypoint level -> Markdown
diEntrypointToMarkdown :: HeaderLevel -> DEntrypoint level -> Markdown
diEntrypointToMarkdown HeaderLevel
lvl (DEntrypoint Text
name SubDoc
block) =
  Markdown
mdSeparator Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
  HeaderLevel -> Markdown -> Markdown
mdHeader HeaderLevel
lvl (Markdown -> Markdown
mdTicked (Markdown -> Markdown) -> (Text -> Markdown) -> Text -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Markdown
forall p. Buildable p => p -> Markdown
build (Text -> Markdown) -> (Text -> Text) -> Text -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter Text Text Char Char -> (Char -> Char) -> Text -> Text
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Text Text Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ Text
name) Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
    ( SubDoc -> Markdown -> Markdown
modifyExample SubDoc
block
    (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ HeaderLevel -> SubDoc -> Markdown
subDocToMarkdown (HeaderLevel -> HeaderLevel
nextHeaderLevel HeaderLevel
lvl)
    (SubDoc -> Markdown) -> SubDoc -> Markdown
forall a b. (a -> b) -> a -> b
$ SubDoc -> SubDoc
filterDEntrypointExample SubDoc
block
    )
  where
    filterDEntrypointExample :: SubDoc -> SubDoc
filterDEntrypointExample (SubDoc DocBlock
subdoc) =
      DocBlock -> SubDoc
SubDoc (DocBlock -> SubDoc) -> DocBlock -> SubDoc
forall a b. (a -> b) -> a -> b
$ DocItemPos -> DocBlock -> DocBlock
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (DocItem DEntrypointExample => DocItemPos
forall d. DocItem d => DocItemPos
docItemPosition @DEntrypointExample) DocBlock
subdoc

    -- | Modify 'SubDoc' of an entrypoint to replace its example value with the one defined in
    -- 'DEntrypointExample' in an ad-hoc way.
    modifyExample :: SubDoc -> Markdown -> Markdown
    modifyExample :: SubDoc -> Markdown -> Markdown
modifyExample (SubDoc DocBlock
sub) Markdown
subDocMd =
      case (DocItemPos -> DocBlock -> Maybe DocSection
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (DocItem DEntrypointExample => DocItemPos
forall d. DocItem d => DocItemPos
docItemPosition @DEntrypointExample) DocBlock
sub) of
        Just (DocSection ((DocElem d
b Maybe SubDoc
_ ) :| [DocElem d]
_)) ->
          Markdown -> Markdown -> Markdown
mdFindExampleIdAndReplace
            (HeaderLevel -> d -> Markdown
forall d. DocItem d => HeaderLevel -> d -> Markdown
docItemToMarkdown (Int -> HeaderLevel
HeaderLevel Int
0) (d -> Markdown) -> d -> Markdown
forall a b. (a -> b) -> a -> b
$ d
b)
            Markdown
subDocMd
        Maybe DocSection
Nothing -> Markdown
subDocMd

    mdFindExampleIdAndReplace :: Markdown -> Markdown -> Markdown
    mdFindExampleIdAndReplace :: Markdown -> Markdown -> Markdown
mdFindExampleIdAndReplace Markdown
replaceTxt Markdown
inputText =
      Text -> Markdown
forall p. Buildable p => p -> Markdown
build
      (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
unlines
      ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (\Text
w ->  case Text -> Text -> Bool
T.isInfixOf (Text
"id=\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Markdown -> Text
forall b. FromBuilder b => Markdown -> b
fmt @Text Markdown
exampleId) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"") Text
w of
        Bool
True -> FromBuilder Text => Markdown -> Text
forall b. FromBuilder b => Markdown -> b
fmt @Text (Markdown -> Text) -> Markdown -> Text
forall a b. (a -> b) -> a -> b
$ Markdown
"    + " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
          Markdown -> Markdown -> Markdown
mdSubsection Markdown
"Example" (Markdown -> Markdown -> Markdown
mdAddId Markdown
exampleId (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Markdown -> Markdown
mdTicked Markdown
replaceTxt)
        Bool
False -> Text
w
        )
      (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [Text]
lines (Markdown -> Text
forall b. FromBuilder b => Markdown -> b
fmt @Text Markdown
inputText)
      where
        exampleId :: Markdown
exampleId = Markdown
"example-id"

-- | Describes location of entrypoints of the given kind.
--
-- All such entrypoints will be placed under the same "entrypoints" section,
-- and this instance defines characteristics of this section.
class Typeable ep => EntrypointKindHasDoc (ep :: Type) where
  -- | Position of the respective entrypoints section in the doc.
  -- This shares the same positions space with all other doc items.
  entrypointKindPos :: Natural

  -- | Name of the respective entrypoints section.
  entrypointKindSectionName :: Text

  -- | Description in the respective entrypoints section.
  entrypointKindSectionDescription :: Maybe Markdown
  entrypointKindSectionDescription = Maybe Markdown
forall a. Maybe a
Nothing

instance EntrypointKindHasDoc ep => DocItem (DEntrypoint ep) where
  type DocItemPlacement (DEntrypoint ep) = 'DocItemInlined
  type DocItemReferenced (DEntrypoint ep) = 'True
  docItemRef :: DEntrypoint ep
-> DocItemRef
     (DocItemPlacement (DEntrypoint ep))
     (DocItemReferenced (DEntrypoint ep))
docItemRef (DEntrypoint Text
name SubDoc
_) = DocItemId -> DocItemRef 'DocItemInlined 'True
DocItemRefInlined (DocItemId -> DocItemRef 'DocItemInlined 'True)
-> DocItemId -> DocItemRef 'DocItemInlined 'True
forall a b. (a -> b) -> a -> b
$
    Text -> DocItemId
DocItemId (Text
"entrypoints-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (ASetter Text Text Char Char -> (Char -> Char) -> Text -> Text
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Text Text Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
name))
  docItemPos :: Natural
docItemPos = EntrypointKindHasDoc ep => Natural
forall ep. EntrypointKindHasDoc ep => Natural
entrypointKindPos @ep
  docItemSectionName :: Maybe Text
docItemSectionName = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ EntrypointKindHasDoc ep => Text
forall ep. EntrypointKindHasDoc ep => Text
entrypointKindSectionName @ep
  docItemSectionDescription :: Maybe Markdown
docItemSectionDescription = EntrypointKindHasDoc ep => Maybe Markdown
forall ep. EntrypointKindHasDoc ep => Maybe Markdown
entrypointKindSectionDescription @ep
  docItemToMarkdown :: HeaderLevel -> DEntrypoint ep -> Markdown
docItemToMarkdown = HeaderLevel -> DEntrypoint ep -> Markdown
forall level. HeaderLevel -> DEntrypoint level -> Markdown
diEntrypointToMarkdown
  docItemToToc :: HeaderLevel -> DEntrypoint ep -> Markdown
docItemToToc HeaderLevel
lvl d :: DEntrypoint ep
d@(DEntrypoint Text
name SubDoc
_) =
    HeaderLevel -> Markdown -> DEntrypoint ep -> Markdown
forall d.
(DocItem d, DocItemReferenced d ~ 'True) =>
HeaderLevel -> Markdown -> d -> Markdown
mdTocFromRef HeaderLevel
lvl (Text -> Markdown
forall p. Buildable p => p -> Markdown
build (Text -> Markdown) -> (Text -> Text) -> Text -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter Text Text Char Char -> (Char -> Char) -> Text -> Text
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Text Text Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ Text
name) DEntrypoint ep
d

-- | Mark code as part of entrypoint with given name.
--
-- This is automatically called at most of the appropriate situations, like
-- 'entryCase' calls.
entrypointSection
  :: EntrypointKindHasDoc kind
  => Text -> Proxy kind -> (i :-> o) -> (i :-> o)
entrypointSection :: Text -> Proxy kind -> (i :-> o) -> i :-> o
entrypointSection Text
name (Proxy kind
_ :: Proxy kind) =
  (SubDoc -> DEntrypoint kind) -> (i :-> o) -> i :-> o
forall di (inp :: [*]) (out :: [*]).
DocItem di =>
(SubDoc -> di) -> (inp :-> out) -> inp :-> out
docGroup (Text -> SubDoc -> DEntrypoint kind
forall kind. Text -> SubDoc -> DEntrypoint kind
DEntrypoint @kind Text
name)

-- | Default value for 'DEntrypoint' type argument.
data PlainEntrypointsKind

instance EntrypointKindHasDoc PlainEntrypointsKind where
  entrypointKindPos :: Natural
entrypointKindPos = Natural
1000
  entrypointKindSectionName :: Text
entrypointKindSectionName = Text
"Entrypoints"

-- | Describes the behaviour common for all entrypoints.
--
-- For instance, if your contract runs some checks before calling any
-- entrypoint, you probably want to wrap those checks into
-- @entrypointSection "Prior checks" (Proxy \@CommonContractBehaviourKind)@.
data CommonContractBehaviourKind

instance EntrypointKindHasDoc CommonContractBehaviourKind where
  entrypointKindPos :: Natural
entrypointKindPos = Natural
1800
  entrypointKindSectionName :: Text
entrypointKindSectionName = Text
"Common for all contract's entrypoints"

-- | Describes the behaviour common for entrypoints of given kind.
--
-- This has very special use cases, like contracts with mix of upgradeable
-- and permanent entrypoints.
data CommonEntrypointsBehaviourKind kind

instance EntrypointKindHasDoc kind =>
         EntrypointKindHasDoc (CommonEntrypointsBehaviourKind kind) where
  entrypointKindPos :: Natural
entrypointKindPos = EntrypointKindHasDoc kind => Natural
forall ep. EntrypointKindHasDoc ep => Natural
entrypointKindPos @kind Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
5
  entrypointKindSectionName :: Text
entrypointKindSectionName =
    Text
"Common for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EntrypointKindHasDoc kind => Text
forall ep. EntrypointKindHasDoc ep => Text
entrypointKindSectionName @kind
  entrypointKindSectionDescription :: Maybe Markdown
entrypointKindSectionDescription = Markdown -> Maybe Markdown
forall a. a -> Maybe a
Just (Markdown -> Maybe Markdown) -> Markdown -> Maybe Markdown
forall a b. (a -> b) -> a -> b
$
    let refToBase :: Markdown
refToBase = DocItem (DEntrypoint kind) => Maybe Markdown
forall di. DocItem di => Maybe Markdown
docItemSectionRef @(DEntrypoint kind)
                 Maybe Markdown -> Markdown -> Markdown
forall a. Maybe a -> a -> a
?: Text -> Markdown
forall a. HasCallStack => Text -> a
error Text
"Unexpectedly cannot reference section with entrypoints"
    in Markdown
"Logic common for all entrypoints in " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
refToBase Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
" section."

-- | Inserts a reference to an existing entrypoint.
--
-- This helps to avoid duplication in the generated documentation, in order not
-- to overwhelm the reader.
data DEntrypointReference = DEntrypointReference Text Anchor

instance DocItem DEntrypointReference where
  docItemPos :: Natural
docItemPos = Natural
13
  docItemSectionName :: Maybe Text
docItemSectionName = Maybe Text
forall a. Maybe a
Nothing
  docItemToMarkdown :: HeaderLevel -> DEntrypointReference -> Markdown
docItemToMarkdown HeaderLevel
_ (DEntrypointReference Text
name Anchor
anchor) =
    Markdown
"Copies behaviour of " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
    Markdown -> Anchor -> Markdown
forall anchor. ToAnchor anchor => Markdown -> anchor -> Markdown
mdLocalRef (Markdown -> Markdown
mdTicked (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
name) Anchor
anchor Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
    Markdown
" entrypoint."

-- | When describing the way of parameter construction - piece of incremental
-- builder for this description.
newtype ParamBuilder = ParamBuilder
  { ParamBuilder -> Markdown -> Markdown
unParamBuilder :: Markdown -> Markdown
    -- ^ Argument stands for previously constructed parameter piece, and
    -- returned value - a piece constructed after our step.
  }

-- | Show what given 'ParamBuilder' does on a sample.
pbSample :: ParamBuilder -> Markdown
pbSample :: ParamBuilder -> Markdown
pbSample (ParamBuilder Markdown -> Markdown
b) = Markdown -> Markdown
b Markdown
"·"

instance Buildable ParamBuilder where
  build :: ParamBuilder -> Markdown
build = ParamBuilder -> Markdown
pbSample

instance Show ParamBuilder where
  show :: ParamBuilder -> String
show (ParamBuilder Markdown -> Markdown
pb) =
    -- Using @'x'@ symbol here because unicode does not render well in 'show'
    String
"ParamBuilder " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Markdown -> String
forall b a. (Show a, IsString b) => a -> b
show (Markdown -> Markdown
pb Markdown
"x")

instance Eq ParamBuilder where
  == :: ParamBuilder -> ParamBuilder -> Bool
(==) = Markdown -> Markdown -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Markdown -> Markdown -> Bool)
-> (ParamBuilder -> Markdown)
-> ParamBuilder
-> ParamBuilder
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ParamBuilder -> Markdown
pbSample

data ParamBuildingDesc = ParamBuildingDesc
  { ParamBuildingDesc -> Markdown
pbdEnglish :: Markdown
    -- ^ Plain english description of this step.
  , ParamBuildingDesc -> ParamBuilder
pbdHaskell :: ParamBuilder
    -- ^ How to construct parameter in Haskell code.
  , ParamBuildingDesc -> ParamBuilder
pbdMichelson :: ParamBuilder
    -- ^ How to construct parameter working on raw Michelson.
  } deriving stock (Int -> ParamBuildingDesc -> ShowS
[ParamBuildingDesc] -> ShowS
ParamBuildingDesc -> String
(Int -> ParamBuildingDesc -> ShowS)
-> (ParamBuildingDesc -> String)
-> ([ParamBuildingDesc] -> ShowS)
-> Show ParamBuildingDesc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParamBuildingDesc] -> ShowS
$cshowList :: [ParamBuildingDesc] -> ShowS
show :: ParamBuildingDesc -> String
$cshow :: ParamBuildingDesc -> String
showsPrec :: Int -> ParamBuildingDesc -> ShowS
$cshowsPrec :: Int -> ParamBuildingDesc -> ShowS
Show, ParamBuildingDesc -> ParamBuildingDesc -> Bool
(ParamBuildingDesc -> ParamBuildingDesc -> Bool)
-> (ParamBuildingDesc -> ParamBuildingDesc -> Bool)
-> Eq ParamBuildingDesc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParamBuildingDesc -> ParamBuildingDesc -> Bool
$c/= :: ParamBuildingDesc -> ParamBuildingDesc -> Bool
== :: ParamBuildingDesc -> ParamBuildingDesc -> Bool
$c== :: ParamBuildingDesc -> ParamBuildingDesc -> Bool
Eq)

-- | Describes a parameter building step.
--
-- This can be wrapping into (Haskell) constructor, or a more complex
-- transformation.
data ParamBuildingStep
    -- | Wraps something into constructor with given name.
    -- Constructor should be the one which corresponds to an entrypoint
    -- defined via field annotation, for more complex cases use 'PbsCustom'.
  = PbsWrapIn Text ParamBuildingDesc
    -- | Directly call an entrypoint marked with a field annotation.
  | PbsCallEntrypoint EpName
    -- | Other action.
  | PbsCustom ParamBuildingDesc
    -- | This entrypoint cannot be called, which is possible when an explicit
    -- default entrypoint is present. This is not a true entrypoint but just some
    -- intermediate node in @or@ tree and neither it nor any of its parents
    -- are marked with a field annotation.
    --
    -- It contains dummy 'ParamBuildingStep's which were assigned before
    -- entrypoints were taken into account.
  | PbsUncallable [ParamBuildingStep]
  deriving stock (Int -> ParamBuildingStep -> ShowS
[ParamBuildingStep] -> ShowS
ParamBuildingStep -> String
(Int -> ParamBuildingStep -> ShowS)
-> (ParamBuildingStep -> String)
-> ([ParamBuildingStep] -> ShowS)
-> Show ParamBuildingStep
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParamBuildingStep] -> ShowS
$cshowList :: [ParamBuildingStep] -> ShowS
show :: ParamBuildingStep -> String
$cshow :: ParamBuildingStep -> String
showsPrec :: Int -> ParamBuildingStep -> ShowS
$cshowsPrec :: Int -> ParamBuildingStep -> ShowS
Show, ParamBuildingStep -> ParamBuildingStep -> Bool
(ParamBuildingStep -> ParamBuildingStep -> Bool)
-> (ParamBuildingStep -> ParamBuildingStep -> Bool)
-> Eq ParamBuildingStep
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParamBuildingStep -> ParamBuildingStep -> Bool
$c/= :: ParamBuildingStep -> ParamBuildingStep -> Bool
== :: ParamBuildingStep -> ParamBuildingStep -> Bool
$c== :: ParamBuildingStep -> ParamBuildingStep -> Bool
Eq)

instance Buildable ParamBuildingStep where
  build :: ParamBuildingStep -> Markdown
build = \case
    PbsWrapIn Text
ctor ParamBuildingDesc
_desc -> Markdown
"Wrap in `" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
ctor Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
"`"
    PbsCallEntrypoint EpName
ep -> Markdown
"Call entrypoint " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> EpName -> Markdown
forall p. Buildable p => p -> Markdown
build EpName
ep
    PbsCustom ParamBuildingDesc
desc -> Markdown
"Custom: \"" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> ParamBuildingDesc -> Markdown
pbdEnglish ParamBuildingDesc
desc Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
"\""
    PbsUncallable [ParamBuildingStep]
steps -> Markdown
"Uncallable; dummy steps: " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> [ParamBuildingStep] -> Markdown
forall (f :: * -> *) a.
(Foldable f, Buildable a) =>
f a -> Markdown
listF [ParamBuildingStep]
steps

-- | Make a 'ParamBuildingStep' that tells about wrapping an argument into
-- a constructor with given name and uses given 'ParamBuilder' as description of
-- Michelson part.
mkPbsWrapIn :: Text -> ParamBuilder -> ParamBuildingStep
mkPbsWrapIn :: Text -> ParamBuilder -> ParamBuildingStep
mkPbsWrapIn Text
ctorName ParamBuilder
michDesc =
  Text -> ParamBuildingDesc -> ParamBuildingStep
PbsWrapIn Text
ctorName ParamBuildingDesc :: Markdown -> ParamBuilder -> ParamBuilder -> ParamBuildingDesc
ParamBuildingDesc
    { pbdEnglish :: Markdown
pbdEnglish = Markdown
"Wrap into " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown -> Markdown
mdTicked (Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
ctorName) Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
" constructor."
    , pbdHaskell :: ParamBuilder
pbdHaskell = (Markdown -> Markdown) -> ParamBuilder
ParamBuilder ((Markdown -> Markdown) -> ParamBuilder)
-> (Markdown -> Markdown) -> ParamBuilder
forall a b. (a -> b) -> a -> b
$ \Markdown
p -> Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
ctorName Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
" (" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
p Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
")"
    , pbdMichelson :: ParamBuilder
pbdMichelson = ParamBuilder
michDesc
    }

-- | Entrypoint argument type in typed representation.
data SomeEntrypointArg =
  forall a. (NiceParameter a, TypeHasDoc a) => SomeEntrypointArg (Proxy a)

-- | Describes argument of an entrypoint.
data DEntrypointArg =
  DEntrypointArg
  { DEntrypointArg -> Maybe SomeEntrypointArg
epaArg :: Maybe SomeEntrypointArg
    -- ^ Argument of the entrypoint. Pass 'Nothing' if no argument is required.
  , DEntrypointArg -> [ParamBuildingStep]
epaBuilding :: [ParamBuildingStep]
    -- ^ Describes a way to lift an entrypoint argument into full parameter
    -- which can be passed to the contract.
    --
    -- Steps are supposed to be applied in the order opposite to one in which
    -- they are given.
    -- E.g. suppose that an entrypoint is called as @Run (Service1 arg)@;
    -- then the first step (actual last) should describe wrapping into @Run@
    -- constructor, and the second step (actual first) should be about wrapping
    -- into @Service1@ constructor.
  }

constructDEpArg
  :: forall arg.
     ( NiceParameter arg
     , TypeHasDoc arg
     )
  => DEntrypointArg
constructDEpArg :: DEntrypointArg
constructDEpArg = DEntrypointArg :: Maybe SomeEntrypointArg -> [ParamBuildingStep] -> DEntrypointArg
DEntrypointArg
  { epaArg :: Maybe SomeEntrypointArg
epaArg = SomeEntrypointArg -> Maybe SomeEntrypointArg
forall a. a -> Maybe a
Just (SomeEntrypointArg -> Maybe SomeEntrypointArg)
-> SomeEntrypointArg -> Maybe SomeEntrypointArg
forall a b. (a -> b) -> a -> b
$ Proxy arg -> SomeEntrypointArg
forall a.
(NiceParameter a, TypeHasDoc a) =>
Proxy a -> SomeEntrypointArg
SomeEntrypointArg (Proxy arg
forall k (t :: k). Proxy t
Proxy @arg)
  , epaBuilding :: [ParamBuildingStep]
epaBuilding = []
  }

emptyDEpArg :: DEntrypointArg
emptyDEpArg :: DEntrypointArg
emptyDEpArg = DEntrypointArg :: Maybe SomeEntrypointArg -> [ParamBuildingStep] -> DEntrypointArg
DEntrypointArg
  { epaArg :: Maybe SomeEntrypointArg
epaArg = Maybe SomeEntrypointArg
forall a. Maybe a
Nothing
  , epaBuilding :: [ParamBuildingStep]
epaBuilding = []
  }

mkDEpUType :: forall t. (KnownValue t, HasAnnotation t) => Untyped.Ty
mkDEpUType :: Ty
mkDEpUType = Notes (ToT t) -> Ty
forall (x :: T). SingI x => Notes x -> Ty
mkUType (FollowEntrypointFlag -> Notes (ToT t)
forall a. HasAnnotation a => FollowEntrypointFlag -> Notes (ToT a)
getAnnotation @t FollowEntrypointFlag
FollowEntrypoint)

mkDEntrypointArgSimple
  :: forall t.
     ( NiceParameter t
     , TypeHasDoc t
     )
  => DEntrypointArg
mkDEntrypointArgSimple :: DEntrypointArg
mkDEntrypointArgSimple = DEntrypointArg :: Maybe SomeEntrypointArg -> [ParamBuildingStep] -> DEntrypointArg
DEntrypointArg
  { epaArg :: Maybe SomeEntrypointArg
epaArg = SomeEntrypointArg -> Maybe SomeEntrypointArg
forall a. a -> Maybe a
Just (SomeEntrypointArg -> Maybe SomeEntrypointArg)
-> SomeEntrypointArg -> Maybe SomeEntrypointArg
forall a b. (a -> b) -> a -> b
$ Proxy t -> SomeEntrypointArg
forall a.
(NiceParameter a, TypeHasDoc a) =>
Proxy a -> SomeEntrypointArg
SomeEntrypointArg (Proxy t
forall k (t :: k). Proxy t
Proxy @t)
  , epaBuilding :: [ParamBuildingStep]
epaBuilding = []
  }

-- | Go over contract code and update every occurrence of 'DEntrypointArg'
-- documentation item, modifying param building steps.
modifyParamBuildingSteps
  :: ([ParamBuildingStep] -> [ParamBuildingStep])
  -> (inp :-> out)
  -> (inp :-> out)
modifyParamBuildingSteps :: ([ParamBuildingStep] -> [ParamBuildingStep])
-> (inp :-> out) -> inp :-> out
modifyParamBuildingSteps [ParamBuildingStep] -> [ParamBuildingStep]
f =
  (DEntrypointArg -> Maybe DEntrypointArg)
-> (inp :-> out) -> inp :-> out
forall a i1 i2.
(ContainsUpdateableDoc a, DocItem i1, DocItem i2) =>
(i1 -> Maybe i2) -> a -> a
modifyDoc (\DEntrypointArg
di -> DEntrypointArg -> Maybe DEntrypointArg
forall a. a -> Maybe a
Just DEntrypointArg
di{ epaBuilding :: [ParamBuildingStep]
epaBuilding = [ParamBuildingStep] -> [ParamBuildingStep]
f (DEntrypointArg -> [ParamBuildingStep]
epaBuilding DEntrypointArg
di) })

-- | Go over contract code and update every occurrence of 'DEntrypointArg'
-- documentation item, adding the given step to its "how to build parameter"
-- description.
clarifyParamBuildingSteps :: ParamBuildingStep -> (inp :-> out) -> (inp :-> out)
clarifyParamBuildingSteps :: ParamBuildingStep -> (inp :-> out) -> inp :-> out
clarifyParamBuildingSteps ParamBuildingStep
pbs =
  ([ParamBuildingStep] -> [ParamBuildingStep])
-> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
([ParamBuildingStep] -> [ParamBuildingStep])
-> (inp :-> out) -> inp :-> out
modifyParamBuildingSteps (ParamBuildingStep
pbs ParamBuildingStep -> [ParamBuildingStep] -> [ParamBuildingStep]
forall a. a -> [a] -> [a]
:)

instance DocItem DEntrypointArg where
  docItemPos :: Natural
docItemPos = Natural
20
  docItemSectionName :: Maybe Text
docItemSectionName = Maybe Text
forall a. Maybe a
Nothing
  docItemDependencies :: DEntrypointArg -> [SomeDocDefinitionItem]
docItemDependencies (DEntrypointArg Maybe SomeEntrypointArg
mdty [ParamBuildingStep]
_) =
    [ DType -> SomeDocDefinitionItem
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
d -> SomeDocDefinitionItem
SomeDocDefinitionItem (Proxy a -> DType
forall a. TypeHasDoc a => Proxy a -> DType
DType (Proxy a -> DType) -> Proxy a -> DType
forall a b. (a -> b) -> a -> b
$ Proxy a
forall k (t :: k). Proxy t
Proxy @ty)
    | Just (SomeEntrypointArg (Proxy a
_ :: Proxy ty)) <- Maybe SomeEntrypointArg -> [Maybe SomeEntrypointArg]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SomeEntrypointArg
mdty ]
  docItemToMarkdown :: HeaderLevel -> DEntrypointArg -> Markdown
docItemToMarkdown HeaderLevel
_ (DEntrypointArg Maybe SomeEntrypointArg
mdty [ParamBuildingStep]
psteps) =
    [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown)
-> ([Markdown] -> [Markdown]) -> [Markdown] -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Markdown -> Markdown) -> [Markdown] -> [Markdown]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.map (Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
"\n\n") ([Markdown] -> Markdown) -> [Markdown] -> Markdown
forall a b. (a -> b) -> a -> b
$
      [ Markdown -> Markdown -> Markdown
mdSubsection Markdown
"Argument" (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$
          case Maybe SomeEntrypointArg
mdty of
            Maybe SomeEntrypointArg
Nothing -> Markdown
"none (pass unit)"
            Just (SomeEntrypointArg (Proxy a
dty :: Proxy ep)) -> [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown)
-> ([Markdown] -> [Markdown]) -> [Markdown] -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markdown -> [Markdown] -> [Markdown]
forall a. a -> [a] -> [a]
Prelude.intersperse Markdown
"\n" ([Markdown] -> Markdown) -> [Markdown] -> Markdown
forall a b. (a -> b) -> a -> b
$
              [ Markdown
forall a. Monoid a => a
mempty
              , Markdown
"  + " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
                Markdown -> Markdown -> Markdown
mdSubsection Markdown
"In Haskell"
                  (Proxy a -> WithinParens -> Markdown
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Markdown
typeDocMdReference Proxy a
dty (Bool -> WithinParens
WithinParens Bool
False))
              , Markdown
"  + " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
                Markdown -> Markdown -> Markdown
mdSubsection Markdown
"In Michelson"
                  (Markdown -> Markdown
mdTicked (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Bool -> Doc -> Markdown
printDocB Bool
False (Doc -> Markdown) -> (Ty -> Doc) -> Ty -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderContext -> Ty -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
needsParens (Ty -> Markdown) -> Ty -> Markdown
forall a b. (a -> b) -> a -> b
$
                     SingI (ToT a) => Ty
forall (t :: T). SingI t => Ty
T.untypeDemoteT @(T.ToT ep))
              , Markdown -> Maybe Markdown -> Markdown
forall a. a -> Maybe a -> a
fromMaybe Markdown
"" (Maybe Markdown -> Markdown) -> Maybe Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Sing (ToT a) -> Maybe (Value (ToT a))
forall (t :: T). Sing t -> Maybe (Value t)
sampleTypedValue (SingI (ToT a) => Sing (ToT a)
forall k (a :: k). SingI a => Sing a
sing @(ToT ep)) Maybe (Value (ToT a))
-> (Value (ToT a) -> Markdown) -> Maybe Markdown
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Value (ToT a)
sampleVal ->
                Markdown
"    + " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
                Markdown -> Markdown -> Markdown
mdSubsection Markdown
"Example"
                  (Markdown -> Markdown -> Markdown
mdAddId Markdown
"example-id"
                    (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Markdown -> Markdown
mdTicked
                    (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Text -> Markdown
forall p. Buildable p => p -> Markdown
build (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ Bool -> Value (ToT a) -> Text
forall (t :: T).
ProperPrintedValBetterErrors t =>
Bool -> Value t -> Text
printTypedValue Bool
True Value (ToT a)
sampleVal
                  )
              ],
          Markdown -> Markdown -> Markdown
mdSpoiler Markdown
"How to call this entrypoint" (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$
            Markdown
"\n0. Construct an argument for the entrypoint.\n" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
            Markdown
howToCall
      ]
    where
      howToCall :: Markdown
howToCall =
        [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown)
-> ([Markdown] -> [Markdown]) -> [Markdown] -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markdown -> [Markdown] -> [Markdown]
forall a. a -> [a] -> [a]
Prelude.intersperse Markdown
"\n" ([Markdown] -> Markdown) -> [Markdown] -> Markdown
forall a b. (a -> b) -> a -> b
$
        -- Markdown re-enumerates enumerated lists automatically
        (Markdown -> Markdown) -> [Markdown] -> [Markdown]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.map (Markdown
"1. " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>) ([Markdown] -> [Markdown]) -> [Markdown] -> [Markdown]
forall a b. (a -> b) -> a -> b
$
          [ParamBuildingStep] -> [ParamBuildingStep]
forall a. [a] -> [a]
reverse [ParamBuildingStep]
psteps [ParamBuildingStep]
-> (ParamBuildingStep -> Markdown) -> [Markdown]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            PbsWrapIn Text
_ ParamBuildingDesc
pbd ->
              ParamBuildingDesc -> Markdown
renderPbDesc ParamBuildingDesc
pbd
            PbsCallEntrypoint EpName
ep -> case EpName
ep of
              EpName
DefEpName ->
                Markdown
"Call the contract (default entrypoint) with the constructed \
                \argument."
              EpName
_ ->
                Markdown
"Call contract's " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown -> Markdown
mdTicked (EpName -> Markdown
forall p. Buildable p => p -> Markdown
build EpName
ep) Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
" entrypoint \
                \passing the constructed argument."
            PbsCustom ParamBuildingDesc
pbd ->
              ParamBuildingDesc -> Markdown
renderPbDesc ParamBuildingDesc
pbd
            PbsUncallable [ParamBuildingStep]
_ ->
              Markdown
"Feel sad: this entrypoint *cannot* be called and is enlisted \
              \here only to describe the parameter structure."
              -- We could hide such entrypoints, but then in case of incorrect
              -- use of 'entryCase's or a bug in documentation, understanding
              -- what's going on would be hard

      renderPbDesc :: ParamBuildingDesc -> Markdown
renderPbDesc ParamBuildingDesc{Markdown
ParamBuilder
pbdMichelson :: ParamBuilder
pbdHaskell :: ParamBuilder
pbdEnglish :: Markdown
pbdMichelson :: ParamBuildingDesc -> ParamBuilder
pbdHaskell :: ParamBuildingDesc -> ParamBuilder
pbdEnglish :: ParamBuildingDesc -> Markdown
..} =
        [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown)
-> ([Markdown] -> [Markdown]) -> [Markdown] -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markdown -> [Markdown] -> [Markdown]
forall a. a -> [a] -> [a]
Prelude.intersperse Markdown
"\n" ([Markdown] -> Markdown) -> [Markdown] -> Markdown
forall a b. (a -> b) -> a -> b
$
        [ Markdown
pbdEnglish
        , Markdown
"    + " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
          Markdown -> Markdown -> Markdown
mdSubsection Markdown
"In Haskell" (Markdown -> Markdown
mdTicked (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ ParamBuilder -> Markdown
pbSample ParamBuilder
pbdHaskell)
        , Markdown
"    + " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
          Markdown -> Markdown -> Markdown
mdSubsection Markdown
"In Michelson" (Markdown -> Markdown
mdTicked (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ ParamBuilder -> Markdown
pbSample ParamBuilder
pbdMichelson)
        ]

-- | Pick a type documentation from 'CtorField'.
class (KnownSymbol con) => DeriveCtorFieldDoc con (cf :: CtorField) where
  deriveCtorFieldDoc :: DEntrypointArg

instance
    (KnownSymbol con)
  =>
    DeriveCtorFieldDoc con 'NoFields
  where
  deriveCtorFieldDoc :: DEntrypointArg
deriveCtorFieldDoc = DEntrypointArg
emptyDEpArg

instance
    (NiceParameter ty, TypeHasDoc ty, KnownValue ty, KnownSymbol con)
  =>
    DeriveCtorFieldDoc con ('OneField ty)
  where
  deriveCtorFieldDoc :: DEntrypointArg
deriveCtorFieldDoc = (NiceParameter ty, TypeHasDoc ty) => DEntrypointArg
forall arg. (NiceParameter arg, TypeHasDoc arg) => DEntrypointArg
constructDEpArg @ty

-- | Add necessary documentation to entry points.
documentEntrypoints
  :: forall a kind inp out.
     DocumentEntrypoints kind a
  => Rec (CaseClauseL inp out) (CaseClauses a)
  -> Rec (CaseClauseL inp out) (CaseClauses a)
documentEntrypoints :: Rec (CaseClauseL inp out) (CaseClauses a)
-> Rec (CaseClauseL inp out) (CaseClauses a)
documentEntrypoints = ParamBuilder
-> Rec (CaseClauseL inp out) (CaseClauses a)
-> Rec (CaseClauseL inp out) (CaseClauses a)
forall kind (x :: * -> *) (inp :: [*]) (out :: [*]).
GDocumentEntrypoints kind x =>
ParamBuilder
-> Rec (CaseClauseL inp out) (GCaseClauses x)
-> Rec (CaseClauseL inp out) (GCaseClauses x)
gDocumentEntrypoints @kind @(G.Rep a) ((Markdown -> Markdown) -> ParamBuilder
ParamBuilder Markdown -> Markdown
forall a. a -> a
id)

-- | Constraint for 'documentEntrypoints'.
type DocumentEntrypoints kind a =
  (Generic a, GDocumentEntrypoints kind (G.Rep a))

-- | Traverse entry points and add parameter building step (which describes
-- necessity to wrap parameter into some constructor of the given datatype)
-- to all parameters described within given code.
class GDocumentEntrypoints (kind :: Type) (x :: Type -> Type) where
  -- | Add corresponding parameter building step.
  --
  -- First argument is accumulator for Michelson description of the building step.
  gDocumentEntrypoints
    :: ParamBuilder
    -> Rec (CaseClauseL inp out) (GCaseClauses x)
    -> Rec (CaseClauseL inp out) (GCaseClauses x)

instance GDocumentEntrypoints kind x => GDocumentEntrypoints kind (G.D1 i x) where
  gDocumentEntrypoints :: ParamBuilder
-> Rec (CaseClauseL inp out) (GCaseClauses (D1 i x))
-> Rec (CaseClauseL inp out) (GCaseClauses (D1 i x))
gDocumentEntrypoints = forall (inp :: [*]) (out :: [*]).
GDocumentEntrypoints kind x =>
ParamBuilder
-> Rec (CaseClauseL inp out) (GCaseClauses x)
-> Rec (CaseClauseL inp out) (GCaseClauses x)
forall kind (x :: * -> *) (inp :: [*]) (out :: [*]).
GDocumentEntrypoints kind x =>
ParamBuilder
-> Rec (CaseClauseL inp out) (GCaseClauses x)
-> Rec (CaseClauseL inp out) (GCaseClauses x)
gDocumentEntrypoints @kind @x

instance ( GDocumentEntrypoints kind x, GDocumentEntrypoints kind y
         , RSplit (GCaseClauses x) (GCaseClauses y)
         ) =>
         GDocumentEntrypoints kind (x :+: y) where
  gDocumentEntrypoints :: ParamBuilder
-> Rec (CaseClauseL inp out) (GCaseClauses (x :+: y))
-> Rec (CaseClauseL inp out) (GCaseClauses (x :+: y))
gDocumentEntrypoints (ParamBuilder Markdown -> Markdown
michDesc) Rec (CaseClauseL inp out) (GCaseClauses (x :+: y))
clauses =
    let (Rec (CaseClauseL inp out) (GCaseClauses x)
lclauses, Rec (CaseClauseL inp out) (GCaseClauses y)
rclauses) = Rec (CaseClauseL inp out) (GCaseClauses x ++ GCaseClauses y)
-> (Rec (CaseClauseL inp out) (GCaseClauses x),
    Rec (CaseClauseL inp out) (GCaseClauses y))
forall k (l :: [k]) (r :: [k]) (f :: k -> *).
RSplit l r =>
Rec f (l ++ r) -> (Rec f l, Rec f r)
rsplit @CaseClauseParam @(GCaseClauses x) Rec (CaseClauseL inp out) (GCaseClauses x ++ GCaseClauses y)
Rec (CaseClauseL inp out) (GCaseClauses (x :+: y))
clauses
    in ParamBuilder
-> Rec (CaseClauseL inp out) (GCaseClauses x)
-> Rec (CaseClauseL inp out) (GCaseClauses x)
forall kind (x :: * -> *) (inp :: [*]) (out :: [*]).
GDocumentEntrypoints kind x =>
ParamBuilder
-> Rec (CaseClauseL inp out) (GCaseClauses x)
-> Rec (CaseClauseL inp out) (GCaseClauses x)
gDocumentEntrypoints @kind @x
         ((Markdown -> Markdown) -> ParamBuilder
ParamBuilder ((Markdown -> Markdown) -> ParamBuilder)
-> (Markdown -> Markdown) -> ParamBuilder
forall a b. (a -> b) -> a -> b
$ \Markdown
a -> Markdown -> Markdown
michDesc (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Markdown
"Left (" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
a Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
")")
         Rec (CaseClauseL inp out) (GCaseClauses x)
lclauses
       Rec (CaseClauseL inp out) (GCaseClauses x)
-> Rec (CaseClauseL inp out) (GCaseClauses y)
-> Rec (CaseClauseL inp out) (GCaseClauses x ++ GCaseClauses y)
forall k (f :: k -> *) (as :: [k]) (bs :: [k]).
Rec f as -> Rec f bs -> Rec f (as ++ bs)
`rappend`
       ParamBuilder
-> Rec (CaseClauseL inp out) (GCaseClauses y)
-> Rec (CaseClauseL inp out) (GCaseClauses y)
forall kind (x :: * -> *) (inp :: [*]) (out :: [*]).
GDocumentEntrypoints kind x =>
ParamBuilder
-> Rec (CaseClauseL inp out) (GCaseClauses x)
-> Rec (CaseClauseL inp out) (GCaseClauses x)
gDocumentEntrypoints @kind @y
         ((Markdown -> Markdown) -> ParamBuilder
ParamBuilder ((Markdown -> Markdown) -> ParamBuilder)
-> (Markdown -> Markdown) -> ParamBuilder
forall a b. (a -> b) -> a -> b
$ \Markdown
a -> Markdown -> Markdown
michDesc (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Markdown
"Right (" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
a Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
")")
         Rec (CaseClauseL inp out) (GCaseClauses y)
rclauses

instance ( 'CaseClauseParam ctor cf ~ GCaseBranchInput ctor x
         , KnownSymbol ctor
         , DocItem (DEntrypoint kind)
         , DeriveCtorFieldDoc ctor cf
         ) =>
         GDocumentEntrypoints kind (G.C1 ('G.MetaCons ctor _1 _2) x) where
  gDocumentEntrypoints :: ParamBuilder
-> Rec
     (CaseClauseL inp out) (GCaseClauses (C1 ('MetaCons ctor _1 _2) x))
-> Rec
     (CaseClauseL inp out) (GCaseClauses (C1 ('MetaCons ctor _1 _2) x))
gDocumentEntrypoints ParamBuilder
michDesc (CaseClauseL AppendCtorField x inp :-> out
clause :& Rec (CaseClauseL inp out) rs
RNil) =
    let entrypointName :: Text
entrypointName = String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy ctor -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy ctor
forall k (t :: k). Proxy t
Proxy @ctor)
        psteps :: ParamBuildingStep
psteps = Text -> ParamBuilder -> ParamBuildingStep
mkPbsWrapIn Text
entrypointName ParamBuilder
michDesc
        addDoc :: (AppendCtorField cf inp :-> out) -> AppendCtorField cf inp :-> out
addDoc AppendCtorField cf inp :-> out
instr =
          ParamBuildingStep
-> (AppendCtorField cf inp :-> out)
-> AppendCtorField cf inp :-> out
forall (inp :: [*]) (out :: [*]).
ParamBuildingStep -> (inp :-> out) -> inp :-> out
clarifyParamBuildingSteps ParamBuildingStep
psteps ((AppendCtorField cf inp :-> out)
 -> AppendCtorField cf inp :-> out)
-> (AppendCtorField cf inp :-> out)
-> AppendCtorField cf inp :-> out
forall a b. (a -> b) -> a -> b
$
          (SubDoc -> DEntrypoint kind)
-> (AppendCtorField cf inp :-> out)
-> AppendCtorField cf inp :-> out
forall di (inp :: [*]) (out :: [*]).
DocItem di =>
(SubDoc -> di) -> (inp :-> out) -> inp :-> out
docGroup (Text -> SubDoc -> DEntrypoint kind
forall kind. Text -> SubDoc -> DEntrypoint kind
DEntrypoint @kind Text
entrypointName) ((AppendCtorField cf inp :-> out)
 -> AppendCtorField cf inp :-> out)
-> (AppendCtorField cf inp :-> out)
-> AppendCtorField cf inp :-> out
forall a b. (a -> b) -> a -> b
$
          DEntrypointArg -> AppendCtorField cf inp :-> AppendCtorField cf inp
forall di (s :: [*]). DocItem di => di -> s :-> s
doc (DeriveCtorFieldDoc ctor cf => DEntrypointArg
forall (con :: Symbol) (cf :: CtorField).
DeriveCtorFieldDoc con cf =>
DEntrypointArg
deriveCtorFieldDoc @ctor @cf) (AppendCtorField cf inp :-> AppendCtorField cf inp)
-> (AppendCtorField cf inp :-> out)
-> AppendCtorField cf inp :-> out
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# AppendCtorField cf inp :-> out
instr
    in (AppendCtorField cf inp :-> out)
-> CaseClauseL inp out ('CaseClauseParam ctor cf)
forall (x :: CtorField) (inp :: [*]) (out :: [*]) (ctor :: Symbol).
(AppendCtorField x inp :-> out)
-> CaseClauseL inp out ('CaseClauseParam ctor x)
CaseClauseL ((AppendCtorField cf inp :-> out) -> AppendCtorField cf inp :-> out
addDoc AppendCtorField cf inp :-> out
AppendCtorField x inp :-> out
clause) CaseClauseL inp out ('CaseClauseParam ctor cf)
-> Rec (CaseClauseL inp out) '[]
-> Rec (CaseClauseL inp out) '[ 'CaseClauseParam ctor cf]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec (CaseClauseL inp out) '[]
forall u (a :: u -> *). Rec a '[]
RNil

-- | Like 'case_', to be used for pattern-matching on a parameter
-- or its part.
--
-- Modifies documentation accordingly. Including description of
-- entrypoints' arguments, thus for them you will need to supply
-- 'TypeHasDoc' instance.
entryCase_
  :: forall dt entrypointKind out inp.
     ( InstrCaseC dt
     , RMap (CaseClauses dt)
     , DocumentEntrypoints entrypointKind dt
     )
  => Proxy entrypointKind
  -> Rec (CaseClauseL inp out) (CaseClauses dt)
  -> dt : inp :-> out
entryCase_ :: Proxy entrypointKind
-> Rec (CaseClauseL inp out) (CaseClauses dt) -> (dt : inp) :-> out
entryCase_ Proxy entrypointKind
_ = Rec (CaseClauseL inp out) (CaseClauses dt) -> (dt : inp) :-> out
forall dt (out :: [*]) (inp :: [*]).
(InstrCaseC dt, RMap (CaseClauses dt)) =>
Rec (CaseClauseL inp out) (CaseClauses dt) -> (dt : inp) :-> out
case_ (Rec (CaseClauseL inp out) (CaseClauses dt) -> (dt : inp) :-> out)
-> (Rec (CaseClauseL inp out) (CaseClauses dt)
    -> Rec (CaseClauseL inp out) (CaseClauses dt))
-> Rec (CaseClauseL inp out) (CaseClauses dt)
-> (dt : inp) :-> out
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (inp :: [*]) (out :: [*]).
DocumentEntrypoints entrypointKind dt =>
Rec (CaseClauseL inp out) (CaseClauses dt)
-> Rec (CaseClauseL inp out) (CaseClauses dt)
forall a kind (inp :: [*]) (out :: [*]).
DocumentEntrypoints kind a =>
Rec (CaseClauseL inp out) (CaseClauses a)
-> Rec (CaseClauseL inp out) (CaseClauses a)
documentEntrypoints @dt @entrypointKind

-- | Version of 'entryCase_' for tuples.
entryCase
  :: forall dt entrypointKind out inp clauses.
     ( CaseTC dt out inp clauses
     , DocumentEntrypoints entrypointKind dt
     )
  => Proxy entrypointKind -> IsoRecTuple clauses -> dt : inp :-> out
entryCase :: Proxy entrypointKind -> IsoRecTuple clauses -> (dt : inp) :-> out
entryCase Proxy entrypointKind
p = Proxy entrypointKind
-> Rec (CaseClauseL inp out) (GCaseClauses (Rep dt))
-> (dt : inp) :-> out
forall dt entrypointKind (out :: [*]) (inp :: [*]).
(InstrCaseC dt, RMap (CaseClauses dt),
 DocumentEntrypoints entrypointKind dt) =>
Proxy entrypointKind
-> Rec (CaseClauseL inp out) (CaseClauses dt) -> (dt : inp) :-> out
entryCase_ Proxy entrypointKind
p (Rec (CaseClauseL inp out) (GCaseClauses (Rep dt))
 -> (dt : inp) :-> out)
-> (IsoRecTuple (Rec (CaseClauseL inp out) (GCaseClauses (Rep dt)))
    -> Rec (CaseClauseL inp out) (GCaseClauses (Rep dt)))
-> IsoRecTuple (Rec (CaseClauseL inp out) (GCaseClauses (Rep dt)))
-> (dt : inp) :-> out
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsoRecTuple (Rec (CaseClauseL inp out) (GCaseClauses (Rep dt)))
-> Rec (CaseClauseL inp out) (GCaseClauses (Rep dt))
forall r. RecFromTuple r => IsoRecTuple r -> r
recFromTuple

-- | Wrapper for documenting single entrypoint which parameter
-- isn't going to be unwrapped from some datatype.
--
-- @entryCase@ unwraps a datatype, however, sometimes we want to
-- have entrypoint parameter to be not wrapped into some datatype.
documentEntrypoint
  :: forall kind epName param s out.
     ( KnownSymbol epName
     , DocItem (DEntrypoint kind)
     , NiceParameter param
     , TypeHasDoc param
     )
  => param : s :-> out -> param : s :-> out
documentEntrypoint :: ((param : s) :-> out) -> (param : s) :-> out
documentEntrypoint (param : s) :-> out
instr =
  let entrypointName :: Text
entrypointName = String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy epName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy epName
forall k (t :: k). Proxy t
Proxy @epName) in
    (SubDoc -> DEntrypoint kind)
-> ((param : s) :-> out) -> (param : s) :-> out
forall di (inp :: [*]) (out :: [*]).
DocItem di =>
(SubDoc -> di) -> (inp :-> out) -> inp :-> out
docGroup (Text -> SubDoc -> DEntrypoint kind
forall kind. Text -> SubDoc -> DEntrypoint kind
DEntrypoint @kind Text
entrypointName) (((param : s) :-> out) -> (param : s) :-> out)
-> ((param : s) :-> out) -> (param : s) :-> out
forall a b. (a -> b) -> a -> b
$
    DEntrypointArg -> (param : s) :-> (param : s)
forall di (s :: [*]). DocItem di => di -> s :-> s
doc ((NiceParameter param, TypeHasDoc param) => DEntrypointArg
forall arg. (NiceParameter arg, TypeHasDoc arg) => DEntrypointArg
constructDEpArg @param) ((param : s) :-> (param : s))
-> ((param : s) :-> out) -> (param : s) :-> out
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (param : s) :-> out
instr

-- | Provides arror for convenient entrypoint documentation
class EntryArrow kind name body where
  -- | Lift entrypoint implementation.
  --
  -- Entrypoint names should go with "e" prefix.
  (#->) :: (Label name, Proxy kind) -> body -> body

instance ( name ~ ("e" `AppendSymbol` epName)
         , body ~ (param : s :-> out)
         , KnownSymbol epName
         , DocItem (DEntrypoint kind)
         , NiceParameter param
         , TypeHasDoc param
         , KnownValue param
         ) => EntryArrow kind name body where
  #-> :: (Label name, Proxy kind) -> body -> body
(#->) (Label name, Proxy kind)
_ = forall param (s :: [*]) (out :: [*]).
(KnownSymbol epName, DocItem (DEntrypoint kind),
 NiceParameter param, TypeHasDoc param) =>
((param : s) :-> out) -> (param : s) :-> out
forall kind (epName :: Symbol) param (s :: [*]) (out :: [*]).
(KnownSymbol epName, DocItem (DEntrypoint kind),
 NiceParameter param, TypeHasDoc param) =>
((param : s) :-> out) -> (param : s) :-> out
documentEntrypoint @kind @epName

-- | Modify param building steps with respect to entrypoints that given
-- parameter declares.
--
-- Each contract with entrypoints should eventually call this function,
-- otherwise, in case if contract uses built-in entrypoints feature,
-- the resulting parameter building steps in the generated documentation
-- will not consider entrypoints and thus may be incorrect.
--
-- Calling this twice over the same code is also prohibited.
--
-- This method is for internal use, if you want to apply it to a contract
-- manually, use 'finalizeParamCallingDoc'.
finalizeParamCallingDoc'
  :: forall cp inp out.
     (NiceParameterFull cp, HasCallStack)
  => Proxy cp -> (inp :-> out) -> (inp :-> out)
finalizeParamCallingDoc' :: Proxy cp -> (inp :-> out) -> inp :-> out
finalizeParamCallingDoc' Proxy cp
_ = ([ParamBuildingStep] -> [ParamBuildingStep])
-> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
([ParamBuildingStep] -> [ParamBuildingStep])
-> (inp :-> out) -> inp :-> out
modifyParamBuildingSteps [ParamBuildingStep] -> [ParamBuildingStep]
modifySteps
  where
    epDescs :: [Some1 EpCallingDesc]
    epDescs :: [Some1 EpCallingDesc]
epDescs =
      -- Reversing the list because if element @e1@ of this list is prefix of
      -- another element @e2@, we want @e2@ to appear eariler than @e1@ to
      -- match against it first. But without reverse exactly the opposite
      -- holds due to [order of entrypoints children] property.
      [Some1 EpCallingDesc] -> [Some1 EpCallingDesc]
forall a. [a] -> [a]
reverse ([Some1 EpCallingDesc] -> [Some1 EpCallingDesc])
-> [Some1 EpCallingDesc] -> [Some1 EpCallingDesc]
forall a b. (a -> b) -> a -> b
$ ParameterDeclaresEntrypoints cp => [Some1 EpCallingDesc]
forall cp. ParameterDeclaresEntrypoints cp => [Some1 EpCallingDesc]
pepDescsWithDef @cp

    modifySteps :: [ParamBuildingStep] -> [ParamBuildingStep]
    modifySteps :: [ParamBuildingStep] -> [ParamBuildingStep]
modifySteps [ParamBuildingStep]
pbs
      | [ParamBuildingStep] -> Bool
areFinalizedParamBuildingSteps [ParamBuildingStep]
pbs =
          Text -> [ParamBuildingStep]
forall a. HasCallStack => Text -> a
error Text
"Applying finalization second time"
      | Bool
otherwise =
          [ParamBuildingStep]
-> Maybe [ParamBuildingStep] -> [ParamBuildingStep]
forall a. a -> Maybe a -> a
fromMaybe [[ParamBuildingStep] -> ParamBuildingStep
PbsUncallable [ParamBuildingStep]
pbs] (Maybe [ParamBuildingStep] -> [ParamBuildingStep])
-> ([Maybe [ParamBuildingStep]] -> Maybe [ParamBuildingStep])
-> [Maybe [ParamBuildingStep]]
-> [ParamBuildingStep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[ParamBuildingStep]] -> Maybe [ParamBuildingStep]
forall a. [a] -> Maybe a
listToMaybe ([[ParamBuildingStep]] -> Maybe [ParamBuildingStep])
-> ([Maybe [ParamBuildingStep]] -> [[ParamBuildingStep]])
-> [Maybe [ParamBuildingStep]]
-> Maybe [ParamBuildingStep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [ParamBuildingStep]] -> [[ParamBuildingStep]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [ParamBuildingStep]] -> [ParamBuildingStep])
-> [Maybe [ParamBuildingStep]] -> [ParamBuildingStep]
forall a b. (a -> b) -> a -> b
$
          [Some1 EpCallingDesc]
epDescs [Some1 EpCallingDesc]
-> (Some1 EpCallingDesc -> Maybe [ParamBuildingStep])
-> [Maybe [ParamBuildingStep]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Some1 EpCallingDesc
epDesc -> Some1 EpCallingDesc
-> [ParamBuildingStep] -> Maybe [ParamBuildingStep]
tryShortcut Some1 EpCallingDesc
epDesc [ParamBuildingStep]
pbs

    -- Further we check whether given 'EpCallingStep's form prefix of
    -- 'ParamBuildingStep's; if so, we can apply only part of building
    -- steps and then call the entrypoint directly

    match :: [EpCallingStep] -> [ParamBuildingStep] -> Bool
    match :: [EpCallingStep] -> [ParamBuildingStep] -> Bool
match [EpCallingStep]
cSteps [ParamBuildingStep]
pbSteps =
      [Bool] -> Bool
forall t. (Container t, Element t ~ Bool) => t -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ [EpCallingStep]
-> [Maybe ParamBuildingStep]
-> [(EpCallingStep, Maybe ParamBuildingStep)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EpCallingStep]
cSteps ([ParamBuildingStep] -> [Maybe ParamBuildingStep]
forall a. [a] -> [Maybe a]
prolong [ParamBuildingStep]
pbSteps) [(EpCallingStep, Maybe ParamBuildingStep)]
-> ((EpCallingStep, Maybe ParamBuildingStep) -> Bool) -> [Bool]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        (EpsWrapIn Text
ctor, Just (PbsWrapIn Text
ctor2 ParamBuildingDesc
_)) | Text
ctor Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
ctor2 -> Bool
True
        (EpCallingStep, Maybe ParamBuildingStep)
_ -> Bool
False
      where
        prolong :: [a] -> [Maybe a]
        prolong :: [a] -> [Maybe a]
prolong [a]
l = (a -> Maybe a) -> [a] -> [Maybe a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map a -> Maybe a
forall a. a -> Maybe a
Just [a]
l [Maybe a] -> [Maybe a] -> [Maybe a]
forall a. [a] -> [a] -> [a]
++ Maybe a -> [Maybe a]
forall a. a -> [a]
repeat Maybe a
forall a. Maybe a
Nothing

    tryShortcut
      :: Some1 EpCallingDesc
      -> [ParamBuildingStep]
      -> Maybe [ParamBuildingStep]
    tryShortcut :: Some1 EpCallingDesc
-> [ParamBuildingStep] -> Maybe [ParamBuildingStep]
tryShortcut (Some1 EpCallingDesc{ epcdSteps :: forall (name :: Symbol) arg.
EpCallingDesc '(name, arg) -> [EpCallingStep]
epcdSteps = [EpCallingStep]
cSteps, epcdEntrypoint :: forall (name :: Symbol) arg. EpCallingDesc '(name, arg) -> EpName
epcdEntrypoint = EpName
ep })
                [ParamBuildingStep]
pbSteps
      | [EpCallingStep] -> [ParamBuildingStep] -> Bool
match [EpCallingStep]
cSteps [ParamBuildingStep]
pbSteps =
          let truncated :: [ParamBuildingStep]
truncated = Int -> [ParamBuildingStep] -> [ParamBuildingStep]
forall a. Int -> [a] -> [a]
drop ([EpCallingStep] -> Int
forall t. Container t => t -> Int
length [EpCallingStep]
cSteps) [ParamBuildingStep]
pbSteps
              callEpStep :: ParamBuildingStep
callEpStep = EpName -> ParamBuildingStep
PbsCallEntrypoint EpName
ep
          in [ParamBuildingStep] -> Maybe [ParamBuildingStep]
forall a. a -> Maybe a
Just ([ParamBuildingStep] -> Maybe [ParamBuildingStep])
-> [ParamBuildingStep] -> Maybe [ParamBuildingStep]
forall a b. (a -> b) -> a -> b
$ ParamBuildingStep
callEpStep ParamBuildingStep -> [ParamBuildingStep] -> [ParamBuildingStep]
forall a. a -> [a] -> [a]
: [ParamBuildingStep]
truncated
      | Bool
otherwise = Maybe [ParamBuildingStep]
forall a. Maybe a
Nothing

-- | Version of 'finalizeParamCallingDoc\'' more convenient for manual call in
-- a contract.
finalizeParamCallingDoc
  :: forall cp inp out.
     (NiceParameterFull cp, RequireSumType cp, HasCallStack)
  => (cp : inp :-> out) -> (cp : inp :-> out)
finalizeParamCallingDoc :: ((cp : inp) :-> out) -> (cp : inp) :-> out
finalizeParamCallingDoc = Proxy cp -> ((cp : inp) :-> out) -> (cp : inp) :-> out
forall cp (inp :: [*]) (out :: [*]).
(NiceParameterFull cp, HasCallStack) =>
Proxy cp -> (inp :-> out) -> inp :-> out
finalizeParamCallingDoc' (Proxy cp
forall k (t :: k). Proxy t
Proxy @cp)
  where
    -- We do not actually need it, requiring this constraint only to avoid
    -- misapplication of our function.
    _needSumType :: Dict (RequireSumType cp)
    _needSumType :: Dict (RequireSumType cp)
_needSumType = Dict (RequireSumType cp)
forall (a :: Constraint). a => Dict a
Dict

-- | Whether 'finalizeParamCallingDoc' has already been applied to these steps.
areFinalizedParamBuildingSteps :: [ParamBuildingStep] -> Bool
areFinalizedParamBuildingSteps :: [ParamBuildingStep] -> Bool
areFinalizedParamBuildingSteps =
  -- Currently, 'finalizeParamCallingDoc' puts either 'PbsCallEntrypoint' or
  -- 'PbsUncallable' to list, and only it, and we rely on this behaviour here.
  -- If something changes so that these heuristics do not work, we can always
  -- insert special markers which would tell us whether finalization has been
  -- applied.
  let
    hasFinalizationTraces :: ParamBuildingStep -> Bool
hasFinalizationTraces = \case
      PbsWrapIn{} -> Bool
False
      PbsCallEntrypoint{} -> Bool
True
      PbsCustom{} -> Bool
False
      PbsUncallable{} -> Bool
True
  in (Element [ParamBuildingStep] -> Bool)
-> [ParamBuildingStep] -> Bool
forall t. Container t => (Element t -> Bool) -> t -> Bool
any Element [ParamBuildingStep] -> Bool
ParamBuildingStep -> Bool
hasFinalizationTraces

entryCaseSimple_
  :: forall cp out inp.
     ( InstrCaseC cp
     , RMap (CaseClauses cp)
     , DocumentEntrypoints PlainEntrypointsKind cp
     , RequireFlatParamEps cp
     )
  => Rec (CaseClauseL inp out) (CaseClauses cp)
  -> cp : inp :-> out
entryCaseSimple_ :: Rec (CaseClauseL inp out) (CaseClauses cp) -> (cp : inp) :-> out
entryCaseSimple_ =
  Proxy PlainEntrypointsKind
-> Rec (CaseClauseL inp out) (CaseClauses cp) -> (cp : inp) :-> out
forall dt entrypointKind (out :: [*]) (inp :: [*]).
(InstrCaseC dt, RMap (CaseClauses dt),
 DocumentEntrypoints entrypointKind dt) =>
Proxy entrypointKind
-> Rec (CaseClauseL inp out) (CaseClauses dt) -> (dt : inp) :-> out
entryCase_ (Proxy PlainEntrypointsKind
forall k (t :: k). Proxy t
Proxy @PlainEntrypointsKind)
  where
    _reqFlat :: Dict (RequireFlatEpDerivation cp (GetParameterEpDerivation cp))
_reqFlat = RequireFlatEpDerivation cp (GetParameterEpDerivation cp) =>
Dict (RequireFlatEpDerivation cp (GetParameterEpDerivation cp))
forall (a :: Constraint). a => Dict a
Dict @(RequireFlatEpDerivation cp (GetParameterEpDerivation cp))

-- | Version of 'entryCase' for contracts with flat parameter, use it when you
-- need only one 'entryCase' all over the contract implementation.
entryCaseSimple
  :: forall cp out inp clauses.
     ( CaseTC cp out inp clauses
     , DocumentEntrypoints PlainEntrypointsKind cp
     , RequireFlatParamEps cp
     )
  => IsoRecTuple clauses -> cp : inp :-> out
entryCaseSimple :: IsoRecTuple clauses -> (cp : inp) :-> out
entryCaseSimple = Rec (CaseClauseL inp out) (GCaseClauses (Rep cp))
-> (cp : inp) :-> out
forall cp (out :: [*]) (inp :: [*]).
(InstrCaseC cp, RMap (CaseClauses cp),
 DocumentEntrypoints PlainEntrypointsKind cp,
 RequireFlatParamEps cp) =>
Rec (CaseClauseL inp out) (CaseClauses cp) -> (cp : inp) :-> out
entryCaseSimple_ (Rec (CaseClauseL inp out) (GCaseClauses (Rep cp))
 -> (cp : inp) :-> out)
-> (IsoRecTuple (Rec (CaseClauseL inp out) (GCaseClauses (Rep cp)))
    -> Rec (CaseClauseL inp out) (GCaseClauses (Rep cp)))
-> IsoRecTuple (Rec (CaseClauseL inp out) (GCaseClauses (Rep cp)))
-> (cp : inp) :-> out
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsoRecTuple (Rec (CaseClauseL inp out) (GCaseClauses (Rep cp)))
-> Rec (CaseClauseL inp out) (GCaseClauses (Rep cp))
forall r. RecFromTuple r => IsoRecTuple r -> r
recFromTuple

type family RequireFlatParamEps cp :: Constraint where
  RequireFlatParamEps cp =
    ( NiceParameterFull cp
    , RequireFlatEpDerivation cp (GetParameterEpDerivation cp)
    , RequireSumType cp
    )

-- Checking this is not strictly necessary, but let's try it
type family RequireFlatEpDerivation cp deriv :: Constraint where
  RequireFlatEpDerivation _ EpdNone = ()
  RequireFlatEpDerivation _ EpdPlain = ()
  RequireFlatEpDerivation cp deriv = TypeError
    ( 'Text "Parameter is not flat" ':$$:
      'Text "For parameter `" ':<>: 'ShowType cp ':<>: 'Text "`" ':$$:
      'Text "With entrypoints derivation way `" ':<>: 'ShowType deriv ':<>: 'Text "`"
    )

---------------------------
-- Helper
---------------------------

-- | Surrouned a markdown text in a span tag with given id.
mdAddId :: Markdown -> Markdown -> Markdown
mdAddId :: Markdown -> Markdown -> Markdown
mdAddId Markdown
idTxt Markdown
txt = Markdown
"<span id=\"" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
idTxt Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
"\">" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
txt Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
"</span>"