{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
module GHC.SYB.Utils where
import Data.Generics
import PprTyThing()
import GHC hiding (moduleName)
import SrcLoc()
#if __GLASGOW_HASKELL__ >= 802
import NameSet(NameSet)
#elif __GLASGOW_HASKELL__ >= 709
import NameSet(NameSet)
#endif
import Control.Monad
data Stage = Parser | Renamer | TypeChecker deriving (Stage -> Stage -> Bool
(Stage -> Stage -> Bool) -> (Stage -> Stage -> Bool) -> Eq Stage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stage -> Stage -> Bool
$c/= :: Stage -> Stage -> Bool
== :: Stage -> Stage -> Bool
$c== :: Stage -> Stage -> Bool
Eq,Eq Stage
Eq Stage =>
(Stage -> Stage -> Ordering)
-> (Stage -> Stage -> Bool)
-> (Stage -> Stage -> Bool)
-> (Stage -> Stage -> Bool)
-> (Stage -> Stage -> Bool)
-> (Stage -> Stage -> Stage)
-> (Stage -> Stage -> Stage)
-> Ord Stage
Stage -> Stage -> Bool
Stage -> Stage -> Ordering
Stage -> Stage -> Stage
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Stage -> Stage -> Stage
$cmin :: Stage -> Stage -> Stage
max :: Stage -> Stage -> Stage
$cmax :: Stage -> Stage -> Stage
>= :: Stage -> Stage -> Bool
$c>= :: Stage -> Stage -> Bool
> :: Stage -> Stage -> Bool
$c> :: Stage -> Stage -> Bool
<= :: Stage -> Stage -> Bool
$c<= :: Stage -> Stage -> Bool
< :: Stage -> Stage -> Bool
$c< :: Stage -> Stage -> Bool
compare :: Stage -> Stage -> Ordering
$ccompare :: Stage -> Stage -> Ordering
$cp1Ord :: Eq Stage
Ord,Int -> Stage -> ShowS
[Stage] -> ShowS
Stage -> String
(Int -> Stage -> ShowS)
-> (Stage -> String) -> ([Stage] -> ShowS) -> Show Stage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stage] -> ShowS
$cshowList :: [Stage] -> ShowS
show :: Stage -> String
$cshow :: Stage -> String
showsPrec :: Int -> Stage -> ShowS
$cshowsPrec :: Int -> Stage -> ShowS
Show)
everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingStaged stage :: Stage
stage k :: r -> r -> r
k z :: r
z f :: GenericQ r
f x :: a
x
| (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
False
(a -> Bool) -> (Fixity -> Bool) -> a -> Bool
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Fixity -> Bool
fixity (a -> Bool) -> (NameSet -> Bool) -> a -> Bool
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` NameSet -> Bool
nameSet) a
x = r
z
| Bool
otherwise = (r -> r -> r) -> r -> [r] -> r
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl r -> r -> r
k (a -> r
GenericQ r
f a
x) (GenericQ r -> a -> [r]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ (Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
forall r. Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingStaged Stage
stage r -> r -> r
k r
z GenericQ r
f) a
x)
where nameSet :: NameSet -> Bool
nameSet = Bool -> NameSet -> Bool
forall a b. a -> b -> a
const (Stage
stage Stage -> [Stage] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Stage
Parser,Stage
TypeChecker]) :: NameSet -> Bool
fixity :: Fixity -> Bool
fixity = Bool -> Fixity -> Bool
forall a b. a -> b -> a
const (Stage
stageStage -> Stage -> Bool
forall a. Ord a => a -> a -> Bool
<Stage
Renamer) :: GHC.Fixity -> Bool
everythingButStaged :: Stage -> (r -> r -> r) -> r -> GenericQ (r,Bool) -> GenericQ r
everythingButStaged :: Stage -> (r -> r -> r) -> r -> GenericQ (r, Bool) -> GenericQ r
everythingButStaged stage :: Stage
stage k :: r -> r -> r
k z :: r
z f :: GenericQ (r, Bool)
f x :: a
x
| (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
False
(a -> Bool) -> (Fixity -> Bool) -> a -> Bool
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Fixity -> Bool
fixity (a -> Bool) -> (NameSet -> Bool) -> a -> Bool
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` NameSet -> Bool
nameSet) a
x = r
z
| Bool
stop Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True = r
v
| Bool
otherwise = (r -> r -> r) -> r -> [r] -> r
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl r -> r -> r
k r
v (GenericQ r -> a -> [r]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ (Stage -> (r -> r -> r) -> r -> GenericQ (r, Bool) -> GenericQ r
forall r.
Stage -> (r -> r -> r) -> r -> GenericQ (r, Bool) -> GenericQ r
everythingButStaged Stage
stage r -> r -> r
k r
z GenericQ (r, Bool)
f) a
x)
where (v :: r
v, stop :: Bool
stop) = a -> (r, Bool)
GenericQ (r, Bool)
f a
x
nameSet :: NameSet -> Bool
nameSet = Bool -> NameSet -> Bool
forall a b. a -> b -> a
const (Stage
stage Stage -> [Stage] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Stage
Parser,Stage
TypeChecker]) :: NameSet -> Bool
fixity :: Fixity -> Bool
fixity = Bool -> Fixity -> Bool
forall a b. a -> b -> a
const (Stage
stageStage -> Stage -> Bool
forall a. Ord a => a -> a -> Bool
<Stage
Renamer) :: GHC.Fixity -> Bool
somethingStaged :: Stage -> (Maybe u) -> GenericQ (Maybe u) -> GenericQ (Maybe u)
somethingStaged :: Stage -> Maybe u -> GenericQ (Maybe u) -> GenericQ (Maybe u)
somethingStaged stage :: Stage
stage z :: Maybe u
z = Stage
-> (Maybe u -> Maybe u -> Maybe u)
-> Maybe u
-> GenericQ (Maybe u)
-> GenericQ (Maybe u)
forall r. Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingStaged Stage
stage Maybe u -> Maybe u -> Maybe u
forall a. Maybe a -> Maybe a -> Maybe a
orElse Maybe u
z
somewhereStaged :: MonadPlus m => Stage -> GenericM m -> GenericM m
somewhereStaged :: Stage -> GenericM m -> GenericM m
somewhereStaged stage :: Stage
stage f :: GenericM m
f x :: a
x
| (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
False
(a -> Bool) -> (Fixity -> Bool) -> a -> Bool
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Fixity -> Bool
fixity (a -> Bool) -> (NameSet -> Bool) -> a -> Bool
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` NameSet -> Bool
nameSet) a
x = m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
| Bool
otherwise = a -> m a
GenericM m
f a
x m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` GenericM m -> a -> m a
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapMp (Stage -> GenericM m -> GenericM m
forall (m :: * -> *).
MonadPlus m =>
Stage -> GenericM m -> GenericM m
somewhereStaged Stage
stage GenericM m
f) a
x
where nameSet :: NameSet -> Bool
nameSet = Bool -> NameSet -> Bool
forall a b. a -> b -> a
const (Stage
stage Stage -> [Stage] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Stage
Parser,Stage
TypeChecker]) :: NameSet -> Bool
fixity :: Fixity -> Bool
fixity = Bool -> Fixity -> Bool
forall a b. a -> b -> a
const (Stage
stageStage -> Stage -> Bool
forall a. Ord a => a -> a -> Bool
<Stage
Renamer) :: GHC.Fixity -> Bool
everywhereMStaged :: Monad m => Stage -> GenericM m -> GenericM m
everywhereMStaged :: Stage -> GenericM m -> GenericM m
everywhereMStaged stage :: Stage
stage f :: GenericM m
f x :: a
x
| (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
False
(a -> Bool) -> (Fixity -> Bool) -> a -> Bool
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Fixity -> Bool
fixity (a -> Bool) -> (NameSet -> Bool) -> a -> Bool
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` NameSet -> Bool
nameSet) a
x = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
| Bool
otherwise = do a
x' <- GenericM m -> a -> m a
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapM (Stage -> GenericM m -> GenericM m
forall (m :: * -> *). Monad m => Stage -> GenericM m -> GenericM m
everywhereMStaged Stage
stage GenericM m
f) a
x
a -> m a
GenericM m
f a
x'
where nameSet :: NameSet -> Bool
nameSet = Bool -> NameSet -> Bool
forall a b. a -> b -> a
const (Stage
stage Stage -> [Stage] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Stage
Parser,Stage
TypeChecker]) :: NameSet -> Bool
fixity :: Fixity -> Bool
fixity = Bool -> Fixity -> Bool
forall a b. a -> b -> a
const (Stage
stageStage -> Stage -> Bool
forall a. Ord a => a -> a -> Bool
<Stage
Renamer) :: GHC.Fixity -> Bool