{- |
Module      :  ./Common/Parsec.hs
Description :  Parsec extensions
Copyright   :  (c) Christian Maeder, DFKI GmbH 2010
License     :  GPLv2 or higher, see LICENSE.txt
Maintainer  :  Christian.Maeder@dfki.de
Stability   :  provisional
Portability :  portable

frequently useful shortcuts mainly for character parsers
-}

module Common.Parsec where

import Text.ParserCombinators.Parsec
import Control.Monad

-- * monad shortcuts

infixl 1 <<

(<<) :: Monad m => m a -> m b -> m a
<< :: m a -> m b -> m a
(<<) = (a -> b -> a) -> m a -> m b -> m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> b -> a
forall a b. a -> b -> a
const

forget :: Monad m => m a -> m ()
forget :: m a -> m ()
forget = (m a -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

pair :: Monad m => m a -> m b -> m (a, b)
pair :: m a -> m b -> m (a, b)
pair = (a -> b -> (a, b)) -> m a -> m b -> m (a, b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)

infixr 5 <:>

(<:>) :: Monad m => m a -> m [a] -> m [a]
<:> :: m a -> m [a] -> m [a]
(<:>) = (a -> [a] -> [a]) -> m a -> m [a] -> m [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:)

infixr 5 <++>

(<++>) :: Monad m => m [a] -> m [a] -> m [a]
<++> :: m [a] -> m [a] -> m [a]
(<++>) = ([a] -> [a] -> [a]) -> m [a] -> m [a] -> m [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)

infixl 4 >->

(>->) :: Monad m => m a -> (a -> b) -> m b
>-> :: m a -> (a -> b) -> m b
(>->) p :: m a
p f :: a -> b
f = (a -> b) -> m a -> m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> b
f m a
p

single :: Monad m => m a -> m [a]
single :: m a -> m [a]
single = (a -> [a]) -> m a -> m [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return

flat :: Monad m => m [[a]] -> m [a]
flat :: m [[a]] -> m [a]
flat = ([[a]] -> [a]) -> m [[a]] -> m [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

enclosedBy :: Monad m => m [a] -> m a -> m [a]
enclosedBy :: m [a] -> m a -> m [a]
enclosedBy p :: m [a]
p q :: m a
q = m a
q m a -> m [a] -> m [a]
forall (m :: * -> *) a. Monad m => m a -> m [a] -> m [a]
<:> m [a]
p m [a] -> m [a] -> m [a]
forall (m :: * -> *) a. Monad m => m [a] -> m [a] -> m [a]
<++> m a -> m [a]
forall (m :: * -> *) a. Monad m => m a -> m [a]
single m a
q

-- * parsec shortcuts

-- | parse an optional list
optionL :: GenParser tok st [a] -> GenParser tok st [a]
optionL :: GenParser tok st [a] -> GenParser tok st [a]
optionL = [a] -> GenParser tok st [a] -> GenParser tok st [a]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option []

-- | shortcut for @try . string@
tryString :: String -> CharParser st String
tryString :: String -> CharParser st String
tryString = CharParser st String -> CharParser st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (CharParser st String -> CharParser st String)
-> (String -> CharParser st String)
-> String
-> CharParser st String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CharParser st String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string

-- | nested comments, open and closing strings must have at least one char
nestedComment :: String -> String -> CharParser st String
nestedComment :: String -> String -> CharParser st String
nestedComment op :: String
op cl :: String
cl =
    let inComment :: ParsecT String u Identity String
inComment = String -> ParsecT String u Identity String
forall st. String -> CharParser st String
tryString String
cl
           ParsecT String u Identity String
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> String -> ParsecT String u Identity String
forall st. String -> String -> CharParser st String
nestedComment String
op String
cl ParsecT String u Identity String
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String u Identity Char -> ParsecT String u Identity String
forall (m :: * -> *) a. Monad m => m a -> m [a]
single ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar) ParsecT String u Identity String
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall (m :: * -> *) a. Monad m => m [a] -> m [a] -> m [a]
<++> ParsecT String u Identity String
inComment
    in String -> CharParser st String
forall st. String -> CharParser st String
tryString String
op CharParser st String
-> CharParser st String -> CharParser st String
forall (m :: * -> *) a. Monad m => m [a] -> m [a] -> m [a]
<++> CharParser st String
forall u. ParsecT String u Identity String
inComment

-- | a literal enclosed in quotes and a backslash as escape character
quotedLit :: Char -> CharParser st String
quotedLit :: Char -> CharParser st String
quotedLit q :: Char
q = CharParser st String
-> ParsecT String st Identity Char -> CharParser st String
forall (m :: * -> *) a. Monad m => m [a] -> m a -> m [a]
enclosedBy (ParsecT String st Identity [String] -> CharParser st String
forall (m :: * -> *) a. Monad m => m [[a]] -> m [a]
flat (ParsecT String st Identity [String] -> CharParser st String)
-> ParsecT String st Identity [String] -> CharParser st String
forall a b. (a -> b) -> a -> b
$ CharParser st String -> ParsecT String st Identity [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (CharParser st String -> ParsecT String st Identity [String])
-> CharParser st String -> ParsecT String st Identity [String]
forall a b. (a -> b) -> a -> b
$ ParsecT String st Identity Char -> CharParser st String
forall (m :: * -> *) a. Monad m => m a -> m [a]
single (String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf ['\\', Char
q])
                        CharParser st String
-> CharParser st String -> CharParser st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '\\' ParsecT String st Identity Char
-> CharParser st String -> CharParser st String
forall (m :: * -> *) a. Monad m => m a -> m [a] -> m [a]
<:> ParsecT String st Identity Char -> CharParser st String
forall (m :: * -> *) a. Monad m => m a -> m [a]
single ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar) (ParsecT String st Identity Char -> CharParser st String)
-> ParsecT String st Identity Char -> CharParser st String
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
q

-- | text in double quotes
stringLit :: CharParser st String
stringLit :: CharParser st String
stringLit = Char -> CharParser st String
forall st. Char -> CharParser st String
quotedLit '"'

-- | text in single quotes
sQuoted :: CharParser st String
sQuoted :: CharParser st String
sQuoted = Char -> CharParser st String
forall st. Char -> CharParser st String
quotedLit '\''

-- | non-nested block
plainBlock :: String -> String -> CharParser st String
plainBlock :: String -> String -> CharParser st String
plainBlock op :: String
op cl :: String
cl = String -> CharParser st String
forall st. String -> CharParser st String
tryString String
op CharParser st String
-> CharParser st String -> CharParser st String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String st Identity Char
-> CharParser st String -> CharParser st String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (String -> CharParser st String
forall st. String -> CharParser st String
tryString String
cl)

reserved :: [String] -> CharParser st String -> CharParser st String
-- | reject keywords
reserved :: [String] -> CharParser st String -> CharParser st String
reserved l :: [String]
l p :: CharParser st String
p = CharParser st String -> CharParser st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (CharParser st String -> CharParser st String)
-> CharParser st String -> CharParser st String
forall a b. (a -> b) -> a -> b
$ do
  String
s <- CharParser st String
p
  if String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
s [String]
l then String -> CharParser st String
forall s (m :: * -> *) t u a.
Stream s m t =>
String -> ParsecT s u m a
unexpected (String -> CharParser st String) -> String -> CharParser st String
forall a b. (a -> b) -> a -> b
$ "keyword " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s else String -> CharParser st String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s

{- | Similar to 'lookAhead', but runs the parser in an isolated sandbox.
The function is monadic but in a read-only manner.  Useful if 'lookAhead'
taints error messages. -}
sneakAhead :: CharParser st a -> CharParser st (Either ParseError a)
sneakAhead :: CharParser st a -> CharParser st (Either ParseError a)
sneakAhead p :: CharParser st a
p = do
  String
i <- ParsecT String st Identity String
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
  State String st
state <- ParsecT String st Identity (State String st)
forall (m :: * -> *) s u. Monad m => ParsecT s u m (State s u)
getParserState
  Either ParseError a -> CharParser st (Either ParseError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError a -> CharParser st (Either ParseError a))
-> Either ParseError a -> CharParser st (Either ParseError a)
forall a b. (a -> b) -> a -> b
$ CharParser st a -> st -> String -> String -> Either ParseError a
forall tok st a.
GenParser tok st a -> st -> String -> [tok] -> Either ParseError a
runParser (State String st -> ParsecT String st Identity (State String st)
forall (m :: * -> *) s u.
Monad m =>
State s u -> ParsecT s u m (State s u)
setParserState State String st
state ParsecT String st Identity (State String st)
-> CharParser st a -> CharParser st a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CharParser st a
p) (State String st -> st
forall s u. State s u -> u
stateUser State String st
state) "" String
i