{-# 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 (VarName -> ExpQ) -> (Name -> VarName) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> VarName
columnOffsetsVarNameDefault (Name -> ExpQ) -> Name -> ExpQ
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 =
    [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
$ (String -> TypeQ -> [TypeQ] -> Q Dec)
-> [String] -> [TypeQ] -> [[TypeQ]] -> [Q Dec]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 String -> TypeQ -> [TypeQ] -> Q Dec
template [String]
sels [TypeQ]
cts ([TypeQ] -> [[TypeQ]]
forall a. [a] -> [[a]]
inits [TypeQ]
cts)
  where
    template :: String -> TypeQ -> [TypeQ] -> Q Dec
template String
colStr TypeQ
colType [TypeQ]
pcts =
      CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD
      ((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| HasProjection $(litT $ strTyLit colStr) $recType $colType |]
      [[TypeQ] -> Q Dec
projectionDec [TypeQ]
pcts]

projectionDec :: [TypeQ] -> Q Dec
projectionDec :: [TypeQ] -> Q Dec
projectionDec [TypeQ]
cts =
    Name -> [ClauseQ] -> Q Dec
funD
    (String -> Name
mkName String
"projection")
    [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [[p| _ |]]
      (ExpQ -> BodyQ
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 :: TypeQ -> ExpQ
runPW TypeQ
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
    [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]
p [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
q
  where
    sels :: [String]
sels = [ String
"pi" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
           | Int
i <- [ Int
0 .. Int
n Int -> Int -> Int
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), (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

-- | 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