{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE CPP, DataKinds, UndecidableInstances #-}
-- | Helpers for working with inner queries.
module Database.Selda.Inner where
import Database.Selda.Column
    ( Exp(AggrEx), UntypedCol(..), Row, Col(..) )
import Database.Selda.SQL (SQL)
import Database.Selda.SqlType (SqlType)
import Database.Selda.Types ( type (:*:)(..) )
import Data.Text (Text)
import Data.Typeable ( Typeable )
import GHC.TypeLits as TL ( TypeError, ErrorMessage(Text, (:$$:)) )

-- | A single aggregate column.
--   Aggregate columns may not be used to restrict queries.
--   When returned from an 'aggregate' subquery, an aggregate column is
--   converted into a non-aggregate column.
newtype Aggr s a = Aggr {forall s a. Aggr s a -> Exp SQL a
unAggr :: Exp SQL a}

-- | Lift a function over columns to aggregates.
liftAggr :: (Col s a -> Col s b) -> Aggr s a -> Aggr s b
liftAggr :: forall s a b. (Col s a -> Col s b) -> Aggr s a -> Aggr s b
liftAggr Col s a -> Col s b
f = forall s a. Exp SQL a -> Aggr s a
Aggr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {s} {a}. Col s a -> Exp SQL a
unOne forall b c a. (b -> c) -> (a -> b) -> a -> c
. Col s a -> Col s b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (s :: k) a. Exp SQL a -> Col s a
One forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. Aggr s a -> Exp SQL a
unAggr
  where unOne :: Col s a -> Exp SQL a
unOne (One Exp SQL a
x) = Exp SQL a
x

-- | Denotes an inner query.
--   For aggregation, treating sequencing as the cartesian product of queries
--   does not work well.
--   Instead, we treat the sequencing of 'aggregate' with other
--   queries as the cartesian product of the aggregated result of the query,
--   a small but important difference.
--
--   However, for this to work, the aggregate query must not depend on any
--   columns in the outer product. Therefore, we let the aggregate query be
--   parameterized over @Inner s@ if the parent query is parameterized over @s@,
--   to enforce this separation.
data Inner s
  deriving Typeable

-- | Create a named aggregate function.
--   Like 'fun', this function is generally unsafe and should ONLY be used
--   to implement missing backend-specific functionality.
aggr :: SqlType a => Text -> Col s a -> Aggr s b
aggr :: forall a s b. SqlType a => Text -> Col s a -> Aggr s b
aggr Text
f (One Exp SQL a
x)  = forall s a. Exp SQL a -> Aggr s a
Aggr (forall sql a b. Text -> Exp sql a -> Exp sql b
AggrEx Text
f Exp SQL a
x)

-- | Convert one or more inner column to equivalent columns in the outer query.
--   @OuterCols (Aggr (Inner s) a :*: Aggr (Inner s) b) = Col s a :*: Col s b@,
--   for instance.
type family OuterCols a where
  OuterCols (Col (Inner s) a :*: b)  = Col s a :*: OuterCols b
  OuterCols (Col (Inner s) a)        = Col s a
  OuterCols (Row (Inner s) a :*: b)  = Row s a :*: OuterCols b
  OuterCols (Row (Inner s) a)        = Row s a
  OuterCols (Col s a) = TypeError
    ( 'TL.Text "An inner query can only return rows and columns from its own scope."
    )
  OuterCols (Row s a) = TypeError
    ( 'TL.Text "An inner query can only return rows and columns from its own scope."
    )
  OuterCols a = TypeError
    ( 'TL.Text "Only (inductive tuples of) row and columns can be returned from" ':$$:
      'TL.Text "an inner query."
    )

type family AggrCols a where
  AggrCols (Aggr (Inner s) a :*: b) = Col s a :*: AggrCols b
  AggrCols (Aggr (Inner s) a)       = Col s a
  AggrCols (Aggr s a) = TypeError
    ( 'TL.Text "An aggregate query can only return columns from its own" ':$$:
      'TL.Text "scope."
    )
  AggrCols a = TypeError
    ( 'TL.Text "Only (inductive tuples of) aggregates can be returned from" ':$$:
      'TL.Text "an aggregate query."
    )

-- | The results of a left join are always nullable, as there is no guarantee
--   that all joined columns will be non-null.
--   @JoinCols a@ where @a@ is an extensible tuple is that same tuple, but in
--   the outer query and with all elements nullable.
--   For instance:
--
-- >  LeftCols (Col (Inner s) Int :*: Col (Inner s) Text)
-- >    = Col s (Maybe Int) :*: Col s (Maybe Text)
type family LeftCols a where
  LeftCols (Col (Inner s) (Maybe a) :*: b) = Col s (Maybe a) :*: LeftCols b
  LeftCols (Col (Inner s) a :*: b)         = Col s (Maybe a) :*: LeftCols b
  LeftCols (Col (Inner s) (Maybe a))       = Col s (Maybe a)
  LeftCols (Col (Inner s) a)               = Col s (Maybe a)

  LeftCols (Row (Inner s) (Maybe a) :*: b) = Row s (Maybe a) :*: LeftCols b
  LeftCols (Row (Inner s) a :*: b)         = Row s (Maybe a) :*: LeftCols b
  LeftCols (Row (Inner s) (Maybe a))       = Row s (Maybe a)
  LeftCols (Row (Inner s) a)               = Row s (Maybe a)
  LeftCols a = TypeError
    ( 'TL.Text "Only (inductive tuples of) rows and columns can be returned" ':$$:
      'TL.Text "from a join."
    )

-- | One or more aggregate columns.
class Aggregates a where
  unAggrs :: a -> [UntypedCol SQL]
instance Aggregates (Aggr (Inner s) a) where
  unAggrs :: Aggr (Inner s) a -> [UntypedCol SQL]
unAggrs (Aggr Exp SQL a
x) = [forall sql a. Exp sql a -> UntypedCol sql
Untyped Exp SQL a
x]
instance Aggregates b => Aggregates (Aggr (Inner s) a :*: b) where
  unAggrs :: (Aggr (Inner s) a :*: b) -> [UntypedCol SQL]
unAggrs (Aggr Exp SQL a
a :*: b
b) = forall sql a. Exp sql a -> UntypedCol sql
Untyped Exp SQL a
a forall a. a -> [a] -> [a]
: forall a. Aggregates a => a -> [UntypedCol SQL]
unAggrs b
b