module Database.PostgreSQL.Query.TH.Entity
  ( EntityOptions(..)
  , deriveEntity
  ) where

import Data.Default
import Database.PostgreSQL.Query.Entity.Class
import Database.PostgreSQL.Query.Import
import Database.PostgreSQL.Query.TH.Common
import Database.PostgreSQL.Query.Types ( FN(..), textFN )
import Database.PostgreSQL.Simple.FromField
import Database.PostgreSQL.Simple.ToField
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Text.Inflections

import qualified Data.Text as T

-- | Options for deriving `Entity`
data EntityOptions = EntityOptions
    { EntityOptions -> Text -> FN
eoTableName      :: Text -> FN -- ^ Type name to table name converter
    , EntityOptions -> Text -> FN
eoColumnNames    :: Text -> FN -- ^ Record field to column name converter
    , EntityOptions -> [Name]
eoDeriveClasses  :: [Name]     -- ^ Typeclasses to derive for Id
    , EntityOptions -> Name
eoIdType         :: Name       -- ^ Base type for Id
    } deriving ((forall x. EntityOptions -> Rep EntityOptions x)
-> (forall x. Rep EntityOptions x -> EntityOptions)
-> Generic EntityOptions
forall x. Rep EntityOptions x -> EntityOptions
forall x. EntityOptions -> Rep EntityOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EntityOptions x -> EntityOptions
$cfrom :: forall x. EntityOptions -> Rep EntityOptions x
Generic)

#if !MIN_VERSION_inflections(0,3,0)
toUnderscore' :: Text -> Text
toUnderscore' = T.pack . toUnderscore . T.unpack
#else
toUnderscore' :: Text -> Text
toUnderscore' :: Text -> Text
toUnderscore' = (ParseErrorBundle Text Void -> Text)
-> (Text -> Text)
-> Either (ParseErrorBundle Text Void) Text
-> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseErrorBundle Text Void -> Text
forall a a. Show a => a -> a
error' Text -> Text
forall a. a -> a
id (Either (ParseErrorBundle Text Void) Text -> Text)
-> (Text -> Either (ParseErrorBundle Text Void) Text)
-> Text
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either (ParseErrorBundle Text Void) Text
toUnderscore
  where
    error' :: a -> a
error' a
er = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"toUnderscore: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
er
#endif

instance Default EntityOptions where
  def :: EntityOptions
def = EntityOptions :: (Text -> FN) -> (Text -> FN) -> [Name] -> Name -> EntityOptions
EntityOptions
        { eoTableName :: Text -> FN
eoTableName     = Text -> FN
textFN (Text -> FN) -> (Text -> Text) -> Text -> FN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toUnderscore'
        , eoColumnNames :: Text -> FN
eoColumnNames   = Text -> FN
textFN (Text -> FN) -> (Text -> Text) -> Text -> FN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toUnderscore'
        , eoDeriveClasses :: [Name]
eoDeriveClasses = [ ''Ord, ''Eq, ''Show
                            , ''FromField, ''ToField ]
        , eoIdType :: Name
eoIdType        = ''Integer
        }

{- | Derives instance for 'Entity' using type name and field names. Also
generates type synonim for ID. E.g. code like this:

@
data Agent = Agent
    { aName          :: !Text
    , aAttributes    :: !HStoreMap
    , aLongWeirdName :: !Int
    } deriving (Ord, Eq, Show)

$(deriveEntity
  def { eoIdType        = ''Id
      , eoTableName     = textFN . toUnderscore'
      , eoColumnNames   = textFN . toUnderscore' . drop 1
      , eoDeriveClasses =
        [''Show, ''Read, ''Ord, ''Eq
        , ''FromField, ''ToField, ''PathPiece]
      }
  ''Agent )
@

Will generate code like this:

@
instance Database.PostgreSQL.Query.Entity Agent where
    newtype EntityId Agent
        = AgentId {getAgentId :: Id}
        deriving (Show, Read, Ord, Eq, FromField, ToField, PathPiece)
    tableName _ = "agent"
    fieldNames _ = ["name", "attributes", "long_weird_name"]
type AgentId = EntityId Agent
@

So, you dont need to write it by hands any more.

NOTE: 'toUnderscore' is from package 'inflections' here
-}

deriveEntity :: EntityOptions -> Name -> Q [Dec]
deriveEntity :: EntityOptions -> Name -> Q [Dec]
deriveEntity EntityOptions
opts Name
tname = do
    Con
tcon <- Info -> [Con]
dataConstructors (Info -> [Con]) -> Q Info -> Q [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
tname Q [Con] -> ([Con] -> Q Con) -> Q Con
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [Con
a] -> Con -> Q Con
forall (m :: * -> *) a. Monad m => a -> m a
return Con
a
      [Con]
x -> [Char] -> Q Con
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Con) -> [Char] -> Q Con
forall a b. (a -> b) -> a -> b
$ [Char]
"expected exactly 1 data constructor, but " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
x) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" got"
    Type
econt <- [t|Entity $(conT tname)|]
    Type
eidcont <- [t|EntityId $(conT tname)|]
    ConT Name
entityIdName <- [t|EntityId|]
    let tnames :: [Char]
tnames = Name -> [Char]
nameBase Name
tname
        idname :: [Char]
idname = [Char]
tnames [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Id"
        unidname :: [Char]
unidname = [Char]
"get" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
idname
        idtype :: Type
idtype = Name -> Type
ConT (EntityOptions -> Name
eoIdType EntityOptions
opts)
#if MIN_VERSION_template_haskell(2,15,0)
        idcon :: Con
idcon = Name -> [VarBangType] -> Con
RecC ([Char] -> Name
mkName [Char]
idname)
                [([Char] -> Name
mkName [Char]
unidname, SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
idtype)]
        iddec :: Dec
iddec = Cxt
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD [] Maybe [TyVarBndr]
forall a. Maybe a
Nothing Type
eidcont Maybe Type
forall a. Maybe a
Nothing
                Con
idcon [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
ConT ([Name] -> Cxt) -> [Name] -> Cxt
forall a b. (a -> b) -> a -> b
$ EntityOptions -> [Name]
eoDeriveClasses EntityOptions
opts)]
#elif MIN_VERSION_template_haskell(2,12,0)
        idcon = RecC (mkName idname)
                [(mkName unidname, Bang NoSourceUnpackedness NoSourceStrictness, idtype)]
        iddec = NewtypeInstD [] entityIdName [ConT tname] Nothing
                idcon [DerivClause Nothing (map ConT $ eoDeriveClasses opts)]
#elif MIN_VERSION_template_haskell(2,11,0)
        idcon = RecC (mkName idname)
                [(mkName unidname, Bang NoSourceUnpackedness NoSourceStrictness, idtype)]
        iddec = NewtypeInstD [] entityIdName [ConT tname] Nothing
                idcon (map ConT $ eoDeriveClasses opts)
#else
        idcon = RecC (mkName idname)
                [(mkName unidname, NotStrict, idtype)]
        iddec = NewtypeInstD [] entityIdName [ConT tname]
                idcon (eoDeriveClasses opts)
#endif
        tblName :: FN
tblName = EntityOptions -> Text -> FN
eoTableName EntityOptions
opts (Text -> FN) -> Text -> FN
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
tnames
        fldNames :: [FN]
fldNames = (Name -> FN) -> [Name] -> [FN]
forall a b. (a -> b) -> [a] -> [b]
map (EntityOptions -> Text -> FN
eoColumnNames EntityOptions
opts (Text -> FN) -> (Name -> Text) -> Name -> FN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Text) -> (Name -> [Char]) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase)
                   ([Name] -> [FN]) -> [Name] -> [FN]
forall a b. (a -> b) -> a -> b
$ Con -> [Name]
cFieldNames Con
tcon
    VarE Name
ntableName  <- [e|tableName|]
    VarE Name
nfieldNames <- [e|fieldNames|]
    Exp
tblExp <- FN -> Q Exp
forall t. Lift t => t -> Q Exp
lift (FN
tblName :: FN)
    [Exp]
fldExp <- (FN -> Q Exp) -> [FN] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FN -> Q Exp
forall t. Lift t => t -> Q Exp
lift ([FN]
fldNames :: [FN])
    let tbldec :: Dec
tbldec = Name -> [Clause] -> Dec
FunD Name
ntableName  [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB Exp
tblExp) []]
        flddec :: Dec
flddec = Name -> [Clause] -> Dec
FunD Name
nfieldNames [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE [Exp]
fldExp) []]
#if MIN_VERSION_template_haskell(2,11,0)
        ret :: Dec
ret = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
econt [ Dec
iddec, Dec
tbldec, Dec
flddec ]
#else
        ret = InstanceD [] econt [ iddec, tbldec, flddec ]
#endif
        syndec :: Dec
syndec = Name -> [TyVarBndr] -> Type -> Dec
TySynD ([Char] -> Name
mkName [Char]
idname) [] (Type -> Type -> Type
AppT (Name -> Type
ConT Name
entityIdName) (Name -> Type
ConT Name
tname))
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
ret, Dec
syndec]