-- | Utilities for declaring and documenting entry points.
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

-- | Gathers information about single entrypoint.
--
-- We assume that entry points might be of different kinds,
-- which is designated by phantom type parameter.
-- For instance, you may want to have several groups of entry points
-- corresponding to various parts of a contract - specifying different @kind@
-- type argument for each of those groups will allow you defining different
-- 'DocItem' instances with appropriate custom descriptions for them.
data DEntryPoint (kind :: Kind.Type) = DEntryPoint
  { depName :: Text
  , depSub :: SubDoc
  }

-- | Default implementation of 'docItemToMarkdown' for entry points.
diEntryPointToMarkdown :: HeaderLevel -> DEntryPoint level -> Markdown
diEntryPointToMarkdown lvl (DEntryPoint name block) =
  mdSeparator <>
  mdHeader lvl (mdTicked . build . over _head toLower $ name) <>
  subDocToMarkdown (nextHeaderLevel lvl) block

-- | Default value for 'DEntryPoint' type argument.
data PlainEntryPointsKind

instance DocItem (DEntryPoint PlainEntryPointsKind) where
  type DocItemPosition (DEntryPoint PlainEntryPointsKind) = 1000
  docItemSectionName = Just "Entrypoints"
  docItemToMarkdown = diEntryPointToMarkdown

-- | During incremental assembly of parameter building steps -
-- current representation of parameter.
type CurrentParam = Markdown

-- | Describes a parameter building step.
--
-- This can be wrapping into (Haskell) constructor, or a more complex
-- transformation.
data ParamBuildingStep = ParamBuildingStep
  { pbsEnglish :: Markdown
    -- ^ Plain english description of this step.
  , pbsHaskell :: CurrentParam -> Markdown
    -- ^ How to construct parameter in Haskell code.
  , pbsMichelson :: CurrentParam -> Markdown
    -- ^ How to construct parameter working on raw Michelson.
  }

-- | Describes argument of an entrypoint.
data DEntryPointArg =
  DEntryPointArg
  { epaArg :: Maybe DType
    -- ^ Argument of the entrypoint. Pass 'Nothing' if no argument is required.
  , epaHasAnnotation :: Bool
    -- ^ Whether this entrypoint has a field annotation (and thus is
    -- callable using the standard "lightweigth entrypoints"
    -- mechanism) or is a virtual entrypoint which requires
    -- constructing a value of the full parameter type.
  , epaBuilding :: [ParamBuildingStep]
    -- ^ Describes a way to lift an entrypoint argument into full parameter
    -- which can be passed to the contract.
    --
    -- Steps are supposed to be applied in the order in which they are given.
    -- E.g. suppose that an entrypoint is called as @Run (Service1 arg)@;
    -- then the first step should describe wrapping into @Service1@ constructor,
    -- and the second step should be about wrapping into @Run@ constructor.
  , epaType :: Untyped.Type
    -- ^ Untyped representation of entrypoint, used for printing its michelson
    -- type representation.
  }

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
  }

-- | Go over contract code and update every occurrence of 'DEntryPointArg'
-- documentation item, adding the given step to its "how to build parameter"
-- description.
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

      -- TODO: currently we always set @hasAnnotation@ to @True@,
      -- hence this case in unreachable.  It is still useful, we
      -- should set @hasAnnotation@ properly and improve handling of
      -- this case.  Specifically, for virtual entrypoints we should
      -- wrap them into constructors until we reach one having a field
      -- annotation. As soon as it is reached, we can call the
      -- contract by an entrypoint name.
      howToCallVirtualEntrypoint =
        [ mconcat . Prelude.intersperse "\n" $
            psteps <&> \ParamBuildingStep{..} ->
              mconcat . Prelude.intersperse "\n" $
              [ -- Markdown re-enumerates enumerated lists automatically
                "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."
        ]

-- | Pick a type documentation from 'CtorField'.
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

-- | Add necessary documentation to entry points.
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

-- | Constraint for 'documentEntryPoints'.
type DocumentEntryPoints kind a =
  (Generic a, GDocumentEntryPoints kind (G.Rep a))

-- | Traverse entry points and add parameter building step (which describes
-- necessity to wrap parameter into some constructor of the given datatype)
-- to all parameters described within given code.
class GDocumentEntryPoints (kind :: Kind.Type) (x :: Kind.Type -> Kind.Type) where
  -- | Add corresponding parameter building step.
  --
  -- First argument is accumulator for Michelson description of the building step.
  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

-- | Like 'case_', to be used for pattern-matching on parameter.
--
-- Modifies documentation accordingly. Including description of
-- entrypoints' arguments, thus for them you will need to supply
-- 'TypeHasDoc' instance.
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

-- | Version of 'entryCase_' for tuples.
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

-- | Wrapper for documenting single entrypoint which parameter
-- isn't going to be unwrapped from some datatype.
--
-- @entryCase@ unwraps a datatype, however, sometimes we want to
-- have entrypoint parameter to be not wrapped into some datatype.
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

-- | Provides arror for convenient entrypoint documentation
class EntryArrow kind name body where
  -- | Lift entrypoint implementation.
  --
  -- Entrypoint names should go with "e" prefix.
  (#->) :: (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