module Text.ParserCombinators.UU.Derived where
import Text.ParserCombinators.UU.Core
import Control.Monad
pReturn :: a -> P str a
pReturn = pure
pFail :: P str a
pFail = empty
infixl 4 <??>
infixl 2 `opt`
opt :: P st a -> a -> P st a
p `opt` v = must_be_non_empty "opt" p (p <<|> pure v)
pMaybe :: P st a -> P st (Maybe a)
pMaybe p = must_be_non_empty "pMaybe" p (Just <$> p `opt` Nothing)
pEither :: P str a -> P str b -> P str (Either a b)
pEither p q = Left <$> p <|> Right <$> q
(<$$>) :: (a -> b -> c) -> P st b -> P st (a -> c)
f <$$> p = flip f <$> p
(<??>) :: P st a -> P st (a -> a) -> P st a
p <??> q = must_be_non_empty "<??>" q (p <**> (q `opt` id))
pPacked :: P st b1 -> P st b2 -> P st a -> P st a
pPacked l r x = l *> x <* r
pFoldr :: (a -> a1 -> a1, a1) -> P st a -> P st a1
pFoldr alg@(op,e) p = must_be_non_empty "pFoldr" p pfm
where pfm = (op <$> p <*> pfm) `opt` e
pFoldr_ng :: (a -> a1 -> a1, a1) -> P st a -> P st a1
pFoldr_ng alg@(op,e) p = must_be_non_empty "pFoldr_ng" p pfm
where pfm = (op <$> p <*> pfm) <|> pure e
pFoldr1 :: (v -> b -> b, b) -> P st v -> P st b
pFoldr1 alg@(op,e) p = must_be_non_empty "pFoldr1" p (op <$> p <*> pFoldr alg p)
pFoldr1_ng :: (v -> b -> b, b) -> P st v -> P st b
pFoldr1_ng alg@(op,e) p = must_be_non_empty "pFoldr1_ng" p (op <$> p <*> pFoldr_ng alg p)
pFoldrSep :: (v -> b -> b, b) -> P st a -> P st v -> P st b
pFoldrSep alg@(op,e) sep p = must_be_non_empties "pFoldrSep" sep p
(op <$> p <*> pFoldr alg sepp `opt` e)
where sepp = sep *> p
pFoldrSep_ng :: (v -> b -> b, b) -> P st a -> P st v -> P st b
pFoldrSep_ng alg@(op,e) sep p = must_be_non_empties "pFoldrSep" sep p
(op <$> p <*> pFoldr_ng alg sepp <|> pure e)
where sepp = sep *> p
pFoldr1Sep :: (a -> b -> b, b) -> P st a1 ->P st a -> P st b
pFoldr1Sep alg@(op,e) sep p = must_be_non_empties "pFoldr1Sep" sep p pfm
where pfm = op <$> p <*> pFoldr alg (sep *> p)
pFoldr1Sep_ng :: (a -> b -> b, b) -> P st a1 ->P st a -> P st b
pFoldr1Sep_ng alg@(op,e) sep p = must_be_non_empties "pFoldr1Sep_ng" sep p pfm
where pfm = op <$> p <*> pFoldr_ng alg (sep *> p)
list_alg :: (a -> [a] -> [a], [a1])
list_alg = ((:), [])
pList :: P st a -> P st [a]
pList p = must_be_non_empty "pList" p (pFoldr list_alg p)
pList_ng :: P st a -> P st [a]
pList_ng p = must_be_non_empty "pList_ng" p (pFoldr_ng list_alg p)
pList1 :: P st a -> P st [a]
pList1 p = must_be_non_empty "pList" p (pFoldr1 list_alg p)
pList1_ng :: P st a -> P st [a]
pList1_ng p = must_be_non_empty "pList_ng" p (pFoldr1_ng list_alg p)
pListSep :: P st a1 -> P st a -> P st [a]
pListSep sep p = must_be_non_empties "pListSep" sep p (pFoldrSep list_alg sep p)
pListSep_ng :: P st a1 -> P st a -> P st [a]
pListSep_ng sep p = must_be_non_empties "pListSep_ng" sep p pFoldrSep_ng list_alg sep p
pList1Sep :: P st a1 -> P st a -> P st [a]
pList1Sep s p = must_be_non_empties "pListSep" s p (pFoldr1Sep list_alg s p)
pList1Sep_ng :: P st a1 -> P st a -> P st [a]
pList1Sep_ng s p = must_be_non_empties "pListSep_ng" s p (pFoldr1Sep_ng list_alg s p)
pChainr :: P st (c -> c -> c) -> P st c -> P st c
pChainr op x = must_be_non_empties "pChainr" op x r where r = x <??> (flip <$> op <*> r)
pChainr_ng :: P st (c -> c -> c) -> P st c -> P st c
pChainr_ng op x = must_be_non_empties "pChainr_ng" op x r where r = x <**> ((flip <$> op <*> r) <|> pure id)
pChainl :: P st (c -> c -> c) -> P st c -> P st c
pChainl op x = must_be_non_empties "pChainl" op x (f <$> x <*> pList (flip <$> op <*> x))
where f x [] = x
f x (func:rest) = f (func x) rest
pChainl_ng :: P st (c -> c -> c) -> P st c -> P st c
pChainl_ng op x = must_be_non_empties "pChainl_ng" op x (f <$> x <*> pList_ng (flip <$> op <*> x))
where f x [] = x
f x (func:rest) = f (func x) rest
pAny :: (a -> P st a1) -> [a] -> P st a1
pAny f l = foldr (<|>) pFail (map f l)
pAnySym :: Provides st s s => [s] -> P st s
pAnySym = pAny pSym
instance MonadPlus (P st) where
mzero = pFail
mplus = (<|>)
infixl 3 <||>
data Freq p = AtLeast Int p
| AtMost Int p
| Between Int Int p
| One p
| Many p
| Opt p
| Never p
instance Functor Freq where
fmap f (AtLeast n p) = AtLeast n (f p)
fmap f (AtMost n p) = AtMost n (f p)
fmap f (Between n m p) = Between n m (f p)
fmap f (One p) = One (f p)
fmap f (Many p) = Many (f p)
fmap f (Opt p) = Opt (f p)
fmap f (Never p) = Never (f p)
canBeEmpty :: Freq t -> Bool
canBeEmpty (AtLeast _ p) = False
canBeEmpty (AtMost _ p) = True
canBeEmpty (Between n m p) = if n==0 then error "wrong use of Between" else False
canBeEmpty (One p) = False
canBeEmpty (Many p) = True
canBeEmpty (Opt p) = True
canBeEmpty (Never p) = True
split :: [Freq p] -> ([Freq p] -> [Freq p]) -> [(p, [Freq p])]
split [] _ = []
split (x:xs) f = oneAlt (x, f xs): split xs (f.(x:))
where oneAlt (AtLeast 1 p, others) = (p, Many p : others)
oneAlt (AtLeast n p, others) = (p, AtLeast (n1) p : others)
oneAlt (AtMost 1 p, others) = (p, others)
oneAlt (AtMost n p, others) = (p, AtMost (n1) p : others)
oneAlt (Between 1 1 p, others) = (p, others)
oneAlt (Between 1 m p, others) = (p, AtMost (m1) p : others)
oneAlt (Between n m p, others) = (p, Between (n1) (m1) p : others)
oneAlt (One p, others) = (p, others)
oneAlt (Many p, others) = (p, Many p : others)
oneAlt (Opt p, others) = (p, others)
toParser :: [ Freq (P st (d -> d)) ] -> P st d -> P st d
toParser [] units = units
toParser alts units = let palts = [p <*> toParser ps units | (p,ps) <- split alts id]
in if and (map canBeEmpty alts)
then foldr (<|>) units palts
else foldr1 (<|>) palts
toParserSep :: [Freq (P st (b -> b))] -> P st a -> P st b -> P st b
toParserSep alts sep units = let palts = [p <*> toParser (map (fmap (sep *>)) ps) units | (p,ps) <- split alts id]
in if and (map canBeEmpty alts)
then foldr (<|>) units palts
else foldr1 (<|>) palts
newtype MergeSpec p = MergeSpec p
(<||>) :: MergeSpec (c, [Freq (P st (d -> d) )], e -> f -> g)
-> MergeSpec (h, [Freq (P st (i -> i) )], g -> j -> k)
-> MergeSpec ((c,h), [Freq (P st ((d,i) -> (d,i)))], e -> (f,j) -> k)
MergeSpec (pe, pp, punp) <||> MergeSpec (qe, qp, qunp)
= MergeSpec ( (pe, qe)
, map (fmap (mapFst <$>)) pp ++ map (fmap (mapSnd <$>)) qp
, \f (x, y) -> qunp (punp f x) y
)
pSem :: t -> MergeSpec (t1, t2, t -> t3 -> t4)
-> MergeSpec (t1, t2, (t4 -> t5) -> t3 -> t5)
f `pSem` MergeSpec (units, alts, unp) = MergeSpec (units, alts, \ g arg -> g ( unp f arg))
pMerge :: c -> MergeSpec (d, [Freq (P st (d -> d))], c -> d -> e) -> P st e
sem `pMerge` MergeSpec (units, alts, unp) = unp sem <$> toParser alts (pure units)
pMergeSep :: (c, P st a) -> MergeSpec (d, [Freq (P st (d -> d))], c -> d -> e) -> P st e
(sem, sep) `pMergeSep` MergeSpec (units, alts, unp) = unp sem <$> toParserSep alts sep (pure units)
pBetween :: Int -> Int -> P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)
pBetween n m p = must_be_non_empty "pOpt" p
(if m <n || m <= 0 then (MergeSpec ([] ,[ ], id))
else if n==0 then (MergeSpec ([] ,[AtMost m ((:) <$> p)], id))
else (MergeSpec ([] ,[Between n m ((:) <$> p)], id)))
pAtMost :: Int -> P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)
pAtMost n p = must_be_non_empty "pOpt" p
(if n <= 0 then (MergeSpec ([] ,[ ], id))
else (MergeSpec ([] ,[AtMost n ((:) <$> p)], id)))
pAtLeast :: Int -> P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)
pAtLeast n p = must_be_non_empty "pOpt" p
(if n <= 0 then (MergeSpec ([] ,[Many ((:) <$> p)], id))
else (MergeSpec ([] ,[AtLeast n ((:) <$> p)], id)))
pMany :: P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)
pMany p = must_be_non_empty "pMany" p (MergeSpec ([] ,[Many ((:) <$> p)], id))
pOpt :: P t t1 -> t11 -> MergeSpec (t11, [Freq (P t (b -> t1))], a -> a)
pOpt p v = must_be_non_empty "pOpt" p (MergeSpec (v ,[Opt (const <$> p)], id))
pSome :: P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)
pSome p = must_be_non_empty "pSome" p (MergeSpec ([] ,[AtLeast 1 ((:) <$> p)], id))
pOne :: P t t1 -> MergeSpec (a, [Freq (P t (b -> t1))], a1 -> a1)
pOne p = must_be_non_empty "pOne" p (MergeSpec (undefined,[One (const <$> p)], id))
mapFst :: (t -> t2) -> (t, t1) -> (t2, t1)
mapFst f (a, b) = (f a, b)
mapSnd :: (t1 -> t2) -> (t, t1) -> (t, t2)
mapSnd f (a, b) = (a, f b)