-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

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

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

  , HaveCommonTypeCtor
  , IsHomomorphic
  , genericTypeDocDependencies
  , customTypeDocMdReference
  , customTypeDocMdReference'
  , homomorphicTypeDocMdReference
  , poly1TypeDocMdReference
  , poly2TypeDocMdReference
  , homomorphicTypeDocHaskellRep
  , concreteTypeDocHaskellRep
  , unsafeConcreteTypeDocHaskellRep
  , haskellAddNewtypeField
  , haskellRepNoFields
  , haskellRepMap
  , haskellRepAdjust
  , homomorphicTypeDocMichelsonRep
  , concreteTypeDocMichelsonRep
  , unsafeConcreteTypeDocMichelsonRep

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

import Control.Lens (_Just, each, to)
import Data.List (lookup)
import Data.Singletons (SingI, demote)
import Data.Typeable (typeRep, typeRepArgs)
import Fmt (Buildable, Doc, build, singleLineF, (+|), (|+))
import GHC.Generics ((:*:)(..), (:+:)(..))
import GHC.Generics qualified as G
import GHC.TypeLits (ErrorMessage(..), KnownSymbol, TypeError, symbolVal)
import Morley.Util.ShowType (Showtype(..))

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

{- $setup
>>> import Morley.Michelson.Typed
-}

-- | 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 = [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
  [] -> mdItalic "no values"
  [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

-- | Show type, wrapping into parentheses if necessary.
buildTypeWithinParens :: forall a. Typeable a => WithinParens -> Markdown
buildTypeWithinParens wp =
  let rep = typeRep (Proxy @a)
      wrap = if null (typeRepArgs rep) then id else applyWithinParens wp
  in wrap $ build @Text $ show rep

-- | Field naming strategy used by a type. 'id' by default.
--
-- Some common options include:
-- > typeFieldNamingStrategy = stripFieldPrefix
-- > typeFieldNamingStrategy = toSnake . dropPrefix
--
-- This is used by the default implementation of 'typeDocHaskellRep' and
-- intended to be reused downstream.
--
-- You can also use @DerivingVia@ together with 'FieldCamelCase' and
-- 'FieldSnakeCase' to easily define instances of this class:
--
-- > data MyType = ... deriving TypeHasFieldNamingStrategy via FieldCamelCase
class TypeHasFieldNamingStrategy a where
  typeFieldNamingStrategy :: Text -> Text
  typeFieldNamingStrategy = id

instance {-# OVERLAPPABLE #-} TypeHasFieldNamingStrategy a

-- | Empty datatype used as marker for @DerivingVia@ with
-- 'TypeHasFieldNamingStrategy'.
--
-- Uses 'stripFieldPrefix' strategy.
data FieldCamelCase

instance TypeHasFieldNamingStrategy FieldCamelCase where
  typeFieldNamingStrategy = stripFieldPrefix

-- | Empty datatype used as marker for @DerivingVia@ with
-- 'TypeHasFieldNamingStrategy'.
--
-- Uses @'toSnake' . 'dropPrefix'@ strategy.
data FieldSnakeCase

instance TypeHasFieldNamingStrategy FieldSnakeCase where
  typeFieldNamingStrategy = toSnake . dropPrefix

{- | Description for a Haskell type appearing in documentation.

Generic-deriving instance produces a custom error when 'Generic' is missing:

>>> data Foo = Foo () deriving TypeHasDoc
...
... GHC.Generics.Rep Foo
... is stuck. Likely
... Generic Foo
... instance is missing or out of scope.
...

>>> data Foo = Foo () deriving Generic
>>> instance TypeHasDoc Foo where typeDocMdDescription = "Foo"
...
... No instance for (IsoValue Foo)
...

>>> data Foo = Foo () deriving (Generic, IsoValue)
>>> instance TypeHasDoc Foo where typeDocMdDescription = "Foo"

-}
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 (GRep 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 polymorphic types consider using 'concreteTypeDocHaskellRep' as implementation.
  --
  -- Modifier 'haskellRepNoFields' can be used to hide names of fields,
  -- beneficial for newtypes.
  --
  -- Use 'haskellRepAdjust' or 'haskellRepMap' for more involved adjustments.
  --
  -- Also, consider defining an instance of 'TypeHasFieldNamingStrategy' instead
  -- of defining this method -- the former can be used downstream, e.g. in
  -- lorentz, for better naming consistency.
  typeDocHaskellRep :: TypeDocHaskellRep a
  default typeDocHaskellRep
    :: (Generic a, GTypeHasDoc (GRep a), IsHomomorphic a, TypeHasFieldNamingStrategy a)
    => TypeDocHaskellRep a
  typeDocHaskellRep = haskellRepMap (typeFieldNamingStrategy @a) 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 _ = '[]

  -- | Final michelson representation of a type.
  --
  -- For homomorphic types use 'homomorphicTypeDocMichelsonRep' implementation.
  --
  -- For polymorphic types consider using 'concreteTypeDocMichelsonRep' as implementation.
  typeDocMichelsonRep :: TypeDocMichelsonRep a
  default typeDocMichelsonRep
    :: (KnownIsoT 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 polymorphic 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 polymorphic 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 polymorphic 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 polymorphic 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 Buildable DType where
  build (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 $
        typeDocBuiltMichelsonRep (Proxy @a) <> "\n\n"
    ]

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

{- | Fully render Michelson representation of a type.

Since this will be used in markdown, the type is forced to a single line.

>>> data Foo = Foo () () () () () () () () () () () () deriving (Generic, IsoValue)
>>> instance TypeHasDoc Foo where typeDocMdDescription = "Foo type"
>>> typeDocBuiltMichelsonRep $ Proxy @Foo
**Final Michelson representation:** `pair (pair (pair unit unit unit) unit unit unit) (pair unit unit unit) unit unit unit`
-}
typeDocBuiltMichelsonRep :: TypeHasDoc a => Proxy a -> Doc
typeDocBuiltMichelsonRep ap' =
  let (mlhs, rep) = typeDocMichelsonRep ap'
      renderedRep = mdTicked $ singleLineF rep
  in case mlhs of
        Nothing ->
          mdSubsection "Final Michelson representation"
          renderedRep
        Just lhs ->
          mdSubsection "Final Michelson representation (example)" $
          mdTicked (build lhs) <> " = " <> renderedRep

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

-- | Proxy version of 'dTypeDep'.
dTypeDepP
  :: forall (t :: 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 @HaveCommonTypeCtor (Maybe Integer) [Integer]@ is not.
type HaveCommonTypeCtor :: forall {k}. k -> k -> Constraint
type family HaveCommonTypeCtor a b where
  HaveCommonTypeCtor (ac _) (bc _) = HaveCommonTypeCtor ac bc
  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 tyInfo typeArgsDoc =
  customTypeDocMdReference'
    tyInfo
    (typeArgsDoc <&> \(DType di) -> typeDocMdReference di)

-- | More generic version of 'customTypeDocMdReference', it accepts
-- arguments not as types with doc, but printers for them.
customTypeDocMdReference'
  :: (Text, DType)
  -> [WithinParens -> Markdown]
  -> WithinParens
  -> Markdown
customTypeDocMdReference' (typeCtorName, tyDoc) typeArgsPrinters wp =
  let DocItemRef ctorDocItemId = docItemRef tyDoc
  in applyWithinParens wpSmart $
     mconcat . intersperse " " $
      ( mdLocalRef (mdTicked $ build typeCtorName) ctorDocItemId
      : (typeArgsPrinters <&> \printer -> printer (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 typeArgsPrinters))

-- | Derive 'typeDocMdReference', for homomorphic types only.
homomorphicTypeDocMdReference
  :: forall (t :: 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 :: Type) (a :: 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 :: Type) (a :: Type) (b :: 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.

Produces a custom error message for missing 'Generic' instances:

>>> data Foo = Foo ()
>>> length $ genericTypeDocDependencies $ Proxy @Foo
...
... GHC.Generics.Rep Foo
... is stuck. Likely
... Generic Foo
... instance is missing or out of scope.
...

>>> data Foo = Foo () deriving Generic
>>> length $ genericTypeDocDependencies $ Proxy @Foo
1

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 (GRep a))
  => Proxy a -> [SomeDocDefinitionItem]
genericTypeDocDependencies _ = do
  ConstructorRep{..} <- toList $ gTypeDocHaskellRep @(GRep 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 polymorphic types which, for documentation
purposes, we want to consider homomorphic.

Example: 'Operation' is in fact polymorphic, but we don't want this fact to
be reflected in the documentation.

Produces a custom error message for missing 'Generic' instances:

>>> data Foo = Foo ()
>>> isJust $ homomorphicTypeDocHaskellRep (Proxy @Foo) []
...
... GHC.Generics.Rep Foo
... is stuck. Likely
... Generic Foo
... instance is missing or out of scope.
...

>>> data Foo = Foo () deriving Generic
>>> isJust $ homomorphicTypeDocHaskellRep (Proxy @Foo) []
True
-}
homomorphicTypeDocHaskellRep
  :: forall a.
     (Generic a, GTypeHasDoc (GRep a))
  => TypeDocHaskellRep a
homomorphicTypeDocHaskellRep _ descr = Just
  ( Nothing
  , gTypeDocHaskellRep @(GRep a) descr
  )

{- | Implement 'typeDocHaskellRep' on example of given concrete type.

This is a best effort attempt to implement 'typeDocHaskellRep' for polymorphic
types, as soon as there is no simple way to preserve type variables when
automatically deriving Haskell representation of a type.

Produces a custom error message for missing 'Generic' instances:

>>> data Foo a = Foo a
>>> isJust $ concreteTypeDocHaskellRep @(Foo Integer) @(Foo ()) Proxy []
...
... GHC.Generics.Rep (Foo Integer)
... is stuck. Likely
... Generic (Foo Integer)
... instance is missing or out of scope.
...

>>> data Foo a = Foo a deriving (Generic, IsoValue)
>>> isJust $ concreteTypeDocHaskellRep @(Foo Integer) @(Foo ()) Proxy []
True
-}
concreteTypeDocHaskellRep
  :: forall a b.
     ( Typeable a, GenericIsoValue a, GTypeHasDoc (GRep a)
     , HaveCommonTypeCtor b a
     )
  => TypeDocHaskellRep b
concreteTypeDocHaskellRep = unsafeConcreteTypeDocHaskellRep @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.

>>> data Foo = Foo ()
>>> isJust $ unsafeConcreteTypeDocHaskellRep @Foo @() Proxy []
...
... GHC.Generics.Rep Foo
... is stuck. Likely
... Generic Foo
... instance is missing or out of scope.
...

>>> data Foo = Foo () deriving (Generic, IsoValue)
>>> isJust $ unsafeConcreteTypeDocHaskellRep @Foo @() Proxy []
True

-}
unsafeConcreteTypeDocHaskellRep
  :: forall a b.
     ( Typeable a, GenericIsoValue a, GTypeHasDoc (GRep a)
     )
  => TypeDocHaskellRep b
unsafeConcreteTypeDocHaskellRep _ descr = Just
  ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)
    -- ↑ this also shows kinds when poly-kinded type arguments are present,
    -- but there seems to be no simple way to deal with this.
  , gTypeDocHaskellRep @(GRep a) descr
  )

-- | Erase fields from Haskell datatype representation.
--
-- Use this when rendering fields names is undesired.
haskellRepNoFields :: TypeDocHaskellRep a -> TypeDocHaskellRep a
haskellRepNoFields = haskellRepAdjust (const Nothing)

-- | Like 'haskellRepAdjust', but can't add or remove field names.
haskellRepMap :: (Text -> Text) -> TypeDocHaskellRep a -> TypeDocHaskellRep a
haskellRepMap = haskellRepAdjust . fmap

-- | 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 = haskellRepAdjust $ const $ Just fieldName

-- | Adjust field names using a function. Can add or remove field names.
haskellRepAdjust :: (Maybe Text -> Maybe Text) -> TypeDocHaskellRep a -> TypeDocHaskellRep a
haskellRepAdjust = fmap . fmap . fmap . fmap . mapADTRepFields
-- This is ridiculous, but we really do need to map over a functor 4 levels
-- deep. This will be less confusing if you look at 'TypeDocHaskellRep'
-- definition above. In a previous iteration of this function, we had a lambda,
-- 'second', 'fmap' and '<$>' all mixed together, and it was even less clear
-- what's going on. -- @lierdakil

-- | Implement 'typeDocMichelsonRep' for homomorphic type.
homomorphicTypeDocMichelsonRep
  :: forall a.
     KnownIsoT 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, KnownIsoT a, HaveCommonTypeCtor b a)
  => TypeDocMichelsonRep b
concreteTypeDocMichelsonRep _ =
  ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)
  , demote @(ToT a)
  )

-- | Version of 'unsafeConcreteTypeDocHaskellRep' 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.
unsafeConcreteTypeDocMichelsonRep
  :: forall a b.
     (Typeable a, KnownIsoT a)
  => TypeDocMichelsonRep b
unsafeConcreteTypeDocMichelsonRep _ =
  ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)
  , demote @(ToT a)
  )

-- | Generic traversal for automatic deriving of some methods in 'TypeHasDoc'.
class GTypeHasDoc (x :: Type -> 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 GTypeHasDoc G.V1 where
  gTypeDocHaskellRep _ = []

-- | Product type traversal for 'TypeHasDoc'.
class GProductHasDoc (x :: Type -> 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
  typeDocMichelsonRep _ = (Nothing, TKeyHash)
  typeDocMdReference tp _ =
    customTypeDocMdReference
      (typeDocName tp, DType tp)
      []
      (WithinParens False)

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
  typeDocMichelsonRep _ = (Nothing, TKeyHash)
  typeDocMdReference tp _ =
    customTypeDocMdReference
      (typeDocName tp, DType tp)
      []
      (WithinParens False)

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 _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc Chest where
  typeDocName _ = "Chest"
  typeDocMdDescription = "Timelock puzzle chest."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

instance TypeHasDoc ChestKey where
  typeDocName _ = "ChestKey"
  typeDocMdDescription = "Timelock puzzle chest key."
  typeDocDependencies _ = []
  typeDocHaskellRep _ _ = Nothing

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, dTypeDep @Integer]
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(ContractRef Integer)

instance PolyTypeHasDocC '[a] => TypeHasDoc (Ticket a) where
  typeDocName _ = "Ticket"
  typeDocMdReference = poly1TypeDocMdReference
  typeDocMdDescription = "Ticket primitive."
  typeDocDependencies _ = [dTypeDep @a, dTypeDep @MText]
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Ticket MText)

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
         , KnownIsoT (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."