{-# 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 #-}
module Database.Persist.Documentation.Internal where
import Control.Monad.Writer
import qualified Data.Char as Char
import Data.Foldable (fold)
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.StrMap
import Data.SemiMap
alignFields
:: forall rec. RC rec
=> [FieldDef] -> StrMap (SomeField rec) Text -> [FieldDef]
alignFields fields strMap =
map findFieldDoc fields
where
findFieldDoc fld@FieldDef{..} =
case Map.lookup (nameAsText fieldHaskell) haskellNames of
Nothing -> fld
Just c -> fld { fieldComments = Just c }
haskellNames = asHaskellNames strMap
nameAsText = lowercaseFirstChar . unHaskellName
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))
newtype EntityDoc' a = ED (Writer SchemaDocs a)
deriving (Functor, Applicative, Monad, MonadWriter SchemaDocs)
type SchemaDocs = SemiMap TypeRep SomeDocs
data SomeDocs where
SomeDocs :: RC rec => EntityDocs rec -> SomeDocs
instance Semigroup SomeDocs where
SomeDocs (r0 :: EntityDocs r0) <> SomeDocs (r1 :: EntityDocs r1) =
case eqT @r0 @r1 of
Just Refl -> SomeDocs (r0 <> r1)
Nothing -> SomeDocs r0
type RC rec = (Typeable rec)
data EntityDocs rec = EntityDocs
{ entityDocumentation :: Text
, fieldDocumentation :: StrMap (SomeField rec) Text
}
instance Semigroup (EntityDocs rec) where
EntityDocs d0 f0 <> EntityDocs d1 f1 = EntityDocs (d0 <> d1) (f0 <> f1)
instance Monoid (EntityDocs rec) where
mempty = EntityDocs mempty mempty
type EntityDoc = EntityDoc' ()
type FieldDoc s = FieldDoc' s ()
data SomeField rec where
SomeField :: FC rec typ => EntityField rec typ -> SomeField rec
instance (forall typ. Show (EntityField rec typ)) => Show (SomeField rec) where
show (SomeField fld) = show fld
type FC rec typ = forall x. Show (EntityField rec x)
newtype FieldDoc' rec a = FD (Writer (EntityDocs rec) a)
deriving (Functor, Applicative, Monad, MonadWriter (EntityDocs rec))
single
:: FC rec typ
=> EntityField rec typ -> Text -> StrMap (SomeField rec) Text
single k t = insert (SomeField k) t mempty
type family KnowResult a where
KnowResult (i -> o) = KnowResult o
KnowResult a = a
instance (a ~ ()) => IsString (FieldDoc' s a) where
fromString str = tell mempty { entityDocumentation = Text.pack str }
lowercaseFirstChar :: Text -> Text
lowercaseFirstChar txt = case Text.uncons txt of
Just (c, r) -> Char.toLower c `Text.cons` r
Nothing -> ""
(--^)
:: forall a r. (KnowResult a ~ r, Typeable r, RC r)
=> a
-> FieldDoc r
-> EntityDoc
_ --^ FD fieldDocs =
tell
. SemiMap
$ Map.singleton
(typeRep (Proxy @r))
(SomeDocs (execWriter fieldDocs))
(#) :: FC rec typ => EntityField rec typ -> Text -> FieldDoc rec
field # txt = tell mempty { fieldDocumentation = insert (SomeField field) txt mempty }