Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Replacing Failure by a Heap of Successes
{-# 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 _ _ [] = []
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment