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

-- Dunno why it triggers
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Documentation of types appearing in contracts.
module Michelson.Typed.Haskell.Doc
  ( ADTRep
  , ConstructorRep (..)
  , crNameL, crDescriptionL, crFieldsL
  , FieldRep (..)
  , frNameL, frDescriptionL, frTypeRepL
  , WithinParens (..)
  , TypeHasDoc (..)
  , TypeDocHaskellRep
  , TypeDocMichelsonRep
  , FieldDescriptions
  , PolyTypeHasDocC
  , SomeTypeWithDoc (..)

  , HaveCommonTypeCtor
  , IsHomomorphic
  , genericTypeDocDependencies
  , customTypeDocMdReference
  , homomorphicTypeDocMdReference
  , poly1TypeDocMdReference
  , poly2TypeDocMdReference
  , homomorphicTypeDocHaskellRep
  , concreteTypeDocHaskellRep
  , concreteTypeDocHaskellRepUnsafe
  , haskellAddNewtypeField
  , haskellRepNoFields
  , haskellRepStripFieldPrefix
  , homomorphicTypeDocMichelsonRep
  , concreteTypeDocMichelsonRep
  , concreteTypeDocMichelsonRepUnsafe

  , DType (..)
  , DStorageType (..)
  , dStorage
  , GTypeHasDoc
  , GProductHasDoc
  , dTypeDep
  , dTypeDepP
  , buildADTRep
  , applyWithinParens
  ) where

import Control.Lens (each, to, _Just)
import Data.Char (isLower, isUpper, toLower)
import qualified Data.Kind as Kind
import Data.List (lookup)
import Data.Singletons (SingI, demote)
import qualified Data.Text as T
import Data.Typeable (typeRep)
import Fmt (Buildable, build, (+|), (|+))
import GHC.Generics ((:*:)(..), (:+:)(..))
import qualified GHC.Generics as G
import GHC.TypeLits (ErrorMessage(..), KnownSymbol, TypeError, symbolVal)
import Named (NamedF)
import qualified Text.Show
import Type.Showtype (Showtype(..))

import Michelson.Doc
import Michelson.Text
import Michelson.Typed.Aliases
import Michelson.Typed.Entrypoints
import Michelson.Typed.Haskell.ValidateDescription
import Michelson.Typed.Haskell.Value
import Michelson.Typed.T
import Tezos.Address
import Tezos.Core
import Tezos.Crypto
import Util.Generic
import Util.Lens
import Util.Markdown
import Util.Named
import Util.Typeable

-- | Stands for representation of some Haskell ADT corresponding to
-- Michelson value. Type parameter @a@ is what you put in place of
-- each field of the datatype, e.g. information about field type.
--
-- This representation also includes descriptions of constructors and fields.
type ADTRep a = NonEmpty (ConstructorRep a)

-- | Representation of a constructor with an optional description.
data ConstructorRep a = ConstructorRep
  { crName :: Text
  , crDescription :: Maybe Text
  , crFields :: [FieldRep a]
  }

-- | Representation of a field with an optional description.
data FieldRep a = FieldRep
  { frName :: Maybe Text
  , frDescription :: Maybe Text
  , frTypeRep :: a
  }

makeLensesWith postfixLFields ''ConstructorRep
makeLensesWith postfixLFields ''FieldRep

-- | Show given 'ADTRep' in a neat way.
buildADTRep :: forall a. (WithinParens -> a -> Markdown) -> ADTRep a -> Markdown
buildADTRep buildField = \case
  ctor@ConstructorRep{..} :| [] -> renderProduct (WithinParens False) ctor crFields
  ps -> (mappend (mdItalic "one of" <> " \n")) $
        foldMap
        (toListItem . renderNamedProduct (WithinParens True)) (toList ps)
  where
    toListItem item = "+ " <> item <> "\n"

    renderNamedProduct :: WithinParens -> ConstructorRep a -> Markdown
    renderNamedProduct wp ctor@ConstructorRep{..} =
      mdBold (build crName) <>
      if hasFieldNames
         then maybe "" (\d -> ": " <> build d <> " ") crDescription <>
              renderProduct wp ctor crFields
         else renderProduct wp ctor crFields <>
              maybe "" (\d -> ": " <> build d) crDescription
      where
        hasFieldNames = any (isJust . frName) crFields

    renderProduct :: WithinParens -> ConstructorRep a -> [FieldRep a] -> Markdown
    renderProduct wp ctor = \case
      [] -> "()"
      [t@FieldRep{ frDescription = Nothing }]
        | Nothing <- crDescription ctor -> renderNamedField wp t
      ts -> mconcat $ map (("\n  * " <>) . renderNamedField wp) ts

    renderNamedField :: WithinParens -> FieldRep a -> Markdown
    renderNamedField wp FieldRep{..} = mconcat
      [ maybe "" buildFieldName frName
      , buildField wp frTypeRep
      , maybe "" (mappend "    " . mappend "\n" . build) frDescription
      ]

-- | Map field names in a 'ADTRep', with the possibility to remove some names by
-- mapping them to 'Nothing'.
mapADTRepFields :: (Maybe Text -> Maybe Text) -> ADTRep a -> ADTRep a
mapADTRepFields = over $ each . crFieldsL . each . frNameL

-- | How field names should be displayed.
--
-- Result of this function call should appear right before rendered type
-- of that field.
buildFieldName :: Text -> Markdown
buildFieldName name = mdItalic (mdBold (build name)) |+ " :"

-- | Whether given text should be rendered grouped in parentheses
-- (if they make sense).
newtype WithinParens = WithinParens Bool

applyWithinParens :: WithinParens -> Markdown -> Markdown
applyWithinParens (WithinParens wp) txt
  | wp = "(" <> txt <> ")"
  | otherwise = txt

-- | Description for a Haskell type appearing in documentation.
class ( Typeable a
      , SingI (TypeDocFieldDescriptions a)
      , FieldDescriptionsValid (TypeDocFieldDescriptions a) a
      ) => TypeHasDoc a where
  -- | Name of type as it appears in definitions section.
  --
  -- Each type must have its own unique name because it will be used
  -- in identifier for references.
  --
  -- Default definition derives name from Generics.
  -- If it does not fit, consider defining this function manually.
  -- (We tried using 'Data.Data' for this, but it produces names including
  -- module names which is not do we want).
  typeDocName :: Proxy a -> Text
  default typeDocName
    :: (Generic a, KnownSymbol (GenericTypeName a))
    => Proxy a -> Text
  typeDocName _ = toText $ symbolVal (Proxy @(GenericTypeName a))

  -- | Explanation of a type. Markdown formatting is allowed.
  typeDocMdDescription :: Markdown

  -- | How reference to this type is rendered, in Markdown.
  --
  -- Examples:
  --
  -- * @\[Integer](\#type-integer)@,
  -- * @\[Maybe](\#type-Maybe) \[()](\#type-unit)@.
  --
  -- Consider using one of the following functions as default implementation;
  -- which one to use depends on number of type arguments in your type:
  --
  -- * 'homomorphicTypeDocMdReference'
  -- * 'poly1TypeDocMdReference'
  -- * 'poly2TypeDocMdReference'
  --
  -- If none of them fits your purposes precisely, consider using
  -- 'customTypeDocMdReference'.
  typeDocMdReference :: Proxy a -> WithinParens -> Markdown
  default typeDocMdReference
    :: (Typeable a, IsHomomorphic a)
    => Proxy a -> WithinParens -> Markdown
  typeDocMdReference = homomorphicTypeDocMdReference

  -- | All types which this type directly contains.
  --
  -- Used in automatic types discovery.
  typeDocDependencies :: Proxy a -> [SomeDocDefinitionItem]
  default typeDocDependencies
    :: (Generic a, GTypeHasDoc (G.Rep a))
    => Proxy a -> [SomeDocDefinitionItem]
  typeDocDependencies = genericTypeDocDependencies

  -- | For complex types - their immediate Haskell representation.
  --
  -- For primitive types set this to 'Nothing'.
  --
  -- For homomorphic types use 'homomorphicTypeDocHaskellRep' implementation.
  --
  -- For polymorhpic types consider using 'concreteTypeDocHaskellRep' as implementation.
  --
  -- Modifier 'haskellRepNoFields' can be used to hide names of fields,
  -- beneficial for newtypes.
  --
  -- Another modifier called 'haskellRepStripFieldPrefix' can be used for datatypes
  -- to leave only meaningful part of name in every field.
  typeDocHaskellRep :: TypeDocHaskellRep a
  default typeDocHaskellRep
    :: (Generic a, GTypeHasDoc (G.Rep a), IsHomomorphic a)
    => TypeDocHaskellRep a
  typeDocHaskellRep = haskellRepStripFieldPrefix homomorphicTypeDocHaskellRep

  -- | Description of constructors and fields of @a@.
  --
  -- See 'FieldDescriptions' documentation for an example of usage.
  --
  -- Descriptions will be checked at compile time to make sure that only existing constructors
  -- and fields are referenced.
  --
  -- For that check to work @instance Generic a@ is required whenever @TypeDocFieldDescriptions@
  -- is not empty.
  --
  -- For implementation of the check see 'FieldDescriptionsValid' type family.
  type TypeDocFieldDescriptions a :: FieldDescriptions
  type TypeDocFieldDescriptions a = '[]

  -- | Final michelson representation of a type.
  --
  -- For homomorphic types use 'homomorphicTypeDocMichelsonRep' implementation.
  --
  -- For polymorhpic types consider using 'concreteTypeDocMichelsonRep' as implementation.
  typeDocMichelsonRep :: TypeDocMichelsonRep a
  default typeDocMichelsonRep
    :: (SingI (ToT a), IsHomomorphic a)
    => TypeDocMichelsonRep a
  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep

-- | Signature of 'typeDocHaskellRep' function.
--
-- A value of 'FieldDescriptionsV' is provided by the library to make sure that
-- instances won't replace it with an unchecked value.
--
-- When value is 'Just', it contains types which this type is built from.
--
-- First element of provided pair may contain name a concrete type which has
-- the same type constructor as @a@ (or just @a@ for homomorphic types), and
-- the second element of the pair - its unfolding in Haskell.
--
-- For example, for some @newtype MyNewtype = MyNewtype (Integer, Natural)@
-- we would not specify the first element in the pair because @MyNewtype@ is
-- already a concrete type, and second element would contain @(Integer, Natural)@.
-- For polymorhpic types like @newtype MyPolyNewtype a = MyPolyNewtype (Text, a)@,
-- we want to describe its representation on some example of @a@, because
-- working with type variables is too non-trivial; so the first element of
-- the pair may be e.g. @"MyPolyNewType Integer"@, and the second one shows
-- that it unfolds to @(Text, Integer)@.
--
-- When rendered, values of this type look like:
--
-- * @(Integer, Natural)@ - for homomorphic type.
-- * @MyError Integer = (Text, Integer)@ - concrete sample for polymorhpic type.
type TypeDocHaskellRep a =
  Proxy a -> FieldDescriptionsV -> Maybe (Maybe DocTypeRepLHS, ADTRep SomeTypeWithDoc)

-- | Signature of 'typeDocMichelsonRep' function.
--
-- As in 'TypeDocHaskellRep', set the first element of the pair to 'Nothing'
-- for primitive types, otherwise it stands as some instantiation of a type,
-- and its Michelson representation is given in the second element of the pair.
--
-- Examples of rendered representation:
--
-- * @pair int nat@ - for homomorphic type.
-- * @MyError Integer = pair string int@ - concrete sample for polymorhpic type.
type TypeDocMichelsonRep a =
  Proxy a -> (Maybe DocTypeRepLHS, T)

-- | Data hides some type implementing 'TypeHasDoc'.
data SomeTypeWithDoc where
  SomeTypeWithDoc :: TypeHasDoc td => Proxy td -> SomeTypeWithDoc

-- | When rendering type's inner representation, this stands for name of
--
-- Having this makes sense for polymorhpic types, when you want to render
-- representation of some concrete instantiation of that type.
newtype DocTypeRepLHS = DocTypeRepLHS Text
  deriving newtype (IsString, Buildable)

-- | Doc element with description of a type.
data DType where
  DType :: TypeHasDoc a => Proxy a -> DType

instance Show DType where
  show (DType a) = show $ typeRep a

instance Eq DType where
  DType a1 == DType a2 = a1 `eqExt` a2
instance Ord DType where
  DType a1 `compare` DType a2 = a1 `compareExt` a2

instance DocItem DType where
  type DocItemPlacement DType = 'DocItemInDefinitions
  type DocItemReferenced DType = 'True
  docItemPos = 5000

  docItemSectionName = Just "Types"

  docItemRef (DType a) = DocItemRef $
    DocItemId ("types-" <> typeDocName a)

  docItemDependencies (DType (ap' :: Proxy a)) =
    typeDocDependencies ap'

  docItemToMarkdown lvl (DType (ap' :: Proxy a)) =
    mconcat . catMaybes $
    [ Just mdSeparator
    , Just $ mdHeader lvl (mdTicked . build $ typeDocName ap')
    , Just $ typeDocMdDescription @a |+ "\n\n"
    , typeDocHaskellRep ap' (demote @(TypeDocFieldDescriptions a)) <&> \(mlhs, rep) ->
        let
          -- Without this signature type inference trips.
          buildField :: WithinParens -> SomeTypeWithDoc -> Markdown
          buildField wp (SomeTypeWithDoc di) =
            typeDocMdReference di wp
          renderedRep =
             buildADTRep buildField rep
          rendered = case mlhs of
            Nothing ->
              mdSubsection "Structure" renderedRep
            Just lhs ->
              mdSubsection "Structure (example)" $
                mdTicked (build lhs) <> " = " <> renderedRep
        in rendered <> "\n\n"
    , Just $
        let (mlhs, rep) = typeDocMichelsonRep ap'
            renderedRep = mdTicked (build rep)
            rendered = case mlhs of
              Nothing -> mdSubsection "Final Michelson representation"
                         renderedRep
              Just lhs -> mdSubsection "Final Michelson representation (example)" $
                          mdTicked (build lhs) <> " = " <> renderedRep
        in rendered <> "\n\n"
    ]

  docItemToToc lvl d@(DType ap') =
    mdTocFromRef lvl (build $ typeDocName ap') d

-- | Create a 'DType' in form suitable for putting to 'typeDocDependencies'.
dTypeDep :: forall (t :: Kind.Type). TypeHasDoc t => SomeDocDefinitionItem
dTypeDep = SomeDocDefinitionItem (DType (Proxy @t))

-- | Proxy version of 'dTypeDep'.
dTypeDepP
  :: forall (t :: Kind.Type).
      TypeHasDoc t
  => Proxy t -> SomeDocDefinitionItem
dTypeDepP _ = dTypeDep @t

-- | Doc element with description of contract storage type.
newtype DStorageType = DStorageType DType
  deriving stock (Generic, Eq, Ord)

-- | Shortcut for 'DStorageType'.
dStorage :: forall store. TypeHasDoc store => DStorageType
dStorage = DStorageType $ DType (Proxy @store)

instance DocItem DStorageType where
  type DocItemPlacement DStorageType = 'DocItemInlined
  type DocItemReferenced DStorageType = 'True

  docItemRef (DStorageType (DType a)) = DocItemRefInlined $
    DocItemId ("storage-" <> typeDocName a)
  docItemPos = 835
  docItemSectionName = Just "Storage"
  docItemToMarkdown lvl (DStorageType t) = docItemToMarkdown lvl t
  docItemToToc lvl d@(DStorageType (DType a)) =
    mdTocFromRef lvl (build $ typeDocName a) d
  docItemDependencies (DStorageType t) = docItemDependencies t

-- Default implementations
----------------------------------------------------------------------------

-- | Require two types to be built from the same type constructor.
--
-- E.g. @HaveCommonTypeCtor (Maybe Integer) (Maybe Natural)@ is defined,
-- while @HaveCmmonTypeCtor (Maybe Integer) [Integer]@ is not.
class HaveCommonTypeCtor a b
instance HaveCommonTypeCtor ac bc => HaveCommonTypeCtor (ac a) (bc b)
instance HaveCommonTypeCtor a a

-- | Require this type to be homomorphic.
class IsHomomorphic a where
instance TypeError ('Text "Type is not homomorphic: " ':<>: 'ShowType (a b)) =>
         IsHomomorphic (a b)
instance {-# OVERLAPPABLE #-} IsHomomorphic a

-- | Render a reference to a type which consists of type constructor
-- (you have to provide name of this type constructor and documentation
-- for the whole type) and zero or more type arguments.
customTypeDocMdReference :: (Text, DType) -> [DType] -> WithinParens -> Markdown
customTypeDocMdReference (typeCtorName, tyDoc) typeArgsDoc wp =
  let DocItemRef ctorDocItemId = docItemRef tyDoc
  in applyWithinParens wpSmart $
     mconcat . intersperse " " $
      ( mdLocalRef (mdTicked $ build typeCtorName) ctorDocItemId
      : (typeArgsDoc <&> \(DType di) -> typeDocMdReference di (WithinParens True))
      )
    where
      -- If we are rendering an atomic thing, there is no need in parentheses
      -- around it
      wpSmart =
        let WithinParens wp' = wp
        in WithinParens (wp' && not (null typeArgsDoc))

-- | Derive 'typeDocMdReference', for homomorphic types only.
homomorphicTypeDocMdReference
  :: forall (t :: Kind.Type).
     (Typeable t, TypeHasDoc t, IsHomomorphic t)
  => Proxy t -> WithinParens -> Markdown
homomorphicTypeDocMdReference tp _ =
  customTypeDocMdReference
    (typeDocName tp, DType tp)
    []
    (WithinParens False)

-- | Derive 'typeDocMdReference', for polymorphic type with one
-- type argument, like @Maybe Integer@.
poly1TypeDocMdReference
  :: forall t (r :: Kind.Type) (a :: Kind.Type).
      (r ~ t a, Typeable t, Each '[TypeHasDoc] [r, a], IsHomomorphic t)
  => Proxy r -> WithinParens -> Markdown
poly1TypeDocMdReference tp =
  customTypeDocMdReference
    (toText $ showtype (Proxy @t), DType tp)
    [DType (Proxy @a)]

-- | Derive 'typeDocMdReference', for polymorphic type with two
-- type arguments, like @Lambda Integer Natural@.
poly2TypeDocMdReference
  :: forall t (r :: Kind.Type) (a :: Kind.Type) (b :: Kind.Type).
      (r ~ t a b, Typeable t, Each '[TypeHasDoc] [r, a, b], IsHomomorphic t)
  => Proxy r -> WithinParens -> Markdown
poly2TypeDocMdReference tp =
  customTypeDocMdReference
    (toText $ showtype (Proxy @t), DType tp)
    [ DType (Proxy @a)
    , DType (Proxy @b)
    ]

-- | Implement 'typeDocDependencies' via getting all immediate fields
-- of a datatype.
--
-- Note: this will not include phantom types, I'm not sure yet how this
-- scenario should be handled (@martoon).
genericTypeDocDependencies
  :: forall a.
      (Generic a, GTypeHasDoc (G.Rep a))
  => Proxy a -> [SomeDocDefinitionItem]
genericTypeDocDependencies _ = do
  ConstructorRep{..} <- toList $ gTypeDocHaskellRep @(G.Rep a) []
  FieldRep{..} <- crFields
  SomeTypeWithDoc ty <- pure frTypeRep
  return (dTypeDepP ty)

-- | Implement 'typeDocHaskellRep' for a homomorphic type.
--
-- Note that it does not require your type to be of 'IsHomomorphic' instance,
-- which can be useful for some polymorhpic types which, for documentation
-- purposes, we want to consider homomorphic.
--
-- Example: 'Operation' is in fact polymorhpic, but we don't want this fact to
-- be reflected in the documentation.
homomorphicTypeDocHaskellRep
  :: forall a.
     (Generic a, GTypeHasDoc (G.Rep a))
  => TypeDocHaskellRep a
homomorphicTypeDocHaskellRep _ descr = Just
  ( Nothing
  , gTypeDocHaskellRep @(G.Rep a) descr
  )

-- | Implement 'typeDocHaskellRep' on example of given concrete type.
--
-- This is a best effort attempt to implement 'typeDocHaskellRep' for polymorhpic
-- types, as soon as there is no simple way to preserve type variables when
-- automatically deriving Haskell representation of a type.
concreteTypeDocHaskellRep
  :: forall a b.
     ( Typeable a, GenericIsoValue a, GTypeHasDoc (G.Rep a)
     , HaveCommonTypeCtor b a
     )
  => TypeDocHaskellRep b
concreteTypeDocHaskellRep = concreteTypeDocHaskellRepUnsafe @a

-- | Version of 'concreteTypeDocHaskellRep' which does not ensure
-- whether the type for which representation is built is any similar to
-- the original type which you implement a 'TypeHasDoc' instance for.
concreteTypeDocHaskellRepUnsafe
  :: forall a b.
     ( Typeable a, GenericIsoValue a, GTypeHasDoc (G.Rep a)
     )
  => TypeDocHaskellRep b
concreteTypeDocHaskellRepUnsafe _ descr = Just
  ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)
  , gTypeDocHaskellRep @(G.Rep a) descr
  )

-- | Erase fields from Haskell datatype representation.
--
-- Use this when rendering fields names is undesired.
haskellRepNoFields :: TypeDocHaskellRep a -> TypeDocHaskellRep a
haskellRepNoFields mkRep =
  \p descr -> second (mapADTRepFields (const Nothing)) <$> mkRep p descr

-- | Add field name for @newtype@.
--
-- Since @newtype@ field is automatically erased. Use this function
-- to add the desired field name.
haskellAddNewtypeField :: Text -> TypeDocHaskellRep a -> TypeDocHaskellRep a
haskellAddNewtypeField fieldName mkRep =
  \p descr -> second (mapADTRepFields (const (Just fieldName))) <$> mkRep p descr

-- | Cut fields prefixes which we use according to the style guide.
--
-- E.g. @cmMyField@ field will be transformed to @myField@.
haskellRepStripFieldPrefix
  :: HasCallStack
  => TypeDocHaskellRep a -> TypeDocHaskellRep a
haskellRepStripFieldPrefix mkRep =
  \p descr -> second (mapADTRepFields (fmap stripPrefix)) <$> mkRep p descr
  where
    stripPrefix fieldName =
      case T.uncons $ T.dropWhile isLower fieldName of
        Nothing -> error $ "Field '" <> fieldName <> "' has no prefix"
        Just (c, cs) ->
          -- For fields like @ciUSPosition@ we should not lead the first letter
          -- to lower case like @uSPosition@.
          let isAbbreviation = case T.uncons cs of
                Just (c2, _)
                  | isUpper c2 -> True
                  | otherwise -> False
                Nothing -> False
          in T.cons (if isAbbreviation then c else toLower c) cs

-- | Implement 'typeDocMichelsonRep' for homomorphic type.
homomorphicTypeDocMichelsonRep
  :: forall a.
     SingI (ToT a)
  => TypeDocMichelsonRep a
homomorphicTypeDocMichelsonRep _ =
  ( Nothing
  , demote @(ToT a)
  )

-- | Implement 'typeDocMichelsonRep' on example of given concrete type.
--
-- This function exists for the same reason as 'concreteTypeDocHaskellRep'.
concreteTypeDocMichelsonRep
  :: forall a b.
     (Typeable a, SingI (ToT a), HaveCommonTypeCtor b a)
  => TypeDocMichelsonRep b
concreteTypeDocMichelsonRep _ =
  ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)
  , demote @(ToT a)
  )

-- | Version of 'concreteTypeDocHaskellRepUnsafe' which does not ensure
-- whether the type for which representation is built is any similar to
-- the original type which you implement a 'TypeHasDoc' instance for.
concreteTypeDocMichelsonRepUnsafe
  :: forall a b.
     (Typeable a, SingI (ToT a))
  => TypeDocMichelsonRep b
concreteTypeDocMichelsonRepUnsafe _ =
  ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)
  , demote @(ToT a)
  )

-- | Generic traversal for automatic deriving of some methods in 'TypeHasDoc'.
class GTypeHasDoc (x :: Kind.Type -> Kind.Type) where
  gTypeDocHaskellRep :: FieldDescriptionsV -> ADTRep SomeTypeWithDoc

instance GTypeHasDoc x => GTypeHasDoc (G.D1 ('G.MetaData _a _b _c 'False) x) where
  gTypeDocHaskellRep = gTypeDocHaskellRep @x

instance GTypeHasDoc x => GTypeHasDoc (G.D1 ('G.MetaData _a _b _c 'True) x) where
  gTypeDocHaskellRep descr =
    mapADTRepFields (const Nothing) $ gTypeDocHaskellRep @x descr

instance (GTypeHasDoc x, GTypeHasDoc y) => GTypeHasDoc (x :+: y) where
  gTypeDocHaskellRep descr = gTypeDocHaskellRep @x descr <> gTypeDocHaskellRep @y descr

instance (GProductHasDoc x, KnownSymbol ctor) =>
         GTypeHasDoc (G.C1 ('G.MetaCons ctor _1 _2) x) where
  gTypeDocHaskellRep descr = one $ ConstructorRep
    { crName = conName
    , crDescription = descr ^? to (lookup conName) . _Just . _1 . _Just
    , crFields = gProductDocHaskellRep @x $ descr ^. to (lookup conName) . _Just . _2
    }
    where
      conName = toText $ symbolVal (Proxy @ctor)

instance TypeError ('Text "Cannot derive documentation for void-like type") =>
    GTypeHasDoc G.V1 where
  gTypeDocHaskellRep = error "impossible"

-- | Product type traversal for 'TypeHasDoc'.
class GProductHasDoc (x :: Kind.Type -> Kind.Type) where
  gProductDocHaskellRep :: [(Text, Text)] -> [FieldRep SomeTypeWithDoc]

instance (GProductHasDoc x, GProductHasDoc y) => GProductHasDoc (x :*: y) where
  gProductDocHaskellRep descr = gProductDocHaskellRep @x descr <> gProductDocHaskellRep @y descr

instance TypeHasDoc a =>
         GProductHasDoc (G.S1 ('G.MetaSel 'Nothing _1 _2 _3) (G.Rec0 a)) where
  gProductDocHaskellRep _ = one $ FieldRep
    { frName = Nothing
    , frDescription = Nothing
    , frTypeRep = SomeTypeWithDoc (Proxy @a)
    }

instance (TypeHasDoc a, KnownSymbol field) =>
         GProductHasDoc (G.S1 ('G.MetaSel ('Just field) _1 _2 _3) (G.Rec0 a)) where
  gProductDocHaskellRep descr = one $ FieldRep
    { frName = Just fieldName
    , frDescription = descr ^? to (lookup fieldName) . _Just
    , frTypeRep = SomeTypeWithDoc (Proxy @a)
    }
    where
      fieldName = toText (symbolVal $ Proxy @field)

instance GProductHasDoc G.U1 where
  gProductDocHaskellRep = mempty

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

-- | Constraint, required when deriving 'TypeHasDoc' for polymorphic type
-- with the least possible number of methods defined manually.
type PolyTypeHasDocC ts = Each '[TypeHasDoc] ts

-- | Version of 'PolyTypeHasDocC' for comparable types.
type PolyCTypeHasDocC ts = Each '[TypeHasDoc] ts

instance TypeHasDoc Integer where
  typeDocName _ = "Integer"
  typeDocMdDescription = "Signed number."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc Natural where
  typeDocName _ = "Natural"
  typeDocMdDescription = "Unsigned number."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc MText where
  typeDocName _ = "Text"
  typeDocMdReference p = customTypeDocMdReference ("Text", DType p) []
  typeDocMdDescription =
    "Michelson string.\n\n\
    \This has to contain only ASCII characters with codes from [32; 126] range; \
    \additionally, newline feed character is allowed."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc Bool where
  typeDocName _ = "Bool"
  typeDocMdDescription = "Bool primitive."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc ByteString where
  typeDocName _ = "ByteString"
  typeDocMdDescription = "Bytes primitive."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc Mutez where
  typeDocName _ = "Mutez"
  typeDocMdDescription = "Mutez primitive."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc KeyHash where
  typeDocName _ = "KeyHash"
  typeDocMdDescription = "KeyHash primitive."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc Timestamp where
  typeDocName _ = "Timestamp"
  typeDocMdDescription = "Timestamp primitive."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc Address where
  typeDocName _ = "Address"
  typeDocMdDescription = [md|
    Address primitive.

    Unlike Michelson's `address`, it is assumed not to contain an entrypoint name,
    even if it refers to a contract; this won't be checked, so passing an entrypoint
    name may result in unexpected errors.
    |]
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc EpAddress where
  typeDocName _ = "EntrypointAddress"
  typeDocMdDescription = [md|
    Address primitive.

    This exactly matches the Michelson's `address`, and can refer to a specific entrypoint.
    |]
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc PublicKey where
  typeDocName _ = "PublicKey"
  typeDocMdDescription = "PublicKey primitive."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc Signature where
  typeDocName _ = "Signature"
  typeDocMdDescription = "Signature primitive."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc ChainId where
  typeDocName _ = "ChainId"
  typeDocMdDescription = "Identifier of the current chain."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc () where
  typeDocName _ = "()"
  typeDocMdDescription = "Unit primitive."
  typeDocDependencies _ = []

instance PolyTypeHasDocC '[a] => TypeHasDoc [a] where
  typeDocName _ = "List"
  typeDocMdDescription = "List primitive."
  typeDocMdReference _ =
    -- poly1TypeDocMdReference would produce text like @[] Integer@, we want
    -- to replace this @[]@ with @List@.
    customTypeDocMdReference ("List", DType (Proxy @[a])) [DType (Proxy @a)]
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @[Integer]

instance PolyTypeHasDocC '[a] => TypeHasDoc (Maybe a) where
  typeDocMdDescription = "Option primitive."
  typeDocMdReference = poly1TypeDocMdReference
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Maybe Integer)

instance PolyTypeHasDocC [l, r] => TypeHasDoc (Either l r) where
  typeDocMdDescription = "Or primitive."
  typeDocMdReference = poly2TypeDocMdReference
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Either Integer Natural)

instance PolyTypeHasDocC [a, b] => TypeHasDoc (a, b) where
  typeDocName _ = "(a, b)"
  typeDocMdReference _ = tupleTypeDocReference
    [ typeDocMdReference (Proxy @a) (WithinParens False)
    , typeDocMdReference (Proxy @b) (WithinParens False)
    ]
  typeDocMdDescription = "Pair primitive."
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Integer, Natural)

instance PolyCTypeHasDocC '[a] => TypeHasDoc (Set a) where
  typeDocName _ = "Set"
  typeDocMdReference = poly1TypeDocMdReference
  typeDocMdDescription = "Set primitive."
  typeDocDependencies _ = [dTypeDep @a]
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Set Integer)

instance TypeHasDoc Operation where
  typeDocName _ = "Operation"
  typeDocMdReference tp = customTypeDocMdReference ("Operation", DType tp) []
  typeDocMdDescription = "Operation primitive."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep

instance PolyTypeHasDocC '[cp] => TypeHasDoc (ContractRef cp) where
  typeDocName _ = "Contract"
  typeDocMdReference = poly1TypeDocMdReference
  typeDocMdDescription = "Contract primitive with given type of parameter."
  typeDocDependencies _ = [dTypeDep @cp]
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(ContractRef Integer)

instance (PolyCTypeHasDocC '[k], PolyTypeHasDocC '[v], Ord k) =>
         TypeHasDoc (Map k v) where
  typeDocName _ = "Map"
  typeDocMdReference = poly2TypeDocMdReference
  typeDocMdDescription = "Map primitive."
  typeDocDependencies _ =
    [dTypeDep @k, dTypeDep @v]
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Map Integer Natural)

instance (PolyCTypeHasDocC '[k], PolyTypeHasDocC '[v], Ord k) =>
         TypeHasDoc (BigMap k v) where
  typeDocName _ = "BigMap"
  typeDocMdReference = poly2TypeDocMdReference
  typeDocMdDescription = "BigMap primitive."
  typeDocDependencies _ =
    [dTypeDep @k, dTypeDep @v]
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(BigMap Integer Natural)


tupleTypeDocReference :: [Markdown] -> WithinParens -> Markdown
tupleTypeDocReference vs _ = "(" +| mconcat (intersperse ", " $ map build vs) |+ ")"

instance PolyTypeHasDocC [a, b, c] => TypeHasDoc (a, b, c) where
  typeDocName _ = "(a, b, c)"
  typeDocMdReference _ = tupleTypeDocReference
    [ typeDocMdReference (Proxy @a) (WithinParens False)
    , typeDocMdReference (Proxy @b) (WithinParens False)
    , typeDocMdReference (Proxy @c) (WithinParens False)
    ]
  typeDocMdDescription = "Tuple of size 3."
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Integer, Natural, MText)

instance PolyTypeHasDocC [a, b, c, d] => TypeHasDoc (a, b, c, d) where
  typeDocName _ = "(a, b, c, d)"
  typeDocMdReference _ = tupleTypeDocReference
    [ typeDocMdReference (Proxy @a) (WithinParens False)
    , typeDocMdReference (Proxy @b) (WithinParens False)
    , typeDocMdReference (Proxy @c) (WithinParens False)
    , typeDocMdReference (Proxy @d) (WithinParens False)
    ]
  typeDocMdDescription = "Tuple of size 4."
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep =
    -- Starting from tuple of size 4 the exact types should not matter to a reader,
    -- rather the resulting pairs tree.
    concreteTypeDocMichelsonRep @((), (), (), ())

instance PolyTypeHasDocC [a, b, c, d, e] => TypeHasDoc (a, b, c, d, e) where
  typeDocName _ = "(a, b, c, d, e)"
  typeDocMdDescription = "Tuple of size 5."
  typeDocMdReference _ = tupleTypeDocReference
    [ typeDocMdReference (Proxy @a) (WithinParens False)
    , typeDocMdReference (Proxy @b) (WithinParens False)
    , typeDocMdReference (Proxy @c) (WithinParens False)
    , typeDocMdReference (Proxy @d) (WithinParens False)
    , typeDocMdReference (Proxy @e) (WithinParens False)
    ]
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep =
    concreteTypeDocMichelsonRep @((), (), (), (), ())

instance PolyTypeHasDocC [a, b, c, d, e, f] => TypeHasDoc (a, b, c, d, e, f) where
  typeDocName _ = "(a, b, c, d, e, f)"
  typeDocMdReference _ = tupleTypeDocReference
    [ typeDocMdReference (Proxy @a) (WithinParens False)
    , typeDocMdReference (Proxy @b) (WithinParens False)
    , typeDocMdReference (Proxy @c) (WithinParens False)
    , typeDocMdReference (Proxy @d) (WithinParens False)
    , typeDocMdReference (Proxy @e) (WithinParens False)
    , typeDocMdReference (Proxy @f) (WithinParens False)
    ]
  typeDocMdDescription = "Tuple of size 6."
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep =
    concreteTypeDocMichelsonRep @((), (), (), (), (), ())

instance PolyTypeHasDocC [a, b, c, d, e, f, g] => TypeHasDoc (a, b, c, d, e, f, g) where
  typeDocName _ = "(a, b, c, d, e, f, g)"
  typeDocMdReference _ = tupleTypeDocReference
    [ typeDocMdReference (Proxy @a) (WithinParens False)
    , typeDocMdReference (Proxy @b) (WithinParens False)
    , typeDocMdReference (Proxy @c) (WithinParens False)
    , typeDocMdReference (Proxy @d) (WithinParens False)
    , typeDocMdReference (Proxy @e) (WithinParens False)
    , typeDocMdReference (Proxy @f) (WithinParens False)
    , typeDocMdReference (Proxy @g) (WithinParens False)
    ]
  typeDocMdDescription = "Tuple of size 7."
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep =
    concreteTypeDocMichelsonRep @((), (), (), (), (), (), ())


instance ( TypeHasDoc (ApplyNamedFunctor f a)
         , KnownSymbol n
         , SingI (ToT (ApplyNamedFunctor f Integer))
         , Typeable f, Typeable a
         ) =>
         TypeHasDoc (NamedF f a n) where
  typeDocName _ = "Named entry"
  typeDocMdReference _ wp =
    applyWithinParens wp $
    buildFieldName (toText (symbolVal $ Proxy @n)) +| " " +|
    typeDocMdReference (Proxy @(ApplyNamedFunctor f a)) (WithinParens False) |+ ""
  typeDocDependencies _ =
    [ dTypeDep @(ApplyNamedFunctor f a)
    , dTypeDep @Integer
    ]
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep _ = (Just "number: Integer", demote @(ToT (ApplyNamedFunctor f Integer)))
  typeDocMdDescription =
    "Some entries have names for clarity.\n\n\
    \In resulting Michelson names may be mapped to annotations."