Doc.hs

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

{-# OPTIONS_GHC -Wno-orphans #-}

-- | Autodoc for UStore.
module Lorentz.UStore.Doc
  ( UStoreTemplateHasDoc (..)
  , UStoreMarkerHasDoc (..)
  , DUStoreTemplate (..)
  , dUStoreTemplateRef
  , DocumentTW
  ) where

import Data.Constraint (Dict(..))
import Fmt (build)
import Lorentz.Doc
import Lorentz.UStore.Traversal
import Lorentz.UStore.Types
import Michelson.Typed.Haskell.Doc
import Util.Generic
import Util.Label
import Util.Markdown
import Util.Typeable
import Util.TypeLits

-- | Information for UStore template required for documentation.
--
-- You only need to instantiate this for templates used directly in
-- UStore, nested subtemplates do not need this instance.
class Typeable template => UStoreTemplateHasDoc template where
  -- | UStore template name as it appears in documentation.
  --
  -- Should be only 1 word.
  ustoreTemplateDocName :: Text
  default ustoreTemplateDocName
    :: (Generic template, KnownSymbol (GenericTypeName template))
    => Text
  ustoreTemplateDocName = symbolValT' @(GenericTypeName template)
    where _needGeneric = Dict @(Generic template)

  -- | Description of template.
  ustoreTemplateDocDescription :: Markdown

  -- | Description of template entries.
  ustoreTemplateDocContents :: Markdown
  default ustoreTemplateDocContents
    :: (UStoreTraversable DocumentTW template) => Markdown
  ustoreTemplateDocContents =
    "\n" <> documentUStore (Proxy @template)

  ustoreTemplateDocDependencies :: [SomeTypeWithDoc]
  default ustoreTemplateDocDependencies
    :: (UStoreTraversable DocumentTW template) => [SomeTypeWithDoc]
  ustoreTemplateDocDependencies =
    gatherUStoreDeps (Proxy @template)

-- | Instantiated for documented UStore markers.
class (KnownUStoreMarker marker) =>
      UStoreMarkerHasDoc (marker :: UStoreMarkerType) where

  -- | Specifies key encoding.
  --
  -- You accept description of field name, and should return how is it encoded
  -- as key of @big_map bytes bytes@.
  ustoreMarkerKeyEncoding :: Text -> Text

instance UStoreTemplateHasDoc template =>
         TypeHasDoc (UStore template) where
  typeDocName _ = "Upgradeable storage"
  typeDocMdDescription = [md|
    Storage with not hardcoded structure, which allows upgrading the contract
    in place. UStore is capable of storing simple fields and multiple submaps.
    |]
  typeDocMdReference tp wp =
    applyWithinParens wp $ mconcat
      [ mdLocalRef (mdTicked "UStore") (docItemRef (DType tp))
      , " "
      , dUStoreTemplateRef (DUStoreTemplate (Proxy @template))
      ]
  typeDocHaskellRep = homomorphicTypeDocHaskellRep
  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep
  typeDocDependencies p =
    genericTypeDocDependencies p <>
    [SomeDocDefinitionItem (DUStoreTemplate $ Proxy @template)]

data DUStoreTemplate where
  DUStoreTemplate
    :: UStoreTemplateHasDoc template
    => Proxy template -> DUStoreTemplate

instance Eq DUStoreTemplate where
  DUStoreTemplate p1 == DUStoreTemplate p2 = eqParam1 p1 p2
instance Ord DUStoreTemplate where
  DUStoreTemplate p1 `compare` DUStoreTemplate p2 = compareExt p1 p2

instance DocItem DUStoreTemplate where
  type DocItemPlacement DUStoreTemplate = 'DocItemInDefinitions

  docItemPos = 12700
  docItemSectionName = Just "Used upgradeable storage formats"
  docItemSectionDescription = Just
    "This section describes formats (aka _templates_) of upgradeable storages \
    \mentioned across the given document. \
    \Each format describes set of fields and virtual submaps which the storage \
    \must have."

  docItemToMarkdown lvl (DUStoreTemplate (_ :: Proxy template)) =
    mconcat
    [ mdSeparator
    , mdHeader lvl (mdTicked . build $ ustoreTemplateDocName @template)
    , ustoreTemplateDocDescription @template
    , "\n\n"
    , mdSubsection "Contents" $ ustoreTemplateDocContents @template
    , "\n\n"
    ]

  docItemRef (DUStoreTemplate (_ :: Proxy template)) =
    DocItemRef . DocItemId $
      "ustore-template-" <> ustoreTemplateDocName @template

  docItemDependencies (DUStoreTemplate (_ :: Proxy template)) =
    ustoreTemplateDocDependencies @template <&>
      \(SomeTypeWithDoc t) -> SomeDocDefinitionItem (DType t)

-- | Make a reference to given UStore template description.
dUStoreTemplateRef :: DUStoreTemplate -> Markdown
dUStoreTemplateRef (DUStoreTemplate (_ :: Proxy template)) =
  mdLocalRef (mdTicked . build $ ustoreTemplateDocName @template)
             (docItemRef (DUStoreTemplate (Proxy @template)))

-- Instances
----------------------------------------------------------------------------

instance UStoreTemplateHasDoc () where
  ustoreTemplateDocName = "empty"
  ustoreTemplateDocDescription = ""
  ustoreTemplateDocContents =
    mdItalic "empty"

instance UStoreMarkerHasDoc UMarkerPlainField where
  ustoreMarkerKeyEncoding k = "pack (" <> k <> ")"

-- Internals
----------------------------------------------------------------------------

documentUStore
  :: forall template.
     (UStoreTraversable DocumentTW template)
  => Proxy template -> Markdown
documentUStore _ =
  let Const collected = traverseUStore @_ @template DocumentTW (Const ())
      entries = appEndo (dcEntries collected) []
  in if null entries
     then mdTicked "<empty>"
     else mconcat $ map (\e -> "* " <> e <> "\n") entries

gatherUStoreDeps
  :: forall template.
     (UStoreTraversable DocumentTW template)
  => Proxy template -> [SomeTypeWithDoc]
gatherUStoreDeps _ =
  let Const collected = traverseUStore @_ @template DocumentTW (Const ())
  in appEndo (dcDependencies collected) []

data DocCollector = DocCollector
  { dcEntries :: Endo [Markdown]
  , dcDependencies :: Endo [SomeTypeWithDoc]
  }

data DocumentTW = DocumentTW

instance Semigroup DocCollector where
  DocCollector e1 d1 <> DocCollector e2 d2 = DocCollector (e1 <> e2) (d1 <> d2)
instance Monoid DocCollector where
  mempty = DocCollector mempty mempty

instance UStoreTraversalWay DocumentTW where
  type UStoreTraversalArgumentWrapper DocumentTW = Const ()
  type UStoreTraversalMonad DocumentTW = Const DocCollector

instance (UStoreMarkerHasDoc marker, TypeHasDoc v) =>
         UStoreTraversalFieldHandler DocumentTW marker v where
  ustoreTraversalFieldHandler DocumentTW fieldName (Const ()) =
    Const DocCollector
    { dcEntries = Endo . (:) $ mconcat
        [ mdBold "Field" <> " "
        , mdTicked (build $ labelToText fieldName)
        , ": "
        , typeDocMdReference (Proxy @v) (WithinParens False)
        , "\n"

        , mdSpoiler "Encoding" $ mconcat
          [ "\n"
          , let key = build $
                  ustoreMarkerKeyEncoding @marker
                  ("\"" <> labelToText fieldName <> "\"")
            in
            "  + " <> mdTicked ("key = " <> key) <> "\n\n"
          , "  + " <> mdTicked "value = pack (<field value>)" <> "\n\n"
          , mdSeparator
          ]
        , "\n"
        ]
    , dcDependencies = Endo . (<>) $
        [ SomeTypeWithDoc (Proxy @v)
        ]
    }

instance (TypeHasDoc k, TypeHasDoc v) =>
         UStoreTraversalSubmapHandler DocumentTW k v where
  ustoreTraversalSubmapHandler DocumentTW fieldName (Const ()) =
    Const DocCollector
    { dcEntries = Endo . (:) $ mconcat
        [ mdBold "Submap" <> " "
        , mdTicked (build $ labelToText fieldName)
        , ": "
        , typeDocMdReference (Proxy @k) (WithinParens False)
        , " -> "
        , typeDocMdReference (Proxy @v) (WithinParens False)
        , "\n"

        , mdSpoiler "Encoding" $ mconcat
          [ "\n"
          , " + " <> mdTicked "key = pack (<submap key>)" <> "\n\n"
          , " + " <> mdTicked "value = pack (<submap value>)" <> "\n\n"
          , mdSeparator
          ]
        , "\n"
        ]
    , dcDependencies = Endo . (<>) $
        [ SomeTypeWithDoc (Proxy @k)
        , SomeTypeWithDoc (Proxy @v)
        ]
    }