ext-core library: Add code for merging multiple Core modules into a single module

[ghc-hetmet.git] / utils / ext-core / Language / Core / Utils.hs

diff --git a/utils/ext-core/Language/Core/Utils.hs b/utils/ext-core/Language/Core/Utils.hs
new file mode 100644 (file)
index 0000000..3ffabf2
--- /dev/null
+++ b/utils/ext-core/Language/Core/Utils.hs
@@ -0,0 +1,76 @@
+module Language.Core.Utils
+         (everywhereExcept, everywhereExceptM, noNames, notNull,
+             expectJust, fixedPointBy, applyPasses, varsIn, dupsBy,
+             everywhere'Except, everywhere'But, wordsBy) where
+
+import Data.Generics
+import Data.List
+import Data.Maybe
+import qualified Data.Set as S
+
+everywhereExcept :: Data a => GenericT -> a -> a
+everywhereExcept = everywhereBut (mkQ False (\ (_::String) -> True))
+
+everywhere'Except :: Data a => GenericT -> a -> a
+everywhere'Except = everywhere'But (mkQ False (\ (_::String) -> True))
+
+everywhereExceptM :: (Data a, Monad m) => GenericM m -> a -> m a
+everywhereExceptM = everywhereButM (mkQ False (\ (_::String) -> True))
+
+
+noNames :: Data a => r -> (r -> r -> r) -> GenericQ r -> a -> r
+noNames e c = everythingBut e c (mkQ False (\ (_::String) -> True))
+
+everythingBut :: r -> (r -> r -> r) -> GenericQ Bool
+              -> GenericQ r -> GenericQ r
+everythingBut empty combine q q1 x
+  | q x         = empty
+  | otherwise   = q1 x `combine` 
+     (foldl' combine empty
+       (gmapQ (everythingBut empty combine q q1) x))
+
+everywhere'But :: GenericQ Bool -> GenericT -> GenericT
+-- Guarded to let traversal cease if predicate q holds for x
+everywhere'But q f x
+    | q x       = x
+    | otherwise = let top = gmapT f x in
+                    top `seq` (gmapT (everywhere'But q f) top)
+
+everywhereButM :: Monad m => GenericQ Bool -> GenericM m -> GenericM m
+everywhereButM q f x
+    | q x       = return x
+    | otherwise = (gmapM (everywhereButM q f) x) >>= f
+
+notNull :: [a] -> Bool
+notNull = not . null
+
+expectJust :: String -> Maybe a -> a
+expectJust s = fromMaybe (error s)
+
+fixedPointBy :: (a -> a -> Bool) -> (a -> a) -> a -> a
+fixedPointBy done trans start = go start
+  where go v = 
+          let next = trans v in
+           if done v next then
+             next
+           else
+             go next
+
+applyPasses :: [a -> a] -> a -> a
+applyPasses passes p = -- trace ("p = " ++ show p) $ 
+  foldl' (\ p' nextF -> nextF p') p passes
+
+varsIn :: (Ord b, Typeable b, Data a) => a -> S.Set b
+varsIn = noNames S.empty S.union 
+           (mkQ S.empty (\ v -> S.singleton v))
+
+dupsBy :: (a -> a -> Bool) -> [a] -> [a]
+dupsBy (~=) xs = filter (\ x -> length (filter (~= x) xs) > 1) xs
+
+wordsBy :: Eq a => a -> [a] -> [[a]]
+wordsBy _ []              = [[]]
+wordsBy y (x:xs) | y == x = [x]:(wordsBy y xs)
+wordsBy y (x:xs)          = 
+  case wordsBy y xs of
+    (z:zs) -> (x:z):zs
+    []     -> [[y]]