{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- |
-- Module      : Database.Record.TH
-- Copyright   : 2013-2017 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines templates for Haskell record type and
-- type class instances to map between list of untyped SQL type and Haskell record type.
module Database.Record.TH (
  -- * Table constraint specified by key
  defineHasColumnConstraintInstance,
  defineHasPrimaryConstraintInstanceDerived,
  defineHasPrimaryKeyInstance,
  defineHasNotNullKeyInstance,

  -- * Record type
  defineRecordType,
  defineRecordTypeWithConfig,

  -- * Function declarations against defined record types
  defineColumnOffsets,
  recordWidthTemplate,

  -- * Instance definitions against defined record types
  definePersistableWidthInstance,
  defineSqlPersistableInstances,

  -- * Templates about record name
  NameConfig,  defaultNameConfig,
  recordTypeName, columnName,

  recordTemplate,

  columnOffsetsVarNameDefault,

  -- * Not nullable single column type
  deriveNotNullType,

  -- * Template for tuple types
  defineTupleInstances,
  ) where

import GHC.Generics (Generic)
import Data.Array (Array)
import Language.Haskell.TH.Name.CamelCase
  (ConName(conName), VarName(varName),
   conCamelcaseName, varCamelcaseName,
   toTypeCon, toDataCon, )
import Language.Haskell.TH.Lib.Extra (integralE, simpleValD, reportWarning)
import Language.Haskell.TH.Compat.Data (dataD')
import Language.Haskell.TH
  (Q, nameBase, Name, Dec, TypeQ, conT, ExpQ, listE, sigE,
   recC, cxt, varStrictType, strictType, isStrict)

import Control.Arrow ((&&&))

import Database.Record
  (HasColumnConstraint(columnConstraint), Primary, NotNull,
   HasKeyConstraint(keyConstraint), derivedCompositePrimary,
   PersistableRecordWidth, PersistableWidth(persistableWidth), )

import Database.Record.KeyConstraint
  (unsafeSpecifyColumnConstraint, unsafeSpecifyNotNullValue, unsafeSpecifyKeyConstraint)
import Database.Record.Persistable
  (runPersistableRecordWidth,
   ProductConst, getProductConst, genericFieldOffsets)
import qualified Database.Record.Persistable as Persistable
import Database.Record.InternalTH
  (definePersistableWidthInstance, defineSqlPersistableInstances, defineTupleInstances)


-- | 'NameConfig' type to customize names of expanded record templates.
data NameConfig =
  NameConfig
  { NameConfig -> String -> String -> ConName
recordTypeName  ::  String -> String -> ConName
    -- ^ Make record type name generated from the table's definition.
    --   The first argument is the schema name of the table, and the second argument is the table name.
  , NameConfig -> String -> String -> VarName
columnName      ::  String -> String -> VarName
    -- ^ Make each field label of the record type generated from the table's definition.
    --   The first argument is the table name, and the second argument is the column name.
  }

-- | Dummy show instance. Handy to define show instance recursively.
instance Show NameConfig where
  show :: NameConfig -> String
show = String -> NameConfig -> String
forall a b. a -> b -> a
const "<nameConfig>"

-- | Default implementation of 'NameConfig' type.
--   To change how generated record types and their columns are named,
--   use record update syntax:
--
-- @
--   defaultNameConfig
--     { recordTypeName = \\schema table -> 'varCamelcaseName' $ schema ++ "_" ++ table
--     -- ^ append the table name after the schema name. e.g. "SchemaTable"
--     , columnName = \\table column -> 'varCamelcaseName' $ table ++ "_" ++ column
--     -- ^ append the column name after the table name. e.g. "tableColumn"
--     }
-- @
defaultNameConfig :: NameConfig
defaultNameConfig :: NameConfig
defaultNameConfig =
  NameConfig :: (String -> String -> ConName)
-> (String -> String -> VarName) -> NameConfig
NameConfig
  { recordTypeName :: String -> String -> ConName
recordTypeName  =  (String -> ConName) -> String -> String -> ConName
forall a b. a -> b -> a
const String -> ConName
conCamelcaseName
  , columnName :: String -> String -> VarName
columnName      =  (String -> VarName) -> String -> String -> VarName
forall a b. a -> b -> a
const String -> VarName
varCamelcaseName
  }

-- | Record constructor templates from SQL table name 'String'.
recordTemplate :: NameConfig    -- ^ name rule config
               -> String        -- ^ Schema name string in SQL
               -> String        -- ^ Table name string in SQL
               -> (TypeQ, ExpQ) -- ^ Record type and data constructor
recordTemplate :: NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate config :: NameConfig
config scm :: String
scm = (ConName -> TypeQ
toTypeCon (ConName -> TypeQ) -> (ConName -> ExpQ) -> ConName -> (TypeQ, ExpQ)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ConName -> ExpQ
toDataCon) (ConName -> (TypeQ, ExpQ))
-> (String -> ConName) -> String -> (TypeQ, ExpQ)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConfig -> String -> String -> ConName
recordTypeName NameConfig
config String
scm

-- | Variable expression of record column offset array.
columnOffsetsVarNameDefault :: Name    -- ^ Table type name
                            -> VarName -- ^ Result expression variable name
columnOffsetsVarNameDefault :: Name -> VarName
columnOffsetsVarNameDefault = String -> VarName
varCamelcaseName (String -> VarName) -> (Name -> String) -> Name -> VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("column_offsets_" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

-- | Template of 'HasColumnConstraint' instance.
defineHasColumnConstraintInstance :: TypeQ   -- ^ Type which represent constraint type
                                  -> TypeQ   -- ^ Type constructor of record
                                  -> Int     -- ^ Key index which specifies this constraint
                                  -> Q [Dec] -- ^ Result definition template
defineHasColumnConstraintInstance :: TypeQ -> TypeQ -> Int -> Q [Dec]
defineHasColumnConstraintInstance constraint :: TypeQ
constraint typeCon :: TypeQ
typeCon index :: Int
index =
  [d| instance HasColumnConstraint $constraint $typeCon where
        columnConstraint = unsafeSpecifyColumnConstraint $(integralE index) |]

-- | Template of 'HasKeyConstraint' instance.
defineHasPrimaryConstraintInstanceDerived ::TypeQ    -- ^ Type constructor of record
                                          -> Q [Dec] -- ^ Result definition template
defineHasPrimaryConstraintInstanceDerived :: TypeQ -> Q [Dec]
defineHasPrimaryConstraintInstanceDerived typeCon :: TypeQ
typeCon =
  [d| instance HasKeyConstraint Primary $typeCon where
        keyConstraint = derivedCompositePrimary |]

-- | Template of 'HasColumnConstraint' 'Primary' instance.
defineHasPrimaryKeyInstance :: TypeQ   -- ^ Type constructor of record
                            -> [Int]   -- ^ Key index which specifies this constraint
                            -> Q [Dec] -- ^ Definition of primary key constraint instance
defineHasPrimaryKeyInstance :: TypeQ -> [Int] -> Q [Dec]
defineHasPrimaryKeyInstance typeCon :: TypeQ
typeCon = [Int] -> Q [Dec]
d  where
  d :: [Int] -> Q [Dec]
d []   = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  d [ix :: Int
ix] = do
    [Dec]
col  <- TypeQ -> TypeQ -> Int -> Q [Dec]
defineHasColumnConstraintInstance [t| Primary |] TypeQ
typeCon Int
ix
    [Dec]
comp <- TypeQ -> Q [Dec]
defineHasPrimaryConstraintInstanceDerived TypeQ
typeCon
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
col [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
comp
  d ixs :: [Int]
ixs  =
    [d| instance HasKeyConstraint Primary $typeCon where
          keyConstraint = unsafeSpecifyKeyConstraint
                          $(listE [integralE ix | ix <- ixs ])
      |]

-- | Template of 'HasColumnConstraint' 'NotNull' instance.
defineHasNotNullKeyInstance :: TypeQ   -- ^ Type constructor of record
                            -> Int     -- ^ Key index which specifies this constraint
                            -> Q [Dec] -- ^ Definition of not null key constraint instance
defineHasNotNullKeyInstance :: TypeQ -> Int -> Q [Dec]
defineHasNotNullKeyInstance =
  TypeQ -> TypeQ -> Int -> Q [Dec]
defineHasColumnConstraintInstance [t| NotNull |]

-- | Record type width expression template.
recordWidthTemplate :: TypeQ -- ^ Record type constructor.
                    -> ExpQ  -- ^ Expression to get record width.
recordWidthTemplate :: TypeQ -> ExpQ
recordWidthTemplate ty :: TypeQ
ty =
  [| runPersistableRecordWidth
     $(sigE [| persistableWidth |] [t| PersistableRecordWidth $(ty) |])
   |]

-- | Column offset array definition.
defineColumnOffsets :: ConName -- ^ Record type constructor.
                    -> Q [Dec] -- ^ Result column offset array declaration.
defineColumnOffsets :: ConName -> Q [Dec]
defineColumnOffsets typeName' :: ConName
typeName' = do
  let ofsVar :: VarName
ofsVar = Name -> VarName
columnOffsetsVarNameDefault (Name -> VarName) -> Name -> VarName
forall a b. (a -> b) -> a -> b
$ ConName -> Name
conName ConName
typeName'
  Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD (VarName -> Name
varName VarName
ofsVar) [t| Array Int Int |]
    [| getProductConst (genericFieldOffsets :: ProductConst (Array Int Int) $(toTypeCon typeName')) |]

-- | Record type definition template.
defineRecordType :: ConName            -- ^ Name of the data type of table record type.
                 -> [(VarName, TypeQ)] -- ^ List of columns in the table. Must be legal, properly cased record columns.
                 -> [Name]             -- ^ Deriving type class names.
                 -> Q [Dec]            -- ^ The data type record definition
defineRecordType :: ConName -> [(VarName, TypeQ)] -> [Name] -> Q [Dec]
defineRecordType typeName' :: ConName
typeName' columns :: [(VarName, TypeQ)]
columns derives :: [Name]
derives = do
  let typeName :: Name
typeName = ConName -> Name
conName ConName
typeName'
      fld :: (VarName, TypeQ) -> VarStrictTypeQ
fld (n :: VarName
n, tq :: TypeQ
tq) = Name -> StrictTypeQ -> VarStrictTypeQ
varStrictType (VarName -> Name
varName VarName
n) (Q Strict -> TypeQ -> StrictTypeQ
strictType Q Strict
isStrict TypeQ
tq)
  [Name]
derives1 <- if (''Generic Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
derives)
              then do String -> Q ()
reportWarning "HRR needs Generic instance, please add ''Generic manually."
                      [Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Q [Name]) -> [Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ''Generic Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
derives
                      {- DROP this hack in future version ups. -}
              else    [Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return   [Name]
derives
  Dec
rec' <- CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> [Name] -> DecQ
dataD' ([TypeQ] -> CxtQ
cxt []) Name
typeName [] [Name -> [VarStrictTypeQ] -> ConQ
recC Name
typeName (((VarName, TypeQ) -> VarStrictTypeQ)
-> [(VarName, TypeQ)] -> [VarStrictTypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (VarName, TypeQ) -> VarStrictTypeQ
fld [(VarName, TypeQ)]
columns)] [Name]
derives1
  [Dec]
offs <- ConName -> Q [Dec]
defineColumnOffsets ConName
typeName'
  [Dec]
pw   <- TypeQ -> [Name] -> Q [Dec]
definePersistableWidthInstance (Name -> TypeQ
conT Name
typeName) []
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
rec' Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
offs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
pw

-- | Record type definition template with configured names.
defineRecordTypeWithConfig :: NameConfig -> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineRecordTypeWithConfig :: NameConfig
-> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineRecordTypeWithConfig config :: NameConfig
config schema :: String
schema table :: String
table columns :: [(String, TypeQ)]
columns =
  ConName -> [(VarName, TypeQ)] -> [Name] -> Q [Dec]
defineRecordType
  (NameConfig -> String -> String -> ConName
recordTypeName NameConfig
config String
schema String
table)
  [ (NameConfig -> String -> String -> VarName
columnName NameConfig
config String
table String
n, TypeQ
t) | (n :: String
n, t :: TypeQ
t) <- [(String, TypeQ)]
columns ]

-- | Templates for single column value type.
deriveNotNullType :: TypeQ -> Q [Dec]
deriveNotNullType :: TypeQ -> Q [Dec]
deriveNotNullType typeCon :: TypeQ
typeCon =
  [d| instance PersistableWidth $typeCon where
        persistableWidth = Persistable.unsafeValueWidth

      instance HasColumnConstraint NotNull $typeCon where
        columnConstraint = unsafeSpecifyNotNullValue
    |]