-- This file is part of the 'term-rewriting' library. It is licensed
-- under an MIT license. See the accompanying 'LICENSE' file for details.
--
-- Authors: Christian Sternagel

{-# LANGUAGE FlexibleContexts#-}
module Data.Rewriting.Utils.Parse (
    lex,
    par,
    ident
) where

import Control.Monad
import Prelude hiding (lex)
import Text.Parsec
import Data.Char (isSpace)

-- | @lex p@ is similar to @p@ but also consumes trailing white space.
lex :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
lex :: forall s (m :: * -> *) u a.
Stream s m Char =>
ParsecT s u m a -> ParsecT s u m a
lex ParsecT s u m a
p = do { a
x <- ParsecT s u m a
p; ParsecT s u m ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces; a -> ParsecT s u m a
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x }

-- | @par p@ accpets @p@ enclosed in parentheses ('@(@' and '@)@').
par :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
par :: forall s (m :: * -> *) u a.
Stream s m Char =>
ParsecT s u m a -> ParsecT s u m a
par = ParsecT s u m Char
-> ParsecT s u m Char -> ParsecT s u m a -> ParsecT s u m a
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (ParsecT s u m Char -> ParsecT s u m Char
forall s (m :: * -> *) u a.
Stream s m Char =>
ParsecT s u m a -> ParsecT s u m a
lex(ParsecT s u m Char -> ParsecT s u m Char)
-> ParsecT s u m Char -> ParsecT s u m Char
forall a b. (a -> b) -> a -> b
$Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'(') (ParsecT s u m Char -> ParsecT s u m Char
forall s (m :: * -> *) u a.
Stream s m Char =>
ParsecT s u m a -> ParsecT s u m a
lex(ParsecT s u m Char -> ParsecT s u m Char)
-> ParsecT s u m Char -> ParsecT s u m Char
forall a b. (a -> b) -> a -> b
$Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')')

-- | @ident taboo@ parses a non-empty sequence of non-space characters not
-- containing elements of @taboo@.
ident :: Stream s m Char => String -> [String] -> ParsecT s u m String
ident :: forall s (m :: * -> *) u.
Stream s m Char =>
String -> [String] -> ParsecT s u m String
ident String
tabooChars [String]
tabooWords = ParsecT s u m String -> ParsecT s u m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT s u m String -> ParsecT s u m String)
-> ParsecT s u m String -> ParsecT s u m String
forall a b. (a -> b) -> a -> b
$ do
    String
s <- ParsecT s u m Char -> ParsecT s u m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ((Char -> Bool) -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
c -> Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
tabooChars))
    Bool -> ParsecT s u m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
tabooWords)
    String -> ParsecT s u m String
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
s