-----------------------------------------------------------
-- |
-- Module      :  PrimQuery
-- 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
-- 
-- PrimQuery defines the datatype of relational expressions
-- ('PrimQuery') and some useful functions on PrimQuery\'s
--
-- 
-----------------------------------------------------------
module Database.HaskellDB.PrimQuery (
		  -- * Type Declarations

		  -- ** Types
		  TableName, Attribute, Scheme, Assoc, Name

		  -- ** Data types
		 , PrimQuery(..), RelOp(..), SpecialOp(..) 
		 , PrimExpr(..), OrderExpr(..)
                 , BinOp(..), UnOp(..), OrderOp(..), AggrOp(..)
	         , Literal(..)

		  -- * Function declarations
		 , extend, times
		 , attributes, attrInExpr, attrInOrder
		 , substAttr
		 , isAggregate, isConstant
		 , foldPrimQuery, foldPrimExpr
		 ) where

import Data.List ((\\), union)
import Control.Exception (assert)
import System.Time (CalendarTime, formatCalendarTime)
import System.Locale (defaultTimeLocale, iso8601DateFormat)
import Text.PrettyPrint.HughesPJ

-----------------------------------------------------------
-- data definitions
-- PrimQuery is the data type of relational expressions.
-- Since 'Project' takes an association, it is actually a
-- projection- and rename-operator at once.
-----------------------------------------------------------

type TableName  = String
type Attribute  = String
type Name = String
type Scheme     = [Attribute]
type Assoc      = [(Attribute,PrimExpr)]


data PrimQuery  = BaseTable TableName Scheme
                | Project   Assoc PrimQuery
                | Restrict  PrimExpr PrimQuery
                | Group Assoc PrimQuery
                | Binary    RelOp PrimQuery PrimQuery
                | Special   SpecialOp PrimQuery
                | Empty
		deriving (Show)

data RelOp      = Times 
                | Union
                | Intersect 
                | Divide 
                | Difference
                deriving (Show)

data SpecialOp  = Order [OrderExpr]
		| Top Int
		deriving (Show)

data OrderExpr = OrderExpr OrderOp PrimExpr 
		deriving (Show)

data OrderOp = OpAsc | OpDesc
		deriving (Show)

data PrimExpr   = AttrExpr  Attribute
                | BinExpr   BinOp PrimExpr PrimExpr
                | UnExpr    UnOp PrimExpr
                | AggrExpr  AggrOp PrimExpr
                | ConstExpr Literal
		| CaseExpr [(PrimExpr,PrimExpr)] PrimExpr
                | ListExpr [PrimExpr]
                | ParamExpr (Maybe Name) PrimExpr
                | FunExpr Name [PrimExpr]
                | CastExpr Name PrimExpr -- ^ Cast an expression to a given type.
                deriving (Read,Show)

data Literal = NullLit
	     | DefaultLit            -- ^ represents a default value
	     | BoolLit Bool
	     | StringLit String
	     | IntegerLit Integer
	     | DoubleLit Double
	     | DateLit CalendarTime
	     | OtherLit String       -- ^ used for hacking in custom SQL
	       deriving (Read,Show)

data BinOp      = OpEq | OpLt | OpLtEq | OpGt | OpGtEq | OpNotEq 
                | OpAnd | OpOr
                | OpLike | OpIn 
                | OpOther String

                | OpCat
                | OpPlus | OpMinus | OpMul | OpDiv | OpMod
                | OpBitNot | OpBitAnd | OpBitOr | OpBitXor
                | OpAsg
                deriving (Show,Read)

data UnOp	= OpNot 
		| OpIsNull | OpIsNotNull
		| OpLength
		| UnOpOther String
		deriving (Show,Read)

data AggrOp     = AggrCount | AggrSum | AggrAvg | AggrMin | AggrMax
                | AggrStdDev | AggrStdDevP | AggrVar | AggrVarP
                | AggrOther String
                deriving (Show,Read)


-- | Creates a projection of some attributes while
--   keeping all other attributes in the relation visible too. 
extend :: Assoc -> PrimQuery -> PrimQuery
extend assoc query	
	= Project (assoc ++ assoc') query
        where
          assoc'  = assocFromScheme (attributes query)

-- | Takes the cartesian product of two queries.
times :: PrimQuery -> PrimQuery -> PrimQuery
times (Empty) query	= query
times query (Empty)     = query
times query1 query2     = 
    assert (length (attributes query1 \\ attributes query2) == 
		   length (attributes query1))
    Binary Times query1 query2

-- | Returns the schema (the attributes) of a query
attributes :: PrimQuery -> Scheme
attributes (Empty)              = []                            
attributes (BaseTable nm attrs) = attrs
attributes (Project assoc q)    = map fst assoc
attributes (Restrict expr q)    = attributes q
attributes (Special op q)	= attributes q
attributes (Binary op q1 q2)    = case op of
                                    Times       -> attr1 `union` attr2
                                    Union       -> attr1
                                    Intersect   -> attr1
                                    Divide      -> attr1 
                                    Difference  -> attr1
                                where
                                  attr1         = attributes q1
                                  attr2         = attributes q2
attributes (Group _ qry) = attributes qry

-- | Returns a one-to-one association of a
--   schema. ie. @assocFromScheme ["name","city"]@ becomes:
--   @[("name",AttrExpr "name"), ("city",AttrExpr "city")]@
assocFromScheme :: Scheme -> Assoc
assocFromScheme scheme          
		= map (\attr -> (attr,AttrExpr attr)) scheme


-- | Returns all attributes in an expression.
attrInExpr :: PrimExpr -> Scheme
attrInExpr      = concat . foldPrimExpr (attr,scalar,binary,unary,aggr,_case,list,param,func, cast)
                where
                  attr name     = [[name]]
                  scalar s      = [[]]
                  binary op x y = x ++ y
                  unary op x    = x
                  aggr op x	= x
		  _case cs el   = concat (uncurry (++) (unzip cs)) ++ el
                  list xs       = concat xs
                  param _ _ = [[]]
                  func _ es = concat es
                  cast _ expr = expr

-- | Returns all attributes in a list of ordering expressions.
attrInOrder :: [OrderExpr] -> Scheme
attrInOrder os = concat [attrInExpr e | OrderExpr _ e <- os]

-- | Substitute attribute names in an expression.
substAttr :: Assoc -> PrimExpr -> PrimExpr
substAttr assoc 
    = foldPrimExpr (attr,ConstExpr,BinExpr,UnExpr,AggrExpr,CaseExpr,ListExpr,ParamExpr,FunExpr,CastExpr)
        where 
          attr name     = case (lookup name assoc) of
                            Just x      -> x 
                            Nothing     -> AttrExpr name

-- | Determines if a primitive expression represents a constant
-- or is an expression only involving constants.
isConstant :: PrimExpr -> Bool
isConstant x = countAttr x == 0
  where
    countAttr = foldPrimExpr (const 1, const 0, binary, unary, aggr, _case, list, 
                                    const2 1, const2 1, cast)
      where
        _case cs el = sum (map (uncurry (+)) cs) + el
        list = sum 
        const2 a _ _ = a
        binary _ x y = x + y
        unary _ x = x
        aggr _ x = x
        cast _ n = n

isAggregate :: PrimExpr -> Bool
isAggregate x = countAggregate x > 0

countAggregate :: PrimExpr -> Int
countAggregate
	= foldPrimExpr (const 0, const 0, binary, unary, aggr, _case, list,(\_ _ -> 0), (\_ n -> sum n), cast)
	where
          binary op x y	 	= x + y
          unary op x		= x
          aggr op x		= x + 1
	  _case cs el           = sum (map (uncurry (+)) cs) + el
          list xs               = sum xs
          cast _ e = e

-- | Fold on 'PrimQuery'
foldPrimQuery :: (t, TableName -> Scheme -> t, Assoc -> t -> t,
                  PrimExpr -> t -> t, RelOp -> t -> t -> t,
                  Assoc -> t -> t, SpecialOp -> t -> t) -> PrimQuery -> t
foldPrimQuery (empty,table,project,restrict,binary,group,special) 
        = fold
        where
          fold (Empty)  = empty
          fold (BaseTable name schema)
                        = table name schema
          fold (Project assoc query)
                        = project assoc (fold query)
          fold (Restrict expr query)
                        = restrict expr (fold query)
          fold (Binary op query1 query2)
                        = binary op (fold query1) (fold query2)
          fold (Group assocs query)
                        = group assocs (fold query)
          fold (Special op query)
          		= special op (fold query)
-- | Fold on 'PrimExpr'
foldPrimExpr :: (Attribute -> t, Literal -> t, BinOp -> t -> t -> t,
                 UnOp -> t -> t, AggrOp -> t -> t, 
		 [(t,t)] -> t -> t, [t] -> t, Maybe Name -> t -> t, Name -> [t] -> t, Name -> t -> t) -> PrimExpr -> t
foldPrimExpr (attr,scalar,binary,unary,aggr,_case,list,param,fun,cast) 
        = fold
        where
          fold (AttrExpr name) = attr name
          fold (ConstExpr s)   = scalar s
          fold (BinExpr op x y)= binary op (fold x) (fold y)
          fold (UnExpr op x)   = unary op (fold x)
          fold (AggrExpr op x) = aggr op (fold x)
	  fold (CaseExpr cs el) = _case (map (both fold) cs) (fold el)
          fold (ListExpr xs) = list (map fold xs)
          fold (ParamExpr n value) = param n (fold value)
          fold (FunExpr n exprs) = fun n (map fold exprs)
          fold (CastExpr n expr) = cast n (fold expr)

          both f (x,y) = (f x, f y)