{-# LANGUAGE TemplateHaskell #-}

module Unison.Sqlite.Sql
  ( Sql (..),
    sql,

    -- * Exported for testing
    Param (..),
    ParsedLump (..),
    internalParseSql,
  )
where

import Control.Monad.Trans.State.Strict qualified as State
import Data.Char qualified as Char
import Data.List.NonEmpty qualified as List (NonEmpty)
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.Text qualified as Text
import Database.SQLite.Simple qualified as Sqlite.Simple
import Database.SQLite.Simple.ToField qualified as Sqlite.Simple
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Quote qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
import Text.Builder qualified
import Text.Builder qualified as Text (Builder)
import Text.Megaparsec qualified as Megaparsec
import Text.Megaparsec.Char qualified as Megaparsec
import Unison.Prelude

-- | A SQL query.
data Sql = Sql
  { Sql -> Text
query :: Text,
    Sql -> [SQLData]
params :: [Sqlite.Simple.SQLData]
  }
  deriving stock (Int -> Sql -> ShowS
[Sql] -> ShowS
Sql -> String
(Int -> Sql -> ShowS)
-> (Sql -> String) -> ([Sql] -> ShowS) -> Show Sql
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Sql -> ShowS
showsPrec :: Int -> Sql -> ShowS
$cshow :: Sql -> String
show :: Sql -> String
$cshowList :: [Sql] -> ShowS
showList :: [Sql] -> ShowS
Show)

-- Template haskell, don't ask.

query__ :: Sql -> Text
query__ :: Sql -> Text
query__ (Sql Text
x [SQLData]
_) = Text
x

params__ :: Sql -> [Sqlite.Simple.SQLData]
params__ :: Sql -> [SQLData]
params__ (Sql Text
_ [SQLData]
x) = [SQLData]
x

-- | A quasi-quoter for producing a 'Sql' from a SQL query string, using the Haskell variables in scope for each named
-- parameter.
--
-- For example, the query
--
-- @
-- let qux = 5 :: Int
--
-- [sql|
--   SELECT foo
--   FROM bar
--   WHERE baz = :qux
-- |]
-- @
--
-- would produce a value like
--
-- @
-- Sql
--   { query = "SELECT foo FROM bar WHERE baz = ?"
--   , params = [SQLInteger 5]
--   }
-- @
--
-- which, of course, will require a @qux@ with a 'Sqlite.Simple.ToField' instance in scope.
--
-- There are five valid syntaxes for interpolating a variable:
--
--   * @:colon@, which denotes a single-field variable
--   * @\@at@, followed by 1+ bare @\@@, which denotes a multi-field variable
--   * @\$dollar@, which denotes an entire 'Sql' fragment
--   * @IN :colon@, which denotes an @IN@ expression, where the right-hand side is a list of scalars
--   * @VALUES :colon@, which denotes an entire @VALUES@ literal (1+ tuples)
--
-- As an example of the @\@at@ syntax, consider a variable @plonk@ with a two-field 'Sqlite.Simple.ToRow' instance. A
-- query that interpolates @plonk@ might look like:
--
-- @
-- [sql|
--   SELECT foo
--   FROM bar
--   WHERE stuff = \@plonk
--     AND other = \@
-- |]
-- @
--
-- As an example of @$dollar@ syntax,
--
-- @
-- let foo = [sql| bar |] in [sql| $foo baz |]
-- @
--
-- splices @foo@ into the second fragment, and is equivalent to
--
-- @
-- [sql| bar baz |]
-- @
--
-- As an example of @IN :colon@ syntax, the query
--
-- @
-- [sql| IN :foo |]
-- @
--
-- will require a list "foo" to be in scope, whose elements have `ToField` instances, and will expand to SQL that looks
-- like
--
-- @
-- IN (?, ?, ?, ?)
-- @
--
-- depending on how man elements "foo" has.
--
-- As an example of @VALUES :colon@ syntax, the query
--
-- @
-- [sql| VALUES :foo |]
-- @
--
-- will require a non-empty list "foo" to be in scope, whose elements have `ToRow` instances, and will expand to
-- SQL that looks like
--
-- @
-- VALUES (?, ?), (?, ?), (?, ?)
-- @
--
-- depending on how many elements "foo" has, and how wide its rows are.
sql :: TH.QuasiQuoter
sql :: QuasiQuoter
sql = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
TH.QuasiQuoter String -> Q Exp
sqlQQ String -> Q Pat
forall a. HasCallStack => a
undefined String -> Q Type
forall a. HasCallStack => a
undefined String -> Q [Dec]
forall a. HasCallStack => a
undefined

sqlQQ :: String -> TH.Q TH.Exp
sqlQQ :: String -> Q Exp
sqlQQ String
input =
  case Text -> Either String [ParsedLump]
internalParseSql (String -> Text
Text.pack String
input) of
    Left String
err -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Right [ParsedLump]
lumps -> do
      ([Exp]
sqlPieces, [Exp]
paramsPieces) <- [(Exp, Exp)] -> ([Exp], [Exp])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp, Exp)] -> ([Exp], [Exp]))
-> Q [(Exp, Exp)] -> Q ([Exp], [Exp])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParsedLump] -> (ParsedLump -> Q (Exp, Exp)) -> Q [(Exp, Exp)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [ParsedLump]
lumps ParsedLump -> Q (Exp, Exp)
unlump
      [|
        Sql
          (mconcat $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Exp] -> Exp
TH.ListE [Exp]
sqlPieces)))
          (mconcat $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Exp] -> Exp
TH.ListE [Exp]
paramsPieces)))
        |]
  where
    unlump :: ParsedLump -> TH.Q (TH.Exp, TH.Exp)
    unlump :: ParsedLump -> Q (Exp, Exp)
unlump = \case
      ParsedOuterLump Text
s [Param]
params -> Text -> [Param] -> Q (Exp, Exp)
outerLump Text
s [Param]
params
      ParsedInnerLump Text
s -> Text -> Q (Exp, Exp)
innerLump Text
s
      ParsedInLump Text
s -> Text -> Q (Exp, Exp)
inLump Text
s
      ParsedValuesLump Text
s -> Text -> Q (Exp, Exp)
valuesLump Text
s

    -- Take an outer lump like
    --
    --   "foo ? ? ?"
    --   [FieldParam "bar", RowParam "qux" 2]
    --
    -- and resolve each parameter (field or row) to its corresponding list of SQLData, ultimately returning a pair like
    --
    --   "foo ? ? ?"
    --   mconcat [[SQLInteger 5], [SQLInteger 6, SQLInteger 7]])
    outerLump :: Text -> [Param] -> TH.Q (TH.Exp, TH.Exp)
    outerLump :: Text -> [Param] -> Q (Exp, Exp)
outerLump Text
s [Param]
params =
      (,) (Exp -> Exp -> (Exp, Exp)) -> Q Exp -> Q (Exp -> (Exp, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Text -> m Exp
TH.lift Text
s Q (Exp -> (Exp, Exp)) -> Q Exp -> Q (Exp, Exp)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [|mconcat $([Exp] -> Exp
TH.ListE ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Param] -> (Param -> Q Exp) -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Param]
params Param -> Q Exp
paramToSqlData)|]
      where
        paramToSqlData :: Param -> TH.Q TH.Exp
        paramToSqlData :: Param -> Q Exp
paramToSqlData = \case
          FieldParam Text
var ->
            String -> Q (Maybe Name)
TH.lookupValueName (Text -> String
Text.unpack Text
var) Q (Maybe Name) -> (Maybe Name -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe Name
Nothing -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Not in scope: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
var)
              Just Name
name -> [|[Sqlite.Simple.toField $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
name)]|]
          RowParam Text
var Int
_count ->
            String -> Q (Maybe Name)
TH.lookupValueName (Text -> String
Text.unpack Text
var) Q (Maybe Name) -> (Maybe Name -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe Name
Nothing -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Not in scope: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
var)
              Just Name
name -> [|Sqlite.Simple.toRow $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
name)|]

    innerLump :: Text -> TH.Q (TH.Exp, TH.Exp)
    innerLump :: Text -> Q (Exp, Exp)
innerLump Text
var =
      String -> Q (Maybe Name)
TH.lookupValueName (Text -> String
Text.unpack Text
var) Q (Maybe Name) -> (Maybe Name -> Q (Exp, Exp)) -> Q (Exp, Exp)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Name
Nothing -> String -> Q (Exp, Exp)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Not in scope: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
var)
        Just Name
name -> (,) (Exp -> Exp -> (Exp, Exp)) -> Q Exp -> Q (Exp -> (Exp, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|query__ $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
name)|] Q (Exp -> (Exp, Exp)) -> Q Exp -> Q (Exp, Exp)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [|params__ $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
name)|]

    inLump :: Text -> TH.Q (TH.Exp, TH.Exp)
    inLump :: Text -> Q (Exp, Exp)
inLump Text
var =
      String -> Q (Maybe Name)
TH.lookupValueName (Text -> String
Text.unpack Text
var) Q (Maybe Name) -> (Maybe Name -> Q (Exp, Exp)) -> Q (Exp, Exp)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Name
Nothing -> String -> Q (Exp, Exp)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Not in scope: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
var)
        Just Name
name -> (,) (Exp -> Exp -> (Exp, Exp)) -> Q Exp -> Q (Exp -> (Exp, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|inSql $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
name)|] Q (Exp -> (Exp, Exp)) -> Q Exp -> Q (Exp, Exp)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [|map Sqlite.Simple.toField $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
name)|]

    valuesLump :: Text -> TH.Q (TH.Exp, TH.Exp)
    valuesLump :: Text -> Q (Exp, Exp)
valuesLump Text
var =
      String -> Q (Maybe Name)
TH.lookupValueName (Text -> String
Text.unpack Text
var) Q (Maybe Name) -> (Maybe Name -> Q (Exp, Exp)) -> Q (Exp, Exp)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Name
Nothing -> String -> Q (Exp, Exp)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Not in scope: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
var)
        Just Name
name -> (,) (Exp -> Exp -> (Exp, Exp)) -> Q Exp -> Q (Exp -> (Exp, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|valuesSql $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
name)|] Q (Exp -> (Exp, Exp)) -> Q Exp -> Q (Exp, Exp)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [|foldMap Sqlite.Simple.toRow $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
name)|]

inSql :: (Sqlite.Simple.ToField a) => [a] -> Text
inSql :: forall a. ToField a => [a] -> Text
inSql [a]
scalars =
  Builder -> Text
Text.Builder.run (Builder
"IN (" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
b_commaSep ((a -> Builder) -> [a] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (\a
_ -> Builder
b_qmark) [a]
scalars) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b_rparen)

valuesSql :: (Sqlite.Simple.ToRow a) => List.NonEmpty a -> Text
valuesSql :: forall a. ToRow a => NonEmpty a -> Text
valuesSql NonEmpty a
values =
  Builder -> Text
Text.Builder.run (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$
    Builder
"VALUES " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
b_commaSep (Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate (NonEmpty a -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty a
values) (Int -> Builder
valueSql Int
columns))
  where
    columns :: Int
    columns :: Int
columns =
      [SQLData] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (a -> [SQLData]
forall a. ToRow a => a -> [SQLData]
Sqlite.Simple.toRow (NonEmpty a -> a
forall a. NonEmpty a -> a
List.NonEmpty.head NonEmpty a
values))

    valueSql :: Int -> Text.Builder
    valueSql :: Int -> Builder
valueSql Int
columns =
      Builder
b_lparen Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
b_commaSep (Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
columns Builder
b_qmark) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b_rparen

data ParsedLump
  = ParsedOuterLump !Text ![Param]
  | ParsedInnerLump !Text
  | ParsedInLump !Text
  | ParsedValuesLump !Text
  deriving stock (ParsedLump -> ParsedLump -> Bool
(ParsedLump -> ParsedLump -> Bool)
-> (ParsedLump -> ParsedLump -> Bool) -> Eq ParsedLump
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParsedLump -> ParsedLump -> Bool
== :: ParsedLump -> ParsedLump -> Bool
$c/= :: ParsedLump -> ParsedLump -> Bool
/= :: ParsedLump -> ParsedLump -> Bool
Eq, Int -> ParsedLump -> ShowS
[ParsedLump] -> ShowS
ParsedLump -> String
(Int -> ParsedLump -> ShowS)
-> (ParsedLump -> String)
-> ([ParsedLump] -> ShowS)
-> Show ParsedLump
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParsedLump -> ShowS
showsPrec :: Int -> ParsedLump -> ShowS
$cshow :: ParsedLump -> String
show :: ParsedLump -> String
$cshowList :: [ParsedLump] -> ShowS
showList :: [ParsedLump] -> ShowS
Show)

-- | Parse a SQL string, and return the list of lumps. Exported only for testing.
internalParseSql :: Text -> Either String [ParsedLump]
internalParseSql :: Text -> Either String [ParsedLump]
internalParseSql Text
input =
  case P () -> Text -> Either (ParseErrorBundle Text Void) ((), [Lump])
forall a.
P a -> Text -> Either (ParseErrorBundle Text Void) (a, [Lump])
runP (P ()
parser P () -> P () -> P ()
forall a b.
StateT [Lump] (Parsec Void Text) a
-> StateT [Lump] (Parsec Void Text) b
-> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Megaparsec.eof) (Text -> Text
Text.strip Text
input) of
    Left ParseErrorBundle Text Void
err -> String -> Either String [ParsedLump]
forall a b. a -> Either a b
Left (ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
Megaparsec.errorBundlePretty ParseErrorBundle Text Void
err)
    Right ((), [Lump]
lumps) -> [ParsedLump] -> Either String [ParsedLump]
forall a b. b -> Either a b
Right ((Lump -> ParsedLump) -> [Lump] -> [ParsedLump]
forall a b. (a -> b) -> [a] -> [b]
map Lump -> ParsedLump
unlump ([Lump] -> [Lump]
forall a. [a] -> [a]
reverse [Lump]
lumps))
  where
    unlump :: Lump -> ParsedLump
unlump = \case
      OuterLump Builder
sql [Param]
params -> Text -> [Param] -> ParsedLump
ParsedOuterLump (Builder -> Text
Text.Builder.run Builder
sql) ([Param] -> [Param]
forall a. [a] -> [a]
reverse [Param]
params)
      InnerLump Text
query -> Text -> ParsedLump
ParsedInnerLump Text
query
      InLump Text
param -> Text -> ParsedLump
ParsedInLump Text
param
      ValuesLump Text
param -> Text -> ParsedLump
ParsedValuesLump Text
param

-- Parser state.
--
-- A simple query, without query interpolation and without a VALUES param, is a single "outer lump", which contains:
--
--   * The SQL parsed so far, with
--       * params replaced by question marks (e.g. ":foo" becomes "?")
--       * run of whitespace normalized to one space
--       * comments stripped
--   * A list of parameter names in reverse order
--
-- For example, if we were partway through parsing the query
--
--   SELECT foo
--   FROM bar
--   WHERE baz = :bonk AND qux = 'monk'
--
-- then we would have an outer lump that looks like
--
--   OuterLump
--     "SELECT foo FROM bar WHERE baz = ? AND "
--     [FieldParam "bonk"]
--
-- There are two ways to specify parameters:
--
--   1. Field parameters like ":bonk", which get turned into a single SQLite parameter (via `toField`)
--   2. Row parameters like "@whonk", followed by 1+ "@", which get turned into that many SQLite parameters (via
--      `toRow`)
--
-- We can also interpolate entire sql fragments, which we represent as an "inner lump". And finally, we can interpolate
-- VALUES literals whose length is only known at runtime, which we represent as a "values lump"
--
-- Putting it all together, here's a visual example. Note, too, that the lumps are actually stored in reverse order in
-- the parser state (because we simply cons lumps as we crawl along, which we reverse at the end).
--
--   [sql| one $two :three IN :four VALUES :five |]
--        ^    ^   ^       ^       ^^           ^
--        |    |   |       |       ||           |
--        |    |   |       |       ||           OuterLump " " []
--        |    |   |       |       ||
--        |    |   |       |       |ValuesLump "five"
--        |    |   |       |       |
--        |    |   |       |       OuterLump " " []
--        |    |   |       |
--        |    |   |       InLump "four"
--        |    |   |
--        |    |   OuterLump " ? " ["three"]
--        |    |
--        |    InnerLump "two"
--        |
--        OuterLump " one " []
--
data Lump
  = OuterLump !Text.Builder ![Param]
  | InnerLump !Text -- "$foo" ==> InnerLump "foo"
  | InLump !Text -- "IN :foo" ==> InLump "foo"
  | ValuesLump !Text -- "VALUES :foo" ==> ValuesLump "foo"

data Param
  = FieldParam !Text -- :foo ==> FieldParam "foo"
  | RowParam !Text !Int -- @bar @ @ ==> RowParam "bar" 3
  deriving stock (Param -> Param -> Bool
(Param -> Param -> Bool) -> (Param -> Param -> Bool) -> Eq Param
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Param -> Param -> Bool
== :: Param -> Param -> Bool
$c/= :: Param -> Param -> Bool
/= :: Param -> Param -> Bool
Eq, Int -> Param -> ShowS
[Param] -> ShowS
Param -> String
(Int -> Param -> ShowS)
-> (Param -> String) -> ([Param] -> ShowS) -> Show Param
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Param -> ShowS
showsPrec :: Int -> Param -> ShowS
$cshow :: Param -> String
show :: Param -> String
$cshowList :: [Param] -> ShowS
showList :: [Param] -> ShowS
Show)

type P a =
  State.StateT [Lump] (Megaparsec.Parsec Void Text) a

runP :: P a -> Text -> Either (Megaparsec.ParseErrorBundle Text Void) (a, [Lump])
runP :: forall a.
P a -> Text -> Either (ParseErrorBundle Text Void) (a, [Lump])
runP P a
p =
  Parsec Void Text (a, [Lump])
-> String
-> Text
-> Either (ParseErrorBundle Text Void) (a, [Lump])
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Megaparsec.runParser (P a -> [Lump] -> Parsec Void Text (a, [Lump])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT P a
p []) String
""

-- Parser for a SQL query (stored in the parser state).
parser :: P ()
parser :: P ()
parser = do
  P Fragment
fragmentParser P Fragment -> (Fragment -> P ()) -> P ()
forall a b.
StateT [Lump] (Parsec Void Text) a
-> (a -> StateT [Lump] (Parsec Void Text) b)
-> StateT [Lump] (Parsec Void Text) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Fragment
Comment -> P ()
parser
    NonParam Builder
fragment -> Builder -> ([Param] -> P [Param]) -> P ()
outer Builder
fragment [Param] -> P [Param]
forall a. a -> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    AtParam Builder
param ->
      Builder -> ([Param] -> P [Param]) -> P ()
outer
        Builder
b_qmark
        -- Either we parsed a bare "@", in which case we want to bump the int count of the latest field we walked over
        -- (which must be a RowField, otherwise the query is invalid as it begins some string of @-params with a bare
        -- @), or we parsed a new "@foo@ row param
        let param1 :: Text
param1 = Builder -> Text
Text.Builder.run Builder
param
         in if Text -> Bool
Text.null Text
param1
              then \case
                RowParam Text
name Int
count : [Param]
params -> do
                  let !count' :: Int
count' = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                  [Param] -> P [Param]
forall a. a -> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Int -> Param
RowParam Text
name Int
count' Param -> [Param] -> [Param]
forall a. a -> [a] -> [a]
: [Param]
params)
                [Param]
_ -> String -> P [Param]
forall a. String -> StateT [Lump] (Parsec Void Text) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid query: encountered unnamed-@ without a preceding named-@, like `@foo`")
              else \[Param]
params -> [Param] -> P [Param]
forall a. a -> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Int -> Param
RowParam Text
param1 Int
1 Param -> [Param] -> [Param]
forall a. a -> [a] -> [a]
: [Param]
params)
    ColonParam Builder
param -> Builder -> ([Param] -> P [Param]) -> P ()
outer Builder
b_qmark \[Param]
params -> [Param] -> P [Param]
forall a. a -> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Param
FieldParam (Builder -> Text
Text.Builder.run Builder
param) Param -> [Param] -> [Param]
forall a. a -> [a] -> [a]
: [Param]
params)
    DollarParam Builder
param -> do
      ([Lump] -> [Lump]) -> P ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' (Text -> Lump
InnerLump (Builder -> Text
Text.Builder.run Builder
param) Lump -> [Lump] -> [Lump]
forall a. a -> [a] -> [a]
:)
      P ()
parser
    InParam Builder
param -> do
      ([Lump] -> [Lump]) -> P ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' (Text -> Lump
InLump (Builder -> Text
Text.Builder.run Builder
param) Lump -> [Lump] -> [Lump]
forall a. a -> [a] -> [a]
:)
      P ()
parser
    ValuesParam Builder
param -> do
      ([Lump] -> [Lump]) -> P ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' (Text -> Lump
ValuesLump (Builder -> Text
Text.Builder.run Builder
param) Lump -> [Lump] -> [Lump]
forall a. a -> [a] -> [a]
:)
      P ()
parser
    Fragment
Whitespace -> Builder -> ([Param] -> P [Param]) -> P ()
outer (Char -> Builder
Text.Builder.char Char
' ') [Param] -> P [Param]
forall a. a -> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Fragment
EndOfInput -> () -> P ()
forall a. a -> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    outer :: Text.Builder -> ([Param] -> P [Param]) -> P ()
    outer :: Builder -> ([Param] -> P [Param]) -> P ()
outer Builder
s [Param] -> P [Param]
g = do
      StateT [Lump] (Parsec Void Text) [Lump]
forall (m :: * -> *) s. Monad m => StateT s m s
State.get StateT [Lump] (Parsec Void Text) [Lump] -> ([Lump] -> P ()) -> P ()
forall a b.
StateT [Lump] (Parsec Void Text) a
-> (a -> StateT [Lump] (Parsec Void Text) b)
-> StateT [Lump] (Parsec Void Text) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        OuterLump Builder
sql [Param]
params : [Lump]
lumps -> do
          let !sql' :: Builder
sql' = Builder
sql Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
s
          [Param]
params' <- [Param] -> P [Param]
g [Param]
params
          [Lump] -> P ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (Builder -> [Param] -> Lump
OuterLump Builder
sql' [Param]
params' Lump -> [Lump] -> [Lump]
forall a. a -> [a] -> [a]
: [Lump]
lumps)
        [Lump]
lumps -> do
          [Param]
params <- [Param] -> P [Param]
g []
          [Lump] -> P ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (Builder -> [Param] -> Lump
OuterLump Builder
s [Param]
params Lump -> [Lump] -> [Lump]
forall a. a -> [a] -> [a]
: [Lump]
lumps)
      P ()
parser

-- A single fragment, where a list of fragments (always ending in EndOfFile) makes a whole query.
--
-- The query
--
--   SELECT foo
--   FROM   bar
--   WHERE  baz = :bonk AND qux = 'monkey monk'
--
-- corresponds to the fragments
--
--   [ NonParam "SELECT"
--   , Whitespace
--   , NonParam "foo"
--   , Whitespace
--   , NonParam "FROM"
--   , Whitespace
--   , NonParam "bar"
--   , Whitespace
--   , NonParam "WHERE"
--   , Whitespace
--   , NonParam "baz"
--   , Whitespace
--   , NonParam "="
--   , Whitespace
--   , ColonParam "bonk"
--   , Whitespace
--   , NonParam "AND"
--   , Whitespace
--   , NonParam "qux"
--   , Whitespace
--   , NonParam "="
--   , Whitespace
--   , NonParam "'monkey monk'"
--   , EndOfInput
--   ]
--
-- Any sequence of consecutive NonParam fragments in such a list is equivalent to a single NonParam fragment with the
-- contents concatenated. How the non-parameter stuff between parameters is turned into 1+ NonParam fragments is just a
-- consequence of how we parse these SQL strings: identify strings and such, but otherwise make no attempt to
-- understand the structure of the query.
--
-- A parsed query can be reconstructed by simply concatenating all fragments together, with a colon character ':'
-- prepended to each Param fragment.
data Fragment
  = Comment -- we toss these, so we don't bother remembering the contents
  | NonParam !Text.Builder
  | AtParam !Text.Builder -- "@foo" ==> "foo"; "@" ==> ""
  | ColonParam !Text.Builder -- ":foo" ==> "foo"
  | DollarParam !Text.Builder -- "$foo" ==> "foo"
  | InParam !Text.Builder -- "IN :foo" ==> "foo"
  | ValuesParam !Text.Builder -- "VALUES :foo" ==> "foo"
  | Whitespace
  | EndOfInput

fragmentParser :: P Fragment
fragmentParser :: P Fragment
fragmentParser =
  [P Fragment] -> P Fragment
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ Fragment
Whitespace Fragment -> P () -> P Fragment
forall a b.
a
-> StateT [Lump] (Parsec Void Text) b
-> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P ()
whitespaceP,
      Builder -> Fragment
NonParam (Builder -> Fragment)
-> StateT [Lump] (Parsec Void Text) Builder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Char -> StateT [Lump] (Parsec Void Text) Builder
betwixt String
"string" Char
'\'',
      Builder -> Fragment
NonParam (Builder -> Fragment)
-> StateT [Lump] (Parsec Void Text) Builder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Char -> StateT [Lump] (Parsec Void Text) Builder
betwixt String
"identifier" Char
'"',
      Builder -> Fragment
NonParam (Builder -> Fragment)
-> StateT [Lump] (Parsec Void Text) Builder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Char -> StateT [Lump] (Parsec Void Text) Builder
betwixt String
"identifier" Char
'`',
      Builder -> Fragment
NonParam (Builder -> Fragment)
-> StateT [Lump] (Parsec Void Text) Builder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) Builder
bracketedIdentifierP,
      Fragment
Comment Fragment -> P () -> P Fragment
forall a b.
a
-> StateT [Lump] (Parsec Void Text) b
-> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P ()
lineCommentP,
      Fragment
Comment Fragment -> P () -> P Fragment
forall a b.
a
-> StateT [Lump] (Parsec Void Text) b
-> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P ()
blockCommentP,
      Builder -> Fragment
ColonParam (Builder -> Fragment)
-> StateT [Lump] (Parsec Void Text) Builder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) Builder
colonParamP,
      Builder -> Fragment
AtParam (Builder -> Fragment)
-> StateT [Lump] (Parsec Void Text) Builder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) Builder
atParamP,
      Builder -> Fragment
DollarParam (Builder -> Fragment)
-> StateT [Lump] (Parsec Void Text) Builder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) Builder
dollarParamP,
      Builder -> Fragment
InParam (Builder -> Fragment)
-> StateT [Lump] (Parsec Void Text) Builder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) Builder
inParamP,
      Builder -> Fragment
ValuesParam (Builder -> Fragment)
-> StateT [Lump] (Parsec Void Text) Builder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) Builder
valuesParamP,
      Builder -> Fragment
NonParam (Builder -> Fragment)
-> StateT [Lump] (Parsec Void Text) Builder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) Builder
unstructuredP,
      Fragment
EndOfInput Fragment -> P () -> P Fragment
forall a b.
a
-> StateT [Lump] (Parsec Void Text) b
-> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Megaparsec.eof
    ]
  where
    -- It's not clear if there is *no* syntax for escaping a literal ] character from an identifier between brackets
    -- that looks like [this], but the documentation here doesn't mention any, and (brief) experimentation at the
    -- sqlite3 repl didn't reveal any.
    --
    -- So this parser is simple: left bracket, stuff, right bracket.
    bracketedIdentifierP :: P Text.Builder
    bracketedIdentifierP :: StateT [Lump] (Parsec Void Text) Builder
bracketedIdentifierP = do
      Builder
x <- Char -> StateT [Lump] (Parsec Void Text) Builder
char Char
'['
      Text
ys <- Maybe String
-> (Token Text -> Bool)
-> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"identifier") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
']')
      Builder
z <- Char -> StateT [Lump] (Parsec Void Text) Builder
char Char
']'
      Builder -> StateT [Lump] (Parsec Void Text) Builder
forall a. a -> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
ys Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
z)

    lineCommentP :: P ()
    lineCommentP :: P ()
lineCommentP = do
      Tokens Text
_ <- Tokens Text -> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Megaparsec.string Tokens Text
"--"
      Tokens Text
_ <- Maybe String
-> (Token Text -> Bool)
-> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"comment") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'\n')
      -- Eat whitespace after a line comment just so we don't end up with [Whitespace, Comment, Whitespace] fragments,
      -- which would get serialized as two consecutive spaces
      P ()
whitespaceP

    blockCommentP :: P ()
    blockCommentP :: P ()
blockCommentP = do
      Tokens Text
_ <- Tokens Text -> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Megaparsec.string Tokens Text
"/*"
      let loop :: StateT [Lump] (Parsec Void Text) (Tokens Text)
loop = do
            Tokens Text
_ <- Maybe String
-> (Token Text -> Bool)
-> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"comment") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'*')
            Tokens Text -> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Megaparsec.string Tokens Text
"*/" StateT [Lump] (Parsec Void Text) (Tokens Text)
-> StateT [Lump] (Parsec Void Text) (Tokens Text)
-> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall a.
StateT [Lump] (Parsec Void Text) a
-> StateT [Lump] (Parsec Void Text) a
-> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (StateT [Lump] (Parsec Void Text) (Token Text)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
Megaparsec.anySingle StateT [Lump] (Parsec Void Text) (Token Text)
-> StateT [Lump] (Parsec Void Text) (Tokens Text)
-> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall a b.
StateT [Lump] (Parsec Void Text) a
-> StateT [Lump] (Parsec Void Text) b
-> StateT [Lump] (Parsec Void Text) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT [Lump] (Parsec Void Text) (Tokens Text)
loop)
      Tokens Text
_ <- StateT [Lump] (Parsec Void Text) (Tokens Text)
loop
      -- See whitespace-eating comment above
      P ()
whitespaceP

    unstructuredP :: P Text.Builder
    unstructuredP :: StateT [Lump] (Parsec Void Text) Builder
unstructuredP = do
      Char
x <- StateT [Lump] (Parsec Void Text) Char
StateT [Lump] (Parsec Void Text) (Token Text)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
Megaparsec.anySingle
      Text
xs <-
        Maybe String
-> (Token Text -> Bool)
-> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhileP
          (String -> Maybe String
forall a. a -> Maybe a
Just String
"sql")
          \Token Text
c ->
            Bool -> Bool
not (Char -> Bool
Char.isSpace Char
Token Text
c)
              Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\'' -- 'string'
              Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"' -- "identifier"
              Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':' -- :param
              Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'@' -- @param
              Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'$' -- \$param
              Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'`' -- `identifier`
              Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'[' -- [identifier]
              Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-' -- -- comment (maybe)
              Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/' -- /* comment */ (maybe)
              Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'I' -- IN :param (maybe)
              Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'V' -- VALUES :param (maybe)
      Builder -> StateT [Lump] (Parsec Void Text) Builder
forall a. a -> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Builder
Text.Builder.char Char
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
xs)

    -- Parse either "@foobar" or just "@"
    atParamP :: P Text.Builder
    atParamP :: StateT [Lump] (Parsec Void Text) Builder
atParamP = do
      Char
_ <- Token Text -> StateT [Lump] (Parsec Void Text) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.char Char
Token Text
'@'
      StateT [Lump] (Parsec Void Text) Builder
haskellVariableP StateT [Lump] (Parsec Void Text) Builder
-> StateT [Lump] (Parsec Void Text) Builder
-> StateT [Lump] (Parsec Void Text) Builder
forall a.
StateT [Lump] (Parsec Void Text) a
-> StateT [Lump] (Parsec Void Text) a
-> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Builder -> StateT [Lump] (Parsec Void Text) Builder
forall a. a -> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
forall a. Monoid a => a
mempty

    colonParamP :: P Text.Builder
    colonParamP :: StateT [Lump] (Parsec Void Text) Builder
colonParamP = do
      Char
_ <- Token Text -> StateT [Lump] (Parsec Void Text) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.char Char
Token Text
':'
      StateT [Lump] (Parsec Void Text) Builder
haskellVariableP

    dollarParamP :: P Text.Builder
    dollarParamP :: StateT [Lump] (Parsec Void Text) Builder
dollarParamP = do
      Char
_ <- Token Text -> StateT [Lump] (Parsec Void Text) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.char Char
Token Text
'$'
      StateT [Lump] (Parsec Void Text) Builder
haskellVariableP

    inParamP :: P Text.Builder
    inParamP :: StateT [Lump] (Parsec Void Text) Builder
inParamP = do
      -- Use try (backtracking), so we can parse both:
      --
      --   * "IN :foo", an "in param", i.e. foo is a list of columns
      --   * "IN (...)", just normal unstructured IN expression, which can contain a subquery, function, etc
      --
      StateT [Lump] (Parsec Void Text) Builder
-> StateT [Lump] (Parsec Void Text) Builder
forall a.
StateT [Lump] (Parsec Void Text) a
-> StateT [Lump] (Parsec Void Text) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.try do
        Tokens Text
_ <- Tokens Text -> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Megaparsec.string Tokens Text
"IN"
        P ()
whitespaceP
        StateT [Lump] (Parsec Void Text) Builder
colonParamP

    valuesParamP :: P Text.Builder
    valuesParamP :: StateT [Lump] (Parsec Void Text) Builder
valuesParamP = do
      -- Use try (backtracking), so we can parse both:
      --
      --   * "VALUES :foo", a "values param", i.e. foo is a non-empty list of rows
      --   * "VALUES (:foo)" or similar, just normal unstructured SQL with params n' stuff, or not
      --
      StateT [Lump] (Parsec Void Text) Builder
-> StateT [Lump] (Parsec Void Text) Builder
forall a.
StateT [Lump] (Parsec Void Text) a
-> StateT [Lump] (Parsec Void Text) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.try do
        Tokens Text
_ <- Tokens Text -> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Megaparsec.string Tokens Text
"VALUES"
        P ()
whitespaceP
        StateT [Lump] (Parsec Void Text) Builder
colonParamP

    haskellVariableP :: P Text.Builder
    haskellVariableP :: StateT [Lump] (Parsec Void Text) Builder
haskellVariableP = do
      Char
x <- (Token Text -> Bool)
-> StateT [Lump] (Parsec Void Text) (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
Megaparsec.satisfy (\Token Text
c -> Char -> Bool
Char.isAlpha Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')
      Text
xs <- Maybe String
-> (Token Text -> Bool)
-> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"parameter") \Token Text
c -> Char -> Bool
Char.isAlphaNum Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''
      Builder -> StateT [Lump] (Parsec Void Text) Builder
forall a. a -> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Builder
Text.Builder.char Char
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
xs)

    whitespaceP :: P ()
    whitespaceP :: P ()
whitespaceP = do
      StateT [Lump] (Parsec Void Text) (Tokens Text) -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Maybe String
-> (Token Text -> Bool)
-> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"whitepsace") Char -> Bool
Token Text -> Bool
Char.isSpace)

-- @betwixt name c@ parses a @c@-surrounded string of arbitrary characters (naming the parser @name@), where two @c@s
-- in a row inside the string is the syntax for a single @c@. This is simply how escaping works in SQLite for
-- single-quoted things (strings), double-quoted things (usually identifiers, but weirdly, SQLite lets you quote
-- strings this way sometimes, probably because people don't know about single-quote syntax), and backtick-quoted
-- things (identifiers).
--
-- That is,
--
--   - 'foo''bar' denotes the string foo'bar
--   - "foo""bar" denotes the identifier foo"bar
--   - `foo``bar` denotes the idetifier foo`bar
--
-- This function returns the quoted thing *with* the surrounding quotes, and *retaining* any double-quoted things
-- within. For example, @betwixt "" '`'@ applied to the string "`foo``bar`" will return the full string "`foo``bar`".
--
-- This implementation is stolen from our own Travis Staton's @hasql-interpolate@ package, but tweaked a bit.
betwixt :: String -> Char -> P Text.Builder
betwixt :: String -> Char -> StateT [Lump] (Parsec Void Text) Builder
betwixt String
name Char
quote = do
  Builder
startQuote <- StateT [Lump] (Parsec Void Text) Builder
quoteP
  let loop :: Builder -> StateT [Lump] (Parsec Void Text) Builder
loop Builder
sofar = do
        Text
content <- Maybe String
-> (Token Text -> Bool)
-> StateT [Lump] (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
name) (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
quote)
        P () -> P ()
forall a. StateT [Lump] (Parsec Void Text) a -> P ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
Megaparsec.notFollowedBy P ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Megaparsec.eof
        let escapedQuoteAndMore :: StateT [Lump] (Parsec Void Text) Builder
escapedQuoteAndMore = do
              Builder
escapedQuote <- StateT [Lump] (Parsec Void Text) Builder
-> StateT [Lump] (Parsec Void Text) Builder
forall a.
StateT [Lump] (Parsec Void Text) a
-> StateT [Lump] (Parsec Void Text) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.try (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
(<>) (Builder -> Builder -> Builder)
-> StateT [Lump] (Parsec Void Text) Builder
-> StateT [Lump] (Parsec Void Text) (Builder -> Builder)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) Builder
quoteP StateT [Lump] (Parsec Void Text) (Builder -> Builder)
-> StateT [Lump] (Parsec Void Text) Builder
-> StateT [Lump] (Parsec Void Text) Builder
forall a b.
StateT [Lump] (Parsec Void Text) (a -> b)
-> StateT [Lump] (Parsec Void Text) a
-> StateT [Lump] (Parsec Void Text) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT [Lump] (Parsec Void Text) Builder
quoteP)
              Builder -> StateT [Lump] (Parsec Void Text) Builder
loop (Builder
sofar Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
content Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
escapedQuote)
        let allDone :: StateT [Lump] (Parsec Void Text) Builder
allDone = do
              Builder
endQuote <- StateT [Lump] (Parsec Void Text) Builder
quoteP
              Builder -> StateT [Lump] (Parsec Void Text) Builder
forall a. a -> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder
sofar Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
content Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
endQuote)
        StateT [Lump] (Parsec Void Text) Builder
escapedQuoteAndMore StateT [Lump] (Parsec Void Text) Builder
-> StateT [Lump] (Parsec Void Text) Builder
-> StateT [Lump] (Parsec Void Text) Builder
forall a.
StateT [Lump] (Parsec Void Text) a
-> StateT [Lump] (Parsec Void Text) a
-> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StateT [Lump] (Parsec Void Text) Builder
allDone
  Builder -> StateT [Lump] (Parsec Void Text) Builder
loop Builder
startQuote
  where
    quoteP :: StateT [Lump] (Parsec Void Text) Builder
quoteP =
      Char -> StateT [Lump] (Parsec Void Text) Builder
char Char
quote

char :: Char -> P Text.Builder
char :: Char -> StateT [Lump] (Parsec Void Text) Builder
char Char
c =
  Token Text -> StateT [Lump] (Parsec Void Text) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.char Char
Token Text
c StateT [Lump] (Parsec Void Text) Char
-> Builder -> StateT [Lump] (Parsec Void Text) Builder
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char -> Builder
Text.Builder.char Char
c

-- Few common text builders

b_qmark :: Text.Builder
b_qmark :: Builder
b_qmark = Char -> Builder
Text.Builder.char Char
'?'

b_lparen :: Text.Builder
b_lparen :: Builder
b_lparen = Char -> Builder
Text.Builder.char Char
'('

b_rparen :: Text.Builder
b_rparen :: Builder
b_rparen = Char -> Builder
Text.Builder.char Char
')'

b_commaSep :: [Text.Builder] -> Text.Builder
b_commaSep :: [Builder] -> Builder
b_commaSep =
  Builder -> [Builder] -> Builder
forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
Text.Builder.intercalate (Text -> Builder
Text.Builder.text Text
", ")