{-# LANGUAGE ExistentialQuantification #-}
module Text.Parsec.Perm
( PermParser
, StreamPermParser
, permute
, (<||>), (<$$>)
, (<|?>), (<$?>)
) where
import Text.Parsec
import Control.Monad.Identity
infixl 1 <||>, <|?>
infixl 2 <$$>, <$?>
(<||>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b
(<||>) perm p = add perm p
(<$$>) :: (Stream s Identity tok) => (a -> b) -> Parsec s st a -> StreamPermParser s st b
(<$$>) f p = newperm f <||> p
(<|?>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b
(<|?>) perm (x,p) = addopt perm x p
(<$?>) :: (Stream s Identity tok) => (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b
(<$?>) f (x,p) = newperm f <|?> (x,p)
type PermParser tok st a = StreamPermParser String st a
data StreamPermParser s st a = Perm (Maybe a) [StreamBranch s st a]
data StreamBranch s st a = forall b. Branch (StreamPermParser s st (b -> a)) (Parsec s st b)
permute :: (Stream s Identity tok) => StreamPermParser s st a -> Parsec s st a
permute (Perm def xs)
= choice (map branch xs ++ empty)
where
empty
= case def of
Nothing -> []
Just x -> [return x]
branch (Branch perm p)
= do{ x <- p
; f <- permute perm
; return (f x)
}
newperm :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st (a -> b)
newperm f
= Perm (Just f) []
add :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b
add perm@(Perm _mf fs) p
= Perm Nothing (first:map insert fs)
where
first = Branch perm p
insert (Branch perm' p')
= Branch (add (mapPerms flip perm') p) p'
addopt :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> a -> Parsec s st a -> StreamPermParser s st b
addopt perm@(Perm mf fs) x p
= Perm (fmap ($ x) mf) (first:map insert fs)
where
first = Branch perm p
insert (Branch perm' p')
= Branch (addopt (mapPerms flip perm') x p) p'
mapPerms :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st a -> StreamPermParser s st b
mapPerms f (Perm x xs)
= Perm (fmap f x) (map mapBranch xs)
where
mapBranch (Branch perm p)
= Branch (mapPerms (f.) perm) p