{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | This is an internal module. This module may have breaking changes without
-- a corresponding major version bump. If you use this module, please open an
-- issue with your use-case so we can safely support it.
module Database.Esqueleto.Internal.ExprParser where

import Prelude hiding (takeWhile)

import Control.Applicative ((<|>))
import Control.Monad (void)
import Data.Attoparsec.Text
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import Database.Persist.Sql
import Database.Persist.SqlBackend

-- | A type representing the access of a table value. In Esqueleto, we get
-- a guarantee that the access will look something like:
--
-- @
-- escape-char [character] escape-char . escape-char [character] escape-char
--             ^^^^^^^^^^^                           ^^^^^^^^^^^
--             table name                            column name
-- @
data TableAccess = TableAccess
    { TableAccess -> Text
tableAccessTable  :: Text
    , TableAccess -> Text
tableAccessColumn :: Text
    }
    deriving (TableAccess -> TableAccess -> Bool
(TableAccess -> TableAccess -> Bool)
-> (TableAccess -> TableAccess -> Bool) -> Eq TableAccess
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TableAccess -> TableAccess -> Bool
== :: TableAccess -> TableAccess -> Bool
$c/= :: TableAccess -> TableAccess -> Bool
/= :: TableAccess -> TableAccess -> Bool
Eq, Eq TableAccess
Eq TableAccess =>
(TableAccess -> TableAccess -> Ordering)
-> (TableAccess -> TableAccess -> Bool)
-> (TableAccess -> TableAccess -> Bool)
-> (TableAccess -> TableAccess -> Bool)
-> (TableAccess -> TableAccess -> Bool)
-> (TableAccess -> TableAccess -> TableAccess)
-> (TableAccess -> TableAccess -> TableAccess)
-> Ord TableAccess
TableAccess -> TableAccess -> Bool
TableAccess -> TableAccess -> Ordering
TableAccess -> TableAccess -> TableAccess
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TableAccess -> TableAccess -> Ordering
compare :: TableAccess -> TableAccess -> Ordering
$c< :: TableAccess -> TableAccess -> Bool
< :: TableAccess -> TableAccess -> Bool
$c<= :: TableAccess -> TableAccess -> Bool
<= :: TableAccess -> TableAccess -> Bool
$c> :: TableAccess -> TableAccess -> Bool
> :: TableAccess -> TableAccess -> Bool
$c>= :: TableAccess -> TableAccess -> Bool
>= :: TableAccess -> TableAccess -> Bool
$cmax :: TableAccess -> TableAccess -> TableAccess
max :: TableAccess -> TableAccess -> TableAccess
$cmin :: TableAccess -> TableAccess -> TableAccess
min :: TableAccess -> TableAccess -> TableAccess
Ord, Int -> TableAccess -> ShowS
[TableAccess] -> ShowS
TableAccess -> String
(Int -> TableAccess -> ShowS)
-> (TableAccess -> String)
-> ([TableAccess] -> ShowS)
-> Show TableAccess
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TableAccess -> ShowS
showsPrec :: Int -> TableAccess -> ShowS
$cshow :: TableAccess -> String
show :: TableAccess -> String
$cshowList :: [TableAccess] -> ShowS
showList :: [TableAccess] -> ShowS
Show)

-- | Parse a @SqlExpr (Value Bool)@'s textual representation into a list of
-- 'TableAccess'
parseOnExpr :: SqlBackend -> Text -> Either String (Set TableAccess)
parseOnExpr :: SqlBackend -> Text -> Either String (Set TableAccess)
parseOnExpr SqlBackend
sqlBackend Text
text = do
    Char
c <- SqlBackend -> Either String Char
mkEscapeChar SqlBackend
sqlBackend
    Parser (Set TableAccess) -> Text -> Either String (Set TableAccess)
forall a. Parser a -> Text -> Either String a
parseOnly (ExprParser (Set TableAccess)
onExpr Char
c) Text
text

-- | This function uses the 'connEscapeName' function in the 'SqlBackend' with an
-- empty identifier to pull out an escape character. This implementation works
-- with postgresql, mysql, and sqlite backends.
mkEscapeChar :: SqlBackend -> Either String Char
mkEscapeChar :: SqlBackend -> Either String Char
mkEscapeChar SqlBackend
sqlBackend =
    case Text -> Maybe (Char, Text)
Text.uncons (Text -> SqlBackend -> Text
forall backend (m :: * -> *).
(BackendCompatible SqlBackend backend, MonadReader backend m) =>
Text -> m Text
getEscapedRawName Text
"" SqlBackend
sqlBackend) of
        Maybe (Char, Text)
Nothing ->
            String -> Either String Char
forall a b. a -> Either a b
Left String
"Failed to get an escape character from the SQL backend."
        Just (Char
c, Text
_) ->
            Char -> Either String Char
forall a b. b -> Either a b
Right Char
c

type ExprParser a = Char -> Parser a

onExpr :: ExprParser (Set TableAccess)
onExpr :: ExprParser (Set TableAccess)
onExpr Char
e = [TableAccess] -> Set TableAccess
forall a. Ord a => [a] -> Set a
Set.fromList ([TableAccess] -> Set TableAccess)
-> Parser Text [TableAccess] -> Parser (Set TableAccess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text TableAccess -> Parser Text [TableAccess]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Text TableAccess
tableAccesses
  where
    tableAccesses :: Parser Text TableAccess
tableAccesses = do
        ExprParser ()
skipToEscape Char
e Parser Text () -> String -> Parser Text ()
forall i a. Parser i a -> String -> Parser i a
<?> String
"Skipping to an escape char"
        ExprParser TableAccess
parseTableAccess Char
e Parser Text TableAccess -> String -> Parser Text TableAccess
forall i a. Parser i a -> String -> Parser i a
<?> String
"Parsing a table access"

skipToEscape :: ExprParser ()
skipToEscape :: ExprParser ()
skipToEscape Char
escapeChar = Parser Text Text -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Char -> Bool) -> Parser Text Text
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
escapeChar))

parseEscapedIdentifier :: ExprParser [Char]
parseEscapedIdentifier :: ExprParser String
parseEscapedIdentifier Char
escapeChar = do
    Char
_ <- Char -> Parser Char
char Char
escapeChar
    String
str <- ExprParser String
parseEscapedChars Char
escapeChar
    Char
_ <- Char -> Parser Char
char Char
escapeChar
    String -> Parser String
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
str

parseTableAccess :: ExprParser TableAccess
parseTableAccess :: ExprParser TableAccess
parseTableAccess Char
ec = do
    Text
tableAccessTable <- String -> Text
Text.pack (String -> Text) -> Parser String -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExprParser String
parseEscapedIdentifier Char
ec
    Char
_ <- Char -> Parser Char
char Char
'.'
    Text
tableAccessColumn <- String -> Text
Text.pack (String -> Text) -> Parser String -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExprParser String
parseEscapedIdentifier Char
ec
    TableAccess -> Parser Text TableAccess
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TableAccess {Text
tableAccessTable :: Text
tableAccessColumn :: Text
tableAccessTable :: Text
tableAccessColumn :: Text
..}

parseEscapedChars :: ExprParser [Char]
parseEscapedChars :: ExprParser String
parseEscapedChars Char
escapeChar = Parser String
go
  where
    twoEscapes :: Parser Char
twoEscapes = Char -> Parser Char
char Char
escapeChar Parser Char -> Parser Char -> Parser Char
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
char Char
escapeChar
    go :: Parser String
go = Parser Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Char -> Parser Char
notChar Char
escapeChar Parser Char -> Parser Char -> Parser Char
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
twoEscapes)