{-# Language FlexibleContexts  #-}
{-# Language OverloadedStrings  #-}
module Ipe.ParserPrimitives( runP, runP'
                                         , pMany, pMany1, pChoice
                                         , pChar, pSpace, pWhiteSpace, pInteger
                                         , pNatural, pPaddedNatural
                                         , (<*><>) , (<*><)
                                         , (<***>) , (<***) , (***>)
                                         , pMaybe , pCount , pSepBy
                                         , Parser, ParseError
                                         , pNotFollowedBy
                                         ) where


import           Text.Parsec(try)
import           Text.Parsec(ParsecT, Stream)
import           Text.Parsec.Text
import           Text.ParserCombinators.Parsec hiding (Parser,try)
import qualified Data.Text as T


runP'     :: Parser a -> T.Text -> (a, T.Text)
runP' :: Parser a -> Text -> (a, Text)
runP' Parser a
p Text
s = case Parser a -> Text -> Either ParseError (a, Text)
forall a. Parser a -> Text -> Either ParseError (a, Text)
runP Parser a
p Text
s of
             Left  ParseError
e -> [Char] -> (a, Text)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (a, Text)) -> [Char] -> (a, Text)
forall a b. (a -> b) -> a -> b
$ ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
e
             Right (a, Text)
x -> (a, Text)
x

runP   :: Parser a -> T.Text -> Either ParseError (a,T.Text)
runP :: Parser a -> Text -> Either ParseError (a, Text)
runP Parser a
p = Parsec Text () (a, Text)
-> [Char] -> Text -> Either ParseError (a, Text)
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse ((,) (a -> Text -> (a, Text))
-> Parser a -> ParsecT Text () Identity (Text -> (a, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p ParsecT Text () Identity (Text -> (a, Text))
-> ParsecT Text () Identity Text -> Parsec Text () (a, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity Text
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput) [Char]
""


----------------------------------------------------------------------------
-- | reexporting some standard combinators

pMany :: Parser a -> Parser [a]
pMany :: Parser a -> Parser [a]
pMany = Parser a -> Parser [a]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many

pMany1 :: Parser a -> Parser [a]
pMany1 :: Parser a -> Parser [a]
pMany1 = Parser a -> Parser [a]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1


pChoice :: [Parser a] -> Parser a
pChoice :: [Parser a] -> Parser a
pChoice = [Parser a] -> Parser a
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([Parser a] -> Parser a)
-> ([Parser a] -> [Parser a]) -> [Parser a] -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Parser a -> Parser a) -> [Parser a] -> [Parser a]
forall a b. (a -> b) -> [a] -> [b]
map Parser a -> Parser a
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try


pNatural :: Parser Integer
pNatural :: Parser Integer
pNatural = [Char] -> Integer
forall a. Read a => [Char] -> a
read ([Char] -> Integer)
-> ParsecT Text () Identity [Char] -> Parser Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> ParsecT Text () Identity [Char]
forall a. Parser a -> Parser [a]
pMany1 Parser Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

-- | parses an integer with a prefix of zeros. Returns the total length of the
-- string parced (i.e. number of digits) and the resulting antural number.
pPaddedNatural :: Parser (Int, Integer)
pPaddedNatural :: Parser (Int, Integer)
pPaddedNatural = (\[Char]
s -> ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s, [Char] -> Integer
forall a. Read a => [Char] -> a
read [Char]
s)) ([Char] -> (Int, Integer))
-> ParsecT Text () Identity [Char] -> Parser (Int, Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> ParsecT Text () Identity [Char]
forall a. Parser a -> Parser [a]
pMany1 Parser Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

pInteger :: Parser Integer
pInteger :: Parser Integer
pInteger = Parser Integer
pNatural
           Parser Integer -> Parser Integer -> Parser Integer
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
           Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> Parser Integer -> Parser Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
pChar Char
'-' Parser Char -> Parser Integer -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Integer
pNatural)

pChar :: Char -> Parser Char
pChar :: Char -> Parser Char
pChar = Char -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char

pSpace :: Parser Char
pSpace :: Parser Char
pSpace = Char -> Parser Char
pChar Char
' '

pWhiteSpace :: Parser [Char]
pWhiteSpace :: ParsecT Text () Identity [Char]
pWhiteSpace = Parser Char -> ParsecT Text () Identity [Char]
forall a. Parser a -> Parser [a]
pMany1 (Parser Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space Parser Char -> Parser Char -> Parser Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline)

pMaybe :: Parser a -> Parser (Maybe a)
pMaybe :: Parser a -> Parser (Maybe a)
pMaybe = Parser a -> Parser (Maybe a)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe

pCount :: Int -> Parser a -> Parser [a]
pCount :: Int -> Parser a -> Parser [a]
pCount = Int -> Parser a -> Parser [a]
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count

pSepBy :: Parser a -> Parser b -> Parser [a]
pSepBy :: Parser a -> Parser b -> Parser [a]
pSepBy = Parser a -> Parser b -> Parser [a]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy


-- | infix variant of notfollowed by
pNotFollowedBy :: Parser a -> Parser b -> Parser a
Parser a
p pNotFollowedBy :: Parser a -> Parser b -> Parser a
`pNotFollowedBy` Parser b
q = do { a
x <- Parser a
p ; Parser b -> ParsecT Text () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy' Parser b
q ; a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x }
    where
      -- | copy of the original notFollowedBy but replaced the error message
      -- to get rid of the Show dependency
      notFollowedBy' :: ParsecT s u m a -> ParsecT s u m ()
notFollowedBy' ParsecT s u m a
z     = ParsecT s u m () -> ParsecT s u m ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (do{ a
_ <- ParsecT s u m a -> ParsecT s u m a
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT s u m a
z; [Char] -> ParsecT s u m ()
forall s (m :: * -> *) t u a.
Stream s m t =>
[Char] -> ParsecT s u m a
unexpected [Char]
"not followed by" }
                                    ParsecT s u m () -> ParsecT s u m () -> ParsecT s u m ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> () -> ParsecT s u m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                 )

----------------------------------------------------------------------------
-- | Running parsers in reverse

infix 1 <*><>, <*><

-- | Runs parser q ``in reverse'' on the end of the input stream
(<*><>) ::  (Reversable s, Stream s m t)
        => ParsecT s u m (a -> b) -> ParsecT s u m a -> ParsecT s u m b
ParsecT s u m (a -> b)
p <*><> :: ParsecT s u m (a -> b) -> ParsecT s u m a -> ParsecT s u m b
<*><> ParsecT s u m a
q = do
  ParsecT s u m ()
forall s (m :: * -> *) t u.
(Reversable s, Stream s m t) =>
ParsecT s u m ()
rev
  a
x <- ParsecT s u m a
q
  ParsecT s u m ()
forall s (m :: * -> *) t u.
(Reversable s, Stream s m t) =>
ParsecT s u m ()
rev
  a -> b
f <- ParsecT s u m (a -> b)
p
  b -> ParsecT s u m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> ParsecT s u m b) -> b -> ParsecT s u m b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x


(<*><)   :: (Stream s m t, Reversable s)
          => ParsecT s u m b -> ParsecT s u m a -> ParsecT s u m b
ParsecT s u m b
p <*>< :: ParsecT s u m b -> ParsecT s u m a -> ParsecT s u m b
<*>< ParsecT s u m a
q = b -> a -> b
forall a b. a -> b -> a
const (b -> a -> b) -> ParsecT s u m b -> ParsecT s u m (a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s u m b
p ParsecT s u m (a -> b) -> ParsecT s u m a -> ParsecT s u m b
forall s (m :: * -> *) t u a b.
(Reversable s, Stream s m t) =>
ParsecT s u m (a -> b) -> ParsecT s u m a -> ParsecT s u m b
<*><> ParsecT s u m a
q


rev :: (Reversable s, Stream s m t) => ParsecT s u m ()
rev :: ParsecT s u m ()
rev = ParsecT s u m s
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput ParsecT s u m s -> (s -> ParsecT s u m ()) -> ParsecT s u m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (s -> ParsecT s u m ()
forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput (s -> ParsecT s u m ()) -> (s -> s) -> s -> ParsecT s u m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s
forall s. Reversable s => s -> s
reverseS)

-- as :: Parser String
-- as = many (char 'a')

-- foo :: Parser String
-- foo = reverse <$> (string . reverse $ "foo")

-- prs :: Parser (String,String)
-- prs = (,) <$> as <*>< foo'

-- foo' :: Parser String
-- foo' = spaces ***> foo

-- (<***>) :: Parser (a -> b)

infixr 2 <***>, ***>, <***

-- | run the parsers in reverse order, first q, then p
(<***>) :: Monad m => m (t -> b) -> m t -> m b
m (t -> b)
p <***> :: m (t -> b) -> m t -> m b
<***> m t
q = do
  t
x <- m t
q
  t -> b
f <- m (t -> b)
p
  b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> m b) -> b -> m b
forall a b. (a -> b) -> a -> b
$ t -> b
f t
x

-- | the variants with missing brackets
(***>) :: Monad m => m a -> m b -> m b
m a
p ***> :: m a -> m b -> m b
***> m b
q = (\a
_ b
s -> b
s) (a -> b -> b) -> m a -> m (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
p m (b -> b) -> m b -> m b
forall (m :: * -> *) t b. Monad m => m (t -> b) -> m t -> m b
<***> m b
q

(<***) :: Monad m => m b -> m t -> m b
m b
p <*** :: m b -> m t -> m b
<*** m t
q = (\b
s t
_ -> b
s) (b -> t -> b) -> m b -> m (t -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
p m (t -> b) -> m t -> m b
forall (m :: * -> *) t b. Monad m => m (t -> b) -> m t -> m b
<***> m t
q

class Reversable s where
  reverseS :: s -> s

instance Reversable [c] where
  reverseS :: [c] -> [c]
reverseS = [c] -> [c]
forall c. [c] -> [c]
reverse

instance Reversable T.Text where
  reverseS :: Text -> Text
reverseS = Text -> Text
T.reverse