module Lorentz.EntryPoints.Doc
( DEntryPoint (..)
, PlainEntryPointsKind
, diEntryPointToMarkdown
, DEntryPointArg (..)
, DeriveCtorFieldDoc (..)
, ParamBuildingStep (..)
, clarifyParamBuildingSteps
, mkDEntryPointArgSimple
, DocumentEntryPoints
, entryCase
, entryCase_
) where
import qualified Data.Kind as Kind
import Data.Vinyl.Core (RMap, Rec(..), rappend)
import Fmt (build)
import GHC.Generics ((:+:))
import qualified GHC.Generics as G
import GHC.TypeLits (KnownSymbol, symbolVal)
import Lorentz.ADT
import Lorentz.Base
import Lorentz.Doc
import Michelson.Typed.Doc
import Michelson.Typed.Haskell.Doc
import Michelson.Typed.Haskell.Instr
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 name) <>
subDocToMarkdown (nextHeaderLevel lvl) block
data PlainEntryPointsKind
instance DocItem (DEntryPoint PlainEntryPointsKind) where
type DocItemPosition (DEntryPoint PlainEntryPointsKind) = 1000
docItemSectionName = Just "Entry points"
docItemToMarkdown = diEntryPointToMarkdown
type CurrentParam = Markdown
data ParamBuildingStep = ParamBuildingStep
{ pbsEnglish :: Markdown
, pbsHaskell :: CurrentParam -> Markdown
, pbsMichelson :: CurrentParam -> Markdown
}
data DEntryPointArg = DEntryPointArg
{ epaArg :: Maybe DType
, epaBuilding :: [ParamBuildingStep]
}
mkDEntryPointArgSimple :: forall t. TypeHasDoc t => DEntryPointArg
mkDEntryPointArgSimple = DEntryPointArg
{ epaArg = Just $ DType (Proxy @t)
, epaBuilding = []
}
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 psteps) =
mconcat . Prelude.map (<> "\n\n") $
[ mdSubsection "Parameter" $
case mdty of
Nothing -> "none (pass unit)"
Just (DType dty) -> typeDocMdReference dty (WithinParens False)
, mdSpoiler "How to call this entry point" . mconcat $
[ "\n0. Construct parameter for the entry point.\n"
, 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"
]
]
class DeriveCtorFieldDoc (cf :: CtorField) where
deriveCtorFieldDoc :: Maybe DType
instance DeriveCtorFieldDoc 'NoFields where
deriveCtorFieldDoc = Nothing
instance TypeHasDoc ty => DeriveCtorFieldDoc ('OneField ty) where
deriveCtorFieldDoc = Just $ DType (Proxy @ty)
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 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 (DEntryPointArg (deriveCtorFieldDoc @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