1{-# LANGUAGE GADTs, UndecidableInstances #-} 2----------------------------------------------------------------------------- 3-- | 4-- Module : Distribution.Compat.Parsing 5-- Copyright : (c) Edward Kmett 2011-2012 6-- License : BSD3 7-- 8-- Maintainer : ekmett@gmail.com 9-- Stability : experimental 10-- Portability : non-portable 11-- 12-- Alternative parser combinators. 13-- 14-- Originally in @parsers@ package. 15-- 16----------------------------------------------------------------------------- 17module Distribution.Compat.Parsing 18 ( 19 -- * Parsing Combinators 20 choice 21 , option 22 , optional -- from Control.Applicative, parsec optionMaybe 23 , skipOptional -- parsec optional 24 , between 25 , some -- from Control.Applicative, parsec many1 26 , many -- from Control.Applicative 27 , sepBy 28 , sepByNonEmpty 29 , sepEndByNonEmpty 30 , sepEndBy 31 , endByNonEmpty 32 , endBy 33 , count 34 , chainl 35 , chainr 36 , chainl1 37 , chainr1 38 , manyTill 39 -- * Parsing Class 40 , Parsing(..) 41 ) where 42 43import Prelude () 44import Distribution.Compat.Prelude 45 46import Control.Applicative ((<**>), optional) 47import Control.Monad.Trans.Class (lift) 48import Control.Monad.Trans.State.Lazy as Lazy 49import Control.Monad.Trans.State.Strict as Strict 50import Control.Monad.Trans.Writer.Lazy as Lazy 51import Control.Monad.Trans.Writer.Strict as Strict 52import Control.Monad.Trans.RWS.Lazy as Lazy 53import Control.Monad.Trans.RWS.Strict as Strict 54import Control.Monad.Trans.Reader (ReaderT (..)) 55import Control.Monad.Trans.Identity (IdentityT (..)) 56import Data.Foldable (asum) 57 58import qualified Data.List.NonEmpty as NE 59import qualified Text.Parsec as Parsec 60 61-- | @choice ps@ tries to apply the parsers in the list @ps@ in order, 62-- until one of them succeeds. Returns the value of the succeeding 63-- parser. 64choice :: Alternative m => [m a] -> m a 65choice = asum 66{-# INLINE choice #-} 67 68-- | @option x p@ tries to apply parser @p@. If @p@ fails without 69-- consuming input, it returns the value @x@, otherwise the value 70-- returned by @p@. 71-- 72-- > priority = option 0 (digitToInt <$> digit) 73option :: Alternative m => a -> m a -> m a 74option x p = p <|> pure x 75{-# INLINE option #-} 76 77-- | @skipOptional p@ tries to apply parser @p@. It will parse @p@ or nothing. 78-- It only fails if @p@ fails after consuming input. It discards the result 79-- of @p@. (Plays the role of parsec's optional, which conflicts with Applicative's optional) 80skipOptional :: Alternative m => m a -> m () 81skipOptional p = (() <$ p) <|> pure () 82{-# INLINE skipOptional #-} 83 84-- | @between open close p@ parses @open@, followed by @p@ and @close@. 85-- Returns the value returned by @p@. 86-- 87-- > braces = between (symbol "{") (symbol "}") 88between :: Applicative m => m bra -> m ket -> m a -> m a 89between bra ket p = bra *> p <* ket 90{-# INLINE between #-} 91 92-- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated 93-- by @sep@. Returns a list of values returned by @p@. 94-- 95-- > commaSep p = p `sepBy` (symbol ",") 96sepBy :: Alternative m => m a -> m sep -> m [a] 97sepBy p sep = toList <$> sepByNonEmpty p sep <|> pure [] 98{-# INLINE sepBy #-} 99 100-- | @sepByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated 101-- by @sep@. Returns a non-empty list of values returned by @p@. 102sepByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) 103sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) 104{-# INLINE sepByNonEmpty #-} 105 106-- | @sepEndByNonEmpty p sep@ parses /one/ or more occurrences of @p@, 107-- separated and optionally ended by @sep@. Returns a non-empty list of values 108-- returned by @p@. 109sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) 110sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) 111 112-- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, 113-- separated and optionally ended by @sep@, ie. haskell style 114-- statements. Returns a list of values returned by @p@. 115-- 116-- > haskellStatements = haskellStatement `sepEndBy` semi 117sepEndBy :: Alternative m => m a -> m sep -> m [a] 118sepEndBy p sep = toList <$> sepEndByNonEmpty p sep <|> pure [] 119{-# INLINE sepEndBy #-} 120 121-- | @endByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated 122-- and ended by @sep@. Returns a non-empty list of values returned by @p@. 123endByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) 124endByNonEmpty p sep = NE.some1 (p <* sep) 125{-# INLINE endByNonEmpty #-} 126 127-- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated 128-- and ended by @sep@. Returns a list of values returned by @p@. 129-- 130-- > cStatements = cStatement `endBy` semi 131endBy :: Alternative m => m a -> m sep -> m [a] 132endBy p sep = many (p <* sep) 133{-# INLINE endBy #-} 134 135-- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or 136-- equal to zero, the parser equals to @return []@. Returns a list of 137-- @n@ values returned by @p@. 138count :: Applicative m => Int -> m a -> m [a] 139count n p | n <= 0 = pure [] 140 | otherwise = sequenceA (replicate n p) 141{-# INLINE count #-} 142 143-- | @chainr p op x@ parses /zero/ or more occurrences of @p@, 144-- separated by @op@ Returns a value obtained by a /right/ associative 145-- application of all functions returned by @op@ to the values returned 146-- by @p@. If there are no occurrences of @p@, the value @x@ is 147-- returned. 148chainr :: Alternative m => m a -> m (a -> a -> a) -> a -> m a 149chainr p op x = chainr1 p op <|> pure x 150{-# INLINE chainr #-} 151 152-- | @chainl p op x@ parses /zero/ or more occurrences of @p@, 153-- separated by @op@. Returns a value obtained by a /left/ associative 154-- application of all functions returned by @op@ to the values returned 155-- by @p@. If there are zero occurrences of @p@, the value @x@ is 156-- returned. 157chainl :: Alternative m => m a -> m (a -> a -> a) -> a -> m a 158chainl p op x = chainl1 p op <|> pure x 159{-# INLINE chainl #-} 160 161-- | @chainl1 p op x@ parses /one/ or more occurrences of @p@, 162-- separated by @op@ Returns a value obtained by a /left/ associative 163-- application of all functions returned by @op@ to the values returned 164-- by @p@. . This parser can for example be used to eliminate left 165-- recursion which typically occurs in expression grammars. 166-- 167-- > expr = term `chainl1` addop 168-- > term = factor `chainl1` mulop 169-- > factor = parens expr <|> integer 170-- > 171-- > mulop = (*) <$ symbol "*" 172-- > <|> div <$ symbol "/" 173-- > 174-- > addop = (+) <$ symbol "+" 175-- > <|> (-) <$ symbol "-" 176chainl1 :: Alternative m => m a -> m (a -> a -> a) -> m a 177chainl1 p op = scan where 178 scan = p <**> rst 179 rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id 180{-# INLINE chainl1 #-} 181 182-- | @chainr1 p op x@ parses /one/ or more occurrences of @p@, 183-- separated by @op@ Returns a value obtained by a /right/ associative 184-- application of all functions returned by @op@ to the values returned 185-- by @p@. 186chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a 187chainr1 p op = scan where 188 scan = p <**> rst 189 rst = (flip <$> op <*> scan) <|> pure id 190{-# INLINE chainr1 #-} 191 192-- | @manyTill p end@ applies parser @p@ /zero/ or more times until 193-- parser @end@ succeeds. Returns the list of values returned by @p@. 194-- This parser can be used to scan comments: 195-- 196-- > simpleComment = do{ string "<!--" 197-- > ; manyTill anyChar (try (string "-->")) 198-- > } 199-- 200-- Note the overlapping parsers @anyChar@ and @string \"-->\"@, and 201-- therefore the use of the 'try' combinator. 202manyTill :: Alternative m => m a -> m end -> m [a] 203manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go) 204{-# INLINE manyTill #-} 205 206infixr 0 <?> 207 208-- | Additional functionality needed to describe parsers independent of input type. 209class Alternative m => Parsing m where 210 -- | Take a parser that may consume input, and on failure, go back to 211 -- where we started and fail as if we didn't consume input. 212 try :: m a -> m a 213 214 -- | Give a parser a name 215 (<?>) :: m a -> String -> m a 216 217 -- | A version of many that discards its input. Specialized because it 218 -- can often be implemented more cheaply. 219 skipMany :: m a -> m () 220 skipMany p = () <$ many p 221 {-# INLINE skipMany #-} 222 223 -- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping 224 -- its result. (aka skipMany1 in parsec) 225 skipSome :: m a -> m () 226 skipSome p = p *> skipMany p 227 {-# INLINE skipSome #-} 228 229 -- | Used to emit an error on an unexpected token 230 unexpected :: String -> m a 231 232 -- | This parser only succeeds at the end of the input. This is not a 233 -- primitive parser but it is defined using 'notFollowedBy'. 234 -- 235 -- > eof = notFollowedBy anyChar <?> "end of input" 236 eof :: m () 237 238 -- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser 239 -- does not consume any input. This parser can be used to implement the 240 -- \'longest match\' rule. For example, when recognizing keywords (for 241 -- example @let@), we want to make sure that a keyword is not followed 242 -- by a legal identifier character, in which case the keyword is 243 -- actually an identifier (for example @lets@). We can program this 244 -- behaviour as follows: 245 -- 246 -- > keywordLet = try $ string "let" <* notFollowedBy alphaNum 247 notFollowedBy :: Show a => m a -> m () 248 249instance (Parsing m, MonadPlus m) => Parsing (Lazy.StateT s m) where 250 try (Lazy.StateT m) = Lazy.StateT $ try . m 251 {-# INLINE try #-} 252 Lazy.StateT m <?> l = Lazy.StateT $ \s -> m s <?> l 253 {-# INLINE (<?>) #-} 254 unexpected = lift . unexpected 255 {-# INLINE unexpected #-} 256 eof = lift eof 257 {-# INLINE eof #-} 258 notFollowedBy (Lazy.StateT m) = Lazy.StateT 259 $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) 260 {-# INLINE notFollowedBy #-} 261 262instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where 263 try (Strict.StateT m) = Strict.StateT $ try . m 264 {-# INLINE try #-} 265 Strict.StateT m <?> l = Strict.StateT $ \s -> m s <?> l 266 {-# INLINE (<?>) #-} 267 unexpected = lift . unexpected 268 {-# INLINE unexpected #-} 269 eof = lift eof 270 {-# INLINE eof #-} 271 notFollowedBy (Strict.StateT m) = Strict.StateT 272 $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) 273 {-# INLINE notFollowedBy #-} 274 275instance (Parsing m, MonadPlus m) => Parsing (ReaderT e m) where 276 try (ReaderT m) = ReaderT $ try . m 277 {-# INLINE try #-} 278 ReaderT m <?> l = ReaderT $ \e -> m e <?> l 279 {-# INLINE (<?>) #-} 280 skipMany (ReaderT m) = ReaderT $ skipMany . m 281 {-# INLINE skipMany #-} 282 unexpected = lift . unexpected 283 {-# INLINE unexpected #-} 284 eof = lift eof 285 {-# INLINE eof #-} 286 notFollowedBy (ReaderT m) = ReaderT $ notFollowedBy . m 287 {-# INLINE notFollowedBy #-} 288 289instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.WriterT w m) where 290 try (Strict.WriterT m) = Strict.WriterT $ try m 291 {-# INLINE try #-} 292 Strict.WriterT m <?> l = Strict.WriterT (m <?> l) 293 {-# INLINE (<?>) #-} 294 unexpected = lift . unexpected 295 {-# INLINE unexpected #-} 296 eof = lift eof 297 {-# INLINE eof #-} 298 notFollowedBy (Strict.WriterT m) = Strict.WriterT 299 $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) 300 {-# INLINE notFollowedBy #-} 301 302instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where 303 try (Lazy.WriterT m) = Lazy.WriterT $ try m 304 {-# INLINE try #-} 305 Lazy.WriterT m <?> l = Lazy.WriterT (m <?> l) 306 {-# INLINE (<?>) #-} 307 unexpected = lift . unexpected 308 {-# INLINE unexpected #-} 309 eof = lift eof 310 {-# INLINE eof #-} 311 notFollowedBy (Lazy.WriterT m) = Lazy.WriterT 312 $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) 313 {-# INLINE notFollowedBy #-} 314 315instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.RWST r w s m) where 316 try (Lazy.RWST m) = Lazy.RWST $ \r s -> try (m r s) 317 {-# INLINE try #-} 318 Lazy.RWST m <?> l = Lazy.RWST $ \r s -> m r s <?> l 319 {-# INLINE (<?>) #-} 320 unexpected = lift . unexpected 321 {-# INLINE unexpected #-} 322 eof = lift eof 323 {-# INLINE eof #-} 324 notFollowedBy (Lazy.RWST m) = Lazy.RWST 325 $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty) 326 {-# INLINE notFollowedBy #-} 327 328instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.RWST r w s m) where 329 try (Strict.RWST m) = Strict.RWST $ \r s -> try (m r s) 330 {-# INLINE try #-} 331 Strict.RWST m <?> l = Strict.RWST $ \r s -> m r s <?> l 332 {-# INLINE (<?>) #-} 333 unexpected = lift . unexpected 334 {-# INLINE unexpected #-} 335 eof = lift eof 336 {-# INLINE eof #-} 337 notFollowedBy (Strict.RWST m) = Strict.RWST 338 $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty) 339 {-# INLINE notFollowedBy #-} 340 341instance (Parsing m, Monad m) => Parsing (IdentityT m) where 342 try = IdentityT . try . runIdentityT 343 {-# INLINE try #-} 344 IdentityT m <?> l = IdentityT (m <?> l) 345 {-# INLINE (<?>) #-} 346 skipMany = IdentityT . skipMany . runIdentityT 347 {-# INLINE skipMany #-} 348 unexpected = lift . unexpected 349 {-# INLINE unexpected #-} 350 eof = lift eof 351 {-# INLINE eof #-} 352 notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m 353 {-# INLINE notFollowedBy #-} 354 355instance (Parsec.Stream s m t, Show t) => Parsing (Parsec.ParsecT s u m) where 356 try = Parsec.try 357 (<?>) = (Parsec.<?>) 358 skipMany = Parsec.skipMany 359 skipSome = Parsec.skipMany1 360 unexpected = Parsec.unexpected 361 eof = Parsec.eof 362 notFollowedBy = Parsec.notFollowedBy 363