{-# 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.Megaparsec qualified as Megaparsec
import Text.Megaparsec.Char qualified as Megaparsec
import TextBuilder (TextBuilder)
import TextBuilder qualified
import Unison.Prelude
import Prelude hiding (unzip)

-- | 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
      (sqlPieces, paramsPieces) <- [(Exp, Exp)] -> ([Exp], [Exp])
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f 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 $(pure (TH.ListE sqlPieces)))
          (mconcat $(pure (TH.ListE 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 =
  TextBuilder -> Text
TextBuilder.toText (TextBuilder
"IN (" TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> [TextBuilder] -> TextBuilder
b_commaSep ((a -> TextBuilder) -> [a] -> [TextBuilder]
forall a b. (a -> b) -> [a] -> [b]
map (\a
_ -> TextBuilder
b_qmark) [a]
scalars) TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> TextBuilder
b_rparen)

valuesSql :: (Sqlite.Simple.ToRow a) => List.NonEmpty a -> Text
valuesSql :: forall a. ToRow a => NonEmpty a -> Text
valuesSql NonEmpty a
values =
  TextBuilder -> Text
TextBuilder.toText (TextBuilder -> Text) -> TextBuilder -> Text
forall a b. (a -> b) -> a -> b
$
    TextBuilder
"VALUES " TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> [TextBuilder] -> TextBuilder
b_commaSep (Int -> TextBuilder -> [TextBuilder]
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 -> TextBuilder
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 -> TextBuilder
    valueSql :: Int -> TextBuilder
valueSql Int
columns =
      TextBuilder
b_lparen TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> [TextBuilder] -> TextBuilder
b_commaSep (Int -> TextBuilder -> [TextBuilder]
forall a. Int -> a -> [a]
replicate Int
columns TextBuilder
b_qmark) TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> TextBuilder
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 TextBuilder
sql [Param]
params -> Text -> [Param] -> ParsedLump
ParsedOuterLump (TextBuilder -> Text
TextBuilder.toText TextBuilder
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 !TextBuilder ![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 TextBuilder
fragment -> TextBuilder -> ([Param] -> P [Param]) -> P ()
outer TextBuilder
fragment [Param] -> P [Param]
forall a. a -> StateT [Lump] (Parsec Void Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    AtParam TextBuilder
param ->
      TextBuilder -> ([Param] -> P [Param]) -> P ()
outer
        TextBuilder
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 = TextBuilder -> Text
TextBuilder.toText TextBuilder
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 TextBuilder
param -> TextBuilder -> ([Param] -> P [Param]) -> P ()
outer TextBuilder
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 (TextBuilder -> Text
TextBuilder.toText TextBuilder
param) Param -> [Param] -> [Param]
forall a. a -> [a] -> [a]
: [Param]
params)
    DollarParam TextBuilder
param -> do
      ([Lump] -> [Lump]) -> P ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' (Text -> Lump
InnerLump (TextBuilder -> Text
TextBuilder.toText TextBuilder
param) Lump -> [Lump] -> [Lump]
forall a. a -> [a] -> [a]
:)
      P ()
parser
    InParam TextBuilder
param -> do
      ([Lump] -> [Lump]) -> P ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' (Text -> Lump
InLump (TextBuilder -> Text
TextBuilder.toText TextBuilder
param) Lump -> [Lump] -> [Lump]
forall a. a -> [a] -> [a]
:)
      P ()
parser
    ValuesParam TextBuilder
param -> do
      ([Lump] -> [Lump]) -> P ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' (Text -> Lump
ValuesLump (TextBuilder -> Text
TextBuilder.toText TextBuilder
param) Lump -> [Lump] -> [Lump]
forall a. a -> [a] -> [a]
:)
      P ()
parser
    Fragment
Whitespace -> TextBuilder -> ([Param] -> P [Param]) -> P ()
outer (Char -> TextBuilder
TextBuilder.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 :: TextBuilder -> ([Param] -> P [Param]) -> P ()
    outer :: TextBuilder -> ([Param] -> P [Param]) -> P ()
outer TextBuilder
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 TextBuilder
sql [Param]
params : [Lump]
lumps -> do
          let !sql' :: TextBuilder
sql' = TextBuilder
sql TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> TextBuilder
s
          params' <- [Param] -> P [Param]
g [Param]
params
          State.put (OuterLump sql' params' : lumps)
        [Lump]
lumps -> do
          params <- [Param] -> P [Param]
g []
          State.put (OuterLump s params : 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 !TextBuilder
  | AtParam !TextBuilder -- "@foo" ==> "foo"; "@" ==> ""
  | ColonParam !TextBuilder -- ":foo" ==> "foo"
  | DollarParam !TextBuilder -- "$foo" ==> "foo"
  | InParam !TextBuilder -- "IN :foo" ==> "foo"
  | ValuesParam !TextBuilder -- "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,
      TextBuilder -> Fragment
NonParam (TextBuilder -> Fragment)
-> StateT [Lump] (Parsec Void Text) TextBuilder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Char -> StateT [Lump] (Parsec Void Text) TextBuilder
betwixt String
"string" Char
'\'',
      TextBuilder -> Fragment
NonParam (TextBuilder -> Fragment)
-> StateT [Lump] (Parsec Void Text) TextBuilder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Char -> StateT [Lump] (Parsec Void Text) TextBuilder
betwixt String
"identifier" Char
'"',
      TextBuilder -> Fragment
NonParam (TextBuilder -> Fragment)
-> StateT [Lump] (Parsec Void Text) TextBuilder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Char -> StateT [Lump] (Parsec Void Text) TextBuilder
betwixt String
"identifier" Char
'`',
      TextBuilder -> Fragment
NonParam (TextBuilder -> Fragment)
-> StateT [Lump] (Parsec Void Text) TextBuilder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) TextBuilder
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,
      TextBuilder -> Fragment
ColonParam (TextBuilder -> Fragment)
-> StateT [Lump] (Parsec Void Text) TextBuilder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) TextBuilder
colonParamP,
      TextBuilder -> Fragment
AtParam (TextBuilder -> Fragment)
-> StateT [Lump] (Parsec Void Text) TextBuilder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) TextBuilder
atParamP,
      TextBuilder -> Fragment
DollarParam (TextBuilder -> Fragment)
-> StateT [Lump] (Parsec Void Text) TextBuilder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) TextBuilder
dollarParamP,
      TextBuilder -> Fragment
InParam (TextBuilder -> Fragment)
-> StateT [Lump] (Parsec Void Text) TextBuilder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) TextBuilder
inParamP,
      TextBuilder -> Fragment
ValuesParam (TextBuilder -> Fragment)
-> StateT [Lump] (Parsec Void Text) TextBuilder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) TextBuilder
valuesParamP,
      TextBuilder -> Fragment
NonParam (TextBuilder -> Fragment)
-> StateT [Lump] (Parsec Void Text) TextBuilder -> P Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) TextBuilder
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 TextBuilder
    bracketedIdentifierP :: StateT [Lump] (Parsec Void Text) TextBuilder
bracketedIdentifierP = do
      x <- Char -> StateT [Lump] (Parsec Void Text) TextBuilder
char Char
'['
      ys <- Megaparsec.takeWhile1P (Just "identifier") (/= ']')
      z <- char ']'
      pure (x <> TextBuilder.text ys <> z)

    lineCommentP :: P ()
    lineCommentP :: P ()
lineCommentP = do
      _ <- 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
"--"
      _ <- Megaparsec.takeWhileP (Just "comment") (/= '\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
      whitespaceP

    blockCommentP :: P ()
    blockCommentP :: P ()
blockCommentP = do
      _ <- 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 = do
            _ <- 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
'*')
            Megaparsec.string "*/" <|> (Megaparsec.anySingle >> loop)
      _ <- loop
      -- See whitespace-eating comment above
      whitespaceP

    unstructuredP :: P TextBuilder
    unstructuredP :: StateT [Lump] (Parsec Void Text) TextBuilder
unstructuredP = do
      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
      xs <-
        Megaparsec.takeWhileP
          (Just "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)
      pure (TextBuilder.char x <> TextBuilder.text xs)

    -- Parse either "@foobar" or just "@"
    atParamP :: P TextBuilder
    atParamP :: StateT [Lump] (Parsec Void Text) TextBuilder
atParamP = do
      _ <- 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
'@'
      haskellVariableP <|> pure mempty

    colonParamP :: P TextBuilder
    colonParamP :: StateT [Lump] (Parsec Void Text) TextBuilder
colonParamP = do
      _ <- 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
':'
      haskellVariableP

    dollarParamP :: P TextBuilder
    dollarParamP :: StateT [Lump] (Parsec Void Text) TextBuilder
dollarParamP = do
      _ <- 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
'$'
      haskellVariableP

    inParamP :: P TextBuilder
    inParamP :: StateT [Lump] (Parsec Void Text) TextBuilder
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) TextBuilder
-> StateT [Lump] (Parsec Void Text) TextBuilder
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 -> 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"
        whitespaceP
        colonParamP

    valuesParamP :: P TextBuilder
    valuesParamP :: StateT [Lump] (Parsec Void Text) TextBuilder
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) TextBuilder
-> StateT [Lump] (Parsec Void Text) TextBuilder
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 -> 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"
        whitespaceP
        colonParamP

    haskellVariableP :: P TextBuilder
    haskellVariableP :: StateT [Lump] (Parsec Void Text) TextBuilder
haskellVariableP = do
      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
'_')
      xs <- Megaparsec.takeWhileP (Just "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
'\''
      pure (TextBuilder.char x <> TextBuilder.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 TextBuilder
betwixt :: String -> Char -> StateT [Lump] (Parsec Void Text) TextBuilder
betwixt String
name Char
quote = do
  startQuote <- StateT [Lump] (Parsec Void Text) TextBuilder
quoteP
  let loop TextBuilder
sofar = do
        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)
        Megaparsec.notFollowedBy Megaparsec.eof
        let escapedQuoteAndMore = do
              escapedQuote <- StateT [Lump] (Parsec Void Text) TextBuilder
-> StateT [Lump] (Parsec Void Text) TextBuilder
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 (TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
(<>) (TextBuilder -> TextBuilder -> TextBuilder)
-> StateT [Lump] (Parsec Void Text) TextBuilder
-> StateT [Lump] (Parsec Void Text) (TextBuilder -> TextBuilder)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Lump] (Parsec Void Text) TextBuilder
quoteP StateT [Lump] (Parsec Void Text) (TextBuilder -> TextBuilder)
-> StateT [Lump] (Parsec Void Text) TextBuilder
-> StateT [Lump] (Parsec Void Text) TextBuilder
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) TextBuilder
quoteP)
              loop (sofar <> TextBuilder.text content <> escapedQuote)
        let allDone = do
              endQuote <- StateT [Lump] (Parsec Void Text) TextBuilder
quoteP
              pure (sofar <> TextBuilder.text content <> endQuote)
        escapedQuoteAndMore <|> allDone
  loop startQuote
  where
    quoteP :: StateT [Lump] (Parsec Void Text) TextBuilder
quoteP =
      Char -> StateT [Lump] (Parsec Void Text) TextBuilder
char Char
quote

char :: Char -> P TextBuilder
char :: Char -> StateT [Lump] (Parsec Void Text) TextBuilder
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
-> TextBuilder -> StateT [Lump] (Parsec Void Text) TextBuilder
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char -> TextBuilder
TextBuilder.char Char
c

-- Few common text builders

b_qmark :: TextBuilder
b_qmark :: TextBuilder
b_qmark = Char -> TextBuilder
TextBuilder.char Char
'?'

b_lparen :: TextBuilder
b_lparen :: TextBuilder
b_lparen = Char -> TextBuilder
TextBuilder.char Char
'('

b_rparen :: TextBuilder
b_rparen :: TextBuilder
b_rparen = Char -> TextBuilder
TextBuilder.char Char
')'

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