{-# 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.Compat.Bang
  (varBangType, bangType, bang,
   noSourceUnpackedness, sourceStrict)
import Language.Haskell.TH
  (Q, nameBase, Name, Dec, TypeQ, conT, ExpQ, listE, sigE, recC, cxt)

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 = forall a b. a -> b -> a
const String
"<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
  { recordTypeName :: String -> String -> ConName
recordTypeName  =  forall a b. a -> b -> a
const String -> ConName
conCamelcaseName
  , columnName :: String -> String -> VarName
columnName      =  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 NameConfig
config String
scm = (ConName -> TypeQ
toTypeCon forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ConName -> ExpQ
toDataCon) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"column_offsets_" forall a. [a] -> [a] -> [a]
++) 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 TypeQ
constraint TypeQ
typeCon 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 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 TypeQ
typeCon = [Int] -> Q [Dec]
d  where
  d :: [Int] -> Q [Dec]
d []   = forall (m :: * -> *) a. Monad m => a -> m a
return []
  d [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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
col forall a. [a] -> [a] -> [a]
++ [Dec]
comp
  d [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 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 ConName
typeName' = do
  let ofsVar :: VarName
ofsVar = Name -> VarName
columnOffsetsVarNameDefault 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 ConName
typeName' [(VarName, TypeQ)]
columns [Name]
derives = do
  let typeName :: Name
typeName = ConName -> Name
conName ConName
typeName'
      fld :: (VarName, m Type) -> m VarBangType
fld (VarName
n, m Type
tq) = forall (m :: * -> *).
Quote m =>
Name -> m BangType -> m VarBangType
varBangType (VarName -> Name
varName VarName
n) (forall (m :: * -> *). Quote m => m Bang -> m Type -> m BangType
bangType (forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness forall (m :: * -> *). Quote m => m SourceStrictness
sourceStrict) m Type
tq)
  [Name]
derives1 <- if (''Generic forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
derives)
              then do String -> Q ()
reportWarning String
"HRR needs Generic instance, please add ''Generic manually."
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ''Generic forall a. a -> [a] -> [a]
: [Name]
derives
                      {- DROP this hack in future version ups. -}
              else    forall (m :: * -> *) a. Monad m => a -> m a
return   [Name]
derives
  Dec
rec' <- CxtQ -> Name -> [TyVarBndr ()] -> [ConQ] -> [Name] -> DecQ
dataD' (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) Name
typeName [] [forall (m :: * -> *). Quote m => Name -> [m VarBangType] -> m Con
recC Name
typeName (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *}. Quote m => (VarName, m Type) -> m VarBangType
fld [(VarName, TypeQ)]
columns)] [Name]
derives1
  [Dec]
offs <- ConName -> Q [Dec]
defineColumnOffsets ConName
typeName'
  [Dec]
pw   <- TypeQ -> [Name] -> Q [Dec]
definePersistableWidthInstance (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
typeName) []
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Dec
rec' forall a. a -> [a] -> [a]
: [Dec]
offs 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 NameConfig
config String
schema String
table [(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) | (String
n, TypeQ
t) <- [(String, TypeQ)]
columns ]

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

      instance HasColumnConstraint NotNull $typeCon where
        columnConstraint = unsafeSpecifyNotNullValue
    |]