Parse.hs

-- This file is part of khph.
--
-- Copyright 2016 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE CPP #-}

-- | Query language parser.
module Khph.Query.Parse (parseQuery) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$), (<$>), (<*), (*>))
#endif
import Data.Char (toLower)
import Data.List (intercalate)
import Khph.Project.Base
import Khph.Project.Monad
import Khph.Query.Base
import Khph.Util
import Text.Parsec (
  (<|>),
  (<?>),
  ParsecT,
  anyToken,
  char,
  digit,
  eof,
  letter,
  many,
  many1,
  noneOf,
  option,
  optional,
  parse,
  runParserT,
  sepBy,
  space,
  try,
  )
import Text.ParserCombinators.Parsec (Parser)

data Term =
    TWord String
  | TLiteralString String
  | TLiteralInteger Integer
  | TParenL
  | TParenR
  deriving (Eq, Show)

-- | Parses a query from a string.  Returns an error message if parsing fails.
parseQuery :: MonadProject m => String -> m (Either String Query)
parseQuery str =
  case parse (terms <* eof) "<terms>" str of
    Left err -> return $ Left $ show err
    Right terms -> either (Left . show) return <$>
                   if null terms
                   then return $ Right LogicTrue
                   else runParserT (query <* eof) () "<query>" terms

terms :: Parser [Term]
terms = term `sepBy` many space

term :: Parser Term
term =
  word <|>
  string <|>
  integer <|>
  TParenL <$ char '(' <|>
  TParenR <$ char ')'

word :: Parser Term
word = TWord . map toLower <$> many1 letter

string :: Parser Term
string =
  TLiteralString <$>
  (char '"' *> many (stringChar '"') <* char '"' <|>
   char '\'' *> many (stringChar '\'') <* char '\'')
  where stringChar :: Char -> Parser Char
        stringChar delim = do
          ch <- noneOf [delim]
          case ch of
            '\\' -> do
              ch2 <- anyToken
              if ch2 == delim
                then return delim
                else case ch2 of
                  '\\' -> return '\\'
                  '0' -> return '\0'
                  'n' -> return '\n'
                  'r' -> return '\r'
                  't' -> return '\t'
                  'v' -> return '\v'
                  _ -> fail $ concat
                       ["Unknown escape sequence \\", [ch2], " in khph string."]
            _ -> return ch

integer :: Parser Term
integer =
  TLiteralInteger <$>
  ((char '-' *> (negate . read <$> digits)) <|>
   read <$> digits)
  where digits = many1 digit

type TermParserT = ParsecT [Term] ()

logic :: MonadProject m => TermParserT m q -> TermParserT m (Logic q)
logic q = disjunction q

disjunction :: MonadProject m => TermParserT m q -> TermParserT m (Logic q)
disjunction q =
  (\ls -> case ls of
     [l] -> l
     _ -> LogicOr ls) <$>
  conjunction q `mySepBy1` w "or"

conjunction :: MonadProject m => TermParserT m q -> TermParserT m (Logic q)
conjunction q =
  (\ls -> case ls of
     [l] -> l
     _ -> LogicAnd ls) <$>
  negation q `mySepBy1` w "and"

negation :: MonadProject m => TermParserT m q -> TermParserT m (Logic q)
negation q =
  w "not" *> (LogicNot <$> negation q) <|>
  logicQuery q

logicQuery :: MonadProject m => TermParserT m q -> TermParserT m (Logic q)
logicQuery q =
  pl *> logic q <* pr <|>
  LogicTrue <$ w "true" <|>
  LogicFalse <$ w "false" <|>
  LogicQuery <$> q

listPredicate :: MonadProject m
              => TermParserT m ()
              -> TermParserT m a
              -> TermParserT m (ListPredicate a)
listPredicate word subparser =
  try (w "all" *> word *> (All <$> subparser)) <|>
  try (w "all1" *> word *> (All1 <$> subparser)) <|>
  try (optional (w "some") *> word *> (option Exists $ Some <$> subparser)) <|>
  try (w "no" *> word *> (option DoesNotExist $ None <$> subparser))

query :: MonadProject m => TermParserT m Query
query =
  logic $
  QueryLink <$> listPredicate (w "link" <|> w "links" <|>
                               w "path" <|> w "paths")
                              linkQuery <|>
  QueryTag <$> listPredicate (w "tag" <|> w "tags") tagQuery

stringQuery :: MonadProject m => TermParserT m StringQuery
stringQuery =
  logic $
  StringEq <$> (w "eq" *> stringTerm) <|>
  StringContains <$> ((w "contains" <|> w "contain") *> stringTerm) <|>
  StringStartsWith <$> ((w "starts" <|> w "start") *> w "with" *> stringTerm) <|>
  StringEndsWith <$> ((w "ends" <|> w "end") *> w "with" *> stringTerm)

linkQuery :: MonadProject m => TermParserT m LinkQuery
linkQuery =
  logic $
  try (LinkTypeIs <$> (isAre *> (HardLink <$ w "hard" <|>
                                 SoftLink <$ w "soft"))) <|>
  LinkMatchesEntrySpec <$> (w "matches" *> entrySpec) <|>
  LinkIsSourcePath <$ isAre <* w "source" <|>
  try (w "file" *> (LinkStringQuery (Just FileComponent) <$> stringQuery) <|>
       w "directory" *> (LinkStringQuery (Just DirectoryComponent) <$> stringQuery) <|>
       LinkStringQuery Nothing <$> stringQuery) <|>
  LinkTreeQuery <$> treeQuery (do spec <- entrySpec
                                  paths <- entrySpecLookup spec
                                  let count = length paths
                                      limit = 10
                                  case paths of
                                    [path] -> return $ projectPathToComponents path
                                    _ -> fail $ concat
                                         ["The EntrySpec given to a LinkTreeQuery should match ",
                                          "a single entry, but we found ", show count, ": ",
                                          intercalate ", " $ map show $ take limit paths,
                                          if count > limit then ", ..." else ""])

tagQuery :: MonadProject m => TermParserT m TagQuery
tagQuery = treeQuery $ tagLookup1 "tagQuery" =<< entrySpec

treeQuery :: MonadProject m => TermParserT m a -> TermParserT m (TreeQuery a)
treeQuery valueParser =
  logic $
  (w "at" *> (TreeAt <$> valueParser)) <|>
  (w "atabove" *> (TreeAtAbove <$> valueParser)) <|>
  (w "atbelow" *> (TreeAtBelow <$> valueParser)) <|>
  (w "above" *> (TreeAbove <$> valueParser)) <|>
  (w "below" *> (TreeBelow <$> valueParser))

entrySpec :: MonadProject m => TermParserT m EntrySpec
entrySpec = do
  str <- stringTerm
  case toEntrySpec str of
    Left err -> fail $ concat
                ["Couldn't parse an EntrySpec from ", show str, ": ", err]
    Right entrySpec -> return entrySpec

stringTerm :: Monad m => TermParserT m String
stringTerm =
  try (do t <- anyToken
          case t of
            TLiteralString str -> return str
            _ -> fail "") <?>
  "string"

w :: Monad m => String -> TermParserT m ()
w = parserEq . TWord . map toLower

pl :: Monad m => TermParserT m ()
pl = parserEq TParenL

pr :: Monad m => TermParserT m ()
pr = parserEq TParenR

isAre :: Monad m => TermParserT m ()
isAre = w "is" <|> w "are"

-- | Similar to 'sepBy1', @mySepBy1 body separator@ parses a series of @body@s
-- separated by @separator@.  However, unlike 'sepBy1', this function wraps each
-- @separator >> mySepBy1 body separator@ recursive call in a 'try', so seeing a
-- separator but failing to parse a subsequent body doesn't cause the parse to
-- fail, because the same separator may be used at a higher level in the syntax
-- tree.
mySepBy1 :: TermParserT m a -> TermParserT m b -> TermParserT m [a]
mySepBy1 body separator = do
  x <- body
  -- Instead of the next line, sepBy1 uses "xs <- many (separator body)".
  xs <- try (separator *> mySepBy1 body separator) <|> return []
  return $ x:xs