{-# 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, classP,
   appT, tupleT, varT, litT, strTyLit, clause, normalB, listE)
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 recName :: ConName
recName colStr :: String
colStr ix :: Int
ix colType :: 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 recType :: TypeQ
recType avs :: [Name]
avs sels :: [String]
sels cts :: [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 colStr :: String
colStr colType :: TypeQ
colType pcts :: [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 cts :: [TypeQ]
cts =
    Name -> [ClauseQ] -> Q Dec
funD
    (String -> Name
mkName "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 t :: TypeQ
t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]
#else
polymorphicProjections _ _ _ _ = [d| |]
#endif

-- | Projection templates for tuple type.
tupleProjection :: Int -> Q [Dec]
tupleProjection :: Int -> Q [Dec]
tupleProjection n :: Int
n = do
    [Dec]
p <- TypeQ -> [Name] -> [String] -> [TypeQ] -> Q [Dec]
polymorphicProjections TypeQ
tyRec [Name]
avs ["fst", "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 = [ "pi" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
           | Int
i <- [ 0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ]
    ((avs :: [Name]
avs, cts :: [TypeQ]
cts), tyRec :: 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
$ "a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
j | Int
j <- [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 recType :: TypeQ
recType colType :: TypeQ
colType indexes :: [Int]
indexes =
  [d| instance HasProjection "primary" $recType $colType  where
        projection _ = projectionKey
                       $ unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes])
    |]
#else
definePrimaryHasProjection _ _ _ = [d| |]
#endif