1 files changed, 30 insertions, 0 deletions
diff --git a/src/tools/c/GFCC/ComposOp.hs b/src/tools/c/GFCC/ComposOp.hs
new file mode 100644
index 000000000..401c1d778
--- /dev/null
+++ b/src/tools/c/GFCC/ComposOp.hs
@@ -0,0 +1,30 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module GFCC.ComposOp (Compos(..),composOp,composOpM,composOpM_,composOpMonoid,
+                 composOpMPlus,composOpFold) where
+
+import Control.Monad.Identity
+import Data.Monoid
+
+class Compos t where
+  compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)
+         -> (forall a. t a -> m (t a)) -> t c -> m (t c)
+
+composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c
+composOp f = runIdentity . composOpM (Identity . f)
+
+composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)
+composOpM = compos return ap
+
+composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()
+composOpM_ = composOpFold (return ()) (>>)
+
+composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m
+composOpMonoid = composOpFold mempty mappend
+
+composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b
+composOpMPlus = composOpFold mzero mplus
+
+composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b
+composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)
+
+newtype C b a = C { unC :: b }