diff options
| -rw-r--r-- | src/Control/Monad/Combinators/FailExpr.hs | 23 |
1 files changed, 16 insertions, 7 deletions
diff --git a/src/Control/Monad/Combinators/FailExpr.hs b/src/Control/Monad/Combinators/FailExpr.hs index 045bd00..d401462 100644 --- a/src/Control/Monad/Combinators/FailExpr.hs +++ b/src/Control/Monad/Combinators/FailExpr.hs @@ -59,6 +59,11 @@ liftMaybe :: (Alternative f) => Maybe a -> f a liftMaybe (Just x) = pure x liftMaybe Nothing = empty +loopM :: (Alternative m, Monad m) => (a -> m a) -> a -> m a +loopM f = go + where + go x = (f x >>= go) <|> return x + -- Algorithm overview: -- * We do not handle parantheses; expressions within parantheses count as @@ -100,9 +105,12 @@ makeExprParser makeExprParser termP = exp where exp :: [[Operator m a]] -> m a - exp ctxOpss = termP >>= suf [] + exp ctxOpss = termP >>= sufs where - suf :: [Operator m a] -> a -> m a + sufs :: a -> m a + sufs = fmap snd . loopM (uncurry suf) . ([],) + + suf :: [Operator m a] -> a -> m ([Operator m a], a) suf badInitialOps x = runAnyBinOp badInitialOps *> fail ( unwords @@ -112,11 +120,12 @@ makeExprParser termP = exp ) <|> suf' ctxOpss where - suf' :: [[Operator m a]] -> m a - suf' [] = return x + suf' :: [[Operator m a]] -> m ([Operator m a], a) + suf' [] = return ([], x) suf' (ops:opss) = suf'' ops opss <|> suf' opss - suf'' :: [Operator m a] -> [[Operator m a]] -> m a + suf'' + :: [Operator m a] -> [[Operator m a]] -> m ([Operator m a], a) suf'' ops opss = do (assoc, f) <- runAnyBinOp ops y <- exp $ case assoc of @@ -125,5 +134,5 @@ makeExprParser termP = exp x' <- liftMaybe (f x y) <|> fail "Mismatching operator signature." case assoc of - AssocL -> suf (filter (not . isOpAssocL) ops) x' - _ -> suf ops x' + AssocL -> return (filter (not . isOpAssocL) ops, x') + _ -> return (ops, x') |