-- |
-- Module      : Database.Relational.Monad.BaseType
-- Copyright   : 2015-2017 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines base monad type to build queries.
module Database.Relational.Monad.BaseType
       ( -- * Base monad type to build queries
         ConfigureQuery, configureQuery,
         qualifyQuery, askConfig,

         -- * Relation type
         Relation, unsafeTypeRelation, untypeRelation, relationWidth,

         dump,
         sqlFromRelationWith, sqlFromRelation,

         rightPh, leftPh,
       ) where

import Data.Functor.Identity (Identity, runIdentity)
import Control.Applicative ((<$>))

import Database.Record.Persistable (PersistableRecordWidth, unsafePersistableRecordWidth)

import Database.Relational.Internal.String (StringSQL, showStringSQL)
import Database.Relational.Internal.Config (Config, defaultConfig)
import Database.Relational.SqlSyntax (Qualified, SubQuery, showSQL, width)

import qualified Database.Relational.Monad.Trans.Qualify as Qualify
import Database.Relational.Monad.Trans.Qualify (Qualify, qualify, evalQualifyPrime)
import Database.Relational.Monad.Trans.Config (QueryConfig, runQueryConfig, askQueryConfig)

-- | Thin monad type for untyped structure.
type ConfigureQuery = Qualify (QueryConfig Identity)

-- | Run 'ConfigureQuery' monad with initial state to get only result.
configureQuery :: ConfigureQuery q -> Config -> q
configureQuery :: ConfigureQuery q -> Config -> q
configureQuery ConfigureQuery q
cq Config
c = Identity q -> q
forall a. Identity a -> a
runIdentity (Identity q -> q) -> Identity q -> q
forall a b. (a -> b) -> a -> b
$ QueryConfig Identity q -> Config -> Identity q
forall (m :: * -> *) a. QueryConfig m a -> Config -> m a
runQueryConfig (ConfigureQuery q -> QueryConfig Identity q
forall (m :: * -> *) a. Monad m => Qualify m a -> m a
evalQualifyPrime ConfigureQuery q
cq) Config
c

-- | Get qualifyed table form query.
qualifyQuery :: a -> ConfigureQuery (Qualified a)
qualifyQuery :: a -> ConfigureQuery (Qualified a)
qualifyQuery =  a -> ConfigureQuery (Qualified a)
forall (m :: * -> *) query.
Monad m =>
query -> Qualify m (Qualified query)
Qualify.qualifyQuery

-- | Read configuration.
askConfig :: ConfigureQuery Config
askConfig :: ConfigureQuery Config
askConfig =  QueryConfig Identity Config -> ConfigureQuery Config
forall (m :: * -> *) a. Monad m => m a -> Qualify m a
qualify QueryConfig Identity Config
forall (m :: * -> *). Monad m => QueryConfig m Config
askQueryConfig


-- | Relation type with place-holder parameter 'p' and query result type 'r'.
newtype Relation p r = SubQuery (ConfigureQuery SubQuery)

-- | Unsafely type qualified subquery into record typed relation type.
unsafeTypeRelation :: ConfigureQuery SubQuery -> Relation p r
unsafeTypeRelation :: ConfigureQuery SubQuery -> Relation p r
unsafeTypeRelation = ConfigureQuery SubQuery -> Relation p r
forall p r. ConfigureQuery SubQuery -> Relation p r
SubQuery

-- | Sub-query Qualify monad from relation.
untypeRelation :: Relation p r -> ConfigureQuery SubQuery
untypeRelation :: Relation p r -> ConfigureQuery SubQuery
untypeRelation (SubQuery ConfigureQuery SubQuery
qsub) = ConfigureQuery SubQuery
qsub

-- | 'PersistableRecordWidth' of 'Relation' type.
relationWidth :: Relation p r ->  PersistableRecordWidth r
relationWidth :: Relation p r -> PersistableRecordWidth r
relationWidth Relation p r
rel =
  Int -> PersistableRecordWidth r
forall a. Int -> PersistableRecordWidth a
unsafePersistableRecordWidth (Int -> PersistableRecordWidth r)
-> (SubQuery -> Int) -> SubQuery -> PersistableRecordWidth r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubQuery -> Int
width (SubQuery -> PersistableRecordWidth r)
-> SubQuery -> PersistableRecordWidth r
forall a b. (a -> b) -> a -> b
$ ConfigureQuery SubQuery -> Config -> SubQuery
forall q. ConfigureQuery q -> Config -> q
configureQuery (Relation p r -> ConfigureQuery SubQuery
forall p r. Relation p r -> ConfigureQuery SubQuery
untypeRelation Relation p r
rel) Config
defaultConfig
  ---                               Assume that width is independent from Config structure

unsafeCastPlaceHolder :: Relation a r -> Relation b r
unsafeCastPlaceHolder :: Relation a r -> Relation b r
unsafeCastPlaceHolder (SubQuery ConfigureQuery SubQuery
qsub) = ConfigureQuery SubQuery -> Relation b r
forall p r. ConfigureQuery SubQuery -> Relation p r
SubQuery ConfigureQuery SubQuery
qsub

-- | Simplify placeholder type applying left identity element.
rightPh :: Relation ((), p) r -> Relation p r
rightPh :: Relation ((), p) r -> Relation p r
rightPh =  Relation ((), p) r -> Relation p r
forall a r b. Relation a r -> Relation b r
unsafeCastPlaceHolder

-- | Simplify placeholder type applying right identity element.
leftPh :: Relation (p, ()) r -> Relation p r
leftPh :: Relation (p, ()) r -> Relation p r
leftPh =  Relation (p, ()) r -> Relation p r
forall a r b. Relation a r -> Relation b r
unsafeCastPlaceHolder

-- | Generate SQL string from 'Relation' with configuration.
sqlFromRelationWith :: Relation p r -> Config -> StringSQL
sqlFromRelationWith :: Relation p r -> Config -> StringSQL
sqlFromRelationWith =  ConfigureQuery StringSQL -> Config -> StringSQL
forall q. ConfigureQuery q -> Config -> q
configureQuery (ConfigureQuery StringSQL -> Config -> StringSQL)
-> (Relation p r -> ConfigureQuery StringSQL)
-> Relation p r
-> Config
-> StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SubQuery -> StringSQL
showSQL (SubQuery -> StringSQL)
-> ConfigureQuery SubQuery -> ConfigureQuery StringSQL
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (ConfigureQuery SubQuery -> ConfigureQuery StringSQL)
-> (Relation p r -> ConfigureQuery SubQuery)
-> Relation p r
-> ConfigureQuery StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation p r -> ConfigureQuery SubQuery
forall p r. Relation p r -> ConfigureQuery SubQuery
untypeRelation

-- | SQL string from 'Relation'.
sqlFromRelation :: Relation p r -> StringSQL
sqlFromRelation :: Relation p r -> StringSQL
sqlFromRelation =  (Relation p r -> Config -> StringSQL
forall p r. Relation p r -> Config -> StringSQL
`sqlFromRelationWith` Config
defaultConfig)

-- | Dump internal structure tree.
dump :: Relation p r -> String
dump :: Relation p r -> String
dump =  SubQuery -> String
forall a. Show a => a -> String
show (SubQuery -> String)
-> (Relation p r -> SubQuery) -> Relation p r -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConfigureQuery SubQuery -> Config -> SubQuery
forall q. ConfigureQuery q -> Config -> q
`configureQuery` Config
defaultConfig) (ConfigureQuery SubQuery -> SubQuery)
-> (Relation p r -> ConfigureQuery SubQuery)
-> Relation p r
-> SubQuery
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation p r -> ConfigureQuery SubQuery
forall p r. Relation p r -> ConfigureQuery SubQuery
untypeRelation

instance Show (Relation p r) where
  show :: Relation p r -> String
show = StringSQL -> String
showStringSQL (StringSQL -> String)
-> (Relation p r -> StringSQL) -> Relation p r -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation p r -> StringSQL
forall p r. Relation p r -> StringSQL
sqlFromRelation