content: -----------------------------------------------------------
  -- |
  -- 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
                  | UnionAll
                  | Intersect 
                  | Divide 
                  | Difference
                  deriving (Show)
  
  data SpecialOp  = Order [OrderExpr]
  		| Top Int
  		| Offset 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
                                      UnionAll    -> 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)
  