Attoparsec.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
module Parsers.Utils.Attoparsec where

import Control.Applicative hiding (some)
import Control.Monad (Monad(..), MonadPlus)
import Data.Attoparsec.Combinator
import Data.Bool (Bool(..))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (flip, ($), id)
import Data.Functor (void)
import Data.Maybe (Maybe(..), maybe)
import Data.String (String)
import Data.Word (Word8)
import qualified Data.List as List
import qualified Data.Text as T
import qualified Data.ByteString as BS
import qualified Data.Attoparsec.Internal.Types as AP
import qualified Data.Attoparsec.ByteString as AP.ByteString
import qualified Data.Attoparsec.ByteString.Char8 as AP.ByteString.Char8
import qualified Data.Attoparsec.Text as AP.Text

-- * Class 'Inputable'
class AP.Chunk inp => Inputable inp where
  type Token inp
  null :: inp -> Bool
  empty :: inp
  uncons :: inp -> Maybe (Token inp, inp)
  satisfy :: (Token inp -> Bool) -> AP.Parser inp (Token inp)
  char :: Char -> AP.Parser inp Char
  notInClass :: String -> Token inp -> Bool
instance Inputable T.Text where
  type Token T.Text = Char
  null = T.null
  empty = T.empty
  uncons = T.uncons
  satisfy = AP.Text.satisfy
  char = AP.Text.char
  notInClass = AP.Text.notInClass
instance Inputable BS.ByteString where
  type Token BS.ByteString = Word8
  null = BS.null
  empty = BS.empty
  uncons = BS.uncons
  satisfy = AP.ByteString.satisfy
  char = AP.ByteString.Char8.char
  notInClass = AP.ByteString.notInClass

between :: Applicative f => f a -> f b -> f c -> f c
between o c p = o *> p <* c

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

skipSome :: Alternative p => p a -> p ()
skipSome p = void (some p)

some :: Alternative p => p a -> p [a]
some = many1

maybeP :: Alternative p => p a -> p (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

(<+>) :: Alternative p => p a -> p b -> p (Either a b)
p <+> q = Left <$> p <|> Right <$> q

(<:>) :: Applicative p => p a -> p [a] -> p [a]
(<:>) = liftA2 (:)

(<~>) :: Applicative p => p a -> p b -> p (a, b)
(<~>) = liftA2 (,)

pfoldl1 :: Alternative p => (b -> a -> b) -> b -> p a -> p b
pfoldl1 f k p = List.foldl' f k <$> some p

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

chainPre :: Alternative p => p (a -> a) -> p a -> p a
chainPre op p = flip (List.foldr ($)) <$> many op <*> p

chainPost :: Alternative p => p a -> p (a -> a) -> p a
chainPost p op = List.foldl' (flip ($)) <$> p <*> many op

chainl1 :: Alternative p => p a -> p (a -> a -> a) -> p a
chainl1 p op = chainPost p (flip <$> op <*> p)

chainr1 :: Alternative p => p a -> p (a -> a -> a) -> p a
chainr1 p op = let go = p <**> ((flip <$> op <*> go) <|> pure id) in go

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

precedence :: Alternative p => [Level p s a] -> p a -> p a
precedence levels atom = List.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)