{-# LANGUAGE CPP, TemplateHaskell, TypeOperators #-}
module Text.Boomerang.Combinators
( (<>), duck, duck1, opt
, manyr, somer, chainr, chainr1, manyl, somel, chainl, chainl1
, rFilter, printAs, push, rNil, rCons, rList, rList1, rListSep, rPair
, rLeft, rRight, rEither, rNothing, rJust, rMaybe
, rTrue, rFalse, rBool, rUnit
)
where
import Control.Arrow (first, second)
import Prelude hiding ((.), id, (/))
import Control.Category (Category((.), id))
import Control.Monad (guard)
import Text.Boomerang.Prim (Parser(..), Boomerang(..), (.~), val, xpure)
import Text.Boomerang.HStack ((:-)(..), arg, hhead)
import Text.Boomerang.TH (makeBoomerangs)
#if MIN_VERSION_base(4,5,0)
import Data.Monoid (Monoid(mappend), (<>))
#else
import Data.Monoid (Monoid(mappend))
infixr 6 <>
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
#endif
duck :: Boomerang e tok r1 r2 -> Boomerang e tok (h :- r1) (h :- r2)
duck r = Boomerang
(fmap (\f (h :- t) -> h :- f t) $ prs r)
(\(h :- t) -> map (second (h :-)) $ ser r t)
duck1 :: Boomerang e tok r1 (a :- r2) -> Boomerang e tok (h :- r1) (a :- h :- r2)
duck1 r = Boomerang
(fmap (\f (h :- t) -> let a :- t' = f t in a :- h :- t') $ prs r)
(\(a :- h :- t) -> map (second (h :-)) $ ser r (a :- t))
opt :: Boomerang e tok r r -> Boomerang e tok r r
opt = (id <>)
manyr :: Boomerang e tok r r -> Boomerang e tok r r
manyr = opt . somer
somer :: Boomerang e tok r r -> Boomerang e tok r r
somer p = p . manyr p
chainr :: Boomerang e tok r r -> Boomerang e tok r r -> Boomerang e tok r r
chainr p op = opt (manyr (p .~ op) . p)
chainr1 :: Boomerang e tok r (a :- r) -> Boomerang e tok (a :- a :- r) (a :- r) -> Boomerang e tok r (a :- r)
chainr1 p op = manyr (duck p .~ op) . p
manyl :: Boomerang e tok r r -> Boomerang e tok r r
manyl = opt . somel
somel :: Boomerang e tok r r -> Boomerang e tok r r
somel p = p .~ manyl p
chainl :: Boomerang e tok r r -> Boomerang e tok r r -> Boomerang e tok r r
chainl p op = opt (p .~ manyl (op . p))
chainl1 :: Boomerang e tok r (a :- r) -> Boomerang e tok (a :- a :- r) (a :- r) -> Boomerang e tok r (a :- r)
chainl1 p op = p .~ manyl (op . duck p)
rFilter :: (a -> Bool) -> Boomerang e tok () (a :- ()) -> Boomerang e tok r (a :- r)
rFilter p r = val ps ss
where
ps = Parser $ \tok pos ->
let parses = runParser (prs r) tok pos
in [ Right ((a, tok), pos) | (Right ((f, tok), pos)) <- parses, let a = hhead (f ()), p a]
ss = \a -> [ f | p a, (f, _) <- ser r (a :- ()) ]
printAs :: Boomerang e [tok] a b -> tok -> Boomerang e [tok] a b
printAs r s = r { ser = map (first (const (s :))) . take 1 . ser r }
push :: Eq a => a -> Boomerang e tok r (a :- r)
push a = xpure (a :-) (\(a' :- t) -> guard (a' == a) >> Just t)
rNil :: Boomerang e tok r ([a] :- r)
rNil = xpure ([] :-) $ \(xs :- t) -> do [] <- Just xs; Just t
rCons :: Boomerang e tok (a :- [a] :- r) ([a] :- r)
rCons = xpure (arg (arg (:-)) (:)) $ \(xs :- t) -> do a:as <- Just xs; Just (a :- as :- t)
rList :: Boomerang e tok r (a :- r) -> Boomerang e tok r ([a] :- r)
rList r = manyr (rCons . duck1 r) . rNil
rList1 :: Boomerang e tok r (a :- r) -> Boomerang e tok r ([a] :- r)
rList1 r = somer (rCons . duck1 r) . rNil
rListSep :: Boomerang e tok r (a :- r) -> Boomerang e tok ([a] :- r) ([a] :- r) -> Boomerang e tok r ([a] :- r)
rListSep r sep = chainr (rCons . duck1 r) sep . rNil
rPair :: Boomerang e tok (f :- s :- r) ((f, s) :- r)
rPair = xpure (arg (arg (:-)) (,)) $ \(ab :- t) -> do (a,b) <- Just ab; Just (a :- b :- t)
$(makeBoomerangs ''Either)
rEither :: Boomerang e tok r (a :- r) -> Boomerang e tok r (b :- r) -> Boomerang e tok r (Either a b :- r)
rEither l r = rLeft . l <> rRight . r
$(makeBoomerangs ''Maybe)
rMaybe :: Boomerang e tok r (a :- r) -> Boomerang e tok r (Maybe a :- r)
rMaybe r = rJust . r <> rNothing
$(makeBoomerangs ''Bool)
rBool :: Boomerang e tok a r
-> Boomerang e tok a r
-> Boomerang e tok a (Bool :- r)
rBool t f = rTrue . t <> rFalse . f
rUnit :: Boomerang e tok r (() :- r)
rUnit = xpure ((:-) ()) (\ (() :- x) -> Just x)