{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}

-- |
-- Module      : Database.Relational.InternalTH.Overloaded
-- Copyright   : 2017-2018 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines overloaded projection templates for internally using.
module Database.Relational.InternalTH.Overloaded (
  monomorphicProjection,
  polymorphicProjections,
  tupleProjection,
  definePrimaryHasProjection,
  ) where

#if __GLASGOW_HASKELL__ >= 800
import Language.Haskell.TH
  (Name, mkName, Q, TypeQ, Dec, instanceD, funD,
   appT, tupleT, varT, litT, strTyLit, clause, normalB, listE)
import Language.Haskell.TH.Compat.Constraint (classP)
import Language.Haskell.TH.Lib.Extra (integralE)
import Language.Haskell.TH.Name.CamelCase
  (ConName, conName, toVarExp, toTypeCon)
import Data.List (foldl', inits)
import Data.Array ((!))
import Database.Record.Persistable
  (PersistableWidth, persistableWidth,
   PersistableRecordWidth, runPersistableRecordWidth)
import Database.Record.TH (columnOffsetsVarNameDefault)

import Database.Relational.Pi.Unsafe (definePi)
import Database.Relational.Constraint (unsafeDefineConstraintKey, projectionKey)
import Database.Relational.OverloadedProjection (HasProjection (projection))
#else
import Language.Haskell.TH (Name, mkName, Q, TypeQ, appT, tupleT, varT, Dec)
import Language.Haskell.TH.Name.CamelCase (ConName)
import Data.List (foldl')
#endif

-- | Projection template for monomorphic record type.
monomorphicProjection :: ConName
                      -> String
                      -> Int
                      -> TypeQ
                      -> Q [Dec]
#if __GLASGOW_HASKELL__ >= 800
monomorphicProjection :: ConName -> String -> Int -> TypeQ -> Q [Dec]
monomorphicProjection ConName
recName String
colStr Int
ix TypeQ
colType =
    [d| instance HasProjection $(litT $ strTyLit colStr) $(toTypeCon recName) $colType where
          projection _ = definePi $ $offsetsExp ! $(integralE ix)
      |]
  where
    offsetsExp :: ExpQ
offsetsExp = VarName -> ExpQ
toVarExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> VarName
columnOffsetsVarNameDefault forall a b. (a -> b) -> a -> b
$ ConName -> Name
conName ConName
recName
#else
monomorphicProjection _ _ _ _ = [d| |]
#endif

-- | Projection templates for record type with type variable.
polymorphicProjections :: TypeQ
                       -> [Name]
                       -> [String]
                       -> [TypeQ]
                       -> Q [Dec]
#if __GLASGOW_HASKELL__ >= 800
polymorphicProjections :: TypeQ -> [Name] -> [String] -> [TypeQ] -> Q [Dec]
polymorphicProjections TypeQ
recType [Name]
avs [String]
sels [TypeQ]
cts =
    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 String -> TypeQ -> [TypeQ] -> Q Dec
template [String]
sels [TypeQ]
cts (forall a. [a] -> [[a]]
inits [TypeQ]
cts)
  where
    template :: String -> TypeQ -> [TypeQ] -> Q Dec
template String
colStr TypeQ
colType [TypeQ]
pcts =
      forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
      (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| HasProjection $(litT $ strTyLit colStr) $recType $colType |]
      [[TypeQ] -> Q Dec
projectionDec [TypeQ]
pcts]

projectionDec :: [TypeQ] -> Q Dec
projectionDec :: [TypeQ] -> Q Dec
projectionDec [TypeQ]
cts =
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
    (String -> Name
mkName String
"projection")
    [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [[p| _ |]]
      (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] cts) |])
      []]
  --- In sub-tree, newName "projection" is called by [d| projection .. = |]?
  --- head <$> [d| projection _ =  definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] cts) |]
  where
    runPW :: m Type -> m Exp
runPW m Type
t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]
#else
polymorphicProjections _ _ _ _ = [d| |]
#endif

-- | Projection templates for tuple type.
tupleProjection :: Int -> Q [Dec]
tupleProjection :: Int -> Q [Dec]
tupleProjection Int
n = do
    [Dec]
p <- TypeQ -> [Name] -> [String] -> [TypeQ] -> Q [Dec]
polymorphicProjections TypeQ
tyRec [Name]
avs [String
"fst", String
"snd"] [TypeQ]
cts
    [Dec]
q <- TypeQ -> [Name] -> [String] -> [TypeQ] -> Q [Dec]
polymorphicProjections TypeQ
tyRec [Name]
avs [String]
sels [TypeQ]
cts
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
p forall a. [a] -> [a] -> [a]
++ [Dec]
q
  where
    sels :: [String]
sels = [ String
"pi" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i
           | Int
i <- [ Int
0 .. Int
n forall a. Num a => a -> a -> a
- Int
1] ]
    (([Name]
avs, [TypeQ]
cts), TypeQ
tyRec) = (([Name], [TypeQ]), TypeQ)
tupleN
    tupleN :: (([Name], [TypeQ]), TypeQ)
    --- same as tupleN of InternalTH.Base, merge after dropping GHC 7.x
    tupleN :: (([Name], [TypeQ]), TypeQ)
tupleN = (([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

-- | Projection template for primary key.
definePrimaryHasProjection :: TypeQ   -- ^ Record type
                           -> TypeQ   -- ^ Key type
                           -> [Int]   -- ^ Indexes specifies key
                           -> Q [Dec] -- ^ Result 'HasProjection' declaration
#if __GLASGOW_HASKELL__ >= 800
definePrimaryHasProjection :: TypeQ -> TypeQ -> [Int] -> Q [Dec]
definePrimaryHasProjection TypeQ
recType TypeQ
colType [Int]
indexes =
  [d| instance HasProjection "primary" $recType $colType  where
        projection _ = projectionKey
                       $ unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes])
    |]
#else
definePrimaryHasProjection _ _ _ = [d| |]
#endif