{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module AutoSplit
  ( plugin
  ) where

import           Control.Exception
import qualified Control.Monad.Trans.Writer.CPS as Writer
import qualified Data.Char as Char
import           Data.Foldable
import           Data.Functor
import qualified Data.Generics as Syb
import           Data.IORef
import qualified Data.List as List
#if MIN_VERSION_ghc(9,12,0)
import qualified Data.List.NonEmpty as NE
#endif
import           Data.Maybe
import           Data.Monoid (Any(..))
import           Data.String (IsString, fromString)
import qualified Data.Typeable as Typeable
import qualified GHC.Paths as Paths
import qualified Language.Haskell.GHC.ExactPrint as EP
import qualified Language.Haskell.GHC.ExactPrint.Parsers as EP
import qualified Language.Haskell.GHC.ExactPrint.Utils as EP
import           Text.Read (readMaybe)

import qualified AutoSplit.GhcFacade as Ghc

plugin :: Ghc.Plugin
plugin :: Plugin
plugin = Plugin
Ghc.defaultPlugin
  { Ghc.driverPlugin = \[String]
_ HscEnv
hscEnv -> HscEnv -> IO HscEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HscEnv -> IO HscEnv) -> HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> HscEnv
addDsHook HscEnv
hscEnv
  , Ghc.parsedResultAction = \[String]
_ ModSummary
_ ParsedResult
result -> ParsedResult -> Hsc ParsedResult
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParsedResult -> Hsc ParsedResult)
-> ParsedResult -> Hsc ParsedResult
forall a b. (a -> b) -> a -> b
$ ParsedResult -> ParsedResult
addImport ParsedResult
result
  , Ghc.pluginRecompile = Ghc.purePlugin
  , Ghc.typeCheckResultAction = \[String]
_ ModSummary
_ TcGblEnv
env ->
      TcM ()
removeUnusedImportWarn TcM () -> TcM TcGblEnv -> TcM TcGblEnv
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TcGblEnv
env
  }

-- | Incomplete patterns warning is emitted by the desugarer. Some shenanigans
-- are needed to intercept these warnings: a custom error is added to the
-- frontend result which causes the desugarer to throw a 'SourceError'
-- exception containing all diagnostics after running. This exception is then
-- caught (and later rethrown) by the plugin.
addDsHook :: Ghc.HscEnv -> Ghc.HscEnv
addDsHook :: HscEnv -> HscEnv
addDsHook HscEnv
hscEnv = HscEnv
hscEnv
  { Ghc.hsc_hooks =
      let hooks = HscEnv -> Hooks
Ghc.hsc_hooks HscEnv
hscEnv
       in hooks
          { Ghc.runPhaseHook = Just $ phaseHook (Ghc.runPhaseHook hooks) }
  }
  where
    phaseHook :: Maybe PhaseHook -> PhaseHook
phaseHook Maybe PhaseHook
mExistingHook = (forall a. TPhase a -> IO a) -> PhaseHook
Ghc.PhaseHook ((forall a. TPhase a -> IO a) -> PhaseHook)
-> (forall a. TPhase a -> IO a) -> PhaseHook
forall a b. (a -> b) -> a -> b
$ \TPhase a
tPhase -> do
      let isMissingPatWarn :: MsgEnvelope GhcMessage
-> Either NonExhaustivePattern (MsgEnvelope GhcMessage)
isMissingPatWarn MsgEnvelope GhcMessage
msgEnv =
            case MsgEnvelope GhcMessage -> GhcMessage
forall e. MsgEnvelope e -> e
Ghc.errMsgDiagnostic MsgEnvelope GhcMessage
msgEnv of
              Ghc.GhcDsMessage (Ghc.DsNonExhaustivePatterns HsMatchContext GhcRn
_ ExhaustivityCheckType
_ Int
_ [Id]
patIds [Nabla]
nablas)
                | Just RealSrcSpan
srcSpan <- SrcSpan -> Maybe RealSrcSpan
Ghc.srcSpanToRealSrcSpan (MsgEnvelope GhcMessage -> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
Ghc.errMsgSpan MsgEnvelope GhcMessage
msgEnv) -> NonExhaustivePattern
-> Either NonExhaustivePattern (MsgEnvelope GhcMessage)
forall a b. a -> Either a b
Left
                NonExhaustivePattern
                  { patternIds :: [Id]
patternIds = [Id]
patIds
                  , patternNablas :: [Nabla]
patternNablas = [Nabla]
nablas
                  , srcCodeLoc :: RealSrcSpan
srcCodeLoc = RealSrcSpan
srcSpan
                  }
              GhcMessage
_ -> MsgEnvelope GhcMessage
-> Either NonExhaustivePattern (MsgEnvelope GhcMessage)
forall a b. b -> Either a b
Right MsgEnvelope GhcMessage
msgEnv
          isAutoSplitError :: MsgEnvelope GhcMessage -> Bool
isAutoSplitError MsgEnvelope GhcMessage
msgEnv =
            case MsgEnvelope GhcMessage -> GhcMessage
forall e. MsgEnvelope e -> e
Ghc.errMsgDiagnostic MsgEnvelope GhcMessage
msgEnv of
              Ghc.GhcUnknownMessage (Ghc.UnknownDiagnostic' a
a)
                | Just PatternSplitDiag
PatternSplitDiag <- a -> Maybe PatternSplitDiag
forall a b. (Typeable a, Typeable b) => a -> Maybe b
Typeable.cast a
a -> Bool
True
              GhcMessage
_ -> Bool
False
          runPhaseOrExistingHook :: Ghc.TPhase res -> IO res
          runPhaseOrExistingHook :: forall a. TPhase a -> IO a
runPhaseOrExistingHook = (TPhase res -> IO res)
-> (PhaseHook -> TPhase res -> IO res)
-> Maybe PhaseHook
-> TPhase res
-> IO res
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TPhase res -> IO res
forall a. TPhase a -> IO a
Ghc.runPhase (\(Ghc.PhaseHook forall a. TPhase a -> IO a
h) -> TPhase res -> IO res
forall a. TPhase a -> IO a
h) Maybe PhaseHook
mExistingHook
      case TPhase a
tPhase of
        Ghc.T_HscPostTc HscEnv
env ModSummary
modSum tcResult :: FrontendResult
tcResult@(Ghc.FrontendTypecheck TcGblEnv
gblEnv) ErrorMessages
warns Maybe Fingerprint
mOldHash -> do
          [GlobalRdrElt]
usedGres <- IORef [GlobalRdrElt] -> IO [GlobalRdrElt]
forall a. IORef a -> IO a
readIORef (IORef [GlobalRdrElt] -> IO [GlobalRdrElt])
-> IORef [GlobalRdrElt] -> IO [GlobalRdrElt]
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> IORef [GlobalRdrElt]
Ghc.tcg_used_gres TcGblEnv
gblEnv
          let usesSplit :: Bool
usesSplit = (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
forall a. IsString a => a
splitName) (FastString -> Bool)
-> (GlobalRdrElt -> FastString) -> GlobalRdrElt -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> FastString
Ghc.occNameFS (OccName -> FastString)
-> (GlobalRdrElt -> OccName) -> GlobalRdrElt -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GreName -> OccName
forall name. HasOccName name => name -> OccName
Ghc.occName (GreName -> OccName)
-> (GlobalRdrElt -> GreName) -> GlobalRdrElt -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrElt -> GreName
Ghc.gre_name) [GlobalRdrElt]
usedGres
              mFilePath :: Maybe String
mFilePath = ModLocation -> Maybe String
Ghc.ml_hs_file (ModSummary -> ModLocation
Ghc.ms_location ModSummary
modSum)
          case Maybe String
mFilePath of
            Just String
filePath | Bool
usesSplit -> do
              let patSplitErr :: MsgEnvelope GhcMessage
patSplitErr =
                    SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
Ghc.mkPlainErrorMsgEnvelope
                      (FastString -> SrcSpan
Ghc.mkGeneralSrcSpan (FastString -> SrcSpan) -> FastString -> SrcSpan
forall a b. (a -> b) -> a -> b
$ String -> FastString
forall a. IsString a => String -> a
fromString String
filePath)
                      (PatternSplitDiag -> GhcMessage
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> GhcMessage
Ghc.ghcUnknownMessage PatternSplitDiag
PatternSplitDiag)
                  noMissingPatErr :: MsgEnvelope GhcMessage
noMissingPatErr =
                    SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
Ghc.mkPlainErrorMsgEnvelope
                      (FastString -> SrcSpan
Ghc.mkGeneralSrcSpan (FastString -> SrcSpan) -> FastString -> SrcSpan
forall a b. (a -> b) -> a -> b
$ String -> FastString
forall a. IsString a => String -> a
fromString String
filePath)
                      (NoMissingPat -> GhcMessage
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> GhcMessage
Ghc.ghcUnknownMessage NoMissingPat
NoMissingPat)
                  parseFailedErr :: MsgEnvelope GhcMessage
parseFailedErr =
                    SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
Ghc.mkPlainErrorMsgEnvelope
                      (FastString -> SrcSpan
Ghc.mkGeneralSrcSpan (FastString -> SrcSpan) -> FastString -> SrcSpan
forall a b. (a -> b) -> a -> b
$ String -> FastString
forall a. IsString a => String -> a
fromString String
filePath)
                      (ParseFailed -> GhcMessage
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> GhcMessage
Ghc.ghcUnknownMessage ParseFailed
ParseFailed)
                  warnsWithError :: ErrorMessages
warnsWithError = MsgEnvelope GhcMessage -> ErrorMessages -> ErrorMessages
forall e. MsgEnvelope e -> Messages e -> Messages e
Ghc.addMessage MsgEnvelope GhcMessage
patSplitErr ErrorMessages
warns
                  updEnv :: HscEnv
updEnv = HscEnv
env
                    -- Plugin only functions if incomplete patterns warning is enabled, so we force it on.
                    -- If this is instead done as driver plugin, ghci sessions won't pick it up.
                    { Ghc.hsc_dflags = (Ghc.hsc_dflags env `Ghc.wopt_set` Ghc.Opt_WarnIncompletePatterns)
                      -- Need to override the number of uncovered patterns reported.
                      { Ghc.maxUncoveredPatterns = maxBound - 1 }
                    }
              IO a -> (SourceError -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
                (TPhase HscBackendAction -> IO HscBackendAction
forall a. TPhase a -> IO a
runPhaseOrExistingHook (TPhase HscBackendAction -> IO HscBackendAction)
-> TPhase HscBackendAction -> IO HscBackendAction
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary
-> FrontendResult
-> ErrorMessages
-> Maybe Fingerprint
-> TPhase HscBackendAction
Ghc.T_HscPostTc HscEnv
updEnv ModSummary
modSum FrontendResult
tcResult ErrorMessages
warnsWithError Maybe Fingerprint
mOldHash)
                (\(Ghc.SourceError ErrorMessages
msgs) -> do
                  let (Bag NonExhaustivePattern
missingPatWarns, Bag (MsgEnvelope GhcMessage)
otherDiags) = (MsgEnvelope GhcMessage
 -> Either NonExhaustivePattern (MsgEnvelope GhcMessage))
-> Bag (MsgEnvelope GhcMessage)
-> (Bag NonExhaustivePattern, Bag (MsgEnvelope GhcMessage))
forall a b c. (a -> Either b c) -> Bag a -> (Bag b, Bag c)
Ghc.partitionBagWith MsgEnvelope GhcMessage
-> Either NonExhaustivePattern (MsgEnvelope GhcMessage)
isMissingPatWarn (ErrorMessages -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
Ghc.getMessages ErrorMessages
msgs)
                      -- Need to parse the module because GHC removes
                      -- ParsedResult from ModSummary after the frontend finishes.
                      -- Use the options from compilation to parse the module, otherwise certain
                      -- syntax extensions won't parse correctly.
                      dynFlags :: DynFlags
dynFlags = ModSummary -> DynFlags
Ghc.ms_hspp_opts ModSummary
modSum DynFlags -> GeneralFlag -> DynFlags
`Ghc.gopt_set` GeneralFlag
Ghc.Opt_KeepRawTokenStream
                  (ParseResult ParsedSource, Bool)
eResult <- HscEnv -> DynFlags -> String -> IO (ParseResult ParsedSource, Bool)
parseModule HscEnv
env DynFlags
dynFlags String
filePath
                  case (ParseResult ParsedSource, Bool)
eResult of
                    (Right ParsedSource
parsedMod, Bool
usesCpp)
                      | Bool -> Bool
not (Bag NonExhaustivePattern -> Bool
forall a. Bag a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bag NonExhaustivePattern
missingPatWarns) -> do
                          let gblRdrEnv :: GlobalRdrEnv
gblRdrEnv = TcGblEnv -> GlobalRdrEnv
Ghc.tcg_rdr_env TcGblEnv
gblEnv
                          GlobalRdrEnv
-> ParsedSource
-> Bool
-> Bag NonExhaustivePattern
-> String
-> IO ()
modifyModule GlobalRdrEnv
gblRdrEnv ParsedSource
parsedMod Bool
usesCpp Bag NonExhaustivePattern
missingPatWarns String
filePath
                          SourceError -> IO a
forall a e. Exception e => e -> a
throw (SourceError -> IO a)
-> (ErrorMessages -> SourceError) -> ErrorMessages -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessages -> SourceError
Ghc.SourceError (ErrorMessages -> IO a) -> ErrorMessages -> IO a
forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope GhcMessage) -> ErrorMessages
forall e. Bag (MsgEnvelope e) -> Messages e
Ghc.mkMessages Bag (MsgEnvelope GhcMessage)
otherDiags
                      | Bool
otherwise -> SourceError -> IO a
forall a e. Exception e => e -> a
throw (SourceError -> IO a)
-> (Bag (MsgEnvelope GhcMessage) -> SourceError)
-> Bag (MsgEnvelope GhcMessage)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessages -> SourceError
Ghc.SourceError (ErrorMessages -> SourceError)
-> (Bag (MsgEnvelope GhcMessage) -> ErrorMessages)
-> Bag (MsgEnvelope GhcMessage)
-> SourceError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope GhcMessage) -> ErrorMessages
forall e. Bag (MsgEnvelope e) -> Messages e
Ghc.mkMessages
                                   (Bag (MsgEnvelope GhcMessage) -> ErrorMessages)
-> (Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage))
-> Bag (MsgEnvelope GhcMessage)
-> ErrorMessages
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope GhcMessage
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
forall a. a -> Bag a -> Bag a
Ghc.consBag MsgEnvelope GhcMessage
noMissingPatErr
                                   (Bag (MsgEnvelope GhcMessage) -> IO a)
-> Bag (MsgEnvelope GhcMessage) -> IO a
forall a b. (a -> b) -> a -> b
$ (MsgEnvelope GhcMessage -> Bool)
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
forall a. (a -> Bool) -> Bag a -> Bag a
Ghc.filterBag (Bool -> Bool
not (Bool -> Bool)
-> (MsgEnvelope GhcMessage -> Bool)
-> MsgEnvelope GhcMessage
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope GhcMessage -> Bool
isAutoSplitError) Bag (MsgEnvelope GhcMessage)
otherDiags
                    (Left ErrorMessages
_, Bool
_) ->
                      SourceError -> IO a
forall a e. Exception e => e -> a
throw (SourceError -> IO a)
-> (Bag (MsgEnvelope GhcMessage) -> SourceError)
-> Bag (MsgEnvelope GhcMessage)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessages -> SourceError
Ghc.SourceError (ErrorMessages -> SourceError)
-> (Bag (MsgEnvelope GhcMessage) -> ErrorMessages)
-> Bag (MsgEnvelope GhcMessage)
-> SourceError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope GhcMessage) -> ErrorMessages
forall e. Bag (MsgEnvelope e) -> Messages e
Ghc.mkMessages
                            (Bag (MsgEnvelope GhcMessage) -> ErrorMessages)
-> (Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage))
-> Bag (MsgEnvelope GhcMessage)
-> ErrorMessages
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope GhcMessage
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
forall a. a -> Bag a -> Bag a
Ghc.consBag MsgEnvelope GhcMessage
parseFailedErr
                            (Bag (MsgEnvelope GhcMessage) -> IO a)
-> Bag (MsgEnvelope GhcMessage) -> IO a
forall a b. (a -> b) -> a -> b
$ (MsgEnvelope GhcMessage -> Bool)
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
forall a. (a -> Bool) -> Bag a -> Bag a
Ghc.filterBag (Bool -> Bool
not (Bool -> Bool)
-> (MsgEnvelope GhcMessage -> Bool)
-> MsgEnvelope GhcMessage
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope GhcMessage -> Bool
isAutoSplitError) Bag (MsgEnvelope GhcMessage)
otherDiags
                )
            Maybe String
_ -> TPhase a -> IO a
forall a. TPhase a -> IO a
runPhaseOrExistingHook TPhase a
tPhase -- no SPLIT or no file path
        TPhase a
_ -> TPhase a -> IO a
forall a. TPhase a -> IO a
runPhaseOrExistingHook TPhase a
tPhase

-- | Parse the given module file. Accounts for CPP comments
parseModule
  :: Ghc.HscEnv
  -> Ghc.DynFlags
  -> String
  -> IO (EP.ParseResult Ghc.ParsedSource, Bool)
parseModule :: HscEnv -> DynFlags -> String -> IO (ParseResult ParsedSource, Bool)
parseModule HscEnv
env DynFlags
dynFlags String
filePath = String
-> Ghc (ParseResult ParsedSource, Bool)
-> IO (ParseResult ParsedSource, Bool)
forall a. String -> Ghc a -> IO a
EP.ghcWrapper String
Paths.libdir (Ghc (ParseResult ParsedSource, Bool)
 -> IO (ParseResult ParsedSource, Bool))
-> Ghc (ParseResult ParsedSource, Bool)
-> IO (ParseResult ParsedSource, Bool)
forall a b. (a -> b) -> a -> b
$ do
  HscEnv -> Ghc ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
Ghc.setSession HscEnv
env { Ghc.hsc_dflags = dynFlags }
  Either ErrorMessages ([LEpaComment], DynFlags, ParsedSource)
res <- CppOptions
-> DynFlags
-> String
-> Ghc
     (Either ErrorMessages ([LEpaComment], DynFlags, ParsedSource))
forall (m :: * -> *).
GhcMonad m =>
CppOptions
-> DynFlags
-> String
-> m (Either ErrorMessages ([LEpaComment], DynFlags, ParsedSource))
EP.parseModuleEpAnnsWithCppInternal CppOptions
EP.defaultCppOptions DynFlags
dynFlags String
filePath
  let eCppComments :: Either ErrorMessages [LEpaComment]
eCppComments = (([LEpaComment], DynFlags, ParsedSource) -> [LEpaComment])
-> Either ErrorMessages ([LEpaComment], DynFlags, ParsedSource)
-> Either ErrorMessages [LEpaComment]
forall a b.
(a -> b) -> Either ErrorMessages a -> Either ErrorMessages b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\([LEpaComment]
c, DynFlags
_, ParsedSource
_) -> [LEpaComment]
c) Either ErrorMessages ([LEpaComment], DynFlags, ParsedSource)
res
      hasCpp :: Bool
hasCpp = case Either ErrorMessages [LEpaComment]
eCppComments of
                 Right [LEpaComment]
cs -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [LEpaComment] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LEpaComment]
cs
                 Either ErrorMessages [LEpaComment]
_ -> Bool
False
  (ParseResult ParsedSource, Bool)
-> Ghc (ParseResult ParsedSource, Bool)
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( (ParsedSource -> [LEpaComment] -> ParsedSource)
-> ParseResult ParsedSource
-> Either ErrorMessages [LEpaComment]
-> ParseResult ParsedSource
forall a b c.
(a -> b -> c)
-> Either ErrorMessages a
-> Either ErrorMessages b
-> Either ErrorMessages c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ParsedSource -> [LEpaComment] -> ParsedSource
EP.insertCppComments
        (Either ErrorMessages ([LEpaComment], DynFlags, ParsedSource)
-> ParseResult ParsedSource
forall a.
Either a ([LEpaComment], DynFlags, ParsedSource)
-> Either a ParsedSource
EP.postParseTransform Either ErrorMessages ([LEpaComment], DynFlags, ParsedSource)
res)
        Either ErrorMessages [LEpaComment]
eCppComments
    , Bool
hasCpp
    )

-- | Applies pattern split transformation and updates the module file.
modifyModule
  :: Ghc.GlobalRdrEnv
  -> Ghc.ParsedSource
  -> Bool
  -> Ghc.Bag NonExhaustivePattern
  -> FilePath
  -> IO ()
modifyModule :: GlobalRdrEnv
-> ParsedSource
-> Bool
-> Bag NonExhaustivePattern
-> String
-> IO ()
modifyModule GlobalRdrEnv
gblRdrEnv ParsedSource
parsedMod Bool
usesCpp Bag NonExhaustivePattern
missingPatWarns String
filePath = do
  let ast :: ParsedSource
ast = ParsedSource -> ParsedSource
forall ast. ExactPrint ast => ast -> ast
EP.makeDeltaAst
          (ParsedSource -> ParsedSource) -> ParsedSource -> ParsedSource
forall a b. (a -> b) -> a -> b
$ [NonExhaustivePattern] -> ParsedSource -> ParsedSource
searchAndMark (Bag NonExhaustivePattern -> [NonExhaustivePattern]
forall a. Bag a -> [a]
Ghc.bagToList Bag NonExhaustivePattern
missingPatWarns) ParsedSource
parsedMod
  case GlobalRdrEnv
-> [NonExhaustivePattern] -> ParsedSource -> (ParsedSource, Any)
splitPattern GlobalRdrEnv
gblRdrEnv (Bag NonExhaustivePattern -> [NonExhaustivePattern]
forall a. Bag a -> [a]
Ghc.bagToList Bag NonExhaustivePattern
missingPatWarns) ParsedSource
ast of
    (ParsedSource
ps, Any Bool
True) ->
      -- If the source contains CPP, newlines are appended
      -- to the end of the file when exact printing. The simple
      -- solution is to remove trailing newlines after exact printing
      -- if the source contains CPP comments.
      let removeTrailingNewlines :: String -> String
removeTrailingNewlines
            | Bool
usesCpp =
                String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\n' :) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse
            | Bool
otherwise = String -> String
forall a. a -> a
id
          printed :: String
printed = String -> String
removeTrailingNewlines (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ParsedSource -> String
forall ast. ExactPrint ast => ast -> String
EP.exactPrint ParsedSource
ps
       in String -> String -> IO ()
writeFile String
filePath String
printed
    (ParsedSource, Any)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Diagnostic thrown when case splitting should be attempted.
data PatternSplitDiag = PatternSplitDiag

instance Ghc.Diagnostic PatternSplitDiag where
  type DiagnosticOpts PatternSplitDiag = Ghc.NoDiagnosticOpts
  diagnosticMessage :: DiagnosticOpts PatternSplitDiag
-> PatternSplitDiag -> DecoratedSDoc
diagnosticMessage DiagnosticOpts PatternSplitDiag
_ PatternSplitDiag
_ = SDoc -> DecoratedSDoc
Ghc.mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
forall doc. IsLine doc => String -> doc
Ghc.text String
"Module updated by auto-split, compilation aborted"
  diagnosticReason :: PatternSplitDiag -> DiagnosticReason
diagnosticReason PatternSplitDiag
_ = DiagnosticReason
Ghc.ErrorWithoutFlag
  diagnosticHints :: PatternSplitDiag -> [GhcHint]
diagnosticHints PatternSplitDiag
_ = []
  diagnosticCode :: PatternSplitDiag -> Maybe DiagnosticCode
diagnosticCode PatternSplitDiag
_ = Maybe DiagnosticCode
forall a. Maybe a
Nothing
#if !MIN_VERSION_ghc(9,8,0)
  defaultDiagnosticOpts :: DiagnosticOpts PatternSplitDiag
defaultDiagnosticOpts = NoDiagnosticOpts
DiagnosticOpts PatternSplitDiag
Ghc.NoDiagnosticOpts
#endif

-- | Diagnostic thrown when SPLIT is used but there are no resulting warnings
data NoMissingPat = NoMissingPat

instance Ghc.Diagnostic NoMissingPat where
  type DiagnosticOpts NoMissingPat = Ghc.NoDiagnosticOpts
  diagnosticMessage :: DiagnosticOpts NoMissingPat -> NoMissingPat -> DecoratedSDoc
diagnosticMessage DiagnosticOpts NoMissingPat
_ NoMissingPat
_ = SDoc -> DecoratedSDoc
Ghc.mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
forall doc. IsLine doc => String -> doc
Ghc.text String
"Module was not updated because all cases are already covered where SPLIT occurs"
  diagnosticReason :: NoMissingPat -> DiagnosticReason
diagnosticReason NoMissingPat
_ = DiagnosticReason
Ghc.ErrorWithoutFlag
  diagnosticHints :: NoMissingPat -> [GhcHint]
diagnosticHints NoMissingPat
_ = []
  diagnosticCode :: NoMissingPat -> Maybe DiagnosticCode
diagnosticCode NoMissingPat
_ = Maybe DiagnosticCode
forall a. Maybe a
Nothing
#if !MIN_VERSION_ghc(9,8,0)
  defaultDiagnosticOpts :: DiagnosticOpts NoMissingPat
defaultDiagnosticOpts = NoDiagnosticOpts
DiagnosticOpts NoMissingPat
Ghc.NoDiagnosticOpts
#endif

-- | Diagnostic thrown if the module fails to parse
data ParseFailed = ParseFailed

instance Ghc.Diagnostic ParseFailed where
  type DiagnosticOpts ParseFailed = Ghc.NoDiagnosticOpts
  diagnosticMessage :: DiagnosticOpts ParseFailed -> ParseFailed -> DecoratedSDoc
diagnosticMessage DiagnosticOpts ParseFailed
_ ParseFailed
_ = SDoc -> DecoratedSDoc
Ghc.mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
forall doc. IsLine doc => String -> doc
Ghc.text String
"auto-split failed to parse the module"
  diagnosticReason :: ParseFailed -> DiagnosticReason
diagnosticReason ParseFailed
_ = DiagnosticReason
Ghc.ErrorWithoutFlag
  diagnosticHints :: ParseFailed -> [GhcHint]
diagnosticHints ParseFailed
_ = []
  diagnosticCode :: ParseFailed -> Maybe DiagnosticCode
diagnosticCode ParseFailed
_ = Maybe DiagnosticCode
forall a. Maybe a
Nothing
#if !MIN_VERSION_ghc(9,8,0)
  defaultDiagnosticOpts :: DiagnosticOpts ParseFailed
defaultDiagnosticOpts = NoDiagnosticOpts
DiagnosticOpts ParseFailed
Ghc.NoDiagnosticOpts
#endif

data NonExhaustivePattern = NonExhaustivePattern
  { NonExhaustivePattern -> [Id]
patternIds :: [Ghc.Id]
  , NonExhaustivePattern -> [Nabla]
patternNablas :: [Ghc.Nabla]
  , NonExhaustivePattern -> RealSrcSpan
srcCodeLoc :: Ghc.RealSrcSpan
  }

-- | Before applying delta transformation, find the expressions that go with
-- non exhaustive patterns and mark them with a special comment containing the
-- index of that pattern. This must be done first because source code locations
-- are removed by delta transformation.
-- Problematic if delta moves comments to a different node, hopefully it won't.
searchAndMark
  :: [NonExhaustivePattern]
  -> Ghc.ParsedSource
  -> Ghc.ParsedSource
searchAndMark :: [NonExhaustivePattern] -> ParsedSource -> ParsedSource
searchAndMark [NonExhaustivePattern]
nePats =
    (forall a. Data a => a -> a) -> forall a. Data a => a -> a
Syb.everywhere ((GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
Syb.mkT LHsExpr GhcPs -> LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
goExpr (a -> a)
-> (GenLocated SrcSpanAnnA (HsDecl GhcPs)
    -> GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> a
-> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`Syb.extT` LHsDecl GhcPs -> LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
goDecl (a -> a)
-> (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
    -> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
-> a
-> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`Syb.extT` LHsBind GhcPs -> LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
goBind)
  where
  goExpr :: Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs
  goExpr :: LHsExpr GhcPs -> LHsExpr GhcPs
goExpr (Ghc.L SrcSpanAnnA
ann c :: HsExpr GhcPs
c@Ghc.HsCase{})
    | Just RealSrcSpan
caseLoc <- SrcSpan -> Maybe RealSrcSpan
Ghc.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
Ghc.locA SrcSpanAnnA
ann
    , Just Int
neIdx <- (NonExhaustivePattern -> Bool)
-> [NonExhaustivePattern] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
List.findIndex ((RealSrcSpan
caseLoc ==) (RealSrcSpan -> Bool)
-> (NonExhaustivePattern -> RealSrcSpan)
-> NonExhaustivePattern
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonExhaustivePattern -> RealSrcSpan
srcCodeLoc) [NonExhaustivePattern]
nePats
    = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L (SrcSpanAnnA -> Int -> SrcSpanAnnA
forall {a} {ann}.
(Show a, Monoid ann) =>
SrcSpanAnn' (EpAnn ann) -> a -> SrcSpanAnn' (EpAnn ann)
addIndexComment SrcSpanAnnA
ann Int
neIdx) HsExpr GhcPs
c
#if MIN_VERSION_ghc(9,10,0)
  goExpr (Ghc.L ann l@(Ghc.HsLam _ lamType _))
    | lamType /= Ghc.LamSingle
    , Just caseLoc <- Ghc.srcSpanToRealSrcSpan $ Ghc.locA ann
    , Just neIdx <- List.findIndex ((caseLoc ==) . srcCodeLoc) nePats
    = Ghc.L (addIndexComment ann neIdx) l
#elif MIN_VERSION_ghc(9,6,0)
  goExpr (Ghc.L SrcSpanAnnA
ann l :: HsExpr GhcPs
l@(Ghc.HsLamCase XLamCase GhcPs
_ LamCaseVariant
_ MatchGroup GhcPs (LHsExpr GhcPs)
_))
    | Just RealSrcSpan
caseLoc <- SrcSpan -> Maybe RealSrcSpan
Ghc.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
Ghc.locA SrcSpanAnnA
ann
    , Just Int
neIdx <- (NonExhaustivePattern -> Bool)
-> [NonExhaustivePattern] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
List.findIndex ((RealSrcSpan
caseLoc ==) (RealSrcSpan -> Bool)
-> (NonExhaustivePattern -> RealSrcSpan)
-> NonExhaustivePattern
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonExhaustivePattern -> RealSrcSpan
srcCodeLoc) [NonExhaustivePattern]
nePats
    = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L (SrcSpanAnnA -> Int -> SrcSpanAnnA
forall {a} {ann}.
(Show a, Monoid ann) =>
SrcSpanAnn' (EpAnn ann) -> a -> SrcSpanAnn' (EpAnn ann)
addIndexComment SrcSpanAnnA
ann Int
neIdx) HsExpr GhcPs
l
#endif
  goExpr LHsExpr GhcPs
x = LHsExpr GhcPs
x

  goDecl :: Ghc.LHsDecl Ghc.GhcPs -> Ghc.LHsDecl Ghc.GhcPs
  goDecl :: LHsDecl GhcPs -> LHsDecl GhcPs
goDecl (Ghc.L SrcSpanAnnA
ann f :: HsDecl GhcPs
f@(Ghc.ValD XValD GhcPs
_ Ghc.FunBind{}))
    | Just RealSrcSpan
caseLoc <- SrcSpan -> Maybe RealSrcSpan
Ghc.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
Ghc.locA SrcSpanAnnA
ann
    , Just Int
neIdx <- (NonExhaustivePattern -> Bool)
-> [NonExhaustivePattern] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
List.findIndex ((RealSrcSpan
caseLoc ==) (RealSrcSpan -> Bool)
-> (NonExhaustivePattern -> RealSrcSpan)
-> NonExhaustivePattern
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonExhaustivePattern -> RealSrcSpan
srcCodeLoc) [NonExhaustivePattern]
nePats
    = SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L (SrcSpanAnnA -> Int -> SrcSpanAnnA
forall {a} {ann}.
(Show a, Monoid ann) =>
SrcSpanAnn' (EpAnn ann) -> a -> SrcSpanAnn' (EpAnn ann)
addIndexComment SrcSpanAnnA
ann Int
neIdx) HsDecl GhcPs
f
  goDecl LHsDecl GhcPs
x = LHsDecl GhcPs
x

  goBind :: Ghc.LHsBind Ghc.GhcPs -> Ghc.LHsBind Ghc.GhcPs
  goBind :: LHsBind GhcPs -> LHsBind GhcPs
goBind (Ghc.L SrcSpanAnnA
ann f :: HsBindLR GhcPs GhcPs
f@Ghc.FunBind{})
    | Just RealSrcSpan
caseLoc <- SrcSpan -> Maybe RealSrcSpan
Ghc.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
Ghc.locA SrcSpanAnnA
ann
    , Just Int
neIdx <- (NonExhaustivePattern -> Bool)
-> [NonExhaustivePattern] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
List.findIndex ((RealSrcSpan
caseLoc ==) (RealSrcSpan -> Bool)
-> (NonExhaustivePattern -> RealSrcSpan)
-> NonExhaustivePattern
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonExhaustivePattern -> RealSrcSpan
srcCodeLoc) [NonExhaustivePattern]
nePats
    = SrcSpanAnnA
-> HsBindLR GhcPs GhcPs
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L (SrcSpanAnnA -> Int -> SrcSpanAnnA
forall {a} {ann}.
(Show a, Monoid ann) =>
SrcSpanAnn' (EpAnn ann) -> a -> SrcSpanAnn' (EpAnn ann)
addIndexComment SrcSpanAnnA
ann Int
neIdx) HsBindLR GhcPs GhcPs
f
  goBind LHsBind GhcPs
x = LHsBind GhcPs
x

  addIndexComment :: SrcSpanAnn' (EpAnn ann) -> a -> SrcSpanAnn' (EpAnn ann)
addIndexComment SrcSpanAnn' (EpAnn ann)
ann a
neIdx =
    let com :: Ghc.LEpaComment
        com :: LEpaComment
com = Anchor -> EpaComment -> LEpaComment
forall l e. l -> e -> GenLocated l e
Ghc.L Anchor
Ghc.fakeCommentLocation
          (EpaCommentTok -> RealSrcSpan -> EpaComment
Ghc.EpaComment (String -> EpaCommentTok
Ghc.EpaLineComment (a -> String
forall a. Show a => a -> String
show a
neIdx)) RealSrcSpan
Ghc.placeholderRealSpan)
        newComms :: EpAnnComments
newComms = case SrcSpanAnn' (EpAnn ann) -> EpAnnComments
forall ann. SrcSpanAnn' (EpAnn ann) -> EpAnnComments
Ghc.getComments SrcSpanAnn' (EpAnn ann)
ann of
          Ghc.EpaComments [LEpaComment]
cs -> [LEpaComment] -> EpAnnComments
Ghc.EpaComments ([LEpaComment] -> EpAnnComments) -> [LEpaComment] -> EpAnnComments
forall a b. (a -> b) -> a -> b
$ LEpaComment
com LEpaComment -> [LEpaComment] -> [LEpaComment]
forall a. a -> [a] -> [a]
: [LEpaComment]
cs
          Ghc.EpaCommentsBalanced [LEpaComment]
cs1 [LEpaComment]
cs2 -> [LEpaComment] -> [LEpaComment] -> EpAnnComments
Ghc.EpaCommentsBalanced (LEpaComment
com LEpaComment -> [LEpaComment] -> [LEpaComment]
forall a. a -> [a] -> [a]
: [LEpaComment]
cs1) [LEpaComment]
cs2
     in EpAnnComments
-> ann -> SrcSpanAnn' (EpAnn ann) -> SrcSpanAnn' (EpAnn ann)
forall ann.
EpAnnComments
-> ann -> SrcSpanAnn' (EpAnn ann) -> SrcSpanAnn' (EpAnn ann)
Ghc.setComments EpAnnComments
newComms ann
forall a. Monoid a => a
mempty SrcSpanAnn' (EpAnn ann)
ann

-- | Finds the target pattern and splits it. Returns the modified source and True if successful.
-- Applied post delta transformation.
splitPattern
  :: Ghc.GlobalRdrEnv
  -> [NonExhaustivePattern]
  -> Ghc.ParsedSource
  -> (Ghc.ParsedSource, Any)
splitPattern :: GlobalRdrEnv
-> [NonExhaustivePattern] -> ParsedSource -> (ParsedSource, Any)
splitPattern GlobalRdrEnv
gblRdrEnv [NonExhaustivePattern]
nePats ParsedSource
ps =
    Writer Any ParsedSource -> (ParsedSource, Any)
forall w a. Monoid w => Writer w a -> (a, w)
Writer.runWriter (Writer Any ParsedSource -> (ParsedSource, Any))
-> Writer Any ParsedSource -> (ParsedSource, Any)
forall a b. (a -> b) -> a -> b
$
      GenericM (WriterT Any Identity) -> GenericM (WriterT Any Identity)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
Syb.everywhereM
        ( (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> WriterT Any Identity (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> a -> WriterT Any Identity a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
Syb.mkM ((GenLocated SrcSpanAnnA (HsExpr GhcPs), Any)
-> WriterT Any Identity (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
(a, w) -> WriterT w m a
Writer.writer ((GenLocated SrcSpanAnnA (HsExpr GhcPs), Any)
 -> WriterT Any Identity (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> (GenLocated SrcSpanAnnA (HsExpr GhcPs), Any))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> WriterT Any Identity (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> (LHsExpr GhcPs, Any)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs), Any)
goExpr)
          (a -> WriterT Any Identity a)
-> (GenLocated SrcSpanAnnA (HsDecl GhcPs)
    -> WriterT Any Identity (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> a
-> WriterT Any Identity a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`Syb.extM` ((GenLocated SrcSpanAnnA (HsDecl GhcPs), Any)
-> WriterT Any Identity (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
(a, w) -> WriterT w m a
Writer.writer ((GenLocated SrcSpanAnnA (HsDecl GhcPs), Any)
 -> WriterT Any Identity (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> (GenLocated SrcSpanAnnA (HsDecl GhcPs)
    -> (GenLocated SrcSpanAnnA (HsDecl GhcPs), Any))
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> WriterT Any Identity (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsDecl GhcPs -> (LHsDecl GhcPs, Any)
GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> (GenLocated SrcSpanAnnA (HsDecl GhcPs), Any)
goDecl)
          (a -> WriterT Any Identity a)
-> (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
    -> WriterT
         Any Identity (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)))
-> a
-> WriterT Any Identity a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`Syb.extM` ((GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), Any)
-> WriterT
     Any Identity (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
(a, w) -> WriterT w m a
Writer.writer ((GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), Any)
 -> WriterT
      Any Identity (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)))
-> (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
    -> (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), Any))
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
-> WriterT
     Any Identity (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsBind GhcPs -> (LHsBind GhcPs, Any)
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
-> (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), Any)
goBind)
        ) ParsedSource
ps
  where
  isIdxComment :: GenLocated l EpaComment -> Bool
isIdxComment (Ghc.L l
_ (Ghc.EpaComment (Ghc.EpaLineComment String
str) RealSrcSpan
realSpan))
    = RealSrcSpan
realSpan RealSrcSpan -> RealSrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan
Ghc.placeholderRealSpan Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
Char.isDigit String
str
  isIdxComment GenLocated l EpaComment
_ = Bool
False

  extractIdxComment :: EpAnnComments -> Maybe (a, EpAnnComments)
extractIdxComment (Ghc.EpaComments [LEpaComment]
comms)
    | ([LEpaComment]
before, Ghc.L Anchor
_ (Ghc.EpaComment (Ghc.EpaLineComment String
str) RealSrcSpan
_) : [LEpaComment]
rest)
        <- (LEpaComment -> Bool)
-> [LEpaComment] -> ([LEpaComment], [LEpaComment])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break LEpaComment -> Bool
forall {l}. GenLocated l EpaComment -> Bool
isIdxComment [LEpaComment]
comms
    , Just a
idx <- String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe String
str
    , let newComments :: EpAnnComments
newComments = [LEpaComment] -> EpAnnComments
Ghc.EpaComments ([LEpaComment] -> EpAnnComments) -> [LEpaComment] -> EpAnnComments
forall a b. (a -> b) -> a -> b
$ [LEpaComment]
before [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. [a] -> [a] -> [a]
++ [LEpaComment]
rest
    = (a, EpAnnComments) -> Maybe (a, EpAnnComments)
forall a. a -> Maybe a
Just (a
idx, EpAnnComments
newComments)
  extractIdxComment Ghc.EpaCommentsBalanced{} = Maybe (a, EpAnnComments)
forall a. Maybe a
Nothing
  extractIdxComment EpAnnComments
_ = Maybe (a, EpAnnComments)
forall a. Maybe a
Nothing

  goExpr :: Ghc.LHsExpr Ghc.GhcPs -> (Ghc.LHsExpr Ghc.GhcPs, Any)
  goExpr :: LHsExpr GhcPs -> (LHsExpr GhcPs, Any)
goExpr (Ghc.L SrcSpanAnnA
ann (Ghc.HsCase XCase GhcPs
x LHsExpr GhcPs
scrut MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup))
    | Just (Int
neIdx, EpAnnComments
otherComms) <- EpAnnComments -> Maybe (Int, EpAnnComments)
forall {a}. Read a => EpAnnComments -> Maybe (a, EpAnnComments)
extractIdxComment (SrcSpanAnnA -> EpAnnComments
forall ann. SrcSpanAnn' (EpAnn ann) -> EpAnnComments
Ghc.getComments SrcSpanAnnA
ann)
    , Just NonExhaustivePattern
nePat <- [NonExhaustivePattern] -> Maybe NonExhaustivePattern
forall a. [a] -> Maybe a
listToMaybe ([NonExhaustivePattern] -> Maybe NonExhaustivePattern)
-> [NonExhaustivePattern] -> Maybe NonExhaustivePattern
forall a b. (a -> b) -> a -> b
$ Int -> [NonExhaustivePattern] -> [NonExhaustivePattern]
forall a. Int -> [a] -> [a]
drop Int
neIdx [NonExhaustivePattern]
nePats
    , Just MatchGroup GhcPs (LHsExpr GhcPs)
newMG <- GlobalRdrEnv
-> Bool
-> Bool
-> Int
-> NonExhaustivePattern
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> Maybe (MatchGroup GhcPs (LHsExpr GhcPs))
splitMG GlobalRdrEnv
gblRdrEnv Bool
False Bool
False Int
0 NonExhaustivePattern
nePat MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup
    = ( SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L (EpAnnComments -> AnnListItem -> SrcSpanAnnA -> SrcSpanAnnA
forall ann.
EpAnnComments
-> ann -> SrcSpanAnn' (EpAnn ann) -> SrcSpanAnn' (EpAnn ann)
Ghc.setComments EpAnnComments
otherComms AnnListItem
forall a. Monoid a => a
mempty SrcSpanAnnA
ann) (XCase GhcPs
-> LHsExpr GhcPs
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> HsExpr GhcPs
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
Ghc.HsCase XCase GhcPs
x LHsExpr GhcPs
scrut MatchGroup GhcPs (LHsExpr GhcPs)
newMG)
      , Bool -> Any
Any Bool
True
      )
#if MIN_VERSION_ghc(9,10,0)
  goExpr (Ghc.L ann (Ghc.HsLam x lamType matchGroup@(Ghc.MG _ (Ghc.L matchesAnn _))))
    | lamType /= Ghc.LamSingle
    , Just (neIdx, otherComms) <- extractIdxComment (Ghc.comments ann)
    , Just nePat <- nePats List.!? neIdx
    , Just newMG <- splitMG gblRdrEnv True False (Ghc.colDelta matchesAnn) nePat matchGroup
    = ( Ghc.L ann {Ghc.comments = otherComms} (Ghc.HsLam x lamType newMG)
      , Any True
      )
#elif MIN_VERSION_ghc(9,6,0)
  goExpr (Ghc.L SrcSpanAnnA
ann (Ghc.HsLamCase XLamCase GhcPs
x LamCaseVariant
lamType matchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup@(Ghc.MG XMG GhcPs (LHsExpr GhcPs)
_ (Ghc.L SrcSpanAnn' (EpAnn AnnList)
matchesAnn [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
_))))
    | Just (Int
neIdx, EpAnnComments
otherComms) <- EpAnnComments -> Maybe (Int, EpAnnComments)
forall {a}. Read a => EpAnnComments -> Maybe (a, EpAnnComments)
extractIdxComment (SrcSpanAnnA -> EpAnnComments
forall ann. SrcSpanAnn' (EpAnn ann) -> EpAnnComments
Ghc.getComments SrcSpanAnnA
ann)
    , Just NonExhaustivePattern
nePat <- [NonExhaustivePattern] -> Maybe NonExhaustivePattern
forall a. [a] -> Maybe a
listToMaybe ([NonExhaustivePattern] -> Maybe NonExhaustivePattern)
-> [NonExhaustivePattern] -> Maybe NonExhaustivePattern
forall a b. (a -> b) -> a -> b
$ Int -> [NonExhaustivePattern] -> [NonExhaustivePattern]
forall a. Int -> [a] -> [a]
drop Int
neIdx [NonExhaustivePattern]
nePats
    , Just MatchGroup GhcPs (LHsExpr GhcPs)
newMG <- GlobalRdrEnv
-> Bool
-> Bool
-> Int
-> NonExhaustivePattern
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> Maybe (MatchGroup GhcPs (LHsExpr GhcPs))
splitMG GlobalRdrEnv
gblRdrEnv Bool
True Bool
False (SrcSpanAnn' (EpAnn AnnList) -> Int
forall ann. SrcSpanAnn' (EpAnn ann) -> Int
Ghc.colDelta SrcSpanAnn' (EpAnn AnnList)
matchesAnn) NonExhaustivePattern
nePat MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup
    = ( SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L (EpAnnComments -> AnnListItem -> SrcSpanAnnA -> SrcSpanAnnA
forall ann.
EpAnnComments
-> ann -> SrcSpanAnn' (EpAnn ann) -> SrcSpanAnn' (EpAnn ann)
Ghc.setComments EpAnnComments
otherComms AnnListItem
forall a. Monoid a => a
mempty SrcSpanAnnA
ann) (XLamCase GhcPs
-> LamCaseVariant
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> HsExpr GhcPs
forall p.
XLamCase p
-> LamCaseVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
Ghc.HsLamCase XLamCase GhcPs
x LamCaseVariant
lamType MatchGroup GhcPs (LHsExpr GhcPs)
newMG)
      , Bool -> Any
Any Bool
True
      )
#endif
  goExpr LHsExpr GhcPs
expr = (LHsExpr GhcPs
expr, Bool -> Any
Any Bool
False)

  goDecl :: Ghc.LHsDecl Ghc.GhcPs -> (Ghc.LHsDecl Ghc.GhcPs, Any)
  goDecl :: LHsDecl GhcPs -> (LHsDecl GhcPs, Any)
goDecl (Ghc.L SrcSpanAnnA
ann (Ghc.ValD XValD GhcPs
x (Ghc.FunBind XFunBind GhcPs GhcPs
x2 LIdP GhcPs
fid MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup)))
    | Just (Int
neIdx, EpAnnComments
otherComms) <- EpAnnComments -> Maybe (Int, EpAnnComments)
forall {a}. Read a => EpAnnComments -> Maybe (a, EpAnnComments)
extractIdxComment (SrcSpanAnnA -> EpAnnComments
forall ann. SrcSpanAnn' (EpAnn ann) -> EpAnnComments
Ghc.getComments SrcSpanAnnA
ann)
    , Just NonExhaustivePattern
nePat <- [NonExhaustivePattern] -> Maybe NonExhaustivePattern
forall a. [a] -> Maybe a
listToMaybe ([NonExhaustivePattern] -> Maybe NonExhaustivePattern)
-> [NonExhaustivePattern] -> Maybe NonExhaustivePattern
forall a b. (a -> b) -> a -> b
$ Int -> [NonExhaustivePattern] -> [NonExhaustivePattern]
forall a. Int -> [a] -> [a]
drop Int
neIdx [NonExhaustivePattern]
nePats
    , Just MatchGroup GhcPs (LHsExpr GhcPs)
newMG <- GlobalRdrEnv
-> Bool
-> Bool
-> Int
-> NonExhaustivePattern
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> Maybe (MatchGroup GhcPs (LHsExpr GhcPs))
splitMG GlobalRdrEnv
gblRdrEnv Bool
True Bool
True Int
0 NonExhaustivePattern
nePat MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup
    = ( SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L (EpAnnComments -> AnnListItem -> SrcSpanAnnA -> SrcSpanAnnA
forall ann.
EpAnnComments
-> ann -> SrcSpanAnn' (EpAnn ann) -> SrcSpanAnn' (EpAnn ann)
Ghc.setComments EpAnnComments
otherComms AnnListItem
forall a. Monoid a => a
mempty SrcSpanAnnA
ann) (XValD GhcPs -> HsBindLR GhcPs GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
Ghc.ValD XValD GhcPs
x (XFunBind GhcPs GhcPs
-> LIdP GhcPs
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> HsBindLR GhcPs GhcPs
forall idL idR.
XFunBind idL idR
-> LIdP idL -> MatchGroup idR (LHsExpr idR) -> HsBindLR idL idR
Ghc.FunBind XFunBind GhcPs GhcPs
x2 LIdP GhcPs
fid MatchGroup GhcPs (LHsExpr GhcPs)
newMG))
      , Bool -> Any
Any Bool
True
      )
  goDecl LHsDecl GhcPs
decl = (LHsDecl GhcPs
decl, Bool -> Any
Any Bool
False)

  goBind :: Ghc.LHsBind Ghc.GhcPs -> (Ghc.LHsBind Ghc.GhcPs, Any)
  goBind :: LHsBind GhcPs -> (LHsBind GhcPs, Any)
goBind (Ghc.L SrcSpanAnnA
ann (Ghc.FunBind XFunBind GhcPs GhcPs
x2 LIdP GhcPs
fid MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup))
    | Just (Int
neIdx, EpAnnComments
otherComms) <- EpAnnComments -> Maybe (Int, EpAnnComments)
forall {a}. Read a => EpAnnComments -> Maybe (a, EpAnnComments)
extractIdxComment (SrcSpanAnnA -> EpAnnComments
forall ann. SrcSpanAnn' (EpAnn ann) -> EpAnnComments
Ghc.getComments SrcSpanAnnA
ann)
    , Just NonExhaustivePattern
nePat <- [NonExhaustivePattern] -> Maybe NonExhaustivePattern
forall a. [a] -> Maybe a
listToMaybe ([NonExhaustivePattern] -> Maybe NonExhaustivePattern)
-> [NonExhaustivePattern] -> Maybe NonExhaustivePattern
forall a b. (a -> b) -> a -> b
$ Int -> [NonExhaustivePattern] -> [NonExhaustivePattern]
forall a. Int -> [a] -> [a]
drop Int
neIdx [NonExhaustivePattern]
nePats
    , Just MatchGroup GhcPs (LHsExpr GhcPs)
newMG <- GlobalRdrEnv
-> Bool
-> Bool
-> Int
-> NonExhaustivePattern
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> Maybe (MatchGroup GhcPs (LHsExpr GhcPs))
splitMG GlobalRdrEnv
gblRdrEnv Bool
True Bool
True Int
0 NonExhaustivePattern
nePat MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup
    = ( SrcSpanAnnA
-> HsBindLR GhcPs GhcPs
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L (EpAnnComments -> AnnListItem -> SrcSpanAnnA -> SrcSpanAnnA
forall ann.
EpAnnComments
-> ann -> SrcSpanAnn' (EpAnn ann) -> SrcSpanAnn' (EpAnn ann)
Ghc.setComments EpAnnComments
otherComms AnnListItem
forall a. Monoid a => a
mempty SrcSpanAnnA
ann) (XFunBind GhcPs GhcPs
-> LIdP GhcPs
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> HsBindLR GhcPs GhcPs
forall idL idR.
XFunBind idL idR
-> LIdP idL -> MatchGroup idR (LHsExpr idR) -> HsBindLR idL idR
Ghc.FunBind XFunBind GhcPs GhcPs
x2 LIdP GhcPs
fid MatchGroup GhcPs (LHsExpr GhcPs)
newMG)
      , Bool -> Any
Any Bool
True
      )
  goBind LHsBind GhcPs
bind = (LHsBind GhcPs
bind, Bool -> Any
Any Bool
False)

splitMG
  :: Ghc.GlobalRdrEnv
  -> Bool -- True => match group can have multiple patterns
  -> Bool -- True => add left padding to each new pattern
  -> Int -- Number of horizontal spaces at the front of inserted pattern match
  -> NonExhaustivePattern
  -> Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)
  -> Maybe (Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs))
splitMG :: GlobalRdrEnv
-> Bool
-> Bool
-> Int
-> NonExhaustivePattern
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> Maybe (MatchGroup GhcPs (LHsExpr GhcPs))
splitMG GlobalRdrEnv
gblRdrEnv Bool
multiplePats Bool
offsetFirstPat Int
colOffset NonExhaustivePattern
nePat (Ghc.MG XMG GhcPs (LHsExpr GhcPs)
x2 (Ghc.L SrcSpanAnn' (EpAnn AnnList)
ann2 [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches))
  | ([GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
beforeSplit, Ghc.L SrcSpanAnnA
splitAnn targetMatch :: Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
targetMatch@(Ghc.Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ HsMatchContext GhcPs
ctx [LPat GhcPs]
_ GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs) : [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
afterSplit)
      <- (GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> Bool)
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> ([GenLocated
       SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))],
    [GenLocated
       SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break LMatch GhcPs (LHsExpr GhcPs) -> Bool
GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Bool
matchHasSplit [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches
  , let mUpdatedMatch :: Maybe
  (GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
mUpdatedMatch = SrcSpanAnnA
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnnA
splitAnn (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Maybe (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Match GhcPs (LHsExpr GhcPs) -> Maybe (Match GhcPs (LHsExpr GhcPs))
removeSplitFromOrPat Match GhcPs (LHsExpr GhcPs)
Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
targetMatch
        -- If splitting the first match, trailing matches need to have a delta
        -- putting it on a new line
        correctDeltas :: [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
correctDeltas [] = []
        correctDeltas (GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
x : [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
xs) | Maybe
  (GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Bool
forall a. Maybe a -> Bool
isNothing Maybe
  (GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
mUpdatedMatch =
          GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
x GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. a -> [a] -> [a]
:
            (SrcSpanAnnA
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
Ghc.L (Int -> SrcSpanAnnA
Ghc.nextLine Int
colOffset) (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> (GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall l e. GenLocated l e -> e
Ghc.unLoc
             (GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
xs)
        correctDeltas [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
xs = SrcSpanAnnA
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
Ghc.L (Int -> SrcSpanAnnA
Ghc.nextLine Int
colOffset) (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> (GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall l e. GenLocated l e -> e
Ghc.unLoc (GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
xs
        newMatches :: [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
newMatches = [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
correctDeltas ([GenLocated
    SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> [GenLocated
       SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ do
          Nabla
nabla <- NonExhaustivePattern -> [Nabla]
patternNablas NonExhaustivePattern
nePat
          let pats :: [GenLocated SrcSpanAnnA (Pat GhcPs)]
pats =
                (Bool -> Id -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [Bool] -> [Id] -> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GlobalRdrEnv -> Nabla -> Bool -> Bool -> Id -> LPat GhcPs
mkPat GlobalRdrEnv
gblRdrEnv Nabla
nabla (Bool -> Bool -> Id -> LPat GhcPs)
-> Bool -> Bool -> Id -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
multiplePats)
                        (Bool
offsetFirstPat Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True)
                        (NonExhaustivePattern -> [Id]
patternIds NonExhaustivePattern
nePat)
          [ SrcSpanAnnA
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnnA
splitAnn (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsMatchContext GhcPs
-> [LPat GhcPs]
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCMatch p body
-> HsMatchContext p -> [LPat p] -> GRHSs p body -> Match p body
Ghc.Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
EpAnn [AddEpAnn]
forall a. EpAnn a
Ghc.noExtFieldCpp HsMatchContext GhcPs
ctx ([GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a. a -> a
Ghc.noLocCpp [GenLocated SrcSpanAnnA (Pat GhcPs)]
pats) GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs ]
        removeSplits :: GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
removeSplits GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
m =
          case (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Maybe (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (GenLocated
        SrcSpanAnnA (Match 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 SrcSpanAnnA a -> f (GenLocated SrcSpanAnnA b)
traverse Match GhcPs (LHsExpr GhcPs) -> Maybe (Match GhcPs (LHsExpr GhcPs))
Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
removeSplitFromOrPat GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
m of
            Maybe
  (GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
Nothing -> if LMatch GhcPs (LHsExpr GhcPs) -> Bool
matchHasSplit LMatch GhcPs (LHsExpr GhcPs)
GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
m then Maybe
  (GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a. Maybe a
Nothing else GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a. a -> Maybe a
Just GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
m
            Just GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
newM -> GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a. a -> Maybe a
Just GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
newM
        afterSplitUpdated :: [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
afterSplitUpdated = (GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> Maybe
      (GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
removeSplits [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
afterSplit
        newMatchGroup :: [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
newMatchGroup
          = [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
beforeSplit
         [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ Maybe
  (GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. Maybe a -> [a]
maybeToList Maybe
  (GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
mUpdatedMatch
         [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
newMatches
         [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
afterSplitUpdated
  = MatchGroup GhcPs (LHsExpr GhcPs)
-> Maybe (MatchGroup GhcPs (LHsExpr GhcPs))
forall a. a -> Maybe a
Just (MatchGroup GhcPs (LHsExpr GhcPs)
 -> Maybe (MatchGroup GhcPs (LHsExpr GhcPs)))
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> Maybe (MatchGroup GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ XMG GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> XRec
     GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XMG p body -> XRec p [LMatch p body] -> MatchGroup p body
Ghc.MG XMG GhcPs (LHsExpr GhcPs)
XMG GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
x2 (SrcSpanAnn' (EpAnn AnnList)
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
     (SrcSpanAnn' (EpAnn AnnList))
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnn' (EpAnn AnnList)
ann2 [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
newMatchGroup)
  | Bool
otherwise = Maybe (MatchGroup GhcPs (LHsExpr GhcPs))
Maybe (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a
Nothing

matchHasSplit :: Ghc.LMatch Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) -> Bool
matchHasSplit :: LMatch GhcPs (LHsExpr GhcPs) -> Bool
matchHasSplit (Ghc.L SrcSpanAnnA
_ (Ghc.Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ HsMatchContext GhcPs
_ [LPat GhcPs]
pats GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_)) =
    (Bool -> Bool -> Bool) -> GenericQ Bool -> GenericQ Bool
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
Syb.everything Bool -> Bool -> Bool
(||) (Bool -> (Pat GhcPs -> Bool) -> a -> Bool
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
Syb.mkQ Bool
False Pat GhcPs -> Bool
isSplitCon) [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats

isSplitCon :: Ghc.Pat Ghc.GhcPs -> Bool
isSplitCon :: Pat GhcPs -> Bool
isSplitCon (Ghc.ConPat XConPat GhcPs
_ (Ghc.L SrcSpanAnnN
_ RdrName
rdr) HsConPatDetails GhcPs
_) =
  RdrName -> OccName
Ghc.rdrNameOcc RdrName
rdr OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> OccName
Ghc.mkDataOcc String
forall a. IsString a => a
splitName
isSplitCon Pat GhcPs
_ = Bool
False

-- | Remove SPLIT pattern from OrPat groups. Returns Just if the match was modified.
removeSplitFromOrPat
  :: Ghc.Match Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)
  -> Maybe (Ghc.Match Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs))
#if MIN_VERSION_ghc(9,12,0)
removeSplitFromOrPat (Ghc.Match a b pats c) =
  let mNewPats = Syb.everywhereM (Syb.mkM (Writer.writer . go)) pats
      patHasSplit = Syb.everything (||) (Syb.mkQ False isSplitCon)
      dropSemicolon ann = ann { Ghc.anns = Ghc.noAnn }
      go :: Ghc.Pat Ghc.GhcPs -> (Ghc.Pat Ghc.GhcPs, Any)
      go (Ghc.OrPat x oPats) =
        case reverse (NE.filter (not . patHasSplit) oPats) of
          [] -> (Ghc.WildPat Ghc.noExtField, Any True)
          (Ghc.L patAnn lastPat : fPats)
            | length fPats + 1 /= NE.length oPats ->
                ( Ghc.OrPat x
                    (NE.reverse $ Ghc.L (dropSemicolon patAnn) lastPat NE.:| fPats)
                , Any True)
            | otherwise -> (Ghc.OrPat x oPats, Any False)
      go other = (other, Any False)
   in case Writer.runWriter mNewPats of
        (newPats, Any True) -> Just (Ghc.Match a b newPats c)
        _ -> Nothing
#else
removeSplitFromOrPat :: Match GhcPs (LHsExpr GhcPs) -> Maybe (Match GhcPs (LHsExpr GhcPs))
removeSplitFromOrPat Match GhcPs (LHsExpr GhcPs)
_ = Maybe (Match GhcPs (LHsExpr GhcPs))
Maybe (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a
Nothing
#endif

-- | Produce a 'Pat' for a missing pattern
mkPat
  :: Ghc.GlobalRdrEnv
  -> Ghc.Nabla
  -> Bool -- ^ True => is a singular pattern which doesn't need outer parens
  -> Bool -- ^ True => needs left padding to separate it from another pattern
  -> Ghc.Id
  -> Ghc.LPat Ghc.GhcPs
mkPat :: GlobalRdrEnv -> Nabla -> Bool -> Bool -> Id -> LPat GhcPs
mkPat GlobalRdrEnv
gblRdrEnv Nabla
nabla Bool
isOutermost Bool
needsLeftPad Id
x = SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnnA
delta (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$
  case Nabla -> Id -> Maybe PmAltConApp
Ghc.lookupSolution Nabla
nabla Id
x of
    Maybe PmAltConApp
Nothing -> XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
Ghc.WildPat XWildPat GhcPs
NoExtField
Ghc.noExtField
    Just (Ghc.PACA (Ghc.PmAltConLike ConLike
con) [Id]
_tvs [Id]
args) -> ConLike -> [Id] -> Pat GhcPs -> Pat GhcPs
paren ConLike
con [Id]
args (Pat GhcPs -> Pat GhcPs) -> Pat GhcPs -> Pat GhcPs
forall a b. (a -> b) -> a -> b
$
      case ConLike -> Bool
Ghc.conLikeIsInfix ConLike
con of
        Bool
True | [Id
arg1, Id
arg2] <- [Id]
args ->
          XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConPatDetails GhcPs
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
Ghc.ConPat XConPat GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
Ghc.noAnn
            ( SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnnN
Ghc.nameAnchorD1
            (RdrName -> XRec GhcPs (ConLikeP GhcPs))
-> (Name -> RdrName) -> Name -> XRec GhcPs (ConLikeP GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrEnv -> Name -> RdrName
nameToRdrName GlobalRdrEnv
gblRdrEnv
            (Name -> XRec GhcPs (ConLikeP GhcPs))
-> Name -> XRec GhcPs (ConLikeP GhcPs)
forall a b. (a -> b) -> a -> b
$ ConLike -> Name
Ghc.conLikeName ConLike
con
            )
          (HsConPatDetails GhcPs -> Pat GhcPs)
-> HsConPatDetails GhcPs -> Pat GhcPs
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
Ghc.InfixCon (GlobalRdrEnv -> Nabla -> Bool -> Bool -> Id -> LPat GhcPs
mkPat GlobalRdrEnv
gblRdrEnv Nabla
nabla Bool
False Bool
False Id
arg1)
                         (GlobalRdrEnv -> Nabla -> Bool -> Bool -> Id -> LPat GhcPs
mkPat GlobalRdrEnv
gblRdrEnv Nabla
nabla Bool
False Bool
True Id
arg2)
        Bool
_ | Ghc.RealDataCon DataCon
dc <- ConLike
con
          , DataCon -> Bool
Ghc.isUnboxedTupleDataCon DataCon
dc
          -> XTuplePat GhcPs -> [LPat GhcPs] -> Boxity -> Pat GhcPs
forall p. XTuplePat p -> [LPat p] -> Boxity -> Pat p
Ghc.TuplePat XTuplePat GhcPs
EpAnn [AddEpAnn]
Ghc.parenHashAnns
               ([GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall {e}.
[GenLocated SrcSpanAnnA e] -> [GenLocated SrcSpanAnnA e]
addCommaAnns ([GenLocated SrcSpanAnnA (Pat GhcPs)]
 -> [GenLocated SrcSpanAnnA (Pat GhcPs)])
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b. (a -> b) -> a -> b
$ (Bool -> Id -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [Bool] -> [Id] -> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GlobalRdrEnv -> Nabla -> Bool -> Bool -> Id -> LPat GhcPs
mkPat GlobalRdrEnv
gblRdrEnv Nabla
nabla Bool
True) (Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True) [Id]
args)
               Boxity
Ghc.Unboxed
        Bool
_ | Ghc.RealDataCon DataCon
dc <- ConLike
con
          , DataCon -> Bool
Ghc.isTupleDataCon DataCon
dc
          -> XTuplePat GhcPs -> [LPat GhcPs] -> Boxity -> Pat GhcPs
forall p. XTuplePat p -> [LPat p] -> Boxity -> Pat p
Ghc.TuplePat XTuplePat GhcPs
EpAnn [AddEpAnn]
Ghc.parenAnns
               ([GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall {e}.
[GenLocated SrcSpanAnnA e] -> [GenLocated SrcSpanAnnA e]
addCommaAnns ([GenLocated SrcSpanAnnA (Pat GhcPs)]
 -> [GenLocated SrcSpanAnnA (Pat GhcPs)])
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b. (a -> b) -> a -> b
$ (Bool -> Id -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [Bool] -> [Id] -> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GlobalRdrEnv -> Nabla -> Bool -> Bool -> Id -> LPat GhcPs
mkPat GlobalRdrEnv
gblRdrEnv Nabla
nabla Bool
True) (Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True) [Id]
args)
               Boxity
Ghc.Boxed
        Bool
_ ->
          -- If GHC tries to use SPLIT as a missing pattern, replace it with wildcard
          if Name -> OccName
forall name. HasOccName name => name -> OccName
Ghc.occName (ConLike -> Name
Ghc.conLikeName ConLike
con) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> OccName
Ghc.mkDataOcc String
forall a. IsString a => a
splitName
          then XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
Ghc.WildPat XWildPat GhcPs
NoExtField
Ghc.noExtField
          else XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConPatDetails GhcPs
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
Ghc.ConPat XConPat GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
Ghc.noAnn
                ( SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnnN
Ghc.nameAnchorD0
                (RdrName -> XRec GhcPs (ConLikeP GhcPs))
-> (Name -> RdrName) -> Name -> XRec GhcPs (ConLikeP GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrEnv -> Name -> RdrName
nameToRdrName GlobalRdrEnv
gblRdrEnv (Name -> XRec GhcPs (ConLikeP GhcPs))
-> Name -> XRec GhcPs (ConLikeP GhcPs)
forall a b. (a -> b) -> a -> b
$ ConLike -> Name
Ghc.conLikeName ConLike
con
                )
             (HsConPatDetails GhcPs -> Pat GhcPs)
-> HsConPatDetails GhcPs -> Pat GhcPs
forall a b. (a -> b) -> a -> b
$ [HsConPatTyArg GhcPs]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
Ghc.PrefixCon [] (GlobalRdrEnv -> Nabla -> Bool -> Bool -> Id -> LPat GhcPs
mkPat GlobalRdrEnv
gblRdrEnv Nabla
nabla Bool
False Bool
True (Id -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [Id] -> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Id]
args)
    Just (Ghc.PACA (Ghc.PmAltLit PmLit
lit) [Id]
_tvs [Id]
_args) ->
      case PmLit -> PmLitValue
Ghc.pm_lit_val PmLit
lit of
        Ghc.PmLitInt Integer
integer ->
          XNPat GhcPs
-> XRec GhcPs (HsOverLit GhcPs)
-> Maybe (SyntaxExpr GhcPs)
-> SyntaxExpr GhcPs
-> Pat GhcPs
forall p.
XNPat p
-> XRec p (HsOverLit p)
-> Maybe (SyntaxExpr p)
-> SyntaxExpr p
-> Pat p
Ghc.NPat XNPat GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
Ghc.noAnn (HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall a an. a -> LocatedAn an a
Ghc.noLocA (HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs))
-> HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XOverLit GhcPs -> OverLitVal -> HsOverLit GhcPs
forall p. XOverLit p -> OverLitVal -> HsOverLit p
Ghc.OverLit XOverLit GhcPs
NoExtField
Ghc.noExtField (OverLitVal -> HsOverLit GhcPs) -> OverLitVal -> HsOverLit GhcPs
forall a b. (a -> b) -> a -> b
$ IntegralLit -> OverLitVal
Ghc.HsIntegral (IntegralLit -> OverLitVal) -> IntegralLit -> OverLitVal
forall a b. (a -> b) -> a -> b
$ SourceText -> Bool -> Integer -> IntegralLit
Ghc.IL (String -> SourceText
Ghc.SourceText (String -> SourceText)
-> (String -> String) -> String -> SourceText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. IsString a => String -> a
fromString (String -> SourceText) -> String -> SourceText
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
integer) (Integer
integer Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) Integer
integer) Maybe NoExtField
Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing NoExtField
SyntaxExpr GhcPs
Ghc.noExtField
        Ghc.PmLitRat Rational
rational ->
          XNPat GhcPs
-> XRec GhcPs (HsOverLit GhcPs)
-> Maybe (SyntaxExpr GhcPs)
-> SyntaxExpr GhcPs
-> Pat GhcPs
forall p.
XNPat p
-> XRec p (HsOverLit p)
-> Maybe (SyntaxExpr p)
-> SyntaxExpr p
-> Pat p
Ghc.NPat XNPat GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
Ghc.noAnn (HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall a an. a -> LocatedAn an a
Ghc.noLocA (HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs))
-> HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XOverLit GhcPs -> OverLitVal -> HsOverLit GhcPs
forall p. XOverLit p -> OverLitVal -> HsOverLit p
Ghc.OverLit XOverLit GhcPs
NoExtField
Ghc.noExtField (OverLitVal -> HsOverLit GhcPs) -> OverLitVal -> HsOverLit GhcPs
forall a b. (a -> b) -> a -> b
$ FractionalLit -> OverLitVal
Ghc.HsFractional (FractionalLit -> OverLitVal) -> FractionalLit -> OverLitVal
forall a b. (a -> b) -> a -> b
$ Rational -> FractionalLit
Ghc.mkTHFractionalLit Rational
rational) Maybe NoExtField
Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing NoExtField
SyntaxExpr GhcPs
Ghc.noExtField
        Ghc.PmLitChar Char
char -> XLitPat GhcPs -> HsLit GhcPs -> Pat GhcPs
forall p. XLitPat p -> HsLit p -> Pat p
Ghc.LitPat XLitPat GhcPs
NoExtField
Ghc.noExtField (HsLit GhcPs -> Pat GhcPs) -> HsLit GhcPs -> Pat GhcPs
forall a b. (a -> b) -> a -> b
$ XHsChar GhcPs -> Char -> HsLit GhcPs
forall x. XHsChar x -> Char -> HsLit x
Ghc.HsChar XHsChar GhcPs
SourceText
Ghc.NoSourceText Char
char
        Ghc.PmLitString FastString
fastString -> XLitPat GhcPs -> HsLit GhcPs -> Pat GhcPs
forall p. XLitPat p -> HsLit p -> Pat p
Ghc.LitPat XLitPat GhcPs
NoExtField
Ghc.noExtField (HsLit GhcPs -> Pat GhcPs) -> HsLit GhcPs -> Pat GhcPs
forall a b. (a -> b) -> a -> b
$ XHsString GhcPs -> FastString -> HsLit GhcPs
forall x. XHsString x -> FastString -> HsLit x
Ghc.HsString XHsString GhcPs
SourceText
Ghc.NoSourceText FastString
fastString
        Ghc.PmLitOverInt Int
_minuses Integer
integer ->
          XNPat GhcPs
-> XRec GhcPs (HsOverLit GhcPs)
-> Maybe (SyntaxExpr GhcPs)
-> SyntaxExpr GhcPs
-> Pat GhcPs
forall p.
XNPat p
-> XRec p (HsOverLit p)
-> Maybe (SyntaxExpr p)
-> SyntaxExpr p
-> Pat p
Ghc.NPat XNPat GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
Ghc.noAnn (HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall a an. a -> LocatedAn an a
Ghc.noLocA (HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs))
-> HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XOverLit GhcPs -> OverLitVal -> HsOverLit GhcPs
forall p. XOverLit p -> OverLitVal -> HsOverLit p
Ghc.OverLit XOverLit GhcPs
NoExtField
Ghc.noExtField (OverLitVal -> HsOverLit GhcPs) -> OverLitVal -> HsOverLit GhcPs
forall a b. (a -> b) -> a -> b
$ IntegralLit -> OverLitVal
Ghc.HsIntegral (IntegralLit -> OverLitVal) -> IntegralLit -> OverLitVal
forall a b. (a -> b) -> a -> b
$ SourceText -> Bool -> Integer -> IntegralLit
Ghc.IL (String -> SourceText
Ghc.SourceText (String -> SourceText)
-> (String -> String) -> String -> SourceText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. IsString a => String -> a
fromString (String -> SourceText) -> String -> SourceText
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
integer) (Integer
integer Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) Integer
integer) Maybe NoExtField
Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing NoExtField
SyntaxExpr GhcPs
Ghc.noExtField
        Ghc.PmLitOverRat Int
_minuses FractionalLit
fractionalLit ->
          XNPat GhcPs
-> XRec GhcPs (HsOverLit GhcPs)
-> Maybe (SyntaxExpr GhcPs)
-> SyntaxExpr GhcPs
-> Pat GhcPs
forall p.
XNPat p
-> XRec p (HsOverLit p)
-> Maybe (SyntaxExpr p)
-> SyntaxExpr p
-> Pat p
Ghc.NPat XNPat GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
Ghc.noAnn (HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall a an. a -> LocatedAn an a
Ghc.noLocA (HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs))
-> HsOverLit GhcPs -> LocatedAn NoEpAnns (HsOverLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XOverLit GhcPs -> OverLitVal -> HsOverLit GhcPs
forall p. XOverLit p -> OverLitVal -> HsOverLit p
Ghc.OverLit XOverLit GhcPs
NoExtField
Ghc.noExtField (OverLitVal -> HsOverLit GhcPs) -> OverLitVal -> HsOverLit GhcPs
forall a b. (a -> b) -> a -> b
$ FractionalLit -> OverLitVal
Ghc.HsFractional FractionalLit
fractionalLit) Maybe NoExtField
Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing NoExtField
SyntaxExpr GhcPs
Ghc.noExtField
        Ghc.PmLitOverString FastString
fastString -> XLitPat GhcPs -> HsLit GhcPs -> Pat GhcPs
forall p. XLitPat p -> HsLit p -> Pat p
Ghc.LitPat XLitPat GhcPs
NoExtField
Ghc.noExtField (HsLit GhcPs -> Pat GhcPs) -> HsLit GhcPs -> Pat GhcPs
forall a b. (a -> b) -> a -> b
$ XHsString GhcPs -> FastString -> HsLit GhcPs
forall x. XHsString x -> FastString -> HsLit x
Ghc.HsString XHsString GhcPs
SourceText
Ghc.NoSourceText FastString
fastString
  where
    delta :: SrcSpanAnnA
delta = if Bool
needsLeftPad
               then SrcSpanAnnA
Ghc.anchorD1
               else SrcSpanAnnA
Ghc.anchorD0
    paren :: ConLike -> [Id] -> Pat GhcPs -> Pat GhcPs
paren ConLike
_ [] Pat GhcPs
inner = Pat GhcPs
inner
    paren (Ghc.RealDataCon DataCon
dc) [Id]
_ Pat GhcPs
inner | DataCon -> Bool
Ghc.isTupleDataCon DataCon
dc = Pat GhcPs
inner -- No parens for tuple pats
    paren ConLike
_ [Id]
_ Pat GhcPs
inner =
      if Bool -> Bool
not Bool
isOutermost
      then LPat GhcPs -> Pat GhcPs
Ghc.mkParPat' (SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnnA
Ghc.anchorD0 Pat GhcPs
inner)
      else Pat GhcPs
inner
    addCommaAnns :: [GenLocated SrcSpanAnnA e] -> [GenLocated SrcSpanAnnA e]
addCommaAnns [] = []
    addCommaAnns [GenLocated SrcSpanAnnA e
a] = [GenLocated SrcSpanAnnA e
a]
    addCommaAnns (Ghc.L SrcSpanAnnA
epAnn e
a : [GenLocated SrcSpanAnnA e]
rest) = SrcSpanAnnA -> e -> GenLocated SrcSpanAnnA e
forall l e. l -> e -> GenLocated l e
Ghc.L (SrcSpanAnnA -> SrcSpanAnnA
EP.addComma SrcSpanAnnA
epAnn) e
a GenLocated SrcSpanAnnA e
-> [GenLocated SrcSpanAnnA e] -> [GenLocated SrcSpanAnnA e]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA e] -> [GenLocated SrcSpanAnnA e]
addCommaAnns [GenLocated SrcSpanAnnA e]
rest

-- | Adds the import for SPLIT to the module being compiled. Otherwise users
-- would have to manually add this import everytime they want to do pattern splitting.
addImport :: Ghc.ParsedResult -> Ghc.ParsedResult
addImport :: ParsedResult -> ParsedResult
addImport ParsedResult
result = ParsedResult
result
  { Ghc.parsedResultModule =
    let resMod = ParsedResult -> HsParsedModule
Ghc.parsedResultModule ParsedResult
result
     in resMod
        { Ghc.hpm_module = Ghc.hpm_module resMod <&> \HsModule GhcPs
pMod ->
            HsModule GhcPs
pMod
              { Ghc.hsmodImports =
                  caseXImport : Ghc.hsmodImports pMod
              }
        }
  }
  where
    caseXImport :: LocatedAn an (ImportDecl GhcPs)
caseXImport = ImportDecl GhcPs -> LocatedAn an (ImportDecl GhcPs)
forall a an. a -> LocatedAn an a
Ghc.noLocA (ImportDecl GhcPs -> LocatedAn an (ImportDecl GhcPs))
-> (ModuleName -> ImportDecl GhcPs)
-> ModuleName
-> LocatedAn an (ImportDecl GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> ImportDecl GhcPs
Ghc.simpleImportDecl (ModuleName -> LocatedAn an (ImportDecl GhcPs))
-> ModuleName -> LocatedAn an (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> ModuleName
Ghc.mkModuleName String
forall a. IsString a => a
patternModName

-- | The automatically added import gets flagged as unused even if it is used.
-- The solution here is to simply suppress the warning.
removeUnusedImportWarn :: Ghc.TcM ()
removeUnusedImportWarn :: TcM ()
removeUnusedImportWarn = do
  TcRef (Messages TcRnMessage)
errsVar <- TcRn (TcRef (Messages TcRnMessage))
Ghc.getErrsVar
#if MIN_VERSION_ghc(9,8,0)
  let isAutoSplitImportWarn msgEnv =
        case Ghc.errMsgDiagnostic msgEnv of
          Ghc.TcRnMessageWithInfo _ (Ghc.TcRnMessageDetailed _ (Ghc.TcRnUnusedImport decl _)) ->
            Ghc.unLoc (Ghc.ideclName decl) == Ghc.mkModuleName patternModName
          _ -> False
  Ghc.liftIO . modifyIORef errsVar $
    Ghc.mkMessages . Ghc.filterBag (not . isAutoSplitImportWarn) . Ghc.getMessages
#else
  -- 9.6 lacks the specific diagnostic
  let isAutoSplitImportWarn :: MsgEnvelope TcRnMessage -> Bool
isAutoSplitImportWarn MsgEnvelope TcRnMessage
msgEnv =
        case MsgEnvelope TcRnMessage -> TcRnMessage
forall e. MsgEnvelope e -> e
Ghc.errMsgDiagnostic MsgEnvelope TcRnMessage
msgEnv of
          Ghc.TcRnMessageWithInfo UnitState
_ (Ghc.TcRnMessageDetailed ErrInfo
_ (Ghc.TcRnUnknownMessage (Ghc.UnknownDiagnostic a
diag)))
            | Ghc.WarningWithFlag WarningFlag
Ghc.Opt_WarnUnusedImports <- a -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
Ghc.diagnosticReason a
diag
            -> Bool
True
          TcRnMessage
_ -> Bool
False
  IO () -> TcM ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Ghc.liftIO (IO () -> TcM ())
-> ((Messages TcRnMessage -> Messages TcRnMessage) -> IO ())
-> (Messages TcRnMessage -> Messages TcRnMessage)
-> TcM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRef (Messages TcRnMessage)
-> (Messages TcRnMessage -> Messages TcRnMessage) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef TcRef (Messages TcRnMessage)
errsVar ((Messages TcRnMessage -> Messages TcRnMessage) -> TcM ())
-> (Messages TcRnMessage -> Messages TcRnMessage) -> TcM ()
forall a b. (a -> b) -> a -> b
$ \Messages TcRnMessage
msgs ->
    -- the target import warning always shows up as the last occurrence
    case (MsgEnvelope TcRnMessage -> Bool)
-> [MsgEnvelope TcRnMessage]
-> ([MsgEnvelope TcRnMessage], [MsgEnvelope TcRnMessage])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break MsgEnvelope TcRnMessage -> Bool
isAutoSplitImportWarn ([MsgEnvelope TcRnMessage]
 -> ([MsgEnvelope TcRnMessage], [MsgEnvelope TcRnMessage]))
-> (Bag (MsgEnvelope TcRnMessage) -> [MsgEnvelope TcRnMessage])
-> Bag (MsgEnvelope TcRnMessage)
-> ([MsgEnvelope TcRnMessage], [MsgEnvelope TcRnMessage])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MsgEnvelope TcRnMessage] -> [MsgEnvelope TcRnMessage]
forall a. [a] -> [a]
reverse ([MsgEnvelope TcRnMessage] -> [MsgEnvelope TcRnMessage])
-> (Bag (MsgEnvelope TcRnMessage) -> [MsgEnvelope TcRnMessage])
-> Bag (MsgEnvelope TcRnMessage)
-> [MsgEnvelope TcRnMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope TcRnMessage) -> [MsgEnvelope TcRnMessage]
forall a. Bag a -> [a]
Ghc.bagToList (Bag (MsgEnvelope TcRnMessage)
 -> ([MsgEnvelope TcRnMessage], [MsgEnvelope TcRnMessage]))
-> Bag (MsgEnvelope TcRnMessage)
-> ([MsgEnvelope TcRnMessage], [MsgEnvelope TcRnMessage])
forall a b. (a -> b) -> a -> b
$ Messages TcRnMessage -> Bag (MsgEnvelope TcRnMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
Ghc.getMessages Messages TcRnMessage
msgs of
      ([MsgEnvelope TcRnMessage]
before, MsgEnvelope TcRnMessage
_ : [MsgEnvelope TcRnMessage]
after) -> Bag (MsgEnvelope TcRnMessage) -> Messages TcRnMessage
forall e. Bag (MsgEnvelope e) -> Messages e
Ghc.mkMessages (Bag (MsgEnvelope TcRnMessage) -> Messages TcRnMessage)
-> ([MsgEnvelope TcRnMessage] -> Bag (MsgEnvelope TcRnMessage))
-> [MsgEnvelope TcRnMessage]
-> Messages TcRnMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MsgEnvelope TcRnMessage] -> Bag (MsgEnvelope TcRnMessage)
forall a. [a] -> Bag a
Ghc.listToBag ([MsgEnvelope TcRnMessage] -> Bag (MsgEnvelope TcRnMessage))
-> ([MsgEnvelope TcRnMessage] -> [MsgEnvelope TcRnMessage])
-> [MsgEnvelope TcRnMessage]
-> Bag (MsgEnvelope TcRnMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MsgEnvelope TcRnMessage] -> [MsgEnvelope TcRnMessage]
forall a. [a] -> [a]
reverse ([MsgEnvelope TcRnMessage] -> Messages TcRnMessage)
-> [MsgEnvelope TcRnMessage] -> Messages TcRnMessage
forall a b. (a -> b) -> a -> b
$ [MsgEnvelope TcRnMessage]
before [MsgEnvelope TcRnMessage]
-> [MsgEnvelope TcRnMessage] -> [MsgEnvelope TcRnMessage]
forall a. [a] -> [a] -> [a]
++ [MsgEnvelope TcRnMessage]
after
      ([MsgEnvelope TcRnMessage], [MsgEnvelope TcRnMessage])
_ -> Messages TcRnMessage
msgs
#endif

nameToRdrName :: Ghc.GlobalRdrEnv -> Ghc.Name -> Ghc.RdrName
nameToRdrName :: GlobalRdrEnv -> Name -> RdrName
nameToRdrName GlobalRdrEnv
rdrEnv Name
n =
  case GlobalRdrEnv -> OccName -> Maybe [GlobalRdrElt]
forall a. OccEnv a -> OccName -> Maybe a
Ghc.lookupOccEnv GlobalRdrEnv
rdrEnv OccName
occName of
    Just [GlobalRdrElt]
gres
      | Just GlobalRdrElt
gre <- (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> Maybe GlobalRdrElt
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find GlobalRdrElt -> Bool
greMatches [GlobalRdrElt]
gres
      , RdrName
rdrName : [RdrName]
_ <- GlobalRdrElt -> [RdrName]
Ghc.greRdrNames GlobalRdrElt
gre
      -> RdrName
rdrName
    Maybe [GlobalRdrElt]
Nothing
      | Bool -> Bool
not (Name -> Bool
Ghc.isWiredInName Name
n)
      , Bool -> Bool
not (Name -> Bool
Ghc.isBuiltInSyntax Name
n)
      , Bool -> Bool
not (Name -> Bool
Ghc.isSystemName Name
n)
      , Bool -> Bool
not (Name -> Bool
Ghc.isInternalName Name
n)
      -> ModuleName -> OccName -> RdrName
Ghc.mkRdrQual (String -> ModuleName
Ghc.mkModuleName String
"NOT_IN_SCOPE") OccName
occName
    Maybe [GlobalRdrElt]
_ -> Name -> RdrName
Ghc.nameRdrName Name
n
  where
    occName :: OccName
occName = Name -> OccName
forall a. NamedThing a => a -> OccName
Ghc.getOccName Name
n
    greMatches :: GlobalRdrElt -> Bool
greMatches GlobalRdrElt
gre = GlobalRdrElt -> Name
Ghc.greToName GlobalRdrElt
gre Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n

splitName :: IsString a => a
splitName :: forall a. IsString a => a
splitName = a
"SPLIT"

patternModName :: IsString a => a
patternModName :: forall a. IsString a => a
patternModName = a
"AutoSplit.Pattern"