parsers/Parsers/Utils/Attoparsec.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 module Parsers.Utils.Attoparsec where
   3
   4 import Control.Applicative hiding (some)
   5 import Control.Monad (Monad(..), MonadPlus)
   6 import Data.Attoparsec.Combinator
   7 import Data.Bool (Bool(..))
   8 import Data.Char (Char)
   9 import Data.Either (Either(..))
  10 import Data.Eq (Eq(..))
  11 import Data.Function (flip, ($), id)
  12 import Data.Functor (void)
  13 import Data.Maybe (Maybe(..), maybe)
  14 import Data.String (String)
  15 import Data.Word (Word8)
  16 import qualified Data.List as List
  17 import qualified Data.Text as T
  18 import qualified Data.ByteString as BS
  19 import qualified Data.Attoparsec.Internal.Types as AP
  20 import qualified Data.Attoparsec.ByteString as AP.ByteString
  21 import qualified Data.Attoparsec.ByteString.Char8 as AP.ByteString.Char8
  22 import qualified Data.Attoparsec.Text as AP.Text
  23
  24 -- * Class 'Inputable'
  25 class AP.Chunk inp => Inputable inp where
  26   type Token inp
  27   null :: inp -> Bool
  28   empty :: inp
  29   uncons :: inp -> Maybe (Token inp, inp)
  30   satisfy :: (Token inp -> Bool) -> AP.Parser inp (Token inp)
  31   char :: Char -> AP.Parser inp Char
  32   notInClass :: String -> Token inp -> Bool
  33 instance Inputable T.Text where
  34   type Token T.Text = Char
  35   null = T.null
  36   empty = T.empty
  37   uncons = T.uncons
  38   satisfy = AP.Text.satisfy
  39   char = AP.Text.char
  40   notInClass = AP.Text.notInClass
  41 instance Inputable BS.ByteString where
  42   type Token BS.ByteString = Word8
  43   null = BS.null
  44   empty = BS.empty
  45   uncons = BS.uncons
  46   satisfy = AP.ByteString.satisfy
  47   char = AP.ByteString.Char8.char
  48   notInClass = AP.ByteString.notInClass
  49
  50 between :: Applicative f => f a -> f b -> f c -> f c
  51 between o c p = o *> p <* c
  52
  53 match :: (Monad m, Eq a) => [a] -> m a -> (a -> m b) -> m b -> m b
  54 match xs p f def = p >>= (\x -> if List.elem x xs then f x else def)
  55
  56 skipSome :: Alternative p => p a -> p ()
  57 skipSome p = void (some p)
  58
  59 some :: Alternative p => p a -> p [a]
  60 some = many1
  61
  62 maybeP :: Alternative p => p a -> p (Maybe a)
  63 maybeP p = option Nothing (Just <$> p)
  64
  65 fromMaybeP :: Monad m => m (Maybe a) -> m a -> m a
  66 fromMaybeP mmx d = mmx >>= maybe d return
  67
  68 (<+>) :: Alternative p => p a -> p b -> p (Either a b)
  69 p <+> q = Left <$> p <|> Right <$> q
  70
  71 (<:>) :: Applicative p => p a -> p [a] -> p [a]
  72 (<:>) = liftA2 (:)
  73
  74 (<~>) :: Applicative p => p a -> p b -> p (a, b)
  75 (<~>) = liftA2 (,)
  76
  77 pfoldl1 :: Alternative p => (b -> a -> b) -> b -> p a -> p b
  78 pfoldl1 f k p = List.foldl' f k <$> some p
  79
  80 (>?>) :: MonadPlus m => m a -> (a -> Bool) -> m a
  81 m >?> f = m >>= \x -> if f x then return x else Control.Applicative.empty
  82
  83 chainPre :: Alternative p => p (a -> a) -> p a -> p a
  84 chainPre op p = flip (List.foldr ($)) <$> many op <*> p
  85
  86 chainPost :: Alternative p => p a -> p (a -> a) -> p a
  87 chainPost p op = List.foldl' (flip ($)) <$> p <*> many op
  88
  89 chainl1 :: Alternative p => p a -> p (a -> a -> a) -> p a
  90 chainl1 p op = chainPost p (flip <$> op <*> p)
  91
  92 chainr1 :: Alternative p => p a -> p (a -> a -> a) -> p a
  93 chainr1 p op = let go = p <**> ((flip <$> op <*> go) <|> pure id) in go
  94
  95 data Level p s a
  96   = InfixL  [p (a -> a -> a)]
  97   | InfixR  [p (a -> a -> a)]
  98   | Prefix  [p (a -> a)]
  99   | Postfix [p (a -> a)]
 100
 101 precedence :: Alternative p => [Level p s a] -> p a -> p a
 102 precedence levels atom = List.foldl' convert atom levels
 103   where
 104   convert x (InfixL ops)  = chainl1 x (choice ops)
 105   convert x (InfixR ops)  = chainr1 x (choice ops)
 106   convert x (Prefix ops)  = chainPre (choice ops) x
 107   convert x (Postfix ops) = chainPost x (choice ops)