{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{- | "GHC.Syb.Utils" provides common utilities for the Ghc Api,
     either based on Data\/Typeable or for use with Data.Generics
     over Ghc Api types.
-}
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

-- | Ghc Ast types tend to have undefined holes, to be filled
--   by later compiler phases. We tag Asts with their source,
--   so that we can avoid such holes based on who generated the Asts.
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)

-- | Like 'everything', but avoid known potholes, based on the 'Stage' that
--   generated the Ast.
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

-- | A variation of 'everything', using a 'GenericQ Bool' to skip
--   parts of the input 'Data'.
--everythingBut :: GenericQ Bool -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
--everythingBut q k z f x
--  | q x       = z
--  | otherwise = foldl k (f x) (gmapQ (everythingBut q k z f) x)


-- Question: how to handle partial results in the otherwise step?
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

-- | Look up a subterm by means of a maybe-typed filter.
somethingStaged :: Stage -> (Maybe u) -> GenericQ (Maybe u) -> GenericQ (Maybe u)

-- "something" can be defined in terms of "everything"
-- when a suitable "choice" operator is used for reduction
--
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


-- | Apply a monadic transformation at least somewhere.
--
-- The transformation is tried in a top-down manner and descends down if it
-- fails to apply at the root of the term.  If the transformation fails to apply
-- anywhere within the the term, the whole operation fails.
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

-- ---------------------------------------------------------------------

{-
-- | Apply a transformation everywhere in bottom-up manner
-- Note type GenericT = forall a. Data a => a -> a
everywhereStaged :: Stage
                    -> (forall a. Data a => a -> a)
                    -> (forall a. Data a => a -> a)

-- Use gmapT to recurse into immediate subterms;
-- recall: gmapT preserves the outermost constructor;
-- post-process recursively transformed result via f
--
everywhereStaged stage f -- = f . gmapT (everywhere f)
  | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) = mzero
  | otherwise = f . gmapT (everywhere stage f)
  where nameSet    = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
        postTcType = const (stage<TypeChecker)                 :: PostTcType -> Bool
        fixity     = const (stage<Renamer)                     :: GHC.Fixity -> Bool
-}


-- | Monadic variation on everywhere
everywhereMStaged :: Monad m => Stage -> GenericM m -> GenericM m

-- Bottom-up order is also reflected in order of do-actions
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