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

-- | Extracting documentation from instructions set.
module Michelson.Typed.Doc
  ( buildInstrDoc
  , buildInstrDocWithGitRev
  , modifyInstrDoc
  , modifyInstrAllDoc
  , cutInstrNonDoc
  , docInstr
  ) where

import Control.Lens (at)
import Data.Default (def)
import Data.Typeable (cast)
import Prelude hiding (Ordering(..))

import Michelson.Doc
import Michelson.Typed.Instr
import Michelson.Typed.Util

someDefinitionDocItemToContractDoc :: SomeDocDefinitionItem -> State ContractDoc ()
someDefinitionDocItemToContractDoc :: SomeDocDefinitionItem -> State ContractDoc ()
someDefinitionDocItemToContractDoc sdi :: SomeDocDefinitionItem
sdi@(SomeDocDefinitionItem di :: d
di) =
  (ContractDoc -> ContractDoc) -> State ContractDoc ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ContractDoc -> ContractDoc) -> State ContractDoc ())
-> (ContractDoc -> ContractDoc) -> State ContractDoc ()
forall a b. (a -> b) -> a -> b
$ (ContractDoc -> ContractDoc -> ContractDoc)
-> ContractDoc -> ContractDoc -> ContractDoc
forall a b c. (a -> b -> c) -> b -> a -> c
flip ContractDoc -> ContractDoc -> ContractDoc
forall a. Monoid a => a -> a -> a
mappend
    ContractDoc
forall a. Monoid a => a
mempty
    { cdContents :: DocBlock
cdContents = DocBlock
forall a. Monoid a => a
mempty
    , cdDefinitions :: DocBlock
cdDefinitions = d -> DocBlock
forall di. DocItem di => di -> DocBlock
docItemToBlock d
di
    , cdDefinitionsSet :: Set SomeDocDefinitionItem
cdDefinitionsSet = OneItem (Set SomeDocDefinitionItem) -> Set SomeDocDefinitionItem
forall x. One x => OneItem x -> x
one OneItem (Set SomeDocDefinitionItem)
SomeDocDefinitionItem
sdi
    , cdDefinitionIds :: Set DocItemId
cdDefinitionIds = OneItem (Set DocItemId) -> Set DocItemId
forall x. One x => OneItem x -> x
one (OneItem (Set DocItemId) -> Set DocItemId)
-> OneItem (Set DocItemId) -> Set DocItemId
forall a b. (a -> b) -> a -> b
$ case d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
forall d.
DocItem d =>
d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
docItemRef d
di of
        DocItemRef docItemId :: DocItemId
docItemId -> OneItem (Set DocItemId)
DocItemId
docItemId
    }

someDocItemToContractDoc :: SomeDocItem -> State ContractDoc ()
someDocItemToContractDoc :: SomeDocItem -> State ContractDoc ()
someDocItemToContractDoc (SomeDocItem di :: d
di) = do
  () <- case d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
forall d.
DocItem d =>
d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
docItemRef d
di of
    DocItemNoRef ->
      (ContractDoc -> ContractDoc) -> State ContractDoc ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (ContractDoc -> ContractDoc -> ContractDoc
forall a. Semigroup a => a -> a -> a
<> ContractDoc
forall a. Monoid a => a
mempty{ cdContents :: DocBlock
cdContents = d -> DocBlock
forall di. DocItem di => di -> DocBlock
docItemToBlock d
di })
    DocItemRefInlined{} ->
      (ContractDoc -> ContractDoc) -> State ContractDoc ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (ContractDoc -> ContractDoc -> ContractDoc
forall a. Semigroup a => a -> a -> a
<> ContractDoc
forall a. Monoid a => a
mempty{ cdContents :: DocBlock
cdContents = d -> DocBlock
forall di. DocItem di => di -> DocBlock
docItemToBlock d
di })
    DocItemRef{} ->
      SomeDocDefinitionItem -> State ContractDoc ()
someDefinitionDocItemToContractDoc (d -> SomeDocDefinitionItem
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
d -> SomeDocDefinitionItem
SomeDocDefinitionItem d
di)
  [SomeDocDefinitionItem]
-> (Element [SomeDocDefinitionItem] -> State ContractDoc ())
-> State ContractDoc ()
forall t (m :: * -> *) b.
(Container t, Monad m) =>
t -> (Element t -> m b) -> m ()
forM_ @_ @_ @() (d -> [SomeDocDefinitionItem]
forall d. DocItem d => d -> [SomeDocDefinitionItem]
docItemDependencies d
di) ((Element [SomeDocDefinitionItem] -> State ContractDoc ())
 -> State ContractDoc ())
-> (Element [SomeDocDefinitionItem] -> State ContractDoc ())
-> State ContractDoc ()
forall a b. (a -> b) -> a -> b
$ \(SomeDocDefinitionItem dep) ->
    case d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
forall d.
DocItem d =>
d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
docItemRef d
dep of
      DocItemRef{} -> do
        -- Taking special treatment for possible cyclic dependencies.
        Maybe ()
isPresent <- Getting (Maybe ()) ContractDoc (Maybe ())
-> StateT ContractDoc Identity (Maybe ())
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting (Maybe ()) ContractDoc (Maybe ())
 -> StateT ContractDoc Identity (Maybe ()))
-> Getting (Maybe ()) ContractDoc (Maybe ())
-> StateT ContractDoc Identity (Maybe ())
forall a b. (a -> b) -> a -> b
$ (Set SomeDocDefinitionItem
 -> Const (Maybe ()) (Set SomeDocDefinitionItem))
-> ContractDoc -> Const (Maybe ()) ContractDoc
Lens' ContractDoc (Set SomeDocDefinitionItem)
cdDefinitionsSetL ((Set SomeDocDefinitionItem
  -> Const (Maybe ()) (Set SomeDocDefinitionItem))
 -> ContractDoc -> Const (Maybe ()) ContractDoc)
-> ((Maybe () -> Const (Maybe ()) (Maybe ()))
    -> Set SomeDocDefinitionItem
    -> Const (Maybe ()) (Set SomeDocDefinitionItem))
-> Getting (Maybe ()) ContractDoc (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Set SomeDocDefinitionItem)
-> Lens'
     (Set SomeDocDefinitionItem)
     (Maybe (IxValue (Set SomeDocDefinitionItem)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (d -> SomeDocDefinitionItem
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
d -> SomeDocDefinitionItem
SomeDocDefinitionItem d
dep)
        case Maybe ()
isPresent of
          Just () -> State ContractDoc ()
forall (f :: * -> *). Applicative f => f ()
pass
          Nothing -> SomeDocItem -> State ContractDoc ()
someDocItemToContractDoc (d -> SomeDocItem
forall d. DocItem d => d -> SomeDocItem
SomeDocItem d
dep)

-- | Put a document item.
docInstr :: DocItem di => di -> Instr s s
docInstr :: di -> Instr s s
docInstr = ExtInstr s -> Instr s s
forall (s :: [T]). ExtInstr s -> Instr s s
Ext (ExtInstr s -> Instr s s) -> (di -> ExtInstr s) -> di -> Instr s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeDocItem -> ExtInstr s
forall (s :: [T]). SomeDocItem -> ExtInstr s
DOC_ITEM (SomeDocItem -> ExtInstr s)
-> (di -> SomeDocItem) -> di -> ExtInstr s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. di -> SomeDocItem
forall d. DocItem d => d -> SomeDocItem
SomeDocItem

attachGitInfo :: DGitRevision -> Instr inp out -> Instr inp out
attachGitInfo :: DGitRevision -> Instr inp out -> Instr inp out
attachGitInfo gitRev :: DGitRevision
gitRev = (DGitRevision -> Maybe DGitRevision)
-> Instr inp out -> Instr inp out
forall i1 i2 (inp :: [T]) (out :: [T]).
(DocItem i1, DocItem i2) =>
(i1 -> Maybe i2) -> Instr inp out -> Instr inp out
modifyInstrDoc ((DGitRevision -> Maybe DGitRevision)
 -> Instr inp out -> Instr inp out)
-> (DGitRevision -> Maybe DGitRevision)
-> Instr inp out
-> Instr inp out
forall a b. (a -> b) -> a -> b
$ \case
  DGitRevisionUnknown -> DGitRevision -> Maybe DGitRevision
forall a. a -> Maybe a
Just DGitRevision
gitRev
  _ -> Maybe DGitRevision
forall a. Maybe a
Nothing

attachToc :: DToc -> Instr inp out -> Instr inp out
attachToc :: DToc -> Instr inp out -> Instr inp out
attachToc toc :: DToc
toc = (DToc -> Maybe DToc) -> Instr inp out -> Instr inp out
forall i1 i2 (inp :: [T]) (out :: [T]).
(DocItem i1, DocItem i2) =>
(i1 -> Maybe i2) -> Instr inp out -> Instr inp out
modifyInstrDoc ((DToc -> Maybe DToc) -> Instr inp out -> Instr inp out)
-> (DToc -> Maybe DToc) -> Instr inp out -> Instr inp out
forall a b. (a -> b) -> a -> b
$ \case
  DToc "" -> DToc -> Maybe DToc
forall a. a -> Maybe a
Just (DToc -> Maybe DToc) -> DToc -> Maybe DToc
forall a b. (a -> b) -> a -> b
$ DToc
toc
  _ -> Maybe DToc
forall a. Maybe a
Nothing

-- | Assemble contract documentation with the revision of the contract.
buildInstrDocWithGitRev :: DGitRevision -> Instr inp out -> ContractDoc
buildInstrDocWithGitRev :: DGitRevision -> Instr inp out -> ContractDoc
buildInstrDocWithGitRev gitRev :: DGitRevision
gitRev contract :: Instr inp out
contract =
  let toc :: DToc
toc = Markdown -> DToc
DToc (Markdown -> DToc) -> Markdown -> DToc
forall a b. (a -> b) -> a -> b
$ ContractDoc -> Markdown
contractDocToToc (ContractDoc -> Markdown) -> ContractDoc -> Markdown
forall a b. (a -> b) -> a -> b
$ Instr inp out -> ContractDoc
forall (inp :: [T]) (out :: [T]). Instr inp out -> ContractDoc
buildInstrDoc Instr inp out
contract
      c :: Instr inp out
c = Instr inp out
contract
            Instr inp out -> (Instr inp out -> Instr inp out) -> Instr inp out
forall a b. a -> (a -> b) -> b
& DGitRevision -> Instr inp out -> Instr inp out
forall (inp :: [T]) (out :: [T]).
DGitRevision -> Instr inp out -> Instr inp out
attachGitInfo DGitRevision
gitRev
            Instr inp out -> (Instr inp out -> Instr inp out) -> Instr inp out
forall a b. a -> (a -> b) -> b
& DToc -> Instr inp out -> Instr inp out
forall (inp :: [T]) (out :: [T]).
DToc -> Instr inp out -> Instr inp out
attachToc DToc
toc
  in Instr inp out -> ContractDoc
forall (inp :: [T]) (out :: [T]). Instr inp out -> ContractDoc
buildInstrDoc Instr inp out
c

-- | Assemble contract documentation.
buildInstrDoc :: Instr inp out -> ContractDoc
buildInstrDoc :: Instr inp out -> ContractDoc
buildInstrDoc = DfsSettings ContractDoc
-> (forall (inp :: [T]) (out :: [T]). Instr inp out -> ContractDoc)
-> Instr inp out
-> ContractDoc
forall x (inp :: [T]) (out :: [T]).
Semigroup x =>
DfsSettings x
-> (forall (i :: [T]) (o :: [T]). Instr i o -> x)
-> Instr inp out
-> x
dfsFoldInstr DfsSettings ContractDoc
dfsSettings ((forall (inp :: [T]) (out :: [T]). Instr inp out -> ContractDoc)
 -> Instr inp out -> ContractDoc)
-> (forall (inp :: [T]) (out :: [T]). Instr inp out -> ContractDoc)
-> Instr inp out
-> ContractDoc
forall a b. (a -> b) -> a -> b
$ \case
  Ext ext :: ExtInstr i
ext -> case ExtInstr i
ext of
    DOC_ITEM sdi :: SomeDocItem
sdi ->
      State ContractDoc () -> ContractDoc -> ContractDoc
forall s a. State s a -> s -> s
execState (SomeDocItem -> State ContractDoc ()
someDocItemToContractDoc SomeDocItem
sdi) ContractDoc
forall a. Monoid a => a
mempty
    _ -> ContractDoc
forall a. Monoid a => a
mempty
  _ -> ContractDoc
forall a. Monoid a => a
mempty
  where
  dfsSettings :: DfsSettings ContractDoc
  dfsSettings :: DfsSettings ContractDoc
dfsSettings = DfsSettings Any
forall a. Default a => a
def
    { dsCtorEffectsApp :: CtorEffectsApp ContractDoc
dsCtorEffectsApp = $WCtorEffectsApp :: forall x.
Text
-> (forall (i :: [T]) (o :: [T]).
    Semigroup x =>
    x -> x -> Instr i o -> (Instr i o, x))
-> CtorEffectsApp x
CtorEffectsApp
        { ceaName :: Text
ceaName = "Building DocGroup"
        , ceaApplyEffects :: forall (i :: [T]) (o :: [T]).
Semigroup ContractDoc =>
ContractDoc -> ContractDoc -> Instr i o -> (Instr i o, ContractDoc)
ceaApplyEffects = \resChildren :: ContractDoc
resChildren _ -> \case
            i :: Instr i o
i@(DocGroup grouping :: DocGrouping
grouping _) ->
              (Instr i o
i, DocGrouping -> ContractDoc -> ContractDoc
docGroupContent DocGrouping
grouping ContractDoc
resChildren)
            i :: Instr i o
i -> (Instr i o
i, ContractDoc
resChildren)
        }
    }

-- | Modify all documentation items recursively.
modifyInstrAllDoc
  :: (SomeDocItem -> SomeDocItem)
  -> Instr inp out
  -> Instr inp out
modifyInstrAllDoc :: (SomeDocItem -> SomeDocItem) -> Instr inp out -> Instr inp out
modifyInstrAllDoc mapper :: SomeDocItem -> SomeDocItem
mapper = DfsSettings ()
-> (forall (i :: [T]) (o :: [T]). Instr i o -> Instr i o)
-> Instr inp out
-> Instr inp out
forall (inp :: [T]) (out :: [T]).
DfsSettings ()
-> (forall (i :: [T]) (o :: [T]). Instr i o -> Instr i o)
-> Instr inp out
-> Instr inp out
dfsModifyInstr DfsSettings ()
forall a. Default a => a
def ((forall (i :: [T]) (o :: [T]). Instr i o -> Instr i o)
 -> Instr inp out -> Instr inp out)
-> (forall (i :: [T]) (o :: [T]). Instr i o -> Instr i o)
-> Instr inp out
-> Instr inp out
forall a b. (a -> b) -> a -> b
$ \case
  Ext ext :: ExtInstr i
ext -> ExtInstr i -> Instr i o
forall (s :: [T]). ExtInstr s -> Instr s s
Ext (ExtInstr i -> Instr i o) -> ExtInstr i -> Instr i o
forall a b. (a -> b) -> a -> b
$
    case ExtInstr i
ext of
      DOC_ITEM sdi :: SomeDocItem
sdi -> SomeDocItem -> ExtInstr i
forall (s :: [T]). SomeDocItem -> ExtInstr s
DOC_ITEM (SomeDocItem -> SomeDocItem
mapper SomeDocItem
sdi)
      i :: ExtInstr i
i -> ExtInstr i
i
  i :: Instr i o
i -> Instr i o
i

-- | Recursevly traverse an instruction and modify documentation items
-- matching given type.
--
-- If mapper returns 'Nothing', doc item will remain unmodified.
modifyInstrDoc
  :: (DocItem i1, DocItem i2)
  => (i1 -> Maybe i2)
  -> Instr inp out
  -> Instr inp out
modifyInstrDoc :: (i1 -> Maybe i2) -> Instr inp out -> Instr inp out
modifyInstrDoc mapper :: i1 -> Maybe i2
mapper = (SomeDocItem -> SomeDocItem) -> Instr inp out -> Instr inp out
forall (inp :: [T]) (out :: [T]).
(SomeDocItem -> SomeDocItem) -> Instr inp out -> Instr inp out
modifyInstrAllDoc SomeDocItem -> SomeDocItem
untypedMapper
  where
  untypedMapper :: SomeDocItem -> SomeDocItem
untypedMapper sdi :: SomeDocItem
sdi@(SomeDocItem di :: d
di) = SomeDocItem -> Maybe SomeDocItem -> SomeDocItem
forall a. a -> Maybe a -> a
fromMaybe SomeDocItem
sdi (Maybe SomeDocItem -> SomeDocItem)
-> Maybe SomeDocItem -> SomeDocItem
forall a b. (a -> b) -> a -> b
$ do
    i1
di' <- d -> Maybe i1
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast d
di
    i2
newDi <- i1 -> Maybe i2
mapper i1
di'
    return (i2 -> SomeDocItem
forall d. DocItem d => d -> SomeDocItem
SomeDocItem i2
newDi)

-- | Leave only instructions related to documentation.
--
-- Generated documentation for resulting instruction remains the same, but
-- semantics of instruction itself gets lost.
-- We have to pass optimizer here as an argument to avoid cyclic dependencies.
cutInstrNonDoc :: (forall i o. Instr i o -> Instr i o) -> Instr inp out -> Instr s s
cutInstrNonDoc :: (forall (i :: [T]) (o :: [T]). Instr i o -> Instr i o)
-> Instr inp out -> Instr s s
cutInstrNonDoc optimize :: forall (i :: [T]) (o :: [T]). Instr i o -> Instr i o
optimize = Instr s s -> Instr s s
forall (i :: [T]) (o :: [T]). Instr i o -> Instr i o
optimize (Instr s s -> Instr s s)
-> (Instr inp out -> Instr s s) -> Instr inp out -> Instr s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DfsSettings (Instr s s)
-> (forall (i :: [T]) (o :: [T]). Instr i o -> Instr s s)
-> Instr inp out
-> Instr s s
forall x (inp :: [T]) (out :: [T]).
Semigroup x =>
DfsSettings x
-> (forall (i :: [T]) (o :: [T]). Instr i o -> x)
-> Instr inp out
-> x
dfsFoldInstr DfsSettings (Instr s s)
forall (s :: [T]). DfsSettings (Instr s s)
dfsSettings forall (i :: [T]) (o :: [T]). Instr i o -> Instr s s
forall (inp :: [T]) (out :: [T]) (s :: [T]).
Instr inp out -> Instr s s
step
  where
  dfsSettings :: DfsSettings (Instr s s)
  dfsSettings :: DfsSettings (Instr s s)
dfsSettings = DfsSettings Any
forall a. Default a => a
def
    { dsCtorEffectsApp :: CtorEffectsApp (Instr s s)
dsCtorEffectsApp = $WCtorEffectsApp :: forall x.
Text
-> (forall (i :: [T]) (o :: [T]).
    Semigroup x =>
    x -> x -> Instr i o -> (Instr i o, x))
-> CtorEffectsApp x
CtorEffectsApp
        { ceaName :: Text
ceaName = "Wrap into DocGroup"
        , ceaApplyEffects :: forall (i :: [T]) (o :: [T]).
Semigroup (Instr s s) =>
Instr s s -> Instr s s -> Instr i o -> (Instr i o, Instr s s)
ceaApplyEffects = \resChildren :: Instr s s
resChildren _ -> \case
            i :: Instr i o
i@(DocGroup g :: DocGrouping
g _) -> (Instr i o
i, DocGrouping -> Instr s s -> Instr s s
forall (inp :: [T]) (out :: [T]).
DocGrouping -> Instr inp out -> Instr inp out
DocGroup DocGrouping
g Instr s s
resChildren)
            i :: Instr i o
i -> (Instr i o
i, Instr s s
resChildren)
        }
    }
  step :: Instr inp out -> Instr s s
  step :: Instr inp out -> Instr s s
step = \case
    Ext ext :: ExtInstr inp
ext -> case ExtInstr inp
ext of
      DOC_ITEM di :: SomeDocItem
di -> ExtInstr s -> Instr s s
forall (s :: [T]). ExtInstr s -> Instr s s
Ext (ExtInstr s -> Instr s s) -> ExtInstr s -> Instr s s
forall a b. (a -> b) -> a -> b
$ SomeDocItem -> ExtInstr s
forall (s :: [T]). SomeDocItem -> ExtInstr s
DOC_ITEM SomeDocItem
di
      _ -> Instr s s
forall (s :: [T]). Instr s s
Nop
    _ -> Instr s s
forall (s :: [T]). Instr s s
Nop