{-# LANGUAGE MagicHash #-}
-- | Finding the positional parameter references (@\@p1@, @\@p2@, ...) in
-- T-SQL text, so that 'Hmssql.Query.mkQuery' can turn them into placeholders
-- that renumber when queries are concatenated.
--
-- This is not a T-SQL parser.  It only knows enough of the lexical
-- structure to leave alone what is inside string literals (@'...'@ and
-- @N'...'@, with @''@ for a quote), quoted identifiers (@\"...\"@ with
-- @\"\"@, and @[...]@ with @]]@) and comments (@-- ...@ to the end of the
-- line, and @\/* ... *\/@, which T-SQL nests).  Everything unterminated
-- runs to the end of the text; the scanner never fails.
module Hmssql.Query.Lexer
  ( Fragment (..)
  , lexPlaceholders
  , isVariableChar
  ) where

import Data.Char (GeneralCategory (..), generalCategory, isDigit)
import qualified Data.Text as T
import Data.Text.Internal (Text (..))
import Hmssql.Internal.Derived

-- | A piece of SQL text, or a reference to a positional parameter (1-based).
data Fragment
  = Static !Text
  | Placeholder !Int

instance Show Fragment where
  showsPrec :: Int -> Fragment -> ShowS
showsPrec Int
p = \case
    Static Text
a -> Int -> Addr# -> Text -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"Static"# Text
a
    Placeholder Int
a -> Int -> Addr# -> Int -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"Placeholder"# Int
a
  {-# OPAQUE showsPrec #-}

instance Eq Fragment where
  Fragment
x == :: Fragment -> Fragment -> Bool
== Fragment
y = case (Fragment
x, Fragment
y) of
    (Static Text
a, Static Text
a') -> Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
a Text
a'
    (Placeholder Int
a, Placeholder Int
a') -> Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
a'
    (Fragment, Fragment)
_ -> Bool
False
  {-# OPAQUE (==) #-}

-- | Split T-SQL text into static text and positional placeholders.
--
-- A placeholder is @\@p@ (either case) followed by one or more ASCII digits,
-- standing alone as a name: the character before the @\@@ is not @\@@ or a
-- character of a variable name (so @\@\@p1@ and @x\@p1@ are text), and the
-- character after the digits is not one either (so @\@p1x@, @\@p1_old@ and
-- @\@p1é@ are other variables).  @\@P01@ is placeholder 1.  More than nine
-- digits is text (no request has that many parameters).
--
-- Adjacent static text is merged; the result concatenates back to the input
-- with each placeholder rendered as @\@pN@.
--
-- The scanner only finds the placeholders; the static text between two of
-- them is one slice of the input.  (Building it from the pieces the
-- scanner passes over, appending as it went, was quadratic in the number
-- of special characters between placeholders: every @-@ of @a - b@, every
-- @''@ in a string, every @/@ or @*@ in a comment.)
lexPlaceholders :: Text -> [Fragment]
lexPlaceholders :: Text -> [Fragment]
lexPlaceholders whole :: Text
whole@(Text Array
arr Int
off0 Int
len0) = Int -> [(Int, Int, Int)] -> [Fragment]
fragments Int
off0 (Maybe Char -> Text -> [(Int, Int, Int)]
go Maybe Char
forall a. Maybe a
Nothing Text
whole)
  where
    -- The static text from @from@ to the next placeholder, and so on.
    fragments :: Int -> [(Int, Int, Int)] -> [Fragment]
fragments Int
from = \case
      [] -> Int -> Int -> [Fragment]
static Int
from (Int
off0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len0)
      (Int
start, Int
end, Int
n) : [(Int, Int, Int)]
ps -> Int -> Int -> [Fragment]
static Int
from Int
start [Fragment] -> [Fragment] -> [Fragment]
forall a. [a] -> [a] -> [a]
++ Int -> Fragment
Placeholder Int
n Fragment -> [Fragment] -> [Fragment]
forall a. a -> [a] -> [a]
: Int -> [(Int, Int, Int)] -> [Fragment]
fragments Int
end [(Int, Int, Int)]
ps
    static :: Int -> Int -> [Fragment]
static Int
a Int
b = [Text -> Fragment
Static (Array -> Int -> Int -> Text
Text Array
arr Int
a (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a)) | Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
a]

    -- The placeholders in @t@, as the offsets (into the input's array) of
    -- their @\@@ and of the end of their digits, and their numbers.
    -- @prev@ is the character before @t@, if any.
    go :: Maybe Char -> Text -> [(Int, Int, Int)]
    go :: Maybe Char -> Text -> [(Int, Int, Int)]
go Maybe Char
prev Text
t
      | Text -> Bool
T.null Text
t = []
      | Bool
otherwise =
          let (Text
plain, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
ordinary Text
t
              prev' :: Maybe Char
prev' = if Text -> Bool
T.null Text
plain then Maybe Char
prev else Char -> Maybe Char
forall a. a -> Maybe a
Just (HasCallStack => Text -> Char
Text -> Char
T.last Text
plain)
           in Maybe Char -> Text -> [(Int, Int, Int)]
special Maybe Char
prev' Text
rest

    special :: Maybe Char -> Text -> [(Int, Int, Int)]
special Maybe Char
prev Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
      Maybe (Char, Text)
Nothing -> []
      Just (Char
c, Text
rest) -> case Char
c of
        Char
'\'' -> Char -> Text -> [(Int, Int, Int)]
skipQuoted Char
'\'' Text
rest
        Char
'"' -> Char -> Text -> [(Int, Int, Int)]
skipQuoted Char
'"' Text
rest
        Char
'[' -> Char -> Text -> [(Int, Int, Int)]
skipQuoted Char
']' Text
rest
        Char
'-' | Text
"--" Text -> Text -> Bool
`T.isPrefixOf` Text
t -> Maybe Char -> Text -> [(Int, Int, Int)]
go (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'-') ((Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') Text
t)
        Char
'/' | Text
"/*" Text -> Text -> Bool
`T.isPrefixOf` Text
t -> Maybe Char -> Text -> [(Int, Int, Int)]
go (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'/') (Int -> Text -> Text
blockComment (Int
1 :: Int) (Int -> Text -> Text
T.drop Int
2 Text
t))
        Char
'@' | Maybe Char -> Bool
placeholderMayStart Maybe Char
prev
            , Just (Char
p, Text
afterP) <- Text -> Maybe (Char, Text)
T.uncons Text
rest
            , Char
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'p' Bool -> Bool -> Bool
|| Char
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'P'
            , (Text
digits, Text
after) <- (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isAsciiDigit Text
afterP
            , Bool -> Bool
not (Text -> Bool
T.null Text
digits), Text -> Int
T.length Text
digits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
9
            , Bool -> (Char -> Bool) -> Maybe Char -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isVariableChar) ((Char, Text) -> Char
forall a b. (a, b) -> a
fst ((Char, Text) -> Char) -> Maybe (Char, Text) -> Maybe Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (Char, Text)
T.uncons Text
after)
            -> (Text -> Int
offset Text
t, Text -> Int
end Text
digits, (Int -> Char -> Int) -> Int -> Text -> Int
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' (\Int
n Char
d -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'0') Int
0 Text
digits)
                 (Int, Int, Int) -> [(Int, Int, Int)] -> [(Int, Int, Int)]
forall a. a -> [a] -> [a]
: Maybe Char -> Text -> [(Int, Int, Int)]
go (Char -> Maybe Char
forall a. a -> Maybe a
Just (HasCallStack => Text -> Char
Text -> Char
T.last Text
digits)) Text
after
        Char
_ -> Maybe Char -> Text -> [(Int, Int, Int)]
go (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c) Text
rest

    -- Where a non-empty text starts and ends in the input's array.  (An
    -- empty one may be text's shared empty value, at offset 0.)
    offset :: Text -> Int
offset (Text Array
_ Int
o Int
_) = Int
o
    end :: Text -> Int
end (Text Array
_ Int
o Int
l) = Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l

    -- Not the start of anything the scanner looks at.
    ordinary :: Char -> Bool
ordinary Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\'' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'[' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'@'

    -- A quoted region after its opening character: up to the closing one,
    -- where a doubled closing character stays inside.  (For @[...]@ the
    -- closing character differs from the opening one; a doubled @]@ is an
    -- escaped bracket, as for quotes.)  The character before what follows
    -- is the closing one, or the region's last (or the opening one) if it
    -- is unterminated.
    skipQuoted :: Char -> Text -> [(Int, Int, Int)]
skipQuoted Char
close = Bool -> Text -> [(Int, Int, Int)]
region Bool
False
      where
        -- @doubled@: a doubled closing character came before @t@.
        region :: Bool -> Text -> [(Int, Int, Int)]
region Bool
doubled Text
t =
          let (Text
body, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
close) Text
t
           in case Text -> Maybe (Char, Text)
T.uncons Text
rest of
                Maybe (Char, Text)
Nothing -> Maybe Char -> Text -> [(Int, Int, Int)]
go (Char -> Maybe Char
forall a. a -> Maybe a
Just (Bool -> Text -> Char
lastOf Bool
doubled Text
body)) Text
rest
                Just (Char
_, Text
afterClose)
                  | Just (Char
c, Text
afterDouble) <- Text -> Maybe (Char, Text)
T.uncons Text
afterClose, Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
close -> Bool -> Text -> [(Int, Int, Int)]
region Bool
True Text
afterDouble
                  | Bool
otherwise -> Maybe Char -> Text -> [(Int, Int, Int)]
go (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
close) Text
afterClose
        -- An unterminated region's last character: of its body, or of the
        -- doubled closing character before it, or the opening character.
        lastOf :: Bool -> Text -> Char
lastOf Bool
doubled Text
body
          | Bool -> Bool
not (Text -> Bool
T.null Text
body) = HasCallStack => Text -> Char
Text -> Char
T.last Text
body
          | Bool
doubled = Char
close
          | Bool
otherwise = Char
opening
        opening :: Char
opening = case Char
close of
          Char
']' -> Char
'['
          Char
q -> Char
q

    -- @/* ... */@ after its opening, nesting; an unterminated one runs to
    -- the end.  What follows it.
    blockComment :: Int -> Text -> Text
    blockComment :: Int -> Text -> Text
blockComment Int
0 Text
rest = Text
rest
    blockComment Int
d Text
rest
      | Text -> Bool
T.null Text
rest = Text
rest
      | Text
"/*" Text -> Text -> Bool
`T.isPrefixOf` Text
rest = Int -> Text -> Text
blockComment (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Text -> Text
T.drop Int
2 Text
rest)
      | Text
"*/" Text -> Text -> Bool
`T.isPrefixOf` Text
rest = Int -> Text -> Text
blockComment (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> Text -> Text
T.drop Int
2 Text
rest)
      | Bool
otherwise = Int -> Text -> Text
blockComment Int
d ((Char -> Bool) -> Text -> Text
T.dropWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'*') (Int -> Text -> Text
T.drop Int
1 Text
rest))

    placeholderMayStart :: Maybe Char -> Bool
placeholderMayStart = \case
      Maybe Char
Nothing -> Bool
True
      Just Char
c -> Bool -> Bool
not (Char -> Bool
isVariableChar Char
c)

isAsciiDigit :: Char -> Bool
isAsciiDigit :: Char -> Bool
isAsciiDigit Char
c = Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9'

-- | A character of a T-SQL variable name after the leading @\@@: a letter,
-- combining mark, decimal digit or letter number from the Basic
-- Multilingual Plane, or one of @\@@, @#@, @$@ and @_@.  (SQL Server
-- rejects surrogates in identifiers, so nothing above U+FFFF.)
isVariableChar :: Char -> Bool
isVariableChar :: Char -> Bool
isVariableChar Char
c = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFFFF' Bool -> Bool -> Bool
&& (Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"@#$_" :: String) Bool -> Bool -> Bool
|| case Char -> GeneralCategory
generalCategory Char
c of
  GeneralCategory
UppercaseLetter -> Bool
True
  GeneralCategory
LowercaseLetter -> Bool
True
  GeneralCategory
TitlecaseLetter -> Bool
True
  GeneralCategory
ModifierLetter -> Bool
True
  GeneralCategory
OtherLetter -> Bool
True
  GeneralCategory
NonSpacingMark -> Bool
True
  GeneralCategory
SpacingCombiningMark -> Bool
True
  GeneralCategory
DecimalNumber -> Bool
True
  GeneralCategory
LetterNumber -> Bool
True
  GeneralCategory
_ -> Bool
False)