{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}

module MonadicBang.Internal where

import Prelude hiding (log)
import Control.Applicative
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Identity
import Control.Carrier.Reader
import Control.Carrier.Writer.Strict
import Control.Carrier.State.Strict
import Control.Carrier.Throw.Either
import Control.Carrier.Lift
import Control.Effect.Sum hiding (L)
import Control.Exception hiding (try, handle, Handler)
import Data.Data
import Data.Foldable
import Data.Functor
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as M
import Data.Monoid
import GHC hiding (Type)
import GHC.Data.Bag
import GHC.Data.Maybe
import GHC.Parser.Errors.Types
import GHC.Plugins hiding (Type, Expr, empty, (<>), panic, try)
import GHC.Types.Error
import GHC.Utils.Monad (concatMapM, whenM)
import Text.Printf

import GHC.Utils.Logger

import MonadicBang.Internal.Effect.Offer
import MonadicBang.Internal.Effect.Uniques
import MonadicBang.Internal.Options
import MonadicBang.Internal.Utils
import MonadicBang.Internal.Error
import MonadicBang.Internal.Effect.Writer.Discard

import Data.Kind
import Data.Coerce

-- We don't care about which file things are from, because the entire AST comes

-- from the same module

data Loc = MkLoc {Loc -> Int
line :: Int, Loc -> Int
col :: Int}
         deriving (Loc -> Loc -> Bool
(Loc -> Loc -> Bool) -> (Loc -> Loc -> Bool) -> Eq Loc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Loc -> Loc -> Bool
== :: Loc -> Loc -> Bool
$c/= :: Loc -> Loc -> Bool
/= :: Loc -> Loc -> Bool
Eq, Eq Loc
Eq Loc =>
(Loc -> Loc -> Ordering)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Loc)
-> (Loc -> Loc -> Loc)
-> Ord Loc
Loc -> Loc -> Bool
Loc -> Loc -> Ordering
Loc -> Loc -> Loc
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Loc -> Loc -> Ordering
compare :: Loc -> Loc -> Ordering
$c< :: Loc -> Loc -> Bool
< :: Loc -> Loc -> Bool
$c<= :: Loc -> Loc -> Bool
<= :: Loc -> Loc -> Bool
$c> :: Loc -> Loc -> Bool
> :: Loc -> Loc -> Bool
$c>= :: Loc -> Loc -> Bool
>= :: Loc -> Loc -> Bool
$cmax :: Loc -> Loc -> Loc
max :: Loc -> Loc -> Loc
$cmin :: Loc -> Loc -> Loc
min :: Loc -> Loc -> Loc
Ord, Int -> Loc -> ShowS
[Loc] -> ShowS
Loc -> String
(Int -> Loc -> ShowS)
-> (Loc -> String) -> ([Loc] -> ShowS) -> Show Loc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Loc -> ShowS
showsPrec :: Int -> Loc -> ShowS
$cshow :: Loc -> String
show :: Loc -> String
$cshowList :: [Loc] -> ShowS
showList :: [Loc] -> ShowS
Show)

type Expr = HsExpr GhcPs
type LExpr = LHsExpr GhcPs

-- | OccSet newtype that allows us to define an orphan Monoid instance

newtype Occs = MkOccs OccSet

instance Semigroup Occs where
  <> :: Occs -> Occs -> Occs
(<>) = (OccSet -> OccSet -> OccSet) -> Occs -> Occs -> Occs
forall a b. Coercible a b => a -> b
coerce OccSet -> OccSet -> OccSet
unionOccSets

instance Monoid Occs where
  mempty :: Occs
mempty = Occs
emptyOccs

emptyOccs :: Occs
emptyOccs :: Occs
emptyOccs = OccSet -> Occs
forall a b. Coercible a b => a -> b
coerce OccSet
emptyOccSet

extendOccs :: Occs -> OccName -> Occs
extendOccs :: Occs -> OccName -> Occs
extendOccs = (OccSet -> OccName -> OccSet) -> Occs -> OccName -> Occs
forall a b. Coercible a b => a -> b
coerce OccSet -> OccName -> OccSet
extendOccSet

elemOccs :: OccName -> Occs -> Bool
elemOccs :: OccName -> Occs -> Bool
elemOccs = (OccName -> OccSet -> Bool) -> OccName -> Occs -> Bool
forall a b. Coercible a b => a -> b
coerce OccName -> OccSet -> Bool
elemOccSet

unitOccs :: OccName -> Occs
unitOccs :: OccName -> Occs
unitOccs = (OccName -> OccSet) -> OccName -> Occs
forall a b. Coercible a b => a -> b
coerce OccName -> OccSet
unitOccSet

-- | To keep track of which local variables in scope may be used

--

-- If local variables are defined within the same statement as a !, but outside

-- of that !, they must not be used within this !, since their desugaring would

-- make them escape their scope.

data InScope = MkInScope {InScope -> Occs
valid :: Occs , InScope -> Occs
invalid :: Occs}

instance Semigroup InScope where
  InScope
a <> :: InScope -> InScope -> InScope
<> InScope
b = MkInScope{$sel:valid:MkInScope :: Occs
valid = InScope
a.valid Occs -> Occs -> Occs
forall a. Semigroup a => a -> a -> a
<> InScope
b.valid, $sel:invalid:MkInScope :: Occs
invalid = InScope
a.invalid Occs -> Occs -> Occs
forall a. Semigroup a => a -> a -> a
<> InScope
b.invalid}

instance Monoid InScope where
  mempty :: InScope
mempty = InScope
noneInScope

noneInScope :: InScope
noneInScope :: InScope
noneInScope = Occs -> Occs -> InScope
MkInScope Occs
emptyOccs Occs
emptyOccs

addValid :: OccName -> InScope -> InScope
addValid :: OccName -> InScope -> InScope
addValid OccName
name InScope
inScope = InScope
inScope{valid = extendOccs inScope.valid name}

addValids :: Occs -> InScope -> InScope
addValids :: Occs -> InScope -> InScope
addValids Occs
names InScope
inScope = InScope
inScope{valid = inScope.valid <> names}

invalidateVars :: InScope -> InScope
invalidateVars :: InScope -> InScope
invalidateVars InScope
inScope = MkInScope{$sel:valid:MkInScope :: Occs
valid = Occs
emptyOccs, $sel:invalid:MkInScope :: Occs
invalid = InScope
inScope.valid Occs -> Occs -> Occs
forall a. Semigroup a => a -> a -> a
<> InScope
inScope.invalid}

isInvalid :: Has (Reader InScope) sig m => OccName -> m Bool
isInvalid :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader InScope) sig m =>
OccName -> m Bool
isInvalid OccName
name = do
  InScope
inScope <- forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask @InScope
  Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ OccName
name OccName -> Occs -> Bool
`elemOccs` InScope
inScope.invalid

-- | Decrement column by one to get the location of a !

bangLoc :: Loc -> Loc
bangLoc :: Loc -> Loc
bangLoc Loc
loc = Loc
loc{col = loc.col - 1}

-- | Decrement start by one column to get the location of a !

bangSpan :: SrcSpan -> SrcSpan
bangSpan :: SrcSpan -> SrcSpan
bangSpan SrcSpan
sp = SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (SrcLoc -> SrcLoc
bangSrcLoc (SrcLoc -> SrcLoc) -> SrcLoc -> SrcLoc
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcLoc
srcSpanStart SrcSpan
sp) (SrcSpan -> SrcLoc
srcSpanEnd SrcSpan
sp)

-- | Decrement column by one to get the location of a !

bangSrcLoc :: SrcLoc -> SrcLoc
bangSrcLoc :: SrcLoc -> SrcLoc
bangSrcLoc = \cases
  l :: SrcLoc
l@(UnhelpfulLoc FastString
_) -> SrcLoc
l
  (RealSrcLoc RealSrcLoc
srcLoc Maybe BufPos
_) -> (FastString -> Int -> Int -> SrcLoc)
-> (RealSrcLoc -> FastString)
-> (RealSrcLoc -> Int)
-> (RealSrcLoc -> Int)
-> RealSrcLoc
-> SrcLoc
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 FastString -> Int -> Int -> SrcLoc
mkSrcLoc RealSrcLoc -> FastString
srcLocFile RealSrcLoc -> Int
srcLocLine (Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> (RealSrcLoc -> Int) -> RealSrcLoc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcLoc -> Int
srcLocCol) RealSrcLoc
srcLoc

-- | Used to extract the Loc of a located expression

pattern ExprLoc :: Loc -> Expr -> LExpr
pattern $mExprLoc :: forall {r}.
LExpr -> (Loc -> HsExpr GhcPs -> r) -> ((# #) -> r) -> r
ExprLoc loc expr <- L (locA -> RealSrcSpan (spanToLoc -> loc) _) expr

spanToLoc :: RealSrcSpan -> Loc
spanToLoc :: RealSrcSpan -> Loc
spanToLoc = (Int -> Int -> Loc)
-> (RealSrcLoc -> Int) -> (RealSrcLoc -> Int) -> RealSrcLoc -> Loc
forall a b c.
(a -> b -> c)
-> (RealSrcLoc -> a) -> (RealSrcLoc -> b) -> RealSrcLoc -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Loc
MkLoc RealSrcLoc -> Int
srcLocLine RealSrcLoc -> Int
srcLocCol (RealSrcLoc -> Loc)
-> (RealSrcSpan -> RealSrcLoc) -> RealSrcSpan -> Loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> RealSrcLoc
realSrcSpanStart

replaceBangs :: [CommandLineOption] -> ModSummary -> Handler Hsc ParsedResult
replaceBangs :: [String] -> ModSummary -> Handler Hsc ParsedResult
replaceBangs [String]
cmdLineOpts ModSummary
_ orig :: ParsedResult
orig@(ParsedResult (HsParsedModule Located (HsModule GhcPs)
mod' [String]
files) PsMessages
msgs)
  | Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> Bool
forall a. Map Loc a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fills = Handler Hsc ParsedResult
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedResult
orig
  | Bool
otherwise = do
    Options
options <- IO Options -> Hsc Options
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Options -> Hsc Options)
-> (ThrowC ErrorCall IO Options -> IO Options)
-> ThrowC ErrorCall IO Options
-> Hsc Options
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ErrorCall -> IO Options)
-> (Options -> IO Options)
-> Either ErrorCall Options
-> IO Options
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorCall -> IO Options
forall e a. Exception e => e -> IO a
throwIO Options -> IO Options
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure =<<) (IO (Either ErrorCall Options) -> IO Options)
-> (ThrowC ErrorCall IO Options -> IO (Either ErrorCall Options))
-> ThrowC ErrorCall IO Options
-> IO Options
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow @ErrorCall (ThrowC ErrorCall IO Options -> Hsc Options)
-> ThrowC ErrorCall IO Options -> Hsc Options
forall a b. (a -> b) -> a -> b
$ Located (HsModule GhcPs) -> [String] -> ThrowC ErrorCall IO Options
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw ErrorCall) sig m =>
Located (HsModule GhcPs) -> [String] -> m Options
parseOptions Located (HsModule GhcPs)
mod' [String]
cmdLineOpts
    DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    (Messages PsError
newErrors, Located (HsModule GhcPs)
mod'') <-
      LiftC Hsc (Messages PsError, Located (HsModule GhcPs))
-> Hsc (Messages PsError, Located (HsModule GhcPs))
forall (m :: * -> *) a. LiftC m a -> m a
runM (LiftC Hsc (Messages PsError, Located (HsModule GhcPs))
 -> Hsc (Messages PsError, Located (HsModule GhcPs)))
-> (ReaderC
      DynFlags
      (DiscardC
         Occs
         (ReaderC
            InScope
            (ReaderC
               Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
      (Located (HsModule GhcPs))
    -> LiftC Hsc (Messages PsError, Located (HsModule GhcPs)))
-> ReaderC
     DynFlags
     (DiscardC
        Occs
        (ReaderC
           InScope
           (ReaderC
              Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
     (Located (HsModule GhcPs))
-> Hsc (Messages PsError, Located (HsModule GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Char
-> UniquesC
     (LiftC Hsc) (Messages PsError, Located (HsModule GhcPs))
-> LiftC Hsc (Messages PsError, Located (HsModule GhcPs))
forall (m :: * -> *) a. MonadIO m => Char -> UniquesC m a -> m a
runUniquesIO Char
'p' (UniquesC (LiftC Hsc) (Messages PsError, Located (HsModule GhcPs))
 -> LiftC Hsc (Messages PsError, Located (HsModule GhcPs)))
-> (ReaderC
      DynFlags
      (DiscardC
         Occs
         (ReaderC
            InScope
            (ReaderC
               Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
      (Located (HsModule GhcPs))
    -> UniquesC
         (LiftC Hsc) (Messages PsError, Located (HsModule GhcPs)))
-> ReaderC
     DynFlags
     (DiscardC
        Occs
        (ReaderC
           InScope
           (ReaderC
              Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
     (Located (HsModule GhcPs))
-> LiftC Hsc (Messages PsError, Located (HsModule GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      WriterC
  (Messages PsError)
  (UniquesC (LiftC Hsc))
  (Located (HsModule GhcPs))
-> UniquesC
     (LiftC Hsc) (Messages PsError, Located (HsModule GhcPs))
forall w (m :: * -> *) a. Monoid w => WriterC w m a -> m (w, a)
runWriter (WriterC
   (Messages PsError)
   (UniquesC (LiftC Hsc))
   (Located (HsModule GhcPs))
 -> UniquesC
      (LiftC Hsc) (Messages PsError, Located (HsModule GhcPs)))
-> (ReaderC
      DynFlags
      (DiscardC
         Occs
         (ReaderC
            InScope
            (ReaderC
               Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
      (Located (HsModule GhcPs))
    -> WriterC
         (Messages PsError)
         (UniquesC (LiftC Hsc))
         (Located (HsModule GhcPs)))
-> ReaderC
     DynFlags
     (DiscardC
        Occs
        (ReaderC
           InScope
           (ReaderC
              Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
     (Located (HsModule GhcPs))
-> UniquesC
     (LiftC Hsc) (Messages PsError, Located (HsModule GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Options
-> ReaderC
     Options
     (WriterC (Messages PsError) (UniquesC (LiftC Hsc)))
     (Located (HsModule GhcPs))
-> WriterC
     (Messages PsError)
     (UniquesC (LiftC Hsc))
     (Located (HsModule GhcPs))
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader Options
options (ReaderC
   Options
   (WriterC (Messages PsError) (UniquesC (LiftC Hsc)))
   (Located (HsModule GhcPs))
 -> WriterC
      (Messages PsError)
      (UniquesC (LiftC Hsc))
      (Located (HsModule GhcPs)))
-> (ReaderC
      DynFlags
      (DiscardC
         Occs
         (ReaderC
            InScope
            (ReaderC
               Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
      (Located (HsModule GhcPs))
    -> ReaderC
         Options
         (WriterC (Messages PsError) (UniquesC (LiftC Hsc)))
         (Located (HsModule GhcPs)))
-> ReaderC
     DynFlags
     (DiscardC
        Occs
        (ReaderC
           InScope
           (ReaderC
              Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
     (Located (HsModule GhcPs))
-> WriterC
     (Messages PsError)
     (UniquesC (LiftC Hsc))
     (Located (HsModule GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      InScope
-> ReaderC
     InScope
     (ReaderC
        Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))
     (Located (HsModule GhcPs))
-> ReaderC
     Options
     (WriterC (Messages PsError) (UniquesC (LiftC Hsc)))
     (Located (HsModule GhcPs))
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader InScope
noneInScope (ReaderC
   InScope
   (ReaderC
      Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))
   (Located (HsModule GhcPs))
 -> ReaderC
      Options
      (WriterC (Messages PsError) (UniquesC (LiftC Hsc)))
      (Located (HsModule GhcPs)))
-> (ReaderC
      DynFlags
      (DiscardC
         Occs
         (ReaderC
            InScope
            (ReaderC
               Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
      (Located (HsModule GhcPs))
    -> ReaderC
         InScope
         (ReaderC
            Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))
         (Located (HsModule GhcPs)))
-> ReaderC
     DynFlags
     (DiscardC
        Occs
        (ReaderC
           InScope
           (ReaderC
              Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
     (Located (HsModule GhcPs))
-> ReaderC
     Options
     (WriterC (Messages PsError) (UniquesC (LiftC Hsc)))
     (Located (HsModule GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall w (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Monoid w, Algebra sig m) =>
DiscardC w m a -> m a
evalWriter @Occs (DiscardC
   Occs
   (ReaderC
      InScope
      (ReaderC
         Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc)))))
   (Located (HsModule GhcPs))
 -> ReaderC
      InScope
      (ReaderC
         Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))
      (Located (HsModule GhcPs)))
-> (ReaderC
      DynFlags
      (DiscardC
         Occs
         (ReaderC
            InScope
            (ReaderC
               Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
      (Located (HsModule GhcPs))
    -> DiscardC
         Occs
         (ReaderC
            InScope
            (ReaderC
               Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc)))))
         (Located (HsModule GhcPs)))
-> ReaderC
     DynFlags
     (DiscardC
        Occs
        (ReaderC
           InScope
           (ReaderC
              Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
     (Located (HsModule GhcPs))
-> ReaderC
     InScope
     (ReaderC
        Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))
     (Located (HsModule GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      DynFlags
-> ReaderC
     DynFlags
     (DiscardC
        Occs
        (ReaderC
           InScope
           (ReaderC
              Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
     (Located (HsModule GhcPs))
-> DiscardC
     Occs
     (ReaderC
        InScope
        (ReaderC
           Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc)))))
     (Located (HsModule GhcPs))
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader DynFlags
dflags (ReaderC
   DynFlags
   (DiscardC
      Occs
      (ReaderC
         InScope
         (ReaderC
            Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
   (Located (HsModule GhcPs))
 -> Hsc (Messages PsError, Located (HsModule GhcPs)))
-> ReaderC
     DynFlags
     (DiscardC
        Occs
        (ReaderC
           InScope
           (ReaderC
              Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc))))))
     (Located (HsModule GhcPs))
-> Hsc (Messages PsError, Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$
      Map Loc LExpr
-> Handler
     (ReaderC
        DynFlags
        (DiscardC
           Occs
           (ReaderC
              InScope
              (ReaderC
                 Options (WriterC (Messages PsError) (UniquesC (LiftC Hsc)))))))
     (Located (HsModule GhcPs))
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Data a,
 Has
   (Writer (Messages PsError)
    :+: (Reader Options
         :+: (Uniques :+: (LocalVars :+: Reader DynFlags))))
   sig
   m) =>
Map Loc LExpr -> Handler m a
fillHoles Map Loc LExpr
Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fills Located (HsModule GhcPs)
mod'
    Verbosity -> SDoc -> Hsc ()
log Options
options.verbosity (Located (HsModule GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (HsModule GhcPs)
mod'')
    Handler Hsc ParsedResult
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handler Hsc ParsedResult -> Handler Hsc ParsedResult
forall a b. (a -> b) -> a -> b
$ HsParsedModule -> PsMessages -> ParsedResult
ParsedResult (Located (HsModule GhcPs) -> [String] -> HsParsedModule
HsParsedModule Located (HsModule GhcPs)
mod'' [String]
files) PsMessages
msgs{psErrors = oldErrors <> newErrors}
  where
    log :: Verbosity -> SDoc -> Hsc ()
log = \cases
      Verbosity
Quiet SDoc
_ -> () -> Hsc ()
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Verbosity
DumpTransformed SDoc
m -> do
        Logger
logger <- Hsc Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
        IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
MCInfo (UnhelpfulSpanReason -> SrcSpan
UnhelpfulSpan UnhelpfulSpanReason
UnhelpfulNoLocationInfo) SDoc
m

    -- Extract the errors we care about, throw the rest back in

    (Bag (MsgEnvelope PsError) -> Messages PsError
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages -> Messages PsError
oldErrors, [(Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
 -> Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (Bag (Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs))
    -> [(Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> Bag (Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [(Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a. Bag a -> [a]
bagToList -> Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fills) =
      ((MsgEnvelope PsError
 -> Either
      (MsgEnvelope PsError) (Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Bag (MsgEnvelope PsError)
-> (Bag (MsgEnvelope PsError),
    Bag (Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b c. (a -> Either b c) -> Bag a -> (Bag b, Bag c)
partitionBagWith ((MsgEnvelope PsError
  -> Either
       (MsgEnvelope PsError) (Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> Bag (MsgEnvelope PsError)
 -> (Bag (MsgEnvelope PsError),
     Bag (Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Bag (MsgEnvelope PsError)
-> (MsgEnvelope PsError
    -> Either
         (MsgEnvelope PsError) (Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (Bag (MsgEnvelope PsError),
    Bag (Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? PsMessages
msgs.psErrors.getMessages) \cases
        MsgEnvelope PsError
err | PsErrBangPatWithoutSpace lexpr :: LExpr
lexpr@(ExprLoc (Loc -> Loc
bangLoc -> Loc
loc) HsExpr GhcPs
_) <- MsgEnvelope PsError
err.errMsgDiagnostic
            -> (Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Either
     (MsgEnvelope PsError) (Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. b -> Either a b
Right (Loc
loc, LExpr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
lexpr)
            | Bool
otherwise -> MsgEnvelope PsError
-> Either
     (MsgEnvelope PsError) (Loc, GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. a -> Either a b
Left MsgEnvelope PsError
err
                  
type HandleFailure :: Bool -> (Type -> Type) -> (Type -> Type)
type family HandleFailure canFail = t | t -> canFail where
  HandleFailure True = MaybeT
  HandleFailure False = IdentityT

class MonadTrans t => HandlingMonadTrans t where
  toMaybeT :: Monad m => t m a -> MaybeT m a

instance HandlingMonadTrans IdentityT where
  toMaybeT :: forall (m :: * -> *) a. Monad m => IdentityT m a -> MaybeT m a
toMaybeT = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe a) -> MaybeT m a)
-> (IdentityT m a -> m (Maybe a)) -> IdentityT m a -> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> m a -> m (Maybe a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (m a -> m (Maybe a))
-> (IdentityT m a -> m a) -> IdentityT m a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentityT m a -> m a
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT 

instance HandlingMonadTrans MaybeT where
  toMaybeT :: forall (m :: * -> *) a. Monad m => MaybeT m a -> MaybeT m a
toMaybeT = MaybeT m a -> MaybeT m a
forall a. a -> a
id

class Typeable (AstType a) => Handle a where
  type CanFail a :: Bool
  type AstType a = (r :: Type) | r -> a
  type Effects a :: (Type -> Type) -> Type -> Type
  handle' :: forall sig m m' . m ~ HandleFailure (CanFail a) m' => Has (Effects a) sig m' => Handler m (AstType a)

handle :: forall a sig m . (Handle a, CanFail a ~ False) => Has (Effects a) sig m => Handler m (AstType a)
handle :: forall {k} (a :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Handle a, CanFail a ~ 'False, Has (Effects a) sig m) =>
Handler m (AstType a)
handle = IdentityT m (AstType a) -> m (AstType a)
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT (IdentityT m (AstType a) -> m (AstType a))
-> (AstType a -> IdentityT m (AstType a))
-> AstType a
-> m (AstType a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstType a -> IdentityT m (AstType a)
forall {k} (a :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *)
       (m' :: * -> *).
(Handle a, m ~ HandleFailure (CanFail a) m',
 Has (Effects a) sig m') =>
Handler m (AstType a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *).
(m ~ HandleFailure (CanFail a) m', Has (Effects a) sig m') =>
Handler m (AstType a)
handle'

try :: forall e sig m a .
       (HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a, Handle e, Monad m, Has (Effects e) sig m) =>
       Try m a
try :: forall {k} (e :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a,
 Handle e, Monad m, Has (Effects e) sig m) =>
Try m a
try a
x = do
  a :~: AstType e
Refl <- Maybe (a :~: AstType e) -> MaybeT m (a :~: AstType e)
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe (Maybe (a :~: AstType e) -> MaybeT m (a :~: AstType e))
-> Maybe (a :~: AstType e) -> MaybeT m (a :~: AstType e)
forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @a @(AstType e)
  HandleFailure (CanFail e) m a -> MaybeT m a
forall (m :: * -> *) a.
Monad m =>
HandleFailure (CanFail e) m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(HandlingMonadTrans t, Monad m) =>
t m a -> MaybeT m a
toMaybeT (HandleFailure (CanFail e) m a -> MaybeT m a)
-> HandleFailure (CanFail e) m a -> MaybeT m a
forall a b. (a -> b) -> a -> b
$ Handler (HandleFailure (CanFail e) m) (AstType e)
forall {k} (a :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *)
       (m' :: * -> *).
(Handle a, m ~ HandleFailure (CanFail a) m',
 Has (Effects a) sig m') =>
Handler m (AstType a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *).
(m ~ HandleFailure (CanFail e) m', Has (Effects e) sig m') =>
Handler m (AstType e)
handle' a
AstType e
x

instance Handle GRHSs where
  type CanFail GRHSs = False
  type AstType GRHSs = GRHSs GhcPs LExpr
  type Effects GRHSs = Fill
  handle' :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *).
(m ~ HandleFailure (CanFail GRHSs) m',
 Has (Effects GRHSs) sig m') =>
Handler m (AstType GRHSs)
handle' AstType GRHSs
grhss = do
    InScope
patVars <- forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask @InScope
    HsLocalBinds GhcPs
grhssLocalBinds <- (InScope -> InScope)
-> m (HsLocalBinds GhcPs) -> m (HsLocalBinds GhcPs)
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Reader r) sig m =>
(r -> r) -> m a -> m a
local (InScope -> InScope -> InScope
forall a. Semigroup a => a -> a -> a
<> InScope
patVars) (m (HsLocalBinds GhcPs) -> m (HsLocalBinds GhcPs))
-> m (HsLocalBinds GhcPs) -> m (HsLocalBinds GhcPs)
forall a b. (a -> b) -> a -> b
$ Handler m (HsLocalBinds GhcPs)
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Fill sig m, Data a) =>
Handler m a
evac GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
AstType GRHSs
grhss.grhssLocalBinds
    [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
grhssGRHSs <- InScope
-> StateC
     InScope
     m
     [GenLocated
        (SrcAnn NoEpAnns)
        (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        (SrcAnn NoEpAnns)
        (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState InScope
patVars (StateC
   InScope
   m
   [GenLocated
      (SrcAnn NoEpAnns)
      (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> m [GenLocated
         (SrcAnn NoEpAnns)
         (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> StateC
     InScope
     m
     [GenLocated
        (SrcAnn NoEpAnns)
        (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        (SrcAnn NoEpAnns)
        (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ Handler
  (StateC InScope m)
  [GenLocated
     (SrcAnn NoEpAnns)
     (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a (m :: * -> *) (sig :: (* -> *) -> * -> *).
(Has (Fill :+: State InScope) sig m, Data a) =>
Handler m a
evacPats GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
AstType GRHSs
grhss.grhssGRHSs
    GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AstType GRHSs
grhss{grhssGRHSs, grhssLocalBinds}

instance Handle MatchGroup where
  type CanFail MatchGroup = False
  type AstType MatchGroup = MatchGroup GhcPs LExpr
  type Effects MatchGroup = Fill
  handle' :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *).
(m ~ HandleFailure (CanFail MatchGroup) m',
 Has (Effects MatchGroup) sig m') =>
Handler m (AstType MatchGroup)
handle' AstType MatchGroup
mg = do
    GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (AstType Match)]
mg_alts <- (([GenLocated SrcSpanAnnA (AstType Match)]
 -> m [GenLocated SrcSpanAnnA (AstType Match)])
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (AstType Match)]
-> m (GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (AstType Match)])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> GenLocated SrcSpanAnnL a -> f (GenLocated SrcSpanAnnL b)
traverse (([GenLocated SrcSpanAnnA (AstType Match)]
  -> m [GenLocated SrcSpanAnnA (AstType Match)])
 -> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (AstType Match)]
 -> m (GenLocated
         SrcSpanAnnL [GenLocated SrcSpanAnnA (AstType Match)]))
-> ((AstType Match -> m (AstType Match))
    -> [GenLocated SrcSpanAnnA (AstType Match)]
    -> m [GenLocated SrcSpanAnnA (AstType Match)])
-> (AstType Match -> m (AstType Match))
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (AstType Match)]
-> m (GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (AstType Match)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (AstType Match)
 -> m (GenLocated SrcSpanAnnA (AstType Match)))
-> [GenLocated SrcSpanAnnA (AstType Match)]
-> m [GenLocated SrcSpanAnnA (AstType Match)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((GenLocated SrcSpanAnnA (AstType Match)
  -> m (GenLocated SrcSpanAnnA (AstType Match)))
 -> [GenLocated SrcSpanAnnA (AstType Match)]
 -> m [GenLocated SrcSpanAnnA (AstType Match)])
-> ((AstType Match -> m (AstType Match))
    -> GenLocated SrcSpanAnnA (AstType Match)
    -> m (GenLocated SrcSpanAnnA (AstType Match)))
-> (AstType Match -> m (AstType Match))
-> [GenLocated SrcSpanAnnA (AstType Match)]
-> m [GenLocated SrcSpanAnnA (AstType Match)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AstType Match -> m (AstType Match))
-> GenLocated SrcSpanAnnA (AstType Match)
-> m (GenLocated SrcSpanAnnA (AstType Match))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> GenLocated SrcSpanAnnA a -> f (GenLocated SrcSpanAnnA b)
traverse) AstType Match -> m (AstType Match)
forall {k} (a :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Handle a, CanFail a ~ 'False, Has (Effects a) sig m) =>
Handler m (AstType a)
handle MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
AstType MatchGroup
mg.mg_alts
    MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AstType MatchGroup
mg{mg_alts}

instance Handle Match where
  type CanFail Match = False
  type AstType Match = Match GhcPs LExpr
  type Effects Match = Fill
  handle' :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *).
(m ~ HandleFailure (CanFail Match) m',
 Has (Effects Match) sig m') =>
Handler m (AstType Match)
handle' AstType Match
match = do
    -- We use the State to keep track of the bindings that have been

    -- introduced in patterns to the left of the one we're currently looking

    -- at. Example:

    --

    -- > \a (Just [b, (+ b) -> d]) (foldr a b -> c) | Just f <- b, f == 24

    --

    -- the view pattern on `c` has access to the variables to the left of it. The same applies to `d`.

    -- `f == 24` additionally has access to variables defined in the guard to its left.

    (InScope
patVars, [GenLocated SrcSpanAnnA (Pat GhcPs)]
m_pats) <- forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask @InScope m InScope
-> (InScope -> m (InScope, [GenLocated SrcSpanAnnA (Pat GhcPs)]))
-> m (InScope, [GenLocated SrcSpanAnnA (Pat GhcPs)])
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InScope
-> StateC
     InScope (IdentityT m') [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> IdentityT m' (InScope, [GenLocated SrcSpanAnnA (Pat GhcPs)])
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState (InScope
 -> StateC
      InScope (IdentityT m') [GenLocated SrcSpanAnnA (Pat GhcPs)]
 -> IdentityT m' (InScope, [GenLocated SrcSpanAnnA (Pat GhcPs)]))
-> StateC
     InScope (IdentityT m') [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> InScope
-> IdentityT m' (InScope, [GenLocated SrcSpanAnnA (Pat GhcPs)])
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? Handler
  (StateC InScope (IdentityT m'))
  [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a (m :: * -> *) (sig :: (* -> *) -> * -> *).
(Has (Fill :+: State InScope) sig m, Data a) =>
Handler m a
evacPats Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
AstType Match
match.m_pats
    GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss <- (InScope -> InScope)
-> m (GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m (GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Reader r) sig m =>
(r -> r) -> m a -> m a
local (InScope -> InScope -> InScope
forall a. Semigroup a => a -> a -> a
<> InScope
patVars) (m (GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> m (GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> m (GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m (GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ Handler m (AstType GRHSs)
forall {k} (a :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Handle a, CanFail a ~ 'False, Has (Effects a) sig m) =>
Handler m (AstType a)
handle Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
AstType Match
match.m_grhss
    Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AstType Match
match{m_pats, m_grhss}

-- | We keep track of any local binds, to prevent the user from using them

-- with ! in situations where they would be evacuated to a place where

-- they're not in scope

--

-- The plugin would still work without this, but might accept programs that

-- shouldn't be accepted, with unexpected semantics. E.g:

--

-- > do let s = pure "outer"

-- >    let s = pure "inner" in putStrLn !s

--

-- You might expect this to print `inner`, but it would actually print

-- `outer`, since it would be desugared to

--

-- > do let s = pure "outer"

-- >    <!s> <- s

-- >    let s = pure "inner" in print <!s>

--

-- With this function, the plugin will instead throw an error saying that

-- `s` cannot be used here.

--

-- If the first `s` weren't defined, the user would, without this function,

-- get an error saying that `s` is not in scope, at the call site. Here,

-- we instead throw a more informative error.

--

-- If only the first `s` were defined, i.e.

--

-- > do let s = pure "outer"

-- >    putStrLn !s

--

-- it would be valid code.


instance Handle HsBindLR where
  type CanFail HsBindLR = True
  type AstType HsBindLR = HsBindLR GhcPs GhcPs
  type Effects HsBindLR = Fill
  handle' :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *).
(m ~ HandleFailure (CanFail HsBindLR) m',
 Has (Effects HsBindLR) sig m') =>
Handler m (AstType HsBindLR)
handle' AstType HsBindLR
bind = case AstType HsBindLR
bind of
    FunBind{fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName (RdrName -> OccName)
-> (GenLocated SrcSpanAnnN RdrName -> RdrName)
-> GenLocated SrcSpanAnnN RdrName
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc -> OccName
name, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcPs LExpr
matches} -> do
      OccName -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Writer Occs) sig m =>
OccName -> m ()
tellLocalVar OccName
name
      AstType MatchGroup
fun_matches <- (InScope -> InScope)
-> m (AstType MatchGroup) -> m (AstType MatchGroup)
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Reader r) sig m =>
(r -> r) -> m a -> m a
local (OccName -> InScope -> InScope
addValid OccName
name) (m (AstType MatchGroup) -> m (AstType MatchGroup))
-> m (AstType MatchGroup) -> m (AstType MatchGroup)
forall a b. (a -> b) -> a -> b
$ Handler m (AstType MatchGroup)
forall {k} (a :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Handle a, CanFail a ~ 'False, Has (Effects a) sig m) =>
Handler m (AstType a)
handle MatchGroup GhcPs LExpr
AstType MatchGroup
matches
      HsBindLR GhcPs GhcPs -> m (HsBindLR GhcPs GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AstType HsBindLR
bind{fun_matches}
    PatBind{pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = XRec GhcPs (Pat GhcPs)
lhs, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcPs LExpr
rhs} -> do
      (InScope
binds, GenLocated SrcSpanAnnA (Pat GhcPs)
pat_lhs) <- forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask @InScope m InScope
-> (InScope -> m (InScope, GenLocated SrcSpanAnnA (Pat GhcPs)))
-> m (InScope, GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (InScope
 -> StateC InScope m (GenLocated SrcSpanAnnA (Pat GhcPs))
 -> m (InScope, GenLocated SrcSpanAnnA (Pat GhcPs)))
-> StateC InScope m (GenLocated SrcSpanAnnA (Pat GhcPs))
-> InScope
-> m (InScope, GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b c. (a -> b -> c) -> b -> a -> c
flip InScope
-> StateC InScope m (GenLocated SrcSpanAnnA (Pat GhcPs))
-> m (InScope, GenLocated SrcSpanAnnA (Pat GhcPs))
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState ((Pat GhcPs -> StateC InScope m (Pat GhcPs))
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> StateC InScope m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> GenLocated SrcSpanAnnA a -> f (GenLocated SrcSpanAnnA b)
traverse Pat GhcPs -> StateC InScope m (Pat GhcPs)
forall a (m :: * -> *) (sig :: (* -> *) -> * -> *).
(Has (Fill :+: State InScope) sig m, Data a) =>
Handler m a
evacPats XRec GhcPs (Pat GhcPs)
GenLocated SrcSpanAnnA (Pat GhcPs)
lhs)
      AstType GRHSs
pat_rhs <- (InScope -> InScope) -> m (AstType GRHSs) -> m (AstType GRHSs)
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Reader r) sig m =>
(r -> r) -> m a -> m a
local (InScope -> InScope -> InScope
forall a. Semigroup a => a -> a -> a
<> InScope
binds) (m (AstType GRHSs) -> m (AstType GRHSs))
-> m (AstType GRHSs) -> m (AstType GRHSs)
forall a b. (a -> b) -> a -> b
$ Handler m (AstType GRHSs)
forall {k} (a :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Handle a, CanFail a ~ 'False, Has (Effects a) sig m) =>
Handler m (AstType a)
handle GRHSs GhcPs LExpr
AstType GRHSs
rhs
      HsBindLR GhcPs GhcPs -> m (HsBindLR GhcPs GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AstType HsBindLR
bind{pat_lhs, pat_rhs}
    -- All VarBinds are introduced by the type checker, but we might as well handle them

    VarBind{var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id = IdP GhcPs -> OccName
RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName -> OccName
name, var_rhs :: forall idL idR. HsBindLR idL idR -> LHsExpr idR
var_rhs = LExpr
expr} -> do
      OccName -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Writer Occs) sig m =>
OccName -> m ()
tellLocalVar OccName
name
      GenLocated SrcSpanAnnA (HsExpr GhcPs)
var_rhs <- (InScope -> InScope)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Reader r) sig m =>
(r -> r) -> m a -> m a
local (OccName -> InScope -> InScope
addValid OccName
name) (m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Handler m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Fill sig m, Data a) =>
Handler m a
evac LExpr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
      HsBindLR GhcPs GhcPs -> m (HsBindLR GhcPs GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AstType HsBindLR
bind{var_rhs}
    -- Pattern synonyms can never appear inside of do blocks, so we don't have

    -- to handle them specially

    PatSynBind{} -> m (HsBindLR GhcPs GhcPs)
m (AstType HsBindLR)
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty

instance Handle Pat where
  type CanFail Pat = True
  type AstType Pat = Pat GhcPs
  type Effects Pat = Fill :+: State InScope
  handle' :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *).
(m ~ HandleFailure (CanFail Pat) m', Has (Effects Pat) sig m') =>
Handler m (AstType Pat)
handle' = \case
    VarPat XVarPat GhcPs
xv LIdP GhcPs
name -> GenLocated SrcSpanAnnN RdrName -> m ()
forall {m :: * -> *} {b} {sig :: (* -> *) -> * -> *} {l}.
(HasOccName b, Member (State InScope) sig,
 Member (Writer Occs) sig, Algebra sig m) =>
GenLocated l b -> m ()
tellName LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name m () -> Pat GhcPs -> m (Pat GhcPs)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> XVarPat GhcPs -> LIdP GhcPs -> Pat GhcPs
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcPs
xv LIdP GhcPs
name
#if MIN_VERSION_ghc(9,10,0)
    AsPat xa name pat -> do
      tellName name
      AsPat xa name <$> traverse (liftMaybeT . evacPats) pat
#elif MIN_VERSION_ghc(9,6,0)
    AsPat XAsPat GhcPs
xa LIdP GhcPs
name LHsToken "@" GhcPs
tok XRec GhcPs (Pat GhcPs)
pat -> do
      GenLocated SrcSpanAnnN RdrName -> m ()
forall {m :: * -> *} {b} {sig :: (* -> *) -> * -> *} {l}.
(HasOccName b, Member (State InScope) sig,
 Member (Writer Occs) sig, Algebra sig m) =>
GenLocated l b -> m ()
tellName LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
name
      XAsPat GhcPs
-> LIdP GhcPs
-> LHsToken "@" GhcPs
-> XRec GhcPs (Pat GhcPs)
-> Pat GhcPs
forall p. XAsPat p -> LIdP p -> LHsToken "@" p -> LPat p -> Pat p
AsPat XAsPat GhcPs
xa LIdP GhcPs
name LHsToken "@" GhcPs
tok (GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs)
-> m (GenLocated SrcSpanAnnA (Pat GhcPs)) -> m (Pat GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat GhcPs -> m (Pat GhcPs))
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> GenLocated SrcSpanAnnA a -> f (GenLocated SrcSpanAnnA b)
traverse (m' (Pat GhcPs) -> m (Pat GhcPs)
m' (Pat GhcPs) -> MaybeT m' (Pat GhcPs)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (m' (Pat GhcPs) -> m (Pat GhcPs))
-> (Pat GhcPs -> m' (Pat GhcPs)) -> Pat GhcPs -> m (Pat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat GhcPs -> m' (Pat GhcPs)
forall a (m :: * -> *) (sig :: (* -> *) -> * -> *).
(Has (Fill :+: State InScope) sig m, Data a) =>
Handler m a
evacPats) XRec GhcPs (Pat GhcPs)
GenLocated SrcSpanAnnA (Pat GhcPs)
pat
#else
    AsPat xa name pat -> do
      tellName name
      AsPat xa name <$> traverse (liftMaybeT . evacPats) pat
#endif

    AstType Pat
_ -> m (Pat GhcPs)
m (AstType Pat)
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty
    where
      tellName :: GenLocated l b -> m ()
tellName (b -> OccName
forall name. HasOccName name => name -> OccName
occName (b -> OccName)
-> (GenLocated l b -> b) -> GenLocated l b -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated l b -> b
forall l e. GenLocated l e -> e
unLoc -> OccName
name) = do
        OccName -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Writer Occs) sig m =>
OccName -> m ()
tellLocalVar OccName
name
        (InScope -> InScope) -> m ()
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
(s -> s) -> m ()
modify ((InScope -> InScope) -> m ()) -> (InScope -> InScope) -> m ()
forall a b. (a -> b) -> a -> b
$ OccName -> InScope -> InScope
addValid OccName
name

instance Handle HsExpr where
  type CanFail HsExpr = True
  type AstType HsExpr = GenLocated SrcSpanAnnA Expr
  type Effects HsExpr = Fill
  handle' :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *).
(m ~ HandleFailure (CanFail HsExpr) m',
 Has (Effects HsExpr) sig m') =>
Handler m (AstType HsExpr)
handle' e :: AstType HsExpr
e@(L SrcSpanAnnA
l HsExpr GhcPs
_) = do
    ExprLoc Loc
loc HsExpr GhcPs
expr <- GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsExpr GhcPs)
AstType HsExpr
e
    case HsExpr GhcPs
expr of
      -- Replace holes resulting from `!`

      -- If no corresponding expression can be found in the Offer, we assume

      -- that it was a hole put there by the user and leave it unmodified

      HsUnboundVar XUnboundVar GhcPs
_ RdrName
_ -> Loc -> m (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall k v (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Offer k v) sig m =>
k -> m (Maybe v)
yoink Loc
loc m (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsExpr GhcPs)
AstType HsExpr
e) \GenLocated SrcSpanAnnA (HsExpr GhcPs)
lexpr -> do
        -- all existing valid local variables now become invalid, since using

        -- them would make them escape their scope

        GenLocated SrcSpanAnnA (HsExpr GhcPs)
lexpr' <- (InScope -> InScope)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Reader r) sig m =>
(r -> r) -> m a -> m a
local InScope -> InScope
invalidateVars (m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Fill sig m, Data a) =>
Handler m a
evac GenLocated SrcSpanAnnA (HsExpr GhcPs)
lexpr
        RdrName
name <- LExpr -> Loc -> m RdrName
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Uniques :+: Reader DynFlags) sig m =>
LExpr -> Loc -> m RdrName
bangVar LExpr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
lexpr' Loc
loc
        BindStmt -> m ()
forall w (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Writer (DList w)) sig m =>
w -> m ()
tellOne (BindStmt -> m ()) -> BindStmt -> m ()
forall a b. (a -> b) -> a -> b
$ RdrName
name RdrName -> LExpr -> BindStmt
:<- LExpr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
lexpr'
        GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsExpr GhcPs -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> HsExpr GhcPs -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> LIdP GhcPs -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcPs
NoExtField
noExtField (RdrName -> GenLocated SrcSpanAnnN RdrName
forall a an. a -> LocatedAn an a
noLocA RdrName
name)
      HsVar XVar GhcPs
_ (RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName (RdrName -> OccName)
-> (GenLocated SrcSpanAnnN RdrName -> RdrName)
-> GenLocated SrcSpanAnnN RdrName
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc -> OccName
name) -> do
        m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (OccName -> m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader InScope) sig m =>
OccName -> m Bool
isInvalid OccName
name) do PsError -> SrcSpan -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Writer (Messages PsError)) sig m =>
PsError -> SrcSpan -> m ()
tellPsError (Error -> PsError
customError (Error -> PsError) -> Error -> PsError
forall a b. (a -> b) -> a -> b
$ OccName -> Error
ErrOutOfScopeVariable OccName
name) (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)
        GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsExpr GhcPs)
AstType HsExpr
e
      -- In HsDo, we can discard all in-scope variables in the context, since

      -- any !-desugaring we encounter cannot escape outside of this

      -- 'do'-block, and thus also not outside of the scope of those

      -- variables

      HsDo XDo GhcPs
xd HsDoFlavour
ctxt XRec GhcPs [ExprLStmt GhcPs]
stmts -> SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (GenLocated
      SrcSpanAnnL
      [GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
    -> HsExpr GhcPs)
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XDo GhcPs
-> HsDoFlavour -> XRec GhcPs [ExprLStmt GhcPs] -> HsExpr GhcPs
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcPs
xd HsDoFlavour
ctxt (GenLocated
   SrcSpanAnnL
   [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated
        SrcSpanAnnL
        [GenLocated
           SrcSpanAnnA
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (InScope -> InScope)
-> m (GenLocated
        SrcSpanAnnL
        [GenLocated
           SrcSpanAnnA
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> m (GenLocated
        SrcSpanAnnL
        [GenLocated
           SrcSpanAnnA
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Reader r) sig m =>
(r -> r) -> m a -> m a
local (InScope -> InScope -> InScope
forall a b. a -> b -> a
const InScope
noneInScope) (([GenLocated
    SrcSpanAnnA
    (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> m [GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m (GenLocated
        SrcSpanAnnL
        [GenLocated
           SrcSpanAnnA
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> GenLocated SrcSpanAnnL a -> f (GenLocated SrcSpanAnnL b)
traverse Handler m [ExprLStmt GhcPs]
[GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has
  (Writer (Messages PsError)
   :+: (HoleFills :+: (Uniques :+: (LocalVars :+: Reader DynFlags))))
  sig
  m =>
Handler m [ExprLStmt GhcPs]
addStmts XRec GhcPs [ExprLStmt GhcPs]
GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts)
#if MIN_VERSION_ghc(9,10,0)
      HsLet xl binds ex -> do
        (boundVars, binds') <- runWriter @Occs $ evac binds
        fmap (L l . HsLet xl binds') <$> liftMaybeT . local (addValids boundVars) $ evac ex
#else
      HsLet XLet GhcPs
xl LHsToken "let" GhcPs
letTok HsLocalBinds GhcPs
binds LHsToken "in" GhcPs
inTok LExpr
ex -> do
        (Occs
boundVars, HsLocalBinds GhcPs
binds') <- forall w (m :: * -> *) a. Monoid w => WriterC w m a -> m (w, a)
runWriter @Occs (WriterC Occs m (HsLocalBinds GhcPs)
 -> m (Occs, HsLocalBinds GhcPs))
-> WriterC Occs m (HsLocalBinds GhcPs)
-> m (Occs, HsLocalBinds GhcPs)
forall a b. (a -> b) -> a -> b
$ Handler (WriterC Occs m) (HsLocalBinds GhcPs)
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Fill sig m, Data a) =>
Handler m a
evac HsLocalBinds GhcPs
binds
        (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XLet GhcPs
-> LHsToken "let" GhcPs
-> HsLocalBinds GhcPs
-> LHsToken "in" GhcPs
-> LExpr
-> HsExpr GhcPs
forall p.
XLet p
-> LHsToken "let" p
-> HsLocalBinds p
-> LHsToken "in" p
-> LHsExpr p
-> HsExpr p
HsLet XLet GhcPs
xl LHsToken "let" GhcPs
letTok HsLocalBinds GhcPs
binds' LHsToken "in" GhcPs
inTok) (m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> MaybeT m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    -> m' (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InScope -> InScope)
-> m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Reader r) sig m =>
(r -> r) -> m a -> m a
local (Occs -> InScope -> InScope
addValids Occs
boundVars) (m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Handler m' (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Fill sig m, Data a) =>
Handler m a
evac LExpr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
ex
#endif

      HsExpr GhcPs
_ -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty

instance Handle StmtLR where
  type CanFail StmtLR = True
  type AstType StmtLR = StmtLR GhcPs GhcPs LExpr
  type Effects StmtLR = Fill
  handle' :: forall sig m m' . (m ~ MaybeT m', Has (Effects StmtLR) sig m') => Handler m (AstType StmtLR)
  handle' :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *).
(m ~ MaybeT m', Has (Effects StmtLR) sig m') =>
Handler m (AstType StmtLR)
handle' AstType StmtLR
e = case AstType StmtLR
e of

    RecStmt{XRec
  GhcPs [LStmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
recS_stmts :: XRec
  GhcPs [LStmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
recS_stmts :: forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts} -> do
      GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
recS_stmts' <- ([GenLocated
    SrcSpanAnnA
    (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> m [GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m (GenLocated
        SrcSpanAnnL
        [GenLocated
           SrcSpanAnnA
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> GenLocated SrcSpanAnnL a -> f (GenLocated SrcSpanAnnL b)
traverse Handler m [ExprLStmt GhcPs]
[GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has
  (Writer (Messages PsError)
   :+: (HoleFills :+: (Uniques :+: (LocalVars :+: Reader DynFlags))))
  sig
  m =>
Handler m [ExprLStmt GhcPs]
addStmts XRec
  GhcPs [LStmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
recS_stmts
      StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AstType StmtLR
e{recS_stmts = recS_stmts'}
    ParStmt XParStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
xp [ParStmtBlock GhcPs GhcPs]
stmtBlocks HsExpr GhcPs
zipper SyntaxExpr GhcPs
bind -> do
      [ParStmtBlock GhcPs GhcPs]
stmtsBlocks' <- (ParStmtBlock GhcPs GhcPs -> m (ParStmtBlock GhcPs GhcPs))
-> [ParStmtBlock GhcPs GhcPs] -> m [ParStmtBlock GhcPs GhcPs]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ParStmtBlock GhcPs GhcPs -> m (ParStmtBlock GhcPs GhcPs)
addParStmts [ParStmtBlock GhcPs GhcPs]
stmtBlocks
      StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> m (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ XParStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [ParStmtBlock GhcPs GhcPs]
-> HsExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt XParStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
xp [ParStmtBlock GhcPs GhcPs]
stmtsBlocks' HsExpr GhcPs
zipper SyntaxExpr GhcPs
bind
      where
        addParStmts :: Handler m (ParStmtBlock GhcPs GhcPs)
        addParStmts :: ParStmtBlock GhcPs GhcPs -> m (ParStmtBlock GhcPs GhcPs)
addParStmts (ParStmtBlock XParStmtBlock GhcPs GhcPs
xb [ExprLStmt GhcPs]
stmts [IdP GhcPs]
vars SyntaxExpr GhcPs
ret) = do
          [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts' <- Handler m [ExprLStmt GhcPs]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has
  (Writer (Messages PsError)
   :+: (HoleFills :+: (Uniques :+: (LocalVars :+: Reader DynFlags))))
  sig
  m =>
Handler m [ExprLStmt GhcPs]
addStmts [ExprLStmt GhcPs]
stmts
          ParStmtBlock GhcPs GhcPs -> m (ParStmtBlock GhcPs GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParStmtBlock GhcPs GhcPs -> m (ParStmtBlock GhcPs GhcPs))
-> ParStmtBlock GhcPs GhcPs -> m (ParStmtBlock GhcPs GhcPs)
forall a b. (a -> b) -> a -> b
$ XParStmtBlock GhcPs GhcPs
-> [ExprLStmt GhcPs]
-> [IdP GhcPs]
-> SyntaxExpr GhcPs
-> ParStmtBlock GhcPs GhcPs
forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcPs GhcPs
xb [ExprLStmt GhcPs]
[GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts' [IdP GhcPs]
vars SyntaxExpr GhcPs
ret

    AstType StmtLR
_ -> m (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
m (AstType StmtLR)
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Replace holes in an AST whenever an expression with the corresponding

-- source span can be found in the given list.

fillHoles :: (Data a, Has (PsErrors :+: Reader Options :+: Uniques :+: LocalVars :+: Reader DynFlags) sig m) => Map Loc LExpr -> Handler m a
fillHoles :: forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Data a,
 Has
   (Writer (Messages PsError)
    :+: (Reader Options
         :+: (Uniques :+: (LocalVars :+: Reader DynFlags))))
   sig
   m) =>
Map Loc LExpr -> Handler m a
fillHoles Map Loc LExpr
fillers a
ast = do
  (Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
remainingErrs, (DList BindStmt -> [BindStmt]
forall a. DList a -> [a]
fromDList -> [BindStmt]
binds :: [BindStmt], a
ast')) <- Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> OfferC
     Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m (DList BindStmt, a)
-> m (Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      (DList BindStmt, a))
forall k v (m :: * -> *) a.
Map k v -> OfferC k v m a -> m (Map k v, a)
runOffer Map Loc LExpr
Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fillers (OfferC
   Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m (DList BindStmt, a)
 -> m (Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
       (DList BindStmt, a)))
-> (WriterC
      (DList BindStmt)
      (OfferC Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m)
      a
    -> OfferC
         Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m (DList BindStmt, a))
-> WriterC
     (DList BindStmt)
     (OfferC Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m)
     a
-> m (Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      (DList BindStmt, a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterC
  (DList BindStmt)
  (OfferC Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m)
  a
-> OfferC
     Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m (DList BindStmt, a)
forall w (m :: * -> *) a. Monoid w => WriterC w m a -> m (w, a)
runWriter (WriterC
   (DList BindStmt)
   (OfferC Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m)
   a
 -> m (Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
       (DList BindStmt, a)))
-> WriterC
     (DList BindStmt)
     (OfferC Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m)
     a
-> m (Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      (DList BindStmt, a))
forall a b. (a -> b) -> a -> b
$ Handler
  (WriterC
     (DList BindStmt)
     (OfferC Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)) m))
  a
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Fill sig m, Data a) =>
Handler m a
evac a
ast
  MkOptions{PreserveErrors
preserveErrors :: PreserveErrors
preserveErrors :: Options -> PreserveErrors
preserveErrors} <- m Options
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask
  [BindStmt] -> (BindStmt -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [BindStmt]
binds \BindStmt
bind -> PsError -> SrcSpan -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Writer (Messages PsError)) sig m =>
PsError -> SrcSpan -> m ()
tellPsError (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PreserveErrors -> PsError
psError (BindStmt -> LExpr
bindStmtExpr BindStmt
bind) PreserveErrors
preserveErrors) (SrcSpan -> SrcSpan
bangSpan (SrcSpan -> SrcSpan) -> SrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$ BindStmt -> SrcSpan
bindStmtSpan BindStmt
bind)
  DynFlags
dflags <- m DynFlags
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask
  a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure if Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> Bool
forall a. Map Loc a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
remainingErrs
    then a
ast'
    else String -> a
forall a. HasCallStack => String -> a
panic (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"Found extraneous bangs:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (DynFlags -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> String)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a. Map Loc a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map Loc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
remainingErrs)
  where
    psError :: GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PreserveErrors -> PsError
psError GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr = \cases
      PreserveErrors
Preserve      -> LExpr -> PsError
PsErrBangPatWithoutSpace LExpr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
      PreserveErrors
Don'tPreserve -> Error -> PsError
customError Error
ErrBangOutsideOfDo

evac :: forall a sig m . (Has Fill sig m, Data a) => Handler m a
-- This recurses over all nodes in the AST, except for nodes for which

-- one of the `try` functions returns `Just <something>`.

evac :: forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Fill sig m, Data a) =>
Handler m a
evac a
e = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((forall d. Data d => d -> m d) -> a -> m a
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a
gmapM Handler m d
forall d. Data d => d -> m d
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Fill sig m, Data a) =>
Handler m a
evac a
e) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m a) -> m (Maybe a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MaybeT m a -> m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT ([Try m a] -> Try m a
forall (m :: * -> *) a. Monad m => [Try m a] -> Try m a
tryEvac [Try m a]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has Fill sig m, Data a) =>
[Try m a]
usualTries a
e)

tryEvac :: Monad m => [Try m a] -> Try m a
tryEvac :: forall (m :: * -> *) a. Monad m => [Try m a] -> Try m a
tryEvac [Try m a]
tries = [MaybeT m a] -> MaybeT m a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([MaybeT m a] -> MaybeT m a) -> (a -> [MaybeT m a]) -> Try m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Try m a]
tries ??)

usualTries :: (Has Fill sig m, Data a) => [Try m a]
usualTries :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has Fill sig m, Data a) =>
[Try m a]
usualTries =
  [ forall {k} (e :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a,
 Handle e, Monad m, Has (Effects e) sig m) =>
Try m a
forall (e :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a,
 Handle e, Monad m, Has (Effects e) sig m) =>
Try m a
try @HsExpr, forall {k} (e :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a,
 Handle e, Monad m, Has (Effects e) sig m) =>
Try m a
forall (e :: * -> * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *)
       a.
(HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a,
 Handle e, Monad m, Has (Effects e) sig m) =>
Try m a
try @HsBindLR, forall {k} (e :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a,
 Handle e, Monad m, Has (Effects e) sig m) =>
Try m a
forall (e :: * -> * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *)
       a.
(HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a,
 Handle e, Monad m, Has (Effects e) sig m) =>
Try m a
try @MatchGroup, forall {k} (e :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a,
 Handle e, Monad m, Has (Effects e) sig m) =>
Try m a
forall (e :: * -> * -> * -> *) (sig :: (* -> *) -> * -> *)
       (m :: * -> *) a.
(HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a,
 Handle e, Monad m, Has (Effects e) sig m) =>
Try m a
try @StmtLR
  , forall e (m :: * -> *) a.
(Monad m, Typeable a, Typeable e) =>
Try m a
ignore @RdrName, forall e (m :: * -> *) a.
(Monad m, Typeable a, Typeable e) =>
Try m a
ignore @OccName, forall e (m :: * -> *) a.
(Monad m, Typeable a, Typeable e) =>
Try m a
ignore @RealSrcSpan, forall e (m :: * -> *) a.
(Monad m, Typeable a, Typeable e) =>
Try m a
ignore @EpAnnComments
  ]

-- As a minor performance optimization, we don't recurse over the AST if the node

-- is a type that we know will never contain an expression

ignore :: forall (e :: Type) m a . (Monad m, Typeable a, Typeable e) => Try m a
ignore :: forall e (m :: * -> *) a.
(Monad m, Typeable a, Typeable e) =>
Try m a
ignore a
e = do
  e :~: a
Refl <- Maybe (e :~: a) -> MaybeT m (e :~: a)
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe (Maybe (e :~: a) -> MaybeT m (e :~: a))
-> Maybe (e :~: a) -> MaybeT m (e :~: a)
forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @e @a
  a -> MaybeT m a
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
e

-- | evacuate !s in pattern and collect all the names it binds

evacPats :: forall a m sig . (Has (Fill :+: State InScope) sig m, Data a) => Handler m a
evacPats :: forall a (m :: * -> *) (sig :: (* -> *) -> * -> *).
(Has (Fill :+: State InScope) sig m, Data a) =>
Handler m a
evacPats a
e = do
  InScope
currentState <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @InScope
  m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((forall d. Data d => d -> m d) -> a -> m a
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a
gmapM Handler m d
forall d. Data d => d -> m d
forall a (m :: * -> *) (sig :: (* -> *) -> * -> *).
(Has (Fill :+: State InScope) sig m, Data a) =>
Handler m a
evacPats a
e) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m a) -> m (Maybe a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MaybeT m a -> m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT ([Try m a] -> Try m a
forall (m :: * -> *) a. Monad m => [Try m a] -> Try m a
tryEvac (((InScope -> InScope) -> MaybeT m a -> MaybeT m a
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Reader r) sig m =>
(r -> r) -> m a -> m a
local (InScope -> InScope -> InScope
forall a. Semigroup a => a -> a -> a
<> InScope
currentState) .) (Try m a -> Try m a) -> [Try m a] -> [Try m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall {k} (e :: k) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a,
 Handle e, Monad m, Has (Effects e) sig m) =>
Try m a
forall (e :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a,
 Handle e, Monad m, Has (Effects e) sig m) =>
Try m a
try @Pat Try m a -> [Try m a] -> [Try m a]
forall a. a -> [a] -> [a]
: [Try m a]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has Fill sig m, Data a) =>
[Try m a]
usualTries)) a
e)

-- | Find all !s in the given statements and combine the resulting bind

-- statements into lists, with the original statements being the last one

-- in each list - then concatenate these lists

addStmts :: forall sig m . Has (PsErrors :+: HoleFills :+: Uniques :+: LocalVars :+: Reader DynFlags) sig m => Handler m [ExprLStmt GhcPs]
addStmts :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has
  (Writer (Messages PsError)
   :+: (HoleFills :+: (Uniques :+: (LocalVars :+: Reader DynFlags))))
  sig
  m =>
Handler m [ExprLStmt GhcPs]
addStmts = (GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> m [GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM \GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
lstmt -> do
  (DList BindStmt -> [BindStmt]
forall a. DList a -> [a]
fromDList -> [BindStmt]
stmts, GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
lstmt') <- WriterC
  (DList BindStmt)
  m
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> m (DList BindStmt,
      GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall w (m :: * -> *) a. Monoid w => WriterC w m a -> m (w, a)
runWriter (WriterC
   (DList BindStmt)
   m
   (GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
 -> m (DList BindStmt,
       GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> WriterC
     (DList BindStmt)
     m
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> m (DList BindStmt,
      GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ Handler
  (WriterC (DList BindStmt) m)
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Fill sig m, Data a) =>
Handler m a
evac GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
lstmt
  [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated
    SrcSpanAnnA
    (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> m [GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ (BindStmt
 -> GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> [BindStmt]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map BindStmt -> ExprLStmt GhcPs
BindStmt
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
fromBindStmt [BindStmt]
stmts [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
lstmt']

type HoleFills = Offer Loc LExpr
-- | We keep track of variables that are bound in lambdas, cases, etc., since

-- these are variables that will not be accessible in the surrounding

-- 'do'-block, and must therefore not be used.

-- The Reader is used to find out what local variables are in scope, the Writer

-- is used to inform callers which local variables have been bound.

type LocalVars = Reader InScope :+: Writer Occs

type Fill = PsErrors :+: Writer (DList BindStmt) :+: HoleFills :+: Uniques :+: LocalVars :+: Reader DynFlags

data BindStmt = RdrName :<- LExpr

bindStmtExpr :: BindStmt -> LExpr
bindStmtExpr :: BindStmt -> LExpr
bindStmtExpr (RdrName
_ :<- LExpr
expr) = LExpr
expr

bindStmtSpan :: BindStmt -> SrcSpan
bindStmtSpan :: BindStmt -> SrcSpan
bindStmtSpan = SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA (SrcSpanAnnA -> SrcSpan)
-> (BindStmt -> SrcSpanAnnA) -> BindStmt -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(RdrName
_ :<- L SrcSpanAnnA
l HsExpr GhcPs
_) -> SrcSpanAnnA
l

fromBindStmt :: BindStmt -> ExprLStmt GhcPs
fromBindStmt :: BindStmt -> ExprLStmt GhcPs
fromBindStmt = StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a an. a -> LocatedAn an a
noLocA (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> (BindStmt
    -> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> BindStmt
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \cases
  (RdrName
var :<- LExpr
lexpr) -> XBindStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> XRec GhcPs (Pat GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn XRec GhcPs (Pat GhcPs)
GenLocated SrcSpanAnnA (Pat GhcPs)
varPat LExpr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
lexpr
    where
      varPat :: GenLocated SrcSpanAnnA (Pat GhcPs)
varPat = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a an. a -> LocatedAn an a
noLocA (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> (GenLocated SrcSpanAnnN RdrName -> Pat GhcPs)
-> GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnA (Pat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XVarPat GhcPs -> LIdP GhcPs -> Pat GhcPs
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcPs
NoExtField
noExtField (GenLocated SrcSpanAnnN RdrName
 -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ RdrName -> GenLocated SrcSpanAnnN RdrName
forall a an. a -> LocatedAn an a
noLocA RdrName
var

-- | Use the !'d expression if it's short enough, or else abbreviate with `...`

-- We don't need to worry about shadowing other !'d expressions:

-- - For the user, we add line and column numbers to the name

-- - For the compiler, we use a unique instead of the name

bangVar :: Has (Uniques :+: Reader DynFlags) sig m => LExpr -> Loc -> m RdrName
bangVar :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Uniques :+: Reader DynFlags) sig m =>
LExpr -> Loc -> m RdrName
bangVar (L SrcSpanAnnA
spn HsExpr GhcPs
expr) Loc
loc = do
  DynFlags
dflags <- m DynFlags
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask
  let name :: String
name = Char
'!' Char -> ShowS
forall a. a -> [a] -> [a]
: case String -> [String]
lines (DynFlags -> HsExpr GhcPs -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags HsExpr GhcPs
expr) of
        (String
str:[String]
rest) | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
rest Bool -> Bool -> Bool
&& String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
20 -> String
str
                   | Bool
otherwise                    -> Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
16 String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"..."
        [String]
_                                         -> String
"<empty expression>"
  String -> SrcSpan -> Loc -> m RdrName
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has Uniques sig m =>
String -> SrcSpan -> Loc -> m RdrName
locVar String
name (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
spn) Loc
loc

locVar :: Has Uniques sig m => String -> SrcSpan -> Loc -> m RdrName
locVar :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has Uniques sig m =>
String -> SrcSpan -> Loc -> m RdrName
locVar String
str SrcSpan
spn Loc
loc = do
  let occ :: OccName
occ = String -> OccName
mkVarOcc (String -> OccName) -> String -> OccName
forall a b. (a -> b) -> a -> b
$ String -> String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"<%s:%d:%d>" String
str Loc
loc.line Loc
loc.col
  Unique
unique <- m Unique
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has Uniques sig m =>
m Unique
freshUnique
  RdrName -> m RdrName
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RdrName -> m RdrName) -> (Name -> RdrName) -> Name -> m RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> RdrName
nameRdrName (Name -> m RdrName) -> Name -> m RdrName
forall a b. (a -> b) -> a -> b
$ Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
unique OccName
occ SrcSpan
spn

tellOne :: Has (Writer (DList w)) sig m => w -> m ()
tellOne :: forall w (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Writer (DList w)) sig m =>
w -> m ()
tellOne w
x = DList w -> m ()
forall w (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Writer w) sig m =>
w -> m ()
tell (DList w -> m ()) -> DList w -> m ()
forall a b. (a -> b) -> a -> b
$ ([w] -> [w]) -> DList w
forall a. (a -> a) -> Endo a
Endo (w
x:)

tellLocalVar :: Has (Writer Occs) sig m => OccName -> m ()
tellLocalVar :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Writer Occs) sig m =>
OccName -> m ()
tellLocalVar = Occs -> m ()
forall w (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Writer w) sig m =>
w -> m ()
tell (Occs -> m ()) -> (OccName -> Occs) -> OccName -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> Occs
unitOccs