{-# LANGUAGE CPP #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module Refact.Internal
  ( apply,
    runRefactoring,
    addExtensionsToFlags,
    parseModuleWithArgs,
    parseExtensions,

    -- * Support for runPipe in the main process
    Verbosity (..),
    refactOptions,
    type Errors,
    onError,
    mkErr,
  )
where

import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Maybe (MaybeT (..))
import Control.Monad.Trans.State.Strict
import Data.Data
import Data.Foldable (foldlM, for_)
import Data.Functor.Identity (Identity (..))
import Data.Generics (everywhere, everywhereM, extM, listify, mkM, mkQ, mkT, something)
import Data.Generics.Uniplate.Data (transformBi, transformBiM)
import Data.IORef.Extra
import Data.List.Extra
import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe)
import Data.Ord (comparing)
import Data.Tuple.Extra
import Debug.Trace
import qualified GHC
import GHC.IO.Exception (IOErrorType (..))
import GHC.LanguageExtensions.Type (Extension (..))
import Language.Haskell.GHC.ExactPrint
  ( ExactPrint,
    exactPrint,
    getEntryDP,
    makeDeltaAst,
    runTransform,
    setEntryDP,
    transferEntryDP,
    transferEntryDP',
  )
import Language.Haskell.GHC.ExactPrint.ExactPrint
  ( EPOptions,
    epRigidity,
    exactPrintWithOptions,
    stringOptions,
  )
import Language.Haskell.GHC.ExactPrint.Parsers
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Utils (ss2pos)
import Refact.Compat
  ( AnnSpan,
    DoGenReplacement,
    Errors,
    FlagSpec (..),
    FunBind,
    Module,
    ReplaceWorker,
    -- combineSrcSpans,
    combineSrcSpansA,
    composeSrcSpan,
    getOptions,
    gopt_set,
    handleGhcException,
    impliedXFlags,
    mkErr,
    occName,
    occNameString,
    onError,
    parseDynamicFilePragma,
    parseModuleName,
    ppr,
    setSrcSpanFile,
    showSDocUnsafe,
    srcSpanToAnnSpan,
    stringToStringBuffer,
    xFlags,
    xopt_set,
    xopt_unset,
    pattern RealSrcSpan',
#if MIN_VERSION_ghc(9,4,0)
    mkGeneratedHsDocString,
    initParserOpts
#endif
  )
import Refact.Types hiding (SrcSpan)
import qualified Refact.Types as R
import Refact.Utils
  ( Decl,
    Expr,
    Import,
    M,
    Name,
    Pat,
    Stmt,
    Type,
    -- foldAnnKey,
    getAnnSpanA,
    modifyAnnKey,
    toGhcSrcSpan,
    toGhcSrcSpan',
  )
import System.IO.Error (mkIOError)
import System.IO.Extra
import System.IO.Unsafe (unsafePerformIO)

refactOptions :: EPOptions Identity String
refactOptions :: EPOptions Identity String
refactOptions = EPOptions Identity String
stringOptions {epRigidity :: Rigidity
epRigidity = Rigidity
RigidLayout}

-- | Apply a set of refactorings as supplied by hlint
apply ::
  Maybe (Int, Int) ->
  Bool ->
  [(String, [Refactoring R.SrcSpan])] ->
  Maybe FilePath ->
  Verbosity ->
  -- Anns ->
  Module ->
  IO String
apply :: Maybe (Int, Int)
-> Bool
-> [(String, [Refactoring SrcSpan])]
-> Maybe String
-> Verbosity
-> ParsedSource
-> IO String
apply Maybe (Int, Int)
mpos Bool
step [(String, [Refactoring SrcSpan])]
inp Maybe String
mbfile Verbosity
verb ParsedSource
m0 = do
  SrcSpan -> SrcSpan
toGhcSS <-
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      ( case forall l e. GenLocated l e -> l
GHC.getLoc ParsedSource
m0 of
          GHC.UnhelpfulSpan UnhelpfulSpanReason
s -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Module has UnhelpfulSpan: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UnhelpfulSpanReason
s
          RealSrcSpan' AnnSpan
s ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FastString -> SrcSpan -> SrcSpan
toGhcSrcSpan' (AnnSpan -> FastString
GHC.srcSpanFile AnnSpan
s)
      )
      (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SrcSpan -> SrcSpan
toGhcSrcSpan)
      Maybe String
mbfile
  let allRefacts :: [((String, [Refactoring GHC.SrcSpan]), R.SrcSpan)]
      allRefacts :: [((String, [Refactoring SrcSpan]), SrcSpan)]
allRefacts =
        forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {a} {a}. (a, SrcSpan) -> (a, SrcSpan) -> Ordering
cmpSrcSpan
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a a' b. (a -> a') -> (a, b) -> (a', b)
first forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b b' a. (b -> b') -> (a, b) -> (a, b')
second forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpan
toGhcSS)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> a
id forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& [SrcSpan] -> Maybe SrcSpan
aggregateSrcSpans forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Refactoring a -> a
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd))
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> b -> a
const Bool
True) (\(Int, Int)
p -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((SrcSpan -> (Int, Int) -> Bool
`spans` (Int, Int)
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Refactoring a -> a
pos) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) Maybe (Int, Int)
mpos)
          forall a b. (a -> b) -> a -> b
$ [(String, [Refactoring SrcSpan])]
inp

      cmpSrcSpan :: (a, SrcSpan) -> (a, SrcSpan) -> Ordering
cmpSrcSpan (a
_, SrcSpan
s1) (a
_, SrcSpan
s2) =
        forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SrcSpan -> Int
startLine SrcSpan
s1 SrcSpan
s2
          forall a. Semigroup a => a -> a -> a
<> forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SrcSpan -> Int
startCol SrcSpan
s1 SrcSpan
s2 -- s1 first if it starts on earlier line
          forall a. Semigroup a => a -> a -> a
<> forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SrcSpan -> Int
endLine SrcSpan
s2 SrcSpan
s1 --             or on earlier column
          forall a. Semigroup a => a -> a -> a
<> forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SrcSpan -> Int
endCol SrcSpan
s2 SrcSpan
s1 -- they start in same place, s2 comes
          -- first if it ends later
          -- else, completely same span, so s1 will be first
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb forall a. Ord a => a -> a -> Bool
>= Verbosity
Normal) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Applicative f => String -> f ()
traceM forall a b. (a -> b) -> a -> b
$
    String
"Applying " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ [((String, [Refactoring SrcSpan]), SrcSpan)]
allRefacts) forall a. [a] -> [a] -> [a]
++ String
" hints"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb forall a. Eq a => a -> a -> Bool
== Verbosity
Loud) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Applicative f => String -> f ()
traceM forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [((String, [Refactoring SrcSpan]), SrcSpan)]
allRefacts)

  ParsedSource
m <-
    if Bool
step
      then forall a. a -> Maybe a -> a
fromMaybe ParsedSource
m0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (ParsedSource
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO ParsedSource
refactoringLoop ParsedSource
m0 [((String, [Refactoring SrcSpan]), SrcSpan)]
allRefacts)
      else forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Verbosity
-> ParsedSource
-> [([Refactoring SrcSpan], SrcSpan)]
-> StateT Int IO ParsedSource
runRefactorings Verbosity
verb ParsedSource
m0 (forall a a' b. (a -> a') -> (a, b) -> (a', b)
first forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((String, [Refactoring SrcSpan]), SrcSpan)]
allRefacts)) Int
0

  -- liftIO $ putStrLn $ "apply:final AST\n" ++ showAst m
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall ast b (m :: * -> *).
(ExactPrint ast, Monoid b, Monad m) =>
EPOptions m b -> ast -> m (ast, b)
exactPrintWithOptions EPOptions Identity String
refactOptions ParsedSource
m

spans :: R.SrcSpan -> (Int, Int) -> Bool
spans :: SrcSpan -> (Int, Int) -> Bool
spans R.SrcSpan {Int
endCol :: Int
endLine :: Int
startCol :: Int
startLine :: Int
endCol :: SrcSpan -> Int
endLine :: SrcSpan -> Int
startCol :: SrcSpan -> Int
startLine :: SrcSpan -> Int
..} (Int, Int)
loc = (Int
startLine, Int
startCol) forall a. Ord a => a -> a -> Bool
<= (Int, Int)
loc Bool -> Bool -> Bool
&& (Int, Int)
loc forall a. Ord a => a -> a -> Bool
<= (Int
endLine, Int
endCol)

aggregateSrcSpans :: [R.SrcSpan] -> Maybe R.SrcSpan
aggregateSrcSpans :: [SrcSpan] -> Maybe SrcSpan
aggregateSrcSpans = \case
  [] -> forall a. Maybe a
Nothing
  [SrcSpan]
rs -> forall a. a -> Maybe a
Just (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SrcSpan -> SrcSpan -> SrcSpan
alg [SrcSpan]
rs)
  where
    alg :: SrcSpan -> SrcSpan -> SrcSpan
alg (R.SrcSpan Int
sl1 Int
sc1 Int
el1 Int
ec1) (R.SrcSpan Int
sl2 Int
sc2 Int
el2 Int
ec2) =
      let (Int
sl, Int
sc) = case forall a. Ord a => a -> a -> Ordering
compare Int
sl1 Int
sl2 of
            Ordering
LT -> (Int
sl1, Int
sc1)
            Ordering
EQ -> (Int
sl1, forall a. Ord a => a -> a -> a
min Int
sc1 Int
sc2)
            Ordering
GT -> (Int
sl2, Int
sc2)
          (Int
el, Int
ec) = case forall a. Ord a => a -> a -> Ordering
compare Int
el1 Int
el2 of
            Ordering
LT -> (Int
el2, Int
ec2)
            Ordering
EQ -> (Int
el2, forall a. Ord a => a -> a -> a
max Int
ec1 Int
ec2)
            Ordering
GT -> (Int
el1, Int
ec1)
       in Int -> Int -> Int -> Int -> SrcSpan
R.SrcSpan Int
sl Int
sc Int
el Int
ec

runRefactorings ::
  Verbosity ->
  Module ->
  [([Refactoring GHC.SrcSpan], R.SrcSpan)] ->
  StateT Int IO Module
runRefactorings :: Verbosity
-> ParsedSource
-> [([Refactoring SrcSpan], SrcSpan)]
-> StateT Int IO ParsedSource
runRefactorings Verbosity
verb ParsedSource
m0 (([Refactoring SrcSpan]
rs, SrcSpan
ss) : [([Refactoring SrcSpan], SrcSpan)]
rest) = do
  Verbosity
-> ParsedSource
-> [Refactoring SrcSpan]
-> StateT Int IO (Maybe ParsedSource)
runRefactorings' Verbosity
verb ParsedSource
m0 [Refactoring SrcSpan]
rs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe ParsedSource
Nothing -> Verbosity
-> ParsedSource
-> [([Refactoring SrcSpan], SrcSpan)]
-> StateT Int IO ParsedSource
runRefactorings Verbosity
verb ParsedSource
m0 [([Refactoring SrcSpan], SrcSpan)]
rest
    Just ParsedSource
m -> do
      let ([([Refactoring SrcSpan], SrcSpan)]
overlaps, [([Refactoring SrcSpan], SrcSpan)]
rest') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (SrcSpan -> SrcSpan -> Bool
overlap SrcSpan
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([Refactoring SrcSpan], SrcSpan)]
rest
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb forall a. Ord a => a -> a -> Bool
>= Verbosity
Normal) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [([Refactoring SrcSpan], SrcSpan)]
overlaps forall a b. (a -> b) -> a -> b
$ \([Refactoring SrcSpan]
rs', SrcSpan
_) ->
        forall (f :: * -> *). Applicative f => String -> f ()
traceM forall a b. (a -> b) -> a -> b
$ String
"Ignoring " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Refactoring SrcSpan]
rs' forall a. [a] -> [a] -> [a]
++ String
" due to overlap."
      Verbosity
-> ParsedSource
-> [([Refactoring SrcSpan], SrcSpan)]
-> StateT Int IO ParsedSource
runRefactorings Verbosity
verb ParsedSource
m [([Refactoring SrcSpan], SrcSpan)]
rest'
runRefactorings Verbosity
_ ParsedSource
m [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedSource
m

runRefactorings' ::
  Verbosity ->
  Module ->
  [Refactoring GHC.SrcSpan] ->
  StateT Int IO (Maybe Module)
runRefactorings' :: Verbosity
-> ParsedSource
-> [Refactoring SrcSpan]
-> StateT Int IO (Maybe ParsedSource)
runRefactorings' Verbosity
verb ParsedSource
m0 [Refactoring SrcSpan]
rs = do
  Int
seed <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  ParsedSource
m <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM forall a. Data a => a -> Refactoring SrcSpan -> StateT Int IO a
runRefactoring ParsedSource
m0 [Refactoring SrcSpan]
rs
  if [Refactoring SrcSpan] -> ParsedSource -> ParsedSource -> Bool
droppedComments [Refactoring SrcSpan]
rs ParsedSource
m0 ParsedSource
m
    then do
      forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Int
seed
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb forall a. Ord a => a -> a -> Bool
>= Verbosity
Normal) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Applicative f => String -> f ()
traceM forall a b. (a -> b) -> a -> b
$
        String
"Ignoring " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Refactoring SrcSpan]
rs forall a. [a] -> [a] -> [a]
++ String
" since applying them would cause comments to be dropped."
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ParsedSource
m

overlap :: R.SrcSpan -> R.SrcSpan -> Bool
overlap :: SrcSpan -> SrcSpan -> Bool
overlap SrcSpan
s1 SrcSpan
s2 =
  -- We know s1 always starts <= s2, due to our sort
  case forall a. Ord a => a -> a -> Ordering
compare (SrcSpan -> Int
startLine SrcSpan
s2) (SrcSpan -> Int
endLine SrcSpan
s1) of
    Ordering
LT -> Bool
True
    Ordering
EQ -> SrcSpan -> Int
startCol SrcSpan
s2 forall a. Ord a => a -> a -> Bool
<= SrcSpan -> Int
endCol SrcSpan
s1
    Ordering
GT -> Bool
False

data LoopOption = LoopOption
  { LoopOption -> String
desc :: String,
    -- perform :: MaybeT IO (Anns, Module)
    LoopOption -> MaybeT IO ParsedSource
perform :: MaybeT IO Module
  }

refactoringLoop ::
  Module ->
  [((String, [Refactoring GHC.SrcSpan]), R.SrcSpan)] ->
  MaybeT IO Module
refactoringLoop :: ParsedSource
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO ParsedSource
refactoringLoop ParsedSource
m [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedSource
m
refactoringLoop ParsedSource
m (((String
_, []), SrcSpan
_) : [((String, [Refactoring SrcSpan]), SrcSpan)]
rs) = ParsedSource
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO ParsedSource
refactoringLoop ParsedSource
m [((String, [Refactoring SrcSpan]), SrcSpan)]
rs
refactoringLoop ParsedSource
m0 hints :: [((String, [Refactoring SrcSpan]), SrcSpan)]
hints@(((String
hintDesc, [Refactoring SrcSpan]
rs), SrcSpan
ss) : [((String, [Refactoring SrcSpan]), SrcSpan)]
rss) = do
  Maybe ParsedSource
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Int
0 forall a b. (a -> b) -> a -> b
$ Verbosity
-> ParsedSource
-> [Refactoring SrcSpan]
-> StateT Int IO (Maybe ParsedSource)
runRefactorings' Verbosity
Silent ParsedSource
m0 [Refactoring SrcSpan]
rs
  let yAction :: MaybeT IO Module
      yAction :: MaybeT IO ParsedSource
yAction = case Maybe ParsedSource
res of
        Just ParsedSource
m -> do
          forall ast. ExactPrint ast => ast -> String
exactPrint ParsedSource
m seq :: forall a b. a -> b -> b
`seq` forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          ParsedSource
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO ParsedSource
refactoringLoop ParsedSource
m forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (SrcSpan -> SrcSpan -> Bool
overlap SrcSpan
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [((String, [Refactoring SrcSpan]), SrcSpan)]
rss
        Maybe ParsedSource
Nothing -> do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Hint skipped since applying it would cause comments to be dropped"
          ParsedSource
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO ParsedSource
refactoringLoop ParsedSource
m0 [((String, [Refactoring SrcSpan]), SrcSpan)]
rss
      opts :: [(String, LoopOption)]
      opts :: [(String, LoopOption)]
opts =
        [ (String
"y", String -> MaybeT IO ParsedSource -> LoopOption
LoopOption String
"Apply current hint" MaybeT IO ParsedSource
yAction),
          (String
"n", String -> MaybeT IO ParsedSource -> LoopOption
LoopOption String
"Don't apply the current hint" (ParsedSource
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO ParsedSource
refactoringLoop ParsedSource
m0 [((String, [Refactoring SrcSpan]), SrcSpan)]
rss)),
          (String
"q", String -> MaybeT IO ParsedSource -> LoopOption
LoopOption String
"Apply no further hints" (forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedSource
m0)),
          (String
"d", String -> MaybeT IO ParsedSource -> LoopOption
LoopOption String
"Discard previous changes" forall (m :: * -> *) a. MonadPlus m => m a
mzero),
          ( String
"v",
            String -> MaybeT IO ParsedSource -> LoopOption
LoopOption
              String
"View current file"
              ( forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn (forall ast. ExactPrint ast => ast -> String
exactPrint ParsedSource
m0))
                  forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsedSource
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO ParsedSource
refactoringLoop ParsedSource
m0 [((String, [Refactoring SrcSpan]), SrcSpan)]
hints
              )
          ),
          (String
"?", String -> MaybeT IO ParsedSource -> LoopOption
LoopOption String
"Show this help menu" MaybeT IO ParsedSource
loopHelp)
        ]
      loopHelp :: MaybeT IO ParsedSource
loopHelp = do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String, LoopOption) -> String
mkLine forall a b. (a -> b) -> a -> b
$ [(String, LoopOption)]
opts
        ParsedSource
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO ParsedSource
refactoringLoop ParsedSource
m0 [((String, [Refactoring SrcSpan]), SrcSpan)]
hints
      mkLine :: (String, LoopOption) -> String
mkLine (String
c, LoopOption
opt) = String
c forall a. [a] -> [a] -> [a]
++ String
" - " forall a. [a] -> [a] -> [a]
++ LoopOption -> String
desc LoopOption
opt
  String
inp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
putStrLn String
hintDesc
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Apply hint [" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, LoopOption)]
opts) forall a. [a] -> [a] -> [a]
++ String
"]"
    -- In case that the input also comes from stdin
    forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
"/dev/tty" IOMode
ReadMode Handle -> IO String
hGetLine
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe MaybeT IO ParsedSource
loopHelp LoopOption -> MaybeT IO ParsedSource
perform (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
inp [(String, LoopOption)]
opts)

data Verbosity = Silent | Normal | Loud deriving (Verbosity -> Verbosity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show, Eq Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
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
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
Ord)

-- ---------------------------------------------------------------------

-- Perform the substitutions

-- | Peform a @Refactoring@.
runRefactoring ::
  Data a =>
  a ->
  Refactoring GHC.SrcSpan ->
  StateT Int IO a
runRefactoring :: forall a. Data a => a -> Refactoring SrcSpan -> StateT Int IO a
runRefactoring a
m = \case
  r :: Refactoring SrcSpan
r@Replace {} -> do
    Int
seed <- forall (m :: * -> *) s. Monad m => StateT s m s
get forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall a. Num a => a -> a -> a
+ Int
1)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case forall a. Refactoring a -> RType
rtype Refactoring SrcSpan
r of
      RType
Expr -> forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LHsExpr GhcPs)
parseExpr Int
seed Refactoring SrcSpan
r
      RType
Decl -> forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LHsDecl GhcPs)
parseDecl Int
seed Refactoring SrcSpan
r
      RType
Type -> forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LHsType GhcPs)
parseType Int
seed Refactoring SrcSpan
r
      RType
Pattern -> forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LPat GhcPs)
parsePattern Int
seed Refactoring SrcSpan
r
      RType
Stmt -> forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (ExprLStmt GhcPs)
parseStmt Int
seed Refactoring SrcSpan
r
      RType
Bind -> forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LHsBind GhcPs)
parseBind Int
seed Refactoring SrcSpan
r
      RType
R.Match -> forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LMatch GhcPs (LHsExpr GhcPs))
parseMatch Int
seed Refactoring SrcSpan
r
      RType
ModuleName -> forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m (SrcSpan -> Parser (LocatedA ModuleName)
parseModuleName (forall a. Refactoring a -> a
pos Refactoring SrcSpan
r)) Int
seed Refactoring SrcSpan
r
      RType
Import -> forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LImportDecl GhcPs)
parseImport Int
seed Refactoring SrcSpan
r
  ModifyComment {String
SrcSpan
newComment :: forall a. Refactoring a -> String
newComment :: String
pos :: SrcSpan
pos :: forall a. Refactoring a -> a
..} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Data a => SrcSpan -> String -> a -> a
modifyComment SrcSpan
pos String
newComment a
m)
  Delete {RType
rtype :: RType
rtype :: forall a. Refactoring a -> RType
rtype, SrcSpan
pos :: SrcSpan
pos :: forall a. Refactoring a -> a
pos} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> a
f a
m)
    where
      annSpan :: AnnSpan
annSpan = SrcSpan -> AnnSpan
srcSpanToAnnSpan SrcSpan
pos
      f :: a -> a
f = case RType
rtype of
        RType
Stmt -> forall a. Data a => (ExprLStmt GhcPs -> Bool) -> a -> a
doDeleteStmt ((forall a. Eq a => a -> a -> Bool
/= AnnSpan
annSpan) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall an a. LocatedAn an a -> AnnSpan
getAnnSpanA)
        RType
Import -> forall a. Data a => (LImportDecl GhcPs -> Bool) -> a -> a
doDeleteImport ((forall a. Eq a => a -> a -> Bool
/= AnnSpan
annSpan) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall an a. LocatedAn an a -> AnnSpan
getAnnSpanA)
        RType
_ -> forall a. a -> a
id
  InsertComment {String
SrcSpan
newComment :: String
pos :: SrcSpan
newComment :: forall a. Refactoring a -> String
pos :: forall a. Refactoring a -> a
..} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> a
addComment a
m)
    where
      addComment :: a -> a
addComment = forall from to. Biplate from to => (to -> to) -> from -> from
transformBi LHsDecl GhcPs -> LHsDecl GhcPs
go
      r :: AnnSpan
r = SrcSpan -> AnnSpan
srcSpanToAnnSpan SrcSpan
pos
      go :: GHC.LHsDecl GHC.GhcPs -> GHC.LHsDecl GHC.GhcPs
      go :: LHsDecl GhcPs -> LHsDecl GhcPs
go old :: LHsDecl GhcPs
old@(GHC.L SrcSpanAnnA
l HsDecl GhcPs
d) =
        if AnnSpan -> (Int, Int)
ss2pos (SrcSpan -> AnnSpan
srcSpanToAnnSpan forall a b. (a -> b) -> a -> b
$ forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
l) forall a. Eq a => a -> a -> Bool
== AnnSpan -> (Int, Int)
ss2pos AnnSpan
r
          then
            let dp :: DeltaPos
dp = case forall t a. LocatedAn t a -> DeltaPos
getEntryDP LHsDecl GhcPs
old of
                  GHC.SameLine Int
0 -> Int -> Int -> DeltaPos
GHC.DifferentLine Int
1 Int
0
                  DeltaPos
dp' -> DeltaPos
dp'
                (GHC.L SrcSpanAnnA
l' HsDecl GhcPs
d') = forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP (forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l HsDecl GhcPs
d) (Int -> Int -> DeltaPos
GHC.DifferentLine Int
1 Int
0)
                comment :: GenLocated Anchor EpaComment
comment =
                  forall l e. l -> e -> GenLocated l e
GHC.L
                    (AnnSpan -> AnchorOperation -> Anchor
GHC.Anchor AnnSpan
r (DeltaPos -> AnchorOperation
GHC.MovedAnchor DeltaPos
dp))
                    (EpaCommentTok -> AnnSpan -> EpaComment
GHC.EpaComment (String -> EpaCommentTok
GHC.EpaLineComment String
newComment) AnnSpan
r)
                l'' :: SrcSpanAnnA
l'' = forall ann. Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann
GHC.addCommentsToSrcAnn SrcSpanAnnA
l' ([GenLocated Anchor EpaComment] -> EpAnnComments
GHC.EpaComments [GenLocated Anchor EpaComment
comment])
             in forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l'' HsDecl GhcPs
d'
          else LHsDecl GhcPs
old
  RemoveAsKeyword {SrcSpan
pos :: SrcSpan
pos :: forall a. Refactoring a -> a
..} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> a
removeAsKeyword a
m)
    where
      removeAsKeyword :: a -> a
removeAsKeyword = forall from to. Biplate from to => (to -> to) -> from -> from
transformBi LImportDecl GhcPs -> LImportDecl GhcPs
go
      go :: GHC.LImportDecl GHC.GhcPs -> GHC.LImportDecl GHC.GhcPs
      go :: LImportDecl GhcPs -> LImportDecl GhcPs
go imp :: LImportDecl GhcPs
imp@(GHC.L SrcSpanAnnA
l ImportDecl GhcPs
i)
        | SrcSpan -> AnnSpan
srcSpanToAnnSpan (forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
l) forall a. Eq a => a -> a -> Bool
== SrcSpan -> AnnSpan
srcSpanToAnnSpan SrcSpan
pos = forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l (ImportDecl GhcPs
i {ideclAs :: Maybe (XRec GhcPs ModuleName)
GHC.ideclAs = forall a. Maybe a
Nothing})
        | Bool
otherwise = LImportDecl GhcPs
imp

modifyComment :: (Data a) => GHC.SrcSpan -> String -> a -> a
modifyComment :: forall a. Data a => SrcSpan -> String -> a -> a
modifyComment SrcSpan
pos String
newComment = forall from to. Biplate from to => (to -> to) -> from -> from
transformBi GenLocated Anchor EpaComment -> GenLocated Anchor EpaComment
go
  where
#if MIN_VERSION_ghc(9,4,0)
    newTok :: GHC.EpaCommentTok -> GHC.EpaCommentTok
    newTok (GHC.EpaDocComment _) = GHC.EpaDocComment $ mkGeneratedHsDocString newComment
    newTok (GHC.EpaDocOptions _) = GHC.EpaDocOptions newComment
    newTok (GHC.EpaLineComment _) = GHC.EpaLineComment newComment
    newTok (GHC.EpaBlockComment _) = GHC.EpaBlockComment newComment
    newTok GHC.EpaEofComment = GHC.EpaEofComment
#else
    newTok :: EpaCommentTok -> EpaCommentTok
newTok (GHC.EpaDocCommentNext String
_) = String -> EpaCommentTok
GHC.EpaDocCommentNext String
newComment
    newTok (GHC.EpaDocCommentPrev String
_) = String -> EpaCommentTok
GHC.EpaDocCommentPrev String
newComment
    newTok (GHC.EpaDocCommentNamed String
_) = String -> EpaCommentTok
GHC.EpaDocCommentNamed String
newComment
    newTok (GHC.EpaDocSection Int
i String
_) = Int -> String -> EpaCommentTok
GHC.EpaDocSection Int
i String
newComment
    newTok (GHC.EpaDocOptions String
_) = String -> EpaCommentTok
GHC.EpaDocOptions String
newComment
    newTok (GHC.EpaLineComment String
_) = String -> EpaCommentTok
GHC.EpaLineComment String
newComment
    newTok (GHC.EpaBlockComment String
_) = String -> EpaCommentTok
GHC.EpaBlockComment String
newComment
    newTok EpaCommentTok
GHC.EpaEofComment = EpaCommentTok
GHC.EpaEofComment
#endif

    go :: GHC.LEpaComment -> GHC.LEpaComment
    go :: GenLocated Anchor EpaComment -> GenLocated Anchor EpaComment
go old :: GenLocated Anchor EpaComment
old@(GHC.L (GHC.Anchor AnnSpan
l AnchorOperation
o) (GHC.EpaComment EpaCommentTok
t AnnSpan
r)) =
      if AnnSpan -> (Int, Int)
ss2pos AnnSpan
l forall a. Eq a => a -> a -> Bool
== AnnSpan -> (Int, Int)
ss2pos (SrcSpan -> AnnSpan
GHC.realSrcSpan SrcSpan
pos)
        then forall l e. l -> e -> GenLocated l e
GHC.L (AnnSpan -> AnchorOperation -> Anchor
GHC.Anchor AnnSpan
l AnchorOperation
o) (EpaCommentTok -> AnnSpan -> EpaComment
GHC.EpaComment (EpaCommentTok -> EpaCommentTok
newTok EpaCommentTok
t) AnnSpan
r)
        else GenLocated Anchor EpaComment
old

droppedComments :: [Refactoring GHC.SrcSpan] -> Module -> Module -> Bool
droppedComments :: [Refactoring SrcSpan] -> ParsedSource -> ParsedSource -> Bool
droppedComments [Refactoring SrcSpan]
rs ParsedSource
orig_m ParsedSource
m = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EpaComment]
current_comments) [EpaComment]
orig_comments)
  where
    mcs :: ParsedSource
mcs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Data a => a -> Refactoring SrcSpan -> a
runModifyComment ParsedSource
orig_m [Refactoring SrcSpan]
rs
    runModifyComment :: a -> Refactoring SrcSpan -> a
runModifyComment a
m' (ModifyComment SrcSpan
pos String
newComment) = forall a. Data a => SrcSpan -> String -> a -> a
modifyComment SrcSpan
pos String
newComment a
m'
    runModifyComment a
m' Refactoring SrcSpan
_ = a
m'

    all_comments :: forall r. (Data r, Typeable r) => r -> [GHC.EpaComment]
    all_comments :: forall r. (Data r, Typeable r) => r -> [EpaComment]
all_comments = forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (Bool
False forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` EpaComment -> Bool
isComment)
    isComment :: GHC.EpaComment -> Bool
    isComment :: EpaComment -> Bool
isComment EpaComment
_ = Bool
True
    orig_comments :: [EpaComment]
orig_comments = forall r. (Data r, Typeable r) => r -> [EpaComment]
all_comments ParsedSource
mcs
    current_comments :: [EpaComment]
current_comments = forall r. (Data r, Typeable r) => r -> [EpaComment]
all_comments ParsedSource
m

parseBind :: Parser (GHC.LHsBind GHC.GhcPs)
parseBind :: Parser (LHsBind GhcPs)
parseBind DynFlags
dyn String
fname String
s =
  case Parser (LHsDecl GhcPs)
parseDecl DynFlags
dyn String
fname String
s of
    -- Safe as we add no annotations to the ValD
    Right (GHC.L SrcSpanAnnA
l (GHC.ValD XValD GhcPs
_ HsBindLR GhcPs GhcPs
b)) -> forall a b. b -> Either a b
Right (forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l HsBindLR GhcPs GhcPs
b)
    Right (GHC.L SrcSpanAnnA
l HsDecl GhcPs
_) -> forall a b. a -> Either a b
Left (DynFlags -> SrcSpan -> String -> ErrorMessages
mkErr DynFlags
dyn (forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
l) String
"Not a HsBind")
    Left ErrorMessages
e -> forall a b. a -> Either a b
Left ErrorMessages
e

parseMatch :: Parser (GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs))
parseMatch :: Parser (LMatch GhcPs (LHsExpr GhcPs))
parseMatch DynFlags
dyn String
fname String
s =
  case Parser (LHsBind GhcPs)
parseBind DynFlags
dyn String
fname String
s of
    Right (GHC.L SrcSpanAnnA
l GHC.FunBind {MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches}) ->
      case forall l e. GenLocated l e -> e
GHC.unLoc (forall p body. MatchGroup p body -> XRec p [LMatch p body]
GHC.mg_alts MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches) of
        [GenLocated
  (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
  (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
x] -> forall a b. b -> Either a b
Right GenLocated
  (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
  (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
x
        [GenLocated
   (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
   (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
_ -> forall a b. a -> Either a b
Left (DynFlags -> SrcSpan -> String -> ErrorMessages
mkErr DynFlags
dyn (forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
l) String
"Not a single match")
    Right (GHC.L SrcSpanAnnA
l HsBindLR GhcPs GhcPs
_) -> forall a b. a -> Either a b
Left (DynFlags -> SrcSpan -> String -> ErrorMessages
mkErr DynFlags
dyn (forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
l) String
"Not a funbind")
    Left ErrorMessages
e -> forall a b. a -> Either a b
Left ErrorMessages
e

-- Substitute variables into templates
-- Finds places in the templates where we need to insert variables.

substTransform :: (Data a, Data b) => b -> [(String, GHC.SrcSpan)] -> a -> M a
substTransform :: forall a b.
(Data a, Data b) =>
b -> [(String, SrcSpan)] -> a -> M a
substTransform b
m [(String, SrcSpan)]
ss =
  forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM
    ( forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM (forall a.
Data a =>
a -> [(String, SrcSpan)] -> LHsType GhcPs -> M (LHsType GhcPs)
typeSub b
m [(String, SrcSpan)]
ss)
        forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` forall a.
Data a =>
a -> [(String, SrcSpan)] -> FunBind -> M FunBind
identSub b
m [(String, SrcSpan)]
ss
        forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` forall a.
Data a =>
a -> [(String, SrcSpan)] -> LPat GhcPs -> M (LPat GhcPs)
patSub b
m [(String, SrcSpan)]
ss
        forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` forall a.
Data a =>
a -> [(String, SrcSpan)] -> ExprLStmt GhcPs -> M (ExprLStmt GhcPs)
stmtSub b
m [(String, SrcSpan)]
ss
        forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` forall a.
Data a =>
a -> [(String, SrcSpan)] -> LHsExpr GhcPs -> M (LHsExpr GhcPs)
exprSub b
m [(String, SrcSpan)]
ss
    )

stmtSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Stmt -> M Stmt
stmtSub :: forall a.
Data a =>
a -> [(String, SrcSpan)] -> ExprLStmt GhcPs -> M (ExprLStmt GhcPs)
stmtSub a
m [(String, SrcSpan)]
subs old :: ExprLStmt GhcPs
old@(GHC.L SrcSpanAnnA
_ (GHC.BodyStmt XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ (GHC.L SrcSpanAnnA
_ (GHC.HsVar XVar GhcPs
_ (GHC.L SrcSpanAnnN
_ RdrName
name))) SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) =
  forall old a an.
(Data old, Data a, Data an, Typeable an, Monoid an) =>
a
-> (AnnSpan -> M (LocatedAn an old))
-> LocatedAn an old
-> [(String, SrcSpan)]
-> RdrName
-> M (LocatedAn an old)
resolveRdrName a
m (forall a an modu (m :: * -> *).
(Typeable an, Data a, Data modu, MonadIO m) =>
modu -> AnnSpan -> m (LocatedAn an a)
findOrError a
m) ExprLStmt GhcPs
old [(String, SrcSpan)]
subs RdrName
name
stmtSub a
_ [(String, SrcSpan)]
_ ExprLStmt GhcPs
e = forall (f :: * -> *) a. Applicative f => a -> f a
pure ExprLStmt GhcPs
e

patSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Pat -> M Pat
patSub :: forall a.
Data a =>
a -> [(String, SrcSpan)] -> LPat GhcPs -> M (LPat GhcPs)
patSub a
m [(String, SrcSpan)]
subs old :: LPat GhcPs
old@(GHC.L SrcSpanAnnA
_ (GHC.VarPat XVarPat GhcPs
_ (GHC.L SrcSpanAnnN
_ RdrName
name))) =
  forall old a an.
(Data old, Data a, Data an, Typeable an, Monoid an) =>
a
-> (AnnSpan -> M (LocatedAn an old))
-> LocatedAn an old
-> [(String, SrcSpan)]
-> RdrName
-> M (LocatedAn an old)
resolveRdrName a
m (forall a an modu (m :: * -> *).
(Typeable an, Data a, Data modu, MonadIO m) =>
modu -> AnnSpan -> m (LocatedAn an a)
findOrError a
m) LPat GhcPs
old [(String, SrcSpan)]
subs RdrName
name
patSub a
_ [(String, SrcSpan)]
_ LPat GhcPs
e = forall (f :: * -> *) a. Applicative f => a -> f a
pure LPat GhcPs
e

typeSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Type -> M Type
typeSub :: forall a.
Data a =>
a -> [(String, SrcSpan)] -> LHsType GhcPs -> M (LHsType GhcPs)
typeSub a
m [(String, SrcSpan)]
subs old :: LHsType GhcPs
old@(GHC.L SrcSpanAnnA
_ (GHC.HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (GHC.L SrcSpanAnnN
_ RdrName
name))) =
  forall old a an.
(Data old, Data a, Data an, Typeable an, Monoid an) =>
a
-> (AnnSpan -> M (LocatedAn an old))
-> LocatedAn an old
-> [(String, SrcSpan)]
-> RdrName
-> M (LocatedAn an old)
resolveRdrName a
m (forall a an modu (m :: * -> *).
(Typeable an, Data a, Data modu, MonadIO m) =>
modu -> AnnSpan -> m (LocatedAn an a)
findOrError a
m) LHsType GhcPs
old [(String, SrcSpan)]
subs RdrName
name
typeSub a
_ [(String, SrcSpan)]
_ LHsType GhcPs
e = forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
e

exprSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Expr -> M Expr
exprSub :: forall a.
Data a =>
a -> [(String, SrcSpan)] -> LHsExpr GhcPs -> M (LHsExpr GhcPs)
exprSub a
m [(String, SrcSpan)]
subs old :: LHsExpr GhcPs
old@(GHC.L SrcSpanAnnA
_ (GHC.HsVar XVar GhcPs
_ (GHC.L SrcSpanAnnN
_ RdrName
name))) =
  forall old a an.
(Data old, Data a, Data an, Typeable an, Monoid an) =>
a
-> (AnnSpan -> M (LocatedAn an old))
-> LocatedAn an old
-> [(String, SrcSpan)]
-> RdrName
-> M (LocatedAn an old)
resolveRdrName a
m (forall a an modu (m :: * -> *).
(Typeable an, Data a, Data modu, MonadIO m) =>
modu -> AnnSpan -> m (LocatedAn an a)
findOrError a
m) LHsExpr GhcPs
old [(String, SrcSpan)]
subs RdrName
name
exprSub a
_ [(String, SrcSpan)]
_ LHsExpr GhcPs
e = forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr GhcPs
e

-- Used for Monad10, Monad11 tests.
-- The issue being that in one case the information is attached to a VarPat
-- but we need to move the annotations onto the actual name
--
-- This looks convoluted but we can't match directly on a located name as
-- it is not specific enough. Instead we match on some bigger context which
-- is contains the located name we want to replace.
identSub :: Data a => a -> [(String, GHC.SrcSpan)] -> FunBind -> M FunBind
identSub :: forall a.
Data a =>
a -> [(String, SrcSpan)] -> FunBind -> M FunBind
identSub a
m [(String, SrcSpan)]
subs old :: FunBind
old@(GHC.FunRhs (GHC.L SrcSpanAnnN
_ RdrName
name) LexicalFixity
_ SrcStrictness
_) =
  forall a an b.
(a -> LocatedAn an b -> M a)
-> (AnnSpan -> M (LocatedAn an b))
-> a
-> [(String, SrcSpan)]
-> RdrName
-> M a
resolveRdrName' FunBind -> GenLocated SrcSpanAnnN RdrName -> M FunBind
subst (forall a an modu (m :: * -> *).
(Typeable an, Data a, Data modu, MonadIO m) =>
modu -> AnnSpan -> m (LocatedAn an a)
findOrError a
m) FunBind
old [(String, SrcSpan)]
subs RdrName
name
  where
    subst :: FunBind -> Name -> M FunBind
    subst :: FunBind -> GenLocated SrcSpanAnnN RdrName -> M FunBind
subst (GHC.FunRhs LIdP GhcPs
_ LexicalFixity
b SrcStrictness
s) GenLocated SrcSpanAnnN RdrName
new = do
      -- Low level version as we need to combine the annotation information
      -- from the template RdrName and the original VarPat.
      -- modify . first $
      --   replaceAnnKey (mkAnnKey n) (mkAnnKey fakeExpr) (mkAnnKey new) (mkAnnKey fakeExpr)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
GHC.FunRhs GenLocated SrcSpanAnnN RdrName
new LexicalFixity
b SrcStrictness
s
    subst FunBind
o GenLocated SrcSpanAnnN RdrName
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure FunBind
o
identSub a
_ [(String, SrcSpan)]
_ FunBind
e = forall (f :: * -> *) a. Applicative f => a -> f a
pure FunBind
e

-- g is usually modifyAnnKey
-- f is usually a function which checks the locations are equal
resolveRdrName' ::
  (a -> GHC.LocatedAn an b -> M a) -> -- How to combine the value to insert and the replaced value
  (AnnSpan -> M (GHC.LocatedAn an b)) -> -- How to find the new value, when given the location it is in
  a -> -- The old thing which we are going to possibly replace
  [(String, GHC.SrcSpan)] -> -- Substs
  GHC.RdrName -> -- The name of the position in the template
  --we are replacing into
  M a
resolveRdrName' :: forall a an b.
(a -> LocatedAn an b -> M a)
-> (AnnSpan -> M (LocatedAn an b))
-> a
-> [(String, SrcSpan)]
-> RdrName
-> M a
resolveRdrName' a -> LocatedAn an b -> M a
g AnnSpan -> M (LocatedAn an b)
f a
old [(String, SrcSpan)]
subs RdrName
name =
  case RdrName
name of
    -- Todo: this should replace anns as well?
    GHC.Unqual (OccName -> String
occNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. HasOccName name => name -> OccName
occName -> String
oname)
      | Just SrcSpan
ss <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
oname [(String, SrcSpan)]
subs -> AnnSpan -> M (LocatedAn an b)
f (SrcSpan -> AnnSpan
srcSpanToAnnSpan SrcSpan
ss) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> LocatedAn an b -> M a
g a
old
    RdrName
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
old

resolveRdrName ::
  (Data old, Data a, Data an, Typeable an, Monoid an) =>
  a ->
  (AnnSpan -> M (GHC.LocatedAn an old)) ->
  GHC.LocatedAn an old ->
  [(String, GHC.SrcSpan)] ->
  GHC.RdrName ->
  M (GHC.LocatedAn an old)
resolveRdrName :: forall old a an.
(Data old, Data a, Data an, Typeable an, Monoid an) =>
a
-> (AnnSpan -> M (LocatedAn an old))
-> LocatedAn an old
-> [(String, SrcSpan)]
-> RdrName
-> M (LocatedAn an old)
resolveRdrName a
m = forall a an b.
(a -> LocatedAn an b -> M a)
-> (AnnSpan -> M (LocatedAn an b))
-> a
-> [(String, SrcSpan)]
-> RdrName
-> M a
resolveRdrName' (forall mod t old new.
(Data mod, Data t, Data old, Data new, Monoid t, Typeable t) =>
mod -> LocatedAn t old -> LocatedAn t new -> M (LocatedAn t new)
modifyAnnKey a
m)

-- Substitute the template into the original AST.
doGenReplacement :: forall ast a. DoGenReplacement GHC.AnnListItem ast a
doGenReplacement :: forall ast a. DoGenReplacement AnnListItem ast a
doGenReplacement a
_ LocatedA ast -> Bool
p LocatedA ast
new LocatedA ast
old
  | LocatedA ast -> Bool
p LocatedA ast
old = do
    let (LocatedA ast
new', Int
_, [String]
_) = forall a. Transform a -> (a, Int, [String])
runTransform forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t2 t1 a b.
(Monad m, Monoid t2, Typeable t1, Typeable t2) =>
LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b)
transferEntryDP LocatedA ast
old LocatedA ast
new
    forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Bool
True
    forall (f :: * -> *) a. Applicative f => a -> f a
pure LocatedA ast
new'
  -- If "f a = body where local" doesn't satisfy the predicate, but "f a = body" does,
  -- run the replacement on "f a = body", and add "local" back afterwards.
  -- This is useful for hints like "Eta reduce" and "Redundant where".
  | Just LocatedA ast :~: LHsDecl GhcPs
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @(GHC.LocatedA ast) @(GHC.LHsDecl GHC.GhcPs),
    GHC.L SrcSpanAnnA
_ (GHC.ValD XValD GhcPs
xvald newBind :: HsBindLR GhcPs GhcPs
newBind@GHC.FunBind {}) <- LocatedA ast
new,
    Just (LHsDecl GhcPs
oldNoLocal, HsLocalBinds GhcPs
oldLocal) <- LHsDecl GhcPs -> Maybe (LHsDecl GhcPs, HsLocalBinds GhcPs)
stripLocalBind LocatedA ast
old,
    (RealSrcSpan' AnnSpan
newLocReal) <- forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA LocatedA ast
new,
    LocatedA ast -> Bool
p (forall a. a -> a
composeSrcSpan LHsDecl GhcPs
oldNoLocal) = do
    let newFile :: FastString
newFile = AnnSpan -> FastString
GHC.srcSpanFile AnnSpan
newLocReal
        newLocal :: GHC.HsLocalBinds GHC.GhcPs
        newLocal :: HsLocalBinds GhcPs
newLocal = forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (FastString -> SrcSpan -> SrcSpan
setSrcSpanFile FastString
newFile) HsLocalBinds GhcPs
oldLocal
        -- newLocalLoc = GHC.getLocA newLocal
        newLocalLoc :: SrcSpan
newLocalLoc = forall (p :: Pass).
Data (HsLocalBinds (GhcPass p)) =>
HsLocalBinds (GhcPass p) -> SrcSpan
GHC.spanHsLocaLBinds HsLocalBinds GhcPs
newLocal
        newMG :: MatchGroup GhcPs (LHsExpr GhcPs)
newMG = forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
GHC.fun_matches HsBindLR GhcPs GhcPs
newBind
        GHC.L SrcSpanAnnL
locMG [GHC.L SrcSpanAnnA
locMatch Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMatch] = forall p body. MatchGroup p body -> XRec p [LMatch p body]
GHC.mg_alts MatchGroup GhcPs (LHsExpr GhcPs)
newMG
        newGRHSs :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newGRHSs = forall p body. Match p body -> GRHSs p body
GHC.m_grhss Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMatch
        finalLoc :: SrcSpanAnnA
finalLoc = forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA (forall ann. SrcSpan -> SrcAnn ann
GHC.noAnnSrcSpan SrcSpan
newLocalLoc) (forall l e. GenLocated l e -> l
GHC.getLoc LocatedA ast
new)
        newWithLocalBinds0 :: LHsDecl GhcPs
newWithLocalBinds0 =
          HsLocalBinds GhcPs
-> XValD GhcPs
-> HsBindLR GhcPs GhcPs
-> SrcSpanAnnA
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> SrcSpanAnnL
-> Match GhcPs (LHsExpr GhcPs)
-> SrcSpanAnnA
-> GRHSs GhcPs (LHsExpr GhcPs)
-> LHsDecl GhcPs
setLocalBind
            HsLocalBinds GhcPs
newLocal
            XValD GhcPs
xvald
            HsBindLR GhcPs GhcPs
newBind
            SrcSpanAnnA
finalLoc
            MatchGroup GhcPs (LHsExpr GhcPs)
newMG
            (forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA (forall ann. SrcSpan -> SrcAnn ann
GHC.noAnnSrcSpan SrcSpan
newLocalLoc) SrcSpanAnnL
locMG)
            Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMatch
            (forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA (forall ann. SrcSpan -> SrcAnn ann
GHC.noAnnSrcSpan SrcSpan
newLocalLoc) SrcSpanAnnA
locMatch)
            GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newGRHSs
        (LocatedA ast
newWithLocalBinds, Int
_, [String]
_) = forall a. Transform a -> (a, Int, [String])
runTransform forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
LHsDecl GhcPs -> LHsDecl GhcPs -> TransformT m (LHsDecl GhcPs)
transferEntryDP' LocatedA ast
old LHsDecl GhcPs
newWithLocalBinds0

    forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Bool
True
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> a
composeSrcSpan LocatedA ast
newWithLocalBinds
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure LocatedA ast
old

-- | If the input is a FunBind with a single match, e.g., "foo a = body where x = y"
-- return "Just (foo a = body, x = y)". Otherwise return Nothing.
stripLocalBind ::
  Decl ->
  Maybe (Decl, GHC.HsLocalBinds GHC.GhcPs)
stripLocalBind :: LHsDecl GhcPs -> Maybe (LHsDecl GhcPs, HsLocalBinds GhcPs)
stripLocalBind = \case
  GHC.L SrcSpanAnnA
_ (GHC.ValD XValD GhcPs
xvald origBind :: HsBindLR GhcPs GhcPs
origBind@GHC.FunBind {})
    | let origMG :: MatchGroup GhcPs (LHsExpr GhcPs)
origMG = forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
GHC.fun_matches HsBindLR GhcPs GhcPs
origBind,
      GHC.L SrcSpanAnnL
locMG [GHC.L SrcSpanAnnA
locMatch Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origMatch] <- forall p body. MatchGroup p body -> XRec p [LMatch p body]
GHC.mg_alts MatchGroup GhcPs (LHsExpr GhcPs)
origMG,
      let origGRHSs :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origGRHSs = forall p body. Match p body -> GRHSs p body
GHC.m_grhss Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origMatch,
      [GHC.L SrcSpan
_ (GHC.GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [ExprLStmt GhcPs]
_ (GHC.L SrcSpanAnnA
loc2 HsExpr GhcPs
_))] <- forall p body. GRHSs p body -> [LGRHS p body]
GHC.grhssGRHSs GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origGRHSs ->
      let loc1 :: SrcSpanAnnN
loc1 = forall l e. GenLocated l e -> l
GHC.getLoc (forall idL idR. HsBindLR idL idR -> LIdP idL
GHC.fun_id HsBindLR GhcPs GhcPs
origBind)
          newLoc :: SrcSpanAnnA
newLoc = forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA (forall a ann. SrcSpanAnn' a -> SrcAnn ann
GHC.l2l SrcSpanAnnN
loc1) SrcSpanAnnA
loc2
          withoutLocalBinds :: LHsDecl GhcPs
withoutLocalBinds =
            HsLocalBinds GhcPs
-> XValD GhcPs
-> HsBindLR GhcPs GhcPs
-> SrcSpanAnnA
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> SrcSpanAnnL
-> Match GhcPs (LHsExpr GhcPs)
-> SrcSpanAnnA
-> GRHSs GhcPs (LHsExpr GhcPs)
-> LHsDecl GhcPs
setLocalBind
              (forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
GHC.EmptyLocalBinds NoExtField
GHC.noExtField)
              XValD GhcPs
xvald
              HsBindLR GhcPs GhcPs
origBind
              SrcSpanAnnA
newLoc
              MatchGroup GhcPs (LHsExpr GhcPs)
origMG
              SrcSpanAnnL
locMG
              Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origMatch
              SrcSpanAnnA
locMatch
              GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origGRHSs
       in forall a. a -> Maybe a
Just (LHsDecl GhcPs
withoutLocalBinds, forall p body. GRHSs p body -> HsLocalBinds p
GHC.grhssLocalBinds GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origGRHSs)
  LHsDecl GhcPs
_ -> forall a. Maybe a
Nothing

-- | Set the local binds in a HsBind.
setLocalBind ::
  GHC.HsLocalBinds GHC.GhcPs ->
  GHC.XValD GHC.GhcPs ->
  GHC.HsBind GHC.GhcPs ->
  GHC.SrcSpanAnnA ->
  GHC.MatchGroup GHC.GhcPs Expr ->
  GHC.SrcSpanAnnL ->
  GHC.Match GHC.GhcPs Expr ->
  GHC.SrcSpanAnnA ->
  GHC.GRHSs GHC.GhcPs Expr ->
  Decl
setLocalBind :: HsLocalBinds GhcPs
-> XValD GhcPs
-> HsBindLR GhcPs GhcPs
-> SrcSpanAnnA
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> SrcSpanAnnL
-> Match GhcPs (LHsExpr GhcPs)
-> SrcSpanAnnA
-> GRHSs GhcPs (LHsExpr GhcPs)
-> LHsDecl GhcPs
setLocalBind HsLocalBinds GhcPs
newLocalBinds XValD GhcPs
xvald HsBindLR GhcPs GhcPs
origBind SrcSpanAnnA
newLoc MatchGroup GhcPs (LHsExpr GhcPs)
origMG SrcSpanAnnL
locMG Match GhcPs (LHsExpr GhcPs)
origMatch SrcSpanAnnA
locMatch GRHSs GhcPs (LHsExpr GhcPs)
origGRHSs =
  forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
newLoc (forall p. XValD p -> HsBind p -> HsDecl p
GHC.ValD XValD GhcPs
xvald HsBindLR GhcPs GhcPs
newBind)
  where
    newGRHSs :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newGRHSs = GRHSs GhcPs (LHsExpr GhcPs)
origGRHSs {grhssLocalBinds :: HsLocalBinds GhcPs
GHC.grhssLocalBinds = HsLocalBinds GhcPs
newLocalBinds}
    newMatch :: Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMatch = Match GhcPs (LHsExpr GhcPs)
origMatch {m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
GHC.m_grhss = GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newGRHSs}
    newMG :: MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMG = MatchGroup GhcPs (LHsExpr GhcPs)
origMG {mg_alts :: XRec GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
GHC.mg_alts = forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnL
locMG [forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
locMatch Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMatch]}
    newBind :: HsBindLR GhcPs GhcPs
newBind = HsBindLR GhcPs GhcPs
origBind {fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
GHC.fun_matches = MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMG}

replaceWorker :: forall a mod. (ExactPrint a) => ReplaceWorker a mod
replaceWorker :: forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker mod
m Parser (LocatedA a)
parser Int
seed Replace {String
[(String, SrcSpan)]
SrcSpan
RType
subts :: forall a. Refactoring a -> [(String, a)]
orig :: forall a. Refactoring a -> String
orig :: String
subts :: [(String, SrcSpan)]
pos :: SrcSpan
rtype :: RType
rtype :: forall a. Refactoring a -> RType
pos :: forall a. Refactoring a -> a
..} = do
  let replExprLocation :: AnnSpan
replExprLocation = SrcSpan -> AnnSpan
srcSpanToAnnSpan SrcSpan
pos
      uniqueName :: String
uniqueName = String
"template" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
seed
  let libdir :: a
libdir = forall a. HasCallStack => a
undefined

  LocatedA a
template <- do
    DynFlags
flags <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. String -> (DynFlags -> a) -> IO a
withDynFlags forall {a}. a
libdir forall a. a -> a
id) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IORef a -> IO a
readIORef IORef (Maybe DynFlags)
dynFlagsRef
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. String -> ErrorMessages -> a
onError String
"replaceWorker") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Parser (LocatedA a)
parser DynFlags
flags String
uniqueName String
orig

  (LocatedA a
newExpr, ()) <-
    forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
      -- (substTransform m subts template)
      (forall a b.
(Data a, Data b) =>
b -> [(String, SrcSpan)] -> a -> M a
substTransform mod
m [(String, SrcSpan)]
subts (forall ast. ExactPrint ast => ast -> ast
makeDeltaAst LocatedA a
template))
      -- (mergeAnns as relat, keyMap)
      ()
  -- Add a space if needed, so that we avoid refactoring `y = do(foo bar)` into `y = dofoo bar`.
  -- ensureDoSpace :: Anns -> Anns
  let ensureSpace :: forall t. (Data t) => t -> t
      ensureSpace :: forall t. Data t => t -> t
ensureSpace = (forall t. Data t => t -> t) -> forall t. Data t => t -> t
everywhere (forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT LHsExpr GhcPs -> LHsExpr GhcPs
ensureExprSpace)

      ensureExprSpace :: Expr -> Expr
      ensureExprSpace :: LHsExpr GhcPs -> LHsExpr GhcPs
ensureExprSpace e :: LHsExpr GhcPs
e@(GHC.L SrcSpanAnnA
l (GHC.HsDo XDo GhcPs
an HsStmtContext (HsDoRn GhcPs)
v (GHC.L SrcSpanAnnL
ls [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts))) = GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' -- ensureDoSpace
        where
          isDo :: Bool
isDo = case HsStmtContext (HsDoRn GhcPs)
v of
            HsStmtContext (HsDoRn GhcPs)
GHC.ListComp -> Bool
False
            HsStmtContext (HsDoRn GhcPs)
_ -> Bool
True
          e' :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' =
            if Bool
isDo
              Bool -> Bool -> Bool
&& forall ann. EpAnn ann -> Maybe AnchorOperation
manchorOp XDo GhcPs
an forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (DeltaPos -> AnchorOperation
GHC.MovedAnchor (Int -> DeltaPos
GHC.SameLine Int
0))
              Bool -> Bool -> Bool
&& forall ann. EpAnn ann -> Maybe AnchorOperation
manchorOp (forall a. SrcSpanAnn' a -> a
GHC.ann SrcSpanAnnL
ls) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (DeltaPos -> AnchorOperation
GHC.MovedAnchor (Int -> DeltaPos
GHC.SameLine Int
0))
              then forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l (forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
GHC.HsDo XDo GhcPs
an HsStmtContext (HsDoRn GhcPs)
v (forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP (forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnL
ls [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts) (Int -> DeltaPos
GHC.SameLine Int
1)))
              else LHsExpr GhcPs
e
      ensureExprSpace e :: LHsExpr GhcPs
e@(GHC.L SrcSpanAnnA
l (GHC.HsApp XApp GhcPs
x (GHC.L SrcSpanAnnA
la HsExpr GhcPs
a) (GHC.L SrcSpanAnnA
lb HsExpr GhcPs
b))) = GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' -- ensureAppSpace
        where
          e' :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' =
            if forall ann. EpAnn ann -> Maybe AnchorOperation
manchorOp (forall a. SrcSpanAnn' a -> a
GHC.ann SrcSpanAnnA
lb) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (DeltaPos -> AnchorOperation
GHC.MovedAnchor (Int -> DeltaPos
GHC.SameLine Int
0))
              then forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l (forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
GHC.HsApp XApp GhcPs
x (forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
la HsExpr GhcPs
a) (forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP (forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
lb HsExpr GhcPs
b) (Int -> DeltaPos
GHC.SameLine Int
1)))
              else LHsExpr GhcPs
e
      ensureExprSpace LHsExpr GhcPs
e = LHsExpr GhcPs
e

      replacementPred :: LocatedA a -> Bool
replacementPred = (forall a. Eq a => a -> a -> Bool
== AnnSpan
replExprLocation) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall an a. LocatedAn an a -> AnnSpan
getAnnSpanA

      tt :: GHC.LocatedA a -> StateT Bool IO (GHC.LocatedA a)
      tt :: LocatedA a -> StateT Bool IO (LocatedA a)
tt = forall ast a. DoGenReplacement AnnListItem ast a
doGenReplacement mod
m LocatedA a -> Bool
replacementPred LocatedA a
newExpr
      transformation :: mod -> StateT Bool IO mod
      transformation :: mod -> StateT Bool IO mod
transformation = forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM LocatedA a -> StateT Bool IO (LocatedA a)
tt
  forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (mod -> StateT Bool IO mod
transformation mod
m) Bool
False forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (mod
finalM, Bool
True) ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall t. Data t => t -> t
ensureSpace mod
finalM)
    -- Failed to find a replacment so don't make any changes
    (mod, Bool)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure mod
m
replaceWorker mod
m Parser (LocatedA a)
_ Int
_ Refactoring SrcSpan
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure mod
m

manchorOp :: GHC.EpAnn ann -> Maybe GHC.AnchorOperation
manchorOp :: forall ann. EpAnn ann -> Maybe AnchorOperation
manchorOp EpAnn ann
GHC.EpAnnNotUsed = forall a. Maybe a
Nothing
manchorOp (GHC.EpAnn Anchor
a ann
_ EpAnnComments
_) = forall a. a -> Maybe a
Just (Anchor -> AnchorOperation
GHC.anchor_op Anchor
a)

data NotFound = NotFound
  { NotFound -> String
nfExpected :: String,
    NotFound -> Maybe String
nfActual :: Maybe String,
    NotFound -> AnnSpan
nfLoc :: AnnSpan
  }

renderNotFound :: NotFound -> String
renderNotFound :: NotFound -> String
renderNotFound NotFound {String
Maybe String
AnnSpan
nfLoc :: AnnSpan
nfActual :: Maybe String
nfExpected :: String
nfLoc :: NotFound -> AnnSpan
nfActual :: NotFound -> Maybe String
nfExpected :: NotFound -> String
..} =
  String
"Expected type not found at the location specified in the refact file.\n"
    forall a. [a] -> [a] -> [a]
++ String
"  Expected type: "
    forall a. [a] -> [a] -> [a]
++ String
nfExpected
    forall a. [a] -> [a] -> [a]
++ String
"\n"
    forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
actual -> String
"  Actual type: " forall a. [a] -> [a] -> [a]
++ String
actual forall a. [a] -> [a] -> [a]
++ String
"\n") Maybe String
nfActual
    forall a. [a] -> [a] -> [a]
++ String
"  Location: "
    forall a. [a] -> [a] -> [a]
++ SDoc -> String
showSDocUnsafe (forall a. Outputable a => a -> SDoc
ppr AnnSpan
nfLoc)

-- Find a given type with a given SrcSpan
findInModule ::
  forall an a modu.
  (Typeable an, Data a, Data modu) =>
  modu ->
  AnnSpan ->
  Either NotFound (GHC.LocatedAn an a)
findInModule :: forall an a modu.
(Typeable an, Data a, Data modu) =>
modu -> AnnSpan -> Either NotFound (LocatedAn an a)
findInModule modu
m AnnSpan
ss = case forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans modu
m of
  Just LocatedAn an a
a -> forall a b. b -> Either a b
Right LocatedAn an a
a
  Maybe (LocatedAn an a)
Nothing ->
    let expected :: String
expected = forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @a))
        actual :: Maybe String
actual =
          forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$
            forall a. [Maybe a] -> [a]
catMaybes
              [ forall an' b. Typeable b => Maybe (LocatedAn an' b) -> Maybe String
showType (forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans modu
m :: Maybe Expr),
                forall an' b. Typeable b => Maybe (LocatedAn an' b) -> Maybe String
showType (forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans modu
m :: Maybe Type),
                forall an' b. Typeable b => Maybe (LocatedAn an' b) -> Maybe String
showType (forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans modu
m :: Maybe Decl),
                forall an' b. Typeable b => Maybe (LocatedAn an' b) -> Maybe String
showType (forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans modu
m :: Maybe Pat),
                forall an' b. Typeable b => Maybe (LocatedAn an' b) -> Maybe String
showType (forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans modu
m :: Maybe Name)
              ]
     in forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> AnnSpan -> NotFound
NotFound String
expected Maybe String
actual AnnSpan
ss
  where
    doTrans :: forall an' b. (Typeable an', Data b) => modu -> Maybe (GHC.LocatedAn an' b)
    doTrans :: forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans = forall u. GenericQ (Maybe u) -> GenericQ (Maybe u)
something (forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ forall a. Maybe a
Nothing (forall an a.
Data a =>
AnnSpan -> LocatedAn an a -> Maybe (LocatedAn an a)
findLargestExpression AnnSpan
ss))

    showType :: forall an' b. Typeable b => Maybe (GHC.LocatedAn an' b) -> Maybe String
    showType :: forall an' b. Typeable b => Maybe (LocatedAn an' b) -> Maybe String
showType = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ \LocatedAn an' b
_ -> forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @b))

findLargestExpression ::
  forall an a.
  Data a =>
  AnnSpan ->
  GHC.LocatedAn an a ->
  Maybe (GHC.LocatedAn an a)
findLargestExpression :: forall an a.
Data a =>
AnnSpan -> LocatedAn an a -> Maybe (LocatedAn an a)
findLargestExpression AnnSpan
as e :: LocatedAn an a
e@(forall an a. LocatedAn an a -> AnnSpan
getAnnSpanA -> AnnSpan
l) = if AnnSpan
l forall a. Eq a => a -> a -> Bool
== AnnSpan
as then forall a. a -> Maybe a
Just LocatedAn an a
e else forall a. Maybe a
Nothing

findOrError ::
  forall a an modu m.
  (Typeable an, Data a, Data modu, MonadIO m) =>
  modu ->
  AnnSpan ->
  m (GHC.LocatedAn an a)
findOrError :: forall a an modu (m :: * -> *).
(Typeable an, Data a, Data modu, MonadIO m) =>
modu -> AnnSpan -> m (LocatedAn an a)
findOrError modu
m = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {m :: * -> *} {a}. MonadIO m => NotFound -> m a
f forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall an a modu.
(Typeable an, Data a, Data modu) =>
modu -> AnnSpan -> Either NotFound (LocatedAn an a)
findInModule modu
m
  where
    f :: NotFound -> m a
f NotFound
nf = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
InappropriateType (NotFound -> String
renderNotFound NotFound
nf) forall a. Maybe a
Nothing forall a. Maybe a
Nothing

-- Deletion from a list

doDeleteStmt :: Data a => (Stmt -> Bool) -> a -> a
doDeleteStmt :: forall a. Data a => (ExprLStmt GhcPs -> Bool) -> a -> a
doDeleteStmt = forall from to. Biplate from to => (to -> to) -> from -> from
transformBi forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter

doDeleteImport :: Data a => (Import -> Bool) -> a -> a
doDeleteImport :: forall a. Data a => (LImportDecl GhcPs -> Bool) -> a -> a
doDeleteImport = forall from to. Biplate from to => (to -> to) -> from -> from
transformBi forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter

addExtensionsToFlags ::
  [Extension] ->
  [Extension] ->
  FilePath ->
  GHC.DynFlags ->
  IO (Either String GHC.DynFlags)
addExtensionsToFlags :: [Extension]
-> [Extension] -> String -> DynFlags -> IO (Either String DynFlags)
addExtensionsToFlags [Extension]
es [Extension]
ds String
fp DynFlags
flags = forall {b}. IO (Either String b) -> IO (Either String b)
catchErrors forall a b. (a -> b) -> a -> b
$ do
  (String -> StringBuffer
stringToStringBuffer -> StringBuffer
buf) <- String -> IO String
readFileUTF8' String
fp
#if MIN_VERSION_ghc(9,4,0)
  let (_, opts) = getOptions (initParserOpts flags) buf fp
#else
  let opts :: [Located String]
opts = DynFlags -> StringBuffer -> String -> [Located String]
getOptions DynFlags
flags StringBuffer
buf String
fp
#endif
      withExts :: DynFlags
withExts =
        forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
xopt_unset) [Extension]
ds
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
xopt_set) [Extension]
es
          forall a b. (a -> b) -> a -> b
$ DynFlags
flags
  (DynFlags
withPragmas, [Located String]
_, [Warn]
_) <- forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
withExts [Located String]
opts
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ DynFlags
withPragmas DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
GHC.Opt_KeepRawTokenStream
  where
    catchErrors :: IO (Either String b) -> IO (Either String b)
catchErrors =
      forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
GHC.handleSourceError (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)

parseModuleWithArgs ::
  LibDir ->
  ([Extension], [Extension]) ->
  FilePath ->
  IO (Either Errors GHC.ParsedSource)
parseModuleWithArgs :: String
-> ([Extension], [Extension])
-> String
-> IO (Either ErrorMessages ParsedSource)
parseModuleWithArgs String
libdir ([Extension]
es, [Extension]
ds) String
fp = forall a. String -> Ghc a -> IO a
ghcWrapper String
libdir forall a b. (a -> b) -> a -> b
$ do
  DynFlags
initFlags <- forall (m :: * -> *). GhcMonad m => String -> m DynFlags
initDynFlags String
fp
  Either String DynFlags
eflags <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Extension]
-> [Extension] -> String -> DynFlags -> IO (Either String DynFlags)
addExtensionsToFlags [Extension]
es [Extension]
ds String
fp DynFlags
initFlags
  case Either String DynFlags
eflags of
    -- TODO: report error properly.
    Left String
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> String -> ErrorMessages
mkErr DynFlags
initFlags SrcSpan
GHC.noSrcSpan String
err
    Right DynFlags
flags -> do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef' IORef (Maybe DynFlags)
dynFlagsRef (forall a. a -> Maybe a
Just DynFlags
flags)
      Either
  ErrorMessages
  ([GenLocated Anchor EpaComment], DynFlags, ParsedSource)
res <- forall (m :: * -> *).
GhcMonad m =>
CppOptions
-> DynFlags
-> String
-> m (Either
        ErrorMessages
        ([GenLocated Anchor EpaComment], DynFlags, ParsedSource))
parseModuleEpAnnsWithCppInternal CppOptions
defaultCppOptions DynFlags
flags String
fp

      -- pure $ postParseTransform res rigidLayout
      case forall a.
Either a ([GenLocated Anchor EpaComment], DynFlags, ParsedSource)
-> Either a ParsedSource
postParseTransform Either
  ErrorMessages
  ([GenLocated Anchor EpaComment], DynFlags, ParsedSource)
res of
        Left ErrorMessages
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left ErrorMessages
e)
        Right ParsedSource
ast -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (forall ast. ExactPrint ast => ast -> ast
makeDeltaAst ParsedSource
ast)

-- | Parse the input into (enabled extensions, disabled extensions, invalid input).
-- Implied extensions are automatically added. For example, @FunctionalDependencies@
-- implies @MultiParamTypeClasses@, and @RebindableSyntax@ implies @NoImplicitPrelude@.
--
-- The input is processed from left to right. An extension (e.g., @StarIsType@)
-- may be overridden later (e.g., by @NoStarIsType@).
--
-- Extensions that appear earlier in the input will appear later in the output.
-- Implied extensions appear in the end. If an extension occurs multiple times in the input,
-- the last one is used.
--
-- >>> parseExtensions ["GADTs", "RebindableSyntax", "StarIsType", "GADTs", "InvalidExtension", "NoStarIsType"]
-- ([GADTs, RebindableSyntax, GADTSyntax, MonoLocalBinds], [StarIsType, ImplicitPrelude], ["InvalidExtension"])
parseExtensions :: [String] -> ([Extension], [Extension], [String])
parseExtensions :: [String] -> ([Extension], [Extension], [String])
parseExtensions = ([Extension], [Extension], [String])
-> ([Extension], [Extension], [String])
addImplied forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Extension], [Extension], [String])
-> String -> ([Extension], [Extension], [String])
f forall a. Monoid a => a
mempty
  where
    f :: ([Extension], [Extension], [String]) -> String -> ([Extension], [Extension], [String])
    f :: ([Extension], [Extension], [String])
-> String -> ([Extension], [Extension], [String])
f ([Extension]
ys, [Extension]
ns, [String]
is) (Char
'N' : Char
'o' : String
s)
      | Just Extension
ext <- String -> Maybe Extension
readExtension String
s =
        (forall a. Eq a => a -> [a] -> [a]
delete Extension
ext [Extension]
ys, Extension
ext forall a. a -> [a] -> [a]
: forall a. Eq a => a -> [a] -> [a]
delete Extension
ext [Extension]
ns, [String]
is)
    f ([Extension]
ys, [Extension]
ns, [String]
is) String
s
      | Just Extension
ext <- String -> Maybe Extension
readExtension String
s =
        (Extension
ext forall a. a -> [a] -> [a]
: forall a. Eq a => a -> [a] -> [a]
delete Extension
ext [Extension]
ys, forall a. Eq a => a -> [a] -> [a]
delete Extension
ext [Extension]
ns, [String]
is)
    f ([Extension]
ys, [Extension]
ns, [String]
is) String
s = ([Extension]
ys, [Extension]
ns, String
s forall a. a -> [a] -> [a]
: [String]
is)

    addImplied :: ([Extension], [Extension], [String]) -> ([Extension], [Extension], [String])
    addImplied :: ([Extension], [Extension], [String])
-> ([Extension], [Extension], [String])
addImplied ([Extension]
ys, [Extension]
ns, [String]
is) = ([Extension]
ys forall a. [a] -> [a] -> [a]
++ [Extension]
impliedOn, [Extension]
ns forall a. [a] -> [a] -> [a]
++ [Extension]
impliedOff, [String]
is)
      where
        impliedOn :: [Extension]
impliedOn = [Extension
b | Extension
ext <- [Extension]
ys, (Extension
a, Bool
True, Extension
b) <- [(Extension, Bool, Extension)]
impliedXFlags, Extension
a forall a. Eq a => a -> a -> Bool
== Extension
ext]
        impliedOff :: [Extension]
impliedOff = [Extension
b | Extension
ext <- [Extension]
ys, (Extension
a, Bool
False, Extension
b) <- [(Extension, Bool, Extension)]
impliedXFlags, Extension
a forall a. Eq a => a -> a -> Bool
== Extension
ext]

readExtension :: String -> Maybe Extension
readExtension :: String -> Maybe Extension
readExtension String
s = forall flag. FlagSpec flag -> flag
flagSpecFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== String
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall flag. FlagSpec flag -> String
flagSpecName) [FlagSpec Extension]
xFlags

-- TODO: This is added to avoid a breaking change. We should remove it and
-- directly pass the `DynFlags` as arguments, before the 0.10 release.
dynFlagsRef :: IORef (Maybe GHC.DynFlags)
dynFlagsRef :: IORef (Maybe DynFlags)
dynFlagsRef = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
{-# NOINLINE dynFlagsRef #-}