{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE TemplateHaskell #-}

module Database.Algebra.SQL.Tile
    ( TileTree (TileNode, ReferenceLeaf)
    , TileChildren
    , ExternalReference
    , InternalReference
    , DependencyList
    , TransformResult
    , transform
    , TADag
    ) where

-- TODO maybe split this file into the tile definition
--      and the transform things.
-- TODO embed closing tiles as subqueries (are there any sub queries which are
-- correlated?)? (reader?)
-- TODO isMultiReferenced special case: check for same parent !!

import           Control.Arrow                    (second)
import           Control.Monad.RWS.Strict
import qualified Data.DList                       as DL (DList, singleton)
import qualified Data.IntMap                      as IntMap
import           Data.Maybe
import           GHC.Exts                         hiding (inline)

import qualified Database.Algebra.Dag             as D
import qualified Database.Algebra.Dag.Common      as C
import           Database.Algebra.Impossible
import qualified Database.Algebra.Table.Lang      as A

import qualified Database.Algebra.SQL.Query       as Q
import           Database.Algebra.SQL.Termination
import Database.Algebra.SQL.Query.Util

-- | A tile internal reference type.
type InternalReference = Q.ReferenceType

-- | The type used to reference table expressions outside of a tile.
type ExternalReference = Int

-- | Aliased tile children, where the first part is the alias used within the
-- 'Q.SelectStmt'.
type TileChildren = [(InternalReference, TileTree)]

-- | Defines the tile tree structure.
data TileTree = -- | A tile: The first argument determines which features the
                -- 'Q.SelectStmt' uses.
                TileNode FeatureSet Q.SelectStmt TileChildren
                -- | A reference pointing to another TileTree: The second
                -- argument specifies the columns of the referenced table
                -- expression.
              | ReferenceLeaf ExternalReference [String]

-- | Table algebra DAGs
type TADag = D.AlgebraDag A.TableAlgebra

-- | Association list (where dependencies should be ordered topologically).
type DependencyList = DL.DList (ExternalReference, TileTree)


-- | A combination of types which need to be modified state wise while
-- transforming:
--     * The processed nodes with multiple parents.
--
--     * The current state of the table id generator.
--
--     * The current state of the variable id generator.
--
data TransformState = TS
                    { multiParentNodes :: IntMap.IntMap ( ExternalReference
                                                        , [String]
                                                        )
                    , tableIdGen       :: ExternalReference
                    , aliasIdGen       :: Int
                    , varIdGen         :: InternalReference
                    }

-- | The initial state.
sInitial :: TransformState
sInitial = TS IntMap.empty 0 0 0

-- | Adds a new binding to the state.
sAddBinding :: C.AlgNode          -- ^ The key as a node with multiple parents.
            -> ( ExternalReference
               , [String]
               )                  -- ^ Name of the reference and its columns.
            -> TransformState
            -> TransformState
sAddBinding node t st =
    st { multiParentNodes = IntMap.insert node t $ multiParentNodes st}

-- | Tries to look up a binding for a node.
sLookupBinding :: C.AlgNode
               -> TransformState
               -> Maybe (ExternalReference, [String])
sLookupBinding n = IntMap.lookup n . multiParentNodes

-- | The transform monad is used for transforming DAGs into dense tiles, it
-- is built from:
--
--     * A reader for the DAG
--
--     * A writer for outputting the dependencies
--
--     * A state for generating fresh names and maintain the mapping of nodes
--
type Transform = RWS TADag DependencyList TransformState

-- | A table expression id generator using the state within the
-- 'Transform' type.
freshTableId :: Transform ExternalReference
freshTableId = do
    st <- get

    let tid = tableIdGen st

    put $ st { tableIdGen = succ tid }

    return tid

freshAlias :: Transform String
freshAlias = do
    st <- get

    let aid = aliasIdGen st

    put $ st { aliasIdGen = succ aid }

    return $ 'a' : show aid

-- | A variable identifier generator.
freshVariableId :: Transform InternalReference
freshVariableId = do
    st <- get

    let vid = varIdGen st

    put $ st { varIdGen = succ vid }

    return vid

-- | Unpack values (or run computation).
runTransform :: Transform a
             -> TADag               -- ^ The used DAG.
             -> TransformState      -- ^ The inital state.
             -> (a, DependencyList)
runTransform = evalRWS

-- | Check if node has more than one parent.
isMultiReferenced :: C.AlgNode
                  -> TADag
                  -> Bool
isMultiReferenced n dag = case D.parents n dag of
    -- Has at least 2 parents.
    _:(_:_) -> True
    _       -> False

-- | Get the column schema of a 'TileNode'.
getSchemaTileTree :: TileTree -> [String]
getSchemaTileTree (ReferenceLeaf _ s) = s
getSchemaTileTree (TileNode _ body _) = getSchemaSelectStmt body

-- | Get the column schema of a 'Q.SelectStmt'.
getSchemaSelectStmt :: Q.SelectStmt -> [String]
getSchemaSelectStmt s = map Q.sName $ Q.selectClause s

-- | The result of the 'transform' function.
type TransformResult = ([TileTree], DependencyList)

-- | Transform a 'TADag', while swapping out repeatedly used sub expressions
-- (nodes with more than one parent).
-- A 'TADag' can have multiple root nodes, and therefore the function returns a
-- list of root tiles and their dependencies.
transform :: TADag -> TransformResult
transform dag = runTransform result dag sInitial
  where
    rootNodes = D.rootNodes dag
    result    = mapM transformNode rootNodes

-- | This function basically checks for already referenced nodes with more than
-- one parent, returning a reference to already computed 'TileTree's.
transformNode :: C.AlgNode -> Transform TileTree
transformNode n = do

    op <- asks $ D.operator n

    -- allowBranch indicates whether multi reference nodes shall be split
    -- for this operator, resulting in multiple equal branches. (Treeify)
    let (allowBranch, transformOp) = case op of
                                   -- Ignore branching for nullary operators.
            (C.NullaryOp nop)   -> (False, transformNullaryOp nop)
            (C.UnOp uop c)      -> (True, transformUnOp uop c)
            (C.BinOp bop c0 c1) -> (True, transformBinOp bop c0 c1)
            (C.TerOp () _ _ _)  -> $impossible

    multiRef <- asks $ isMultiReferenced n

    if allowBranch && multiRef
    then do
        -- Lookup whether there exists a binding for the node in the current
        -- state.
        possibleBinding <- gets $ sLookupBinding n

        case possibleBinding of
            -- If so, just return it.
            Just (b, s) -> return $ ReferenceLeaf b s
            -- Otherwise add it.
            Nothing     -> do

                resultingTile <- transformOp

                -- Generate a name for the sub tree.
                tableId <- freshTableId

                -- Add the tree to the writer.
                tell $ DL.singleton (tableId, resultingTile)

                let schema = getSchemaTileTree resultingTile

                -- Add binding for this node (to prevent recalculation).
                modify $ sAddBinding n (tableId, schema)

                return $ ReferenceLeaf tableId schema
    else transformOp

transformNullaryOp :: A.NullOp -> Transform TileTree
transformNullaryOp (A.LitTable (tuples, typedSchema)) = do
    tableAlias <- freshAlias

    let -- Abstracts over the differences.
        tile otherFeatures tuples' wClause =
            TileNode (otherFeatures <> tableF)
                     emptySelectStmt
                     { Q.selectClause = columnsFromSchema tableAlias schema
                     , Q.fromClause   =
                         [ Q.FPAlias (Q.FESubQuery $ Q.VQLiteral tuples')
                                     tableAlias
                                     $ Just schema
                         ]
                     , Q.whereClause  = wClause
                     }
                     []

    return $ case tuples of
        [] -> tile (projectF <> filterF)
                   [map (castedNull . snd) typedSchema]
                   [Q.CEBase . Q.VEValue $ Q.VBoolean False]
        _  -> tile projectF
                   (map (map translateLit) tuples)
                   []
  where
    schema        = map fst typedSchema
    castedNull ty = Q.CEBase $ Q.VECast (Q.CEBase $ Q.VEValue Q.VNull)
                                         (translateATy ty)
    translateLit  = Q.CEBase . Q.VEValue . translateAVal

transformNullaryOp (A.TableRef (name, typedSchema, _))   = do
    tableAlias <- freshAlias

    return $ TileNode (projectF <> tableF)
                      emptySelectStmt
                      { -- Map the columns of the table reference to the given
                        -- column names.
                        Q.selectClause = columnsFromSchema tableAlias schema
                      , Q.fromClause   =
                              [ Q.FPAlias (Q.FETableReference name)
                                          tableAlias
                                          -- Map to old column name.
                                          $ Just schema
                              ]
                      }
                      []
  where
    schema = map fst typedSchema

-- | Abstraction for rank operators.
transformUnOpRank :: -- ExtendedExpr constructor.
                     Q.WindowFunction
                  -> (String, [A.SortSpec])
                  -> C.AlgNode
                  -> Transform TileTree
transformUnOpRank rankFun (name, sortList) =
    attachColFunUnOp colFun $ projectF <> windowFunctionF
  where
    colFun sClause = Q.SCAlias rankExpr name

      where
        rankExpr = Q.EEWinFun rankFun
                              []
                              (asWindowOrderExprList sClause sortList)
                              Nothing

transformUnOp :: A.UnOp -> C.AlgNode -> Transform TileTree
transformUnOp (A.Serialize (mDescr, pos, payloadCols)) c = do
    (ctor, select, children) <- transformTerminated' c $ projectF <> sortF

    let inline :: String -> Q.ExtendedExpr
        inline                      = inlineEE $ Q.selectClause select

        -- Inline a column and alias the result.
        project :: String -> String -> Q.SelectColumn
        project col alias = Q.SCAlias (inline col) alias

        itemi i                     = "item" ++ show i
    
        payloadProjs :: [Q.SelectColumn]
        payloadProjs                =
            zipWith (\(A.PayloadCol col) i -> project col $ itemi i)
                    payloadCols
                    ([1..] :: [Integer])

        boundNames = map itemi [1..length payloadCols]

        inlineOrderBy col = if col `elem` boundNames
                            then Q.EEBase $ Q.VEColumn col Nothing
                            else inline col

        (posOrderList, posProjList) = case pos of
            A.NoPos       -> ([], [])
            -- Sort and project (avoid inlining, because not
            -- necessary: The pos column will appear in the select
            -- clause and can be referenced in the order by clause).
            A.AbsPos col  -> ([Q.EEBase $ mkCol "pos"], [(col, "pos")])
            -- Sort but do not project. It is not necessary because
            -- relative positions are not needed to reconstruct nested
            -- results. But: only inline those sorting columns that do
            -- not appear in the select clause. Names bound in the
            -- select clause are visible in the order by clause and
            -- can be referenced.
            A.RelPos cols -> (map inlineOrderBy cols, [])

    return $ ctor
             select
             { Q.selectClause =
                   map (uncurry project) (descrProjAdder posProjList)
                   ++ payloadProjs
             , -- Order by optional columns. Remove constant column expressions,
               -- since SQL99 defines different semantics.
               Q.orderByClause =
                   map (`Q.OE` Q.Ascending)
                       . filter affectsSortOrderEE
                       . descrColAdder
                       $ posOrderList
             }
             children
  where
    (descrColAdder, descrProjAdder) = case mDescr of
        Nothing               -> (id, id)
        -- Project and sort. Since descr gets added as new alias we can use it
        -- in the ORDER BY clause (also avoid inlining).
        Just (A.DescrCol col) -> ( (:) $ Q.EEBase $ mkCol "descr"
                                 , (:) (col, "descr")
                                 )



transformUnOp (A.RowNum (name, sortList, partExprs)) c =
    attachColFunUnOp colFun
                     (projectF <> windowFunctionF)
                     c
  where
    colFun sClause = Q.SCAlias rowNumExpr name
        where
          -- ROW_NUMBER() OVER (PARTITION BY p ORDER BY s)
          rowNumExpr = Q.EEWinFun Q.WFRowNumber
                                  (map (translateExprAE $ Just sClause) partExprs)
                                  (asWindowOrderExprList sClause sortList)
                                  Nothing

transformUnOp (A.WinFun ((name, fun), partExprs, sortExprs, mFrameSpec)) c =
    attachColFunUnOp colFun
                     (projectF <> windowFunctionF)
                     c

  where
    colFun sClause = Q.SCAlias winFunExpr name
      where
        winFunExpr = Q.EEWinFun (translateWindowFunction translateE fun)
                                (map (translateExprAE $ Just sClause) partExprs)
                                (asWindowOrderExprList sClause sortExprs)
                                (fmap translateFrameSpec mFrameSpec)

        translateE = translateExprCE $ Just sClause

transformUnOp (A.RowRank inf) c = transformUnOpRank Q.WFDenseRank inf c
transformUnOp (A.Rank inf) c = transformUnOpRank Q.WFRank inf c
transformUnOp (A.Project projList) c = do
    
    (ctor, select, children) <- transformTerminated' c projectF

    let -- Inlining is obligatory here, since we possibly eliminate referenced
        -- columns. ('translateExpr' inlines columns.)
        translateAlias :: (A.Attr, A.Expr) -> Q.SelectColumn
        translateAlias (col, expr) = Q.SCAlias translatedExpr col
          where
            translatedExpr = translateExprEE (Just $ Q.selectClause select) expr

    return $ ctor select
                  -- Replace the select clause with the projection list.
                  { Q.selectClause = map translateAlias projList }
                  -- But use the old children.
                  children

transformUnOp (A.Select expr) c = do

    (ctor, select, children) <- transformTerminated' c filterF
    
    return $ ctor ( appendToWhere ( translateExprCE
                                    (Just $ Q.selectClause select)
                                    expr
                                  )
                    select
                  )
                  children

transformUnOp (A.Distinct ()) c = do

    (ctor, select, children) <- transformTerminated' c dupElimF

    -- Keep everything but set distinct.
    return $ ctor select { Q.distinct = True } children

transformUnOp (A.Aggr (aggrs, partExprMapping)) c = do

    (ctor, select, children) <- transformTerminated' c $ projectF <> aggrAndGroupingF
    
    let justSClause       = Just $ Q.selectClause select
        translateE        = translateExprCE justSClause
        -- Inlining here is obligatory, since we could eliminate referenced
        -- columns. (This is similar to projection.)
        aggrToEE (a, n)   = 
            Q.SCAlias ( let (fun, optExpr) = translateAggrType a
                        in Q.EEAggrExpr
                           $ Q.AEAggregate (liftM translateE optExpr)
                                           fun
                      )
                      n

        partColumnExprs   = map (second translateE) partExprMapping
        partExtendedExprs = map (second $ translateExprEE $ justSClause)
                                partExprMapping


        wrapSCAlias (name, extendedExpr)
                          =
            Q.SCAlias extendedExpr name

    return $ ctor select
                  { Q.selectClause =
                        map wrapSCAlias partExtendedExprs
                        ++ map aggrToEE aggrs
                  , -- Since SQL treats numbers in the group by clause as
                    -- column indices, filter them out. (They do not change
                    -- the semantics anyway.)
                    Q.groupByClause =
                        filter affectsSortOrderCE $ map snd partColumnExprs
                  }
                  children

-- | Generates a new 'TileTree' by attaching a column, generated by a function
-- taking the select clause.
attachColFunUnOp :: ([Q.SelectColumn] -> Q.SelectColumn)
                 -> FeatureSet
                 -> C.AlgNode
                 -> Transform TileTree
attachColFunUnOp colFun opFeatures c = do

    (ctor, select, children) <- transformTerminated' c opFeatures

    let sClause = Q.selectClause select

    -- Attach a column to the select clause generated by the
    -- given function.
    return $ case colFun sClause of
                 col@(Q.SCAlias _ name) ->
                     ctor select { Q.selectClause = col : pruneCol name sClause }
                          children
                 col@Q.SCExpr{}         -> 
                     ctor select { Q.selectClause = col : sClause }
                          children

pruneCol :: String -> [Q.SelectColumn] -> [Q.SelectColumn]
pruneCol n cols = filter namePred cols
  where
    namePred (Q.SCAlias _ n') | n == n' = False
    namePred _                          = True

-- | Abstracts over binary set operation operators.
transformBinSetOp :: Q.SetOperation
                  -> C.AlgNode
                  -> C.AlgNode
                  -> Transform TileTree
transformBinSetOp setOp c0 c1 = do

    -- Use one tile to get the schema information.
    (_, select0, children0) <- transformTerminated c0 noneF
    (_, select1, children1) <- transformTerminated c1 noneF

    -- Impose a canonical order on entries in the SELECT clauses to
    -- ensure that schemata of the set operator inputs match.
    let select0' = select0 { Q.selectClause = sortWith Q.sName $ Q.selectClause select0 }
        select1' = select1 { Q.selectClause = sortWith Q.sName $ Q.selectClause select1 }

    tableAlias <- freshAlias

    -- Take the schema of the first one, but could also be from the second one,
    -- since we assume they are equal.
    let schema = getSchemaSelectStmt select0'

    return $ TileNode (projectF <> tableF)
                      emptySelectStmt
                      { Q.selectClause =
                            columnsFromSchema tableAlias schema
                      , Q.fromClause =
                            [ Q.FPAlias ( Q.FESubQuery
                                          $ Q.VQBinarySetOperation
                                            (Q.VQSelect select0')
                                            (Q.VQSelect select1')
                                            setOp
                                        )
                                        tableAlias
                                        $ Just schema
                            ]
                      }
                      $ children0 ++ children1

-- | Perform a cross join between two nodes.
transformBinCrossJoin :: C.AlgNode
                      -> C.AlgNode
                      -> Transform ( FeatureSet
                                   , Q.SelectStmt
                                   , TileChildren
                                   )
transformBinCrossJoin c0 c1 = do

    (childFeatures0, select0, children0) <- transformF c0
    (childFeatures1, select1, children1) <- transformF c1

    -- We can simply concatenate everything, because all things are prefixed and
    -- cross join is associative.
    return ( mconcat [childFeatures0, childFeatures1, opFeatures]
           , emptySelectStmt
             { Q.selectClause =
                   Q.selectClause select0 ++ Q.selectClause select1
             , Q.fromClause =
                   Q.fromClause select0 ++ Q.fromClause select1
             , Q.whereClause = Q.whereClause select0
                               ++ Q.whereClause select1
             }
           , children0 ++ children1
           )
  where
    transformF c = transformTerminated c opFeatures
    opFeatures   = projectF <> tableF <> filterF

transformBinOp :: A.BinOp
               -> C.AlgNode
               -> C.AlgNode
               -> Transform TileTree
transformBinOp (A.Cross ()) c0 c1 = do
    (f, s, c) <- transformBinCrossJoin c0 c1
    return $ TileNode f s c

transformBinOp (A.EqJoin (lName, rName)) c0 c1 = do

    (childrenFeatures, select, children) <- transformBinCrossJoin c0 c1

    let sClause = Q.selectClause select
        cond    = Q.CEBase $ Q.VEBinApp Q.BFEqual (inlineCE sClause lName)
                                                  $ inlineCE sClause rName

    -- 'transformBinCrossJoin' already has the 'filterF' feature.
    return $ TileNode childrenFeatures (appendToWhere cond select) children


transformBinOp (A.ThetaJoin conditions) c0 c1  = do

    when (null conditions) $impossible

    (childrenFeatures, select, children) <- transformBinCrossJoin c0 c1

    let sClause = Q.selectClause select
        conds   = map f conditions
        f       = translateJoinCond sClause sClause

    return $ TileNode childrenFeatures
                        (appendAllToWhere conds select)
                        children

transformBinOp (A.SemiJoin cs) c0 c1          =
    transformExistsJoin cs c0 c1 id
transformBinOp (A.AntiJoin cs) c0 c1          =
    transformExistsJoin cs c0 c1 (Q.CEBase . Q.VENot)
transformBinOp (A.DisjUnion ()) c0 c1         =
    transformBinSetOp Q.SOUnionAll c0 c1
transformBinOp (A.Difference ()) c0 c1        =
    transformBinSetOp Q.SOExceptAll c0 c1

transformExistsJoin :: [(A.Expr, A.Expr, A.JoinRel)]
                    -> C.AlgNode 
                    -> C.AlgNode
                    -> (Q.ColumnExpr -> Q.ColumnExpr)
                    -> Transform TileTree
transformExistsJoin conditions c0 c1 wrapFun = do

    when (null conditions) $impossible

    (ctor0, select0, children0) <- transformTerminated' c0 filterF

    -- Ignore operator features, since it will be nested and therefore
    -- terminated.
    (_, select1, children1) <- transformTerminated c1 noneF

    let ctor s = ctor0 s $ children0 ++ children1
    
    -- Split the conditions into the first equality condition found and the
    -- remaining ones.
    case foldr findEq (Nothing, []) conditions of
        -- We did not find an equality condition, use the EXISTS construct.
        (Nothing, _)               -> do
            -- TODO in case we do not have merge conditions we can simply use
            -- the unmergeable but less nested select stmt on the right side

            let outerCond   = wrapFun . Q.CEBase
                                      . Q.VEExists
                                      $ Q.VQSelect innerSelect
                innerSelect = appendAllToWhere innerConds select1
                innerConds  = map f conditions
                f           = translateJoinCond (Q.selectClause select0)
                                                $ Q.selectClause select1

            return $ ctor (appendToWhere outerCond select0)
        -- We did find an equality condition, use it with the IN construct.
        (Just (l, r), conditions') -> do
           
            let -- Embedd the right query into the where clause of the left one.
                leftCond    =
                    wrapFun . Q.CEBase
                            . Q.VEIn (translateExprCE (Just lSClause) l)
                            $ rightSelect'
    
                -- If the nested query is a simple selection from a
                -- literal table, use the literal table directly:
                -- SELECT t.c FROM (VALUES ...) AS t(c)
                -- =>
                -- VALUES ...
                rightSelect' = 
                    case rightSelect of
                        Q.VQSelect 
                          (Q.SelectStmt
                            [Q.SCExpr (Q.EEBase (Q.VEColumn colName (Just tabName)))] 
                            False 
                            [Q.FPAlias (Q.FESubQuery (Q.VQLiteral rows)) tabName' (Just [colName'])]
                            []
                            []
                            []) | colName == colName' && tabName == tabName' -> Q.VQLiteral rows
                        _ -> rightSelect
                    
                -- Embedd all conditions in the right select, and set select
                -- clause to the right part of the equal join condition.
                rightSelect = Q.VQSelect $ appendAllToWhere innerConds select1
                                           { Q.selectClause = [rightSCol] }
                innerConds  = map f conditions'
                f           = translateJoinCond lSClause rSClause
                rightSCol   = Q.SCExpr (translateExprEE (Just rSClause) r)
                lSClause    = Q.selectClause select0
                rSClause    = Q.selectClause select1

            return $ ctor (appendToWhere leftCond select0)
  where
    -- Tries to extract a join condition for usage in the IN sql construct.
    findEq c (Just eqCols, r)              = (Just eqCols, c:r)
    findEq c@(left, right, j) (Nothing, r) = case j of
        A.EqJ -> (Just (left, right), r)
        _     -> (Nothing, c:r)

-- | Terminates a SQL fragment when suggested. Returns the resulting
-- 'FeatureSet' of the child, the 'Q.SelectStmt' and its children.
transformTerminated :: C.AlgNode
                    -> FeatureSet
                    -> Transform (FeatureSet, Q.SelectStmt, TileChildren)
transformTerminated n topFs = do
    tile <- transformNode n
    
    case tile of
        TileNode bottomFs body children
            | topFs `terminatesOver` bottomFs -> do
                tableAlias <- freshAlias

                let schema = getSchemaSelectStmt body

                return ( projectF <> tableF
                       , emptySelectStmt
                         { Q.selectClause =
                               columnsFromSchema tableAlias schema
                         , Q.fromClause =
                               [mkSubQuery body tableAlias $ Just schema]
                         }
                       , children
                       )
            | otherwise                       ->
                return (bottomFs, body, children)
        ReferenceLeaf r s                     -> do
                (sel, cs) <- embedExternalReference r s
                return (projectF <> tableF, sel, cs)

-- | Does the same as 'transformTerminated', but further handles combining of
-- the 'FeatureSet' and applies it to the constructor.
transformTerminated' :: C.AlgNode
                     -> FeatureSet
                     -> Transform ( Q.SelectStmt -> TileChildren -> TileTree
                                  , Q.SelectStmt
                                  , TileChildren
                                  )
transformTerminated' n topFs = do
    (fs, select, cs) <- transformTerminated n topFs
    return (TileNode $ fs <> topFs, select, cs)

-- | Embeds an external reference into a 'Q.SelectStmt'.
embedExternalReference :: ExternalReference
                       -> [String]
                       -> Transform (Q.SelectStmt, TileChildren)
embedExternalReference extRef schema = do

        tableAlias <- freshAlias
        varId <- freshVariableId

        return ( emptySelectStmt
                 { -- Use the schema to construct the select clause.
                   Q.selectClause =
                       columnsFromSchema tableAlias schema
                 , Q.fromClause =
                       [Q.FPAlias (Q.FEVariable varId) tableAlias $ Just schema]
                 }
               , [(varId, ReferenceLeaf extRef schema)]
               )

-- | Generate a select clause with column names from a schema and a prefix.
columnsFromSchema :: String -> [String] -> [Q.SelectColumn]
columnsFromSchema p = map $ asSelectColumn p

-- | Creates 'Q.SelectColumn' which points at a prefixed column with the same
-- name.
asSelectColumn :: String
               -> String
               -> Q.SelectColumn
asSelectColumn tablePrefix columnName =
    Q.SCAlias (Q.EEBase $ mkPCol tablePrefix columnName) columnName

-- Translates a '[A.SortSpec]' into a '[Q.WindowOrderExpr]'. Column names will
-- be inlined as a 'Q.AggrExpr', constant ones will be discarded.
asWindowOrderExprList :: [Q.SelectColumn]
                      -> [A.SortSpec]
                      -> [Q.WindowOrderExpr]
asWindowOrderExprList sClause si =
    filter (affectsSortOrderAE . Q.woExpr)
           $ translateSortInf si (translateExprAE $ Just sClause)

-- | Search the select clause for a specific column definition and return it as
-- 'Q.ColumnExpr'.
inlineCE :: [Q.SelectColumn]
         -> String
         -> Q.ColumnExpr
inlineCE sClause col =
    fromMaybe (Q.CEBase $ Q.VEColumn col Nothing)
              $ convertEEtoCE $ inlineEE sClause col


-- | Search the select clause for a specific column definition and return it as
-- 'Q.AggrExpr'.
inlineAE :: [Q.SelectColumn]
         -> String
         -> Q.AggrExpr
inlineAE sClause col =
    fromMaybe (Q.AEBase $ Q.VEColumn col Nothing)
              $ convertEEtoAE $ inlineEE sClause col

-- | Search the select clause for a specific column definition and return it as
-- 'Q.ExtendedExpr'.
inlineEE :: [Q.SelectColumn]
         -> String
         -> Q.ExtendedExpr
inlineEE sClause col =
    fromMaybe (Q.EEBase $ mkCol col) $ foldr f Nothing sClause
  where
    f sc r = case sc of
        Q.SCAlias expr alias | col == alias -> return expr
        _                                   -> r

-- | Generic base converter for the value expression template. Since types do
-- not have equal functionality, conversion can fail.
convertEEBaseTemplate :: (Q.ExtendedExpr -> Maybe a)
                      -> Q.ExtendedExprBase
                      -> Maybe (Q.ValueExprTemplate a)
convertEEBaseTemplate convertEEBaseRec eeb = case eeb of
    Q.VEValue v             -> return $ Q.VEValue v
    Q.VEColumn n p          -> return $ Q.VEColumn n p
    Q.VECast rec t          -> do
        e <- convertEEBaseRec rec
        return $ Q.VECast e t

    Q.VEBinApp f lrec rrec  -> do
        l <- convertEEBaseRec lrec
        r <- convertEEBaseRec rrec
        return $ Q.VEBinApp f l r

    Q.VEUnApp f rec         -> do
        e <- convertEEBaseRec rec
        return $ Q.VEUnApp f e

    Q.VENot rec             -> do
        e <- convertEEBaseRec rec
        return $ Q.VENot e

    Q.VEExists q            -> return $ Q.VEExists q
    Q.VEIn rec q            -> do
        e <- convertEEBaseRec rec
        return $ Q.VEIn e q
    Q.VECase crec trec erec -> do
        c <- convertEEBaseRec crec
        t <- convertEEBaseRec trec
        e <- convertEEBaseRec erec

        return $ Q.VECase c t e

-- | Converts an 'Q.ExtendedExpr' to a 'Q.ColumnExpr', if possible.
convertEEtoCE :: Q.ExtendedExpr -> Maybe Q.ColumnExpr
convertEEtoCE ee = case ee of
    Q.EEBase eeb -> do
        ceb <- convertEEBaseTemplate convertEEtoCE eeb
        return $ Q.CEBase ceb
    _            -> Nothing

-- | Converts an 'Q.ExtendedExpr' to a 'Q.AggrExpr', if possible.
convertEEtoAE :: Q.ExtendedExpr -> Maybe Q.AggrExpr
convertEEtoAE ee = case ee of
    Q.EEBase eeb    -> do
        aeb <- convertEEBaseTemplate convertEEtoAE eeb
        return $ Q.AEBase aeb

    Q.EEAggrExpr ae -> return ae

    _               -> Nothing

-- | Shorthand to make an unprefixed column.
mkCol :: String
      -> Q.ValueExprTemplate a
mkCol c = Q.VEColumn c Nothing

appendToWhere :: Q.ColumnExpr -- ^ The expression added with logical and.
              -> Q.SelectStmt -- ^ The select statement to add to.
              -> Q.SelectStmt -- ^ The result.
appendToWhere cond select =
    select { Q.whereClause = cond : Q.whereClause select }

-- | Append predicate expressions to the WHERE clause of a select
-- statement.
appendAllToWhere :: [Q.ColumnExpr]
                 -> Q.SelectStmt
                 -> Q.SelectStmt
appendAllToWhere conds select =
    select { Q.whereClause = conds ++ Q.whereClause select }

-- | Translate 'A.JoinRel' into 'Q.BinaryFunction'.
translateJoinRel :: A.JoinRel
                 -> Q.BinaryFunction
translateJoinRel rel = case rel of
    A.EqJ -> Q.BFEqual
    A.GtJ -> Q.BFGreaterThan
    A.GeJ -> Q.BFGreaterEqual
    A.LtJ -> Q.BFLowerThan
    A.LeJ -> Q.BFLowerEqual
    A.NeJ -> Q.BFNotEqual

translateFrameSpec :: A.FrameBounds -> Q.FrameSpec
translateFrameSpec (A.HalfOpenFrame fs)  = Q.FHalfOpen $ translateFrameStart fs
translateFrameSpec (A.ClosedFrame fs fe) = Q.FClosed (translateFrameStart fs)
                                                     (translateFrameEnd fe)

translateFrameStart :: A.FrameStart -> Q.FrameStart
translateFrameStart A.FSUnboundPrec = Q.FSUnboundPrec
translateFrameStart (A.FSValPrec i) = Q.FSValPrec i
translateFrameStart A.FSCurrRow     = Q.FSCurrRow

translateFrameEnd :: A.FrameEnd -> Q.FrameEnd
translateFrameEnd A.FEUnboundFol = Q.FEUnboundFol
translateFrameEnd (A.FEValFol i) = Q.FEValFol i
translateFrameEnd A.FECurrRow    = Q.FECurrRow

translateWindowFunction :: (A.Expr -> Q.ColumnExpr) -> A.WinFun -> Q.WindowFunction
translateWindowFunction translateExpr wfun = case wfun of
    A.WinMax e        -> Q.WFMax $ translateExpr e
    A.WinMin e        -> Q.WFMin $ translateExpr e
    A.WinSum e        -> Q.WFSum $ translateExpr e
    A.WinAvg e        -> Q.WFAvg $ translateExpr e
    A.WinAll e        -> Q.WFAll $ translateExpr e
    A.WinAny e        -> Q.WFAny $ translateExpr e
    A.WinFirstValue e -> Q.WFFirstValue $ translateExpr e
    A.WinLastValue e  -> Q.WFLastValue $ translateExpr e
    A.WinCount        -> Q.WFCount

translateAggrType :: A.AggrType
                  -> (Q.AggregateFunction, Maybe A.Expr)
translateAggrType aggr = case aggr of
    A.Avg e  -> (Q.AFAvg, Just e)
    A.Max e  -> (Q.AFMax, Just e)
    A.Min e  -> (Q.AFMin, Just e)
    A.Sum e  -> (Q.AFSum, Just e)
    A.Count  -> (Q.AFCount, Nothing)
    A.All e  -> (Q.AFAll, Just e)
    A.Any e  -> (Q.AFAny, Just e)

translateExprValueExprTemplate :: (Maybe [Q.SelectColumn] -> A.Expr -> a)
                               -> (Q.ValueExprTemplate a -> a)
                               -> ([Q.SelectColumn] -> String -> a)
                               -> Maybe [Q.SelectColumn]
                               -> A.Expr
                               -> a
translateExprValueExprTemplate rec wrap inline optSelectClause expr =
    case expr of
        A.IfE c t e       ->
            wrap $ Q.VECase (rec optSelectClause c)
                            (rec optSelectClause t)
                            (rec optSelectClause e)
                               
        A.BinAppE f e1 e2 ->
            wrap $ Q.VEBinApp (translateBinFun f)
                              (rec optSelectClause e1)
                              $ rec optSelectClause e2
        A.UnAppE f e      ->
            wrap $ case f of
                A.Not           -> Q.VENot tE
                A.Cast t        -> Q.VECast tE $ translateATy t
                A.Sin           -> Q.VEUnApp Q.UFSin tE
                A.Cos           -> Q.VEUnApp Q.UFCos tE
                A.Tan           -> Q.VEUnApp Q.UFTan tE
                A.ASin          -> Q.VEUnApp Q.UFASin tE
                A.ACos          -> Q.VEUnApp Q.UFACos tE
                A.ATan          -> Q.VEUnApp Q.UFATan tE
                A.Sqrt          -> Q.VEUnApp Q.UFSqrt tE
                A.Log           -> Q.VEUnApp Q.UFLog tE
                A.Exp           -> Q.VEUnApp Q.UFExp tE
                A.SubString from to -> Q.VEUnApp (Q.UFSubString from to) tE

          where
            tE = rec optSelectClause e

        A.ColE n          -> case optSelectClause of
            Just s  -> inline s n
            Nothing -> wrap $ mkCol n
        A.ConstE v        -> wrap $ Q.VEValue $ translateAVal v

translateExprCE :: Maybe [Q.SelectColumn] -> A.Expr -> Q.ColumnExpr
translateExprCE = translateExprValueExprTemplate translateExprCE Q.CEBase inlineCE

translateExprEE :: Maybe [Q.SelectColumn] -> A.Expr -> Q.ExtendedExpr
translateExprEE = translateExprValueExprTemplate translateExprEE Q.EEBase inlineEE

translateExprAE :: Maybe [Q.SelectColumn] -> A.Expr -> Q.AggrExpr
translateExprAE = translateExprValueExprTemplate translateExprAE Q.AEBase inlineAE

translateBinFun :: A.BinFun -> Q.BinaryFunction
translateBinFun f = case f of
    A.Gt        -> Q.BFGreaterThan
    A.Lt        -> Q.BFLowerThan
    A.GtE       -> Q.BFGreaterEqual
    A.LtE       -> Q.BFLowerEqual
    A.Eq        -> Q.BFEqual
    A.NEq       -> Q.BFNotEqual
    A.And       -> Q.BFAnd
    A.Or        -> Q.BFOr
    A.Plus      -> Q.BFPlus
    A.Minus     -> Q.BFMinus
    A.Times     -> Q.BFTimes
    A.Div       -> Q.BFDiv
    A.Modulo    -> Q.BFModulo
    A.Contains  -> Q.BFContains
    A.SimilarTo -> Q.BFSimilarTo
    A.Like      -> Q.BFLike
    A.Concat    -> Q.BFConcat

-- | Translate sort information into '[Q.WindowOrderExpr]', using the column
-- function, which takes a 'String'.
translateSortInf :: [A.SortSpec]
                 -> (A.Expr -> Q.AggrExpr)
                 -> [Q.WindowOrderExpr]
translateSortInf sortInfos colFun = map toWOE sortInfos
  where
    toWOE (n, d) = Q.WOE (colFun n) (translateSortDir d)


-- | Translate a single join condition into it's 'Q.ColumnExpr' equivalent.
-- 'A.Expr' contained within the join condition are inlined with the according
-- select clauses.
translateJoinCond :: [Q.SelectColumn] -- ^ Left select clause.
                  -> [Q.SelectColumn] -- ^ Right select clause.
                  -> (A.Expr, A.Expr, A.JoinRel)
                  -> Q.ColumnExpr
translateJoinCond lSelectClause rSelectClause (l, r, j) =
    Q.CEBase $ Q.VEBinApp (translateJoinRel j)
                          (translateExprCE (Just lSelectClause) l)
                          (translateExprCE (Just rSelectClause) r)

translateSortDir :: A.SortDir -> Q.SortDirection
translateSortDir d = case d of
    A.Asc  -> Q.Ascending
    A.Desc -> Q.Descending

translateAVal :: A.AVal -> Q.Value
translateAVal v = case v of
    A.VInt i    -> Q.VInteger i
    A.VStr s    -> Q.VText s
    A.VBool b   -> Q.VBoolean b
    A.VDouble d -> Q.VDoublePrecision d
    A.VDec d    -> Q.VDecimal d
    A.VNat n    -> Q.VInteger n

translateATy :: A.ATy -> Q.DataType
translateATy t = case t of
    A.AInt    -> Q.DTInteger
    A.AStr    -> Q.DTText
    A.ABool   -> Q.DTBoolean
    A.ADec    -> Q.DTDecimal
    A.ADouble -> Q.DTDoublePrecision
    A.ANat    -> Q.DTInteger