content: {-# 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 recName colStr ix colType =
      [d| instance HasProjection $(litT $ strTyLit colStr) $(toTypeCon recName) $colType where
            projection _ = definePi $ $offsetsExp ! $(integralE ix)
        |]
    where
      offsetsExp = toVarExp . columnOffsetsVarNameDefault $ 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 recType avs sels cts =
      sequence $ zipWith3 template sels cts (inits cts)
    where
      template colStr colType pcts =
        instanceD
        (mapM (classP ''PersistableWidth . (:[]) . varT) avs)
        [t| HasProjection $(litT $ strTyLit colStr) $recType $colType |]
        [projectionDec pcts]
  
  projectionDec :: [TypeQ] -> Q Dec
  projectionDec cts =
      funD
      (mkName "projection")
      [clause [[p| _ |]]
        (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 t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]
  #else
  polymorphicProjections _ _ _ _ = [d| |]
  #endif
  
  -- | Projection templates for tuple type.
  tupleProjection :: Int -> Q [Dec]
  tupleProjection n = do
      p <- polymorphicProjections tyRec avs ["fst", "snd"] cts
      q <- polymorphicProjections tyRec avs sels cts
      return $ p ++ q
    where
      sels = [ "pi" ++ show i
             | i <- [ 0 .. n - 1] ]
      ((avs, cts), tyRec) = tupleN
      tupleN :: (([Name], [TypeQ]), TypeQ)
      --- same as tupleN of InternalTH.Base, merge after dropping GHC 7.x
      tupleN = ((ns, vs), foldl' appT (tupleT n) vs)
        where
          ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ]
          vs = map varT 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 recType colType indexes =
    [d| instance HasProjection "primary" $recType $colType  where
          projection _ = projectionKey
                         $ unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes])
      |]
  #else
  definePrimaryHasProjection _ _ _ = [d| |]
  #endif
  