-- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} module Lorentz.Doc ( doc , docGroup , dStorage , contractGeneralDefault , cutLorentzNonDoc -- * Views , DView (..) , DViewArg (..) , DViewRet (..) , DViewDesc (..) , ViewsDescriptorHasDoc (..) -- * Re-exports , Markdown , DocElem(..) , DocItem (..) , docItemPosition , DocItemId (..) , DocItemPlacementKind (..) , DocItemPos(..) , DocItemRef (..) , DocSection(..) , DocSectionNameStyle (..) , SomeDocItem (..) , SomeDocDefinitionItem (..) , SubDoc (..) , DocGrouping , ContractDoc (..) , DGeneralInfoSection (..) , DName (..) , DDescription (..) , DEntrypointExample (..) , mkDEntrypointExample , DGitRevision (..) , GitRepoSettings (..) , mkDGitRevision , morleyRepoSettings , DComment (..) , DAnchor (..) , DType (..) , dTypeDep , docDefinitionRef , contractDocToMarkdown , subDocToMarkdown , docItemSectionRef , ContainsDoc (..) , ContainsUpdateableDoc (..) , WithFinalizedDoc , finalizedAsIs , buildDoc , buildMarkdownDoc , modifyDoc , attachDocCommons , TypeHasDoc (..) , SomeTypeWithDoc (..) , typeDocBuiltMichelsonRep , HaveCommonTypeCtor , IsHomomorphic , genericTypeDocDependencies , customTypeDocMdReference , homomorphicTypeDocMdReference , poly1TypeDocMdReference , poly2TypeDocMdReference , homomorphicTypeDocHaskellRep , concreteTypeDocHaskellRep , unsafeConcreteTypeDocHaskellRep , haskellAddNewtypeField , haskellRepNoFields , haskellRepStripFieldPrefix , homomorphicTypeDocMichelsonRep , concreteTypeDocMichelsonRep , unsafeConcreteTypeDocMichelsonRep , mdTocFromRef ) where import Data.Singletons (demote) import Data.Typeable (typeRep) import Fmt (Buildable(..), Builder, pretty) import Lorentz.Base import Lorentz.Constraints import Lorentz.Lambda import Lorentz.Value import Lorentz.ViewBase import Lorentz.Zip () import Morley.Michelson.Doc import Morley.Michelson.Optimizer import Morley.Michelson.Printer import Morley.Michelson.Typed hiding (Contract, ContractCode, ContractCode'(..)) import Morley.Util.Generic import Morley.Util.Markdown import Morley.Util.Type import Morley.Util.TypeLits -- | Put a document item. doc :: DocItem di => di -> s :-> s doc = I . docInstr -- | Group documentation built in the given piece of code -- into block dedicated to one thing, e.g. to one entrypoint. -- -- Examples of doc items you can pass here: 'DName', 'DGeneralInfoSection'. docGroup :: DocItem di => (SubDoc -> di) -> (inp :-> out) -> (inp :-> out) docGroup gr = iMapAnyCode (DocGroup $ SomeDocItem . gr) -- | Inserts general information about the contract using the default format. -- -- This includes git revision and some other information common -- for all contracts. -- Git revision is left unknown in the library code and is supposed -- to be updated in an executable using e.g. 'attachDocCommons'. contractGeneralDefault :: s :-> s contractGeneralDefault = (docGroup DGeneralInfoSection $ doc DGitRevisionUnknown ) # doc (DToc "") # doc DConversionInfo instance ContainsDoc (i :-> o) where buildDocUnfinalized = buildDocUnfinalized . iAnyCode instance ContainsUpdateableDoc (i :-> o) where modifyDocEntirely how = iMapAnyCode $ modifyDocEntirely how instance ContainsDoc (ContractCode i o) where buildDocUnfinalized = buildDocUnfinalized . iAnyCode . unContractCode instance ContainsUpdateableDoc (ContractCode i o) where modifyDocEntirely how (ContractCode x) = ContractCode $ iMapAnyCode (modifyDocEntirely how) x instance ContainsDoc (Contract cp st vd) where buildDocUnfinalized = buildDocUnfinalized . cDocumentedCode instance ContainsUpdateableDoc (Contract cp st vd) where modifyDocEntirely how c = c{ cDocumentedCode = modifyDocEntirely how (cDocumentedCode c) } -- | 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 (iAnyCode -> code) = I $ cutInstrNonDoc optimize code instance Each [Typeable, ReifyList TypeHasDoc] [i, o] => TypeHasDoc (WrappedLambda i o) where typeDocName _ = "WrappedLambda (extended lambda)" typeDocMdReference tp wp = let DocItemRef ctorDocItemId = docItemRef (DType tp) refToThis = mdLocalRef (mdTicked "WrappedLambda") ctorDocItemId in applyWithinParens wp $ mconcat $ intersperse " " [refToThis, refToStack @i, refToStack @o] where refToStack :: forall s. ReifyList TypeHasDoc s => Markdown refToStack = let stack = reifyList @_ @TypeHasDoc @s (\p -> typeDocMdReference p (WithinParens False)) in mconcat [ mdBold "[" , case stack of [] -> " " st -> mconcat $ intersperse (mdBold "," <> " ") st , mdBold "]" ] typeDocMdDescription = "`WrappedLambda 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 _ = mconcat [ reifyList @_ @TypeHasDoc @i dTypeDepP , reifyList @_ @TypeHasDoc @o dTypeDepP , [ dTypeDep @Integer , dTypeDep @Natural , dTypeDep @MText ] ] typeDocHaskellRep _ _ = Nothing typeDocMichelsonRep _ = ( Just "Code [Integer, Natural, MText, ()] [ByteString]" , demote @(ToT ([Integer, Natural, MText, ()] :-> '[ByteString])) ) instance (TypeHasDoc p, ViewsDescriptorHasDoc vd) => TypeHasDoc (TAddress p vd) where typeDocMdDescription = [md| A typed version of address primitive. Type in `TAddress` denotes parameter type of the target contract. This is not assumed to carry an entrypoint name. |] typeDocMdReference pa = customTypeDocMdReference' ("TAddress", DType pa) [ typeDocMdReference (Proxy @p) , \_wp -> docDefinitionRef (mdTicked . pretty $ viewsDescriptorName (Proxy @vd)) (DViewDesc (Proxy @vd)) ] typeDocDependencies _ = [ dTypeDep @() , SomeDocDefinitionItem $ DViewDesc (Proxy @vd) ] typeDocHaskellRep _ _ = Nothing typeDocMichelsonRep = concreteTypeDocMichelsonRep @(TAddress () ()) instance TypeHasDoc p => TypeHasDoc (FutureContract p) where typeDocName _ = "FutureContract" typeDocMdDescription = [md| A typed version of address primitive. Type in `FutureContract` denotes argument type of the target _entrypoint_. This address can carry an entrypoint name. We use `FutureContract` as a replacement for Michelson's `contract`, since places where the latter can appear are severely restricted. |] typeDocMdReference = poly1TypeDocMdReference typeDocDependencies _ = [dTypeDep @()] typeDocHaskellRep _ _ = Nothing typeDocMichelsonRep = concreteTypeDocMichelsonRep @(FutureContract ()) -- | Modify the example value of an entrypoint data DEntrypointExample = forall t . ParameterScope t => DEntrypointExample (Value t) instance DocItem DEntrypointExample where docItemPos = 10000 docItemSectionName = Nothing docItemToMarkdown _ (DEntrypointExample val) = build $ printUntypedValue True $ untypeValue val mkDEntrypointExample :: forall a. NiceParameter a => a -> DEntrypointExample mkDEntrypointExample v = withDict (niceParameterEvi @a) $ DEntrypointExample $ toVal v ---------------------------------------------------------------------------- -- Views documentation ---------------------------------------------------------------------------- -- View doc items ---------------------------------------------------------------------------- -- | Renders to a view section. data DView = DView { dvName :: ViewName , dvSub :: SubDoc } -- | Renders to a line mentioning the view's argument. data DViewArg = forall a. (NiceViewable a, TypeHasDoc a) => DViewArg (Proxy a) -- | Renders to a line mentioning the view's argument. data DViewRet = forall a. (NiceViewable a, TypeHasDoc a) => DViewRet (Proxy a) instance DocItem DViewArg where docItemPos = 20 docItemSectionName = Nothing docItemDependencies (DViewArg p) = [ SomeDocDefinitionItem (DType p) ] docItemToMarkdown _ (DViewArg p) = "Argument type: " <> typeDocMdReference p (WithinParens False) <> "\n\n" instance DocItem DViewRet where docItemPos = 21 docItemSectionName = Nothing docItemDependencies (DViewRet p) = [ SomeDocDefinitionItem (DType p) ] docItemToMarkdown _ (DViewRet p) = "Return type: " <> typeDocMdReference p (WithinParens False) <> "\n\n" instance DocItem DView where type DocItemPlacement DView = 'DocItemInlined type DocItemReferenced DView = 'True docItemRef (DView name _) = DocItemRefInlined $ DocItemId ("views-" <> pretty name) docItemPos = 12000 docItemSectionName = Just "Contract views" docItemSectionDescription = Just "On-chain views of the contract." docItemToMarkdown lvl (DView name block) = mconcat [ mdHeader lvl $ mdTicked (build name) , subDocToMarkdown (nextHeaderLevel lvl) block ] -- View list ---------------------------------------------------------------------------- -- | Helper typeclass to renders information about view interface. class RenderViewsImpl (vs :: [ViewTyInfo]) where renderViewsDocImpl :: Proxy vs -> Builder instance RenderViewsImpl '[] where renderViewsDocImpl _ = mempty instance ( KnownSymbol name, TypeHasDoc arg, TypeHasDoc ret , RenderViewsImpl vs ) => RenderViewsImpl ('ViewTyInfo name arg ret ': vs) where renderViewsDocImpl _ = mconcat [ mconcat $ map (<> "\n") [ "* " <> mdTicked (pretty $ demoteViewName @name) , " + Parameter type: " , " * Haskell representation: " <> typeDocMdReference (Proxy @arg) (WithinParens False) , " * Michelson: " <> typeDocBuiltMichelsonRep (Proxy @arg) , " + Return type: " , " * Haskell representation: " <> typeDocMdReference (Proxy @ret) (WithinParens False) , " * Michelson: " <> typeDocBuiltMichelsonRep (Proxy @ret) , "" ] , renderViewsDocImpl (Proxy @vs) ] -- | Provides documentation for views descriptor. -- -- Note that views descriptors may describe views that do not belong to the -- current contract, e.g. @TAddress@ may refer to an external contract provided -- by the user in which we want to call a view. class (Typeable vd, RenderViewsImpl (RevealViews vd)) => ViewsDescriptorHasDoc (vd :: Type) where viewsDescriptorName :: Proxy vd -> Text default viewsDescriptorName :: (Generic vd, KnownSymbol (GenericTypeName vd)) => Proxy vd -> Text viewsDescriptorName _ = toText $ symbolVal (Proxy @(GenericTypeName vd)) where _reallyNeedGenerics = Dict @(Generic vd) renderViewsDescriptorDoc :: Proxy vd -> Builder renderViewsDescriptorDoc _ = "Contract having this type must contain the following views:\n" <> renderViewsDocImpl (Proxy @(RevealViews vd)) -- | Renders to documentation of view descriptor. data DViewDesc = forall vd. ViewsDescriptorHasDoc vd => DViewDesc (Proxy vd) instance Eq DViewDesc where (==) = (== Prelude.EQ) ... compare instance Ord DViewDesc where compare = compare `on` (\(DViewDesc p) -> typeRep p) instance DocItem DViewDesc where type DocItemPlacement DViewDesc = 'DocItemInDefinitions type DocItemReferenced DViewDesc = 'True docItemRef (DViewDesc p) = DocItemRef $ DocItemId ("views-descs-" <> show (typeRep p)) docItemPos = 18010 docItemSectionName = Just "Referenced views descriptors" docItemSectionDescription = Just "All the mentioned views descriptors.\n\ \Each descriptor stands for a set of views" docItemToMarkdown lvl (DViewDesc p) = mconcat [ mdSeparator , mdHeader lvl $ mdTicked $ build (viewsDescriptorName p) , "\n\n" , renderViewsDescriptorDoc p ]