{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ConstraintKinds #-}

-- |
-- Module      : Database.Relational.ProjectableClass
-- Copyright   : 2017 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module provides interfaces to preserve constraints of
-- direct product projections.
module Database.Relational.ProjectableClass (
  -- * Literal SQL terms
  LiteralSQL (..), showLiteral,
  StringSQL,

  -- * Deprecated.
  ShowConstantTermsSQL, showConstantTermsSQL', showConstantTermsSQL,
  ) where

import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), from)
import Data.Monoid (mempty, (<>))
import Data.DList (DList, toList)

import Database.Relational.Internal.String (StringSQL)


-- | Convert from haskell record to SQL literal row-value.
showLiteral :: LiteralSQL a
            => a
            -> [StringSQL]
showLiteral :: a -> [StringSQL]
showLiteral = DList StringSQL -> [StringSQL]
forall a. DList a -> [a]
toList (DList StringSQL -> [StringSQL])
-> (a -> DList StringSQL) -> a -> [StringSQL]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DList StringSQL
forall a. LiteralSQL a => a -> DList StringSQL
showLiteral'

{- |
'LiteralSQL' 'a' is implicit rule to derive function to convert
from haskell record type 'a' into SQL literal row-value.

Generic programming (<https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#generic-programming>)
with default signature is available for 'LiteralSQL' class,
so you can make instance like below:

@
  \{\-\# LANGUAGE DeriveGeneric \#\-\}
  import GHC.Generics (Generic)
  --
  data Foo = Foo { ... } deriving Generic
  instance LiteralSQL Foo
@

-}
class LiteralSQL a where
  showLiteral' :: a -> DList StringSQL

  default showLiteral' :: (Generic a, GLiteralSQL (Rep a)) => a -> DList StringSQL
  showLiteral' = Rep a Any -> DList StringSQL
forall (f :: * -> *) a. GLiteralSQL f => f a -> DList StringSQL
gShowLiteral (Rep a Any -> DList StringSQL)
-> (a -> Rep a Any) -> a -> DList StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

class GLiteralSQL f where
  gShowLiteral :: f a -> DList StringSQL

instance GLiteralSQL U1 where
  gShowLiteral :: U1 a -> DList StringSQL
gShowLiteral U1 a
U1 = DList StringSQL
forall a. Monoid a => a
mempty

instance (GLiteralSQL a, GLiteralSQL b) =>
         GLiteralSQL (a :*: b) where
  gShowLiteral :: (:*:) a b a -> DList StringSQL
gShowLiteral (a a
a :*: b a
b) = a a -> DList StringSQL
forall (f :: * -> *) a. GLiteralSQL f => f a -> DList StringSQL
gShowLiteral a a
a DList StringSQL -> DList StringSQL -> DList StringSQL
forall a. Semigroup a => a -> a -> a
<> b a -> DList StringSQL
forall (f :: * -> *) a. GLiteralSQL f => f a -> DList StringSQL
gShowLiteral b a
b

instance GLiteralSQL a => GLiteralSQL (M1 i c a) where
  gShowLiteral :: M1 i c a a -> DList StringSQL
gShowLiteral (M1 a a
a) = a a -> DList StringSQL
forall (f :: * -> *) a. GLiteralSQL f => f a -> DList StringSQL
gShowLiteral a a
a

instance ShowConstantTermsSQL a => GLiteralSQL (K1 i a) where
  gShowLiteral :: K1 i a a -> DList StringSQL
gShowLiteral (K1 a
a) = a -> DList StringSQL
forall a. LiteralSQL a => a -> DList StringSQL
showLiteral' a
a

---

{-# DEPRECATED ShowConstantTermsSQL "Use `LiteralSQL` instead of this." #-}
-- | Deprecated.
type ShowConstantTermsSQL = LiteralSQL

{-# DEPRECATED showConstantTermsSQL' "Use `showLiteral'` instead of this." #-}
showConstantTermsSQL' :: ShowConstantTermsSQL a => a -> DList StringSQL
showConstantTermsSQL' :: a -> DList StringSQL
showConstantTermsSQL' = a -> DList StringSQL
forall a. LiteralSQL a => a -> DList StringSQL
showLiteral'

{-# DEPRECATED showConstantTermsSQL "Use `showLiteral` instead of this." #-}
-- | Deprecated.
showConstantTermsSQL :: ShowConstantTermsSQL a
                     => a
                     -> [StringSQL]
showConstantTermsSQL :: a -> [StringSQL]
showConstantTermsSQL = DList StringSQL -> [StringSQL]
forall a. DList a -> [a]
toList (DList StringSQL -> [StringSQL])
-> (a -> DList StringSQL) -> a -> [StringSQL]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DList StringSQL
forall a. LiteralSQL a => a -> DList StringSQL
showConstantTermsSQL'