Extended.hs

{-# LANGUAGE FlexibleContexts #-}
module Shared.Parsec.Extended (
    module Text.Parsec,
    module Data.Functor,
    module Control.Monad,
    module Control.Monad.Identity,
    module Control.Applicative,
    module Shared.Parsec.Extended
  ) where

import Text.Parsec hiding (token)
import Data.Functor (void, ($>))
import Control.Monad.Identity (Identity)
import Control.Monad (MonadPlus)
import Control.Applicative (liftA2, liftA3, empty, Alternative, (<**>))
import Data.List (foldl')

type Parser s a = Parsec s () a

token :: Stream s Identity Char => String -> Parser s String
token = try . string

match :: (Monad m, Eq a) => [a] -> m a -> (a -> m b) -> m b -> m b
match xs p f def = p >>= (\x -> if elem x xs then f x else def)

skipSome :: Stream s Identity Char => Parser s a -> Parser s ()
skipSome p = void (some p)

maybeP :: Stream s Identity Char => Parser s a -> Parser s (Maybe a)
maybeP p = option Nothing (Just <$> p)

fromMaybeP :: Monad m => m (Maybe a) -> m a -> m a
fromMaybeP mmx d = mmx >>= maybe d return

(<+>) :: Stream s Identity Char => Parser s a -> Parser s b -> Parser s (Either a b)
p <+> q = Left <$> p <|> Right <$> q

(<:>) :: Stream s Identity Char => Parser s a -> Parser s [a] -> Parser s [a]
(<:>) = liftA2 (:)

(<~>) :: Stream s Identity Char => Parser s a -> Parser s b -> Parser s (a, b)
(<~>) = liftA2 (,)

some :: Stream s Identity Char => Parser s a -> Parser s [a]
some = many1

pfoldl1 :: Stream s Identity Char => (b -> a -> b) -> b -> Parser s a -> Parser s b
pfoldl1 f k p = foldl' f k <$> some p

(>?>) :: MonadPlus m => m a -> (a -> Bool) -> m a
m >?> f = m >>= \x -> if f x then return x else empty

chainPre :: Stream s Identity Char => Parser s (a -> a) -> Parser s a -> Parser s a
chainPre op p = flip (foldr ($)) <$> many op <*> p

chainPost :: Stream s Identity Char => Parser s a -> Parser s (a -> a) -> Parser s a
chainPost p op = foldl' (flip ($)) <$> p <*> many op

data Level s a = InfixL  [Parser s (a -> a -> a)]
               | InfixR  [Parser s (a -> a -> a)]
               | Prefix  [Parser s (a -> a)]
               | Postfix [Parser s (a -> a)]

precedence :: Stream s Identity Char => [Level s a] -> Parser s a -> Parser s a
precedence levels atom = foldl' convert atom levels
  where
    convert x (InfixL ops)  = chainl1 x (choice ops)
    convert x (InfixR ops)  = chainr1 x (choice ops)
    convert x (Prefix ops)  = chainPre (choice ops) x
    convert x (Postfix ops) = chainPost x (choice ops)