module Language.Haskell.Refact.Utils.GhcUtils (
everythingButStaged
, somethingStaged
, somewhereMStaged
, somewhereMStagedBu
, everywhereMStaged
, everywhereMStaged'
, everywhereStaged
, everywhereStaged'
, listifyStaged
, checkItemRenamer
, full_tdTUGhc
, stop_tdTUGhc
, allTUGhc'
, once_tdTPGhc
, once_buTPGhc
, oneTPGhc
, allTUGhc
, checkItemStage'
, checkItemRenamer'
, zeverywhereStaged
, zopenStaged
, zsomewhereStaged
, transZ
, transZM
, zopenStaged'
, ztransformStagedM
, checkZipperStaged
, upUntil
, findAbove
) where
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import Control.Monad
import Data.Data
import Data.Maybe
import GHC
import NameSet
import Data.Generics.Strafunski.StrategyLib.StrategyLib
import qualified Data.Generics.Zipper as Z
everythingButStaged :: SYB.Stage -> (r -> r -> r) -> r -> SYB.GenericQ (r,Bool) -> SYB.GenericQ r
everythingButStaged stage k z f x
| checkItemStage stage x = z
| stop == True = v
| otherwise = foldl k v (gmapQ (everythingButStaged stage k z f) x)
where (v, stop) = f x
somethingStaged :: SYB.Stage -> (Maybe u) -> SYB.GenericQ (Maybe u) -> SYB.GenericQ (Maybe u)
somethingStaged stage z = everythingStaged stage SYB.orElse z
somewhereMStaged :: MonadPlus m => SYB.Stage -> SYB.GenericM m -> SYB.GenericM m
somewhereMStaged stage f x
| checkItemStage stage x = mzero
| otherwise = f x `mplus` gmapMp (somewhereMStaged stage f) x
somewhereMStagedBu :: MonadPlus m => SYB.Stage -> SYB.GenericM m -> SYB.GenericM m
somewhereMStagedBu stage f x
| checkItemStage stage x = mzero
| otherwise = gmapMp (somewhereMStagedBu stage f) x `mplus` f x
everywhereMStaged :: Monad m => SYB.Stage -> SYB.GenericM m -> SYB.GenericM m
everywhereMStaged stage f x
| checkItemStage stage x = return x
| otherwise = do x' <- gmapM (everywhereMStaged stage f) x
f x'
everywhereMStaged' :: Monad m => SYB.Stage -> SYB.GenericM m -> SYB.GenericM m
everywhereMStaged' stage f x
| checkItemStage stage x = return x
| otherwise = do x' <- f x
gmapM (everywhereMStaged' stage f) x'
everywhereStaged :: SYB.Stage -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhereStaged stage f x
| checkItemStage stage x = x
| otherwise = (f . gmapT (everywhereStaged stage f)) x
everywhereStaged' :: SYB.Stage -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhereStaged' stage f x
| checkItemStage stage x = x
| otherwise = (gmapT (everywhereStaged stage f) . f) x
checkItemStage :: Typeable a => SYB.Stage -> a -> Bool
checkItemStage stage x = (const False `SYB.extQ` postTcType `SYB.extQ` fixity `SYB.extQ` nameSet) x
where nameSet = const (stage `elem` [SYB.Parser,SYB.TypeChecker]) :: NameSet -> Bool
postTcType = const (stage < SYB.TypeChecker ) :: GHC.PostTcType -> Bool
fixity = const (stage < SYB.Renamer ) :: GHC.Fixity -> Bool
checkItemRenamer :: Typeable a => a -> Bool
checkItemRenamer x = checkItemStage SYB.Renamer x
everythingStaged :: SYB.Stage -> (r -> r -> r) -> r -> SYB.GenericQ r -> SYB.GenericQ r
everythingStaged stage k z f x
| checkItemStage stage x = z
| otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x)
listifyStaged
:: (Data a, Typeable a1) => SYB.Stage -> (a1 -> Bool) -> a -> [a1]
listifyStaged stage p = everythingStaged stage (++) [] ([] `SYB.mkQ` (\x -> [ x | p x ]))
full_tdTUGhc :: (MonadPlus m, Monoid a) => TU a m -> TU a m
full_tdTUGhc s = op2TU mappend s (allTUGhc' (full_tdTUGhc s))
stop_tdTUGhc :: (MonadPlus m, Monoid a) => TU a m -> TU a m
stop_tdTUGhc s = (s `choiceTU` (allTUGhc' (stop_tdTUGhc s)))
allTUGhc' :: (MonadPlus m, Monoid a) => TU a m -> TU a m
allTUGhc' = allTUGhc mappend mempty
once_tdTPGhc :: MonadPlus m => TP m -> TP m
once_tdTPGhc s = s `choiceTP` (oneTPGhc (once_tdTPGhc s))
once_buTPGhc :: MonadPlus m => TP m -> TP m
once_buTPGhc s = (oneTPGhc (once_buTPGhc s)) `choiceTP` s
oneTPGhc :: MonadPlus m => TP m -> TP m
oneTPGhc s = ifTP checkItemRenamer' (const failTP) (oneTP s)
allTUGhc :: (MonadPlus m) => (a -> a -> a) -> a -> TU a m -> TU a m
allTUGhc op2 u s = ifTU checkItemRenamer' (const $ constTU u) (allTU op2 u s)
checkItemStage' :: forall m. (MonadPlus m) => SYB.Stage -> TU () m
checkItemStage' stage = failTU `adhocTU` postTcType `adhocTU` fixity `adhocTU` nameSet
where nameSet = const (guard $ stage `elem` [SYB.Parser,SYB.TypeChecker]) :: NameSet -> m ()
postTcType = const (guard $ stage<SYB.TypeChecker) :: GHC.PostTcType -> m ()
fixity = const (guard $ stage<SYB.Renamer) :: GHC.Fixity -> m ()
checkItemRenamer' :: (MonadPlus m) => TU () m
checkItemRenamer' = checkItemStage' SYB.Renamer
zeverywhereStaged :: (Typeable a) => SYB.Stage -> SYB.GenericT -> Z.Zipper a -> Z.Zipper a
zeverywhereStaged stage f z
| checkZipperStaged stage z = z
| otherwise = Z.trans f (Z.downT g z)
where
g z' = Z.leftT g (zeverywhereStaged stage f z')
zopenStaged :: (Typeable a) => SYB.Stage -> SYB.GenericQ Bool -> Z.Zipper a -> [Z.Zipper a]
zopenStaged stage q z
| checkZipperStaged stage z = []
| Z.query q z = [z]
| otherwise = reverse $ Z.downQ [] g z
where
g z' = (zopenStaged stage q z') ++ (Z.leftQ [] g z')
zsomewhereStaged :: (MonadPlus m) => SYB.Stage -> SYB.GenericM m -> Z.Zipper a -> m (Z.Zipper a)
zsomewhereStaged stage f z
| checkZipperStaged stage z = return z
| otherwise = Z.transM f z `mplus` Z.downM mzero (g . Z.leftmost) z
where
g z' = Z.transM f z `mplus` Z.rightM mzero (zsomewhereStaged stage f) z'
transZ :: SYB.Stage -> SYB.GenericQ Bool -> (SYB.Stage -> Z.Zipper a -> Z.Zipper a) -> Z.Zipper a -> Z.Zipper a
transZ stage q t z
| Z.query q z = t stage z
| otherwise = z
transZM :: Monad m
=> SYB.Stage
-> SYB.GenericQ Bool
-> (SYB.Stage -> Z.Zipper a -> m (Z.Zipper a))
-> Z.Zipper a
-> m (Z.Zipper a)
transZM stage q t z
| Z.query q z = t stage z
| otherwise = return z
checkZipperStaged :: SYB.Stage -> Z.Zipper a -> Bool
checkZipperStaged stage z
| isJust maybeNameSet = checkItemStage stage (fromJust maybeNameSet)
| isJust maybePostTcType = checkItemStage stage (fromJust maybePostTcType)
| isJust maybeFixity = checkItemStage stage (fromJust maybeFixity)
| otherwise = False
where
maybeNameSet :: Maybe NameSet
maybeNameSet = Z.getHole z
maybePostTcType :: Maybe PostTcType
maybePostTcType = Z.getHole z
maybeFixity :: Maybe GHC.Fixity
maybeFixity = Z.getHole z
upUntil :: SYB.GenericQ Bool -> Z.Zipper a -> Maybe (Z.Zipper a)
upUntil q z
| Z.query q z = Just z
| otherwise = Z.upQ Nothing (upUntil q) z
findAbove :: (Data a) => (a -> Bool) -> Z.Zipper a -> Maybe a
findAbove cond z = do
zu <- upUntil (False `SYB.mkQ` cond) z
res <- (Z.getHole zu)
return res
zopenStaged' :: (Typeable a)
=> SYB.Stage
-> SYB.GenericQ (Maybe b)
-> Z.Zipper a
-> [(Z.Zipper a,b)]
zopenStaged' stage q z
| checkZipperStaged stage z = []
| isJust zq = [(z,fromJust zq)]
| otherwise = reverse $ Z.downQ [] g z
where
g z' = (zopenStaged' stage q z') ++ (Z.leftQ [] g z')
zq = Z.query q z
ztransformStagedM :: (Typeable a,Monad m)
=> SYB.Stage
-> SYB.GenericQ (Maybe (SYB.Stage -> Z.Zipper a -> m (Z.Zipper a)))
-> Z.Zipper a
-> m (Z.Zipper a)
ztransformStagedM stage q z = do
let zs = zopenStaged' stage q z
z' <- case zs of
[(zz,t)] -> t stage zz
_ -> return z
return z'