module Lorentz.EntryPoints.Doc
( DEntryPoint (..)
, EntryArrow (..)
, PlainEntryPointsKind
, diEntryPointToMarkdown
, DEntryPointArg (..)
, DType (..)
, DeriveCtorFieldDoc (..)
, ParamBuildingStep (..)
, clarifyParamBuildingSteps
, constructDEpArg
, emptyDEpArg
, mkUType
, mkDEpUType
, mkDEntryPointArgSimple
, DocumentEntryPoints
, documentEntryPoint
, entryCase
, entryCase_
) where
import Control.Lens.Cons (_head)
import Data.Char (toLower)
import qualified Data.Kind as Kind
import Data.Singletons (sing)
import Data.Vinyl.Core (RMap, Rec(..), rappend)
import Data.Vinyl.Derived (Label)
import Fmt (build)
import GHC.Generics ((:+:))
import qualified GHC.Generics as G
import GHC.TypeLits (AppendSymbol, KnownSymbol, symbolVal)
import Lorentz.ADT
import Lorentz.Base
import Lorentz.Constraints.Scopes
import Lorentz.Doc
import Lorentz.TypeAnns
import Michelson.Printer.Util (RenderDoc(..), needsParens, printDocB)
import Michelson.Typed (mkUType)
import Michelson.Typed.Doc
import Michelson.Typed.Haskell.Doc
import Michelson.Typed.Haskell.Instr
import qualified Michelson.Untyped as Untyped
import Util.Markdown
import Util.Type
import Util.TypeTuple
data DEntryPoint (kind :: Kind.Type) = DEntryPoint
{ depName :: Text
, depSub :: SubDoc
}
diEntryPointToMarkdown :: HeaderLevel -> DEntryPoint level -> Markdown
diEntryPointToMarkdown lvl (DEntryPoint name block) =
mdSeparator <>
mdHeader lvl (mdTicked . build . over _head toLower $ name) <>
subDocToMarkdown (nextHeaderLevel lvl) block
data PlainEntryPointsKind
instance DocItem (DEntryPoint PlainEntryPointsKind) where
type DocItemPosition (DEntryPoint PlainEntryPointsKind) = 1000
docItemSectionName = Just "Entrypoints"
docItemToMarkdown = diEntryPointToMarkdown
type CurrentParam = Markdown
data ParamBuildingStep = ParamBuildingStep
{ pbsEnglish :: Markdown
, pbsHaskell :: CurrentParam -> Markdown
, pbsMichelson :: CurrentParam -> Markdown
}
data DEntryPointArg =
DEntryPointArg
{ epaArg :: Maybe DType
, epaHasAnnotation :: Bool
, epaBuilding :: [ParamBuildingStep]
, epaType :: Untyped.Type
}
constructDEpArg
:: forall arg.
( TypeHasDoc arg
, HasTypeAnn arg
, KnownValue arg
)
=> Bool -> DEntryPointArg
constructDEpArg epaHasAnnotation = DEntryPointArg
{ epaArg = Just $ DType (Proxy @arg)
, epaHasAnnotation = epaHasAnnotation
, epaBuilding = []
, epaType = mkDEpUType @arg
}
emptyDEpArg :: Bool -> DEntryPointArg
emptyDEpArg epaHasAnnotation = DEntryPointArg
{ epaArg = Nothing
, epaHasAnnotation = epaHasAnnotation
, epaBuilding = []
, epaType = Untyped.Type Untyped.TUnit Untyped.noAnn
}
mkDEpUType :: forall t. (KnownValue t, HasTypeAnn t) => Untyped.Type
mkDEpUType = mkUType sing (getTypeAnn @t)
mkDEntryPointArgSimple
:: forall t.
( KnownValue t
, HasTypeAnn t
, TypeHasDoc t
)
=> DEntryPointArg
mkDEntryPointArgSimple = DEntryPointArg
{ epaArg = Just $ DType (Proxy @t)
, epaHasAnnotation = False
, epaBuilding = []
, epaType = mkDEpUType @t
}
clarifyParamBuildingSteps :: ParamBuildingStep -> (inp :-> out) -> (inp :-> out)
clarifyParamBuildingSteps pbs =
iMapAnyCode $
modifyInstrDoc (\di -> di{ epaBuilding = epaBuilding di ++ [pbs] })
instance DocItem DEntryPointArg where
type DocItemPosition DEntryPointArg = 20
docItemSectionName = Nothing
docItemDependencies (DEntryPointArg mdty _ _ _) =
[SomeDocDefinitionItem dty | Just dty <- pure mdty]
docItemToMarkdown _ (DEntryPointArg mdty hasAnnotation psteps et) =
mconcat . Prelude.map (<> "\n\n") $
[ mdSubsection "Argument" $
case mdty of
Nothing -> "none (pass unit)"
Just (DType (dty :: Proxy ep)) -> mconcat . Prelude.intersperse "\n" $
[ mempty
, " + " <>
mdSubsection "In Haskell"
(typeDocMdReference dty (WithinParens False))
, " + " <>
mdSubsection "In Michelson"
(mdTicked $ printDocB False . renderDoc needsParens $ et)
],
mdSpoiler "How to call this entrypoint" $
"\n0. Construct an argument for the entrypoint.\n" <>
mconcat howToCall
]
where
howToCall
| hasAnnotation = howToCallAnnotatedEntrypoint
| otherwise = howToCallVirtualEntrypoint
howToCallVirtualEntrypoint =
[ mconcat . Prelude.intersperse "\n" $
psteps <&> \ParamBuildingStep{..} ->
mconcat . Prelude.intersperse "\n" $
[
"1. " <> pbsEnglish
, " + " <>
mdSubsection "In Haskell" (mdTicked $ pbsHaskell "·")
, " + " <>
mdSubsection "In Michelson" (mdTicked $ pbsMichelson "·")
]
, "\n\nPass resulting value as parameter to the contract.\n"
]
howToCallAnnotatedEntrypoint =
[ "1. Make a transfer to the contract passing this entrypoint's name " <>
"and the constructed value as an argument."
]
class (KnownSymbol con) => DeriveCtorFieldDoc con (cf :: CtorField) where
deriveCtorFieldDoc :: DEntryPointArg
instance
(KnownSymbol con)
=>
DeriveCtorFieldDoc con 'NoFields
where
deriveCtorFieldDoc = emptyDEpArg True
instance
(TypeHasDoc ty, HasTypeAnn ty, KnownValue ty, KnownSymbol con)
=>
DeriveCtorFieldDoc con ('OneField ty)
where
deriveCtorFieldDoc = constructDEpArg @ty True
documentEntryPoints
:: forall a kind inp out.
DocumentEntryPoints kind a
=> Rec (CaseClauseL inp out) (CaseClauses a)
-> Rec (CaseClauseL inp out) (CaseClauses a)
documentEntryPoints = gDocumentEntryPoints @kind @(G.Rep a) id
type DocumentEntryPoints kind a =
(Generic a, GDocumentEntryPoints kind (G.Rep a))
class GDocumentEntryPoints (kind :: Kind.Type) (x :: Kind.Type -> Kind.Type) where
gDocumentEntryPoints
:: (Markdown -> Markdown)
-> Rec (CaseClauseL inp out) (GCaseClauses x)
-> Rec (CaseClauseL inp out) (GCaseClauses x)
instance GDocumentEntryPoints kind x => GDocumentEntryPoints kind (G.D1 i x) where
gDocumentEntryPoints = gDocumentEntryPoints @kind @x
instance ( GDocumentEntryPoints kind x, GDocumentEntryPoints kind y
, RSplit (GCaseClauses x) (GCaseClauses y)
) =>
GDocumentEntryPoints kind (x :+: y) where
gDocumentEntryPoints michDesc clauses =
let (lclauses, rclauses) = rsplit @CaseClauseParam @(GCaseClauses x) clauses
in gDocumentEntryPoints @kind @x
(\a -> michDesc $ "Left (" <> a <> ")")
lclauses
`rappend`
gDocumentEntryPoints @kind @y
(\a -> michDesc $ "Right (" <> a <> ")")
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 michDesc (CaseClauseL clause :& RNil) =
let entryPointName = toText $ symbolVal (Proxy @ctor)
psteps = ParamBuildingStep
{ pbsEnglish = "Wrap into " <> mdTicked (build entryPointName) <> " constructor."
, pbsHaskell = \p -> build entryPointName <> " (" <> p <> ")"
, pbsMichelson = michDesc
}
addDoc instr =
clarifyParamBuildingSteps psteps $
docGroup (SomeDocItem . DEntryPoint @kind entryPointName) $
doc (deriveCtorFieldDoc @ctor @cf) # instr
in CaseClauseL (addDoc clause) :& RNil
entryCase_
:: forall dt entryPointKind out inp.
( InstrCaseC dt inp out
, RMap (CaseClauses dt)
, DocumentEntryPoints entryPointKind dt
)
=> Proxy entryPointKind
-> Rec (CaseClauseL inp out) (CaseClauses dt)
-> dt & inp :-> out
entryCase_ _ = case_ . documentEntryPoints @dt @entryPointKind
entryCase
:: forall dt entryPointKind out inp clauses.
( CaseTC dt out inp clauses
, DocumentEntryPoints entryPointKind dt
)
=> Proxy entryPointKind -> IsoRecTuple clauses -> dt & inp :-> out
entryCase p = entryCase_ p . recFromTuple
documentEntryPoint
:: forall kind epName param s out.
( KnownSymbol epName
, DocItem (DEntryPoint kind)
, TypeHasDoc param
, HasTypeAnn param
, KnownValue param
)
=> param & s :-> out -> param & s :-> out
documentEntryPoint instr =
let entryPointName = toText $ symbolVal (Proxy @epName) in
docGroup (SomeDocItem . DEntryPoint @kind entryPointName) $
doc (constructDEpArg @param True) # instr
class EntryArrow kind name body where
(#->) :: (Label name, Proxy kind) -> body -> body
instance ( name ~ ("e" `AppendSymbol` epName)
, body ~ (param & s :-> out)
, KnownSymbol epName
, DocItem (DEntryPoint kind)
, TypeHasDoc param
, HasTypeAnn param
, KnownValue param
) => EntryArrow kind name body where
(#->) _ = documentEntryPoint @kind @epName