utils/ext-core/Language/Core/Utils.hs

   1 module Language.Core.Utils
   2          (everywhereExcept, everywhereExceptM, noNames, notNull,
   3              expectJust, fixedPointBy, applyPasses, varsIn, dupsBy,
   4              everywhere'Except, everywhere'But, wordsBy) where
   5
   6 import Data.Generics
   7 import Data.List
   8 import Data.Maybe
   9 import qualified Data.Set as S
  10
  11 everywhereExcept :: Data a => GenericT -> a -> a
  12 everywhereExcept = everywhereBut (mkQ False (\ (_::String) -> True))
  13
  14 everywhere'Except :: Data a => GenericT -> a -> a
  15 everywhere'Except = everywhere'But (mkQ False (\ (_::String) -> True))
  16
  17 everywhereExceptM :: (Data a, Monad m) => GenericM m -> a -> m a
  18 everywhereExceptM = everywhereButM (mkQ False (\ (_::String) -> True))
  19
  20
  21 noNames :: Data a => r -> (r -> r -> r) -> GenericQ r -> a -> r
  22 noNames e c = everythingBut e c (mkQ False (\ (_::String) -> True))
  23
  24 everythingBut :: r -> (r -> r -> r) -> GenericQ Bool
  25               -> GenericQ r -> GenericQ r
  26 everythingBut empty combine q q1 x
  27   | q x         = empty
  28   | otherwise   = q1 x `combine`
  29      (foldl' combine empty
  30        (gmapQ (everythingBut empty combine q q1) x))
  31
  32 everywhere'But :: GenericQ Bool -> GenericT -> GenericT
  33 -- Guarded to let traversal cease if predicate q holds for x
  34 everywhere'But q f x
  35     | q x       = x
  36     | otherwise = let top = f x in
  37                     top `seq` (gmapT (everywhere'But q f) top)
  38
  39 everywhereButM :: Monad m => GenericQ Bool -> GenericM m -> GenericM m
  40 everywhereButM q f x
  41     | q x       = return x
  42     | otherwise = (gmapM (everywhereButM q f) x) >>= f
  43
  44 notNull :: [a] -> Bool
  45 notNull = not . null
  46
  47 expectJust :: String -> Maybe a -> a
  48 expectJust s = fromMaybe (error s)
  49
  50 fixedPointBy :: (a -> a -> Bool) -> (a -> a) -> a -> a
  51 fixedPointBy done trans start = go start
  52   where go v =
  53           let next = trans v in
  54            if done v next then
  55              next
  56            else
  57              go next
  58
  59 applyPasses :: [a -> a] -> a -> a
  60 applyPasses passes p = -- trace ("p = " ++ show p) $
  61   foldl' (\ p' nextF -> nextF p') p passes
  62
  63 varsIn :: (Ord b, Typeable b, Data a) => a -> S.Set b
  64 varsIn = noNames S.empty S.union
  65            (mkQ S.empty (\ v -> S.singleton v))
  66
  67 dupsBy :: (a -> a -> Bool) -> [a] -> [a]
  68 dupsBy (~=) xs = filter (\ x -> length (filter (~= x) xs) > 1) xs
  69
  70 wordsBy :: Eq a => a -> [a] -> [[a]]
  71 wordsBy _ []              = [[]]
  72 wordsBy y (x:xs) | y == x = [x]:(wordsBy y xs)
  73 wordsBy y (x:xs)          =
  74   case wordsBy y xs of
  75     (z:zs) -> (x:z):zs
  76     []     -> [[y]]