{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module StackTrace.Plugin (plugin) where

import Control.Arrow (first)
import Data.Monoid (Any(Any, getAny))
#if __GLASGOW_HASKELL__ >= 900
import GHC.Plugins
#else

import GhcPlugins
#endif
#if __GLASGOW_HASKELL__ >= 810
import GHC.Hs
#endif
#if __GLASGOW_HASKELL__ < 810
import HsSyn
#endif

type Traversal s t a b
   = forall f. Applicative f =>
                 (a -> f b) -> s -> f t

type Traversal' s a = Traversal s s a a

plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin {parsedResultAction :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction = [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedPlugin, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
pluginRecompile = [CommandLineOption] -> IO PluginRecompile
purePlugin}

parsedPlugin ::
     [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedPlugin :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedPlugin [CommandLineOption]
_ ModSummary
_ HsParsedModule
pm = do
  let m :: GenLocated SrcSpan (HsModule GhcPs)
m = HsModule GhcPs -> HsModule GhcPs
updateHsModule (HsModule GhcPs -> HsModule GhcPs)
-> GenLocated SrcSpan (HsModule GhcPs)
-> GenLocated SrcSpan (HsModule GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsParsedModule -> GenLocated SrcSpan (HsModule GhcPs)
hpm_module HsParsedModule
pm
      pm' :: HsParsedModule
pm' = HsParsedModule
pm {hpm_module :: GenLocated SrcSpan (HsModule GhcPs)
hpm_module = GenLocated SrcSpan (HsModule GhcPs)
m}
  HsParsedModule -> Hsc HsParsedModule
forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
pm'

-- Use qualified import for GHC.Stack as "AutoImported.GHC.Stack"
-- ...this should not interfere with other imports...
ghcStackModuleName :: ModuleName
ghcStackModuleName :: ModuleName
ghcStackModuleName = CommandLineOption -> ModuleName
mkModuleName CommandLineOption
"AutoImported.GHC.Stack"

#if __GLASGOW_HASKELL__ < 810
importDeclQualified :: Bool
importDeclQualified = True
#else
importDeclQualified :: ImportDeclQualifiedStyle
importDeclQualified :: ImportDeclQualifiedStyle
importDeclQualified = ImportDeclQualifiedStyle
QualifiedPre
#endif

ghcStackImport :: Located (ImportDecl (GhcPass p))
ghcStackImport :: Located (ImportDecl (GhcPass p))
ghcStackImport =
  SrcSpanLess (Located (ImportDecl (GhcPass p)))
-> Located (ImportDecl (GhcPass p))
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located (ImportDecl (GhcPass p)))
 -> Located (ImportDecl (GhcPass p)))
-> SrcSpanLess (Located (ImportDecl (GhcPass p)))
-> Located (ImportDecl (GhcPass p))
forall a b. (a -> b) -> a -> b
$
  (ModuleName -> ImportDecl (GhcPass p)
forall (p :: Pass). ModuleName -> ImportDecl (GhcPass p)
simpleImportDecl (ModuleName -> ImportDecl (GhcPass p))
-> ModuleName -> ImportDecl (GhcPass p)
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> ModuleName
mkModuleName CommandLineOption
"GHC.Stack")
    {ideclQualified :: ImportDeclQualifiedStyle
ideclQualified = ImportDeclQualifiedStyle
importDeclQualified, ideclAs :: Maybe (Located ModuleName)
ideclAs = Located ModuleName -> Maybe (Located ModuleName)
forall a. a -> Maybe a
Just (Located ModuleName -> Maybe (Located ModuleName))
-> Located ModuleName -> Maybe (Located ModuleName)
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (Located ModuleName) -> Located ModuleName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located ModuleName)
ModuleName
ghcStackModuleName}

#if __GLASGOW_HASKELL__ >= 900
updateHsModule :: HsModule -> HsModule
#else
updateHsModule :: HsModule GhcPs -> HsModule GhcPs
#endif
updateHsModule :: HsModule GhcPs -> HsModule GhcPs
updateHsModule HsModule GhcPs
hsm =
  HsModule GhcPs
hsm {hsmodImports :: [LImportDecl GhcPs]
hsmodImports = [LImportDecl GhcPs]
hsmodImports', hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = [LHsDecl GhcPs]
hsmodDecls'}
  where
    -- Traverse the haskell AST; if we have to add some HasStack
    -- constraint we set a flag in a (Any,) functor.
    -- ...it'd be simpler to check if before == after, but Haskell AST
    -- doesn't have Eq instances.
    (Bool
updatedP, [LHsDecl GhcPs]
hsmodDecls') =
      (Any -> Bool) -> (Any, [LHsDecl GhcPs]) -> (Bool, [LHsDecl GhcPs])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Any -> Bool
getAny ((Any, [LHsDecl GhcPs]) -> (Bool, [LHsDecl GhcPs]))
-> (Any, [LHsDecl GhcPs]) -> (Bool, [LHsDecl GhcPs])
forall a b. (a -> b) -> a -> b
$
      ((LHsDecl GhcPs -> (Any, LHsDecl GhcPs))
-> [LHsDecl GhcPs] -> (Any, [LHsDecl GhcPs])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((LHsDecl GhcPs -> (Any, LHsDecl GhcPs))
 -> [LHsDecl GhcPs] -> (Any, [LHsDecl GhcPs]))
-> ((HsType GhcPs -> (Any, HsType GhcPs))
    -> LHsDecl GhcPs -> (Any, LHsDecl GhcPs))
-> (HsType GhcPs -> (Any, HsType GhcPs))
-> [LHsDecl GhcPs]
-> (Any, [LHsDecl GhcPs])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType GhcPs -> (Any, HsType GhcPs))
-> LHsDecl GhcPs -> (Any, LHsDecl GhcPs)
Traversal' (LHsDecl GhcPs) (HsType GhcPs)
astTraversal) HsType GhcPs -> (Any, HsType GhcPs)
updateHsType (HsModule GhcPs -> [LHsDecl GhcPs]
forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls HsModule GhcPs
hsm)

    -- Only import GHC.Stack if needed for a constraint we introduced
    hsmodImports' :: [LImportDecl GhcPs]
hsmodImports' =
      (if Bool
updatedP
         then [LImportDecl GhcPs
forall (p :: Pass). Located (ImportDecl (GhcPass p))
ghcStackImport]
         else []) [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++
      HsModule GhcPs -> [LImportDecl GhcPs]
forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports HsModule GhcPs
hsm

    astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
    astTraversal :: (HsType GhcPs -> f (HsType GhcPs))
-> LHsDecl GhcPs -> f (LHsDecl GhcPs)
astTraversal = (HsDecl GhcPs -> f (HsDecl GhcPs))
-> LHsDecl GhcPs -> f (LHsDecl GhcPs)
Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
updateHsmodDecl
                 ((HsDecl GhcPs -> f (HsDecl GhcPs))
 -> LHsDecl GhcPs -> f (LHsDecl GhcPs))
-> ((HsType GhcPs -> f (HsType GhcPs))
    -> HsDecl GhcPs -> f (HsDecl GhcPs))
-> (HsType GhcPs -> f (HsType GhcPs))
-> LHsDecl GhcPs
-> f (LHsDecl GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sig GhcPs -> f (Sig GhcPs)) -> HsDecl GhcPs -> f (HsDecl GhcPs)
Traversal' (HsDecl GhcPs) (Sig GhcPs)
updateHsDecl
                 ((Sig GhcPs -> f (Sig GhcPs)) -> HsDecl GhcPs -> f (HsDecl GhcPs))
-> ((HsType GhcPs -> f (HsType GhcPs))
    -> Sig GhcPs -> f (Sig GhcPs))
-> (HsType GhcPs -> f (HsType GhcPs))
-> HsDecl GhcPs
-> f (HsDecl GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsSigWcType GhcPs -> f (LHsSigWcType GhcPs))
-> Sig GhcPs -> f (Sig GhcPs)
Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
updateSig
                 ((LHsSigWcType GhcPs -> f (LHsSigWcType GhcPs))
 -> Sig GhcPs -> f (Sig GhcPs))
-> ((HsType GhcPs -> f (HsType GhcPs))
    -> LHsSigWcType GhcPs -> f (LHsSigWcType GhcPs))
-> (HsType GhcPs -> f (HsType GhcPs))
-> Sig GhcPs
-> f (Sig GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsSigType GhcPs -> f (LHsSigType GhcPs))
-> LHsSigWcType GhcPs -> f (LHsSigWcType GhcPs)
Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
updateLHsSigWsType
                 ((LHsSigType GhcPs -> f (LHsSigType GhcPs))
 -> LHsSigWcType GhcPs -> f (LHsSigWcType GhcPs))
-> ((HsType GhcPs -> f (HsType GhcPs))
    -> LHsSigType GhcPs -> f (LHsSigType GhcPs))
-> (HsType GhcPs -> f (HsType GhcPs))
-> LHsSigWcType GhcPs
-> f (LHsSigWcType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsType GhcPs -> f (LHsType GhcPs))
-> LHsSigType GhcPs -> f (LHsSigType GhcPs)
Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
updateLHsSigType
                 ((LHsType GhcPs -> f (LHsType GhcPs))
 -> LHsSigType GhcPs -> f (LHsSigType GhcPs))
-> ((HsType GhcPs -> f (HsType GhcPs))
    -> LHsType GhcPs -> f (LHsType GhcPs))
-> (HsType GhcPs -> f (HsType GhcPs))
-> LHsSigType GhcPs
-> f (LHsSigType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType GhcPs -> f (HsType GhcPs))
-> LHsType GhcPs -> f (LHsType GhcPs)
Traversal' (LHsType GhcPs) (HsType GhcPs)
updateLHsType

--------------
updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
updateHsmodDecl :: (HsDecl GhcPs -> f (HsDecl GhcPs))
-> LHsDecl GhcPs -> f (LHsDecl GhcPs)
updateHsmodDecl = (HsDecl GhcPs -> f (HsDecl GhcPs))
-> LHsDecl GhcPs -> f (LHsDecl GhcPs)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse

updateHsDecl :: Traversal' (HsDecl GhcPs) (Sig GhcPs)
updateHsDecl :: (Sig GhcPs -> f (Sig GhcPs)) -> HsDecl GhcPs -> f (HsDecl GhcPs)
updateHsDecl Sig GhcPs -> f (Sig GhcPs)
f (SigD XSigD GhcPs
xSig Sig GhcPs
s) = XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
SigD XSigD GhcPs
xSig (Sig GhcPs -> HsDecl GhcPs) -> f (Sig GhcPs) -> f (HsDecl GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sig GhcPs -> f (Sig GhcPs)
f Sig GhcPs
s
updateHsDecl Sig GhcPs -> f (Sig GhcPs)
_ HsDecl GhcPs
sig = HsDecl GhcPs -> f (HsDecl GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsDecl GhcPs
sig

updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
updateSig :: (LHsSigWcType GhcPs -> f (LHsSigWcType GhcPs))
-> Sig GhcPs -> f (Sig GhcPs)
updateSig LHsSigWcType GhcPs -> f (LHsSigWcType GhcPs)
f (TypeSig XTypeSig GhcPs
xSig [Located (IdP GhcPs)]
ls LHsSigWcType GhcPs
t) = XTypeSig GhcPs
-> [Located (IdP GhcPs)] -> LHsSigWcType GhcPs -> Sig GhcPs
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig GhcPs
xSig [Located (IdP GhcPs)]
ls (LHsSigWcType GhcPs -> Sig GhcPs)
-> f (LHsSigWcType GhcPs) -> f (Sig GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsSigWcType GhcPs -> f (LHsSigWcType GhcPs)
f LHsSigWcType GhcPs
t
updateSig LHsSigWcType GhcPs -> f (LHsSigWcType GhcPs)
_ Sig GhcPs
sig = Sig GhcPs -> f (Sig GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sig GhcPs
sig

updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
updateLHsSigWsType :: (LHsSigType GhcPs -> f (LHsSigType GhcPs))
-> LHsSigWcType GhcPs -> f (LHsSigWcType GhcPs)
updateLHsSigWsType LHsSigType GhcPs -> f (LHsSigType GhcPs)
f lhs :: LHsSigWcType GhcPs
lhs@HsWC {} =
  (\LHsSigType GhcPs
x -> LHsSigWcType GhcPs
lhs {hswc_body :: LHsSigType GhcPs
hswc_body = LHsSigType GhcPs
x}) (LHsSigType GhcPs -> LHsSigWcType GhcPs)
-> f (LHsSigType GhcPs) -> f (LHsSigWcType GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsSigType GhcPs -> f (LHsSigType GhcPs)
f (LHsSigWcType GhcPs -> LHsSigType GhcPs
forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsSigWcType GhcPs
lhs)
#if __GLASGOW_HASKELL__ < 900
updateLHsSigWsType LHsSigType GhcPs -> f (LHsSigType GhcPs)
_ LHsSigWcType GhcPs
lhs = LHsSigWcType GhcPs -> f (LHsSigWcType GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsSigWcType GhcPs
lhs
#endif

updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
updateLHsSigType :: (LHsType GhcPs -> f (LHsType GhcPs))
-> LHsSigType GhcPs -> f (LHsSigType GhcPs)
updateLHsSigType LHsType GhcPs -> f (LHsType GhcPs)
f lhs :: LHsSigType GhcPs
lhs@HsIB {} =
  (\LHsType GhcPs
x -> LHsSigType GhcPs
lhs {hsib_body :: LHsType GhcPs
hsib_body = LHsType GhcPs
x}) (LHsType GhcPs -> LHsSigType GhcPs)
-> f (LHsType GhcPs) -> f (LHsSigType GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcPs -> f (LHsType GhcPs)
f (LHsSigType GhcPs -> LHsType GhcPs
forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body LHsSigType GhcPs
lhs)
#if __GLASGOW_HASKELL__ < 900
updateLHsSigType LHsType GhcPs -> f (LHsType GhcPs)
_ LHsSigType GhcPs
lhs = LHsSigType GhcPs -> f (LHsSigType GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsSigType GhcPs
lhs
#endif

updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
updateLHsType :: (HsType GhcPs -> f (HsType GhcPs))
-> LHsType GhcPs -> f (LHsType GhcPs)
updateLHsType = (HsType GhcPs -> f (HsType GhcPs))
-> LHsType GhcPs -> f (LHsType GhcPs)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse

-- Main process
updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
updateHsType (HsQualTy XQualTy GhcPs
xty LHsContext GhcPs
ctxt LHsType GhcPs
body) =
  HsType GhcPs -> (Any, HsType GhcPs)
forall a. a -> (Any, a)
flagASTModified (HsType GhcPs -> (Any, HsType GhcPs))
-> HsType GhcPs -> (Any, HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XQualTy GhcPs -> LHsContext GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy XQualTy GhcPs
xty ((HsContext GhcPs -> HsContext GhcPs)
-> LHsContext GhcPs -> LHsContext GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsContext GhcPs -> HsContext GhcPs
appendHSC LHsContext GhcPs
ctxt) LHsType GhcPs
body
updateHsType ty :: HsType GhcPs
ty@HsTyVar {} =
  HsType GhcPs -> (Any, HsType GhcPs)
forall a. a -> (Any, a)
flagASTModified (HsType GhcPs -> (Any, HsType GhcPs))
-> HsType GhcPs -> (Any, HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XQualTy GhcPs -> LHsContext GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy NoExtField
XQualTy GhcPs
xQualTy (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs)
-> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a b. (a -> b) -> a -> b
$ HsContext GhcPs -> HsContext GhcPs
appendHSC []) (SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcPs
SrcSpanLess (LHsType GhcPs)
ty)
updateHsType ty :: HsType GhcPs
ty@HsAppTy {} =
  HsType GhcPs -> (Any, HsType GhcPs)
forall a. a -> (Any, a)
flagASTModified (HsType GhcPs -> (Any, HsType GhcPs))
-> HsType GhcPs -> (Any, HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XQualTy GhcPs -> LHsContext GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy NoExtField
XQualTy GhcPs
xQualTy (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs)
-> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a b. (a -> b) -> a -> b
$ HsContext GhcPs -> HsContext GhcPs
appendHSC []) (SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcPs
SrcSpanLess (LHsType GhcPs)
ty)
updateHsType ty :: HsType GhcPs
ty@HsFunTy {} =
  HsType GhcPs -> (Any, HsType GhcPs)
forall a. a -> (Any, a)
flagASTModified (HsType GhcPs -> (Any, HsType GhcPs))
-> HsType GhcPs -> (Any, HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XQualTy GhcPs -> LHsContext GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy NoExtField
XQualTy GhcPs
xQualTy (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs)
-> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a b. (a -> b) -> a -> b
$ HsContext GhcPs -> HsContext GhcPs
appendHSC []) (SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcPs
SrcSpanLess (LHsType GhcPs)
ty)
updateHsType ty :: HsType GhcPs
ty@HsListTy {} =
  HsType GhcPs -> (Any, HsType GhcPs)
forall a. a -> (Any, a)
flagASTModified (HsType GhcPs -> (Any, HsType GhcPs))
-> HsType GhcPs -> (Any, HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XQualTy GhcPs -> LHsContext GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy NoExtField
XQualTy GhcPs
xQualTy (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs)
-> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a b. (a -> b) -> a -> b
$ HsContext GhcPs -> HsContext GhcPs
appendHSC []) (SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcPs
SrcSpanLess (LHsType GhcPs)
ty)
updateHsType ty :: HsType GhcPs
ty@HsTupleTy {} =
  HsType GhcPs -> (Any, HsType GhcPs)
forall a. a -> (Any, a)
flagASTModified (HsType GhcPs -> (Any, HsType GhcPs))
-> HsType GhcPs -> (Any, HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XQualTy GhcPs -> LHsContext GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy NoExtField
XQualTy GhcPs
xQualTy (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs)
-> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a b. (a -> b) -> a -> b
$ HsContext GhcPs -> HsContext GhcPs
appendHSC []) (SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcPs
SrcSpanLess (LHsType GhcPs)
ty)
updateHsType HsType GhcPs
ty = HsType GhcPs -> (Any, HsType GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsType GhcPs
ty

#if __GLASGOW_HASKELL__ < 810
xQualTy :: NoExt
xQualTy = noExt
#else
xQualTy :: NoExtField
xQualTy :: NoExtField
xQualTy = NoExtField
NoExtField
#endif

flagASTModified :: a -> (Any, a)
flagASTModified :: a -> (Any, a)
flagASTModified a
a = (Bool -> Any
Any Bool
True, a
a)

appendHSC :: HsContext GhcPs -> HsContext GhcPs
appendHSC :: HsContext GhcPs -> HsContext GhcPs
appendHSC HsContext GhcPs
cs = LHsType GhcPs
mkHSC LHsType GhcPs -> HsContext GhcPs -> HsContext GhcPs
forall a. a -> [a] -> [a]
: HsContext GhcPs
cs

-- make HasCallStack => constraint
mkHSC :: LHsType GhcPs
mkHSC :: LHsType GhcPs
mkHSC = SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs)
-> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExtField
XTyVar GhcPs
xQualTy PromotionFlag
NotPromoted Located (IdP GhcPs)
lId

lId :: Located (IdP GhcPs)
lId :: Located (IdP GhcPs)
lId = SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located RdrName) -> Located RdrName)
-> SrcSpanLess (Located RdrName) -> Located RdrName
forall a b. (a -> b) -> a -> b
$ ModuleName -> OccName -> RdrName
mkRdrQual ModuleName
ghcStackModuleName (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
mkClsOcc CommandLineOption
"HasCallStack"