diff options
Diffstat (limited to 'compiler/utils')
| -rw-r--r-- | compiler/utils/Bag.lhs | 55 | ||||
| -rw-r--r-- | compiler/utils/Digraph.lhs | 2 | ||||
| -rw-r--r-- | compiler/utils/Outputable.lhs | 5 |
3 files changed, 57 insertions, 5 deletions
diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs index b2be2c30db..fa18219cb8 100644 --- a/compiler/utils/Bag.lhs +++ b/compiler/utils/Bag.lhs @@ -12,10 +12,13 @@ module Bag ( emptyBag, unitBag, unionBags, unionManyBags, mapBag, elemBag, lengthBag, - filterBag, partitionBag, concatBag, foldBag, foldrBag, foldlBag, + filterBag, partitionBag, partitionBagWith, + concatBag, foldBag, foldrBag, foldlBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, listToBag, bagToList, - mapBagM, mapAndUnzipBagM + foldlBagM, mapBagM, mapBagM_, + flatMapBagM, flatMapBagPairM, + mapAndUnzipBagM ) where #include "Typeable.h" @@ -23,6 +26,7 @@ module Bag ( import Outputable import Util +import MonadUtils import Data.Data import Data.List ( partition ) @@ -115,6 +119,21 @@ partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) where (sats, fails) = partition pred vs +partitionBagWith :: (a -> Either b c) -> Bag a + -> (Bag b {- Left -}, + Bag c {- Right -}) +partitionBagWith _ EmptyBag = (EmptyBag, EmptyBag) +partitionBagWith pred (UnitBag val) + = case pred val of + Left a -> (UnitBag a, EmptyBag) + Right b -> (EmptyBag, UnitBag b) +partitionBagWith pred (TwoBags b1 b2) + = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) + where (sat1, fail1) = partitionBagWith pred b1 + (sat2, fail2) = partitionBagWith pred b2 +partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) + where (sats, fails) = partitionWith pred vs + foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative -> (a -> r) -- Replace UnitBag with this -> r -- Replace EmptyBag with this @@ -152,6 +171,11 @@ foldlBag k z (UnitBag x) = k z x foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2 foldlBag k z (ListBag xs) = foldl k z xs +foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b +foldlBagM _ z EmptyBag = return z +foldlBagM k z (UnitBag x) = k z x +foldlBagM k z (TwoBags b1 b2) = do { z' <- foldlBagM k z b1; foldlBagM k z' b2 } +foldlBagM k z (ListBag xs) = foldlM k z xs mapBag :: (a -> b) -> Bag a -> Bag b mapBag _ EmptyBag = EmptyBag @@ -169,6 +193,33 @@ mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1 mapBagM f (ListBag xs) = do rs <- mapM f xs return (ListBag rs) +mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m () +mapBagM_ _ EmptyBag = return () +mapBagM_ f (UnitBag x) = f x >> return () +mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2 +mapBagM_ f (ListBag xs) = mapM_ f xs + +flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b) +flatMapBagM _ EmptyBag = return EmptyBag +flatMapBagM f (UnitBag x) = f x +flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1 + r2 <- flatMapBagM f b2 + return (r1 `unionBags` r2) +flatMapBagM f (ListBag xs) = foldrM k EmptyBag xs + where + k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) } + +flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c) +flatMapBagPairM _ EmptyBag = return (EmptyBag, EmptyBag) +flatMapBagPairM f (UnitBag x) = f x +flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1 + (r2,s2) <- flatMapBagPairM f b2 + return (r1 `unionBags` r2, s1 `unionBags` s2) +flatMapBagPairM f (ListBag xs) = foldrM k (EmptyBag, EmptyBag) xs + where + k x (r2,s2) = do { (r1,s1) <- f x + ; return (r1 `unionBags` r2, s1 `unionBags` s2) } + mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) mapAndUnzipBagM _ EmptyBag = return (EmptyBag, EmptyBag) mapAndUnzipBagM f (UnitBag x) = do (r,s) <- f x diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index a2bb21572d..2ed39332c6 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -76,7 +76,7 @@ Note [Nodes, keys, vertices] \begin{code} data Graph node = Graph { - gr_int_graph :: IntGraph, + gr_int_graph :: IntGraph, gr_vertex_to_node :: Vertex -> node, gr_node_to_vertex :: node -> Maybe Vertex } diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index c6ba81c225..7a643d7eb4 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -23,7 +23,7 @@ module Outputable ( text, ftext, ptext, int, integer, float, double, rational, parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets, - semi, comma, colon, dcolon, space, equals, dot, arrow, + semi, comma, colon, dcolon, space, equals, dot, arrow, darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, blankLine, (<>), (<+>), hcat, hsep, @@ -404,11 +404,12 @@ quotes d sty = case show pp_d of pp_d = d sty semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc -lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc +darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc blankLine _sty = Pretty.ptext (sLit "") dcolon _sty = Pretty.ptext (sLit "::") arrow _sty = Pretty.ptext (sLit "->") +darrow _sty = Pretty.ptext (sLit "=>") semi _sty = Pretty.semi comma _sty = Pretty.comma colon _sty = Pretty.colon |