{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}

-- |
-- Module      : Database.Relational.InternalTH.Base
-- Copyright   : 2017 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines templates for internally using.
module Database.Relational.InternalTH.Base (
  defineTupleShowLiteralInstance,
  defineTuplePi,

  defineRecordProjections,
  ) where

import Control.Applicative ((<$>))
import Data.List (foldl', inits)
import Language.Haskell.TH
  (Q, Name, mkName, normalB, varP,
   TypeQ, forallT, varT, tupleT, appT,
   Dec, sigD, valD, instanceD,
   TyVarBndr (PlainTV), )
import Language.Haskell.TH.Compat.Constraint (classP)
import Database.Record.Persistable
  (PersistableWidth, persistableWidth,
   PersistableRecordWidth, runPersistableRecordWidth)

import Database.Relational.ProjectableClass (LiteralSQL (..))
import Database.Relational.Pi.Unsafe (Pi, definePi)


tupleN :: Int -> (([Name], [TypeQ]), TypeQ)
tupleN :: Int -> (([Name], [TypeQ]), TypeQ)
tupleN Int
n = (([Name]
ns, [TypeQ]
vs), (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT Int
n) [TypeQ]
vs)
  where
    ns :: [Name]
ns = [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
j | Int
j <- [Int
1 .. Int
n] ]
    vs :: [TypeQ]
vs = (Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT [Name]
ns

-- | Make template of 'LiteralSQL' instance of tuple type.
defineTupleShowLiteralInstance :: Int -> Q [Dec]
defineTupleShowLiteralInstance :: Int -> Q [Dec]
defineTupleShowLiteralInstance Int
n = do
  let (([Name]
_, [TypeQ]
vs), TypeQ
tty)  =  Int -> (([Name], [TypeQ]), TypeQ)
tupleN Int
n
  (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD
    -- in template-haskell 2.8 or older, Pred is not Type
    ((TypeQ -> TypeQ) -> [TypeQ] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> [TypeQ] -> TypeQ
classP ''LiteralSQL ([TypeQ] -> TypeQ) -> (TypeQ -> [TypeQ]) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
:[])) [TypeQ]
vs)
    [t| LiteralSQL $tty |]
    []

-- | Make polymorphic projection templates.
defineRecordProjections :: TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec]
defineRecordProjections :: TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec]
defineRecordProjections TypeQ
tyRec [Name]
avs [Name]
sels [TypeQ]
cts =
    ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([Q [Dec]] -> Q [[Dec]]) -> [Q [Dec]] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (TypeQ -> [TypeQ] -> Name -> Q [Dec])
-> [TypeQ] -> [[TypeQ]] -> [Name] -> [Q [Dec]]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 TypeQ -> [TypeQ] -> Name -> Q [Dec]
template [TypeQ]
cts ([TypeQ] -> [[TypeQ]]
forall a. [a] -> [[a]]
inits [TypeQ]
cts) [Name]
sels
  where
    template :: TypeQ -> [TypeQ] -> Name -> Q [Dec]
    template :: TypeQ -> [TypeQ] -> Name -> Q [Dec]
template TypeQ
ct [TypeQ]
pcts Name
selN = do
      Dec
sig <- Name -> TypeQ -> Q Dec
sigD Name
selN (TypeQ -> Q Dec) -> TypeQ -> Q Dec
forall a b. (a -> b) -> a -> b
$
             [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV [Name]
avs)
             ((Name -> TypeQ) -> [Name] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> [TypeQ] -> TypeQ
classP ''PersistableWidth ([TypeQ] -> TypeQ) -> (Name -> [TypeQ]) -> Name -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
:[]) (TypeQ -> [TypeQ]) -> (Name -> TypeQ) -> Name -> [TypeQ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TypeQ
varT) [Name]
avs)
             [t| Pi $tyRec $ct |]
      let runPW :: TypeQ -> ExpQ
runPW TypeQ
t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]
      Dec
val <- PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
selN)
             (ExpQ -> BodyQ
normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) :: Int |]) [| 0 :: Int |] pcts) |]) []
      [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
sig, Dec
val]

-- | Make templates of projection paths for tuple types.
defineTuplePi :: Int -> Q [Dec]
defineTuplePi :: Int -> Q [Dec]
defineTuplePi Int
n =
  TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec]
defineRecordProjections TypeQ
tyRec [Name]
avs [Name]
sels [TypeQ]
cts
  where
    (([Name]
avs, [TypeQ]
cts), TypeQ
tyRec) = Int -> (([Name], [TypeQ]), TypeQ)
tupleN Int
n
    sels :: [Name]
sels = [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"tuplePi" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
           | Int
i <- [ Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]