{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# 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
#if MIN_VERSION_ghc(9,10,0)
#else
import Data.Default
#endif
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
#if MIN_VERSION_ghc(9,12,0)
import qualified GHC.Data.Strict as Strict
#endif
import GHC.IO.Exception (IOErrorType (..))
import GHC.LanguageExtensions.Type (Extension (..))
import Language.Haskell.GHC.ExactPrint
  ( ExactPrint,
    exactPrint,
    getEntryDP,
    makeDeltaAst,
    runTransform,
    setEntryDP,
  )
import Language.Haskell.GHC.ExactPrint.ExactPrint
  ( EPOptions,
#if MIN_VERSION_ghc(9,12,0)
#else
    epRigidity,
#endif
    exactPrintWithOptions,
    stringOptions,
  )
import Language.Haskell.GHC.ExactPrint.Parsers
-- import Language.Haskell.GHC.ExactPrint.Types
#if MIN_VERSION_ghc(9,12,0)
#else
import Language.Haskell.GHC.ExactPrint.Types
    -- epRigidity,
    -- Rigidity(..),
#endif
-- #if MIN_VERSION_ghc(9,12,0)
-- import Language.Haskell.GHC.ExactPrint.Utils (showAst)
-- #else
-- import Language.Haskell.GHC.ExactPrint.ExactPrint (showAst)
-- #endif
import Language.Haskell.GHC.ExactPrint.Utils (ss2pos)
import Refact.Compat
  ( AnnSpan,
    DoGenReplacement,
    Errors,
    FlagSpec (..),
    FunBind,
    Module,
    ReplaceWorker,

    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',
    transferEntryDP,
    transferEntryDP',
    commentSrcSpan,
#if MIN_VERSION_ghc(9,12,0)
#else
    ann,
#endif

#if MIN_VERSION_ghc(9,4,0)
    mkGeneratedHsDocString,
    initParserOpts,
#else
#endif
    AnnConstraint
  )
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)
-- import qualified GHC

refactOptions :: EPOptions Identity String
#if MIN_VERSION_ghc(9,12,0)
refactOptions = stringOptions
#else
refactOptions :: EPOptions Identity String
refactOptions = EPOptions Identity String
stringOptions {epRigidity = RigidLayout}
#endif

-- | 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 <-
    IO (SrcSpan -> SrcSpan)
-> (String -> IO (SrcSpan -> SrcSpan))
-> Maybe String
-> IO (SrcSpan -> SrcSpan)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      ( case ParsedSource -> SrcSpan
forall l e. GenLocated l e -> l
GHC.getLoc ParsedSource
m0 of
          GHC.UnhelpfulSpan UnhelpfulSpanReason
s -> String -> IO (SrcSpan -> SrcSpan)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (SrcSpan -> SrcSpan))
-> String -> IO (SrcSpan -> SrcSpan)
forall a b. (a -> b) -> a -> b
$ String
"Module has UnhelpfulSpan: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnhelpfulSpanReason -> String
forall a. Show a => a -> String
show UnhelpfulSpanReason
s
          RealSrcSpan' AnnSpan
s ->
            (SrcSpan -> SrcSpan) -> IO (SrcSpan -> SrcSpan)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SrcSpan -> SrcSpan) -> IO (SrcSpan -> SrcSpan))
-> (SrcSpan -> SrcSpan) -> IO (SrcSpan -> SrcSpan)
forall a b. (a -> b) -> a -> b
$ FastString -> SrcSpan -> SrcSpan
toGhcSrcSpan' (AnnSpan -> FastString
GHC.srcSpanFile AnnSpan
s)
      )
      ((SrcSpan -> SrcSpan) -> IO (SrcSpan -> SrcSpan)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SrcSpan -> SrcSpan) -> IO (SrcSpan -> SrcSpan))
-> (String -> SrcSpan -> SrcSpan)
-> String
-> IO (SrcSpan -> SrcSpan)
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 =
        (((String, [Refactoring SrcSpan]), SrcSpan)
 -> ((String, [Refactoring SrcSpan]), SrcSpan) -> Ordering)
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((String, [Refactoring SrcSpan]), SrcSpan)
-> ((String, [Refactoring SrcSpan]), SrcSpan) -> Ordering
forall {a} {a}. (a, SrcSpan) -> (a, SrcSpan) -> Ordering
cmpSrcSpan
          ([((String, [Refactoring SrcSpan]), SrcSpan)]
 -> [((String, [Refactoring SrcSpan]), SrcSpan)])
-> ([(String, [Refactoring SrcSpan])]
    -> [((String, [Refactoring SrcSpan]), SrcSpan)])
-> [(String, [Refactoring SrcSpan])]
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((String, [Refactoring SrcSpan]), SrcSpan)
 -> ((String, [Refactoring SrcSpan]), SrcSpan))
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
forall a b. (a -> b) -> [a] -> [b]
map (((String, [Refactoring SrcSpan])
 -> (String, [Refactoring SrcSpan]))
-> ((String, [Refactoring SrcSpan]), SrcSpan)
-> ((String, [Refactoring SrcSpan]), SrcSpan)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (((String, [Refactoring SrcSpan])
  -> (String, [Refactoring SrcSpan]))
 -> ((String, [Refactoring SrcSpan]), SrcSpan)
 -> ((String, [Refactoring SrcSpan]), SrcSpan))
-> ((SrcSpan -> SrcSpan)
    -> (String, [Refactoring SrcSpan])
    -> (String, [Refactoring SrcSpan]))
-> (SrcSpan -> SrcSpan)
-> ((String, [Refactoring SrcSpan]), SrcSpan)
-> ((String, [Refactoring SrcSpan]), SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Refactoring SrcSpan] -> [Refactoring SrcSpan])
-> (String, [Refactoring SrcSpan])
-> (String, [Refactoring SrcSpan])
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (([Refactoring SrcSpan] -> [Refactoring SrcSpan])
 -> (String, [Refactoring SrcSpan])
 -> (String, [Refactoring SrcSpan]))
-> ((SrcSpan -> SrcSpan)
    -> [Refactoring SrcSpan] -> [Refactoring SrcSpan])
-> (SrcSpan -> SrcSpan)
-> (String, [Refactoring SrcSpan])
-> (String, [Refactoring SrcSpan])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Refactoring SrcSpan -> Refactoring SrcSpan)
-> [Refactoring SrcSpan] -> [Refactoring SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map ((Refactoring SrcSpan -> Refactoring SrcSpan)
 -> [Refactoring SrcSpan] -> [Refactoring SrcSpan])
-> ((SrcSpan -> SrcSpan)
    -> Refactoring SrcSpan -> Refactoring SrcSpan)
-> (SrcSpan -> SrcSpan)
-> [Refactoring SrcSpan]
-> [Refactoring SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcSpan -> SrcSpan) -> Refactoring SrcSpan -> Refactoring SrcSpan
forall a b. (a -> b) -> Refactoring a -> Refactoring b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SrcSpan -> SrcSpan)
 -> ((String, [Refactoring SrcSpan]), SrcSpan)
 -> ((String, [Refactoring SrcSpan]), SrcSpan))
-> (SrcSpan -> SrcSpan)
-> ((String, [Refactoring SrcSpan]), SrcSpan)
-> ((String, [Refactoring SrcSpan]), SrcSpan)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpan
toGhcSS)
          ([((String, [Refactoring SrcSpan]), SrcSpan)]
 -> [((String, [Refactoring SrcSpan]), SrcSpan)])
-> ([(String, [Refactoring SrcSpan])]
    -> [((String, [Refactoring SrcSpan]), SrcSpan)])
-> [(String, [Refactoring SrcSpan])]
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [Refactoring SrcSpan])
 -> Maybe ((String, [Refactoring SrcSpan]), SrcSpan))
-> [(String, [Refactoring SrcSpan])]
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (((String, [Refactoring SrcSpan]), Maybe SrcSpan)
-> Maybe ((String, [Refactoring SrcSpan]), SrcSpan)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
((String, [Refactoring SrcSpan]), f a)
-> f ((String, [Refactoring SrcSpan]), a)
sequenceA (((String, [Refactoring SrcSpan]), Maybe SrcSpan)
 -> Maybe ((String, [Refactoring SrcSpan]), SrcSpan))
-> ((String, [Refactoring SrcSpan])
    -> ((String, [Refactoring SrcSpan]), Maybe SrcSpan))
-> (String, [Refactoring SrcSpan])
-> Maybe ((String, [Refactoring SrcSpan]), SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [Refactoring SrcSpan]) -> (String, [Refactoring SrcSpan])
forall a. a -> a
id ((String, [Refactoring SrcSpan])
 -> (String, [Refactoring SrcSpan]))
-> ((String, [Refactoring SrcSpan]) -> Maybe SrcSpan)
-> (String, [Refactoring SrcSpan])
-> ((String, [Refactoring SrcSpan]), Maybe SrcSpan)
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& [SrcSpan] -> Maybe SrcSpan
aggregateSrcSpans ([SrcSpan] -> Maybe SrcSpan)
-> ((String, [Refactoring SrcSpan]) -> [SrcSpan])
-> (String, [Refactoring SrcSpan])
-> Maybe SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Refactoring SrcSpan -> SrcSpan)
-> [Refactoring SrcSpan] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Refactoring SrcSpan -> SrcSpan
forall a. Refactoring a -> a
pos ([Refactoring SrcSpan] -> [SrcSpan])
-> ((String, [Refactoring SrcSpan]) -> [Refactoring SrcSpan])
-> (String, [Refactoring SrcSpan])
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [Refactoring SrcSpan]) -> [Refactoring SrcSpan]
forall a b. (a, b) -> b
snd))
          ([(String, [Refactoring SrcSpan])]
 -> [((String, [Refactoring SrcSpan]), SrcSpan)])
-> ([(String, [Refactoring SrcSpan])]
    -> [(String, [Refactoring SrcSpan])])
-> [(String, [Refactoring SrcSpan])]
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [Refactoring SrcSpan]) -> Bool)
-> [(String, [Refactoring SrcSpan])]
-> [(String, [Refactoring SrcSpan])]
forall a. (a -> Bool) -> [a] -> [a]
filter (((String, [Refactoring SrcSpan]) -> Bool)
-> ((Int, Int) -> (String, [Refactoring SrcSpan]) -> Bool)
-> Maybe (Int, Int)
-> (String, [Refactoring SrcSpan])
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> (String, [Refactoring SrcSpan]) -> Bool
forall a b. a -> b -> a
const Bool
True) (\(Int, Int)
p -> (Refactoring SrcSpan -> Bool) -> [Refactoring SrcSpan] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((SrcSpan -> (Int, Int) -> Bool
`spans` (Int, Int)
p) (SrcSpan -> Bool)
-> (Refactoring SrcSpan -> SrcSpan) -> Refactoring SrcSpan -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Refactoring SrcSpan -> SrcSpan
forall a. Refactoring a -> a
pos) ([Refactoring SrcSpan] -> Bool)
-> ((String, [Refactoring SrcSpan]) -> [Refactoring SrcSpan])
-> (String, [Refactoring SrcSpan])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [Refactoring SrcSpan]) -> [Refactoring SrcSpan]
forall a b. (a, b) -> b
snd) Maybe (Int, Int)
mpos)
          ([(String, [Refactoring SrcSpan])]
 -> [((String, [Refactoring SrcSpan]), SrcSpan)])
-> [(String, [Refactoring SrcSpan])]
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
forall a b. (a -> b) -> a -> b
$ [(String, [Refactoring SrcSpan])]
inp

      cmpSrcSpan :: (a, SrcSpan) -> (a, SrcSpan) -> Ordering
cmpSrcSpan (a
_, SrcSpan
s1) (a
_, SrcSpan
s2) =
        (SrcSpan -> Int) -> SrcSpan -> SrcSpan -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SrcSpan -> Int
startLine SrcSpan
s1 SrcSpan
s2
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (SrcSpan -> Int) -> SrcSpan -> SrcSpan -> Ordering
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
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (SrcSpan -> Int) -> SrcSpan -> SrcSpan -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SrcSpan -> Int
endLine SrcSpan
s2 SrcSpan
s1 --             or on earlier column
          Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (SrcSpan -> Int) -> SrcSpan -> SrcSpan -> Ordering
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Normal) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    String
"Applying " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ([((String, [Refactoring SrcSpan]), SrcSpan)] -> Int)
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int)
-> ([((String, [Refactoring SrcSpan]), SrcSpan)] -> [Int])
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((String, [Refactoring SrcSpan]), SrcSpan) -> Int)
-> [((String, [Refactoring SrcSpan]), SrcSpan)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Refactoring SrcSpan] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Refactoring SrcSpan] -> Int)
-> (((String, [Refactoring SrcSpan]), SrcSpan)
    -> [Refactoring SrcSpan])
-> ((String, [Refactoring SrcSpan]), SrcSpan)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [Refactoring SrcSpan]) -> [Refactoring SrcSpan]
forall a b. (a, b) -> b
snd ((String, [Refactoring SrcSpan]) -> [Refactoring SrcSpan])
-> (((String, [Refactoring SrcSpan]), SrcSpan)
    -> (String, [Refactoring SrcSpan]))
-> ((String, [Refactoring SrcSpan]), SrcSpan)
-> [Refactoring SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [Refactoring SrcSpan]), SrcSpan)
-> (String, [Refactoring SrcSpan])
forall a b. (a, b) -> a
fst) ([((String, [Refactoring SrcSpan]), SrcSpan)] -> String)
-> [((String, [Refactoring SrcSpan]), SrcSpan)] -> String
forall a b. (a -> b) -> a -> b
$ [((String, [Refactoring SrcSpan]), SrcSpan)]
allRefacts) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" hints"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Loud) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [(String, [Refactoring SrcSpan])] -> String
forall a. Show a => a -> String
show ((((String, [Refactoring SrcSpan]), SrcSpan)
 -> (String, [Refactoring SrcSpan]))
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> [(String, [Refactoring SrcSpan])]
forall a b. (a -> b) -> [a] -> [b]
map ((String, [Refactoring SrcSpan]), SrcSpan)
-> (String, [Refactoring SrcSpan])
forall a b. (a, b) -> a
fst [((String, [Refactoring SrcSpan]), SrcSpan)]
allRefacts)

  ParsedSource
m <-
    if Bool
step
      then ParsedSource -> Maybe ParsedSource -> ParsedSource
forall a. a -> Maybe a -> a
fromMaybe ParsedSource
m0 (Maybe ParsedSource -> ParsedSource)
-> IO (Maybe ParsedSource) -> IO ParsedSource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT IO ParsedSource -> IO (Maybe ParsedSource)
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 StateT Int IO ParsedSource -> Int -> IO ParsedSource
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 (((String, [Refactoring SrcSpan]) -> [Refactoring SrcSpan])
-> ((String, [Refactoring SrcSpan]), SrcSpan)
-> ([Refactoring SrcSpan], SrcSpan)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (String, [Refactoring SrcSpan]) -> [Refactoring SrcSpan]
forall a b. (a, b) -> b
snd (((String, [Refactoring SrcSpan]), SrcSpan)
 -> ([Refactoring SrcSpan], SrcSpan))
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> [([Refactoring SrcSpan], SrcSpan)]
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
  String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String)
-> (Identity (ParsedSource, String) -> String)
-> Identity (ParsedSource, String)
-> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParsedSource, String) -> String
forall a b. (a, b) -> b
snd ((ParsedSource, String) -> String)
-> (Identity (ParsedSource, String) -> (ParsedSource, String))
-> Identity (ParsedSource, String)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (ParsedSource, String) -> (ParsedSource, String)
forall a. Identity a -> a
runIdentity (Identity (ParsedSource, String) -> IO String)
-> Identity (ParsedSource, String) -> IO String
forall a b. (a -> b) -> a -> b
$ EPOptions Identity String
-> ParsedSource -> Identity (ParsedSource, String)
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
startLine :: SrcSpan -> Int
startCol :: SrcSpan -> Int
endLine :: SrcSpan -> Int
endCol :: SrcSpan -> Int
startLine :: Int
startCol :: Int
endLine :: Int
endCol :: Int
..} (Int, Int)
loc = (Int
startLine, Int
startCol) (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int, Int)
loc Bool -> Bool -> Bool
&& (Int, Int)
loc (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int
endLine, Int
endCol)

aggregateSrcSpans :: [R.SrcSpan] -> Maybe R.SrcSpan
aggregateSrcSpans :: [SrcSpan] -> Maybe SrcSpan
aggregateSrcSpans = \case
  [] -> Maybe SrcSpan
forall a. Maybe a
Nothing
  [SrcSpan]
rs -> SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just ((SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall a. (a -> a -> a) -> [a] -> a
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 Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
sl1 Int
sl2 of
            Ordering
LT -> (Int
sl1, Int
sc1)
            Ordering
EQ -> (Int
sl1, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
sc1 Int
sc2)
            Ordering
GT -> (Int
sl2, Int
sc2)
          (Int
el, Int
ec) = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
el1 Int
el2 of
            Ordering
LT -> (Int
el2, Int
ec2)
            Ordering
EQ -> (Int
el2, Int -> Int -> Int
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 StateT Int IO (Maybe ParsedSource)
-> (Maybe ParsedSource -> StateT Int IO ParsedSource)
-> StateT Int IO ParsedSource
forall a b.
StateT Int IO a -> (a -> StateT Int IO b) -> StateT Int IO b
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') = (([Refactoring SrcSpan], SrcSpan) -> Bool)
-> [([Refactoring SrcSpan], SrcSpan)]
-> ([([Refactoring SrcSpan], SrcSpan)],
    [([Refactoring SrcSpan], SrcSpan)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (SrcSpan -> SrcSpan -> Bool
overlap SrcSpan
ss (SrcSpan -> Bool)
-> (([Refactoring SrcSpan], SrcSpan) -> SrcSpan)
-> ([Refactoring SrcSpan], SrcSpan)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Refactoring SrcSpan], SrcSpan) -> SrcSpan
forall a b. (a, b) -> b
snd) [([Refactoring SrcSpan], SrcSpan)]
rest
      Bool -> StateT Int IO () -> StateT Int IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Normal) (StateT Int IO () -> StateT Int IO ())
-> ((([Refactoring SrcSpan], SrcSpan) -> StateT Int IO ())
    -> StateT Int IO ())
-> (([Refactoring SrcSpan], SrcSpan) -> StateT Int IO ())
-> StateT Int IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Refactoring SrcSpan], SrcSpan)]
-> (([Refactoring SrcSpan], SrcSpan) -> StateT Int IO ())
-> StateT Int IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [([Refactoring SrcSpan], SrcSpan)]
overlaps ((([Refactoring SrcSpan], SrcSpan) -> StateT Int IO ())
 -> StateT Int IO ())
-> (([Refactoring SrcSpan], SrcSpan) -> StateT Int IO ())
-> StateT Int IO ()
forall a b. (a -> b) -> a -> b
$ \([Refactoring SrcSpan]
rs', SrcSpan
_) ->
        String -> StateT Int IO ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> StateT Int IO ()) -> String -> StateT Int IO ()
forall a b. (a -> b) -> a -> b
$ String
"Ignoring " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Refactoring SrcSpan] -> String
forall a. Show a => a -> String
show [Refactoring SrcSpan]
rs' String -> String -> String
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 [] = ParsedSource -> StateT Int IO ParsedSource
forall a. a -> StateT Int IO a
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 <- StateT Int IO Int
forall (m :: * -> *) s. Monad m => StateT s m s
get
  ParsedSource
m <- (ParsedSource -> Refactoring SrcSpan -> StateT Int IO ParsedSource)
-> ParsedSource
-> [Refactoring SrcSpan]
-> StateT Int IO ParsedSource
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ParsedSource -> Refactoring SrcSpan -> StateT Int IO ParsedSource
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
      Int -> StateT Int IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Int
seed
      Bool -> StateT Int IO () -> StateT Int IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Normal) (StateT Int IO () -> StateT Int IO ())
-> (String -> StateT Int IO ()) -> String -> StateT Int IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StateT Int IO ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> StateT Int IO ()) -> String -> StateT Int IO ()
forall a b. (a -> b) -> a -> b
$
        String
"Ignoring " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Refactoring SrcSpan] -> String
forall a. Show a => a -> String
show [Refactoring SrcSpan]
rs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" since applying them would cause comments to be dropped."
      Maybe ParsedSource -> StateT Int IO (Maybe ParsedSource)
forall a. a -> StateT Int IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ParsedSource
forall a. Maybe a
Nothing
    else Maybe ParsedSource -> StateT Int IO (Maybe ParsedSource)
forall a. a -> StateT Int IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ParsedSource -> StateT Int IO (Maybe ParsedSource))
-> Maybe ParsedSource -> StateT Int IO (Maybe ParsedSource)
forall a b. (a -> b) -> a -> b
$ ParsedSource -> Maybe ParsedSource
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 Int -> Int -> Ordering
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 Int -> Int -> Bool
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 [] = ParsedSource -> MaybeT IO ParsedSource
forall a. a -> MaybeT IO a
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 <- IO (Maybe ParsedSource) -> MaybeT IO (Maybe ParsedSource)
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ParsedSource) -> MaybeT IO (Maybe ParsedSource))
-> (StateT Int IO (Maybe ParsedSource) -> IO (Maybe ParsedSource))
-> StateT Int IO (Maybe ParsedSource)
-> MaybeT IO (Maybe ParsedSource)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT Int IO (Maybe ParsedSource)
 -> Int -> IO (Maybe ParsedSource))
-> Int
-> StateT Int IO (Maybe ParsedSource)
-> IO (Maybe ParsedSource)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Int IO (Maybe ParsedSource)
-> Int -> IO (Maybe ParsedSource)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Int
0 (StateT Int IO (Maybe ParsedSource)
 -> MaybeT IO (Maybe ParsedSource))
-> StateT Int IO (Maybe ParsedSource)
-> MaybeT IO (Maybe ParsedSource)
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
          ParsedSource -> String
forall ast. ExactPrint ast => ast -> String
exactPrint ParsedSource
m String -> MaybeT IO () -> MaybeT IO ()
forall a b. a -> b -> b
`seq` () -> MaybeT IO ()
forall a. a -> MaybeT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          ParsedSource
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO ParsedSource
refactoringLoop ParsedSource
m ([((String, [Refactoring SrcSpan]), SrcSpan)]
 -> MaybeT IO ParsedSource)
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO ParsedSource
forall a b. (a -> b) -> a -> b
$ (((String, [Refactoring SrcSpan]), SrcSpan) -> Bool)
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (SrcSpan -> SrcSpan -> Bool
overlap SrcSpan
ss (SrcSpan -> Bool)
-> (((String, [Refactoring SrcSpan]), SrcSpan) -> SrcSpan)
-> ((String, [Refactoring SrcSpan]), SrcSpan)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [Refactoring SrcSpan]), SrcSpan) -> SrcSpan
forall a b. (a, b) -> b
snd) [((String, [Refactoring SrcSpan]), SrcSpan)]
rss
        Maybe ParsedSource
Nothing -> do
          IO () -> MaybeT IO ()
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT IO ()) -> IO () -> MaybeT IO ()
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" (ParsedSource -> MaybeT IO ParsedSource
forall a. a -> MaybeT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedSource
m0)),
          (String
"d", String -> MaybeT IO ParsedSource -> LoopOption
LoopOption String
"Discard previous changes" MaybeT IO ParsedSource
forall a. MaybeT IO a
forall (m :: * -> *) a. MonadPlus m => m a
mzero),
          ( String
"v",
            String -> MaybeT IO ParsedSource -> LoopOption
LoopOption
              String
"View current file"
              ( IO () -> MaybeT IO ()
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn (ParsedSource -> String
forall ast. ExactPrint ast => ast -> String
exactPrint ParsedSource
m0))
                  MaybeT IO () -> MaybeT IO ParsedSource -> MaybeT IO ParsedSource
forall a b. MaybeT IO a -> MaybeT IO b -> MaybeT IO b
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
        IO () -> MaybeT IO ()
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT IO ())
-> ([(String, LoopOption)] -> IO ())
-> [(String, LoopOption)]
-> MaybeT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ())
-> ([(String, LoopOption)] -> String)
-> [(String, LoopOption)]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> ([(String, LoopOption)] -> [String])
-> [(String, LoopOption)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, LoopOption) -> String)
-> [(String, LoopOption)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, LoopOption) -> String
mkLine ([(String, LoopOption)] -> MaybeT IO ())
-> [(String, LoopOption)] -> MaybeT IO ()
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LoopOption -> String
desc LoopOption
opt
  String
inp <- IO String -> MaybeT IO String
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> MaybeT IO String) -> IO String -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
putStrLn String
hintDesc
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Apply hint [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (((String, LoopOption) -> String)
-> [(String, LoopOption)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, LoopOption) -> String
forall a b. (a, b) -> a
fst [(String, LoopOption)]
opts) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
    -- In case that the input also comes from stdin
    String -> IOMode -> (Handle -> IO String) -> IO String
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
"/dev/tty" IOMode
ReadMode Handle -> IO String
hGetLine
  MaybeT IO ParsedSource
-> (LoopOption -> MaybeT IO ParsedSource)
-> Maybe LoopOption
-> MaybeT IO ParsedSource
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MaybeT IO ParsedSource
loopHelp LoopOption -> MaybeT IO ParsedSource
perform (String -> [(String, LoopOption)] -> Maybe LoopOption
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
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
/= :: Verbosity -> Verbosity -> Bool
Eq, Int -> Verbosity -> String -> String
[Verbosity] -> String -> String
Verbosity -> String
(Int -> Verbosity -> String -> String)
-> (Verbosity -> String)
-> ([Verbosity] -> String -> String)
-> Show Verbosity
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Verbosity -> String -> String
showsPrec :: Int -> Verbosity -> String -> String
$cshow :: Verbosity -> String
show :: Verbosity -> String
$cshowList :: [Verbosity] -> String -> String
showList :: [Verbosity] -> String -> String
Show, Eq Verbosity
Eq Verbosity =>
(Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord 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
$ccompare :: Verbosity -> Verbosity -> Ordering
compare :: Verbosity -> Verbosity -> Ordering
$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
>= :: Verbosity -> Verbosity -> Bool
$cmax :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
min :: Verbosity -> Verbosity -> Verbosity
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 <- StateT Int IO Int
forall (m :: * -> *) s. Monad m => StateT s m s
get StateT Int IO Int -> StateT Int IO () -> StateT Int IO Int
forall a b. StateT Int IO a -> StateT Int IO b -> StateT Int IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Int -> Int) -> StateT Int IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    IO a -> StateT Int IO a
forall a. IO a -> StateT Int IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> StateT Int IO a) -> IO a -> StateT Int IO a
forall a b. (a -> b) -> a -> b
$ case Refactoring SrcSpan -> RType
forall a. Refactoring a -> RType
rtype Refactoring SrcSpan
r of
      RType
Expr -> a
-> Parser (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Int
-> Refactoring SrcSpan
-> IO a
forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LHsExpr GhcPs)
Parser (GenLocated SrcSpanAnnA (HsExpr GhcPs))
parseExpr Int
seed Refactoring SrcSpan
r
      RType
Decl -> a
-> Parser (LocatedA (HsDecl GhcPs))
-> Int
-> Refactoring SrcSpan
-> IO a
forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LHsDecl GhcPs)
Parser (LocatedA (HsDecl GhcPs))
parseDecl Int
seed Refactoring SrcSpan
r
      RType
Type -> a
-> Parser (LocatedA (HsType GhcPs))
-> Int
-> Refactoring SrcSpan
-> IO a
forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LHsType GhcPs)
Parser (LocatedA (HsType GhcPs))
parseType Int
seed Refactoring SrcSpan
r
      RType
Pattern -> a
-> Parser (LocatedA (Pat GhcPs))
-> Int
-> Refactoring SrcSpan
-> IO a
forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LPat GhcPs)
Parser (LocatedA (Pat GhcPs))
parsePattern Int
seed Refactoring SrcSpan
r
      RType
Stmt -> a
-> Parser
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Int
-> Refactoring SrcSpan
-> IO a
forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (ExprLStmt GhcPs)
Parser
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
parseStmt Int
seed Refactoring SrcSpan
r
      RType
Bind -> a
-> Parser (LocatedA (HsBindLR GhcPs GhcPs))
-> Int
-> Refactoring SrcSpan
-> IO a
forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LHsBind GhcPs)
Parser (LocatedA (HsBindLR GhcPs GhcPs))
parseBind Int
seed Refactoring SrcSpan
r
      RType
R.Match -> a
-> Parser
     (LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Int
-> Refactoring SrcSpan
-> IO a
forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LMatch GhcPs (LHsExpr GhcPs))
Parser
  (LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
parseMatch Int
seed Refactoring SrcSpan
r
      RType
ModuleName -> a
-> Parser (LocatedA ModuleName)
-> Int
-> Refactoring SrcSpan
-> IO a
forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m (SrcSpan -> Parser (LocatedA ModuleName)
parseModuleName (Refactoring SrcSpan -> SrcSpan
forall a. Refactoring a -> a
pos Refactoring SrcSpan
r)) Int
seed Refactoring SrcSpan
r
      RType
Import -> a
-> Parser (LocatedA (ImportDecl GhcPs))
-> Int
-> Refactoring SrcSpan
-> IO a
forall a mod. ExactPrint a => ReplaceWorker a mod
replaceWorker a
m Parser (LImportDecl GhcPs)
Parser (LocatedA (ImportDecl GhcPs))
parseImport Int
seed Refactoring SrcSpan
r
  ModifyComment {String
SrcSpan
pos :: forall a. Refactoring a -> a
pos :: SrcSpan
newComment :: String
newComment :: forall a. Refactoring a -> String
..} -> a -> StateT Int IO a
forall a. a -> StateT Int IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan -> String -> a -> a
forall a. Data a => SrcSpan -> String -> a -> a
modifyComment SrcSpan
pos String
newComment a
m)
  Delete {RType
rtype :: forall a. Refactoring a -> RType
rtype :: RType
rtype, SrcSpan
pos :: forall a. Refactoring a -> a
pos :: SrcSpan
pos} -> a -> StateT Int IO a
forall a. a -> StateT Int IO a
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 -> (ExprLStmt GhcPs -> Bool) -> a -> a
forall a. Data a => (ExprLStmt GhcPs -> Bool) -> a -> a
doDeleteStmt ((AnnSpan -> AnnSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= AnnSpan
annSpan) (AnnSpan -> Bool)
-> (GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> AnnSpan)
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> AnnSpan
forall an a. LocatedAn an a -> AnnSpan
getAnnSpanA)
        RType
Import -> (LImportDecl GhcPs -> Bool) -> a -> a
forall a. Data a => (LImportDecl GhcPs -> Bool) -> a -> a
doDeleteImport ((AnnSpan -> AnnSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= AnnSpan
annSpan) (AnnSpan -> Bool)
-> (LocatedA (ImportDecl GhcPs) -> AnnSpan)
-> LocatedA (ImportDecl GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedA (ImportDecl GhcPs) -> AnnSpan
forall an a. LocatedAn an a -> AnnSpan
getAnnSpanA)
        RType
_ -> a -> a
forall a. a -> a
id
  InsertComment {String
SrcSpan
pos :: forall a. Refactoring a -> a
newComment :: forall a. Refactoring a -> String
pos :: SrcSpan
newComment :: String
..} -> a -> StateT Int IO a
forall a. a -> StateT Int IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> a
addComment a
m)
    where
      addComment :: a -> a
addComment = (LocatedA (HsDecl GhcPs) -> LocatedA (HsDecl GhcPs)) -> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi LHsDecl GhcPs -> LHsDecl GhcPs
LocatedA (HsDecl GhcPs) -> LocatedA (HsDecl 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 (SrcSpan -> AnnSpan) -> SrcSpan -> AnnSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
l) (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== AnnSpan -> (Int, Int)
ss2pos AnnSpan
r
          then
            let dp :: DeltaPos
dp = case LocatedA (HsDecl GhcPs) -> DeltaPos
forall t a. LocatedAn t a -> DeltaPos
getEntryDP LHsDecl GhcPs
LocatedA (HsDecl 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') = LocatedA (HsDecl GhcPs) -> DeltaPos -> LocatedA (HsDecl GhcPs)
forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP (SrcSpanAnnA -> HsDecl GhcPs -> LocatedA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l HsDecl GhcPs
d) (Int -> Int -> DeltaPos
GHC.DifferentLine Int
1 Int
0)
#if MIN_VERSION_ghc(9,12,0)
                comment =
                  GHC.L
                    (GHC.EpaDelta (GHC.RealSrcSpan r Strict.Nothing) dp GHC.NoComments)
                    (GHC.EpaComment (GHC.EpaLineComment newComment) r)
                l'' = GHC.addCommentsToEpAnn l' (GHC.EpaComments [comment])
#else
                comment :: GenLocated Anchor EpaComment
comment =
                  Anchor -> EpaComment -> GenLocated Anchor EpaComment
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'' = SrcSpanAnnA -> EpAnnComments -> SrcSpanAnnA
forall ann. Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann
GHC.addCommentsToSrcAnn SrcSpanAnnA
l' ([GenLocated Anchor EpaComment] -> EpAnnComments
GHC.EpaComments [GenLocated Anchor EpaComment
comment])
#endif
             in SrcSpanAnnA -> HsDecl GhcPs -> LocatedA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l'' HsDecl GhcPs
d'
          else LHsDecl GhcPs
old
  RemoveAsKeyword {SrcSpan
pos :: forall a. Refactoring a -> a
pos :: SrcSpan
..} -> a -> StateT Int IO a
forall a. a -> StateT Int IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> a
removeAsKeyword a
m)
    where
      removeAsKeyword :: a -> a
removeAsKeyword = (LocatedA (ImportDecl GhcPs) -> LocatedA (ImportDecl GhcPs))
-> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi LImportDecl GhcPs -> LImportDecl GhcPs
LocatedA (ImportDecl GhcPs) -> LocatedA (ImportDecl 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 (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
l) AnnSpan -> AnnSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan -> AnnSpan
srcSpanToAnnSpan SrcSpan
pos = SrcSpanAnnA -> ImportDecl GhcPs -> LocatedA (ImportDecl GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l (ImportDecl GhcPs
i {GHC.ideclAs = 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 = (GenLocated Anchor EpaComment -> GenLocated Anchor EpaComment)
-> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi GenLocated Anchor EpaComment -> GenLocated Anchor EpaComment
go
  where

#if MIN_VERSION_ghc(9,12,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
#else
#if MIN_VERSION_ghc(9,4,0)
    newTok :: GHC.EpaCommentTok -> GHC.EpaCommentTok
    newTok :: EpaCommentTok -> EpaCommentTok
newTok (GHC.EpaDocComment HsDocString
_) = HsDocString -> EpaCommentTok
GHC.EpaDocComment (HsDocString -> EpaCommentTok) -> HsDocString -> EpaCommentTok
forall a b. (a -> b) -> a -> b
$ String -> HsDocString
mkGeneratedHsDocString 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
#else
    newTok (GHC.EpaDocCommentNext _) = GHC.EpaDocCommentNext newComment
    newTok (GHC.EpaDocCommentPrev _) = GHC.EpaDocCommentPrev newComment
    newTok (GHC.EpaDocCommentNamed _) = GHC.EpaDocCommentNamed newComment
    newTok (GHC.EpaDocSection i _) = GHC.EpaDocSection i newComment
    newTok (GHC.EpaDocOptions _) = GHC.EpaDocOptions newComment
    newTok (GHC.EpaLineComment _) = GHC.EpaLineComment newComment
    newTok (GHC.EpaBlockComment _) = GHC.EpaBlockComment newComment
    newTok GHC.EpaEofComment = GHC.EpaEofComment
#endif
#endif

    go :: GHC.LEpaComment -> GHC.LEpaComment
    go :: GenLocated Anchor EpaComment -> GenLocated Anchor EpaComment
go old :: GenLocated Anchor EpaComment
old@(GHC.L Anchor
anc (GHC.EpaComment EpaCommentTok
t AnnSpan
r)) =
      if AnnSpan -> (Int, Int)
ss2pos (SrcSpan -> AnnSpan
GHC.realSrcSpan (SrcSpan -> AnnSpan) -> SrcSpan -> AnnSpan
forall a b. (a -> b) -> a -> b
$ GenLocated Anchor EpaComment -> SrcSpan
commentSrcSpan GenLocated Anchor EpaComment
old) (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== AnnSpan -> (Int, Int)
ss2pos (SrcSpan -> AnnSpan
GHC.realSrcSpan SrcSpan
pos)
        then Anchor -> EpaComment -> GenLocated Anchor EpaComment
forall l e. l -> e -> GenLocated l e
GHC.L Anchor
anc (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 ((EpaComment -> Bool) -> [EpaComment] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (EpaComment -> [EpaComment] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EpaComment]
current_comments) [EpaComment]
orig_comments)
  where
    mcs :: ParsedSource
mcs = (ParsedSource -> Refactoring SrcSpan -> ParsedSource)
-> ParsedSource -> [Refactoring SrcSpan] -> ParsedSource
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ParsedSource -> Refactoring SrcSpan -> ParsedSource
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) = SrcSpan -> String -> a -> a
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 = (EpaComment -> Bool) -> GenericQ [EpaComment]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (Bool
False Bool -> (EpaComment -> Bool) -> EpaComment -> Bool
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 = ParsedSource -> [EpaComment]
forall r. (Data r, Typeable r) => r -> [EpaComment]
all_comments ParsedSource
mcs
    current_comments :: [EpaComment]
current_comments = ParsedSource -> [EpaComment]
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)) -> LocatedA (HsBindLR GhcPs GhcPs)
-> Either ErrorMessages (LocatedA (HsBindLR GhcPs GhcPs))
forall a b. b -> Either a b
Right (SrcSpanAnnA
-> HsBindLR GhcPs GhcPs -> LocatedA (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l HsBindLR GhcPs GhcPs
b)
    Right (GHC.L SrcSpanAnnA
l HsDecl GhcPs
_) -> ErrorMessages
-> Either ErrorMessages (LocatedA (HsBindLR GhcPs GhcPs))
forall a b. a -> Either a b
Left (DynFlags -> SrcSpan -> String -> ErrorMessages
mkErr DynFlags
dyn (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
l) String
"Not a HsBind")
    Left ErrorMessages
e -> ErrorMessages
-> Either ErrorMessages (LocatedA (HsBindLR GhcPs GhcPs))
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 :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches}) ->
      case GenLocated
  (Anno
     [GenLocated
        (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
        (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
  [GenLocated
     (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
     (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
      (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. GenLocated l e -> e
GHC.unLoc (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> XRec
     GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall p body. MatchGroup p body -> XRec p [LMatch p body]
GHC.mg_alts MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fun_matches) of
        [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)))
-> Either
     ErrorMessages
     (GenLocated
        (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
        (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
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)))]
_ -> ErrorMessages
-> Either
     ErrorMessages
     (LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. a -> Either a b
Left (DynFlags -> SrcSpan -> String -> ErrorMessages
mkErr DynFlags
dyn (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
l) String
"Not a single match")
    Right (GHC.L SrcSpanAnnA
l HsBindLR GhcPs GhcPs
_) -> ErrorMessages
-> Either
     ErrorMessages
     (LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. a -> Either a b
Left (DynFlags -> SrcSpan -> String -> ErrorMessages
mkErr DynFlags
dyn (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA SrcSpanAnnA
l) String
"Not a funbind")
    Left ErrorMessages
e -> ErrorMessages
-> Either
     ErrorMessages
     (LocatedA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
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 =
  GenericM (StateT () IO) -> GenericM (StateT () IO)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM
    ( (LocatedA (HsType GhcPs) -> StateT () IO (LocatedA (HsType GhcPs)))
-> a -> StateT () IO a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM (b -> [(String, SrcSpan)] -> LHsType GhcPs -> M (LHsType GhcPs)
forall a.
Data a =>
a -> [(String, SrcSpan)] -> LHsType GhcPs -> M (LHsType GhcPs)
typeSub b
m [(String, SrcSpan)]
ss)
        (a -> StateT () IO a)
-> (FunBind -> StateT () IO FunBind) -> a -> StateT () IO a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` b -> [(String, SrcSpan)] -> FunBind -> StateT () IO FunBind
forall a.
Data a =>
a -> [(String, SrcSpan)] -> FunBind -> StateT () IO FunBind
identSub b
m [(String, SrcSpan)]
ss
        (a -> StateT () IO a)
-> (LocatedA (Pat GhcPs) -> StateT () IO (LocatedA (Pat GhcPs)))
-> a
-> StateT () IO a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` b -> [(String, SrcSpan)] -> LPat GhcPs -> M (LPat GhcPs)
forall a.
Data a =>
a -> [(String, SrcSpan)] -> LPat GhcPs -> M (LPat GhcPs)
patSub b
m [(String, SrcSpan)]
ss
        (a -> StateT () IO a)
-> (GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> StateT
         ()
         IO
         (GenLocated
            SrcSpanAnnA
            (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> a
-> StateT () IO a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` b -> [(String, SrcSpan)] -> ExprLStmt GhcPs -> M (ExprLStmt GhcPs)
forall a.
Data a =>
a -> [(String, SrcSpan)] -> ExprLStmt GhcPs -> M (ExprLStmt GhcPs)
stmtSub b
m [(String, SrcSpan)]
ss
        (a -> StateT () IO a)
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> StateT () IO (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> a
-> StateT () IO a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` b -> [(String, SrcSpan)] -> LHsExpr GhcPs -> M (LHsExpr GhcPs)
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
_)) =
  a
-> (AnnSpan
    -> StateT
         ()
         IO
         (GenLocated
            SrcSpanAnnA
            (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [(String, SrcSpan)]
-> RdrName
-> StateT
     ()
     IO
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall old a an.
(Data old, Data a, Data an, Typeable an, AnnConstraint an) =>
a
-> (AnnSpan -> M (LocatedAn an old))
-> LocatedAn an old
-> [(String, SrcSpan)]
-> RdrName
-> M (LocatedAn an old)
resolveRdrName a
m (a
-> AnnSpan
-> StateT
     ()
     IO
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a an modu (m :: * -> *).
(Typeable an, Data a, Data modu, MonadIO m) =>
modu -> AnnSpan -> m (LocatedAn an a)
findOrError a
m) ExprLStmt GhcPs
GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
old [(String, SrcSpan)]
subs RdrName
name
stmtSub a
_ [(String, SrcSpan)]
_ ExprLStmt GhcPs
e = GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> StateT
     ()
     IO
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a. a -> StateT () IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExprLStmt GhcPs
GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr 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))) =
  a
-> (AnnSpan -> StateT () IO (LocatedA (Pat GhcPs)))
-> LocatedA (Pat GhcPs)
-> [(String, SrcSpan)]
-> RdrName
-> StateT () IO (LocatedA (Pat GhcPs))
forall old a an.
(Data old, Data a, Data an, Typeable an, AnnConstraint an) =>
a
-> (AnnSpan -> M (LocatedAn an old))
-> LocatedAn an old
-> [(String, SrcSpan)]
-> RdrName
-> M (LocatedAn an old)
resolveRdrName a
m (a -> AnnSpan -> StateT () IO (LocatedA (Pat GhcPs))
forall a an modu (m :: * -> *).
(Typeable an, Data a, Data modu, MonadIO m) =>
modu -> AnnSpan -> m (LocatedAn an a)
findOrError a
m) LPat GhcPs
LocatedA (Pat GhcPs)
old [(String, SrcSpan)]
subs RdrName
name
patSub a
_ [(String, SrcSpan)]
_ LPat GhcPs
e = LocatedA (Pat GhcPs) -> StateT () IO (LocatedA (Pat GhcPs))
forall a. a -> StateT () IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LPat GhcPs
LocatedA (Pat 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))) =
  a
-> (AnnSpan -> StateT () IO (LocatedA (HsType GhcPs)))
-> LocatedA (HsType GhcPs)
-> [(String, SrcSpan)]
-> RdrName
-> StateT () IO (LocatedA (HsType GhcPs))
forall old a an.
(Data old, Data a, Data an, Typeable an, AnnConstraint an) =>
a
-> (AnnSpan -> M (LocatedAn an old))
-> LocatedAn an old
-> [(String, SrcSpan)]
-> RdrName
-> M (LocatedAn an old)
resolveRdrName a
m (a -> AnnSpan -> StateT () IO (LocatedA (HsType GhcPs))
forall a an modu (m :: * -> *).
(Typeable an, Data a, Data modu, MonadIO m) =>
modu -> AnnSpan -> m (LocatedAn an a)
findOrError a
m) LHsType GhcPs
LocatedA (HsType GhcPs)
old [(String, SrcSpan)]
subs RdrName
name
typeSub a
_ [(String, SrcSpan)]
_ LHsType GhcPs
e = LocatedA (HsType GhcPs) -> StateT () IO (LocatedA (HsType GhcPs))
forall a. a -> StateT () IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
LocatedA (HsType 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))) =
  a
-> (AnnSpan
    -> StateT () IO (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [(String, SrcSpan)]
-> RdrName
-> StateT () IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall old a an.
(Data old, Data a, Data an, Typeable an, AnnConstraint an) =>
a
-> (AnnSpan -> M (LocatedAn an old))
-> LocatedAn an old
-> [(String, SrcSpan)]
-> RdrName
-> M (LocatedAn an old)
resolveRdrName a
m (a
-> AnnSpan -> StateT () IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a an modu (m :: * -> *).
(Typeable an, Data a, Data modu, MonadIO m) =>
modu -> AnnSpan -> m (LocatedAn an a)
findOrError a
m) LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
old [(String, SrcSpan)]
subs RdrName
name
exprSub a
_ [(String, SrcSpan)]
_ LHsExpr GhcPs
e = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> StateT () IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> StateT () IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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
#if MIN_VERSION_ghc(9,12,0)
identSub m subs old@(GHC.FunRhs {mc_fun=name}) =
  resolveRdrName' subst (findOrError m) old subs (GHC.unLoc name)
  where
    subst :: FunBind -> Name -> M FunBind
    subst f@(GHC.FunRhs{}) 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)
      pure $ f {GHC.mc_fun=new}
    subst o _ = pure o
#else
identSub :: forall a.
Data a =>
a -> [(String, SrcSpan)] -> FunBind -> StateT () IO FunBind
identSub a
m [(String, SrcSpan)]
subs old :: FunBind
old@(GHC.FunRhs (GHC.L SrcSpanAnnN
_ RdrName
name) LexicalFixity
_ SrcStrictness
_) =
  (FunBind -> GenLocated SrcSpanAnnN RdrName -> StateT () IO FunBind)
-> (AnnSpan -> M (GenLocated SrcSpanAnnN RdrName))
-> FunBind
-> [(String, SrcSpan)]
-> RdrName
-> StateT () IO FunBind
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 -> StateT () IO FunBind
subst (a -> AnnSpan -> M (GenLocated SrcSpanAnnN RdrName)
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 -> StateT () IO FunBind
subst (GHC.FunRhs LIdP (NoGhcTc 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)
      FunBind -> StateT () IO FunBind
forall a. a -> StateT () IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FunBind -> StateT () IO FunBind)
-> FunBind -> StateT () IO FunBind
forall a b. (a -> b) -> a -> b
$ LIdP (NoGhcTc GhcPs) -> LexicalFixity -> SrcStrictness -> FunBind
forall p.
LIdP (NoGhcTc p)
-> LexicalFixity -> SrcStrictness -> HsMatchContext p
GHC.FunRhs LIdP (NoGhcTc GhcPs)
GenLocated SrcSpanAnnN RdrName
new LexicalFixity
b SrcStrictness
s
    subst FunBind
o GenLocated SrcSpanAnnN RdrName
_ = FunBind -> StateT () IO FunBind
forall a. a -> StateT () IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FunBind
o
#endif
identSub a
_ [(String, SrcSpan)]
_ FunBind
e = FunBind -> StateT () IO FunBind
forall a. a -> StateT () IO a
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 (OccName -> String) -> (OccName -> OccName) -> OccName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> OccName
forall name. HasOccName name => name -> OccName
occName -> String
oname)
      | Just SrcSpan
ss <- String -> [(String, SrcSpan)] -> Maybe SrcSpan
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) M (LocatedAn an b) -> (LocatedAn an b -> M a) -> M a
forall a b.
StateT () IO a -> (a -> StateT () IO b) -> StateT () IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> LocatedAn an b -> M a
g a
old
    RdrName
_ -> a -> M a
forall a. a -> StateT () IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
old

resolveRdrName ::
  (Data old, Data a, Data an, Typeable an, AnnConstraint 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, AnnConstraint an) =>
a
-> (AnnSpan -> M (LocatedAn an old))
-> LocatedAn an old
-> [(String, SrcSpan)]
-> RdrName
-> M (LocatedAn an old)
resolveRdrName a
m = (LocatedAn an old -> LocatedAn an old -> M (LocatedAn an old))
-> (AnnSpan -> M (LocatedAn an old))
-> LocatedAn an old
-> [(String, SrcSpan)]
-> RdrName
-> M (LocatedAn an old)
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 old -> LocatedAn an old -> M (LocatedAn an old)
forall mod t old new.
(Data mod, Data t, Data old, Data new, AnnConstraint t,
 Typeable t) =>
mod -> LocatedAn t old -> LocatedAn t new -> M (LocatedAn t new)
modifyAnnKey a
m)

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]
_) = Transform (LocatedA ast) -> (LocatedA ast, Int, [String])
forall a. Transform a -> (a, Int, [String])
runTransform (Transform (LocatedA ast) -> (LocatedA ast, Int, [String]))
-> Transform (LocatedA ast) -> (LocatedA ast, Int, [String])
forall a b. (a -> b) -> a -> b
$ LocatedA ast -> LocatedA ast -> Transform (LocatedA ast)
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
    Bool -> StateT Bool IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Bool
True
    LocatedA ast -> StateT Bool IO (LocatedA ast)
forall a. a -> StateT Bool IO a
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)
forall a b. (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 LHsDecl GhcPs
LocatedA ast
old,
    (RealSrcSpan' AnnSpan
newLocReal) <- LocatedA ast -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA LocatedA ast
new,
    LocatedA ast -> Bool
p (LocatedA ast -> LocatedA ast
forall a. a -> a
composeSrcSpan LHsDecl GhcPs
LocatedA ast
oldNoLocal) = do
    let newFile :: FastString
newFile = AnnSpan -> FastString
GHC.srcSpanFile AnnSpan
newLocReal
        newLocal :: GHC.HsLocalBinds GHC.GhcPs
        newLocal :: HsLocalBinds GhcPs
newLocal = (SrcSpan -> SrcSpan) -> HsLocalBinds GhcPs -> HsLocalBinds GhcPs
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (FastString -> SrcSpan -> SrcSpan
setSrcSpanFile FastString
newFile) HsLocalBinds GhcPs
oldLocal
        newLocalLoc :: SrcSpan
newLocalLoc = HsLocalBinds GhcPs -> SrcSpan
forall (p :: Pass). HsLocalBinds (GhcPass p) -> SrcSpan
GHC.spanHsLocaLBinds HsLocalBinds GhcPs
newLocal
        newMG :: GHC.MatchGroup GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)
        newMG :: MatchGroup GhcPs (LHsExpr GhcPs)
newMG = HsBindLR GhcPs GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs)
forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
GHC.fun_matches HsBindLR GhcPs GhcPs
newBind
        -- GHC.L locMG [GHC.L locMatch newMatch] = GHC.mg_alts newMG
        -- locMG1 :: GHC.SrcSpanAnnLW
        GHC.L SrcSpanAnnL
locMG1 [GHC.L SrcSpanAnnA
locMatch Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMatch] = MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> XRec
     GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall p body. MatchGroup p body -> XRec p [LMatch p body]
GHC.mg_alts MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMG
        -- xx :: GHC.SrcSpanAnnLW -> GHC.EpAnn (GHC.AnnList ())
        -- xx (GHC.EpAnn anc alw cs) = GHC.EpAnn anc (yy alw) cs
        -- yy :: GHC.AnnList (GHC.EpToken "where") -> GHC.AnnList ()
        -- yy (GHC.AnnList anc bs semis _ lt) = GHC.AnnList anc bs semis () lt
   -- = AnnList {
   --    al_anchor    :: !(Maybe EpaLocation), -- ^ start point of a list having layout
   --    al_brackets  :: !AnnListBrackets,
   --    al_semis     :: [EpToken ";"], -- decls
   --    al_rest      :: !a,
   --    al_trailing  :: ![TrailingAnn] -- ^ items appearing after the

        locMG :: SrcSpanAnnL
locMG = SrcSpanAnnL
locMG1
        newGRHSs :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newGRHSs = Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body. Match p body -> GRHSs p body
GHC.m_grhss Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMatch
        finalLoc :: SrcSpanAnnA
finalLoc = SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA
forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
GHC.noAnnSrcSpan SrcSpan
newLocalLoc) (LocatedA ast -> SrcSpanAnnA
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
            (SrcSpanAnnL -> SrcSpanAnnL -> SrcSpanAnnL
forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansLW (SrcSpan -> SrcSpanAnnL
forall ann. SrcSpan -> SrcAnn ann
GHC.noAnnSrcSpan SrcSpan
newLocalLoc) SrcSpanAnnL
locMG)
            Match GhcPs (LHsExpr GhcPs)
Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMatch
            (SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA
forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
GHC.noAnnSrcSpan SrcSpan
newLocalLoc) SrcSpanAnnA
locMatch)
            GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newGRHSs
        (LocatedA ast
newWithLocalBinds, Int
_, [String]
_) = Transform (LocatedA ast) -> (LocatedA ast, Int, [String])
forall a. Transform a -> (a, Int, [String])
runTransform (Transform (LocatedA ast) -> (LocatedA ast, Int, [String]))
-> Transform (LocatedA ast) -> (LocatedA ast, Int, [String])
forall a b. (a -> b) -> a -> b
$ LHsDecl GhcPs
-> LHsDecl GhcPs -> TransformT Identity (LHsDecl GhcPs)
forall (m :: * -> *).
Monad m =>
LHsDecl GhcPs -> LHsDecl GhcPs -> TransformT m (LHsDecl GhcPs)
transferEntryDP' LHsDecl GhcPs
LocatedA ast
old LHsDecl GhcPs
newWithLocalBinds0

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


#if MIN_VERSION_ghc(9,12,0)
combineSrcSpansLW :: GHC.SrcSpanAnnA -> GHC.SrcSpanAnnLW -> GHC.SrcSpanAnnLW
combineSrcSpansLW (GHC.EpAnn anca _ csa) (GHC.EpAnn ancb anb csb)
    = GHC.EpAnn (anca <> ancb) anb (csa <> csb)
#else
combineSrcSpansLW :: Semigroup a => GHC.SrcAnn a -> GHC.SrcAnn a -> GHC.SrcAnn a
combineSrcSpansLW :: forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansLW = SrcAnn a -> SrcAnn a -> SrcAnn a
forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA
#endif

-- | 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 = HsBindLR GhcPs GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs)
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] <- MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> XRec
     GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall p body. MatchGroup p body -> XRec p [LMatch p body]
GHC.mg_alts MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origMG,
      let origGRHSs :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origGRHSs = Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body. Match p body -> GRHSs p body
GHC.m_grhss Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origMatch,
#if MIN_VERSION_ghc(9,12,0)
      [GHC.L loc2 _] <- GHC.grhssGRHSs origGRHSs ->
#else
      [GHC.L SrcAnn NoEpAnns
_ (GHC.GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [ExprLStmt GhcPs]
_ (GHC.L SrcSpanAnnA
loc2 HsExpr GhcPs
_))] <- GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall p body. GRHSs p body -> [LGRHS p body]
GHC.grhssGRHSs GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origGRHSs ->
#endif
      let loc1 :: SrcSpanAnnN
loc1 = GenLocated SrcSpanAnnN RdrName -> SrcSpanAnnN
forall l e. GenLocated l e -> l
GHC.getLoc (HsBindLR GhcPs GhcPs -> LIdP GhcPs
forall idL idR. HsBindLR idL idR -> LIdP idL
GHC.fun_id HsBindLR GhcPs GhcPs
origBind)
          newLoc :: SrcSpanAnnA
newLoc = SrcSpanAnnA -> SrcSpanAnnA -> SrcSpanAnnA
forall a. Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
combineSrcSpansA (SrcSpanAnnN -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
GHC.l2l SrcSpanAnnN
loc1) (SrcSpanAnnA -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
GHC.l2l 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
              (XEmptyLocalBinds GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
GHC.EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
NoExtField
GHC.noExtField)
              XValD GhcPs
xvald
              HsBindLR GhcPs GhcPs
origBind
              SrcSpanAnnA
newLoc
              MatchGroup GhcPs (LHsExpr GhcPs)
origMG
              SrcSpanAnnL
locMG
              Match GhcPs (LHsExpr GhcPs)
Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origMatch
              SrcSpanAnnA
locMatch
              GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origGRHSs
       in (LocatedA (HsDecl GhcPs), HsLocalBinds GhcPs)
-> Maybe (LocatedA (HsDecl GhcPs), HsLocalBinds GhcPs)
forall a. a -> Maybe a
Just (LHsDecl GhcPs
LocatedA (HsDecl GhcPs)
withoutLocalBinds, GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsLocalBinds GhcPs
forall p body. GRHSs p body -> HsLocalBinds p
GHC.grhssLocalBinds GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
origGRHSs)
  LHsDecl GhcPs
_ -> Maybe (LHsDecl GhcPs, HsLocalBinds GhcPs)
Maybe (LocatedA (HsDecl GhcPs), HsLocalBinds 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 ->
#if MIN_VERSION_ghc(9,12,0)
  GHC.SrcSpanAnnLW ->
#else
  GHC.SrcSpanAnnL ->
#endif
  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 =
  SrcSpanAnnA -> HsDecl GhcPs -> LocatedA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
newLoc (XValD GhcPs -> HsBindLR GhcPs GhcPs -> HsDecl GhcPs
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 {GHC.grhssLocalBinds = newLocalBinds}
    newMatch :: Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMatch = Match GhcPs (LHsExpr GhcPs)
origMatch {GHC.m_grhss = newGRHSs}
    newMG :: MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
newMG = MatchGroup GhcPs (LHsExpr GhcPs)
origMG {GHC.mg_alts = GHC.L locMG [GHC.L locMatch newMatch]}
    newBind :: HsBindLR GhcPs GhcPs
newBind = HsBindLR GhcPs GhcPs
origBind {GHC.fun_matches = 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
pos :: forall a. Refactoring a -> a
rtype :: forall a. Refactoring a -> RType
rtype :: RType
pos :: SrcSpan
subts :: [(String, SrcSpan)]
orig :: String
subts :: forall a. Refactoring a -> [(String, a)]
orig :: forall a. Refactoring a -> String
..} = do
  let replExprLocation :: AnnSpan
replExprLocation = SrcSpan -> AnnSpan
srcSpanToAnnSpan SrcSpan
pos
      uniqueName :: String
uniqueName = String
"template" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
seed
  let libdir :: a
libdir = a
forall a. HasCallStack => a
undefined

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

  (LocatedA a
newExpr, ()) <-
    StateT () IO (LocatedA a) -> () -> IO (LocatedA a, ())
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
      -- (substTransform m subts template)
      (mod
-> [(String, SrcSpan)] -> LocatedA a -> StateT () IO (LocatedA a)
forall a b.
(Data a, Data b) =>
b -> [(String, SrcSpan)] -> a -> M a
substTransform mod
m [(String, SrcSpan)]
subts (LocatedA a -> LocatedA a
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 ((GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT LHsExpr GhcPs -> LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
ensureExprSpace)

      ensureExprSpace :: Expr -> Expr
      ensureExprSpace :: LHsExpr GhcPs -> LHsExpr GhcPs
ensureExprSpace e :: LHsExpr GhcPs
e@(GHC.L SrcSpanAnnA
l (GHC.HsDo XDo GhcPs
an HsDoFlavour
v (GHC.L SrcSpanAnnL
ls [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts))) = LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' -- ensureDoSpace
        where
          isDo :: Bool
isDo = case HsDoFlavour
v of
            HsDoFlavour
GHC.ListComp -> Bool
False
            HsDoFlavour
_ -> Bool
True
          e' :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' =
            if Bool
isDo
#if MIN_VERSION_ghc(9,12,0)
              && manchorOp ls == Just (GHC.SameLine 0)
#else
              Bool -> Bool -> Bool
&& EpAnn AnnList -> Maybe DeltaPos
forall ann. EpAnn ann -> Maybe DeltaPos
manchorOp XDo GhcPs
EpAnn AnnList
an Maybe DeltaPos -> Maybe DeltaPos -> Bool
forall a. Eq a => a -> a -> Bool
== DeltaPos -> Maybe DeltaPos
forall a. a -> Maybe a
Just (Int -> DeltaPos
GHC.SameLine Int
0)
              Bool -> Bool -> Bool
&& EpAnn AnnList -> Maybe DeltaPos
forall ann. EpAnn ann -> Maybe DeltaPos
manchorOp (SrcSpanAnnL -> EpAnn AnnList
forall a. SrcSpanAnn' a -> a
GHC.ann SrcSpanAnnL
ls) Maybe DeltaPos -> Maybe DeltaPos -> Bool
forall a. Eq a => a -> a -> Bool
== DeltaPos -> Maybe DeltaPos
forall a. a -> Maybe a
Just (Int -> DeltaPos
GHC.SameLine Int
0)
#endif
              then SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l (XDo GhcPs
-> HsDoFlavour -> XRec GhcPs [ExprLStmt GhcPs] -> HsExpr GhcPs
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
GHC.HsDo XDo GhcPs
an HsDoFlavour
v (LocatedL
  [GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> DeltaPos
-> LocatedL
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP (SrcSpanAnnL
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> LocatedL
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
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
GenLocated SrcSpanAnnA (HsExpr 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))) = LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' -- ensureAppSpace
        where
          e' :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' =
#if MIN_VERSION_ghc(9,12,0)
            if manchorOp lb == Just (GHC.SameLine 0)
#else
            if EpAnn AnnListItem -> Maybe DeltaPos
forall ann. EpAnn ann -> Maybe DeltaPos
manchorOp (SrcSpanAnnA -> EpAnn AnnListItem
forall a. SrcSpanAnn' a -> a
ann SrcSpanAnnA
lb) Maybe DeltaPos -> Maybe DeltaPos -> Bool
forall a. Eq a => a -> a -> Bool
== DeltaPos -> Maybe DeltaPos
forall a. a -> Maybe a
Just (Int -> DeltaPos
GHC.SameLine Int
0)
#endif
              then SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
GHC.HsApp XApp GhcPs
x (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
la HsExpr GhcPs
a) (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> DeltaPos -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
lb HsExpr GhcPs
b) (Int -> DeltaPos
GHC.SameLine Int
1)))
              else LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e
      ensureExprSpace LHsExpr GhcPs
e = LHsExpr GhcPs
e

      replacementPred :: LocatedA a -> Bool
replacementPred = (AnnSpan -> AnnSpan -> Bool
forall a. Eq a => a -> a -> Bool
== AnnSpan
replExprLocation) (AnnSpan -> Bool) -> (LocatedA a -> AnnSpan) -> LocatedA a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedA a -> AnnSpan
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 = mod
-> (LocatedA a -> Bool)
-> LocatedA a
-> LocatedA a
-> StateT Bool IO (LocatedA a)
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 = (LocatedA a -> StateT Bool IO (LocatedA a))
-> mod -> StateT Bool IO mod
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
  StateT Bool IO mod -> Bool -> IO (mod, Bool)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (mod -> StateT Bool IO mod
transformation mod
m) Bool
False IO (mod, Bool) -> ((mod, Bool) -> IO mod) -> IO mod
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (mod
finalM, Bool
True) ->
      mod -> IO mod
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (mod -> mod
forall t. Data t => t -> t
ensureSpace mod
finalM)
    -- Failed to find a replacment so don't make any changes
    (mod, Bool)
_ -> mod -> IO mod
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure mod
m
replaceWorker mod
m Parser (LocatedA a)
_ Int
_ Refactoring SrcSpan
_ = mod -> IO mod
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure mod
m

manchorOp :: GHC.EpAnn ann -> Maybe GHC.DeltaPos
#if MIN_VERSION_ghc(9,12,0)
manchorOp (GHC.EpAnn (GHC.EpaSpan{}) _ _) = Nothing
manchorOp (GHC.EpAnn (GHC.EpaDelta _ dp _) _ _) = Just dp
#else
manchorOp :: forall ann. EpAnn ann -> Maybe DeltaPos
manchorOp (GHC.EpAnn (GHC.Anchor AnnSpan
_ (GHC.MovedAnchor DeltaPos
dp)) ann
_ EpAnnComments
_) = DeltaPos -> Maybe DeltaPos
forall a. a -> Maybe a
Just DeltaPos
dp
manchorOp EpAnn ann
_ = Maybe DeltaPos
forall a. Maybe a
Nothing
#endif

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
nfExpected :: NotFound -> String
nfActual :: NotFound -> Maybe String
nfLoc :: NotFound -> AnnSpan
nfExpected :: String
nfActual :: Maybe String
nfLoc :: AnnSpan
..} =
  String
"Expected type not found at the location specified in the refact file.\n"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  Expected type: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nfExpected
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
actual -> String
"  Actual type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
actual String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") Maybe String
nfActual
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  Location: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ SDoc -> String
showSDocUnsafe (AnnSpan -> SDoc
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 modu -> Maybe (LocatedAn an a)
forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans modu
m of
  Just LocatedAn an a
a -> LocatedAn an a -> Either NotFound (LocatedAn an a)
forall a b. b -> Either a b
Right LocatedAn an a
a
  Maybe (LocatedAn an a)
Nothing ->
    let expected :: String
expected = TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
        actual :: Maybe String
actual =
          [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$
            [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes
              [ Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> Maybe String
forall an' b. Typeable b => Maybe (LocatedAn an' b) -> Maybe String
showType (modu -> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans modu
m :: Maybe Expr),
                Maybe (LocatedA (HsType GhcPs)) -> Maybe String
forall an' b. Typeable b => Maybe (LocatedAn an' b) -> Maybe String
showType (modu -> Maybe (LocatedA (HsType GhcPs))
forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans modu
m :: Maybe Type),
                Maybe (LocatedA (HsDecl GhcPs)) -> Maybe String
forall an' b. Typeable b => Maybe (LocatedAn an' b) -> Maybe String
showType (modu -> Maybe (LocatedA (HsDecl GhcPs))
forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans modu
m :: Maybe Decl),
                Maybe (LocatedA (Pat GhcPs)) -> Maybe String
forall an' b. Typeable b => Maybe (LocatedAn an' b) -> Maybe String
showType (modu -> Maybe (LocatedA (Pat GhcPs))
forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans modu
m :: Maybe Pat),
                Maybe (GenLocated SrcSpanAnnN RdrName) -> Maybe String
forall an' b. Typeable b => Maybe (LocatedAn an' b) -> Maybe String
showType (modu -> Maybe (GenLocated SrcSpanAnnN RdrName)
forall an' b.
(Typeable an', Data b) =>
modu -> Maybe (LocatedAn an' b)
doTrans modu
m :: Maybe Name)
              ]
     in NotFound -> Either NotFound (LocatedAn an a)
forall a b. a -> Either a b
Left (NotFound -> Either NotFound (LocatedAn an a))
-> NotFound -> Either NotFound (LocatedAn an a)
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 = GenericQ (Maybe (LocatedAn an' b))
-> GenericQ (Maybe (LocatedAn an' b))
forall u. GenericQ (Maybe u) -> GenericQ (Maybe u)
something (Maybe (LocatedAn an' b)
-> (LocatedAn an' b -> Maybe (LocatedAn an' b))
-> a
-> Maybe (LocatedAn an' b)
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Maybe (LocatedAn an' b)
forall a. Maybe a
Nothing (AnnSpan -> LocatedAn an' b -> Maybe (LocatedAn an' b)
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 = (LocatedAn an' b -> String)
-> Maybe (LocatedAn an' b) -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LocatedAn an' b -> String)
 -> Maybe (LocatedAn an' b) -> Maybe String)
-> (LocatedAn an' b -> String)
-> Maybe (LocatedAn an' b)
-> Maybe String
forall a b. (a -> b) -> a -> b
$ \LocatedAn an' b
_ -> TypeRep -> String
forall a. Show a => a -> String
show (Proxy b -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
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@(LocatedAn an a -> AnnSpan
forall an a. LocatedAn an a -> AnnSpan
getAnnSpanA -> AnnSpan
l) = if AnnSpan
l AnnSpan -> AnnSpan -> Bool
forall a. Eq a => a -> a -> Bool
== AnnSpan
as then LocatedAn an a -> Maybe (LocatedAn an a)
forall a. a -> Maybe a
Just LocatedAn an a
e else Maybe (LocatedAn an a)
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 = (NotFound -> m (LocatedAn an a))
-> (LocatedAn an a -> m (LocatedAn an a))
-> Either NotFound (LocatedAn an a)
-> m (LocatedAn an a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either NotFound -> m (LocatedAn an a)
forall {m :: * -> *} {a}. MonadIO m => NotFound -> m a
f LocatedAn an a -> m (LocatedAn an a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotFound (LocatedAn an a) -> m (LocatedAn an a))
-> (AnnSpan -> Either NotFound (LocatedAn an a))
-> AnnSpan
-> m (LocatedAn an a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. modu -> AnnSpan -> Either NotFound (LocatedAn an a)
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 = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (IOError -> IO a) -> IOError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO (IOError -> m a) -> IOError -> m a
forall a b. (a -> b) -> a -> b
$ IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
InappropriateType (NotFound -> String
renderNotFound NotFound
nf) Maybe Handle
forall a. Maybe a
Nothing Maybe String
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 = ([GenLocated
    SrcSpanAnnA
    (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> [GenLocated
       SrcSpanAnnA
       (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (([GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
  -> [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
 -> a -> a)
-> ((GenLocated
       SrcSpanAnnA
       (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
     -> Bool)
    -> [GenLocated
          SrcSpanAnnA
          (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
    -> [GenLocated
          SrcSpanAnnA
          (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> (GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> Bool)
-> a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> Bool)
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall t a.
Default t =>
(LocatedAn t a -> Bool) -> [LocatedAn t a] -> [LocatedAn t a]
filterAndSetDP

doDeleteImport :: Data a => (Import -> Bool) -> a -> a
doDeleteImport :: forall a. Data a => (LImportDecl GhcPs -> Bool) -> a -> a
doDeleteImport = ([LocatedA (ImportDecl GhcPs)] -> [LocatedA (ImportDecl GhcPs)])
-> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (([LocatedA (ImportDecl GhcPs)] -> [LocatedA (ImportDecl GhcPs)])
 -> a -> a)
-> ((LocatedA (ImportDecl GhcPs) -> Bool)
    -> [LocatedA (ImportDecl GhcPs)] -> [LocatedA (ImportDecl GhcPs)])
-> (LocatedA (ImportDecl GhcPs) -> Bool)
-> a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocatedA (ImportDecl GhcPs) -> Bool)
-> [LocatedA (ImportDecl GhcPs)] -> [LocatedA (ImportDecl GhcPs)]
forall t a.
Default t =>
(LocatedAn t a -> Bool) -> [LocatedAn t a] -> [LocatedAn t a]
filterAndSetDP

-- | Like `filter`, but after filtering one or multiple consecutive elements
-- out, it applies `setEntryDP` to the next element.
filterAndSetDP ::
  forall t a.
#if MIN_VERSION_ghc(9,10,0)
#else
  (Default t) =>
#endif
  (GHC.LocatedAn t a -> Bool) ->
  [GHC.LocatedAn t a] ->
  [GHC.LocatedAn t a]
filterAndSetDP :: forall t a.
Default t =>
(LocatedAn t a -> Bool) -> [LocatedAn t a] -> [LocatedAn t a]
filterAndSetDP LocatedAn t a -> Bool
p = [LocatedAn t a] -> [LocatedAn t a]
go
  where
    go :: [LocatedAn t a] -> [LocatedAn t a]
go [LocatedAn t a]
xs = case (LocatedAn t a -> Bool)
-> [LocatedAn t a] -> ([LocatedAn t a], [LocatedAn t a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break LocatedAn t a -> Bool
p [LocatedAn t a]
xs of
      ([LocatedAn t a]
_, []) -> []
      -- No prefix is filtered out; do not apply `setEntryDP` to `y`
      ([], LocatedAn t a
y : [LocatedAn t a]
ys) -> LocatedAn t a
y LocatedAn t a -> [LocatedAn t a] -> [LocatedAn t a]
forall a. a -> [a] -> [a]
: [LocatedAn t a] -> [LocatedAn t a]
go [LocatedAn t a]
ys
      -- Some prefix is filtered out; apply `setEntryDP` to `y`
      (LocatedAn t a
_ : [LocatedAn t a]
_, LocatedAn t a
y : [LocatedAn t a]
ys) -> LocatedAn t a -> DeltaPos -> LocatedAn t a
forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP LocatedAn t a
y (Int -> DeltaPos
GHC.SameLine Int
0) LocatedAn t a -> [LocatedAn t a] -> [LocatedAn t a]
forall a. a -> [a] -> [a]
: [LocatedAn t a] -> [LocatedAn t a]
go [LocatedAn t a]
ys

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 = IO (Either String DynFlags) -> IO (Either String DynFlags)
forall {b}. IO (Either String b) -> IO (Either String b)
catchErrors (IO (Either String DynFlags) -> IO (Either String DynFlags))
-> IO (Either String DynFlags) -> IO (Either String DynFlags)
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 (Messages PsMessage
_, [Located String]
opts) = ParserOpts
-> StringBuffer -> String -> (Messages PsMessage, [Located String])
getOptions (DynFlags -> ParserOpts
initParserOpts DynFlags
flags) StringBuffer
buf String
fp
#else
  let opts = getOptions flags buf fp
#endif
      withExts :: DynFlags
withExts =
        (DynFlags -> [Extension] -> DynFlags)
-> [Extension] -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
xopt_unset) [Extension]
ds
          (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> [Extension] -> DynFlags)
-> [Extension] -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
xopt_set) [Extension]
es
          (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
flags
  (DynFlags
withPragmas, [Located String]
_, [Warn]
_) <- DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
withExts [Located String]
opts
  Either String DynFlags -> IO (Either String DynFlags)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String DynFlags -> IO (Either String DynFlags))
-> (DynFlags -> Either String DynFlags)
-> DynFlags
-> IO (Either String DynFlags)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> Either String DynFlags
forall a b. b -> Either a b
Right (DynFlags -> IO (Either String DynFlags))
-> DynFlags -> IO (Either String DynFlags)
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 =
      (GhcException -> IO (Either String b))
-> IO (Either String b) -> IO (Either String b)
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException (Either String b -> IO (Either String b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String b -> IO (Either String b))
-> (GhcException -> Either String b)
-> GhcException
-> IO (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b)
-> (GhcException -> String) -> GhcException -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcException -> String
forall a. Show a => a -> String
show)
        (IO (Either String b) -> IO (Either String b))
-> (IO (Either String b) -> IO (Either String b))
-> IO (Either String b)
-> IO (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceError -> IO (Either String b))
-> IO (Either String b) -> IO (Either String b)
forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
GHC.handleSourceError (Either String b -> IO (Either String b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String b -> IO (Either String b))
-> (SourceError -> Either String b)
-> SourceError
-> IO (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b)
-> (SourceError -> String) -> SourceError -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> String
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 = String
-> Ghc (Either ErrorMessages ParsedSource)
-> IO (Either ErrorMessages ParsedSource)
forall a. String -> Ghc a -> IO a
ghcWrapper String
libdir (Ghc (Either ErrorMessages ParsedSource)
 -> IO (Either ErrorMessages ParsedSource))
-> Ghc (Either ErrorMessages ParsedSource)
-> IO (Either ErrorMessages ParsedSource)
forall a b. (a -> b) -> a -> b
$ do
  DynFlags
initFlags <- String -> Ghc DynFlags
forall (m :: * -> *). GhcMonad m => String -> m DynFlags
initDynFlags String
fp
  Either String DynFlags
eflags <- IO (Either String DynFlags) -> Ghc (Either String DynFlags)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String DynFlags) -> Ghc (Either String DynFlags))
-> IO (Either String DynFlags) -> Ghc (Either String DynFlags)
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 -> Either ErrorMessages ParsedSource
-> Ghc (Either ErrorMessages ParsedSource)
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorMessages ParsedSource
 -> Ghc (Either ErrorMessages ParsedSource))
-> (ErrorMessages -> Either ErrorMessages ParsedSource)
-> ErrorMessages
-> Ghc (Either ErrorMessages ParsedSource)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessages -> Either ErrorMessages ParsedSource
forall a b. a -> Either a b
Left (ErrorMessages -> Ghc (Either ErrorMessages ParsedSource))
-> ErrorMessages -> Ghc (Either ErrorMessages ParsedSource)
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> String -> ErrorMessages
mkErr DynFlags
initFlags SrcSpan
GHC.noSrcSpan String
err
    Right DynFlags
flags -> do
      IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe DynFlags) -> Maybe DynFlags -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef' IORef (Maybe DynFlags)
dynFlagsRef (DynFlags -> Maybe DynFlags
forall a. a -> Maybe a
Just DynFlags
flags)
      Either
  ErrorMessages
  ([GenLocated Anchor EpaComment], DynFlags, ParsedSource)
res <- CppOptions
-> DynFlags
-> String
-> Ghc
     (Either
        ErrorMessages
        ([GenLocated Anchor EpaComment], DynFlags, ParsedSource))
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 Either
  ErrorMessages
  ([GenLocated Anchor EpaComment], DynFlags, ParsedSource)
-> Either ErrorMessages ParsedSource
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 -> Either ErrorMessages ParsedSource
-> Ghc (Either ErrorMessages ParsedSource)
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ErrorMessages -> Either ErrorMessages ParsedSource
forall a b. a -> Either a b
Left ErrorMessages
e)
        Right ParsedSource
ast -> Either ErrorMessages ParsedSource
-> Ghc (Either ErrorMessages ParsedSource)
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorMessages ParsedSource
 -> Ghc (Either ErrorMessages ParsedSource))
-> Either ErrorMessages ParsedSource
-> Ghc (Either ErrorMessages ParsedSource)
forall a b. (a -> b) -> a -> b
$ ParsedSource -> Either ErrorMessages ParsedSource
forall a b. b -> Either a b
Right (ParsedSource -> ParsedSource
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 (([Extension], [Extension], [String])
 -> ([Extension], [Extension], [String]))
-> ([String] -> ([Extension], [Extension], [String]))
-> [String]
-> ([Extension], [Extension], [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Extension], [Extension], [String])
 -> String -> ([Extension], [Extension], [String]))
-> ([Extension], [Extension], [String])
-> [String]
-> ([Extension], [Extension], [String])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Extension], [Extension], [String])
-> String -> ([Extension], [Extension], [String])
f ([Extension], [Extension], [String])
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 =
        (Extension -> [Extension] -> [Extension]
forall a. Eq a => a -> [a] -> [a]
delete Extension
ext [Extension]
ys, Extension
ext Extension -> [Extension] -> [Extension]
forall a. a -> [a] -> [a]
: Extension -> [Extension] -> [Extension]
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 Extension -> [Extension] -> [Extension]
forall a. a -> [a] -> [a]
: Extension -> [Extension] -> [Extension]
forall a. Eq a => a -> [a] -> [a]
delete Extension
ext [Extension]
ys, Extension -> [Extension] -> [Extension]
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 String -> [String] -> [String]
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 [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ [Extension]
impliedOn, [Extension]
ns [Extension] -> [Extension] -> [Extension]
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 Extension -> Extension -> Bool
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 Extension -> Extension -> Bool
forall a. Eq a => a -> a -> Bool
== Extension
ext]

readExtension :: String -> Maybe Extension
readExtension :: String -> Maybe Extension
readExtension String
s = FlagSpec Extension -> Extension
forall flag. FlagSpec flag -> flag
flagSpecFlag (FlagSpec Extension -> Extension)
-> Maybe (FlagSpec Extension) -> Maybe Extension
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FlagSpec Extension -> Bool)
-> [FlagSpec Extension] -> Maybe (FlagSpec Extension)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s) (String -> Bool)
-> (FlagSpec Extension -> String) -> FlagSpec Extension -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagSpec Extension -> String
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 = IO (IORef (Maybe DynFlags)) -> IORef (Maybe DynFlags)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Maybe DynFlags)) -> IORef (Maybe DynFlags))
-> IO (IORef (Maybe DynFlags)) -> IORef (Maybe DynFlags)
forall a b. (a -> b) -> a -> b
$ Maybe DynFlags -> IO (IORef (Maybe DynFlags))
forall a. a -> IO (IORef a)
newIORef Maybe DynFlags
forall a. Maybe a
Nothing
{-# NOINLINE dynFlagsRef #-}