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

{-# OPTIONS_GHC -Wno-orphans #-}

module Lorentz.Doc
  ( doc
  , docGroup
  , docStorage
  , buildLorentzDoc
  , buildLorentzDocWithGitRev
  , renderLorentzDoc
  , renderLorentzDocWithGitRev
  , contractName
  , contractGeneral
  , contractGeneralDefault
  , cutLorentzNonDoc

    -- * Re-exports
  , Markdown
  , DocElem(..)
  , DocItem (..)
  , docItemPosition
  , DocItemId (..)
  , DocItemPlacementKind (..)
  , DocItemPos(..)
  , DocItemRef (..)
  , DocSection(..)
  , DocSectionNameStyle (..)
  , SomeDocItem (..)
  , SomeDocDefinitionItem (..)
  , SubDoc (..)
  , DocGrouping
  , ContractDoc (..)
  , DDescription (..)
  , DEntrypointExample (..)
  , mkDEntrypointExample
  , DGitRevision (..)
  , GitRepoSettings (..)
  , mkDGitRevision
  , morleyRepoSettings
  , DComment (..)
  , DAnchor (..)
  , DType (..)
  , dTypeDep
  , docDefinitionRef
  , contractDocToMarkdown
  , subDocToMarkdown

  , TypeHasDoc (..)
  , SomeTypeWithDoc (..)

  , HaveCommonTypeCtor
  , IsHomomorphic
  , genericTypeDocDependencies
  , customTypeDocMdReference
  , homomorphicTypeDocMdReference
  , poly1TypeDocMdReference
  , poly2TypeDocMdReference
  , homomorphicTypeDocHaskellRep
  , concreteTypeDocHaskellRep
  , concreteTypeDocHaskellRepUnsafe
  , haskellAddNewtypeField
  , haskellRepNoFields
  , haskellRepStripFieldPrefix
  , homomorphicTypeDocMichelsonRep
  , concreteTypeDocMichelsonRep
  , concreteTypeDocMichelsonRepUnsafe
  , mdTocFromRef
  ) where

import Data.Singletons (demote)
import Fmt (build)

import Lorentz.Base
import Lorentz.Constraints
import Lorentz.Value
import Lorentz.Zip ()
import Michelson.Doc
import Michelson.Optimizer
import Michelson.Printer
import Michelson.Typed
import Util.Markdown
import Util.Type

-- | Put a document item.
doc :: DocItem di => di -> s :-> s
doc :: di -> s :-> s
doc = Instr (ToTs s) (ToTs s) -> s :-> s
forall (inp :: [*]) (out :: [*]).
Instr (ToTs inp) (ToTs out) -> inp :-> out
I (Instr (ToTs s) (ToTs s) -> s :-> s)
-> (di -> Instr (ToTs s) (ToTs s)) -> di -> s :-> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. di -> Instr (ToTs s) (ToTs s)
forall di (s :: [T]). DocItem di => di -> Instr s s
docInstr

-- | Group documentation built in the given piece of code
-- into block dedicated to one thing, e.g. to one entrypoint.
docGroup :: DocGrouping -> (inp :-> out) -> (inp :-> out)
docGroup :: DocGrouping -> (inp :-> out) -> inp :-> out
docGroup gr :: DocGrouping
gr = (forall (o' :: [T]). Instr (ToTs inp) o' -> Instr (ToTs inp) o')
-> (inp :-> out) -> inp :-> out
forall (i1 :: [*]) (i2 :: [*]) (o :: [*]).
(forall (o' :: [T]). Instr (ToTs i1) o' -> Instr (ToTs i2) o')
-> (i1 :-> o) -> i2 :-> o
iMapAnyCode (DocGrouping -> Instr (ToTs inp) o' -> Instr (ToTs inp) o'
forall (inp :: [T]) (out :: [T]).
DocGrouping -> Instr inp out -> Instr inp out
DocGroup DocGrouping
gr)

-- | Insert documentation of the contract storage type. The type
-- should be passed using type applications.
docStorage :: forall storage s. TypeHasDoc storage => s :-> s
docStorage :: s :-> s
docStorage = DStorageType -> s :-> s
forall di (s :: [*]). DocItem di => di -> s :-> s
doc (DStorageType -> s :-> s) -> DStorageType -> s :-> s
forall a b. (a -> b) -> a -> b
$ DType -> DStorageType
DStorageType (DType -> DStorageType) -> DType -> DStorageType
forall a b. (a -> b) -> a -> b
$ Proxy storage -> DType
forall a. TypeHasDoc a => Proxy a -> DType
DType (Proxy storage -> DType) -> Proxy storage -> DType
forall a b. (a -> b) -> a -> b
$ Proxy storage
forall k (t :: k). Proxy t
Proxy @storage

-- | Give a name to given contract. Apply it to the whole contract code.
contractName :: Text -> (inp :-> out) -> (inp :-> out)
contractName :: Text -> (inp :-> out) -> inp :-> out
contractName name :: Text
name = DocGrouping -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
DocGrouping -> (inp :-> out) -> inp :-> out
docGroup (DName -> SomeDocItem
forall d. DocItem d => d -> SomeDocItem
SomeDocItem (DName -> SomeDocItem) -> (SubDoc -> DName) -> DocGrouping
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SubDoc -> DName
DName Text
name)

buildLorentzDoc :: inp :-> out -> ContractDoc
buildLorentzDoc :: (inp :-> out) -> ContractDoc
buildLorentzDoc ((inp :-> out) -> Instr (ToTs inp) (ToTs out)
forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> Instr (ToTs inp) (ToTs out)
iAnyCode -> Instr (ToTs inp) (ToTs out)
code) = Instr (ToTs inp) (ToTs out) -> ContractDoc
forall (inp :: [T]) (out :: [T]). Instr inp out -> ContractDoc
buildInstrDoc Instr (ToTs inp) (ToTs out)
code

-- | Takes an instruction that inserts documentation items with
-- general information about the contract. Inserts it into general
-- section. See 'DGeneralInfoSection'.
contractGeneral :: (inp :-> out) -> (inp :-> out)
contractGeneral :: (inp :-> out) -> inp :-> out
contractGeneral = DocGrouping -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
DocGrouping -> (inp :-> out) -> inp :-> out
docGroup (DGeneralInfoSection -> SomeDocItem
forall d. DocItem d => d -> SomeDocItem
SomeDocItem (DGeneralInfoSection -> SomeDocItem)
-> (SubDoc -> DGeneralInfoSection) -> DocGrouping
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubDoc -> DGeneralInfoSection
DGeneralInfoSection)

-- | Inserts general information about the contract using the default format.
--
-- Currently we only include git revision. It is unknown in the
-- library code and is supposed to be updated in an executable.
contractGeneralDefault :: s :-> s
contractGeneralDefault :: s :-> s
contractGeneralDefault =
  ((s :-> s) -> s :-> s
forall (inp :: [*]) (out :: [*]). (inp :-> out) -> inp :-> out
contractGeneral ((s :-> s) -> s :-> s) -> (s :-> s) -> s :-> s
forall a b. (a -> b) -> a -> b
$ DGitRevision -> s :-> s
forall di (s :: [*]). DocItem di => di -> s :-> s
doc DGitRevision
DGitRevisionUnknown) (s :-> s) -> (s :-> s) -> s :-> s
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  DToc -> s :-> s
forall di (s :: [*]). DocItem di => di -> s :-> s
doc (Markdown -> DToc
DToc "") (s :-> s) -> (s :-> s) -> s :-> s
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  DConversionInfo -> s :-> s
forall di (s :: [*]). DocItem di => di -> s :-> s
doc DConversionInfo
DConversionInfo

buildLorentzDocWithGitRev :: DGitRevision -> inp :-> out -> ContractDoc
buildLorentzDocWithGitRev :: DGitRevision -> (inp :-> out) -> ContractDoc
buildLorentzDocWithGitRev gitRev :: DGitRevision
gitRev ((inp :-> out) -> Instr (ToTs inp) (ToTs out)
forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> Instr (ToTs inp) (ToTs out)
iAnyCode -> Instr (ToTs inp) (ToTs out)
code) =
  DGitRevision -> Instr (ToTs inp) (ToTs out) -> ContractDoc
forall (inp :: [T]) (out :: [T]).
DGitRevision -> Instr inp out -> ContractDoc
buildInstrDocWithGitRev DGitRevision
gitRev Instr (ToTs inp) (ToTs out)
code

renderLorentzDoc :: inp :-> out -> LText
renderLorentzDoc :: (inp :-> out) -> LText
renderLorentzDoc = ContractDoc -> LText
contractDocToMarkdown (ContractDoc -> LText)
-> ((inp :-> out) -> ContractDoc) -> (inp :-> out) -> LText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (inp :-> out) -> ContractDoc
forall (inp :: [*]) (out :: [*]). (inp :-> out) -> ContractDoc
buildLorentzDoc

renderLorentzDocWithGitRev :: DGitRevision -> inp :-> out -> LText
renderLorentzDocWithGitRev :: DGitRevision -> (inp :-> out) -> LText
renderLorentzDocWithGitRev gitRev :: DGitRevision
gitRev = ContractDoc -> LText
contractDocToMarkdown (ContractDoc -> LText)
-> ((inp :-> out) -> ContractDoc) -> (inp :-> out) -> LText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DGitRevision -> (inp :-> out) -> ContractDoc
forall (inp :: [*]) (out :: [*]).
DGitRevision -> (inp :-> out) -> ContractDoc
buildLorentzDocWithGitRev DGitRevision
gitRev

-- | Leave only instructions related to documentation.
--
-- This function is useful when your method executes a lambda coming from outside,
-- but you know its properties and want to propagate its documentation to your
-- contract code.
cutLorentzNonDoc :: (inp :-> out) -> (s :-> s)
cutLorentzNonDoc :: (inp :-> out) -> s :-> s
cutLorentzNonDoc ((inp :-> out) -> Instr (ToTs inp) (ToTs out)
forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> Instr (ToTs inp) (ToTs out)
iAnyCode -> Instr (ToTs inp) (ToTs out)
code) = Instr (ToTs s) (ToTs s) -> s :-> s
forall (inp :: [*]) (out :: [*]).
Instr (ToTs inp) (ToTs out) -> inp :-> out
I (Instr (ToTs s) (ToTs s) -> s :-> s)
-> Instr (ToTs s) (ToTs s) -> s :-> s
forall a b. (a -> b) -> a -> b
$ (forall (i :: [T]) (o :: [T]). Instr i o -> Instr i o)
-> Instr (ToTs inp) (ToTs out) -> Instr (ToTs s) (ToTs s)
forall (inp :: [T]) (out :: [T]) (s :: [T]).
(forall (i :: [T]) (o :: [T]). Instr i o -> Instr i o)
-> Instr inp out -> Instr s s
cutInstrNonDoc forall (i :: [T]) (o :: [T]). Instr i o -> Instr i o
optimize Instr (ToTs inp) (ToTs out)
code

instance Each [Typeable, ReifyList TypeHasDoc] [i, o] =>
         TypeHasDoc (i :-> o) where
  typeDocName :: Proxy (i :-> o) -> Text
typeDocName _ = "Code (extended lambda)"
  typeDocMdReference :: Proxy (i :-> o) -> WithinParens -> Markdown
typeDocMdReference tp :: Proxy (i :-> o)
tp wp :: WithinParens
wp =
    let DocItemRef ctorDocItemId = DType
-> DocItemRef (DocItemPlacement DType) (DocItemReferenced DType)
forall d.
DocItem d =>
d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
docItemRef (Proxy (i :-> o) -> DType
forall a. TypeHasDoc a => Proxy a -> DType
DType Proxy (i :-> o)
tp)
        refToThis :: Markdown
refToThis = Markdown -> DocItemId -> Markdown
forall anchor. ToAnchor anchor => Markdown -> anchor -> Markdown
mdLocalRef (Markdown -> Markdown
mdTicked "Code") DocItemId
ctorDocItemId
    in WithinParens -> Markdown -> Markdown
applyWithinParens WithinParens
wp (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$
      [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown) -> [Markdown] -> Markdown
forall a b. (a -> b) -> a -> b
$ Markdown -> [Markdown] -> [Markdown]
forall a. a -> [a] -> [a]
intersperse " " [Markdown
refToThis, ReifyList TypeHasDoc i => Markdown
forall (s :: [*]). ReifyList TypeHasDoc s => Markdown
refToStack @i, ReifyList TypeHasDoc o => Markdown
forall (s :: [*]). ReifyList TypeHasDoc s => Markdown
refToStack @o]
    where
    refToStack :: forall s. ReifyList TypeHasDoc s => Markdown
    refToStack :: Markdown
refToStack =
      let stack :: [Markdown]
stack = (forall a. TypeHasDoc a => Proxy a -> Markdown) -> [Markdown]
forall k (c :: k -> Constraint) (l :: [k]) r.
ReifyList c l =>
(forall (a :: k). c a => Proxy a -> r) -> [r]
reifyList @_ @TypeHasDoc @s (\p :: Proxy a
p -> Proxy a -> WithinParens -> Markdown
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Markdown
typeDocMdReference Proxy a
p (Bool -> WithinParens
WithinParens Bool
False))
      in [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat
          [ Markdown -> Markdown
mdBold "["
          , case [Markdown]
stack of
              [] -> " "
              st :: [Markdown]
st -> [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown) -> [Markdown] -> Markdown
forall a b. (a -> b) -> a -> b
$ Markdown -> [Markdown] -> [Markdown]
forall a. a -> [a] -> [a]
intersperse (Markdown -> Markdown
mdBold "," Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> " ") [Markdown]
st
          , Markdown -> Markdown
mdBold "]"
          ]

  typeDocMdDescription :: Markdown
typeDocMdDescription =
    "`Code i o` stands for a sequence of instructions which accepts stack \
    \of type `i` and returns stack of type `o`.\n\n\
    \When both `i` and `o` are of length 1, this primitive corresponds to \
    \the Michelson lambda. In more complex cases code is surrounded with `pair`\
    \and `unpair` instructions until fits into mentioned restriction.\
    \"
  typeDocDependencies :: Proxy (i :-> o) -> [SomeDocDefinitionItem]
typeDocDependencies _ = [[SomeDocDefinitionItem]] -> [SomeDocDefinitionItem]
forall a. Monoid a => [a] -> a
mconcat
    [ (forall a. TypeHasDoc a => Proxy a -> SomeDocDefinitionItem)
-> [SomeDocDefinitionItem]
forall k (c :: k -> Constraint) (l :: [k]) r.
ReifyList c l =>
(forall (a :: k). c a => Proxy a -> r) -> [r]
reifyList @_ @TypeHasDoc @i forall a. TypeHasDoc a => Proxy a -> SomeDocDefinitionItem
dTypeDepP
    , (forall a. TypeHasDoc a => Proxy a -> SomeDocDefinitionItem)
-> [SomeDocDefinitionItem]
forall k (c :: k -> Constraint) (l :: [k]) r.
ReifyList c l =>
(forall (a :: k). c a => Proxy a -> r) -> [r]
reifyList @_ @TypeHasDoc @o forall a. TypeHasDoc a => Proxy a -> SomeDocDefinitionItem
dTypeDepP
    , [ TypeHasDoc Integer => SomeDocDefinitionItem
forall t. TypeHasDoc t => SomeDocDefinitionItem
dTypeDep @Integer
      , TypeHasDoc Natural => SomeDocDefinitionItem
forall t. TypeHasDoc t => SomeDocDefinitionItem
dTypeDep @Natural
      , TypeHasDoc MText => SomeDocDefinitionItem
forall t. TypeHasDoc t => SomeDocDefinitionItem
dTypeDep @MText
      ]
    ]
  typeDocHaskellRep :: TypeDocHaskellRep (i :-> o)
typeDocHaskellRep _ _ = Maybe (Maybe DocTypeRepLHS, ADTRep SomeTypeWithDoc)
forall a. Maybe a
Nothing
  typeDocMichelsonRep :: TypeDocMichelsonRep (i :-> o)
typeDocMichelsonRep _ =
    ( DocTypeRepLHS -> Maybe DocTypeRepLHS
forall a. a -> Maybe a
Just "Code [Integer, Natural, MText, ()] [ByteString]"
    , (SingKind T,
 SingI (ToT ('[Integer, Natural, MText, ()] :-> '[ByteString]))) =>
Demote T
forall k (a :: k). (SingKind k, SingI a) => Demote k
demote @(ToT ([Integer, Natural, MText, ()] :-> '[ByteString]))
    )

-- | Modify the example value of an entrypoint
data DEntrypointExample = forall t . ParameterScope t => DEntrypointExample (Value t)

instance DocItem DEntrypointExample where
  docItemPos :: Natural
docItemPos = 10000
  docItemSectionName :: Maybe Text
docItemSectionName = Maybe Text
forall a. Maybe a
Nothing
  docItemToMarkdown :: HeaderLevel -> DEntrypointExample -> Markdown
docItemToMarkdown _ (DEntrypointExample val :: Value t
val) =
    LText -> Markdown
forall p. Buildable p => p -> Markdown
build (LText -> Markdown) -> LText -> Markdown
forall a b. (a -> b) -> a -> b
$ Bool -> Value' ExpandedOp -> LText
forall op. RenderDoc op => Bool -> Value' op -> LText
printUntypedValue Bool
True (Value' ExpandedOp -> LText) -> Value' ExpandedOp -> LText
forall a b. (a -> b) -> a -> b
$ Value t -> Value' ExpandedOp
forall (t :: T).
(SingI t, HasNoOp t) =>
Value' Instr t -> Value' ExpandedOp
untypeValue Value t
val

mkDEntrypointExample :: forall a. NiceParameter a => a -> DEntrypointExample
mkDEntrypointExample :: a -> DEntrypointExample
mkDEntrypointExample v :: a
v =
  ((KnownValue a,
  (KnownT (ToT a), FailOnOperationFound (ContainsOp (ToT a)),
   FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT a))))
 :- ParameterScope (ToT a))
-> (ParameterScope (ToT a) => DEntrypointExample)
-> DEntrypointExample
forall (c :: Constraint) e r. HasDict c e => e -> (c => r) -> r
withDict ((KnownValue a,
 (KnownT (ToT a), FailOnOperationFound (ContainsOp (ToT a)),
  FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT a))))
:- ParameterScope (ToT a)
forall a. NiceParameter a :- ParameterScope (ToT a)
niceParameterEvi @a) ((ParameterScope (ToT a) => DEntrypointExample)
 -> DEntrypointExample)
-> (ParameterScope (ToT a) => DEntrypointExample)
-> DEntrypointExample
forall a b. (a -> b) -> a -> b
$
    Value (ToT a) -> DEntrypointExample
forall (t :: T). ParameterScope t => Value t -> DEntrypointExample
DEntrypointExample (Value (ToT a) -> DEntrypointExample)
-> Value (ToT a) -> DEntrypointExample
forall a b. (a -> b) -> a -> b
$ a -> Value (ToT a)
forall a. IsoValue a => a -> Value (ToT a)
toVal a
v