content: -- Copyright (c) 2017 Uber Technologies, Inc.
  --
  -- Permission is hereby granted, free of charge, to any person obtaining a copy
  -- of this software and associated documentation files (the "Software"), to deal
  -- in the Software without restriction, including without limitation the rights
  -- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  -- copies of the Software, and to permit persons to whom the Software is
  -- furnished to do so, subject to the following conditions:
  --
  -- The above copyright notice and this permission notice shall be included in
  -- all copies or substantial portions of the Software.
  --
  -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  -- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  -- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  -- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  -- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  -- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
  -- THE SOFTWARE.
  
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FunctionalDependencies #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE KindSignatures #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  
  module Database.Sql.Util.Eval.Concrete where
  
  import Database.Sql.Util.Eval
  
  import Database.Sql.Type.Names
  import Database.Sql.Type.Query
  
  import           Data.ByteString.Lazy (ByteString)
  import qualified Data.ByteString.Lazy as BL
  import qualified Data.Text.Lazy as TL
  import           Data.List (nub, sort)
  import           Data.List.NonEmpty (NonEmpty (..))
  import           Data.Map (Map)
  import qualified Data.Map as M
  import qualified Data.Set as S
  import           Control.Monad.Identity
  import           Control.Monad.Except
  import           Data.Proxy
  
  
  data Concrete
  
  deriving instance Eq (RecordSet Concrete)
  deriving instance Show (RecordSet Concrete)
  
  data SqlValue
      = SqlInt Integer
      | SqlStr ByteString
      | SqlBool Bool
      | SqlStruct (Map (StructFieldName ()) SqlValue)
      | SqlNull
        deriving (Eq, Ord, Show)
  
  
  -- | truthy tells us whether our Haskell code should consider a SqlValue
  -- "true", mostly for the purpose of filtering.  It should not be used to
  -- construct a SqlValue, as it does not handle NULL correctly for that
  -- purpose.
  
  truthy :: SqlValue -> Bool
  truthy (SqlBool bool) = bool
  truthy (SqlInt int) = int /= 0
  truthy (SqlStr str) = not $ BL.null str
  truthy (SqlStruct _) = True -- pigeon?
  truthy SqlNull = False
  
  
  instance Evaluation Concrete where
      type EvalValue Concrete = SqlValue
      type EvalRow Concrete = []
      type EvalMonad Concrete = Identity
      addItems _ = (pure .) . (++)
      removeItems _ exclude unfiltered = pure $ filter (not . (`S.member` S.fromList exclude)) unfiltered
      unionItems _ xs ys = pure $ S.toList $ S.union (S.fromList xs) (S.fromList ys)
      intersectItems _ xs ys = pure $ S.toList $ S.intersection (S.fromList xs) (S.fromList ys)
      distinctItems _ = nub
      offsetItems p offset RecordSet{..} = makeRecordSet p recordSetLabels $ drop offset recordSetItems
      limitItems p limit RecordSet{..} = makeRecordSet p recordSetLabels $ take limit recordSetItems
  
      filterBy expr (RecordSet cs rs) = do
          rs' <- filterM ((truthy <$>) . exprToTable (eval Proxy expr) . makeRowMap cs) rs
          pure $ makeRecordSet Proxy cs rs'
  
      handleGroups cs gs = map (makeRecordSet Proxy cs) $ M.elems $ M.fromListWith (++) gs
  
      inList x xs = pure $ SqlBool $ elem x xs
      inSubquery x xss = pure $ SqlBool $ elem x $ concat xss
      existsSubquery = pure . SqlBool . not . null
  
      atTimeZone _ _ = throwError "AT TIME ZONE not yet handled in concrete evaluation"
      handleConstant _ (StringConstant _ str) = pure $ SqlStr str
      handleConstant _ (NumericConstant _ num) = pure $ SqlInt $ read $ TL.unpack num
      handleConstant _ (NullConstant _) = pure SqlNull
      handleConstant _ (BooleanConstant _ bool) = pure $ SqlBool bool
      handleConstant _ (TypedConstant _ text dataType) = error "typed constant expression not yet supported" text dataType
      handleConstant _ (ParameterConstant _) = throwError "no way to evaluate unsubstituted parameter"
  
      handleCases p ((when_, then_):cases) else_ = do
          truthy <$> eval p when_ >>= \case
              True -> eval p then_
              False -> handleCases p cases else_
  
      handleCases _ [] Nothing = throwError "fell through case with no else"
      handleCases p [] (Just expr) = eval p expr
  
      handleFunction _ _ _ _ _ _ _ = throwError "function exprs not yet supported"
  
      handleLike _ _ _ _ _ = throwError "concrete evaluation for LIKE expressions not yet supported"
  
      handleOrder p orders (RecordSet cs rs) = do
          pairs <- forM rs $ \ r -> do
              k <- (`exprToTable` makeRowMap cs r) $ forM orders $ \case
                  Order _ (PositionOrExprPosition _ pos _) (OrderAsc _) _ -> Ascending <$> return (r !! (pos - 1))
                  Order _ (PositionOrExprPosition _ pos _) (OrderDesc _) _ -> Descending <$> return (r !! (pos - 1))
                  Order _ (PositionOrExprExpr expr) (OrderAsc _) _ -> Ascending <$> eval p expr
                  Order _ (PositionOrExprExpr expr) (OrderDesc _) _ -> Descending <$> eval p expr
              pure (k, r)
          pure $ makeRecordSet p cs $ map snd $ sort pairs
  
      handleSubquery [[x]] = pure x
      handleSubquery [] = throwError "no rows returned from subquery"
      handleSubquery [_] = throwError "wrong number of columns from subquery"
      handleSubquery _ = throwError "multiple rows returned from subquery"
  
      handleJoin p (JoinInner _) cond x y = eval p cond x y
      handleJoin p (JoinLeft _) cond x y = do
          case x of
              RecordSet _ [] -> eval p cond x y
              RecordSet lcols lrows -> do
                  ~(set:sets) <- forM lrows $ \ lrow -> do
                      let x' = makeRecordSet p lcols [lrow]
                      eval p cond x' y >>= \case
                          RecordSet cols [] -> pure $ makeRecordSet p cols [extendWithNulls cols lrow]
                          set -> pure set
                  appendRecordSets p (set:|sets)
  
      handleJoin p (JoinRight _) cond x y = do
          case y of
              RecordSet _ [] -> eval p cond x y
              RecordSet rcols rrows -> do
                  ~(set:sets) <- forM rrows $ \ rrow -> do
                      let y' = makeRecordSet p rcols [rrow]
                      eval p cond x y' >>= \case
                          RecordSet cols [] -> pure $ makeRecordSet p cols [reverse $ extendWithNulls cols $ reverse rrow]
                          set -> pure set
                  appendRecordSets p (set:|sets)
  
      handleJoin p (JoinFull info) cond x y = do
          RecordSet cs rs <- handleJoin p (JoinLeft info) cond x y
          RecordSet _ rs' <- do -- get those from the RHS with no matches on LHS
              case y of
                  RecordSet _ [] -> eval p cond x y
                  RecordSet rcols rrows -> do
                      ~(set:sets) <- forM rrows $ \ rrow -> do
                          let y' = makeRecordSet p rcols [rrow]
                          eval p cond x y' >>= \case
                              RecordSet cols [] -> pure $ makeRecordSet p cols [reverse $ extendWithNulls cols $ reverse rrow]
                              RecordSet cols _ -> pure $ makeRecordSet p cols []
                      appendRecordSets p (set:|sets)
          pure $ makeRecordSet p cs $ rs ++ rs'
  
      handleJoin _ (JoinSemi _) cond x y = error "semi joins not yet supported" cond x y
  
      handleStructField expr field = eval (Proxy :: Proxy Concrete) expr >>= \case
          SqlStruct m
              | Just val <- M.lookup (void field) m
              -> pure val
              | otherwise
              -> throwError "missing field in SQL struct"
          _ -> throwError "field access of non-struct value"
  
      handleTypeCast _ _ _ = throwError "concrete evaluation for type cast expressions not yet supported"
  
      binop _ op = M.lookup op $ M.fromList
          [ ("+", opAdd)
          , ("=", opEq)
          , ("AND", opAnd)
          ]
        where
          opAdd (SqlInt x) (SqlInt y) = pure $ SqlInt (x + y)
          opAdd (SqlInt _) SqlNull = pure SqlNull
          opAdd SqlNull (SqlInt _) = pure SqlNull
          opAdd _ _ = throwError "unsupported arguments to + operator"
  
          opEq SqlNull _ = pure SqlNull
          opEq _ SqlNull = pure SqlNull
          opEq x y = pure $ SqlBool $ x == y  -- TODO coerce
  
          opAnd SqlNull _ = pure SqlNull
          opAnd _ SqlNull = pure SqlNull
          opAnd x y = pure $ SqlBool $ truthy x && truthy y
  
      unop _ op = M.lookup op $ M.fromList
          [ ("-", neg)
          ]
        where
          neg (SqlInt int) = pure $ SqlInt (-int)
          neg SqlNull = pure SqlNull
          neg _ = throwError "unsupported argument to - operator"
  
  
  extendWithNulls :: [a] -> [SqlValue] -> [SqlValue]
  extendWithNulls (_:xs) (y:ys) = y:extendWithNulls xs ys
  extendWithNulls xs [] = map (const SqlNull) xs
  extendWithNulls [] _ = error "more values than columns - this should never happen"
  