{-# LANGUAGE OverloadedStrings #-}
-- | Incomplete parser for SQL CREATE TABLE statements.
--   Needed to figure out whether any given column is auto-incrementing
--   or not. It's super inefficient, but doesn't really matter since it'll
--   only ever be invoked during validation.
module Database.Selda.SQLite.Parser (colsFromQuery) where
import Control.Applicative
import Control.Monad (void, msum, MonadPlus (..))
import Data.Char (isSpace, isAlpha, isAlphaNum)
import Data.Maybe (isJust, catMaybes)
import Data.Text (Text)
import qualified Data.Text as Text

colsFromQuery :: Text -> [(Text, (Text, Bool))]
colsFromQuery :: Text -> [(Text, (Text, Bool))]
colsFromQuery = forall a. Parser a -> Text -> a
parse' Parser [(Text, (Text, Bool))]
parseCreateQueryCols

newtype Parser a = P { forall a. Parser a -> Text -> Maybe (Text, a)
unP :: (Text -> Maybe (Text, a)) }

instance Functor Parser where
  fmap :: forall a b. (a -> b) -> Parser a -> Parser b
fmap a -> b
f (P Text -> Maybe (Text, a)
g) = forall a. (Text -> Maybe (Text, a)) -> Parser a
P (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (Text, a)
g)

instance Applicative Parser where
  pure :: forall a. a -> Parser a
pure a
x = forall a. (Text -> Maybe (Text, a)) -> Parser a
P forall a b. (a -> b) -> a -> b
$ \Text
t -> forall a. a -> Maybe a
Just (Text
t, a
x)
  Parser (a -> b)
f <*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
<*> Parser a
x = Parser (a -> b)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a -> b
f' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f' Parser a
x

instance Alternative Parser where
  empty :: forall a. Parser a
empty = forall a. (Text -> Maybe (Text, a)) -> Parser a
P forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a. Maybe a
Nothing
  P Text -> Maybe (Text, a)
f <|> :: forall a. Parser a -> Parser a -> Parser a
<|> P Text -> Maybe (Text, a)
g = forall a. (Text -> Maybe (Text, a)) -> Parser a
P forall a b. (a -> b) -> a -> b
$ \Text
s ->
    case Text -> Maybe (Text, a)
f Text
s of
      res :: Maybe (Text, a)
res@(Just (Text, a)
_) -> Maybe (Text, a)
res
      Maybe (Text, a)
_            -> Text -> Maybe (Text, a)
g Text
s

instance Monad Parser where
  return :: forall a. a -> Parser a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  P Text -> Maybe (Text, a)
m >>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
f = forall a. (Text -> Maybe (Text, a)) -> Parser a
P forall a b. (a -> b) -> a -> b
$ \Text
s -> do
    case Text -> Maybe (Text, a)
m Text
s of
      Just (Text
rest, a
x) -> forall a. Parser a -> Text -> Maybe (Text, a)
unP (a -> Parser b
f a
x) Text
rest
      Maybe (Text, a)
_              -> forall a. Maybe a
Nothing

instance MonadPlus Parser where
  mzero :: forall a. Parser a
mzero = forall (f :: * -> *) a. Alternative f => f a
empty
  mplus :: forall a. Parser a -> Parser a -> Parser a
mplus = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

parse :: Parser a -> Text -> Maybe a
parse :: forall a. Parser a -> Text -> Maybe a
parse (P Text -> Maybe (Text, a)
f) Text
t = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (Text, a)
f Text
t

parse' :: Parser a -> Text -> a
parse' :: forall a. Parser a -> Text -> a
parse' Parser a
f Text
t = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"no parse: '" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
t forall a. [a] -> [a] -> [a]
++ [Char]
"'") forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Text -> Maybe a
parse Parser a
f Text
t

lowerText :: Text -> Parser ()
lowerText :: Text -> Parser ()
lowerText Text
prefix = forall a. (Text -> Maybe (Text, a)) -> Parser a
P forall a b. (a -> b) -> a -> b
$ \Text
s ->
  case Int -> Text -> (Text, Text)
Text.splitAt (Text -> Int
Text.length Text
prefix) Text
s of
    (Text
prefix', Text
rest) | Text
prefix forall a. Eq a => a -> a -> Bool
== Text -> Text
Text.toLower Text
prefix' -> forall a. a -> Maybe a
Just (Text
rest, ())
    (Text, Text)
_                                                -> forall a. Maybe a
Nothing

charP :: (Char -> Bool) -> Parser Char
charP :: (Char -> Bool) -> Parser Char
charP Char -> Bool
p = forall a. (Text -> Maybe (Text, a)) -> Parser a
P forall a b. (a -> b) -> a -> b
$ \Text
s ->
  case Int -> Text -> (Text, Text)
Text.splitAt Int
1 Text
s of
    (Text
prefix, Text
rest) | (Char -> Bool) -> Text -> Bool
Text.any Char -> Bool
p Text
prefix -> forall a. a -> Maybe a
Just (Text
rest, Text -> Char
Text.head Text
prefix)
    (Text, Text)
_                                  -> forall a. Maybe a
Nothing

char :: Char -> Parser Char
char :: Char -> Parser Char
char Char
c = (Char -> Bool) -> Parser Char
charP (forall a. Eq a => a -> a -> Bool
== Char
c)

space :: Parser ()
space :: Parser ()
space = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Char
charP Char -> Bool
isSpace

spaces :: Parser ()
spaces :: Parser ()
spaces = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser ()
space

sepBy1 :: Parser s -> Parser a -> Parser [a]
sepBy1 :: forall s a. Parser s -> Parser a -> Parser [a]
sepBy1 Parser s
sep Parser a
p = do
  a
x <- Parser a
p
  Maybe [a]
xs <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ Parser s
sep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s a. Parser s -> Parser a -> Parser [a]
sepBy1 Parser s
sep Parser a
p
  case Maybe [a]
xs of
    Just [a]
xs' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
xforall a. a -> [a] -> [a]
:[a]
xs')
    Maybe [a]
_        -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [a
x]

commaSeparated :: Parser a -> Parser [a]
commaSeparated :: forall a. Parser a -> Parser [a]
commaSeparated = forall s a. Parser s -> Parser a -> Parser [a]
sepBy1 (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Char
char Char
',' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
space)

keywords :: [Text]
keywords :: [Text]
keywords = [Text
"constraint", Text
"unique", Text
"primary key"]

parseCreateQueryCols :: Parser [(Text, (Text, Bool))]
parseCreateQueryCols :: Parser [(Text, (Text, Bool))]
parseCreateQueryCols = do
  Text -> Parser ()
lowerText Text
"create table"
  Parser ()
spaces
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Parser Text
sqliteIdentifier
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
space
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
char Char
'('
  [Maybe (Text, (Text, Bool))]
cols <- forall a. Parser a -> Parser [a]
commaSeparated Parser (Maybe (Text, (Text, Bool)))
parseCol forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
space
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
char Char
')'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe (Text, (Text, Bool))]
cols

parseCol :: Parser (Maybe (Text, (Text, Bool)))
parseCol :: Parser (Maybe (Text, (Text, Bool)))
parseCol = do
    Either () (Text, (Text, Bool))
decl <- forall {b}. Parser (Either () b)
constraint forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}. Parser (Either a (Text, (Text, Bool)))
column
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either () (Text, (Text, Bool))
decl of
      Right (Text, (Text, Bool))
col -> forall a. a -> Maybe a
Just (Text, (Text, Bool))
col
      Either () (Text, (Text, Bool))
_         -> forall a. Maybe a
Nothing
  where
    column :: Parser (Either a (Text, (Text, Bool)))
column = do
      Text
name <- Parser Text
sqliteIdentifier
      Parser ()
spaces
      Text
ty <- Parser Text
sqliteIdentifier
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ Parser ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser ()
lowerText Text
"primary key"
      Maybe ()
isAuto <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ Parser ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser ()
lowerText Text
"autoincrement"
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Char
charP (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c)
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ do
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
char Char
'('
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser [a]
commaSeparated Parser Text
sqliteIdentifier
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
char Char
')'
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ (Text
name, (Text
ty, forall a. Maybe a -> Bool
isJust Maybe ()
isAuto))
    constraint :: Parser (Either () b)
constraint = do
      forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a b. (a -> b) -> [a] -> [b]
map Text -> Parser ()
lowerText [Text]
keywords)
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
        [ forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser Text
sqliteIdentifier
        , forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
char Char
'('
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser [a]
commaSeparated Parser Text
sqliteIdentifier
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
char Char
')'
        , Parser ()
spaces
        ]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ()

sqliteIdentifier :: Parser Text
sqliteIdentifier :: Parser Text
sqliteIdentifier = [Char] -> Text
Text.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser [Char]
quoted forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [Char]
unquoted)
  where
    unquoted :: Parser [Char]
unquoted = do
      Char
x <- (Char -> Bool) -> Parser Char
charP forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'
      [Char]
xs <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Char
charP forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'$'
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Char
xforall a. a -> [a] -> [a]
:[Char]
xs)
    quoted :: Parser [Char]
quoted = Char -> Parser Char
char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Char
quotedChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'"'
    quotedChar :: Parser Char
quotedChar = (Char -> Parser Char
char Char
'"' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Char
char Char
'"') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Parser Char
charP (forall a. Eq a => a -> a -> Bool
/= Char
'"')