{-# LANGUAGE OverloadedStrings #-}

module FTag.Expr.Parser (FTag.Expr.Parser.parse) where

import Text.Parsec
import qualified Data.Text as T
import Control.Monad
import Control.Exception (throw)
import FTag.Data

parse :: T.Text -> UserExpr
parse t = case Text.Parsec.parse pExpr "(invalid expression)" t of
            Left e -> throw $ FTInvalidExpression $ T.pack $ show e
            Right r -> r

ws = skipMany $ char ' '

betw o c p = char o *> ws *> p <* ws <* char c

parens = betw '(' ')'

quoted = betw '\'' '\''

setOf p = betw '{' '}' $ p `sepBy` (try $ ws *> char ',' <* ws)

atomicSetName = ws *> as
  where n = T.pack <$> (try (quoted $ many1 $ noneOf "'") <|> many1 (noneOf " ,-+{}()[]"))
        as = choice $ map try [ UASTag <$> (string "t:" *> n),
                                UASPreset <$> (string "p:" *> n),
                                UASSpecial <$> (string "s:" *> n),
                                UASByName <$> n ]

filename = UserFileN <$> strValue

strValue = ws *> (T.pack <$> (try (quoted $ many1 $ noneOf "'")
                               <|> many1 (noneOf ",}")))

predicateOp = opEnt FTLesser "<"
          <|> opEnt FTLesserOrEq "<="
          <|> opEnt FTEqual "="
          <|> opEnt FTNotEqual "!="
          <|> opEnt FTGreater ">"
          <|> opEnt FTGreaterOrEq ">="
          <|> opSet FTInSet "in"
          <|> opSet FTNotInSet "ni"
          <|> opUn  FTDefined "def"
          <|> opUn  FTNotDefined "undef"
  where opEnt f o = f <$> try (ws *> string o *> ws *> strValue <* ws)
        opSet f o = f <$> try (ws *> string o *> ws *> setOf strValue <* ws)
        opUn  f o = try (ws >> string o >> ws) >> return f

predicate = betw '[' ']' $ FTPredicate <$> atomicSetName <*> predicateOp

term = parens pExpr
   <|> FTLeaf <$> predicate
   <|> FTLeaf . FTLitSet <$> setOf filename
   <|> FTLeaf . FTAtomic <$> atomicSetName

-- I use a custom parser instead of Parsec.Expr because the kind of syntactic
-- sugar I want is easier to implement this way.

pExpr = unionExpr

unionExpr = do
  cts <- intersectionExpr
  FTNode FTUnion cts <$> try (ws >> char ',' >> ws >> unionExpr)
    <|> return cts

intersectionExpr = do
  cts <- omittedInter
  FTNode FTIntersection cts <$> try (ws >> char '+' >> ws >> intersectionExpr)
    <|> return cts

-- Syntactic sugar: omitting the '+' operator and replacing it with whitespace
omittedInter = do
  cts <- differenceExpr
  FTNode FTIntersection cts <$> try (ws >> omittedInter)
    <|> return cts

differenceExpr = chainl1 omittedAll $ try (ws >> char '-' >> ws >> return (FTNode FTDifference))

-- Syntactic sugar: using a '-' with no term before it to mean "all files except those"
omittedAll = FTNode FTDifference (FTLeaf $ FTAtomic $ UASByName "all") <$> try (ws >> char '-' >> ws >> term)
         <|> term


