adblock2privoxy-3.0.0: src/ParsecExt.hs

module ParsecExt
  ( CasesParser,
    StateParser,
    StringStateParser,
    cases,
    manyCases,
    many1Cases,
    oneCase,
  )
where

import Control.Applicative hiding (many)
import Control.Monad
import Control.Monad.RWS
import Control.Monad.State
import Data.Maybe
import Text.ParserCombinators.Parsec hiding (State, (<|>))
import Utils

-- parser should consume some input to prevent infinite loop
manyCases :: (Monoid a, Monoid st) => Parser a -> StateParser st a
manyCases p = do
  acc <- get
  put $ Just mempty
  lift $
    if isNothing acc
      then return mempty
      else p

oneCase :: (Monoid a, Monoid st) => Parser a -> StateParser st a
oneCase p = do
  acc <- get
  put $ Just mempty
  lift $
    if isNothing acc
      then p
      else pzero

many1Cases :: Parser a -> StateParser st a
many1Cases = lift

type StringStateParser = StateParser String

type StateParser st = StateT (Maybe st) Parser

type CasesParser st r = RWST () [r] String (StateParser st)

optionMaybeTry :: StateParser st a -> StateParser st (Maybe a)
optionMaybeTry p = fmap Just (mapStateT try p) <|> return Nothing

cases :: forall r st. (Monoid r) => [StateParser st r] -> Parser [r]
cases parsers = evalStateT stateParser Nothing
  where
    stateParser = do
      input <- lift getInput
      let boxedParser = (mapRWST . mapStateT) lookAhead $ casesParser mempty parsers
      (input', res) <- execRWST boxedParser () input
      lift (setInput input')
      return res

casesParser :: forall r st. (Monoid r) => r -> [StateParser st r] -> CasesParser st r ()
casesParser _ [] = error "Empty parser list is not accepted"
casesParser acc parsers@(parser : next) = do
  maybeRes <- lift (optionMaybeTry parser)
  case maybeRes of
    Nothing -> return ()
    Just res -> do
      input <- lift . lift $ getInput
      let acc' = acc <> res
      if null input || null next
        then do
          modify (minList input) -- TODO: somehow use processed length to select min input
          tell [acc']
        else do
          st <- lift get
          lift (put Nothing)
          (mapRWST . mapStateT) lookAhead $ casesParser acc' next
          lift (put st)
      unless (null input) $ casesParser acc' parsers

------------------------------------------------------------------------------------------------