{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
----------------------------------------------------------------------------
-- |
-- Module      :  Codec.Winery.Query.Parser
-- Copyright   :  (c) Fumiaki Kinoshita 2019
-- License     :  BSD3
-- Stability   :  Experimental
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--
-- The language for winery queries
--
-- See the Pretty-printing section of README.md for examples.
--
-----------------------------------------------------------------------------
module Codec.Winery.Query.Parser (parseQuery) where

import Prelude hiding ((.), id)
import Control.Category
import Codec.Winery.Query
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import qualified Data.Text as T
import Data.Text.Prettyprint.Doc (Doc, hsep)
import Data.Typeable
import Data.Void

type Parser = Parsec Void T.Text

symbol :: T.Text -> Parser T.Text
symbol :: Text -> Parser Text
symbol = ParsecT Void Text Identity ()
-> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

name :: Parser T.Text
name :: Parser Text
name = (String -> Text)
-> ParsecT Void Text Identity String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack (ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf (String
"_\'" :: [Char])) ParsecT Void Text Identity String
-> String -> ParsecT Void Text Identity String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"field name")

parseQuery :: Typeable a => Parser (Query (Doc a) (Doc a))
parseQuery :: Parser (Query (Doc a) (Doc a))
parseQuery = (Query (Doc a) (Doc a)
 -> Query (Doc a) (Doc a) -> Query (Doc a) (Doc a))
-> Query (Doc a) (Doc a)
-> [Query (Doc a) (Doc a)]
-> Query (Doc a) (Doc a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Query (Doc a) (Doc a)
-> Query (Doc a) (Doc a) -> Query (Doc a) (Doc a)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.) Query (Doc a) (Doc a)
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id ([Query (Doc a) (Doc a)] -> Query (Doc a) (Doc a))
-> ParsecT Void Text Identity [Query (Doc a) (Doc a)]
-> Parser (Query (Doc a) (Doc a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Query (Doc a) (Doc a))
-> Parser Text
-> ParsecT Void Text Identity [Query (Doc a) (Doc a)]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 Parser (Query (Doc a) (Doc a))
forall a. Typeable a => Parser (Query (Doc a) (Doc a))
parseTerms (Text -> Parser Text
symbol Text
"|")

-- | Space-separated list of terms translate to a tabular output, applying the
-- queries in parallel
parseTerms :: Typeable a => Parser (Query (Doc a) (Doc a))
parseTerms :: Parser (Query (Doc a) (Doc a))
parseTerms = ([Doc a] -> Doc a)
-> Query (Doc a) [Doc a] -> Query (Doc a) (Doc a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
hsep (Query (Doc a) [Doc a] -> Query (Doc a) (Doc a))
-> ([Query (Doc a) (Doc a)] -> Query (Doc a) [Doc a])
-> [Query (Doc a) (Doc a)]
-> Query (Doc a) (Doc a)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Query (Doc a) (Doc a)] -> Query (Doc a) [Doc a]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ([Query (Doc a) (Doc a)] -> Query (Doc a) (Doc a))
-> ParsecT Void Text Identity [Query (Doc a) (Doc a)]
-> Parser (Query (Doc a) (Doc a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Query (Doc a) (Doc a))
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity [Query (Doc a) (Doc a)]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 Parser (Query (Doc a) (Doc a))
forall a. Typeable a => Parser (Query (Doc a) (Doc a))
parseTerm ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

parseTerm :: Typeable a => Parser (Query (Doc a) (Doc a))
parseTerm :: Parser (Query (Doc a) (Doc a))
parseTerm = ParsecT Void Text Identity ()
-> Parser (Query (Doc a) (Doc a)) -> Parser (Query (Doc a) (Doc a))
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space (Parser (Query (Doc a) (Doc a)) -> Parser (Query (Doc a) (Doc a)))
-> Parser (Query (Doc a) (Doc a)) -> Parser (Query (Doc a) (Doc a))
forall a b. (a -> b) -> a -> b
$ [Parser (Query (Doc a) (Doc a))] -> Parser (Query (Doc a) (Doc a))
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'.' ParsecT Void Text Identity Char
-> Parser (Query (Doc a) (Doc a)) -> Parser (Query (Doc a) (Doc a))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Parser (Query (Doc a) (Doc a))] -> Parser (Query (Doc a) (Doc a))
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ do
      Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'['
      Maybe Int
i <- ParsecT Void Text Identity Int
-> ParsecT Void Text Identity (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
      Maybe Int
j <- ParsecT Void Text Identity Int
-> ParsecT Void Text Identity (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Text -> Parser Text
symbol Text
":" Parser Text
-> ParsecT Void Text Identity Int -> ParsecT Void Text Identity Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void Text Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal)
      Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
']'
      Query (Doc a) (Doc a) -> Parser (Query (Doc a) (Doc a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Query (Doc a) (Doc a) -> Parser (Query (Doc a) (Doc a)))
-> Query (Doc a) (Doc a) -> Parser (Query (Doc a) (Doc a))
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Query (Doc a) (Doc a)
forall a. Typeable a => Int -> Int -> Query a a
range (Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 Int -> Int
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id Maybe Int
i) (Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-Int
1) Int -> Int
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id Maybe Int
j)
    , Int -> Query (Doc a) (Doc a)
forall a. Typeable a => Int -> Query a a
productItem (Int -> Query (Doc a) (Doc a))
-> ParsecT Void Text Identity Int -> Parser (Query (Doc a) (Doc a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
    , Text -> Query (Doc a) (Doc a)
forall a. Typeable a => Text -> Query a a
field (Text -> Query (Doc a) (Doc a))
-> Parser Text -> Parser (Query (Doc a) (Doc a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
name
    , Query (Doc a) (Doc a) -> Parser (Query (Doc a) (Doc a))
forall (m :: * -> *) a. Monad m => a -> m a
return Query (Doc a) (Doc a)
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
    ]
  ]