{-# 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
  , withTimingWallClock
  ) where

import Control.Monad
import Control.Monad.IO.Class
import GHC.Conc (getAllocationCounter)
import Debug.Trace
import GHC.Clock (getMonotonicTimeNSec)
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 qualified Data.Map as Map
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 , 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.Error                as Ghc
import GHC.Utils.Logger               as Ghc
import GHC.Utils.Outputable           as Ghc hiding ((<>))
import qualified GHC.Utils.Outputable as Ghc

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), ((Var, Kind) -> Kind) -> Maybe (Var, 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 (Var, Kind) -> Kind
forall a b. (a, b) -> b
snd (Kind -> Maybe (Var, 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 -> ([Var], ThetaType, ThetaType, Kind)
dataConSig DataCon
dc
  = (DataCon -> [Var]
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 = Map Module [ImportedBy] -> [Module]
forall k a. Map k a -> [k]
Map.keys (Map Module [ImportedBy] -> [Module])
-> (TcGblEnv -> Map Module [ImportedBy]) -> TcGblEnv -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportAvails -> Map Module [ImportedBy]
imp_mods (ImportAvails -> Map Module [ImportedBy])
-> (TcGblEnv -> ImportAvails)
-> TcGblEnv
-> Map Module [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
epaLocationRealSrcSpan 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 and sets them as
-- exported identifiers.
--
-- This prevents the simple optimizer from inlining such bindings which might
-- have specs that would otherwise be left dangling.
--
-- Setting the exported flag prevents both inlining and removal of dead bindings
-- in the simple optimizer. NOINLINE is redundant with this, but it expresseses
-- the intent more clearly. Note also that Language.Haskell.Liquid.Transform.Rewrite.inlineLoopBreaker
-- depends at the moment on NOINLINE being inserted to tell appart bindings in
-- the original program from generated bindings.
--
-- 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)
-> (HsBindLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc) -> b -> b
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` HsBindLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
markHsBind

    -- Mark all user-originating `Id` binders as `NOINLINE`.
    markHsBind :: HsBind GhcTc -> HsBind GhcTc
    markHsBind :: HsBindLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
markHsBind = \case
        bind :: HsBindLR GhcTc 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 } -> HsBindLR GhcTc GhcTc
bind{ var_id = markId var, var_rhs = go rhs }
        bind :: HsBindLR GhcTc 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 } -> HsBindLR GhcTc GhcTc
bind{ fun_id = markId <$> var, fun_matches = go matches }
        bind :: HsBindLR GhcTc 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 } -> HsBindLR GhcTc GhcTc
bind{ pat_lhs = markPat <$> lhs, pat_rhs = go rhs }
        PatSynBind{} -> String -> HsBindLR GhcTc 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 -> HsBindLR GhcTc 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 (Var -> Var
markId (Var -> Var)
-> GenLocated SrcSpanAnnN Var -> GenLocated SrcSpanAnnN Var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LIdP GhcTc
GenLocated SrcSpanAnnN Var
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 :: Var -> Var
markId Var
var = Var -> Var
setIdExported (Var
var Var -> InlinePragma -> Var
`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.
    --
    -- The first binding inside abs_binds is not given NOINLINE (to avoid
    -- interfering with the polymorphism wrapper), but nested where-clause
    -- bindings inside it are still marked via the generic traversal.
    markAbsBinds :: AbsBinds -> AbsBinds
    markAbsBinds :: AbsBinds -> AbsBinds
markAbsBinds absBinds0 :: AbsBinds
absBinds0@AbsBinds{ abs_binds :: AbsBinds -> [XRec GhcTc (HsBindLR GhcTc GhcTc)]
abs_binds = [XRec GhcTc (HsBindLR GhcTc 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 :: HsBindLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
skipFirstHsBind = \case
          XHsBindsLR XXHsBindsLR GhcTc GhcTc
absBinds -> XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
XHsBindsLR (AbsBinds -> AbsBinds
markAbsBinds XXHsBindsLR GhcTc GhcTc
AbsBinds
absBinds)
          HsBindLR GhcTc GhcTc
b -> (forall a. Data a => a -> a)
-> HsBindLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall a. Data a => (forall a. Data a => a -> a) -> a -> a
gmapT b -> b
forall a. Data a => a -> a
go HsBindLR GhcTc GhcTc
b

        markABE :: ABExport -> ABExport
        markABE :: ABExport -> ABExport
markABE abe :: ABExport
abe@ABE{ abe_poly :: ABExport -> Var
abe_poly = Var
poly
                       , abe_mono :: ABExport -> Var
abe_mono = Var
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
_ [Var]
_ Expr Var
exprCoreBndr) = Expr Var -> Bool
hasPatErrorCall Expr Var
exprCoreBndr
  where
   hasPatErrorCall :: CoreExpr -> Bool
   -- auto generated undefined case: (\_ -> (patError @levity @type "error message")) void
   -- Type arguments are erased before calling isUndefined
   hasPatErrorCall :: Expr Var -> Bool
hasPatErrorCall (App Expr Var
e Expr Var
_)
     | Var Var
x <- Expr Var -> Expr Var
forall {b}. Expr b -> Expr b
unTick Expr Var
e = Var
x Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
pAT_ERROR_ID
     | Bool
otherwise = Expr Var -> Bool
hasPatErrorCall Expr Var
e
   -- another auto generated undefined case:
   -- let lqanf_... = patError "error message") in case lqanf_... of {}
   hasPatErrorCall (Let (NonRec Var
x Expr Var
e) Expr Var
ec)
     | Case Expr Var
e0 Var
_ Kind
_ [] <- Expr Var -> Expr Var
forall {b}. Expr b -> Expr b
unTick Expr Var
ec
     , Var Var
v <- Expr Var -> Expr Var
forall {b}. Expr b -> Expr b
unTick Expr Var
e0
     , Var
x Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
v = Expr Var -> Bool
hasPatErrorCall Expr Var
e
   hasPatErrorCall (Case Expr Var
e Var
_ Kind
_ [CoreAlt]
_) = Expr Var -> Bool
hasPatErrorCall Expr Var
e
   hasPatErrorCall (Let Bind Var
_ Expr Var
e) = Expr Var -> Bool
hasPatErrorCall Expr Var
e
   hasPatErrorCall (Tick CoreTickish
_ Expr Var
e) = Expr Var -> Bool
hasPatErrorCall Expr Var
e
   -- otherwise
   hasPatErrorCall Expr Var
_ = 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 Var -> Maybe (Expr Var, Expr Var)
splitDollarApp Expr Var
e
     -- matches `$ t1 t2 t3 t4 f a`
     | App Expr Var
e1 Expr Var
a  <- Expr Var -> Expr Var
untick Expr Var
e
     , App Expr Var
e2 Expr Var
f  <- Expr Var -> Expr Var
untick Expr Var
e1
     , App Expr Var
e3 Expr Var
t4 <- Expr Var -> Expr Var
untick Expr Var
e2
     , App Expr Var
e4 Expr Var
t3 <- Expr Var -> Expr Var
untick Expr Var
e3
     , App Expr Var
e5 Expr Var
t2 <- Expr Var -> Expr Var
untick Expr Var
e4
     , App Expr Var
d Expr Var
t1  <- Expr Var -> Expr Var
untick Expr Var
e5
     , Var Var
v     <- Expr Var -> Expr Var
untick Expr Var
d
     , Var
v Var -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
dollarIdKey
     , Type Kind
_    <- Expr Var -> Expr Var
untick Expr Var
t1
     , Type Kind
_    <- Expr Var -> Expr Var
untick Expr Var
t2
     , Type Kind
_    <- Expr Var -> Expr Var
untick Expr Var
t3
     , Type Kind
_    <- Expr Var -> Expr Var
untick Expr Var
t4
     = (Expr Var, Expr Var) -> Maybe (Expr Var, Expr Var)
forall a. a -> Maybe a
Just (Expr Var
f, Expr Var
a)
     | Bool
otherwise
     = Maybe (Expr Var, Expr Var)
forall a. Maybe a
Nothing

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

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

-- | A version of 'withTiming' that uses wall clock time instead of CPU time.
--
-- This version is copied and modified from GHC's 'GHC.Utils.Error.withTiming'
withTimingWallClock :: MonadIO m
           => Logger
           -> SDoc         -- ^ The name of the phase
           -> (a -> ())    -- ^ A function to force the result
                           -- (often either @const ()@ or 'rnf')
           -> m a          -- ^ The body of the phase to be timed
           -> m a
withTimingWallClock :: forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTimingWallClock Logger
logger SDoc
what a -> ()
force_result m a
action =
    if Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
2 Bool -> Bool -> Bool
|| Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_timings
    then do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
printTimingsNotDumpToFile (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
              Logger -> SDoc -> IO ()
logInfo Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"***" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
Ghc.<> SDoc
forall doc. IsLine doc => doc
colon
            let ctx :: SDocContext
ctx = LogFlags -> SDocContext
log_default_user_context (Logger -> LogFlags
logFlags Logger
logger)
            alloc0 <- IO Int64 -> m Int64
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int64
getAllocationCounter
            !start <- liftIO getMonotonicTimeNSec
            eventBegins ctx what
            recordAllocs alloc0
            !r <- action
            () <- pure $ force_result r
            eventEnds ctx what
            !end <- liftIO getMonotonicTimeNSec
            alloc1 <- liftIO getAllocationCounter
            recordAllocs alloc1
            -- recall that allocation counter counts down
            let alloc = Int64
alloc0 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
alloc1
                time = (Word64
end Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
start) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
1000000

            when (logVerbAtLeast logger 2 && printTimingsNotDumpToFile)
                $ liftIO $ logInfo logger $ withPprStyle defaultUserStyle
                    (text "!!!" <+> what Ghc.<> colon <+> text "finished in"
                     <+> word64 time
                     <+> text "milliseconds"
                     Ghc.<> comma
                     <+> text "allocated"
                     <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
                     <+> text "megabytes")

            liftIO $ putDumpFileMaybe logger Opt_D_dump_timings "" FormatText
                    $ text $ showSDocOneLine ctx
                    $ hsep [ what Ghc.<> colon
                           , text "alloc=" Ghc.<> ppr alloc
                           , text "time=" Ghc.<> word64 time
                           ]
            pure r
     else m a
action

    where -- Avoid both printing to console and dumping to a file (#20316).
          printTimingsNotDumpToFile :: Bool
printTimingsNotDumpToFile =
            Bool -> Bool
not (LogFlags -> Bool
log_dump_to_file (Logger -> LogFlags
logFlags Logger
logger))

          recordAllocs :: a -> m ()
recordAllocs a
alloc =
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceMarkerIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"GHC:allocs:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
alloc

          eventBegins :: SDocContext -> SDoc -> m ()
eventBegins SDocContext
ctx SDoc
w = do
            let doc :: String
doc = SDocContext -> SDoc -> String
eventBeginsDoc SDocContext
ctx SDoc
w
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceMarkerIO String
doc
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceEventIO String
doc

          eventEnds :: SDocContext -> SDoc -> m ()
eventEnds SDocContext
ctx SDoc
w = do
            let doc :: String
doc = SDocContext -> SDoc -> String
eventEndsDoc SDocContext
ctx SDoc
w
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceMarkerIO String
doc
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceEventIO String
doc

          eventBeginsDoc :: SDocContext -> SDoc -> String
eventBeginsDoc SDocContext
ctx SDoc
w = SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"GHC:started:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
w
          eventEndsDoc :: SDocContext -> SDoc -> String
eventEndsDoc   SDocContext
ctx SDoc
w = SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"GHC:finished:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
w