{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}

module Liquid.GHC.API.Extra (
    module StableModule
  , ApiComment(..)
  , addNoInlinePragmasToBinds
  , apiComments
  , apiCommentsParsedSource
  , dataConSig
  , directImports
  , fsToUnitId
  , isPatErrorAlt
  , minus_RDR
  , qualifiedNameFS
  , renderWithStyle
  , showPprQualified
  , showPprDebug
  , showSDocQualified
  , splitDollarApp
  , strictNothing
  , thisPackage
  , tyConRealArity
  , untick
  ) where

import           Liquid.GHC.API.StableModule      as StableModule
import GHC hiding (modInfoLookupName)
import Data.Data (Data, gmapQr, gmapT)
import Data.Generics (extQ, extT)
import Data.Foldable                  (asum)
import Data.List                      (sortOn)
import GHC.Builtin.Names ( dollarIdKey, minusName )
import GHC.Core                       as Ghc
import GHC.Core.Coercion              as Ghc
import GHC.Core.DataCon               as Ghc
import GHC.Core.Make                  (pAT_ERROR_ID)
import GHC.Core.Type                  as Ghc hiding (typeKind , isPredTy, extendCvSubst, linear)
import GHC.Data.FastString            as Ghc
import GHC.Data.Maybe
import qualified GHC.Data.Strict
import GHC.Driver.Session             as Ghc
import GHC.Tc.Types
import GHC.Types.Id
import GHC.Types.Basic
import GHC.Types.Name                 (isSystemName, nameModule_maybe, occNameFS)
import GHC.Types.Name.Reader          (nameRdrName)
import GHC.Types.SrcLoc               as Ghc
import GHC.Types.Unique               (getUnique, hasKey)

import GHC.Utils.Outputable           as Ghc hiding ((<>))

import GHC.Unit.Module

-- 'fsToUnitId' is gone in GHC 9, but we can bring code it in terms of 'fsToUnit' and 'toUnitId'.
fsToUnitId :: FastString -> UnitId
fsToUnitId :: FastString -> UnitId
fsToUnitId = Unit -> UnitId
toUnitId (Unit -> UnitId) -> (FastString -> Unit) -> FastString -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Unit
fsToUnit

thisPackage :: DynFlags -> UnitId
thisPackage :: DynFlags -> UnitId
thisPackage = DynFlags -> UnitId
homeUnitId_

-- See NOTE [tyConRealArity].
tyConRealArity :: TyCon -> Int
tyConRealArity :: TyCon -> Int
tyConRealArity TyCon
tc = Int -> Kind -> Int
go Int
0 (TyCon -> Kind
tyConKind TyCon
tc)
  where
    go :: Int -> Kind -> Int
    go :: Int -> Kind -> Int
go !Int
acc Kind
k =
      case [Maybe Kind] -> Maybe Kind
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [((FunTyFlag, Kind, Kind, Kind) -> Kind)
-> Maybe (FunTyFlag, Kind, Kind, Kind) -> Maybe Kind
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(FunTyFlag
_, Kind
_, Kind
_, Kind
c) -> Kind
c) (Kind -> Maybe (FunTyFlag, Kind, Kind, Kind)
splitFunTy_maybe Kind
k), ((Id, Kind) -> Kind) -> Maybe (Id, Kind) -> Maybe Kind
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Id, Kind) -> Kind
forall a b. (a, b) -> b
snd (Kind -> Maybe (Id, Kind)
splitForAllTyCoVar_maybe Kind
k)] of
        Maybe Kind
Nothing -> Int
acc
        Just Kind
ks -> Int -> Kind -> Int
go (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Kind
ks

renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
renderWithStyle DynFlags
dynflags SDoc
sdoc PprStyle
style = SDocContext -> SDoc -> String
Ghc.renderWithContext (DynFlags -> PprStyle -> SDocContext
Ghc.initSDocContext DynFlags
dynflags PprStyle
style) SDoc
sdoc

-- This function is gone in GHC 9.
dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type)
dataConSig :: DataCon -> ([Id], ThetaType, ThetaType, Kind)
dataConSig DataCon
dc
  = (DataCon -> [Id]
dataConUnivAndExTyCoVars DataCon
dc, DataCon -> ThetaType
dataConTheta DataCon
dc, (Scaled Kind -> Kind) -> [Scaled Kind] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Scaled Kind -> Kind
forall a. Scaled a -> a
irrelevantMult ([Scaled Kind] -> ThetaType) -> [Scaled Kind] -> ThetaType
forall a b. (a -> b) -> a -> b
$ DataCon -> [Scaled Kind]
dataConOrigArgTys DataCon
dc, DataCon -> Kind
dataConOrigResTy DataCon
dc)

-- | Extracts the direct imports of a module.
directImports :: TcGblEnv -> [Module]
directImports :: TcGblEnv -> [Module]
directImports = ModuleEnv [ImportedBy] -> [Module]
forall a. ModuleEnv a -> [Module]
moduleEnvKeys (ModuleEnv [ImportedBy] -> [Module])
-> (TcGblEnv -> ModuleEnv [ImportedBy]) -> TcGblEnv -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportAvails -> ModuleEnv [ImportedBy]
imp_mods (ImportAvails -> ModuleEnv [ImportedBy])
-> (TcGblEnv -> ImportAvails) -> TcGblEnv -> ModuleEnv [ImportedBy]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv -> ImportAvails
tcg_imports

-- | Abstraction of 'EpaComment'.
data ApiComment
  = ApiLineComment String
  | ApiBlockComment String
  deriving (ApiComment -> ApiComment -> Bool
(ApiComment -> ApiComment -> Bool)
-> (ApiComment -> ApiComment -> Bool) -> Eq ApiComment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ApiComment -> ApiComment -> Bool
== :: ApiComment -> ApiComment -> Bool
$c/= :: ApiComment -> ApiComment -> Bool
/= :: ApiComment -> ApiComment -> Bool
Eq, Int -> ApiComment -> ShowS
[ApiComment] -> ShowS
ApiComment -> String
(Int -> ApiComment -> ShowS)
-> (ApiComment -> String)
-> ([ApiComment] -> ShowS)
-> Show ApiComment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApiComment -> ShowS
showsPrec :: Int -> ApiComment -> ShowS
$cshow :: ApiComment -> String
show :: ApiComment -> String
$cshowList :: [ApiComment] -> ShowS
showList :: [ApiComment] -> ShowS
Show)

-- | Extract top-level comments from a module.
apiComments :: HsParsedModule -> [Ghc.Located ApiComment]
apiComments :: HsParsedModule -> [Located ApiComment]
apiComments = Located (HsModule GhcPs) -> [Located ApiComment]
apiCommentsParsedSource (Located (HsModule GhcPs) -> [Located ApiComment])
-> (HsParsedModule -> Located (HsModule GhcPs))
-> HsParsedModule
-> [Located ApiComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsParsedModule -> Located (HsModule GhcPs)
hpm_module

apiCommentsParsedSource :: Located (HsModule GhcPs) -> [Ghc.Located ApiComment]
apiCommentsParsedSource :: Located (HsModule GhcPs) -> [Located ApiComment]
apiCommentsParsedSource Located (HsModule GhcPs)
ps =
    let hs :: HsModule GhcPs
hs = Located (HsModule GhcPs) -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc Located (HsModule GhcPs)
ps
        go :: forall a. Data a => a -> [LEpaComment]
        go :: forall a. Data a => a -> [LEpaComment]
go = ([LEpaComment] -> [LEpaComment] -> [LEpaComment])
-> [LEpaComment]
-> (forall a. Data a => a -> [LEpaComment])
-> a
-> [LEpaComment]
forall a r r'.
Data a =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
gmapQr [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. [a] -> [a] -> [a]
(++) [] d -> [LEpaComment]
forall a. Data a => a -> [LEpaComment]
go (a -> [LEpaComment])
-> ([LEpaComment] -> [LEpaComment]) -> a -> [LEpaComment]
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (forall a. a -> a
id @[LEpaComment])
     in (Located ApiComment -> Maybe (Int, Int))
-> [Located ApiComment] -> [Located ApiComment]
forall b a. Ord b => (a -> b) -> [a] -> [a]
Data.List.sortOn (SrcSpan -> Maybe (Int, Int)
spanToLineColumn (SrcSpan -> Maybe (Int, Int))
-> (Located ApiComment -> SrcSpan)
-> Located ApiComment
-> Maybe (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located ApiComment -> SrcSpan
forall l e. GenLocated l e -> l
getLoc) ([Located ApiComment] -> [Located ApiComment])
-> [Located ApiComment] -> [Located ApiComment]
forall a b. (a -> b) -> a -> b
$
          (LEpaComment -> Maybe (Located ApiComment))
-> [LEpaComment] -> [Located ApiComment]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (GenLocated SrcSpan EpaComment -> Maybe (Located ApiComment)
forall {l}.
GenLocated l EpaComment -> Maybe (GenLocated l ApiComment)
tokComment (GenLocated SrcSpan EpaComment -> Maybe (Located ApiComment))
-> (LEpaComment -> GenLocated SrcSpan EpaComment)
-> LEpaComment
-> Maybe (Located ApiComment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEpaComment -> GenLocated SrcSpan EpaComment
forall {a} {e}.
GenLocated (EpaLocation' a) e -> GenLocated SrcSpan e
toRealSrc) ([LEpaComment] -> [Located ApiComment])
-> [LEpaComment] -> [Located ApiComment]
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> [LEpaComment]
forall a. Data a => a -> [LEpaComment]
go HsModule GhcPs
hs
  where
    tokComment :: GenLocated l EpaComment -> Maybe (GenLocated l ApiComment)
tokComment (L l
sp (EpaComment (EpaLineComment String
s) RealSrcSpan
_)) = GenLocated l ApiComment -> Maybe (GenLocated l ApiComment)
forall a. a -> Maybe a
Just (l -> ApiComment -> GenLocated l ApiComment
forall l e. l -> e -> GenLocated l e
L l
sp (String -> ApiComment
ApiLineComment String
s))
    tokComment (L l
sp (EpaComment (EpaBlockComment String
s) RealSrcSpan
_)) = GenLocated l ApiComment -> Maybe (GenLocated l ApiComment)
forall a. a -> Maybe a
Just (l -> ApiComment -> GenLocated l ApiComment
forall l e. l -> e -> GenLocated l e
L l
sp (String -> ApiComment
ApiBlockComment String
s))
    tokComment GenLocated l EpaComment
_ = Maybe (GenLocated l ApiComment)
forall a. Maybe a
Nothing

    -- TODO: take into account anchor_op, which only matters if the source was
    -- pre-processed by an exact-print-aware tool.
    toRealSrc :: GenLocated (EpaLocation' a) e -> GenLocated SrcSpan e
toRealSrc (L EpaLocation' a
a e
e) = SrcSpan -> e -> GenLocated SrcSpan e
forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (EpaLocation' a -> RealSrcSpan
forall a. EpaLocation' a -> RealSrcSpan
anchor EpaLocation' a
a) Maybe BufSpan
forall a. Maybe a
strictNothing) e
e

    spanToLineColumn :: SrcSpan -> Maybe (Int, Int)
spanToLineColumn =
      (RealSrcSpan -> (Int, Int))
-> Maybe RealSrcSpan -> Maybe (Int, Int)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\RealSrcSpan
s -> (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s, RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s)) (Maybe RealSrcSpan -> Maybe (Int, Int))
-> (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Maybe RealSrcSpan
srcSpanToRealSrcSpan

-- | Adds NOINLINE pragmas to all bindings in the module.
--
-- This prevents the simple optimizer from inlining such bindings which might
-- have specs that would otherwise be left dangling.
--
-- https://gitlab.haskell.org/ghc/ghc/-/issues/24386
--
addNoInlinePragmasToBinds :: TcGblEnv -> TcGblEnv
addNoInlinePragmasToBinds :: TcGblEnv -> TcGblEnv
addNoInlinePragmasToBinds TcGblEnv
tcg = TcGblEnv
tcg{ tcg_binds = go (tcg_binds tcg) }
  where
    go :: forall a. Data a => a -> a
    go :: forall a. Data a => a -> a
go = (forall a. Data a => a -> a) -> a -> a
forall a. Data a => (forall a. Data a => a -> a) -> a -> a
gmapT ((forall a. Data a => a -> a) -> a -> a)
-> (forall a. Data a => a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ b -> b
forall a. Data a => a -> a
go (b -> b) -> (HsBind GhcTc -> HsBind GhcTc) -> b -> b
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` HsBind GhcTc -> HsBind GhcTc
markHsBind

    -- Mark all user-originating `Id` binders as `NOINLINE`.
    markHsBind :: HsBind GhcTc -> HsBind GhcTc
    markHsBind :: HsBind GhcTc -> HsBind GhcTc
markHsBind = \case
        bind :: HsBind GhcTc
bind@VarBind{ var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id = IdP GhcTc
var, var_rhs :: forall idL idR. HsBindLR idL idR -> LHsExpr idR
var_rhs = LHsExpr GhcTc
rhs } -> HsBind GhcTc
bind{ var_id = markId var, var_rhs = go rhs }
        bind :: HsBind GhcTc
bind@FunBind{ fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcTc
var, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
matches } -> HsBind GhcTc
bind{ fun_id = markId <$> var, fun_matches = go matches }
        bind :: HsBind GhcTc
bind@PatBind{ pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcTc
lhs, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
rhs } -> HsBind GhcTc
bind{ pat_lhs = markPat <$> lhs, pat_rhs = go rhs }
        PatSynBind{} -> String -> HsBind GhcTc
forall a. HasCallStack => String -> a
error String
"markNoInline: unexpected PatSynBind, should have been eliminated by the typechecker"
        XHsBindsLR XXHsBindsLR GhcTc GhcTc
absBinds -> XXHsBindsLR GhcTc GhcTc -> HsBind GhcTc
forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
XHsBindsLR (AbsBinds -> AbsBinds
markAbsBinds XXHsBindsLR GhcTc GhcTc
AbsBinds
absBinds)

    markPat :: Pat GhcTc -> Pat GhcTc
    markPat :: Pat GhcTc -> Pat GhcTc
markPat = \case
        VarPat XVarPat GhcTc
ext LIdP GhcTc
var -> XVarPat GhcTc -> LIdP GhcTc -> Pat GhcTc
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcTc
ext (Id -> Id
markId (Id -> Id)
-> GenLocated SrcSpanAnnN Id -> GenLocated SrcSpanAnnN Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LIdP GhcTc
GenLocated SrcSpanAnnN Id
var)
        Pat GhcTc
pat -> (forall a. Data a => a -> a) -> Pat GhcTc -> Pat GhcTc
forall a. Data a => (forall a. Data a => a -> a) -> a -> a
gmapT (b -> b
forall a. a -> a
id (b -> b) -> (Pat GhcTc -> Pat GhcTc) -> b -> b
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` Pat GhcTc -> Pat GhcTc
markPat) Pat GhcTc
pat

    markId :: Id -> Id
    markId :: Id -> Id
markId Id
var = Id
var Id -> InlinePragma -> Id
`setInlinePragma` InlinePragma
neverInlinePragma

    -- The AbsBinds come from the GHC typechecker to handle polymorphism,
    -- overloading, and recursion, so those don't correspond directly to
    -- user-written `Id`s except for those in @abs_exports@. For instance,
    -- @tests/pos/Map0.hs@ would fail if Ids in @abs_exports@ are not marked.
    --
    -- See
    -- https://github.com/ucsd-progsys/liquidhaskell/issues/2257 for more
    -- context.
    markAbsBinds :: AbsBinds -> AbsBinds
    markAbsBinds :: AbsBinds -> AbsBinds
markAbsBinds absBinds0 :: AbsBinds
absBinds0@AbsBinds{ abs_binds :: AbsBinds -> Bag (XRec GhcTc (HsBind GhcTc))
abs_binds = Bag (XRec GhcTc (HsBind GhcTc))
binds, abs_exports :: AbsBinds -> [ABExport]
abs_exports = [ABExport]
exports }  =
        AbsBinds
absBinds0
          { abs_binds = fmap skipFirstHsBind <$> binds
          , abs_exports = map markABE exports
          }
      where
        skipFirstHsBind :: HsBind GhcTc -> HsBind GhcTc
        skipFirstHsBind :: HsBind GhcTc -> HsBind GhcTc
skipFirstHsBind = \case
          XHsBindsLR XXHsBindsLR GhcTc GhcTc
absBinds -> XXHsBindsLR GhcTc GhcTc -> HsBind GhcTc
forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
XHsBindsLR (AbsBinds -> AbsBinds
markAbsBinds XXHsBindsLR GhcTc GhcTc
AbsBinds
absBinds)
          HsBind GhcTc
b -> (forall a. Data a => a -> a) -> HsBind GhcTc -> HsBind GhcTc
forall a. Data a => (forall a. Data a => a -> a) -> a -> a
gmapT b -> b
forall a. Data a => a -> a
go HsBind GhcTc
b

        markABE :: ABExport -> ABExport
        markABE :: ABExport -> ABExport
markABE abe :: ABExport
abe@ABE{ abe_poly :: ABExport -> Id
abe_poly = Id
poly
                       , abe_mono :: ABExport -> Id
abe_mono = Id
mono } = ABExport
abe
          { abe_poly = markId poly
          , abe_mono = markId mono }

-- | Tells if a case alternative calls to patError
isPatErrorAlt :: CoreAlt -> Bool
isPatErrorAlt :: CoreAlt -> Bool
isPatErrorAlt (Alt AltCon
_ [Id]
_ Expr Id
exprCoreBndr) = Expr Id -> Bool
hasPatErrorCall Expr Id
exprCoreBndr
  where
   hasPatErrorCall :: CoreExpr -> Bool
   -- auto generated undefined case: (\_ -> (patError @levity @type "error message")) void
   -- Type arguments are erased before calling isUndefined
   hasPatErrorCall :: Expr Id -> Bool
hasPatErrorCall (App Expr Id
e Expr Id
_)
     | Var Id
x <- Expr Id -> Expr Id
forall {b}. Expr b -> Expr b
unTick Expr Id
e = Id
x Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
pAT_ERROR_ID
     | Bool
otherwise = Expr Id -> Bool
hasPatErrorCall Expr Id
e
   -- another auto generated undefined case:
   -- let lqanf_... = patError "error message") in case lqanf_... of {}
   hasPatErrorCall (Let (NonRec Id
x Expr Id
e) Expr Id
ec)
     | Case Expr Id
e0 Id
_ Kind
_ [] <- Expr Id -> Expr Id
forall {b}. Expr b -> Expr b
unTick Expr Id
ec
     , Var Id
v <- Expr Id -> Expr Id
forall {b}. Expr b -> Expr b
unTick Expr Id
e0
     , Id
x Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v = Expr Id -> Bool
hasPatErrorCall Expr Id
e
   hasPatErrorCall (Case Expr Id
e Id
_ Kind
_ [CoreAlt]
_) = Expr Id -> Bool
hasPatErrorCall Expr Id
e
   hasPatErrorCall (Let Bind Id
_ Expr Id
e) = Expr Id -> Bool
hasPatErrorCall Expr Id
e
   hasPatErrorCall (Tick CoreTickish
_ Expr Id
e) = Expr Id -> Bool
hasPatErrorCall Expr Id
e
   -- otherwise
   hasPatErrorCall Expr Id
_ = Bool
False

   unTick :: Expr b -> Expr b
unTick (Tick CoreTickish
_ Expr b
e) = Expr b -> Expr b
unTick Expr b
e
   unTick Expr b
e = Expr b
e


qualifiedNameFS :: Name -> FastString
qualifiedNameFS :: Name -> FastString
qualifiedNameFS Name
n = [FastString] -> FastString
concatFS [FastString
modFS, FastString
occFS, FastString
uniqFS]
  where
  modFS :: FastString
modFS = case Name -> Maybe Module
nameModule_maybe Name
n of
            Maybe Module
Nothing -> String -> FastString
fsLit String
""
            Just Module
m  -> [FastString] -> FastString
concatFS [ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m), String -> FastString
fsLit String
"."]

  occFS :: FastString
occFS = OccName -> FastString
occNameFS (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
n)
  uniqFS :: FastString
uniqFS
    | Name -> Bool
isSystemName Name
n
    = [FastString] -> FastString
concatFS [String -> FastString
fsLit String
"_",  String -> FastString
fsLit (Unique -> String
forall a. Outputable a => a -> String
showPprQualified (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
n))]
    | Bool
otherwise
    = String -> FastString
fsLit String
""

-- Variants of Outputable functions which now require DynFlags!
showPprQualified :: Outputable a => a -> String
showPprQualified :: forall a. Outputable a => a -> String
showPprQualified = SDoc -> String
showSDocQualified (SDoc -> String) -> (a -> SDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr

showSDocQualified :: Ghc.SDoc -> String
showSDocQualified :: SDoc -> String
showSDocQualified = SDocContext -> SDoc -> String
Ghc.renderWithContext SDocContext
ctx
  where
    style :: PprStyle
style = NamePprCtx -> Depth -> PprStyle
Ghc.mkUserStyle NamePprCtx
myQualify Depth
Ghc.AllTheWay
    ctx :: SDocContext
ctx = SDocContext
Ghc.defaultSDocContext { sdocStyle = style }

myQualify :: Ghc.NamePprCtx
myQualify :: NamePprCtx
myQualify = NamePprCtx
Ghc.neverQualify { Ghc.queryQualifyName = Ghc.alwaysQualifyNames }
-- { Ghc.queryQualifyName = \_ _ -> Ghc.NameNotInScope1 }

showPprDebug :: Outputable a => a -> String
showPprDebug :: forall a. Outputable a => a -> String
showPprDebug = SDoc -> String
showSDocDebug (SDoc -> String) -> (a -> SDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr

showSDocDebug :: Ghc.SDoc -> String
showSDocDebug :: SDoc -> String
showSDocDebug = SDocContext -> SDoc -> String
Ghc.renderWithContext SDocContext
ctx
  where
    style :: PprStyle
style = NamePprCtx -> Depth -> PprStyle
Ghc.mkUserStyle NamePprCtx
myQualify Depth
Ghc.AllTheWay
    ctx :: SDocContext
ctx = SDocContext
Ghc.defaultSDocContext {
        sdocStyle = style
      , sdocPprDebug = True
      }

strictNothing :: GHC.Data.Strict.Maybe a
strictNothing :: forall a. Maybe a
strictNothing = Maybe a
forall a. Maybe a
GHC.Data.Strict.Nothing

splitDollarApp :: CoreExpr -> Maybe (CoreExpr, CoreExpr)
splitDollarApp :: Expr Id -> Maybe (Expr Id, Expr Id)
splitDollarApp Expr Id
e
     -- matches `$ t1 t2 t3 t4 f a`
     | App Expr Id
e1 Expr Id
a  <- Expr Id -> Expr Id
untick Expr Id
e
     , App Expr Id
e2 Expr Id
f  <- Expr Id -> Expr Id
untick Expr Id
e1
     , App Expr Id
e3 Expr Id
t4 <- Expr Id -> Expr Id
untick Expr Id
e2
     , App Expr Id
e4 Expr Id
t3 <- Expr Id -> Expr Id
untick Expr Id
e3
     , App Expr Id
e5 Expr Id
t2 <- Expr Id -> Expr Id
untick Expr Id
e4
     , App Expr Id
d Expr Id
t1  <- Expr Id -> Expr Id
untick Expr Id
e5
     , Var Id
v     <- Expr Id -> Expr Id
untick Expr Id
d
     , Id
v Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
dollarIdKey
     , Type Kind
_    <- Expr Id -> Expr Id
untick Expr Id
t1
     , Type Kind
_    <- Expr Id -> Expr Id
untick Expr Id
t2
     , Type Kind
_    <- Expr Id -> Expr Id
untick Expr Id
t3
     , Type Kind
_    <- Expr Id -> Expr Id
untick Expr Id
t4
     = (Expr Id, Expr Id) -> Maybe (Expr Id, Expr Id)
forall a. a -> Maybe a
Just (Expr Id
f, Expr Id
a)
     | Bool
otherwise
     = Maybe (Expr Id, Expr Id)
forall a. Maybe a
Nothing

untick :: CoreExpr -> CoreExpr
untick :: Expr Id -> Expr Id
untick (Tick CoreTickish
_ Expr Id
e) = Expr Id -> Expr Id
untick Expr Id
e
untick Expr Id
e = Expr Id
e

minus_RDR :: RdrName
minus_RDR :: RdrName
minus_RDR = Name -> RdrName
nameRdrName Name
minusName