Replacing Failure by a Heap of Successes

Success.hs

{-# LANGUAGE DeriveFunctor, TypeFamilies #-}
module Success
  ( Parser(..)
  , parse
  ) where

import Control.Applicative
import Control.Monad
import Data.Bifunctor
import Data.Profunctor
import Text.Parser.Combinators
import Text.Parser.Char
import Text.Parser.LookAhead

gather :: [(Int,a)] -> [(Int, [a])]
gather [] = []
gather ((i0, a0) : as0) = go i0 [a0] as0 where
  go i acc [] = [(i,acc)]
  go i acc ((j, a) : as)
    | i == j    = go i (a:acc) as
    | otherwise = (i, acc) : go j [a] as

-- fair interleaving, because, well, why not?
merge :: [(Int, a)] -> [(Int, a)] -> [(Int, a)]
merge [] as = as
merge as [] = as
merge aas@(a:as) bbs@(b:bs)
  | fst a <= fst b = a : merge bbs as
  | otherwise      = b : merge bs aas
  
newtype Parser i o = Parser { runParser :: [i] -> [(Int,o)] }
  deriving Functor

instance Applicative (Parser i) where
  pure a = Parser $ \_ -> [(0,a)]
  Parser mf <*> Parser ma = Parser $ \s0 -> go 0 s0 (gather (mf s0)) [] where
    go i s ((j, fs) : fss) acc
      | s' <- drop (j-i) s = go j s' fss $ merge acc $ ma s' >>= \(k,a) -> fmap (\f -> (j+k,f a)) fs
    go _ _ [] acc = acc

instance Alternative (Parser i) where
  empty = Parser $ \_ -> []
  Parser m <|> Parser n = Parser $ \s -> m s `merge` n s

instance Monad (Parser i) where
  return a = Parser $ \_ -> [(0,a)]
  Parser ma >>= amb = Parser $ \s0 -> go 0 s0 (ma s0) [] where
    go i s ((j, a) : fss) acc 
      | s' <- drop (j-i) s = go j s' fss $ merge acc $ (\(k,b) -> (j+k,b)) <$> runParser (amb a) s'
    go _ _ [] acc = acc

instance MonadPlus (Parser i) where
  mzero = empty
  mplus = (<|>)

instance Parsing (Parser i) where
  try = id
  m <?> _ = m
  unexpected _ = empty
  eof = Parser $ \s -> case s of
    [] -> [(0,())]
    _  -> []
  notFollowedBy (Parser m) = Parser $ \s -> 
    if null (m s)
    then [(0,())]
    else []

instance (c ~ Char) => CharParsing (Parser c) where
  satisfy p = Parser $ \s -> case s of
    c:_ | p c -> [(1,c)]
    _         -> []

instance LookAheadParsing (Parser i) where
  lookAhead (Parser m) = Parser $ \s -> first (const 0) <$> m s

instance Profunctor Parser where
  dimap f g (Parser m) = Parser $ map (second g) . m . map f

parse :: Parser i o -> [i] -> [(o, [i])]
parse (Parser m) s0 = go 0 s0 (m s0) where
  go i s ((j,o):xs) | s' <- drop (j-i) s = (o,s') : go j s' xs
  go _ _ [] = []