content: {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances
    , FlexibleContexts, UndecidableInstances
    , TypeSynonymInstances #-}
  -----------------------------------------------------------
  -- |
  -- Module      :  Query
  -- Copyright   :  Daan Leijen (c) 1999, daan@cs.uu.nl
  --                HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
  -- License     :  BSD-style
  -- 
  -- Maintainer  :  haskelldb-users@lists.sourceforge.net
  -- Stability   :  experimental
  -- Portability :  non portable
  -- 
  -- Basic combinators for building type-safe queries.
  -- The Query monad constructs a relational expression
  -- ('PrimQuery'). 
  --
  -- 
  -----------------------------------------------------------
  module Database.HaskellDB.Query (
  	      -- * Data and class declarations
  	     Rel(..), Attr(..), Table(..), Query, Expr(..), OrderExpr
  	     , ToPrimExprs, ConstantRecord
  	     , ShowConstant(..), ExprC(..), ProjectExpr, ProjectRec, InsertRec
  	     , ExprAggr(..), ExprDefault(..)
  	     , copy, copyAll, RelToRec
  	      -- * Operators
  	     , (.==.) , (.<>.), (.<.), (.<=.), (.>.), (.>=.)
  	     , (.&&.) , (.||.)
  	     , (.*.), (./.), (.+.), (.-.), (.%.), (.++.)
               , (<<), (<<-)
  	      -- * Function declarations
  	     , project, restrict, table, unique
  	     , union, unionAll, intersect, divide, minus
  	     , _not, like, _in, cat, _length
  	     , isNull, notNull
  	     , fromNull, fromVal
  	     , constant, constVal, constNull, constExpr
  	     , param, namedParam, Args, func, cast
  	     , toStr, coerce , select
  	     , count, _sum, _max, _min, avg , literal
  	     , stddev, stddevP, variance, varianceP
  	     , asc, desc, order , top, offset
  	     , _case , _default
  	     -- * Internals
  	     , runQuery, runQueryRel, unQuery
  	     , subQuery
  	     , attribute, attributeName, tableName, baseTable, emptyTable
  	     , exprs, labels, tableRec 
  	     , constantRecord
  	     ) where
  import Database.HaskellDB.HDBRec 
  import Database.HaskellDB.PrimQuery
  import Database.HaskellDB.BoundedString
  import Database.HaskellDB.BoundedList
  
  import Control.Applicative
  import Control.Monad
  import System.Time (CalendarTime)
  
  -----------------------------------------------------------
  -- Operators
  -----------------------------------------------------------
  
  infix   8 `like`, `_in`
  infixl  7 .*., ./., .%.
  infixl  6 .+.,.-.
  infix   6 <<, <<-
  infixr  5 .++.
  infix   4 .==., .<>., .<., .<=., .>., .>=.
  infixr  3 .&&.
  infixr  2 .||.
  
  ----------------------------------------------------------
  -- Data definitions. 
  ----------------------------------------------------------
  
  -- | Type of relations, contains the attributes
  --   of the relation and an 'Alias' to which the
  --   attributes are renamed in the 'PrimQuery'.
  data Rel r      = Rel Alias Scheme
  
  -- | Type of normal expressions, contains the untyped PrimExpr.
  newtype Expr a     = Expr PrimExpr
  		deriving (Read, Show)
  
  -- | Type of aggregate expressions.
  newtype ExprAggr a = ExprAggr PrimExpr deriving (Read, Show)
  
  -- | The type of default expressions.
  newtype ExprDefault a = ExprDefault PrimExpr deriving (Read, Show)
  
  -- | Basic tables, contains table name and an
  --   association from attributes to attribute
  --   names in the real table.
  data Table r    = Table TableName Assoc
  
  -- | Typed attributes
  data Attr f a   = Attr Attribute
  
  type Alias      = Int
  
  -- | A Query monad provides unique names (aliases)
  --   and constructs a PrimQuery.
  type QState     = (Alias,PrimQuery)
  
  data Query a    = Query (QState -> (a,QState))
  
  
  scheme :: Rel r -> Scheme
  scheme (Rel _ s) = s
  
  attributeName :: Attr f a -> Attribute
  attributeName (Attr name) = name
  
  -----------------------------------------------------------
  -- Expression and record classes.
  -----------------------------------------------------------
  
  -- | Class of expression types.
  class ExprC e where
      -- | Get the underlying untyped 'PrimExpr'.
      primExpr :: e a -> PrimExpr
  instance ExprC Expr where primExpr ~(Expr e) = e
  instance ExprC ExprAggr where primExpr ~(ExprAggr e) = e
  instance ExprC ExprDefault where primExpr ~(ExprDefault e) = e
  
  -- | Class of expressions that can be used with 'insert'.
  class ExprC e => InsertExpr e
  instance InsertExpr Expr
  instance InsertExpr ExprDefault
  
  -- | Class of records that can be used with 'insert'. 
  --   All all the values must be instances of 'InsertExpr' for the
  --   record to be an instance of 'InsertRec'.
  class InsertRec r er | r -> er
  instance InsertRec RecNil RecNil
  instance (InsertExpr e, InsertRec r er) => 
    InsertRec (RecCons f (e a) r) (RecCons f (Expr a) er)
  
  -- | Class of expressions that can be used with 'project'.
  class ExprC e => ProjectExpr e
  instance ProjectExpr Expr
  instance ProjectExpr ExprAggr
  
  -- | Class of records that can be used with 'project'. 
  --   All all the values must be instances of 'ProjectExpr' for the
  --   record to be an instance of 'ProjectRec'.
  class ProjectRec r er | r -> er
  instance ProjectRec RecNil RecNil
  instance (ProjectExpr e, ProjectRec r er) => 
    ProjectRec (RecCons f (e a) r) (RecCons f (Expr a) er)
  
  -----------------------------------------------------------
  -- Record operators
  -----------------------------------------------------------
  
  -- | Creates a record field.
  --   Similar to '(.=.)', but gets the field label from an 'Attr'.
  ( << ) :: Attr f a        -- ^ Label
         -> e a                        -- ^ Expression
         -> Record (RecCons f (e a) RecNil)  -- ^ New record
  _ << x = RecCons x
  
  -- | Convenience operator for constructing records of constants.
  --   Useful primarily with 'insert'.
  --   @f <<- x@ is the same as @f << constant x@
  ( <<- ) :: ShowConstant a =>
           Attr f a        -- ^ Field label
        -> a                        -- ^ Field value
        -> Record (RecCons f (Expr a) RecNil)  -- ^ New record
  f <<- x = f << constant x
  
  -- | Creates a single-field record from an attribute and a table. Useful
  -- for building projections that will re-use the same attribute name. @copy attr tbl@ is
  -- equivalent to:
  --
  --   @attr .=. (tbl .!. attr)@
  --
  copy :: (HasField f r) => Attr f a -> Rel r -> Record (RecCons f (Expr a) RecNil)
  copy attr tbl = attr << tbl ! attr
  
  -- | Copies all columns in the relation given. Useful for appending
  -- the remaining columns in a table to a projection. For example:
  --
  -- >   query = do
  -- >     tbl <- table some_table
  -- >     project $ copyAll tbl
  --
  -- will add all columns in "some_table" to the query.
  copyAll :: (RelToRec r) => Rel r -> Record r
  copyAll = relToRec
  
  -- | Helper class which gives a polymorphic
  -- copy function that can turn a Rel into a Record.
  class RelToRec a where
    relToRec :: Rel a -> Record a
  
  instance RelToRec RecNil where
    relToRec v = \_ -> unRel v
      where 
        unRel :: Rel r -> r
        unRel = error "unRel RelToRec RecNil"
  
  -- All this type magic takes the first field off the Rel (Record ...) type, 
  -- turns it into a (Record ...) type, and prepends it to the rest of the 
  -- converted record. 
  instance (RelToRec rest, FieldTag f) => RelToRec (RecCons f (Expr a) rest) where
    relToRec t@(Rel v s) = copy (attr . fieldT $ t) t # relToRec (restT t) 
      where
        attr :: FieldTag f => f -> Attr f a
        attr = Attr . fieldName
        fieldT :: Rel (RecCons f a rest) -> f 
        fieldT = error "fieldT"
        restT :: Rel (RecCons f a rest) -> Rel rest
        restT _ = Rel v s
  
  -- | Field selection operator. It is overloaded to work for both
  --   relations in a query and the result of a query.
  --   That is, it corresponds to both '!' and '!.' from the original
  --   HaskellDB. An overloaded operator was selected because users
  --   (and the developers) always forgot to use !. instead of !
  --   on query results.
  instance HasField f r => Select (Attr f a) (Rel r) (Expr a) where
      (!) rel attr = select attr rel
  
  select :: HasField f r => Attr f a -> Rel r -> Expr a
  select (Attr attribute) (Rel alias scheme)
          = Expr (AttrExpr (fresh alias attribute))
  
  -----------------------------------------------------------
  -- Basic relational operators
  -----------------------------------------------------------
  
  -- | Specifies a subset of the columns in the table.
  project :: (ShowLabels r, ToPrimExprs r, ProjectRec r er) => Record r -> Query (Rel er)
  project r
          = do
  	  alias <- newAlias
            let scheme        = labels r
  	      assoc         = zip (map (fresh alias) scheme) (exprs r)
  	  updatePrimQuery (extend assoc)
            return (Rel alias scheme)
  
  -- | Restricts the records to only those who evaluates the 
  -- expression to True.
  restrict :: Expr Bool -> Query ()
  restrict (Expr primExpr) = updatePrimQuery_ (Restrict primExpr)
  
  -- | Restricts the relation given to only return unique records. Upshot
  -- is all projected attributes will be 'grouped'.
  unique :: Query ()
  unique = Query (\(i, primQ) ->
      -- Add all non-aggregate expressions in the query
      -- to a groupby association list. This list holds the name
      -- of the expression and the expression itself. Those expressions
      -- will later by added to the groupby list in the SqlSelect built.
      case nonAggr primQ of
        [] -> ((), (i + 1, primQ)) -- No non-aggregate expressions - no-op.
        newCols -> ((), (i + 1, Group newCols primQ)))
    where
      -- Find all non-aggregate expressions and convert
      -- them to attribute expressions for use in group by.
      nonAggr :: PrimQuery -> Assoc
      nonAggr p = map toAttrExpr . filter (not . isAggregate . snd) . projected $ p 
      toAttrExpr (col, _) = (col, AttrExpr col)
      -- Find all projected columns from subqueries.
      projected :: PrimQuery -> Assoc
      projected (Project cols q) = cols
      projected (Restrict _ q) = projected q
      projected (Binary _ q1 q2) = projected q1 ++ projected q2
      projected (BaseTable tblName cols) = zip cols (map AttrExpr cols)
      projected (Special _ q) = projected q
      -- Group and Empty are no-ops
      projected (Group _ _) = []
      projected Empty  = []
  
  
  -----------------------------------------------------------
  -- Binary operations
  -----------------------------------------------------------
  
  binrel :: RelOp -> Query (Rel r) -> Query (Rel r) -> Query (Rel r)
  binrel op (Query q1) (Query q2)
    = Query (\(i,primQ) ->
        let (Rel a1 scheme1,(j,primQ1)) = q1 (i,primQ)
            (Rel a2 scheme2,(alias,primQ2)) = q2 (j,primQ)
            
            scheme  = scheme1
  
            assoc1  = zip (map (fresh alias) scheme1)
            		(map (AttrExpr . fresh a1) scheme1)
            assoc2  = zip (map (fresh alias) scheme2)
            		(map (AttrExpr . fresh a2) scheme2)
  
            r1      = Project assoc1 primQ1
            r2      = Project assoc2 primQ2
            r       = Binary op r1 r2
        in
            (Rel alias scheme,(alias + 1, times r primQ)) )
  
  -- | Return all records which are present in at least
  --   one of the relations.
  union :: Query (Rel r) -> Query (Rel r) -> Query (Rel r)
  union           = binrel Union
  
  -- | UNION ALL
  unionAll :: Query (Rel r) -> Query (Rel r) -> Query (Rel r)
  unionAll        = binrel UnionAll
  
  -- | Return all records which are present in both relations.
  intersect :: Query (Rel r) -> Query (Rel r) -> Query (Rel r) 
  intersect       = binrel Intersect
  
  -- | Not in SQL92.
  divide :: Query (Rel r) -> Query (Rel r) -> Query (Rel r) 
  divide          = binrel Divide
  
  -- | Return all records from the first relation that are not 
  --   present in the second relation.
  minus :: Query (Rel r) -> Query (Rel r) -> Query (Rel r)
  minus           = binrel Difference
  
  -----------------------------------------------------------
  -- Tables
  -----------------------------------------------------------
  
  -- | Return all records from a specific table.
  table :: (ShowRecRow r) => Table r -> Query (Rel r)
  table (Table name assoc)
          = do
  	  alias <- newAlias
            let newAssoc = map (\(attr,expr) -> (fresh alias attr,expr)) assoc
  	      scheme   = map fst assoc
  	      q        = Project newAssoc (BaseTable name scheme)
  	  updatePrimQuery (times q)
            return (Rel alias scheme)
  
  -- | Get the name of a table.
  tableName :: Table t -> TableName
  tableName (Table n _) = n
  
  -- Type-level function to return the type of a table's row.
  tableRec :: Table (Record r) -> Record r
  tableRec = error "tableRec should never be evaluated."
  
  -- used in table definitions
  baseTable :: (ShowLabels r, ToPrimExprs r) => TableName -> Record r -> Table r
  baseTable t r   = Table t (zip (labels r) (exprs r))
  
  -- | For queries against fake tables, such as
  -- 'information_schema.information_schema_catalog_name'. Useful for
  -- constructing queries that contain constant data (and do not select
  -- from columns) but need a table to select from.
  emptyTable :: TableName -> Table (Record RecNil)
  emptyTable t = Table t []
  
  attribute :: String -> Expr a
  attribute name  = Expr (AttrExpr name)
  
  -----------------------------------------------------------
  -- Expressions
  -----------------------------------------------------------
  -- | Create a named parameter with a default value.
  namedParam :: Name -- ^ Name of the parameter.
    -> Expr a -- ^ Default value for the parameter.
    -> Expr a 
  namedParam n (Expr def) = Expr (ParamExpr (Just n) def) 
  
  -- | Create an anonymous parameter with a default value.
  param :: Expr a -- ^ Default value.
    -> Expr a
  param (Expr def) = Expr (ParamExpr Nothing def) 
  
  unop :: UnOp -> Expr a -> Expr b
  unop op (Expr primExpr)
                  = Expr (UnExpr op primExpr)
  
  binop :: BinOp -> Expr a  -> Expr b -> Expr c
  binop op (Expr primExpr1) (Expr primExpr2)
                  = Expr (BinExpr op primExpr1 primExpr2)
  
  -- | Equality comparison on Exprs, = in SQL.
  (.==.) :: Eq a => Expr a -> Expr a -> Expr Bool
  (.==.) = binop OpEq
  
  -- | Inequality on Exprs, <> in SQL.
  (.<>.) :: Eq a => Expr a -> Expr a -> Expr Bool
  (.<>.) = binop OpNotEq
  
  (.<.) :: Ord a => Expr a -> Expr a -> Expr Bool
  (.<.)  = binop OpLt
  
  (.<=.) :: Ord a => Expr a -> Expr a -> Expr Bool
  (.<=.) = binop OpLtEq
  
  (.>.) :: Ord a => Expr a -> Expr a -> Expr Bool
  (.>.)  = binop OpGt
  
  (.>=.) :: Ord a => Expr a -> Expr a -> Expr Bool
  (.>=.) = binop OpGtEq
  
  -- | The inverse of an Expr Bool.
  _not :: Expr Bool -> Expr Bool
  _not   = unop OpNot
  
  -- | \"Logical and\" on 'Expr', AND in SQL.
  (.&&.):: Expr Bool -> Expr Bool -> Expr Bool
  (.&&.) = binop OpAnd
  
  -- | \"Logical or\" on 'Expr'. OR in SQL.
  (.||.) :: Expr Bool -> Expr Bool -> Expr Bool
  (.||.) = binop OpOr
  
  -- | The HaskellDB counterpart to the SQL LIKE keyword.
  -- In the expresions, % is a wildcard representing any characters
  -- in the same position relavtive to the given characters and
  -- _ is a wildcard representing one character e.g.
  --
  -- > like (constant "ABCDEFFF") (constant "AB%F_F")
  -- 
  -- is true while
  -- 
  -- > like (constant "ABCDEF") (constant "AC%F") 
  -- 
  -- is false.
  --
  -- Note that SQL92 does not specify whether LIKE is case-sensitive or not.
  -- Different database systems implement this differently.
  like :: Expr String -> Expr String -> Expr Bool
  like   = binop OpLike
  
  -- | Returns true if the value of the first operand is
  --   equal to the value of any of the expressions in the 
  --   list operand. 
  _in :: Eq a => Expr a -> [Expr a] -> Expr Bool
  _in (Expr x) ys = Expr (BinExpr OpIn x (ListExpr [y | Expr y <- ys]))
  
  
  -- | Produces the concatenation of two String-expressions.
  cat :: Expr String -> Expr String -> Expr String
  cat = binop OpCat
  
  -- | Concatenates two String-expressions. 
  (.++.) :: Expr String -> Expr String -> Expr String
  (.++.) = cat
  
  -- | Gets the length of a string.
  _length :: Expr String -> Expr Int
  _length = unop OpLength
  
  numop :: Num a => BinOp -> Expr a -> Expr a -> Expr a
  numop   = binop
  
  -- | Addition
  (.+.) :: Num a => Expr a -> Expr a -> Expr a
  (.+.) = numop OpPlus
  -- | Subtraction 
  (.-.) :: Num a => Expr a -> Expr a -> Expr a
  (.-.) = numop OpMinus
  -- | Multiplication
  (.*.) :: Num a => Expr a -> Expr a -> Expr a
  (.*.) = numop OpMul
  -- | Division
  (./.) :: Num a => Expr a -> Expr a -> Expr a
  (./.) = numop OpDiv
  -- | Modulo
  (.%.) :: Num a => Expr a -> Expr a -> Expr a
  (.%.) = numop OpMod
  
  -- | Returns true if the expression is Null.
  isNull :: Expr a -> Expr Bool
  isNull  = unop OpIsNull
  
  -- | The inverse of 'isNull', returns false
  -- if the expression supplied is Null.
  notNull :: Expr a -> Expr Bool
  notNull = unop OpIsNotNull
  
  -- | Creates a conditional expression.
  --   Returns the value of the expression corresponding to the first 
  --   true condition. If none of the conditions are true, the value of
  --   the else-expression is returned.
  _case :: [(Expr Bool, Expr a)] -- ^ A list of conditions and expressions.
        -> Expr a                -- ^ Else-expression. 
        -> Expr a
  _case cs (Expr el) = Expr (CaseExpr [ (c,e) | (Expr c, Expr e) <- cs] el)
  
  -- | Class which can convert BoundedStrings to normal strings,
  -- even inside type constructors. Useful when a field
  -- is defined as a BoundedString (e.g. "Expr BStr10" or "Expr (Maybe BStr20)") but
  -- it needs to be used in an expression context. The example below illustrates a
  -- table with at least two fields, strField and bStrField. The first is defined as
  -- containing strings, the second as containing strings up to 10 characters long. The
  -- @toStr@ function must be used to convert the bStrField into the appropriate type for
  -- projecting as the strField:
  --
  -- > type SomeTable = (RecCons StrField (Expr String)
  -- >                    (RecCons BStrField (Expr BStr10) ... ))
  --
  -- > someTable :: Table SomeTable
  -- > someTable = ...
  --
  -- > strField :: Attr StrField String
  -- > strField = ...
  -- >
  -- > bstrField :: Attr BStrField (BStr10)
  -- > bstrField = ...
  -- > 
  -- > query = do
  -- >  t <- table someTable
  -- >  project $ strField << toStr $ t ! bstrField
  --
  class BStrToStr s d where
    -- | Convert a bounded string to a real string.
    toStr :: s -> d
  
  instance (Size n) => BStrToStr (Expr (BoundedString n)) (Expr String) where
    toStr (Expr e) = (Expr e)
  
  instance (Size n) => BStrToStr (Expr (Maybe (BoundedString n))) (Expr (Maybe String)) where
    toStr (Expr m) = (Expr m)
  
  instance BStrToStr (Expr (Maybe String)) (Expr (Maybe String)) where
    toStr (Expr m) = (Expr m)
  
  instance BStrToStr (Expr String) (Expr String) where
    toStr (Expr m) = (Expr m)
  
  -----------------------------------------------------------
  -- Using arbitrary SQL functions in a type-safe way.
  -----------------------------------------------------------
  
  -- | Used to implement variable length arguments to @func@, below.
  class Args a where
    arg_ :: String -> [PrimExpr] -> a
  
  -- | Used to limit variable argument form of @func@ to only take @Expr@ types,
  -- and ignore @ExprAggr@ types.
  class IsExpr a
  
  instance (IsExpr tail) => IsExpr (Expr a -> tail)
  
  instance IsExpr (Expr a)
  
  instance (IsExpr tail, Args tail) => Args (Expr a -> tail) where
    arg_ name exprs = \(Expr prim) -> arg_ name (prim : exprs)
  
  instance Args (Expr a) where
    -- Reverse necessary because arguments are built in reverse order by instances
    -- of Args above.
    arg_ name exprs = Expr (FunExpr name (reverse exprs))
  
  instance Args (Expr a -> ExprAggr c) where
    arg_ name exprs = \(Expr prim) -> ExprAggr (AggrExpr (AggrOther name) prim)
  
  {- | Can be used to define SQL functions which will
  appear in queries. Each argument for the function is specified by its own Expr value. 
  Examples include:
  
  >  lower :: Expr a -> Expr (Maybe String) 
  >  lower str = func "lower" str
  
  The arguments to the function do not have to be Expr if they can
  be converted to Expr:
  
  >  data DatePart = Day | Century deriving Show 
  
  >  datePart :: DatePart -> Expr (Maybe CalendarTime) -> Expr (Maybe Int) 
  >  datePart date col = func "date_part" (constant $ show date) col
  
  Aggregate functions can also be defined. For example:
  
   >  every :: Expr Bool -> ExprAggr Bool 
   >  every col = func "every" col
  
  Aggregates are implemented to always take one argument, so any attempt to
  define an aggregate with any more or less arguments will result in an error.
  
  Note that type signatures are usually required for each function defined,
  unless the arguments can be inferred.-}
  func :: (Args a) => String -> a 
  func name = arg_ name [] 
  
  -----------------------------------------------------------
  -- Default values
  -----------------------------------------------------------
  
  -- | The default value of the column. Only works with 'insert'.
  _default :: ExprDefault a
  _default = ExprDefault (ConstExpr DefaultLit)
  
  -----------------------------------------------------------
  -- Constants
  -- Maybe we should change the set according to the 
  -- database backend
  -----------------------------------------------------------
  
  class ShowConstant a where
      showConstant :: a -> Literal
  
  instance ShowConstant String where
      showConstant = StringLit
  instance ShowConstant Int where
      showConstant = IntegerLit . fromIntegral
  instance ShowConstant Integer where
      showConstant = IntegerLit
  instance ShowConstant Double where
      showConstant = DoubleLit
  instance ShowConstant Bool where
      showConstant = BoolLit
  
  -- this assumes that all databases accept both date and time even when they
  -- only want date.
  instance ShowConstant CalendarTime where
      showConstant = DateLit
  
  instance ShowConstant a => ShowConstant (Maybe a) where
      showConstant = maybe NullLit showConstant
  
  instance Size n => ShowConstant (BoundedString n) where
      showConstant = showConstant . fromBounded
  
  -- | Creates a constant expression from a haskell value.
  constant :: ShowConstant a => a -> Expr a
  constant x  = Expr (ConstExpr (showConstant x))
  
  -- | Inserts the string literally - no escaping, no quoting.
  literal :: String -> Expr a
  literal x = Expr (ConstExpr (OtherLit x))
  
  -- | Takes a default value a and a nullable value. If the value is NULL,
  --   the default value is returned, otherwise the value itself is returned.
  --   Simliar to 'fromMaybe'
  fromNull :: Expr a         -- ^ Default value (to be returned for 'Nothing')
  	 -> Expr (Maybe a) -- ^ A nullable expression
  	 -> Expr a
  fromNull d x@(Expr px) = _case [(isNull x, d)] (Expr px)
  
  -- | Similar to fromNull, but takes a 
  -- value argument rather than an Expr.
  fromVal :: ShowConstant a => a 
          -> Expr (Maybe a)
          -> Expr a
  fromVal = fromNull . constant 
  
  -- | Turn constant data into a nullable expression. 
  --   Same as @constant . Just@
  constExpr :: Expr a -> Expr (Maybe a)
  constExpr (Expr x) = (Expr x)
  
  -- | Turn constant data into a nullable expression. 
  --   Same as @constant . Just@
  constVal :: ShowConstant a => a -> Expr (Maybe a)
  constVal x = constant (Just x)
  
  -- | Represents a null value.
  constNull :: Expr (Maybe a)
  constNull = Expr (ConstExpr NullLit)
  
  -- | Generates a 'CAST' expression for the given
  -- expression, using the argument given as the destination
  -- type. 
  cast :: String -- ^ Destination type.
    -> Expr a -- ^ Source expression.
    -> Expr b
  cast typ (Expr expr) = Expr (CastExpr typ expr)
  
  -- | Coerce the type of an expression
  -- to another type. Does not affect the actual
  -- primitive value - only the `phantom' type.
  coerce :: Expr a -- ^ Source expression
    -> Expr b -- ^ Destination type.
  coerce (Expr e) = Expr e
  
  -- | Converts records w/o Expr (usually from database
  -- queries) to records with Expr types. 
  class ConstantRecord r cr | r -> cr where
      constantRecord :: r -> cr
  
  instance ConstantRecord r cr => ConstantRecord (Record r) (Record cr) where
      constantRecord r = \n -> constantRecord (r n)
  
  instance ConstantRecord RecNil RecNil where
      constantRecord RecNil = RecNil
  
  instance (ShowConstant a, ConstantRecord r cr)
      => ConstantRecord (RecCons f a r) (RecCons f (Expr a) cr) where
      constantRecord ~(RecCons x rs) = RecCons (constant x) (constantRecord rs)
  
  -----------------------------------------------------------
  -- Aggregate operators
  -----------------------------------------------------------
  
  aggregate :: AggrOp -> Expr a -> ExprAggr b
  aggregate op (Expr primExpr) = ExprAggr (AggrExpr op primExpr)
  
  -- | Returns the number of records (=rows) in a query.
  count :: Expr a -> ExprAggr Int
  count x		= aggregate AggrCount x
  
  -- | Returns the total sum of a column.
  _sum :: Num a => Expr a -> ExprAggr a
  _sum x = aggregate AggrSum x
  
  -- | Returns the highest value of a column.
  _max :: Ord a => Expr a -> ExprAggr a
  _max x = aggregate AggrMax x
  
  -- | Returns the lowest value of a column.
  _min :: Ord a => Expr a -> ExprAggr a
  _min x = aggregate AggrMin x
  
  -- | Returns the average of a column.
  avg :: Num a => Expr a -> ExprAggr a
  avg x = aggregate AggrAvg x
  
  -- | Returns the standard deviation of a column.
  stddev :: Num a => Expr a -> ExprAggr a
  stddev x = aggregate AggrStdDev x
  
  stddevP :: Num a => Expr a -> ExprAggr a
  stddevP x = aggregate AggrStdDevP x
  
  -- | Returns the standard variance of a column.
  variance :: Num a => Expr a -> ExprAggr a
  variance x = aggregate AggrVar x
  
  varianceP :: Num a => Expr a -> ExprAggr a
  varianceP x  = aggregate AggrVarP x
  
  -----------------------------------------------------------
  -- Special ops
  -----------------------------------------------------------
  
  -- | Return the n topmost records.
  top :: Int -> Query ()
  top n = updatePrimQuery_ (Special (Top n))
  
  -- | Skip the n topmost records.
  offset :: Int -> Query ()
  offset n = updatePrimQuery_ (Special (Offset n))
  
  -----------------------------------------------------------
  -- Ordering results
  -----------------------------------------------------------
  
  orderOp :: HasField f r => OrderOp -> Rel r -> Attr f a -> OrderExpr
  orderOp op rel attr = OrderExpr op expr
      where Expr expr = select attr rel
  
  -- | Use this together with the function 'order' to 
  -- order the results of a query in ascending order.
  -- Takes a relation and an attribute of that relation, which
  -- is used for the ordering.
  asc :: HasField f r => Rel r -> Attr f a -> OrderExpr
  asc rel attr = orderOp OpAsc rel attr
  
  -- | Use this together with the function 'order' to 
  -- order the results of a query in descending order.
  -- Takes a relation and an attribute of that relation, which
  -- is used for the ordering.
  desc :: (HasField f r) => Rel r -> Attr f a -> OrderExpr
  desc rel attr = orderOp OpDesc rel attr
  
  -- | Order the results of a query.
  -- Use this with the 'asc' or 'desc' functions.
  order :: [OrderExpr] -> Query ()
  order xs = updatePrimQuery_ (Special (Order xs))
  
  -----------------------------------------------------------
  -- Query Monad
  -----------------------------------------------------------
  
  unQuery :: Query a -> a
  unQuery (Query g) = fst $ g (1, Empty)
  
  runQuery :: Query (Rel r) -> PrimQuery
  runQuery = fst . runQueryRel
  
  runQueryRel :: Query (Rel r) -> (PrimQuery,Rel r)
  runQueryRel (Query f)
          = let (Rel alias scheme,(i,primQuery)) = f (1,Empty)
                assoc   = zip scheme (map (AttrExpr . fresh alias) scheme)
            in  (Project assoc primQuery, Rel 0 scheme)
  
  -- | Allows a subquery to be created between another query and
  -- this query. Normally query definition is associative and query definition
  -- is interleaved. This combinator ensures the given query is
  -- added as a whole piece.
  subQuery :: Query (Rel r) -> Query (Rel r)
  subQuery (Query qs) = Query make
    where
      make (currentAlias, currentQry) =
          -- Take the query to add and run it first, using the current alias as
          -- a seed.
          let (Rel otherAlias otherScheme,(newestAlias, otherQuery)) = qs (currentAlias,Empty)
              -- Effectively renames all columns in otherQuery to make them unique in this
              -- query.
              assoc = zip (map (fresh newestAlias) otherScheme)
                          (map (AttrExpr . fresh otherAlias) otherScheme)
              -- Produce a query which is a cross product of the other query and the current query.
          in (Rel newestAlias otherScheme, (newestAlias + 1, times (Project assoc otherQuery) currentQry))
              
  instance Functor Query where
    fmap f (Query g)      = Query (\q0 -> let (x,q1) = g q0  in (f x,q1))
  
  instance Monad Query where
    return x              = Query (\q0 -> (x,q0))
    (Query g) >>= f       = Query (\q0 -> let (x,q1)    = g q0
                                              (Query h) = f x
                                          in  (h q1))
  
  instance Applicative Query where
    pure  = return
    (<*>) = ap
  
  updatePrimQuery :: (PrimQuery -> PrimQuery) -> Query PrimQuery
  updatePrimQuery f  = Query (\(i,qt) -> (qt,(i,f qt)))
  
  updatePrimQuery_ :: (PrimQuery -> PrimQuery) -> Query ()
  updatePrimQuery_ f = updatePrimQuery f >> return ()
  
  newAlias :: Query Alias
  newAlias                = Query (\(i,qt) -> (i,(i+1,qt)))
  
  -- fresh 0 is used in the 'Database' module
  fresh :: Alias -> Attribute -> Attribute
  fresh 0     attribute   = attribute
  fresh alias attribute   = (attribute ++ show alias)
  
  labels :: ShowLabels r => r -> [String]
  labels = recordLabels
  
  -- Type safe version of exprs below. If we use this, we must add
  --  ToPrimExprs r to a lot of functions
  exprs :: ToPrimExprs r => Record r -> [PrimExpr]
  exprs r = toPrimExprs (r RecNil)
  
  class ToPrimExprs r where
      toPrimExprs :: r -> [PrimExpr]
  
  instance ToPrimExprs RecNil where
      toPrimExprs ~RecNil = []
  
  instance (ExprC e, ToPrimExprs r) => ToPrimExprs (RecCons l (e a) r) where
      toPrimExprs ~(RecCons e r) = primExpr e : toPrimExprs r
  
  