{-# 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 Language.Haskell.TH.Compat.Data (plainTVspecified)
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), forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Int -> m Type
tupleT Int
n) [TypeQ]
vs)
  where
    ns :: [Name]
ns = [ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"a" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
j | Int
j <- [Int
1 .. Int
n] ]
    vs :: [TypeQ]
vs = forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Type
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
  (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
    -- in template-haskell 2.8 or older, Pred is not Type
    (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> [TypeQ] -> TypeQ
classP ''LiteralSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 TypeQ -> [TypeQ] -> Name -> Q [Dec]
template [TypeQ]
cts (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 <- forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
selN forall a b. (a -> b) -> a -> b
$
             forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT (forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr Specificity
plainTVspecified [Name]
avs)
             (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> [TypeQ] -> TypeQ
classP ''PersistableWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => Name -> m Type
varT) [Name]
avs)
             [t| Pi $tyRec $ct |]
      let runPW :: m Type -> m Exp
runPW m Type
t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]
      Dec
val <- forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
selN)
             (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) :: Int |]) [| 0 :: Int |] pcts) |]) []
      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 forall a b. (a -> b) -> a -> b
$ String
"tuplePi" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
"'"
           | Int
i <- [ Int
0 .. Int
n forall a. Num a => a -> a -> a
- Int
1] ]