{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
module Graph.Trace.Internal.Predicates
  ( removeConstraints
  , addConstraintToSig
  ) where

import           Control.Monad.Trans.Writer.CPS
import qualified Data.Generics as Syb
import qualified Data.List as L
import qualified Data.Map.Strict as M
import           Data.Maybe
import qualified Data.Set as S

import qualified Graph.Trace.Internal.GhcFacade as Ghc
import           Graph.Trace.Internal.Types

-- | Removes debug predicates from the type signatures in an expression.
-- This is necessary if there are type signatures for pattern bound names and
-- the monomorphism restriction is on.
removeConstraints :: Syb.Data a => DebugNames -> S.Set Ghc.Name -> a -> a
removeConstraints :: DebugNames -> Set Name -> a -> a
removeConstraints DebugNames
debugNames Set Name
targetNames a
thing
  | Set Name -> Bool
forall a. Set a -> Bool
S.null Set Name
targetNames = a
thing
  | Bool
otherwise = (HsValBinds GhcRn -> HsValBinds GhcRn) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
Syb.mkT HsValBinds GhcRn -> HsValBinds GhcRn
processBind (forall a. Data a => a -> a) -> a -> a
(forall a. Data a => a -> a) -> forall a. Data a => a -> a
`Syb.everywhere` a
thing
  where
    processBind :: Ghc.HsValBinds Ghc.GhcRn -> Ghc.HsValBinds Ghc.GhcRn
    processBind :: HsValBinds GhcRn -> HsValBinds GhcRn
processBind (Ghc.XValBindsLR (Ghc.NValBinds binds sigs)) =
      XXValBindsLR GhcRn GhcRn -> HsValBinds GhcRn
forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
Ghc.XValBindsLR ([(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> NHsValBindsLR GhcRn
forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
Ghc.NValBinds [(RecFlag, LHsBinds GhcRn)]
binds ((LSig GhcRn -> [LSig GhcRn]) -> [LSig GhcRn] -> [LSig GhcRn]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LSig GhcRn -> [LSig GhcRn]
removeConstraint [LSig GhcRn]
sigs))
    processBind HsValBinds GhcRn
binds = HsValBinds GhcRn
binds
    removeConstraint :: LSig GhcRn -> [LSig GhcRn]
removeConstraint (Ghc.L SrcSpan
loc (Ghc.TypeSig XTypeSig GhcRn
x1 [Located (IdP GhcRn)]
names LHsSigWcType GhcRn
sig)) =
      let ([Located Name]
targeted, [Located Name]
inert) =
            (Located Name -> Bool)
-> [Located Name] -> ([Located Name], [Located Name])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition ((Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
targetNames) (Name -> Bool) -> (Located Name -> Name) -> Located Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc) [Located (IdP GhcRn)]
[Located Name]
names
       in [ Sig GhcRn -> LSig GhcRn
forall a. a -> Located a
Ghc.noLocA' (Sig GhcRn -> LSig GhcRn)
-> (LHsSigWcType GhcRn -> Sig GhcRn)
-> LHsSigWcType GhcRn
-> LSig GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTypeSig GhcRn
-> [Located (IdP GhcRn)] -> LHsSigWcType GhcRn -> Sig GhcRn
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
Ghc.TypeSig XTypeSig GhcRn
x1 [Located (IdP GhcRn)]
[Located Name]
targeted
              (LHsSigWcType GhcRn -> LSig GhcRn)
-> LHsSigWcType GhcRn -> LSig GhcRn
forall a b. (a -> b) -> a -> b
$ (HsType GhcRn -> HsType GhcRn) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
Syb.mkT HsType GhcRn -> HsType GhcRn
removePred (forall a. Data a => a -> a)
-> LHsSigWcType GhcRn -> LHsSigWcType GhcRn
(forall a. Data a => a -> a) -> forall a. Data a => a -> a
`Syb.everywhere` LHsSigWcType GhcRn
sig
          , SrcSpan -> Sig GhcRn -> LSig GhcRn
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
loc (Sig GhcRn -> LSig GhcRn) -> Sig GhcRn -> LSig GhcRn
forall a b. (a -> b) -> a -> b
$ XTypeSig GhcRn
-> [Located (IdP GhcRn)] -> LHsSigWcType GhcRn -> Sig GhcRn
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
Ghc.TypeSig XTypeSig GhcRn
x1 [Located (IdP GhcRn)]
[Located Name]
inert LHsSigWcType GhcRn
sig
          ]
    removeConstraint LSig GhcRn
s = [LSig GhcRn
s]
    removePred :: HsType GhcRn -> HsType GhcRn
removePred (Ghc.HsQualTy' XQualTy GhcRn
x Maybe (LHsContext GhcRn)
ctx LHsType GhcRn
body) =
      let newCtx :: Maybe (LHsContext GhcRn)
newCtx = ((LHsContext GhcRn -> LHsContext GhcRn)
-> Maybe (LHsContext GhcRn) -> Maybe (LHsContext GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LHsContext GhcRn -> LHsContext GhcRn)
 -> Maybe (LHsContext GhcRn) -> Maybe (LHsContext GhcRn))
-> (([LHsType GhcRn] -> [LHsType GhcRn])
    -> LHsContext GhcRn -> LHsContext GhcRn)
-> ([LHsType GhcRn] -> [LHsType GhcRn])
-> Maybe (LHsContext GhcRn)
-> Maybe (LHsContext GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([LHsType GhcRn] -> [LHsType GhcRn])
-> LHsContext GhcRn -> LHsContext GhcRn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ((LHsType GhcRn -> Bool) -> [LHsType GhcRn] -> [LHsType GhcRn]
forall a. (a -> Bool) -> [a] -> [a]
filter (HsType GhcRn -> Bool
notDebugPred (HsType GhcRn -> Bool)
-> (LHsType GhcRn -> HsType GhcRn) -> LHsType GhcRn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcRn -> HsType GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc)) Maybe (LHsContext GhcRn)
ctx
       in XQualTy GhcRn
-> Maybe (LHsContext GhcRn) -> LHsType GhcRn -> HsType GhcRn
Ghc.HsQualTy' XQualTy GhcRn
x Maybe (LHsContext GhcRn)
newCtx LHsType GhcRn
body
    removePred HsType GhcRn
x = HsType GhcRn
x
    notDebugPred :: HsType GhcRn -> Bool
notDebugPred = Maybe (Maybe FastString, Propagation) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (Maybe FastString, Propagation) -> Bool)
-> (HsType GhcRn -> Maybe (Maybe FastString, Propagation))
-> HsType GhcRn
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugNames -> HsType GhcRn -> Maybe (Maybe FastString, Propagation)
checkForDebugPred DebugNames
debugNames

-- | Matches on type signatures in order to add the constraint to them.
addConstraintToSig
  :: DebugNames
  -> Bool -- True <=> Debug all functions
  -> Ghc.Sig Ghc.GhcRn
  -> Writer (M.Map Ghc.Name (Maybe Ghc.FastString, Propagation))
            (Ghc.Sig Ghc.GhcRn)
addConstraintToSig :: DebugNames
-> Bool
-> Sig GhcRn
-> Writer (Map Name (Maybe FastString, Propagation)) (Sig GhcRn)
addConstraintToSig DebugNames
debugNames Bool
debugAllFlag
  (Ghc.TypeSig XTypeSig GhcRn
x1 [Located (IdP GhcRn)]
lNames (Ghc.HsWC XHsWC GhcRn (LHsSigType GhcRn)
x2 LHsSigType GhcRn
sig)) = do
    LHsSigType GhcRn
sig' <- DebugNames
-> Bool
-> [Name]
-> LHsSigType GhcRn
-> Writer
     (Map Name (Maybe FastString, Propagation)) (LHsSigType GhcRn)
addConstraintToSigType DebugNames
debugNames Bool
debugAllFlag (Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc (Located Name -> Name) -> [Located Name] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located (IdP GhcRn)]
[Located Name]
lNames) LHsSigType GhcRn
sig
    Sig GhcRn
-> Writer (Map Name (Maybe FastString, Propagation)) (Sig GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sig GhcRn
 -> Writer (Map Name (Maybe FastString, Propagation)) (Sig GhcRn))
-> Sig GhcRn
-> Writer (Map Name (Maybe FastString, Propagation)) (Sig GhcRn)
forall a b. (a -> b) -> a -> b
$ XTypeSig GhcRn
-> [Located (IdP GhcRn)] -> LHsSigWcType GhcRn -> Sig GhcRn
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
Ghc.TypeSig XTypeSig GhcRn
x1 [Located (IdP GhcRn)]
lNames (XHsWC GhcRn (LHsSigType GhcRn)
-> LHsSigType GhcRn -> LHsSigWcType GhcRn
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
Ghc.HsWC XHsWC GhcRn (LHsSigType GhcRn)
x2 LHsSigType GhcRn
sig')
addConstraintToSig DebugNames
debugNames Bool
debugAllFlag
  (Ghc.ClassOpSig XClassOpSig GhcRn
x1 Bool
b [Located (IdP GhcRn)]
lNames LHsSigType GhcRn
sig) = do
    LHsSigType GhcRn
sig' <- DebugNames
-> Bool
-> [Name]
-> LHsSigType GhcRn
-> Writer
     (Map Name (Maybe FastString, Propagation)) (LHsSigType GhcRn)
addConstraintToSigType DebugNames
debugNames Bool
debugAllFlag (Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc (Located Name -> Name) -> [Located Name] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located (IdP GhcRn)]
[Located Name]
lNames) LHsSigType GhcRn
sig
    Sig GhcRn
-> Writer (Map Name (Maybe FastString, Propagation)) (Sig GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sig GhcRn
 -> Writer (Map Name (Maybe FastString, Propagation)) (Sig GhcRn))
-> Sig GhcRn
-> Writer (Map Name (Maybe FastString, Propagation)) (Sig GhcRn)
forall a b. (a -> b) -> a -> b
$ XClassOpSig GhcRn
-> Bool -> [Located (IdP GhcRn)] -> LHsSigType GhcRn -> Sig GhcRn
forall pass.
XClassOpSig pass
-> Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
Ghc.ClassOpSig XClassOpSig GhcRn
x1 Bool
b [Located (IdP GhcRn)]
lNames LHsSigType GhcRn
sig'
addConstraintToSig DebugNames
_ Bool
_ Sig GhcRn
s = Sig GhcRn
-> Writer (Map Name (Maybe FastString, Propagation)) (Sig GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sig GhcRn
s

-- | Adds the 'Debug' constraint to a signature if it doesn't already have it
-- as the first constraint in the context.
addConstraintToSigType
  :: DebugNames
  -> Bool -- True <=> Debug all functions
  -> [Ghc.Name]
  -> Ghc.LHsSigType Ghc.GhcRn
  -> Writer (M.Map Ghc.Name (Maybe Ghc.FastString, Propagation))
            (Ghc.LHsSigType Ghc.GhcRn)
addConstraintToSigType :: DebugNames
-> Bool
-> [Name]
-> LHsSigType GhcRn
-> Writer
     (Map Name (Maybe FastString, Propagation)) (LHsSigType GhcRn)
addConstraintToSigType DebugNames
debugNames Bool
debugAllFlag [Name]
names sig :: LHsSigType GhcRn
sig@(Ghc.HsSig' LHsType GhcRn
t) = do
  LHsType GhcRn
sigBody <- (HsType GhcRn
 -> WriterT
      (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn))
-> LHsType GhcRn
-> WriterT
     (Map Name (Maybe FastString, Propagation)) Identity (LHsType GhcRn)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse HsType GhcRn
-> WriterT
     (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn)
go LHsType GhcRn
t
  LHsSigType GhcRn
-> Writer
     (Map Name (Maybe FastString, Propagation)) (LHsSigType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsSigType GhcRn
 -> Writer
      (Map Name (Maybe FastString, Propagation)) (LHsSigType GhcRn))
-> LHsSigType GhcRn
-> Writer
     (Map Name (Maybe FastString, Propagation)) (LHsSigType GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> LHsSigType GhcRn -> LHsSigType GhcRn
Ghc.setSigBody LHsType GhcRn
sigBody LHsSigType GhcRn
sig
    where
      prop :: Propagation
prop = if Bool
debugAllFlag then Propagation
Shallow else Propagation
Inert
      predName :: Name
predName =
        if Bool
debugAllFlag
           then DebugNames -> Name
tracePredName DebugNames
debugNames
           else DebugNames -> Name
traceInertPredName DebugNames
debugNames
      predTy :: LHsType GhcRn
predTy = HsType GhcRn -> LHsType GhcRn
forall a. a -> Located a
Ghc.noLocA'
             (HsType GhcRn -> LHsType GhcRn) -> HsType GhcRn -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XTyVar GhcRn
-> PromotionFlag -> Located (IdP GhcRn) -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
Ghc.HsTyVar NoExtField
XTyVar GhcRn
Ghc.emptyEpAnn PromotionFlag
Ghc.NotPromoted
                 (Name -> Located Name
forall a. a -> Located a
Ghc.noLocA' Name
predName)
      go :: HsType GhcRn
-> WriterT
     (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn)
go HsType GhcRn
ty =
        case HsType GhcRn
ty of
          x :: HsType GhcRn
x@Ghc.HsForAllTy { hst_body :: forall pass. HsType pass -> LHsType pass
Ghc.hst_body = LHsType GhcRn
body } -> do
            LHsType GhcRn
body' <- (HsType GhcRn
 -> WriterT
      (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn))
-> LHsType GhcRn
-> WriterT
     (Map Name (Maybe FastString, Propagation)) Identity (LHsType GhcRn)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse HsType GhcRn
-> WriterT
     (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn)
go LHsType GhcRn
body
            HsType GhcRn
-> WriterT
     (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType GhcRn
 -> WriterT
      (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn))
-> HsType GhcRn
-> WriterT
     (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ HsType GhcRn
x { hst_body :: LHsType GhcRn
Ghc.hst_body = LHsType GhcRn
body' }
          q :: HsType GhcRn
q@(Ghc.HsQualTy' XQualTy GhcRn
x Maybe (LHsContext GhcRn)
ctx LHsType GhcRn
body)
            | (Maybe FastString, Propagation)
foundPred : [(Maybe FastString, Propagation)]
_ <-
                (HsType GhcRn -> Maybe (Maybe FastString, Propagation))
-> [HsType GhcRn] -> [(Maybe FastString, Propagation)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (DebugNames -> HsType GhcRn -> Maybe (Maybe FastString, Propagation)
checkForDebugPred DebugNames
debugNames)
                  (LHsType GhcRn -> HsType GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc (LHsType GhcRn -> HsType GhcRn)
-> [LHsType GhcRn] -> [HsType GhcRn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LHsContext GhcRn -> [LHsType GhcRn])
-> Maybe (LHsContext GhcRn) -> [LHsType GhcRn]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LHsContext GhcRn -> [LHsType GhcRn]
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc Maybe (LHsContext GhcRn)
ctx)
            -- Note that DebugMuted bindings should still be included because
            -- the muted status needs to be inherited by the functions called from it
            -> do Map Name (Maybe FastString, Propagation)
-> WriterT (Map Name (Maybe FastString, Propagation)) Identity ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell ([(Name, (Maybe FastString, Propagation))]
-> Map Name (Maybe FastString, Propagation)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, (Maybe FastString, Propagation))]
 -> Map Name (Maybe FastString, Propagation))
-> [(Name, (Maybe FastString, Propagation))]
-> Map Name (Maybe FastString, Propagation)
forall a b. (a -> b) -> a -> b
$ [Name]
names [Name]
-> [(Maybe FastString, Propagation)]
-> [(Name, (Maybe FastString, Propagation))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Maybe FastString, Propagation)
-> [(Maybe FastString, Propagation)]
forall a. a -> [a]
repeat (Maybe FastString, Propagation)
foundPred)
                  HsType GhcRn
-> WriterT
     (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsType GhcRn
q
            | Bool
otherwise -> do
                Map Name (Maybe FastString, Propagation)
-> WriterT (Map Name (Maybe FastString, Propagation)) Identity ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell ([(Name, (Maybe FastString, Propagation))]
-> Map Name (Maybe FastString, Propagation)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, (Maybe FastString, Propagation))]
 -> Map Name (Maybe FastString, Propagation))
-> [(Name, (Maybe FastString, Propagation))]
-> Map Name (Maybe FastString, Propagation)
forall a b. (a -> b) -> a -> b
$ [Name]
names [Name]
-> [(Maybe FastString, Propagation)]
-> [(Name, (Maybe FastString, Propagation))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Maybe FastString, Propagation)
-> [(Maybe FastString, Propagation)]
forall a. a -> [a]
repeat (Maybe FastString
forall a. Maybe a
Nothing, Propagation
prop))
                HsType GhcRn
-> WriterT
     (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType GhcRn
 -> WriterT
      (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn))
-> HsType GhcRn
-> WriterT
     (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$
                  XQualTy GhcRn
-> Maybe (LHsContext GhcRn) -> LHsType GhcRn -> HsType GhcRn
Ghc.HsQualTy'
                    XQualTy GhcRn
x
                    (LHsContext GhcRn -> Maybe (LHsContext GhcRn)
forall a. a -> Maybe a
Just (LHsContext GhcRn -> Maybe (LHsContext GhcRn))
-> LHsContext GhcRn -> Maybe (LHsContext GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsContext GhcRn
-> (LHsContext GhcRn -> LHsContext GhcRn)
-> Maybe (LHsContext GhcRn)
-> LHsContext GhcRn
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([LHsType GhcRn] -> LHsContext GhcRn
forall a. a -> Located a
Ghc.noLocA' [LHsType GhcRn
predTy])
                                  (([LHsType GhcRn] -> [LHsType GhcRn])
-> LHsContext GhcRn -> LHsContext GhcRn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LHsType GhcRn
predTy LHsType GhcRn -> [LHsType GhcRn] -> [LHsType GhcRn]
forall a. a -> [a] -> [a]
:))
                                  Maybe (LHsContext GhcRn)
ctx
                    )
                    LHsType GhcRn
body
          HsType GhcRn
_ -> do
              Map Name (Maybe FastString, Propagation)
-> WriterT (Map Name (Maybe FastString, Propagation)) Identity ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell ([(Name, (Maybe FastString, Propagation))]
-> Map Name (Maybe FastString, Propagation)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, (Maybe FastString, Propagation))]
 -> Map Name (Maybe FastString, Propagation))
-> [(Name, (Maybe FastString, Propagation))]
-> Map Name (Maybe FastString, Propagation)
forall a b. (a -> b) -> a -> b
$ [Name]
names [Name]
-> [(Maybe FastString, Propagation)]
-> [(Name, (Maybe FastString, Propagation))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Maybe FastString, Propagation)
-> [(Maybe FastString, Propagation)]
forall a. a -> [a]
repeat (Maybe FastString
forall a. Maybe a
Nothing, Propagation
prop))
              HsType GhcRn
-> WriterT
     (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType GhcRn
 -> WriterT
      (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn))
-> HsType GhcRn
-> WriterT
     (Map Name (Maybe FastString, Propagation)) Identity (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$
                XQualTy GhcRn
-> Maybe (LHsContext GhcRn) -> LHsType GhcRn -> HsType GhcRn
Ghc.HsQualTy'
                  NoExtField
XQualTy GhcRn
Ghc.NoExtField
                  (LHsContext GhcRn -> Maybe (LHsContext GhcRn)
forall a. a -> Maybe a
Just (LHsContext GhcRn -> Maybe (LHsContext GhcRn))
-> LHsContext GhcRn -> Maybe (LHsContext GhcRn)
forall a b. (a -> b) -> a -> b
$ [LHsType GhcRn] -> LHsContext GhcRn
forall a. a -> Located a
Ghc.noLocA' [LHsType GhcRn
predTy])
                  (HsType GhcRn -> LHsType GhcRn
forall a. a -> Located a
Ghc.noLocA' HsType GhcRn
ty)
addConstraintToSigType DebugNames
_ Bool
_ [Name]
_ LHsSigType GhcRn
x = LHsSigType GhcRn
-> Writer
     (Map Name (Maybe FastString, Propagation)) (LHsSigType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsSigType GhcRn
x

-- | Check if a type has a debug predicate in it's context. If so, return the
-- override key if supplied and the propagation strategy.
checkForDebugPred
  :: DebugNames
  -> Ghc.HsType Ghc.GhcRn
  -> Maybe (Maybe Ghc.FastString, Propagation)
checkForDebugPred :: DebugNames -> HsType GhcRn -> Maybe (Maybe FastString, Propagation)
checkForDebugPred DebugNames
debugNames
    (Ghc.HsTyVar XTyVar GhcRn
_ PromotionFlag
_ (Ghc.L SrcSpan
_ IdP GhcRn
name))
  | IdP GhcRn
Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== DebugNames -> Name
tracePredName DebugNames
debugNames = (Maybe FastString, Propagation)
-> Maybe (Maybe FastString, Propagation)
forall a. a -> Maybe a
Just (Maybe FastString
forall a. Maybe a
Nothing, Propagation
Shallow)
  | IdP GhcRn
Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== DebugNames -> Name
traceDeepPredName DebugNames
debugNames = (Maybe FastString, Propagation)
-> Maybe (Maybe FastString, Propagation)
forall a. a -> Maybe a
Just (Maybe FastString
forall a. Maybe a
Nothing, Propagation
Deep)
  | IdP GhcRn
Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== DebugNames -> Name
traceMutePredName DebugNames
debugNames = (Maybe FastString, Propagation)
-> Maybe (Maybe FastString, Propagation)
forall a. a -> Maybe a
Just (Maybe FastString
forall a. Maybe a
Nothing, Propagation
Mute)
  | IdP GhcRn
Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== DebugNames -> Name
traceInertPredName DebugNames
debugNames = (Maybe FastString, Propagation)
-> Maybe (Maybe FastString, Propagation)
forall a. a -> Maybe a
Just (Maybe FastString
forall a. Maybe a
Nothing, Propagation
Inert)
checkForDebugPred DebugNames
debugNames
    (Ghc.HsAppTy XAppTy GhcRn
_ (Ghc.L SrcSpan
_ (Ghc.HsTyVar XTyVar GhcRn
_ PromotionFlag
_ (Ghc.L SrcSpan
_ IdP GhcRn
name))) (Ghc.L SrcSpan
_ (Ghc.HsTyLit XTyLit GhcRn
_ (Ghc.HsStrTy SourceText
_ FastString
key))))
  | IdP GhcRn
Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== DebugNames -> Name
traceKeyPredName DebugNames
debugNames = (Maybe FastString, Propagation)
-> Maybe (Maybe FastString, Propagation)
forall a. a -> Maybe a
Just (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
key, Propagation
Shallow)
  | IdP GhcRn
Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== DebugNames -> Name
traceDeepKeyPredName DebugNames
debugNames = (Maybe FastString, Propagation)
-> Maybe (Maybe FastString, Propagation)
forall a. a -> Maybe a
Just (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
key, Propagation
Deep)
checkForDebugPred DebugNames
debugNames Ghc.HsForAllTy { hst_body :: forall pass. HsType pass -> LHsType pass
Ghc.hst_body = Ghc.L SrcSpan
_ HsType GhcRn
ty }
  = DebugNames -> HsType GhcRn -> Maybe (Maybe FastString, Propagation)
checkForDebugPred DebugNames
debugNames HsType GhcRn
ty
checkForDebugPred DebugNames
debugNames (Ghc.HsParTy XParTy GhcRn
_ (Ghc.L SrcSpan
_ HsType GhcRn
ty))
  = DebugNames -> HsType GhcRn -> Maybe (Maybe FastString, Propagation)
checkForDebugPred DebugNames
debugNames HsType GhcRn
ty
checkForDebugPred DebugNames
_ HsType GhcRn
_ = Maybe (Maybe FastString, Propagation)
forall a. Maybe a
Nothing
-- need a case for nested QualTy?