{-# LANGUAGE CPP                        #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE EmptyCase                  #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs               #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuantifiedConstraints      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeInType                 #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}

{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- | This module contains code for documenting a set of @persistent@ entity
-- definitions. All the library provides is a means to render a Markdown
-- document with table and column documentation and comments. A further
-- expansion could use the information here to generate PostgreSQL @COMMENT@s on
-- the fields and tables too.
--
-- = Getting Started
--
-- You probably already have a @persistent@ entity definitions somewhere, and
-- they probably look like this:
--
-- @
-- 'share' ['mkPersist' 'sqlSettings'] ['persistUpperCase'|
--   User
--     firstName Text.Text
--     active    Bool
--     deriving Show Eq Read Ord
-- |]
-- @
--
-- The 'persistUpperCase' QuasiQuoter parses the block of text and returns
-- a value of type @['EntityDef']@. We need to get our hands on that
-- definition so we can document it. We'll use the 'mkEntityDefList'
-- function to expose it:
--
-- @
-- 'share'
--   [ 'mkPersist' 'sqlSettings'
--   , 'mkEntityDefList' "entityDefs"
--   ] ['persistUpperCase'|
--   User
--     firstName Text.Text
--     active    Bool
--     deriving Show Eq Read Ord
-- |]
-- @
--
-- You may want to factor out the quasiquoter into a term and import from
-- another module. This has an important downside: the ID fields from the
-- QuasiQuoter are given as 'Int64' regardless of what they actually are.
-- It's not possible for the persistent quasiquoter to properly know the
-- types of the IDs.
--
-- = Documentating The Schema
--
-- Now, we're going to use the 'document' function to link up the
-- @entityDefs@ with a documentation expression (type 'EntityDoc').
--
-- @
-- docs :: ['EntityDef']
-- docs = 'document' entityDefs $ do
--   pure ()
-- @
--
-- The 'EntityDoc' type is a monad, and we'll use @do@ notation to sequence
-- multiple entity definitions.
--
-- @
-- docs :: ['EntityDef']
-- docs = 'document' entityDefs $ do
--   User '--^' do
--     pure ()
-- @
--
-- The '--^' operator mimics the Haddock comment syntax. We use the
-- constructor of the entity (in this case, @User@). On the right, we
-- provide documentation for the entity. The right hand expression will
-- have the type 'FieldDoc', and we can use @do@ notation to construct it.
--
-- We can use string literals to document the entity itself, with the
-- @OverloadedStrings@ extension enabled. The string literals are
-- concatenated, and used to provide entity-level comments. You'll need to
-- manage whitespace yourself, though.
--
-- @
-- docs :: ['EntityDef']
-- docs = 'document' entityDefs $ do
--   User '--^' do
--     "This is user documentation. "
--     "You can have multiple lines, but you need to watch out for spaces. "
--     "The lines will be combined."
-- @
--
-- We can also document the entity fields. We do this using the '#'
-- operator.
--
-- @
-- docs :: ['EntityDef']
-- docs = 'document' entityDefs $ do
--   User '--^' do
--     "This is user documentation. "
--     "You can have multiple lines, but you need to watch out for spaces. "
--     "The lines will be combined."
--
--     UserFirstName '#' "The user's first name."
--     UserActive    '#' "Whether or not the user is able to log in."
-- @
--
-- This attaches the comment to the entity field.
--
-- = Rendering the Documentation
--
-- Finally, we'll use 'render' and provide a 'Renderer' to generate
-- documentation. For an example of what this looks like, check out the
-- file @test/example.md@ in the repository (linked from the README).
--
-- @
-- renderedDocs :: Text
-- renderedDocs = 'render' 'markdownTableRenderer' docs
-- @
module Database.Persist.Documentation
  ( -- * The Documentation DSL
    document
  , (--^)
  , (#)
  , EntityDoc
  , FieldDoc
  , deriveShowFields
    -- * Rendering Documentation
  , Renderer(..)
  , render
  , markdownTableRenderer
  ) where

import           Control.Monad.Writer
import qualified Data.Char                               as Char
import           Data.Foldable                           (fold, toList)
import           Data.Map                                (Map)
import qualified Data.Map                                as Map
import           Data.String
import           Data.Text                               (Text)
import qualified Data.Text                               as Text
import           Data.Typeable
import           Database.Persist.Sql                    hiding (insert)
import           Language.Haskell.TH

import           Data.SemiMap
import           Data.StrMap
import           Database.Persist.Documentation.Internal

#if MIN_VERSION_persistent(2,13,0)
import           Database.Persist.EntityDef.Internal
import           Database.Persist.FieldDef.Internal
import Database.Persist.Quasi.Internal
#endif

-- | This function accepts a list of 'EntityDef' and an 'EntityDoc' block, and
-- substitutes the 'entityComments' and 'fieldComments' from the
-- 'EntityDoc'.
--
-- @since 0.1.0.0
document :: [EntityDef] -> EntityDoc -> [EntityDef]
document entities (ED docs) = fmap associate entities
  where
    schemaDocs = execWriter docs
    typeReps = Map.mapKeys show (unSemiMap schemaDocs)
    associate edef =
      let
        tyStr = Text.unpack . unEntityNameHS . entityHaskell $ edef
       in
        case Map.lookup tyStr typeReps of
          Just (SomeDocs (EntityDocs e cs)) ->
            edef
              { entityComments = Just e
              , entityFields = alignFields (entityFields edef) cs
              , entityId =
#if MIN_VERSION_persistent(2,13,0)
                  case getEntityIdField edef of
                     Nothing ->
                        entityId edef
                     Just field ->
                         -- this is safe because it's a `map`, under the
                         -- hood
                        head $ EntityIdField <$> alignFields [field] cs
#else
                  head $ alignFields [entityId edef] cs
#endif
              }
          Nothing -> edef

-- | A renderer for documented entities, abstract in the intermediate
-- representations of entities and fields.
--
-- @since 0.1.0.0
data Renderer rendered where
  Renderer
    :: { renderField :: FieldDef -> Maybe Text -> renderedField
       -- ^ Render a field definition as some intermediate structure
       , renderFields :: [renderedField] -> renderedFields
       -- ^ Fold a collection of rendered fields
       , renderEntity :: EntityDef -> Maybe Text -> renderedFields -> renderedEntity
       -- ^ Attach some entity-level metadata to a rendered collection of fields
       , renderEntities :: [renderedEntity] -> rendered
       -- ^ Finally, fold a collection of rendered entities
       }
    -> Renderer rendered

-- | Given a 'Renderer' for a list of entity defintiions, render it.
--
-- @since 0.1.0.0
render :: Renderer rendered -> [EntityDef] -> rendered
render Renderer{..} =
  renderEntities . map f
  where
    f ent = renderEntity ent entityDocs renderedFields
      where
        fields = toList $ keyAndEntityFields ent
        entityDocs = entityComments ent
        renderedFields =
          renderFields (map (\f -> renderField f (fieldComments f)) fields)

-- | A 'Renderer' that generates Markdown tables for an entity.
--
-- === __ Example __
--
-- Given 'entityDefs' like:
--
-- @
-- entityDefs :: ['EntityDef']
-- entityDefs = ['persistUpperCase'|
--   User
--     firstName Text.Text
--     active    Bool
--     deriving Show Eq Read Ord
-- |]
-- @
--
-- and a doc block like:
--
-- @
-- docs :: [EntityDef]
-- docs = document entityDefs $ do
--   User --^ do
--     "you can use string literals to write documentation for the entity itself. "
--     "The strings will be mappended together, so you'll need to handle "
--     "whitespace yourself."
--     UserFirstName # "The user's first name."
--     UserActive # "Whether or not the user is able to log in."
--     UserId # "You can document the user's ID field."
-- @
--
-- This will rende the given Markdown output:
--
-- @
-- # `User`
--
-- you can use string literals to write documentation for the entity itself. The strings will be
-- mappended together, so you'll need to handle whitespace yourself.
--
-- * Primary ID: `id`
--
-- | Column name | Type | Description |
-- |-|-|-|
-- | `id` | integer (64) | You can document the user's ID field. |
-- | `firstName` | string | The user's first name. |
-- | `active` | boolean | Whether or not the user is able to log in. |
-- @
--
-- @since 0.1.0.0
markdownTableRenderer :: Renderer Text
markdownTableRenderer = Renderer{..}
  where
   renderField :: FieldDef -> Maybe Text -> Text
   renderField FieldDef{..} mextra =
      fold
        [ "| `"
        , unFieldNameDB fieldDB
        , "` | "
        , showType fieldSqlType
        , " | "
        , foldMap cleanComment mextra
        , " |"
        ]

   renderFields :: [Text] -> Text
   renderFields xs =
     Text.unlines $
         "| Column name | Type | Description |"
       : "|-|-|-|"
       : xs

   renderEntity :: EntityDef -> Maybe Text -> Text -> Text
   renderEntity ed@EntityDef{..} mdocs fields =
     Text.unlines (concat
       [ pure $ "# `" <> unEntityNameDB entityDB <> "`"
       , pure $ case mdocs of
           Just entityDocs -> "\n" <> entityDocs <> "\n"
           Nothing         -> ""
       ,
#if MIN_VERSION_persistent(2,13,0)
         case getEntityIdField ed of
           Nothing ->
               []
           Just field ->
               pure $ "* Primary ID: `" <> unFieldNameDB (fieldDB field) <> "`"
#else
         pure $ "* Primary ID: `" <> unFieldNameDB (fieldDB entityId) <> "`"
#endif
       , pure ""
       ])
     <> fields

   renderEntities :: [Text] -> Text
   renderEntities =
     Text.unlines

   showType SqlString    = "string"
   showType SqlInt32     = "integer (32)"
   showType SqlInt64     = "integer (64)"
   showType SqlReal      = "double"
   showType SqlNumeric{} = "numeric"
   showType SqlDay       = "date"
   showType SqlTime      = "time"
   showType SqlDayTime   = "datetime"
   showType SqlBlob      = "blob"
   showType SqlBool      = "boolean"
   showType (SqlOther t) = t
   
   cleanComment :: Text -> Text
   cleanComment comment =
     let
       -- Newline characters may be present in a comment. The need to be removed
       -- to allow the markdown tables to render properly.
       newlineToBr '\n' = "<br>"
       newlineToBr c = Text.singleton c
     in
       Text.concatMap newlineToBr $ Text.strip comment

-- | Render the '[EntityDef]' into a Markdown table representation. See
-- 'markdownTable
--
-- @since 0.1.0.0
toMarkdownTables :: [EntityDef] -> Text
toMarkdownTables = render markdownTableRenderer

-- | Formats the @'SomeField' rec@ in the keys of the 'Map' to be formatted in
-- the same way as the 'HaskellName' present in a 'FieldDef'.
--
-- @since 0.1.0.0
asHaskellNames
  :: forall rec. RC rec
  => StrMap (SomeField rec) Text -> Map Text Text
asHaskellNames (StrMap extraDocMap) =
  Map.mapKeys (lowercaseFirstChar . Text.drop (length recName) . asStrText) extraDocMap
  where
    recName =
      show (typeRep (Proxy @rec))

-- | Given a list of entity definitions, derives `Show` for all their fields.
-- This is necessary for using this library for internal reasons, unfortunately.
--
-- @since 0.1.0.0
deriveShowFields
#if MIN_VERSION_persistent(2,13,0)
    :: [UnboundEntityDef]
#else
    :: [EntityDef]
#endif
    -> Q [Dec]
deriveShowFields defs = fmap join . forM defs $ \def -> do
  let name = conT . mkName . Text.unpack . unEntityNameHS . unname $ def
  [d|deriving instance Show (EntityField $(name) x)|]
  where
    unname =
#if MIN_VERSION_persistent(2,13,0)
      getUnboundEntityNameHS
#else
      entityHaskell
#endif