{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Refact.Internal
( apply,
runRefactoring,
addExtensionsToFlags,
parseModuleWithArgs,
parseExtensions,
Verbosity (..),
rigidLayout,
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
import Data.Char (isAlphaNum)
import Data.Data
import Data.Foldable (foldlM, for_)
import Data.Functor.Identity (Identity (..))
import Data.Generics (everywhereM, extM, listify, mkM, mkQ, something)
import Data.Generics.Uniplate.Data (transformBi, transformBiM, universeBi)
import Data.IORef.Extra
import Data.List.Extra
import qualified Data.Map as Map
import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe)
import Data.Ord (comparing)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Tuple.Extra
import Debug.Trace
import qualified GHC
import GHC.IO.Exception (IOErrorType (..))
import GHC.LanguageExtensions.Type (Extension (..))
import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.Delta
import Language.Haskell.GHC.ExactPrint.Parsers
import Language.Haskell.GHC.ExactPrint.Print
import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcRn, GhcTc)
import Language.Haskell.GHC.ExactPrint.Utils hiding (rs)
import Refact.Compat
( DoGenReplacement,
Errors,
FlagSpec (..),
FunBind,
Module,
RdrName (..),
ReplaceWorker,
SrcSpanLess,
annSpanToSrcSpan,
badAnnSpan,
combineSrcSpans,
composeSrcSpan,
decomposeSrcSpan,
getOptions,
gopt_set,
handleGhcException,
impliedXFlags,
mkErr,
nameOccName,
occName,
occNameString,
onError,
parseDynamicFilePragma,
parseModuleName,
ppr,
rdrNameOcc,
setAnnSpanFile,
setSrcSpanFile,
showSDocUnsafe,
srcSpanToAnnSpan,
stringToStringBuffer,
xFlags,
xopt_set,
xopt_unset,
pattern RealSrcLoc',
pattern RealSrcSpan',
)
import Refact.Types hiding (SrcSpan)
import qualified Refact.Types as R
import Refact.Utils
( AnnKeyMap,
Decl,
Expr,
Import,
M,
Name,
Pat,
Stmt,
Type,
foldAnnKey,
getAnnSpan,
modifyAnnKey,
replaceAnnKey,
toGhcSrcSpan,
toGhcSrcSpan',
)
import System.IO.Error (mkIOError)
import System.IO.Extra
import System.IO.Unsafe (unsafePerformIO)
refactOptions :: PrintOptions Identity String
refactOptions :: PrintOptions Identity String
refactOptions = PrintOptions Identity String
stringOptions {epRigidity :: Rigidity
epRigidity = Rigidity
RigidLayout}
rigidLayout :: DeltaOptions
rigidLayout :: DeltaOptions
rigidLayout = Rigidity -> DeltaOptions
deltaOptions Rigidity
RigidLayout
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
-> Anns
-> Module
-> IO String
apply Maybe (Int, Int)
mpos Bool
step [(String, [Refactoring SrcSpan])]
inp Maybe String
mbfile Verbosity
verb Anns
as0 Module
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 Module -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc Module
m0 of
GHC.UnhelpfulSpan FastString
s -> String -> IO (SrcSpan -> SrcSpan)
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]
++ FastString -> String
forall a. Show a => a -> String
show FastString
s
RealSrcSpan' RealSrcSpan
s ->
(SrcSpan -> SrcSpan) -> IO (SrcSpan -> SrcSpan)
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' (RealSrcSpan -> FastString
GHC.srcSpanFile RealSrcSpan
s)
)
((SrcSpan -> SrcSpan) -> IO (SrcSpan -> SrcSpan)
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 (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)
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
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
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
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 (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 (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)
(Anns
as, Module
m) <-
if Bool
step
then (Anns, Module) -> Maybe (Anns, Module) -> (Anns, Module)
forall a. a -> Maybe a -> a
fromMaybe (Anns
as0, Module
m0) (Maybe (Anns, Module) -> (Anns, Module))
-> IO (Maybe (Anns, Module)) -> IO (Anns, Module)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT IO (Anns, Module) -> IO (Maybe (Anns, Module))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (Anns
-> Module
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO (Anns, Module)
refactoringLoop Anns
as0 Module
m0 [((String, [Refactoring SrcSpan]), SrcSpan)]
allRefacts)
else StateT Int IO (Anns, Module) -> Int -> IO (Anns, Module)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Verbosity
-> Anns
-> Module
-> [([Refactoring SrcSpan], SrcSpan)]
-> StateT Int IO (Anns, Module)
runRefactorings Verbosity
verb Anns
as0 Module
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
String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String)
-> (Identity String -> String) -> Identity String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity String -> String
forall a. Identity a -> a
runIdentity (Identity String -> IO String) -> Identity String -> IO String
forall a b. (a -> b) -> a -> b
$ PrintOptions Identity String -> Module -> Anns -> Identity String
forall ast b (m :: * -> *).
(Annotate ast, Monoid b, Monad m) =>
PrintOptions m b -> Located ast -> Anns -> m b
exactPrintWithOptions PrintOptions Identity String
refactOptions Module
m Anns
as
spans :: R.SrcSpan -> (Int, Int) -> Bool
spans :: SrcSpan -> (Int, Int) -> Bool
spans R.SrcSpan {Int
endCol :: Int
endLine :: Int
startCol :: Int
startLine :: Int
endCol :: SrcSpan -> Int
endLine :: SrcSpan -> Int
startCol :: SrcSpan -> Int
startLine :: SrcSpan -> Int
..} (Int, Int)
loc = (Int
startLine, Int
startCol) (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 (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 ->
Anns ->
Module ->
[([Refactoring GHC.SrcSpan], R.SrcSpan)] ->
StateT Int IO (Anns, Module)
runRefactorings :: Verbosity
-> Anns
-> Module
-> [([Refactoring SrcSpan], SrcSpan)]
-> StateT Int IO (Anns, Module)
runRefactorings Verbosity
verb Anns
as0 Module
m0 (([Refactoring SrcSpan]
rs, SrcSpan
ss) : [([Refactoring SrcSpan], SrcSpan)]
rest) = do
Verbosity
-> Anns
-> Module
-> [Refactoring SrcSpan]
-> StateT Int IO (Maybe (Anns, Module))
runRefactorings' Verbosity
verb Anns
as0 Module
m0 [Refactoring SrcSpan]
rs StateT Int IO (Maybe (Anns, Module))
-> (Maybe (Anns, Module) -> StateT Int IO (Anns, Module))
-> StateT Int IO (Anns, Module)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Anns, Module)
Nothing -> Verbosity
-> Anns
-> Module
-> [([Refactoring SrcSpan], SrcSpan)]
-> StateT Int IO (Anns, Module)
runRefactorings Verbosity
verb Anns
as0 Module
m0 [([Refactoring SrcSpan], SrcSpan)]
rest
Just (Anns
as, Module
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
-> Anns
-> Module
-> [([Refactoring SrcSpan], SrcSpan)]
-> StateT Int IO (Anns, Module)
runRefactorings Verbosity
verb Anns
as Module
m [([Refactoring SrcSpan], SrcSpan)]
rest'
runRefactorings Verbosity
_ Anns
as Module
m [] = (Anns, Module) -> StateT Int IO (Anns, Module)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
as, Module
m)
runRefactorings' ::
Verbosity ->
Anns ->
Module ->
[Refactoring GHC.SrcSpan] ->
StateT Int IO (Maybe (Anns, Module))
runRefactorings' :: Verbosity
-> Anns
-> Module
-> [Refactoring SrcSpan]
-> StateT Int IO (Maybe (Anns, Module))
runRefactorings' Verbosity
verb Anns
as0 Module
m0 [Refactoring SrcSpan]
rs = do
Int
seed <- StateT Int IO Int
forall (m :: * -> *) s. Monad m => StateT s m s
get
(Anns
as, Module
m, AnnKeyMap
keyMap) <- ((Anns, Module, AnnKeyMap)
-> Refactoring SrcSpan -> StateT Int IO (Anns, Module, AnnKeyMap))
-> (Anns, Module, AnnKeyMap)
-> [Refactoring SrcSpan]
-> StateT Int IO (Anns, Module, AnnKeyMap)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ((Anns
-> Module
-> AnnKeyMap
-> Refactoring SrcSpan
-> StateT Int IO (Anns, Module, AnnKeyMap))
-> (Anns, Module, AnnKeyMap)
-> Refactoring SrcSpan
-> StateT Int IO (Anns, Module, AnnKeyMap)
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 Anns
-> Module
-> AnnKeyMap
-> Refactoring SrcSpan
-> StateT Int IO (Anns, Module, AnnKeyMap)
forall a.
Data a =>
Anns
-> a
-> AnnKeyMap
-> Refactoring SrcSpan
-> StateT Int IO (Anns, a, AnnKeyMap)
runRefactoring) (Anns
as0, Module
m0, AnnKeyMap
forall k a. Map k a
Map.empty) [Refactoring SrcSpan]
rs
if Anns -> Module -> AnnKeyMap -> Bool
droppedComments Anns
as Module
m AnnKeyMap
keyMap
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 (Anns, Module) -> StateT Int IO (Maybe (Anns, Module))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Anns, Module)
forall a. Maybe a
Nothing
else Maybe (Anns, Module) -> StateT Int IO (Maybe (Anns, Module))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Anns, Module) -> StateT Int IO (Maybe (Anns, Module)))
-> Maybe (Anns, Module) -> StateT Int IO (Maybe (Anns, Module))
forall a b. (a -> b) -> a -> b
$ (Anns, Module) -> Maybe (Anns, Module)
forall a. a -> Maybe a
Just (Anns
as, Module
m)
overlap :: R.SrcSpan -> R.SrcSpan -> Bool
overlap :: SrcSpan -> SrcSpan -> Bool
overlap SrcSpan
s1 SrcSpan
s2 =
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,
LoopOption -> MaybeT IO (Anns, Module)
perform :: MaybeT IO (Anns, Module)
}
refactoringLoop ::
Anns ->
Module ->
[((String, [Refactoring GHC.SrcSpan]), R.SrcSpan)] ->
MaybeT IO (Anns, Module)
refactoringLoop :: Anns
-> Module
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO (Anns, Module)
refactoringLoop Anns
as Module
m [] = (Anns, Module) -> MaybeT IO (Anns, Module)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
as, Module
m)
refactoringLoop Anns
as Module
m (((String
_, []), SrcSpan
_) : [((String, [Refactoring SrcSpan]), SrcSpan)]
rs) = Anns
-> Module
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO (Anns, Module)
refactoringLoop Anns
as Module
m [((String, [Refactoring SrcSpan]), SrcSpan)]
rs
refactoringLoop Anns
as0 Module
m0 hints :: [((String, [Refactoring SrcSpan]), SrcSpan)]
hints@(((String
hintDesc, [Refactoring SrcSpan]
rs), SrcSpan
ss) : [((String, [Refactoring SrcSpan]), SrcSpan)]
rss) = do
Maybe (Anns, Module)
res <- IO (Maybe (Anns, Module)) -> MaybeT IO (Maybe (Anns, Module))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Anns, Module)) -> MaybeT IO (Maybe (Anns, Module)))
-> (StateT Int IO (Maybe (Anns, Module))
-> IO (Maybe (Anns, Module)))
-> StateT Int IO (Maybe (Anns, Module))
-> MaybeT IO (Maybe (Anns, Module))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT Int IO (Maybe (Anns, Module))
-> Int -> IO (Maybe (Anns, Module)))
-> Int
-> StateT Int IO (Maybe (Anns, Module))
-> IO (Maybe (Anns, Module))
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Int IO (Maybe (Anns, Module))
-> Int -> IO (Maybe (Anns, Module))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Int
0 (StateT Int IO (Maybe (Anns, Module))
-> MaybeT IO (Maybe (Anns, Module)))
-> StateT Int IO (Maybe (Anns, Module))
-> MaybeT IO (Maybe (Anns, Module))
forall a b. (a -> b) -> a -> b
$ Verbosity
-> Anns
-> Module
-> [Refactoring SrcSpan]
-> StateT Int IO (Maybe (Anns, Module))
runRefactorings' Verbosity
Silent Anns
as0 Module
m0 [Refactoring SrcSpan]
rs
let yAction :: MaybeT IO (Anns, Module)
yAction = case Maybe (Anns, Module)
res of
Just (Anns
as, Module
m) -> do
Module -> Anns -> String
forall ast. Annotate ast => Located ast -> Anns -> String
exactPrint Module
m Anns
as String -> MaybeT IO () -> MaybeT IO ()
`seq` () -> MaybeT IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Anns
-> Module
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO (Anns, Module)
refactoringLoop Anns
as Module
m ([((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO (Anns, Module))
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO (Anns, Module)
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 (Anns, Module)
Nothing -> do
IO () -> MaybeT IO ()
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"
Anns
-> Module
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO (Anns, Module)
refactoringLoop Anns
as0 Module
m0 [((String, [Refactoring SrcSpan]), SrcSpan)]
rss
opts :: [(String, LoopOption)]
opts =
[ (String
"y", String -> MaybeT IO (Anns, Module) -> LoopOption
LoopOption String
"Apply current hint" MaybeT IO (Anns, Module)
yAction),
(String
"n", String -> MaybeT IO (Anns, Module) -> LoopOption
LoopOption String
"Don't apply the current hint" (Anns
-> Module
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO (Anns, Module)
refactoringLoop Anns
as0 Module
m0 [((String, [Refactoring SrcSpan]), SrcSpan)]
rss)),
(String
"q", String -> MaybeT IO (Anns, Module) -> LoopOption
LoopOption String
"Apply no further hints" ((Anns, Module) -> MaybeT IO (Anns, Module)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
as0, Module
m0))),
(String
"d", String -> MaybeT IO (Anns, Module) -> LoopOption
LoopOption String
"Discard previous changes" MaybeT IO (Anns, Module)
forall (m :: * -> *) a. MonadPlus m => m a
mzero),
( String
"v",
String -> MaybeT IO (Anns, Module) -> LoopOption
LoopOption
String
"View current file"
( IO () -> MaybeT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn (Module -> Anns -> String
forall ast. Annotate ast => Located ast -> Anns -> String
exactPrint Module
m0 Anns
as0))
MaybeT IO ()
-> MaybeT IO (Anns, Module) -> MaybeT IO (Anns, Module)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Anns
-> Module
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO (Anns, Module)
refactoringLoop Anns
as0 Module
m0 [((String, [Refactoring SrcSpan]), SrcSpan)]
hints
)
),
(String
"?", String -> MaybeT IO (Anns, Module) -> LoopOption
LoopOption String
"Show this help menu" MaybeT IO (Anns, Module)
loopHelp)
]
loopHelp :: MaybeT IO (Anns, Module)
loopHelp = do
IO () -> MaybeT IO ()
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
Anns
-> Module
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> MaybeT IO (Anns, Module)
refactoringLoop Anns
as0 Module
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 (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
"]"
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 (Anns, Module)
-> (LoopOption -> MaybeT IO (Anns, Module))
-> Maybe LoopOption
-> MaybeT IO (Anns, Module)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MaybeT IO (Anns, Module)
loopHelp LoopOption -> MaybeT IO (Anns, Module)
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
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: 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
showList :: [Verbosity] -> String -> String
$cshowList :: [Verbosity] -> String -> String
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> String -> String
$cshowsPrec :: Int -> 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
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
$cp1Ord :: Eq Verbosity
Ord)
runRefactoring ::
Data a =>
Anns ->
a ->
AnnKeyMap ->
Refactoring GHC.SrcSpan ->
StateT Int IO (Anns, a, AnnKeyMap)
runRefactoring :: Anns
-> a
-> AnnKeyMap
-> Refactoring SrcSpan
-> StateT Int IO (Anns, a, AnnKeyMap)
runRefactoring Anns
as a
m AnnKeyMap
keyMap = \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 (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 (Anns, a, AnnKeyMap) -> StateT Int IO (Anns, a, AnnKeyMap)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Anns, a, AnnKeyMap) -> StateT Int IO (Anns, a, AnnKeyMap))
-> IO (Anns, a, AnnKeyMap) -> StateT Int IO (Anns, a, AnnKeyMap)
forall a b. (a -> b) -> a -> b
$ case Refactoring SrcSpan -> RType
forall a. Refactoring a -> RType
rtype Refactoring SrcSpan
r of
RType
Expr -> Anns
-> a
-> AnnKeyMap
-> Parser (LHsExpr GhcPs)
-> Int
-> Refactoring SrcSpan
-> IO (Anns, a, AnnKeyMap)
forall a mod. ReplaceWorker a mod
replaceWorker Anns
as a
m AnnKeyMap
keyMap Parser (LHsExpr GhcPs)
parseExpr Int
seed Refactoring SrcSpan
r
RType
Decl -> Anns
-> a
-> AnnKeyMap
-> Parser (LHsDecl GhcPs)
-> Int
-> Refactoring SrcSpan
-> IO (Anns, a, AnnKeyMap)
forall a mod. ReplaceWorker a mod
replaceWorker Anns
as a
m AnnKeyMap
keyMap Parser (LHsDecl GhcPs)
parseDecl Int
seed Refactoring SrcSpan
r
RType
Type -> Anns
-> a
-> AnnKeyMap
-> Parser (LHsType GhcPs)
-> Int
-> Refactoring SrcSpan
-> IO (Anns, a, AnnKeyMap)
forall a mod. ReplaceWorker a mod
replaceWorker Anns
as a
m AnnKeyMap
keyMap Parser (LHsType GhcPs)
parseType Int
seed Refactoring SrcSpan
r
RType
Pattern -> Anns
-> a
-> AnnKeyMap
-> Parser (Located (Pat GhcPs))
-> Int
-> Refactoring SrcSpan
-> IO (Anns, a, AnnKeyMap)
forall a mod. ReplaceWorker a mod
replaceWorker Anns
as a
m AnnKeyMap
keyMap Parser (LPat GhcPs)
Parser (Located (Pat GhcPs))
parsePattern Int
seed Refactoring SrcSpan
r
RType
Stmt -> Anns
-> a
-> AnnKeyMap
-> Parser (ExprLStmt GhcPs)
-> Int
-> Refactoring SrcSpan
-> IO (Anns, a, AnnKeyMap)
forall a mod. ReplaceWorker a mod
replaceWorker Anns
as a
m AnnKeyMap
keyMap Parser (ExprLStmt GhcPs)
parseStmt Int
seed Refactoring SrcSpan
r
RType
Bind -> Anns
-> a
-> AnnKeyMap
-> Parser (LHsBind GhcPs)
-> Int
-> Refactoring SrcSpan
-> IO (Anns, a, AnnKeyMap)
forall a mod. ReplaceWorker a mod
replaceWorker Anns
as a
m AnnKeyMap
keyMap Parser (LHsBind GhcPs)
parseBind Int
seed Refactoring SrcSpan
r
RType
R.Match -> Anns
-> a
-> AnnKeyMap
-> Parser (LMatch GhcPs (LHsExpr GhcPs))
-> Int
-> Refactoring SrcSpan
-> IO (Anns, a, AnnKeyMap)
forall a mod. ReplaceWorker a mod
replaceWorker Anns
as a
m AnnKeyMap
keyMap Parser (LMatch GhcPs (LHsExpr GhcPs))
parseMatch Int
seed Refactoring SrcSpan
r
RType
ModuleName -> Anns
-> a
-> AnnKeyMap
-> Parser (Located ModuleName)
-> Int
-> Refactoring SrcSpan
-> IO (Anns, a, AnnKeyMap)
forall a mod. ReplaceWorker a mod
replaceWorker Anns
as a
m AnnKeyMap
keyMap (SrcSpan -> Parser (Located ModuleName)
parseModuleName (Refactoring SrcSpan -> SrcSpan
forall a. Refactoring a -> a
pos Refactoring SrcSpan
r)) Int
seed Refactoring SrcSpan
r
RType
Import -> Anns
-> a
-> AnnKeyMap
-> Parser (LImportDecl GhcPs)
-> Int
-> Refactoring SrcSpan
-> IO (Anns, a, AnnKeyMap)
forall a mod. ReplaceWorker a mod
replaceWorker Anns
as a
m AnnKeyMap
keyMap Parser (LImportDecl GhcPs)
parseImport Int
seed Refactoring SrcSpan
r
ModifyComment {String
SrcSpan
newComment :: forall a. Refactoring a -> String
newComment :: String
pos :: SrcSpan
pos :: forall a. Refactoring a -> a
..} -> (Anns, a, AnnKeyMap) -> StateT Int IO (Anns, a, AnnKeyMap)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Annotation -> Annotation) -> Anns -> Anns
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Annotation -> Annotation
go Anns
as, a
m, AnnKeyMap
keyMap)
where
go :: Annotation -> Annotation
go a :: Annotation
a@Ann {[(Comment, DeltaPos)]
annPriorComments :: Annotation -> [(Comment, DeltaPos)]
annPriorComments :: [(Comment, DeltaPos)]
annPriorComments, [(KeywordId, DeltaPos)]
annsDP :: Annotation -> [(KeywordId, DeltaPos)]
annsDP :: [(KeywordId, DeltaPos)]
annsDP} =
Annotation
a
{ annsDP :: [(KeywordId, DeltaPos)]
annsDP = ((KeywordId, DeltaPos) -> (KeywordId, DeltaPos))
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a b. (a -> b) -> [a] -> [b]
map (KeywordId, DeltaPos) -> (KeywordId, DeltaPos)
changeComment [(KeywordId, DeltaPos)]
annsDP,
annPriorComments :: [(Comment, DeltaPos)]
annPriorComments = ((Comment, DeltaPos) -> (Comment, DeltaPos))
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a b. (a -> b) -> [a] -> [b]
map ((Comment -> Comment) -> (Comment, DeltaPos) -> (Comment, DeltaPos)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first Comment -> Comment
change) [(Comment, DeltaPos)]
annPriorComments
}
changeComment :: (KeywordId, DeltaPos) -> (KeywordId, DeltaPos)
changeComment (AnnComment Comment
d, DeltaPos
dp) = (Comment -> KeywordId
AnnComment (Comment -> Comment
change Comment
d), DeltaPos
dp)
changeComment (KeywordId, DeltaPos)
e = (KeywordId, DeltaPos)
e
change :: Comment -> Comment
change old :: Comment
old@Comment {String
Maybe AnnKeywordId
SrcSpan
commentContents :: Comment -> String
commentIdentifier :: Comment -> SrcSpan
commentOrigin :: Comment -> Maybe AnnKeywordId
commentOrigin :: Maybe AnnKeywordId
commentIdentifier :: SrcSpan
commentContents :: String
..} =
if SrcSpan -> (Int, Int)
ss2pos (SrcSpan -> SrcSpan
annSpanToSrcSpan SrcSpan
commentIdentifier) (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan -> (Int, Int)
ss2pos SrcSpan
pos
then Comment
old {commentContents :: String
commentContents = String
newComment}
else Comment
old
Delete {RType
rtype :: RType
rtype :: forall a. Refactoring a -> RType
rtype, SrcSpan
pos :: SrcSpan
pos :: forall a. Refactoring a -> a
pos} -> (Anns, a, AnnKeyMap) -> StateT Int IO (Anns, a, AnnKeyMap)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
as, a -> a
f a
m, AnnKeyMap
keyMap)
where
annSpan :: SrcSpan
annSpan = SrcSpan -> SrcSpan
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 ((SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcSpan
annSpan) (SrcSpan -> Bool)
-> (ExprLStmt GhcPs -> SrcSpan) -> ExprLStmt GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExprLStmt GhcPs -> SrcSpan
forall a. Located a -> SrcSpan
getAnnSpan)
RType
Import -> (LImportDecl GhcPs -> Bool) -> a -> a
forall a. Data a => (LImportDecl GhcPs -> Bool) -> a -> a
doDeleteImport ((SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcSpan
annSpan) (SrcSpan -> Bool)
-> (LImportDecl GhcPs -> SrcSpan) -> LImportDecl GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LImportDecl GhcPs -> SrcSpan
forall a. Located a -> SrcSpan
getAnnSpan)
RType
_ -> a -> a
forall a. a -> a
id
InsertComment {String
SrcSpan
newComment :: String
pos :: SrcSpan
newComment :: forall a. Refactoring a -> String
pos :: forall a. Refactoring a -> a
..} -> do
AnnKey
exprkey <- LHsDecl GhcPs -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey (LHsDecl GhcPs -> AnnKey)
-> StateT Int IO (LHsDecl GhcPs) -> StateT Int IO AnnKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> SrcSpan -> StateT Int IO (LHsDecl GhcPs)
forall a modu (m :: * -> *).
(Data a, Data modu, MonadIO m) =>
modu -> SrcSpan -> m (Located a)
findOrError @(GHC.HsDecl GHC.GhcPs) a
m (SrcSpan -> SrcSpan
srcSpanToAnnSpan SrcSpan
pos)
(Anns, a, AnnKeyMap) -> StateT Int IO (Anns, a, AnnKeyMap)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnKey -> String -> Anns -> Anns
insertComment AnnKey
exprkey String
newComment Anns
as, a
m, AnnKeyMap
keyMap)
RemoveAsKeyword {SrcSpan
pos :: SrcSpan
pos :: forall a. Refactoring a -> a
..} -> (Anns, a, AnnKeyMap) -> StateT Int IO (Anns, a, AnnKeyMap)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
as, a -> a
removeAsKeyword a
m, AnnKeyMap
keyMap)
where
removeAsKeyword :: a -> a
removeAsKeyword = (LImportDecl GhcPs -> LImportDecl GhcPs) -> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi LImportDecl GhcPs -> LImportDecl GhcPs
go
go :: GHC.LImportDecl GHC.GhcPs -> GHC.LImportDecl GHC.GhcPs
go :: LImportDecl GhcPs -> LImportDecl GhcPs
go imp :: LImportDecl GhcPs
imp@(GHC.L SrcSpan
l ImportDecl GhcPs
i)
| SrcSpan -> SrcSpan
srcSpanToAnnSpan SrcSpan
l SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan -> SrcSpan
srcSpanToAnnSpan SrcSpan
pos = SrcSpan -> ImportDecl GhcPs -> LImportDecl GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (ImportDecl GhcPs
i {ideclAs :: Maybe (Located ModuleName)
GHC.ideclAs = Maybe (Located ModuleName)
forall a. Maybe a
Nothing})
| Bool
otherwise = LImportDecl GhcPs
imp
droppedComments :: Anns -> Module -> AnnKeyMap -> Bool
Anns
as Module
m AnnKeyMap
keyMap = ([SrcSpan] -> Bool) -> [[SrcSpan]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((SrcSpan -> Bool) -> [SrcSpan] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (SrcSpan -> Set SrcSpan -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set SrcSpan
allSpans)) [[SrcSpan]]
spanssWithComments
where
spanssWithComments :: [[SrcSpan]]
spanssWithComments =
((AnnKey, Annotation) -> [SrcSpan])
-> [(AnnKey, Annotation)] -> [[SrcSpan]]
forall a b. (a -> b) -> [a] -> [b]
map (\(AnnKey
key, Annotation
_) -> (AnnKey -> SrcSpan) -> [AnnKey] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map AnnKey -> SrcSpan
keySpan ([AnnKey] -> [SrcSpan]) -> [AnnKey] -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ AnnKey
key AnnKey -> [AnnKey] -> [AnnKey]
forall a. a -> [a] -> [a]
: [AnnKey] -> AnnKey -> AnnKeyMap -> [AnnKey]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] AnnKey
key AnnKeyMap
keyMap)
([(AnnKey, Annotation)] -> [[SrcSpan]])
-> ([(AnnKey, Annotation)] -> [(AnnKey, Annotation)])
-> [(AnnKey, Annotation)]
-> [[SrcSpan]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AnnKey, Annotation) -> Bool)
-> [(AnnKey, Annotation)] -> [(AnnKey, Annotation)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(AnnKey
_, Annotation
v) -> [(Comment, DeltaPos)] -> Bool
forall a. [a] -> Bool
notNull (Annotation -> [(Comment, DeltaPos)]
annPriorComments Annotation
v) Bool -> Bool -> Bool
|| [(Comment, DeltaPos)] -> Bool
forall a. [a] -> Bool
notNull (Annotation -> [(Comment, DeltaPos)]
annFollowingComments Annotation
v))
([(AnnKey, Annotation)] -> [[SrcSpan]])
-> [(AnnKey, Annotation)] -> [[SrcSpan]]
forall a b. (a -> b) -> a -> b
$ Anns -> [(AnnKey, Annotation)]
forall k a. Map k a -> [(k, a)]
Map.toList Anns
as
keySpan :: AnnKey -> SrcSpan
keySpan (AnnKey SrcSpan
ss AnnConName
_) = SrcSpan
ss
allSpans :: Set AnnSpan
allSpans :: Set SrcSpan
allSpans = [SrcSpan] -> Set SrcSpan
forall a. Ord a => [a] -> Set a
Set.fromList ([SrcSpan] -> Set SrcSpan)
-> ([SrcSpan] -> [SrcSpan]) -> [SrcSpan] -> Set SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcSpan -> SrcSpan) -> [SrcSpan] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SrcSpan -> SrcSpan
srcSpanToAnnSpan ([SrcSpan] -> Set SrcSpan) -> [SrcSpan] -> Set SrcSpan
forall a b. (a -> b) -> a -> b
$ Module -> [SrcSpan]
forall from to. Biplate from to => from -> [to]
universeBi Module
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
Right (Anns
as, GHC.L SrcSpan
l (GHC.ValD XValD GhcPs
_ HsBind GhcPs
b)) -> (Anns, LHsBind GhcPs) -> ParseResult (LHsBind GhcPs)
forall a b. b -> Either a b
Right (Anns
as, SrcSpan -> HsBind GhcPs -> LHsBind GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l HsBind GhcPs
b)
Right (Anns
_, GHC.L SrcSpan
l HsDecl GhcPs
_) -> ErrorMessages -> ParseResult (LHsBind GhcPs)
forall a b. a -> Either a b
Left (DynFlags -> SrcSpan -> String -> ErrorMessages
mkErr DynFlags
dyn SrcSpan
l String
"Not a HsBind")
Left ErrorMessages
e -> ErrorMessages -> ParseResult (LHsBind 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 (Anns
as, GHC.L SrcSpan
l GHC.FunBind {MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches}) ->
case Located [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc (MatchGroup GhcPs (LHsExpr GhcPs)
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall p body. MatchGroup p body -> Located [LMatch p body]
GHC.mg_alts MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches) of
[x] -> (Anns, LMatch GhcPs (LHsExpr GhcPs))
-> ParseResult (LMatch GhcPs (LHsExpr GhcPs))
forall a b. b -> Either a b
Right (Anns
as, LMatch GhcPs (LHsExpr GhcPs)
x)
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
_ -> ErrorMessages -> ParseResult (LMatch GhcPs (LHsExpr GhcPs))
forall a b. a -> Either a b
Left (DynFlags -> SrcSpan -> String -> ErrorMessages
mkErr DynFlags
dyn SrcSpan
l String
"Not a single match")
Right (Anns
_, GHC.L SrcSpan
l HsBind GhcPs
_) -> ErrorMessages -> ParseResult (LMatch GhcPs (LHsExpr GhcPs))
forall a b. a -> Either a b
Left (DynFlags -> SrcSpan -> String -> ErrorMessages
mkErr DynFlags
dyn SrcSpan
l String
"Not a funbind")
Left ErrorMessages
e -> ErrorMessages -> ParseResult (LMatch GhcPs (LHsExpr GhcPs))
forall a b. a -> Either a b
Left ErrorMessages
e
substTransform :: (Data a, Data b) => b -> [(String, GHC.SrcSpan)] -> a -> M a
substTransform :: b -> [(String, SrcSpan)] -> a -> M a
substTransform b
m [(String, SrcSpan)]
ss =
GenericM (StateT (Anns, AnnKeyMap) IO)
-> GenericM (StateT (Anns, AnnKeyMap) IO)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM
( (LHsType GhcPs -> StateT (Anns, AnnKeyMap) IO (LHsType GhcPs))
-> a -> StateT (Anns, AnnKeyMap) IO a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM (b
-> [(String, SrcSpan)]
-> LHsType GhcPs
-> StateT (Anns, AnnKeyMap) IO (LHsType GhcPs)
forall a.
Data a =>
a
-> [(String, SrcSpan)]
-> LHsType GhcPs
-> StateT (Anns, AnnKeyMap) IO (LHsType GhcPs)
typeSub b
m [(String, SrcSpan)]
ss)
(a -> StateT (Anns, AnnKeyMap) IO a)
-> (FunBind -> StateT (Anns, AnnKeyMap) IO FunBind)
-> a
-> StateT (Anns, AnnKeyMap) 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 (Anns, AnnKeyMap) IO FunBind
forall a.
Data a =>
a
-> [(String, SrcSpan)]
-> FunBind
-> StateT (Anns, AnnKeyMap) IO FunBind
identSub b
m [(String, SrcSpan)]
ss
(a -> StateT (Anns, AnnKeyMap) IO a)
-> (Located (Pat GhcPs)
-> StateT (Anns, AnnKeyMap) IO (Located (Pat GhcPs)))
-> a
-> StateT (Anns, AnnKeyMap) 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)]
-> Located (Pat GhcPs)
-> StateT (Anns, AnnKeyMap) IO (Located (Pat GhcPs))
forall a.
Data a =>
a
-> [(String, SrcSpan)]
-> Located (Pat GhcPs)
-> StateT (Anns, AnnKeyMap) IO (Located (Pat GhcPs))
patSub b
m [(String, SrcSpan)]
ss
(a -> StateT (Anns, AnnKeyMap) IO a)
-> (ExprLStmt GhcPs
-> StateT (Anns, AnnKeyMap) IO (ExprLStmt GhcPs))
-> a
-> StateT (Anns, AnnKeyMap) 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
-> StateT (Anns, AnnKeyMap) IO (ExprLStmt GhcPs)
forall a.
Data a =>
a
-> [(String, SrcSpan)]
-> ExprLStmt GhcPs
-> StateT (Anns, AnnKeyMap) IO (ExprLStmt GhcPs)
stmtSub b
m [(String, SrcSpan)]
ss
(a -> StateT (Anns, AnnKeyMap) IO a)
-> (LHsExpr GhcPs -> StateT (Anns, AnnKeyMap) IO (LHsExpr GhcPs))
-> a
-> StateT (Anns, AnnKeyMap) 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
-> StateT (Anns, AnnKeyMap) IO (LHsExpr GhcPs)
forall a.
Data a =>
a
-> [(String, SrcSpan)]
-> LHsExpr GhcPs
-> StateT (Anns, AnnKeyMap) IO (LHsExpr GhcPs)
exprSub b
m [(String, SrcSpan)]
ss
)
stmtSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Stmt -> M Stmt
stmtSub :: a
-> [(String, SrcSpan)]
-> ExprLStmt GhcPs
-> StateT (Anns, AnnKeyMap) IO (ExprLStmt GhcPs)
stmtSub a
m [(String, SrcSpan)]
subs old :: ExprLStmt GhcPs
old@(GHC.L SrcSpan
_ (GHC.BodyStmt XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
_ (GHC.L SrcSpan
_ (GHC.HsVar XVar GhcPs
_ (GHC.L SrcSpan
_ IdP GhcPs
name))) SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) =
a
-> (SrcSpan -> StateT (Anns, AnnKeyMap) IO (ExprLStmt GhcPs))
-> ExprLStmt GhcPs
-> [(String, SrcSpan)]
-> RdrName
-> StateT (Anns, AnnKeyMap) IO (ExprLStmt GhcPs)
forall old a.
(Data old, Data a) =>
a
-> (SrcSpan -> M (Located old))
-> Located old
-> [(String, SrcSpan)]
-> RdrName
-> M (Located old)
resolveRdrName a
m (a -> SrcSpan -> StateT (Anns, AnnKeyMap) IO (ExprLStmt GhcPs)
forall a modu (m :: * -> *).
(Data a, Data modu, MonadIO m) =>
modu -> SrcSpan -> m (Located a)
findOrError a
m) ExprLStmt GhcPs
old [(String, SrcSpan)]
subs IdP GhcPs
RdrName
name
stmtSub a
_ [(String, SrcSpan)]
_ ExprLStmt GhcPs
e = ExprLStmt GhcPs -> StateT (Anns, AnnKeyMap) IO (ExprLStmt GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExprLStmt GhcPs
e
patSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Pat -> M Pat
patSub :: a
-> [(String, SrcSpan)]
-> Located (Pat GhcPs)
-> StateT (Anns, AnnKeyMap) IO (Located (Pat GhcPs))
patSub a
m [(String, SrcSpan)]
subs old :: Located (Pat GhcPs)
old@(GHC.L SrcSpan
_ (GHC.VarPat XVarPat GhcPs
_ (GHC.L SrcSpan
_ IdP GhcPs
name))) =
a
-> (SrcSpan -> StateT (Anns, AnnKeyMap) IO (Located (Pat GhcPs)))
-> Located (Pat GhcPs)
-> [(String, SrcSpan)]
-> RdrName
-> StateT (Anns, AnnKeyMap) IO (Located (Pat GhcPs))
forall old a.
(Data old, Data a) =>
a
-> (SrcSpan -> M (Located old))
-> Located old
-> [(String, SrcSpan)]
-> RdrName
-> M (Located old)
resolveRdrName a
m (a -> SrcSpan -> StateT (Anns, AnnKeyMap) IO (Located (Pat GhcPs))
forall a modu (m :: * -> *).
(Data a, Data modu, MonadIO m) =>
modu -> SrcSpan -> m (Located a)
findOrError a
m) Located (Pat GhcPs)
old [(String, SrcSpan)]
subs IdP GhcPs
RdrName
name
patSub a
_ [(String, SrcSpan)]
_ Located (Pat GhcPs)
e = Located (Pat GhcPs)
-> StateT (Anns, AnnKeyMap) IO (Located (Pat GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Located (Pat GhcPs)
e
typeSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Type -> M Type
typeSub :: a
-> [(String, SrcSpan)]
-> LHsType GhcPs
-> StateT (Anns, AnnKeyMap) IO (LHsType GhcPs)
typeSub a
m [(String, SrcSpan)]
subs old :: LHsType GhcPs
old@(GHC.L SrcSpan
_ (GHC.HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (GHC.L SrcSpan
_ IdP GhcPs
name))) =
a
-> (SrcSpan -> StateT (Anns, AnnKeyMap) IO (LHsType GhcPs))
-> LHsType GhcPs
-> [(String, SrcSpan)]
-> RdrName
-> StateT (Anns, AnnKeyMap) IO (LHsType GhcPs)
forall old a.
(Data old, Data a) =>
a
-> (SrcSpan -> M (Located old))
-> Located old
-> [(String, SrcSpan)]
-> RdrName
-> M (Located old)
resolveRdrName a
m (a -> SrcSpan -> StateT (Anns, AnnKeyMap) IO (LHsType GhcPs)
forall a modu (m :: * -> *).
(Data a, Data modu, MonadIO m) =>
modu -> SrcSpan -> m (Located a)
findOrError a
m) LHsType GhcPs
old [(String, SrcSpan)]
subs IdP GhcPs
RdrName
name
typeSub a
_ [(String, SrcSpan)]
_ LHsType GhcPs
e = LHsType GhcPs -> StateT (Anns, AnnKeyMap) IO (LHsType GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
e
exprSub :: Data a => a -> [(String, GHC.SrcSpan)] -> Expr -> M Expr
exprSub :: a
-> [(String, SrcSpan)]
-> LHsExpr GhcPs
-> StateT (Anns, AnnKeyMap) IO (LHsExpr GhcPs)
exprSub a
m [(String, SrcSpan)]
subs old :: LHsExpr GhcPs
old@(GHC.L SrcSpan
_ (GHC.HsVar XVar GhcPs
_ (GHC.L SrcSpan
_ IdP GhcPs
name))) =
a
-> (SrcSpan -> StateT (Anns, AnnKeyMap) IO (LHsExpr GhcPs))
-> LHsExpr GhcPs
-> [(String, SrcSpan)]
-> RdrName
-> StateT (Anns, AnnKeyMap) IO (LHsExpr GhcPs)
forall old a.
(Data old, Data a) =>
a
-> (SrcSpan -> M (Located old))
-> Located old
-> [(String, SrcSpan)]
-> RdrName
-> M (Located old)
resolveRdrName a
m (a -> SrcSpan -> StateT (Anns, AnnKeyMap) IO (LHsExpr GhcPs)
forall a modu (m :: * -> *).
(Data a, Data modu, MonadIO m) =>
modu -> SrcSpan -> m (Located a)
findOrError a
m) LHsExpr GhcPs
old [(String, SrcSpan)]
subs IdP GhcPs
RdrName
name
exprSub a
_ [(String, SrcSpan)]
_ LHsExpr GhcPs
e = LHsExpr GhcPs -> StateT (Anns, AnnKeyMap) IO (LHsExpr GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr GhcPs
e
identSub :: Data a => a -> [(String, GHC.SrcSpan)] -> FunBind -> M FunBind
identSub :: a
-> [(String, SrcSpan)]
-> FunBind
-> StateT (Anns, AnnKeyMap) IO FunBind
identSub a
m [(String, SrcSpan)]
subs old :: FunBind
old@(GHC.FunRhs (GHC.L SrcSpan
_ RdrName
name) LexicalFixity
_ SrcStrictness
_) =
(FunBind
-> GenLocated SrcSpan RdrName
-> StateT (Anns, AnnKeyMap) IO FunBind)
-> (SrcSpan -> M (GenLocated SrcSpan RdrName))
-> FunBind
-> [(String, SrcSpan)]
-> RdrName
-> StateT (Anns, AnnKeyMap) IO FunBind
forall a b.
(a -> b -> M a)
-> (SrcSpan -> M b) -> a -> [(String, SrcSpan)] -> RdrName -> M a
resolveRdrName' FunBind
-> GenLocated SrcSpan RdrName
-> StateT (Anns, AnnKeyMap) IO FunBind
subst (a -> SrcSpan -> M (GenLocated SrcSpan RdrName)
forall a modu (m :: * -> *).
(Data a, Data modu, MonadIO m) =>
modu -> SrcSpan -> m (Located a)
findOrError a
m) FunBind
old [(String, SrcSpan)]
subs RdrName
name
where
subst :: FunBind -> Name -> M FunBind
subst :: FunBind
-> GenLocated SrcSpan RdrName
-> StateT (Anns, AnnKeyMap) IO FunBind
subst (GHC.FunRhs GenLocated SrcSpan RdrName
n LexicalFixity
b SrcStrictness
s) GenLocated SrcSpan RdrName
new = do
let fakeExpr :: Pat
fakeExpr :: Located (Pat GhcPs)
fakeExpr = SrcSpan -> Pat GhcPs -> Located (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L (GenLocated SrcSpan RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc GenLocated SrcSpan RdrName
new) (XVarPat GhcPs -> GenLocated SrcSpan (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
GHC.VarPat NoExtField
XVarPat GhcPs
noExt GenLocated SrcSpan (IdP GhcPs)
GenLocated SrcSpan RdrName
new)
((Anns, AnnKeyMap) -> (Anns, AnnKeyMap))
-> StateT (Anns, AnnKeyMap) IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (((Anns, AnnKeyMap) -> (Anns, AnnKeyMap))
-> StateT (Anns, AnnKeyMap) IO ())
-> ((Anns -> Anns) -> (Anns, AnnKeyMap) -> (Anns, AnnKeyMap))
-> (Anns -> Anns)
-> StateT (Anns, AnnKeyMap) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Anns -> Anns) -> (Anns, AnnKeyMap) -> (Anns, AnnKeyMap)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first ((Anns -> Anns) -> StateT (Anns, AnnKeyMap) IO ())
-> (Anns -> Anns) -> StateT (Anns, AnnKeyMap) IO ()
forall a b. (a -> b) -> a -> b
$
AnnKey -> AnnKey -> AnnKey -> AnnKey -> Anns -> Anns
replaceAnnKey (GenLocated SrcSpan RdrName -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey GenLocated SrcSpan RdrName
n) (Located (Pat GhcPs) -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located (Pat GhcPs)
fakeExpr) (GenLocated SrcSpan RdrName -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey GenLocated SrcSpan RdrName
new) (Located (Pat GhcPs) -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located (Pat GhcPs)
fakeExpr)
FunBind -> StateT (Anns, AnnKeyMap) IO FunBind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FunBind -> StateT (Anns, AnnKeyMap) IO FunBind)
-> FunBind -> StateT (Anns, AnnKeyMap) IO FunBind
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan RdrName
-> LexicalFixity -> SrcStrictness -> FunBind
forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
GHC.FunRhs GenLocated SrcSpan RdrName
new LexicalFixity
b SrcStrictness
s
subst FunBind
o GenLocated SrcSpan RdrName
_ = FunBind -> StateT (Anns, AnnKeyMap) IO FunBind
forall (f :: * -> *) a. Applicative f => a -> f a
pure FunBind
o
identSub a
_ [(String, SrcSpan)]
_ FunBind
e = FunBind -> StateT (Anns, AnnKeyMap) IO FunBind
forall (f :: * -> *) a. Applicative f => a -> f a
pure FunBind
e
resolveRdrName' ::
(a -> b -> M a) ->
(AnnSpan -> M b) ->
a ->
[(String, GHC.SrcSpan)] ->
GHC.RdrName ->
M a
resolveRdrName' :: (a -> b -> M a)
-> (SrcSpan -> M b) -> a -> [(String, SrcSpan)] -> RdrName -> M a
resolveRdrName' a -> b -> M a
g SrcSpan -> M b
f a
old [(String, SrcSpan)]
subs RdrName
name =
case RdrName
name of
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 -> SrcSpan -> M b
f (SrcSpan -> SrcSpan
srcSpanToAnnSpan SrcSpan
ss) M b -> (b -> M a) -> M a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> b -> M a
g a
old
RdrName
_ -> a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
old
resolveRdrName ::
(Data old, Data a) =>
a ->
(AnnSpan -> M (GHC.Located old)) ->
GHC.Located old ->
[(String, GHC.SrcSpan)] ->
GHC.RdrName ->
M (GHC.Located old)
resolveRdrName :: a
-> (SrcSpan -> M (Located old))
-> Located old
-> [(String, SrcSpan)]
-> RdrName
-> M (Located old)
resolveRdrName a
m = (Located old -> Located old -> M (Located old))
-> (SrcSpan -> M (Located old))
-> Located old
-> [(String, SrcSpan)]
-> RdrName
-> M (Located old)
forall a b.
(a -> b -> M a)
-> (SrcSpan -> M b) -> a -> [(String, SrcSpan)] -> RdrName -> M a
resolveRdrName' (a -> Located old -> Located old -> M (Located old)
forall old new mod.
(Data old, Data new, Data mod) =>
mod -> Located old -> Located new -> M (Located new)
modifyAnnKey a
m)
insertComment ::
AnnKey ->
String ->
Map.Map AnnKey Annotation ->
Map.Map AnnKey Annotation
AnnKey
k String
s Anns
as =
let comment :: Comment
comment = String -> SrcSpan -> Maybe AnnKeywordId -> Comment
Comment String
s SrcSpan
badAnnSpan Maybe AnnKeywordId
forall a. Maybe a
Nothing
in (Annotation -> Annotation) -> AnnKey -> Anns -> Anns
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
( \a :: Annotation
a@Ann {[(Comment, DeltaPos)]
[(KeywordId, DeltaPos)]
Maybe [SrcSpan]
Maybe AnnKey
DeltaPos
annEntryDelta :: Annotation -> DeltaPos
annSortKey :: Annotation -> Maybe [SrcSpan]
annCapturedSpan :: Annotation -> Maybe AnnKey
annCapturedSpan :: Maybe AnnKey
annSortKey :: Maybe [SrcSpan]
annsDP :: [(KeywordId, DeltaPos)]
annFollowingComments :: [(Comment, DeltaPos)]
annPriorComments :: [(Comment, DeltaPos)]
annEntryDelta :: DeltaPos
annFollowingComments :: Annotation -> [(Comment, DeltaPos)]
annsDP :: Annotation -> [(KeywordId, DeltaPos)]
annPriorComments :: Annotation -> [(Comment, DeltaPos)]
..} ->
Annotation
a
{ annPriorComments :: [(Comment, DeltaPos)]
annPriorComments = [(Comment, DeltaPos)]
annPriorComments [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ [(Comment
comment, (Int, Int) -> DeltaPos
DP (Int
1, Int
0))],
annEntryDelta :: DeltaPos
annEntryDelta = (Int, Int) -> DeltaPos
DP (Int
1, Int
0)
}
)
AnnKey
k
Anns
as
doGenReplacement :: forall ast a. DoGenReplacement ast a
doGenReplacement :: a
-> (ast -> Bool)
-> ast
-> ast
-> StateT ((Anns, AnnKeyMap), Bool) IO ast
doGenReplacement a
m ast -> Bool
p ast
new ast
old
| ast -> Bool
p ast
old = do
(Anns
anns, AnnKeyMap
keyMap) <- (((Anns, AnnKeyMap), Bool) -> (Anns, AnnKeyMap))
-> StateT ((Anns, AnnKeyMap), Bool) IO (Anns, AnnKeyMap)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ((Anns, AnnKeyMap), Bool) -> (Anns, AnnKeyMap)
forall a b. (a, b) -> a
fst
let n :: Located (SrcSpanLess ast)
n = ast -> Located (SrcSpanLess ast)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
decomposeSrcSpan ast
new
o :: Located (SrcSpanLess ast)
o = ast -> Located (SrcSpanLess ast)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
decomposeSrcSpan ast
old
(Anns
newAnns, AnnKeyMap
newKeyMap) <- IO (Anns, AnnKeyMap)
-> StateT ((Anns, AnnKeyMap), Bool) IO (Anns, AnnKeyMap)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Anns, AnnKeyMap)
-> StateT ((Anns, AnnKeyMap), Bool) IO (Anns, AnnKeyMap))
-> IO (Anns, AnnKeyMap)
-> StateT ((Anns, AnnKeyMap), Bool) IO (Anns, AnnKeyMap)
forall a b. (a -> b) -> a -> b
$ StateT (Anns, AnnKeyMap) IO (Located (SrcSpanLess ast))
-> (Anns, AnnKeyMap) -> IO (Anns, AnnKeyMap)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (a
-> Located (SrcSpanLess ast)
-> Located (SrcSpanLess ast)
-> StateT (Anns, AnnKeyMap) IO (Located (SrcSpanLess ast))
forall old new mod.
(Data old, Data new, Data mod) =>
mod -> Located old -> Located new -> M (Located new)
modifyAnnKey a
m Located (SrcSpanLess ast)
o Located (SrcSpanLess ast)
n) (Anns
anns, AnnKeyMap
keyMap)
((Anns, AnnKeyMap), Bool) -> StateT ((Anns, AnnKeyMap), Bool) IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ((Anns
newAnns, AnnKeyMap
newKeyMap), Bool
True)
ast -> StateT ((Anns, AnnKeyMap), Bool) IO ast
forall (f :: * -> *) a. Applicative f => a -> f a
pure ast
new
| Just SrcSpanLess ast :~: HsDecl GhcPs
Refl <- (Typeable (SrcSpanLess ast), Typeable (HsDecl GhcPs)) =>
Maybe (SrcSpanLess ast :~: HsDecl GhcPs)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @(SrcSpanLess ast) @(GHC.HsDecl GHC.GhcPs),
GHC.L SrcSpan
_ (GHC.ValD xvald newBind@GHC.FunBind {}) <- ast -> Located (SrcSpanLess ast)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
decomposeSrcSpan ast
new,
Just (LHsDecl GhcPs
oldNoLocal, LHsLocalBinds GhcPs
oldLocal) <- LHsDecl GhcPs -> Maybe (LHsDecl GhcPs, LHsLocalBinds GhcPs)
stripLocalBind (ast -> Located (SrcSpanLess ast)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
decomposeSrcSpan ast
old),
newLoc :: SrcSpan
newLoc@(RealSrcSpan' RealSrcSpan
newLocReal) <- ast -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc ast
new,
ast -> Bool
p (Located (SrcSpanLess ast) -> ast
forall a. HasSrcSpan a => Located (SrcSpanLess a) -> a
composeSrcSpan LHsDecl GhcPs
Located (SrcSpanLess ast)
oldNoLocal) = do
(Anns
anns, AnnKeyMap
keyMap) <- (((Anns, AnnKeyMap), Bool) -> (Anns, AnnKeyMap))
-> StateT ((Anns, AnnKeyMap), Bool) IO (Anns, AnnKeyMap)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ((Anns, AnnKeyMap), Bool) -> (Anns, AnnKeyMap)
forall a b. (a, b) -> a
fst
let n :: Located (SrcSpanLess ast)
n = ast -> Located (SrcSpanLess ast)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
decomposeSrcSpan ast
new
o :: Located (SrcSpanLess ast)
o = ast -> Located (SrcSpanLess ast)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
decomposeSrcSpan ast
old
(Anns
intAnns, AnnKeyMap
newKeyMap) <- IO (Anns, AnnKeyMap)
-> StateT ((Anns, AnnKeyMap), Bool) IO (Anns, AnnKeyMap)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Anns, AnnKeyMap)
-> StateT ((Anns, AnnKeyMap), Bool) IO (Anns, AnnKeyMap))
-> IO (Anns, AnnKeyMap)
-> StateT ((Anns, AnnKeyMap), Bool) IO (Anns, AnnKeyMap)
forall a b. (a -> b) -> a -> b
$ StateT (Anns, AnnKeyMap) IO (LHsDecl GhcPs)
-> (Anns, AnnKeyMap) -> IO (Anns, AnnKeyMap)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (a
-> LHsDecl GhcPs
-> LHsDecl GhcPs
-> StateT (Anns, AnnKeyMap) IO (LHsDecl GhcPs)
forall old new mod.
(Data old, Data new, Data mod) =>
mod -> Located old -> Located new -> M (Located new)
modifyAnnKey a
m LHsDecl GhcPs
Located (SrcSpanLess ast)
o LHsDecl GhcPs
Located (SrcSpanLess ast)
n) (Anns
anns, AnnKeyMap
keyMap)
let newFile :: FastString
newFile = RealSrcSpan -> FastString
GHC.srcSpanFile RealSrcSpan
newLocReal
newLocal :: LHsLocalBinds GhcPs
newLocal = (SrcSpan -> SrcSpan) -> LHsLocalBinds GhcPs -> LHsLocalBinds GhcPs
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (FastString -> SrcSpan -> SrcSpan
setSrcSpanFile FastString
newFile) LHsLocalBinds GhcPs
oldLocal
newLocalLoc :: SrcSpan
newLocalLoc = LHsLocalBinds GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc LHsLocalBinds GhcPs
newLocal
ensureLoc :: SrcSpan -> SrcSpan
ensureLoc = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
newLocalLoc
newMG :: MatchGroup GhcPs (LHsExpr GhcPs)
newMG = HsBind GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs)
forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
GHC.fun_matches HsBind GhcPs
newBind
GHC.L SrcSpan
locMG [GHC.L SrcSpan
locMatch Match GhcPs (LHsExpr GhcPs)
newMatch] = MatchGroup GhcPs (LHsExpr GhcPs)
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall p body. MatchGroup p body -> Located [LMatch p body]
GHC.mg_alts MatchGroup GhcPs (LHsExpr GhcPs)
newMG
newGRHSs :: GRHSs GhcPs (LHsExpr GhcPs)
newGRHSs = Match GhcPs (LHsExpr GhcPs) -> GRHSs GhcPs (LHsExpr GhcPs)
forall p body. Match p body -> GRHSs p body
GHC.m_grhss Match GhcPs (LHsExpr GhcPs)
newMatch
finalLoc :: SrcSpan
finalLoc = SrcSpan -> SrcSpan
ensureLoc SrcSpan
newLoc
newWithLocalBinds :: LHsDecl GhcPs
newWithLocalBinds =
LHsLocalBinds GhcPs
-> XValD GhcPs
-> HsBind GhcPs
-> SrcSpan
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> SrcSpan
-> Match GhcPs (LHsExpr GhcPs)
-> SrcSpan
-> GRHSs GhcPs (LHsExpr GhcPs)
-> LHsDecl GhcPs
setLocalBind
LHsLocalBinds GhcPs
newLocal
XValD GhcPs
xvald
HsBind GhcPs
newBind
SrcSpan
finalLoc
MatchGroup GhcPs (LHsExpr GhcPs)
newMG
(SrcSpan -> SrcSpan
ensureLoc SrcSpan
locMG)
Match GhcPs (LHsExpr GhcPs)
newMatch
(SrcSpan -> SrcSpan
ensureLoc SrcSpan
locMatch)
GRHSs GhcPs (LHsExpr GhcPs)
newGRHSs
addLocalBindsToAnns :: Anns -> Anns
addLocalBindsToAnns =
Anns -> Anns
addAnnWhere
(Anns -> Anns) -> (Anns -> Anns) -> Anns -> Anns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AnnKey, Annotation)] -> Anns
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
([(AnnKey, Annotation)] -> Anns)
-> (Anns -> [(AnnKey, Annotation)]) -> Anns -> Anns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AnnKey, Annotation) -> (AnnKey, Annotation))
-> [(AnnKey, Annotation)] -> [(AnnKey, Annotation)]
forall a b. (a -> b) -> [a] -> [b]
map ((AnnKey -> AnnKey) -> (AnnKey, Annotation) -> (AnnKey, Annotation)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (AnnKey -> AnnKey
expandTemplateLoc (AnnKey -> AnnKey) -> (AnnKey -> AnnKey) -> AnnKey -> AnnKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnKey -> AnnKey
updateFile (AnnKey -> AnnKey) -> (AnnKey -> AnnKey) -> AnnKey -> AnnKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnKey -> AnnKey
expandGRHSLoc))
([(AnnKey, Annotation)] -> [(AnnKey, Annotation)])
-> (Anns -> [(AnnKey, Annotation)])
-> Anns
-> [(AnnKey, Annotation)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anns -> [(AnnKey, Annotation)]
forall k a. Map k a -> [(k, a)]
Map.toList
where
addAnnWhere :: Anns -> Anns
addAnnWhere :: Anns -> Anns
addAnnWhere Anns
oldAnns =
let oldAnns' :: [(AnnKey, Annotation)]
oldAnns' = Anns -> [(AnnKey, Annotation)]
forall k a. Map k a -> [(k, a)]
Map.toList Anns
oldAnns
po :: AnnKey -> Bool
po = (AnnKey -> Bool)
-> (RealSrcSpan -> AnnConName -> Bool) -> AnnKey -> Bool
forall a.
(AnnKey -> a) -> (RealSrcSpan -> AnnConName -> a) -> AnnKey -> a
foldAnnKey (Bool -> AnnKey -> Bool
forall a b. a -> b -> a
const Bool
False) ((RealSrcSpan -> AnnConName -> Bool) -> AnnKey -> Bool)
-> (RealSrcSpan -> AnnConName -> Bool) -> AnnKey -> Bool
forall a b. (a -> b) -> a -> b
$ \RealSrcSpan
r AnnConName
con ->
SrcSpan -> SrcSpan
srcSpanToAnnSpan (RealSrcSpan -> SrcSpan
RealSrcSpan' RealSrcSpan
r) SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan -> SrcSpan
srcSpanToAnnSpan (ast -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc ast
old)
Bool -> Bool -> Bool
&& AnnConName
con AnnConName -> AnnConName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> AnnConName
CN String
"Match"
Bool -> Bool -> Bool
&& RealSrcSpan -> FastString
GHC.srcSpanFile RealSrcSpan
r FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
/= FastString
newFile
pn :: AnnKey -> Bool
pn = (AnnKey -> Bool)
-> (RealSrcSpan -> AnnConName -> Bool) -> AnnKey -> Bool
forall a.
(AnnKey -> a) -> (RealSrcSpan -> AnnConName -> a) -> AnnKey -> a
foldAnnKey (Bool -> AnnKey -> Bool
forall a b. a -> b -> a
const Bool
False) ((RealSrcSpan -> AnnConName -> Bool) -> AnnKey -> Bool)
-> (RealSrcSpan -> AnnConName -> Bool) -> AnnKey -> Bool
forall a b. (a -> b) -> a -> b
$ \RealSrcSpan
r AnnConName
con ->
SrcSpan -> SrcSpan
srcSpanToAnnSpan (RealSrcSpan -> SrcSpan
RealSrcSpan' RealSrcSpan
r) SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan -> SrcSpan
srcSpanToAnnSpan SrcSpan
finalLoc
Bool -> Bool -> Bool
&& AnnConName
con AnnConName -> AnnConName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> AnnConName
CN String
"Match"
Bool -> Bool -> Bool
&& RealSrcSpan -> FastString
GHC.srcSpanFile RealSrcSpan
r FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
newFile
in Anns -> Maybe Anns -> Anns
forall a. a -> Maybe a -> a
fromMaybe Anns
oldAnns (Maybe Anns -> Anns) -> Maybe Anns -> Anns
forall a b. (a -> b) -> a -> b
$ do
Annotation
oldAnn <- (AnnKey, Annotation) -> Annotation
forall a b. (a, b) -> b
snd ((AnnKey, Annotation) -> Annotation)
-> Maybe (AnnKey, Annotation) -> Maybe Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((AnnKey, Annotation) -> Bool)
-> [(AnnKey, Annotation)] -> Maybe (AnnKey, Annotation)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (AnnKey -> Bool
po (AnnKey -> Bool)
-> ((AnnKey, Annotation) -> AnnKey) -> (AnnKey, Annotation) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnnKey, Annotation) -> AnnKey
forall a b. (a, b) -> a
fst) [(AnnKey, Annotation)]
oldAnns'
(KeywordId, DeltaPos)
annWhere <- ((KeywordId, DeltaPos) -> Bool)
-> [(KeywordId, DeltaPos)] -> Maybe (KeywordId, DeltaPos)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((KeywordId -> KeywordId -> Bool
forall a. Eq a => a -> a -> Bool
== AnnKeywordId -> KeywordId
G AnnKeywordId
GHC.AnnWhere) (KeywordId -> Bool)
-> ((KeywordId, DeltaPos) -> KeywordId)
-> (KeywordId, DeltaPos)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeywordId, DeltaPos) -> KeywordId
forall a b. (a, b) -> a
fst) (Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
oldAnn)
let newSortKey :: Maybe [SrcSpan]
newSortKey = (SrcSpan -> SrcSpan) -> [SrcSpan] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FastString -> SrcSpan -> SrcSpan
setAnnSpanFile FastString
newFile) ([SrcSpan] -> [SrcSpan]) -> Maybe [SrcSpan] -> Maybe [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotation -> Maybe [SrcSpan]
annSortKey Annotation
oldAnn
AnnKey
newKey <- (AnnKey, Annotation) -> AnnKey
forall a b. (a, b) -> a
fst ((AnnKey, Annotation) -> AnnKey)
-> Maybe (AnnKey, Annotation) -> Maybe AnnKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((AnnKey, Annotation) -> Bool)
-> [(AnnKey, Annotation)] -> Maybe (AnnKey, Annotation)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (AnnKey -> Bool
pn (AnnKey -> Bool)
-> ((AnnKey, Annotation) -> AnnKey) -> (AnnKey, Annotation) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnnKey, Annotation) -> AnnKey
forall a b. (a, b) -> a
fst) [(AnnKey, Annotation)]
oldAnns'
Anns -> Maybe Anns
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns -> Maybe Anns) -> Anns -> Maybe Anns
forall a b. (a -> b) -> a -> b
$
(Annotation -> Annotation) -> AnnKey -> Anns -> Anns
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
(\Annotation
ann -> Annotation
ann {annsDP :: [(KeywordId, DeltaPos)]
annsDP = Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
ann [(KeywordId, DeltaPos)]
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ [(KeywordId, DeltaPos)
annWhere], annSortKey :: Maybe [SrcSpan]
annSortKey = Maybe [SrcSpan]
newSortKey})
AnnKey
newKey
Anns
oldAnns
expandGRHSLoc :: AnnKey -> AnnKey
expandGRHSLoc = (AnnKey -> AnnKey)
-> (RealSrcSpan -> AnnConName -> AnnKey) -> AnnKey -> AnnKey
forall a.
(AnnKey -> a) -> (RealSrcSpan -> AnnConName -> a) -> AnnKey -> a
foldAnnKey AnnKey -> AnnKey
forall a. a -> a
id ((RealSrcSpan -> AnnConName -> AnnKey) -> AnnKey -> AnnKey)
-> (RealSrcSpan -> AnnConName -> AnnKey) -> AnnKey -> AnnKey
forall a b. (a -> b) -> a -> b
$ \RealSrcSpan
r AnnConName
con ->
if AnnConName
con AnnConName -> AnnConName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> AnnConName
CN String
"GRHS" Bool -> Bool -> Bool
&& RealSrcSpan -> FastString
GHC.srcSpanFile RealSrcSpan
r FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
newFile
then SrcSpan -> AnnConName -> AnnKey
AnnKey (SrcSpan -> SrcSpan
srcSpanToAnnSpan (SrcSpan -> SrcSpan) -> SrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpan
ensureLoc (SrcSpan -> SrcSpan) -> SrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> SrcSpan
RealSrcSpan' RealSrcSpan
r) AnnConName
con
else SrcSpan -> AnnConName -> AnnKey
AnnKey (SrcSpan -> SrcSpan
srcSpanToAnnSpan (SrcSpan -> SrcSpan) -> SrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> SrcSpan
RealSrcSpan' RealSrcSpan
r) AnnConName
con
updateFile :: AnnKey -> AnnKey
updateFile = \case
AnnKey SrcSpan
loc AnnConName
con
| SrcSpan -> SrcSpan
annSpanToSrcSpan SrcSpan
loc SrcSpan -> SrcSpan -> Bool
`GHC.isSubspanOf` LHsLocalBinds GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc LHsLocalBinds GhcPs
oldLocal ->
SrcSpan -> AnnConName -> AnnKey
AnnKey (FastString -> SrcSpan -> SrcSpan
setAnnSpanFile FastString
newFile SrcSpan
loc) AnnConName
con
AnnKey
other -> AnnKey
other
expandTemplateLoc :: AnnKey -> AnnKey
expandTemplateLoc = \case
AnnKey SrcSpan
loc AnnConName
con
| SrcSpan
loc SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan -> SrcSpan
srcSpanToAnnSpan SrcSpan
newLoc -> SrcSpan -> AnnConName -> AnnKey
AnnKey (SrcSpan -> SrcSpan
srcSpanToAnnSpan SrcSpan
finalLoc) AnnConName
con
AnnKey
other -> AnnKey
other
newAnns :: Anns
newAnns = Anns -> Anns
addLocalBindsToAnns Anns
intAnns
((Anns, AnnKeyMap), Bool) -> StateT ((Anns, AnnKeyMap), Bool) IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ((Anns
newAnns, AnnKeyMap
newKeyMap), Bool
True)
ast -> StateT ((Anns, AnnKeyMap), Bool) IO ast
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ast -> StateT ((Anns, AnnKeyMap), Bool) IO ast)
-> ast -> StateT ((Anns, AnnKeyMap), Bool) IO ast
forall a b. (a -> b) -> a -> b
$ Located (SrcSpanLess ast) -> ast
forall a. HasSrcSpan a => Located (SrcSpanLess a) -> a
composeSrcSpan LHsDecl GhcPs
Located (SrcSpanLess ast)
newWithLocalBinds
| Bool
otherwise = ast -> StateT ((Anns, AnnKeyMap), Bool) IO ast
forall (f :: * -> *) a. Applicative f => a -> f a
pure ast
old
stripLocalBind ::
Decl ->
Maybe (Decl, GHC.LHsLocalBinds GHC.GhcPs)
stripLocalBind :: LHsDecl GhcPs -> Maybe (LHsDecl GhcPs, LHsLocalBinds GhcPs)
stripLocalBind = \case
GHC.L SrcSpan
_ (GHC.ValD XValD GhcPs
xvald origBind :: HsBind GhcPs
origBind@GHC.FunBind {})
| let origMG :: MatchGroup GhcPs (LHsExpr GhcPs)
origMG = HsBind GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs)
forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
GHC.fun_matches HsBind GhcPs
origBind,
GHC.L SrcSpan
locMG [GHC.L SrcSpan
locMatch Match GhcPs (LHsExpr GhcPs)
origMatch] <- MatchGroup GhcPs (LHsExpr GhcPs)
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall p body. MatchGroup p body -> Located [LMatch p body]
GHC.mg_alts MatchGroup GhcPs (LHsExpr GhcPs)
origMG,
let origGRHSs :: GRHSs GhcPs (LHsExpr GhcPs)
origGRHSs = Match GhcPs (LHsExpr GhcPs) -> GRHSs GhcPs (LHsExpr GhcPs)
forall p body. Match p body -> GRHSs p body
GHC.m_grhss Match GhcPs (LHsExpr GhcPs)
origMatch,
[GHC.L SrcSpan
_ (GHC.GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [ExprLStmt GhcPs]
_ (GHC.L SrcSpan
loc2 HsExpr GhcPs
_))] <- GRHSs GhcPs (LHsExpr GhcPs) -> [LGRHS GhcPs (LHsExpr GhcPs)]
forall p body. GRHSs p body -> [LGRHS p body]
GHC.grhssGRHSs GRHSs GhcPs (LHsExpr GhcPs)
origGRHSs ->
let loc1 :: SrcSpan
loc1 = GenLocated SrcSpan RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc (HsBind GhcPs -> GenLocated SrcSpan (IdP GhcPs)
forall idL idR. HsBindLR idL idR -> Located (IdP idL)
GHC.fun_id HsBind GhcPs
origBind)
newLoc :: SrcSpan
newLoc = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc1 SrcSpan
loc2
withoutLocalBinds :: LHsDecl GhcPs
withoutLocalBinds =
LHsLocalBinds GhcPs
-> XValD GhcPs
-> HsBind GhcPs
-> SrcSpan
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> SrcSpan
-> Match GhcPs (LHsExpr GhcPs)
-> SrcSpan
-> GRHSs GhcPs (LHsExpr GhcPs)
-> LHsDecl GhcPs
setLocalBind
(SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
GHC.noLoc (XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
GHC.EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcPs GhcPs
noExt))
XValD GhcPs
xvald
HsBind GhcPs
origBind
SrcSpan
newLoc
MatchGroup GhcPs (LHsExpr GhcPs)
origMG
SrcSpan
locMG
Match GhcPs (LHsExpr GhcPs)
origMatch
SrcSpan
locMatch
GRHSs GhcPs (LHsExpr GhcPs)
origGRHSs
in (LHsDecl GhcPs, LHsLocalBinds GhcPs)
-> Maybe (LHsDecl GhcPs, LHsLocalBinds GhcPs)
forall a. a -> Maybe a
Just (LHsDecl GhcPs
withoutLocalBinds, GRHSs GhcPs (LHsExpr GhcPs) -> LHsLocalBinds GhcPs
forall p body. GRHSs p body -> LHsLocalBinds p
GHC.grhssLocalBinds GRHSs GhcPs (LHsExpr GhcPs)
origGRHSs)
LHsDecl GhcPs
_ -> Maybe (LHsDecl GhcPs, LHsLocalBinds GhcPs)
forall a. Maybe a
Nothing
setLocalBind ::
GHC.LHsLocalBinds GHC.GhcPs ->
GHC.XValD GHC.GhcPs ->
GHC.HsBind GHC.GhcPs ->
GHC.SrcSpan ->
GHC.MatchGroup GHC.GhcPs Expr ->
GHC.SrcSpan ->
GHC.Match GHC.GhcPs Expr ->
GHC.SrcSpan ->
GHC.GRHSs GHC.GhcPs Expr ->
Decl
setLocalBind :: LHsLocalBinds GhcPs
-> XValD GhcPs
-> HsBind GhcPs
-> SrcSpan
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> SrcSpan
-> Match GhcPs (LHsExpr GhcPs)
-> SrcSpan
-> GRHSs GhcPs (LHsExpr GhcPs)
-> LHsDecl GhcPs
setLocalBind LHsLocalBinds GhcPs
newLocalBinds XValD GhcPs
xvald HsBind GhcPs
origBind SrcSpan
newLoc MatchGroup GhcPs (LHsExpr GhcPs)
origMG SrcSpan
locMG Match GhcPs (LHsExpr GhcPs)
origMatch SrcSpan
locMatch GRHSs GhcPs (LHsExpr GhcPs)
origGRHSs =
SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
newLoc (XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
GHC.ValD XValD GhcPs
xvald HsBind GhcPs
newBind)
where
newGRHSs :: GRHSs GhcPs (LHsExpr GhcPs)
newGRHSs = GRHSs GhcPs (LHsExpr GhcPs)
origGRHSs {grhssLocalBinds :: LHsLocalBinds GhcPs
GHC.grhssLocalBinds = LHsLocalBinds GhcPs
newLocalBinds}
newMatch :: Match GhcPs (LHsExpr GhcPs)
newMatch = Match GhcPs (LHsExpr GhcPs)
origMatch {m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
GHC.m_grhss = GRHSs GhcPs (LHsExpr GhcPs)
newGRHSs}
newMG :: MatchGroup GhcPs (LHsExpr GhcPs)
newMG = MatchGroup GhcPs (LHsExpr GhcPs)
origMG {mg_alts :: Located [LMatch GhcPs (LHsExpr GhcPs)]
GHC.mg_alts = SrcSpan
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
locMG [SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
locMatch Match GhcPs (LHsExpr GhcPs)
newMatch]}
newBind :: HsBind GhcPs
newBind = HsBind GhcPs
origBind {fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
GHC.fun_matches = MatchGroup GhcPs (LHsExpr GhcPs)
newMG}
replaceWorker :: forall a mod. ReplaceWorker a mod
replaceWorker :: Anns
-> mod
-> AnnKeyMap
-> Parser a
-> Int
-> Refactoring SrcSpan
-> IO (Anns, mod, AnnKeyMap)
replaceWorker Anns
as mod
m AnnKeyMap
keyMap Parser a
parser Int
seed Replace {String
[(String, SrcSpan)]
SrcSpan
RType
subts :: forall a. Refactoring a -> [(String, a)]
orig :: forall a. Refactoring a -> String
orig :: String
subts :: [(String, SrcSpan)]
pos :: SrcSpan
rtype :: RType
rtype :: forall a. Refactoring a -> RType
pos :: forall a. Refactoring a -> a
..} = do
let replExprLocation :: SrcSpan
replExprLocation = SrcSpan -> SrcSpan
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
(Anns
relat, a
template) <- do
DynFlags
flags <- IO DynFlags
-> (DynFlags -> IO DynFlags) -> Maybe DynFlags -> IO DynFlags
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((DynFlags -> DynFlags) -> IO DynFlags
forall a. (DynFlags -> a) -> IO a
withDynFlags DynFlags -> DynFlags
forall a. a -> a
id) DynFlags -> IO DynFlags
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 (Anns, a))
-> ((Anns, a) -> IO (Anns, a))
-> Either ErrorMessages (Anns, a)
-> IO (Anns, a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> ErrorMessages -> IO (Anns, a)
forall a. String -> ErrorMessages -> a
onError String
"replaceWorker") (Anns, a) -> IO (Anns, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorMessages (Anns, a) -> IO (Anns, a))
-> Either ErrorMessages (Anns, a) -> IO (Anns, a)
forall a b. (a -> b) -> a -> b
$ Parser a
parser DynFlags
flags String
uniqueName String
orig
(a
newExpr, (Anns
newAnns, AnnKeyMap
newKeyMap)) <-
StateT (Anns, AnnKeyMap) IO a
-> (Anns, AnnKeyMap) -> IO (a, (Anns, AnnKeyMap))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
(mod -> [(String, SrcSpan)] -> a -> StateT (Anns, AnnKeyMap) IO a
forall a b.
(Data a, Data b) =>
b -> [(String, SrcSpan)] -> a -> M a
substTransform mod
m [(String, SrcSpan)]
subts a
template)
(Anns -> Anns -> Anns
mergeAnns Anns
as Anns
relat, AnnKeyMap
keyMap)
let lst :: RdrName -> Maybe Char
lst = String -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe (String -> Maybe Char)
-> (RdrName -> String) -> RdrName -> Maybe Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (RdrName -> String) -> RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
occNameString (OccName -> String) -> (RdrName -> OccName) -> RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc
adjacent :: SrcSpan -> SrcSpan -> Bool
adjacent (SrcSpan -> SrcLoc
GHC.srcSpanEnd -> RealSrcLoc' RealSrcLoc
loc1) (SrcSpan -> SrcLoc
GHC.srcSpanStart -> RealSrcLoc' RealSrcLoc
loc2) = RealSrcLoc
loc1 RealSrcLoc -> RealSrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcLoc
loc2
adjacent SrcSpan
_ SrcSpan
_ = Bool
False
diffStartCols :: Int -> GHC.SrcSpan -> GHC.SrcSpan -> Bool
diffStartCols :: Int -> SrcSpan -> SrcSpan -> Bool
diffStartCols Int
x (SrcSpan -> SrcLoc
GHC.srcSpanStart -> RealSrcLoc' RealSrcLoc
loc1) (SrcSpan -> SrcLoc
GHC.srcSpanStart -> RealSrcLoc' RealSrcLoc
loc2) =
RealSrcLoc -> Int
GHC.srcLocLine RealSrcLoc
loc1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcLoc -> Int
GHC.srcLocLine RealSrcLoc
loc2 Bool -> Bool -> Bool
&& RealSrcLoc -> Int
GHC.srcLocCol RealSrcLoc
loc1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- RealSrcLoc -> Int
GHC.srcLocCol RealSrcLoc
loc2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
x
diffStartCols Int
_ SrcSpan
_ SrcSpan
_ = Bool
False
ensureAppSpace :: Anns -> Anns
ensureAppSpace :: Anns -> Anns
ensureAppSpace = (Anns -> Anns) -> Maybe (Anns -> Anns) -> Anns -> Anns
forall a. a -> Maybe a -> a
fromMaybe Anns -> Anns
forall a. a -> a
id (Maybe (Anns -> Anns) -> Anns -> Anns)
-> Maybe (Anns -> Anns) -> Anns -> Anns
forall a b. (a -> b) -> a -> b
$ do
(GHC.L SrcSpan
_ (GHC.HsVar XVar GhcPs
_ (GHC.L SrcSpan
_ IdP GhcPs
newName))) :: Expr <- a -> Maybe (LHsExpr GhcPs)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
newExpr
Char
hd <- String -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe (String -> Maybe Char) -> String -> Maybe Char
forall a b. (a -> b) -> a -> b
$ case IdP GhcPs
newName of
Unqual n -> OccName -> String
occNameString OccName
n
Qual moduleName _ -> ModuleName -> String
GHC.moduleNameString ModuleName
moduleName
Orig modu _ -> ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
GHC.moduleName Module
modu)
Exact name -> OccName -> String
occNameString (Name -> OccName
nameOccName Name
name)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isAlphaNum Char
hd
let [LHsExpr GhcPs]
prev :: [Expr] =
(LHsExpr GhcPs -> Bool) -> mod -> [LHsExpr GhcPs]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify
( \case
(GHC.L SrcSpan
loc (GHC.HsVar XVar GhcPs
_ (GHC.L SrcSpan
_ IdP GhcPs
rdr))) ->
Bool -> (Char -> Bool) -> Maybe Char -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Char -> Bool
isAlphaNum (RdrName -> Maybe Char
lst IdP GhcPs
RdrName
rdr) Bool -> Bool -> Bool
&& SrcSpan -> SrcSpan -> Bool
adjacent SrcSpan
loc SrcSpan
pos
LHsExpr GhcPs
_ -> Bool
False
)
mod
m
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ())
-> ([LHsExpr GhcPs] -> Bool) -> [LHsExpr GhcPs] -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool)
-> ([LHsExpr GhcPs] -> Bool) -> [LHsExpr GhcPs] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LHsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([LHsExpr GhcPs] -> Maybe ()) -> [LHsExpr GhcPs] -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [LHsExpr GhcPs]
prev
(Anns -> Anns) -> Maybe (Anns -> Anns)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Anns -> Anns) -> Maybe (Anns -> Anns))
-> ((Annotation -> Annotation) -> Anns -> Anns)
-> (Annotation -> Annotation)
-> Maybe (Anns -> Anns)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Annotation -> Annotation) -> AnnKey -> Anns -> Anns)
-> AnnKey -> (Annotation -> Annotation) -> Anns -> Anns
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Annotation -> Annotation) -> AnnKey -> Anns -> Anns
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey a
newExpr) ((Annotation -> Annotation) -> Maybe (Anns -> Anns))
-> (Annotation -> Annotation) -> Maybe (Anns -> Anns)
forall a b. (a -> b) -> a -> b
$ \Annotation
ann ->
if Annotation -> DeltaPos
annEntryDelta Annotation
ann DeltaPos -> DeltaPos -> Bool
forall a. Eq a => a -> a -> Bool
== (Int, Int) -> DeltaPos
DP (Int
0, Int
0)
then Annotation
ann {annEntryDelta :: DeltaPos
annEntryDelta = (Int, Int) -> DeltaPos
DP (Int
0, Int
1)}
else Annotation
ann
ensureDoSpace :: Anns -> Anns
ensureDoSpace :: Anns -> Anns
ensureDoSpace = (Anns -> Anns) -> Maybe (Anns -> Anns) -> Anns -> Anns
forall a. a -> Maybe a -> a
fromMaybe Anns -> Anns
forall a. a -> a
id (Maybe (Anns -> Anns) -> Anns -> Anns)
-> Maybe (Anns -> Anns) -> Anns -> Anns
forall a b. (a -> b) -> a -> b
$ do
let [LHsExpr GhcPs]
doBlocks :: [Expr] =
(LHsExpr GhcPs -> Bool) -> mod -> [LHsExpr GhcPs]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify
( \case
(GHC.L SrcSpan
_ GHC.HsDo {}) -> Bool
True
LHsExpr GhcPs
_ -> Bool
False
)
mod
m
doBlocks' :: [(GHC.SrcSpan, Int)]
doBlocks' :: [(SrcSpan, Int)]
doBlocks' =
(LHsExpr GhcPs -> (SrcSpan, Int))
-> [LHsExpr GhcPs] -> [(SrcSpan, Int)]
forall a b. (a -> b) -> [a] -> [b]
map
( \case
GHC.L SrcSpan
loc (GHC.HsDo XDo GhcPs
_ GHC.MDoExpr {} Located [ExprLStmt GhcPs]
_) -> (SrcSpan
loc, Int
3)
GHC.L SrcSpan
loc HsExpr GhcPs
_ -> (SrcSpan
loc, Int
2)
)
[LHsExpr GhcPs]
doBlocks
(SrcSpan, Int)
_ <- ((SrcSpan, Int) -> Bool)
-> [(SrcSpan, Int)] -> Maybe (SrcSpan, Int)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(SrcSpan
ss, Int
len) -> Int -> SrcSpan -> SrcSpan -> Bool
diffStartCols Int
len SrcSpan
pos SrcSpan
ss) [(SrcSpan, Int)]
doBlocks'
(Anns -> Anns) -> Maybe (Anns -> Anns)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Anns -> Anns) -> Maybe (Anns -> Anns))
-> ((Annotation -> Annotation) -> Anns -> Anns)
-> (Annotation -> Annotation)
-> Maybe (Anns -> Anns)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Annotation -> Annotation) -> AnnKey -> Anns -> Anns)
-> AnnKey -> (Annotation -> Annotation) -> Anns -> Anns
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Annotation -> Annotation) -> AnnKey -> Anns -> Anns
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey a
newExpr) ((Annotation -> Annotation) -> Maybe (Anns -> Anns))
-> (Annotation -> Annotation) -> Maybe (Anns -> Anns)
forall a b. (a -> b) -> a -> b
$ \Annotation
ann ->
if Annotation -> DeltaPos
annEntryDelta Annotation
ann DeltaPos -> DeltaPos -> Bool
forall a. Eq a => a -> a -> Bool
== (Int, Int) -> DeltaPos
DP (Int
0, Int
0)
then Annotation
ann {annEntryDelta :: DeltaPos
annEntryDelta = (Int, Int) -> DeltaPos
DP (Int
0, Int
1)}
else Annotation
ann
replacementPred :: Located (SrcSpanLess a) -> Bool
replacementPred = (SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
replExprLocation) (SrcSpan -> Bool)
-> (Located (SrcSpanLess a) -> SrcSpan)
-> Located (SrcSpanLess a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (SrcSpanLess a) -> SrcSpan
forall a. Located a -> SrcSpan
getAnnSpan
transformation :: mod -> StateT ((Anns, AnnKeyMap), Bool) IO mod
transformation = (a -> StateT ((Anns, AnnKeyMap), Bool) IO a)
-> mod -> StateT ((Anns, AnnKeyMap), Bool) IO mod
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM (mod
-> (a -> Bool) -> a -> a -> StateT ((Anns, AnnKeyMap), Bool) IO a
forall ast a. DoGenReplacement ast a
doGenReplacement mod
m (Located (SrcSpanLess a) -> Bool
replacementPred (Located (SrcSpanLess a) -> Bool)
-> (a -> Located (SrcSpanLess a)) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
decomposeSrcSpan) a
newExpr)
StateT ((Anns, AnnKeyMap), Bool) IO mod
-> ((Anns, AnnKeyMap), Bool) -> IO (mod, ((Anns, AnnKeyMap), Bool))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (mod -> StateT ((Anns, AnnKeyMap), Bool) IO mod
transformation mod
m) ((Anns
newAnns, AnnKeyMap
newKeyMap), Bool
False) IO (mod, ((Anns, AnnKeyMap), Bool))
-> ((mod, ((Anns, AnnKeyMap), Bool)) -> IO (Anns, mod, AnnKeyMap))
-> IO (Anns, mod, AnnKeyMap)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(mod
finalM, ((Anns -> Anns
ensureDoSpace (Anns -> Anns) -> (Anns -> Anns) -> Anns -> Anns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anns -> Anns
ensureAppSpace -> Anns
finalAs, AnnKeyMap
finalKeyMap), Bool
True)) ->
(Anns, mod, AnnKeyMap) -> IO (Anns, mod, AnnKeyMap)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
finalAs, mod
finalM, AnnKeyMap
finalKeyMap)
(mod, ((Anns, AnnKeyMap), Bool))
_ -> (Anns, mod, AnnKeyMap) -> IO (Anns, mod, AnnKeyMap)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
as, mod
m, AnnKeyMap
keyMap)
replaceWorker Anns
as mod
m AnnKeyMap
keyMap Parser a
_ Int
_ Refactoring SrcSpan
_ = (Anns, mod, AnnKeyMap) -> IO (Anns, mod, AnnKeyMap)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
as, mod
m, AnnKeyMap
keyMap)
data NotFound = NotFound
{ NotFound -> String
nfExpected :: String,
NotFound -> Maybe String
nfActual :: Maybe String,
NotFound -> SrcSpan
nfLoc :: AnnSpan
}
renderNotFound :: NotFound -> String
renderNotFound :: NotFound -> String
renderNotFound NotFound {String
Maybe String
SrcSpan
nfLoc :: SrcSpan
nfActual :: Maybe String
nfExpected :: String
nfLoc :: NotFound -> SrcSpan
nfActual :: NotFound -> Maybe String
nfExpected :: NotFound -> String
..} =
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 (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
nfLoc)
findInModule :: forall a modu. (Data a, Data modu) => modu -> AnnSpan -> Either NotFound (GHC.Located a)
findInModule :: modu -> SrcSpan -> Either NotFound (Located a)
findInModule modu
m SrcSpan
ss = case modu -> Maybe (Located a)
forall b. Data b => modu -> Maybe (Located b)
doTrans modu
m of
Just Located a
a -> Located a -> Either NotFound (Located a)
forall a b. b -> Either a b
Right Located a
a
Maybe (Located 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 (Proxy a
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 (LHsExpr GhcPs) -> Maybe String
forall b. Typeable b => Maybe (Located b) -> Maybe String
showType (modu -> Maybe (LHsExpr GhcPs)
forall b. Data b => modu -> Maybe (Located b)
doTrans modu
m :: Maybe Expr),
Maybe (LHsType GhcPs) -> Maybe String
forall b. Typeable b => Maybe (Located b) -> Maybe String
showType (modu -> Maybe (LHsType GhcPs)
forall b. Data b => modu -> Maybe (Located b)
doTrans modu
m :: Maybe Type),
Maybe (LHsDecl GhcPs) -> Maybe String
forall b. Typeable b => Maybe (Located b) -> Maybe String
showType (modu -> Maybe (LHsDecl GhcPs)
forall b. Data b => modu -> Maybe (Located b)
doTrans modu
m :: Maybe Decl),
Maybe (Located (Pat GhcPs)) -> Maybe String
forall b. Typeable b => Maybe (Located b) -> Maybe String
showType (modu -> Maybe (Located (Pat GhcPs))
forall b. Data b => modu -> Maybe (Located b)
doTrans modu
m :: Maybe Pat),
Maybe (GenLocated SrcSpan RdrName) -> Maybe String
forall b. Typeable b => Maybe (Located b) -> Maybe String
showType (modu -> Maybe (GenLocated SrcSpan RdrName)
forall b. Data b => modu -> Maybe (Located b)
doTrans modu
m :: Maybe Name)
]
in NotFound -> Either NotFound (Located a)
forall a b. a -> Either a b
Left (NotFound -> Either NotFound (Located a))
-> NotFound -> Either NotFound (Located a)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> SrcSpan -> NotFound
NotFound String
expected Maybe String
actual SrcSpan
ss
where
doTrans :: forall b. Data b => modu -> Maybe (GHC.Located b)
doTrans :: modu -> Maybe (Located b)
doTrans = GenericQ (Maybe (Located b)) -> GenericQ (Maybe (Located b))
forall u. GenericQ (Maybe u) -> GenericQ (Maybe u)
something (Maybe (Located b)
-> (Located b -> Maybe (Located b)) -> a -> Maybe (Located b)
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Maybe (Located b)
forall a. Maybe a
Nothing (SrcSpan -> Located b -> Maybe (Located b)
forall a. Data a => SrcSpan -> Located a -> Maybe (Located a)
findLargestExpression SrcSpan
ss))
showType :: forall b. Typeable b => Maybe (GHC.Located b) -> Maybe String
showType :: Maybe (Located b) -> Maybe String
showType = (Located b -> String) -> Maybe (Located b) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Located b -> String) -> Maybe (Located b) -> Maybe String)
-> (Located b -> String) -> Maybe (Located b) -> Maybe String
forall a b. (a -> b) -> a -> b
$ \Located 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 (Proxy b
forall k (t :: k). Proxy t
Proxy @b))
findLargestExpression :: forall a. Data a => AnnSpan -> GHC.Located a -> Maybe (GHC.Located a)
findLargestExpression :: SrcSpan -> Located a -> Maybe (Located a)
findLargestExpression SrcSpan
as e :: Located a
e@(Located a -> SrcSpan
forall a. Located a -> SrcSpan
getAnnSpan -> SrcSpan
l) = if SrcSpan
l SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
as then Located a -> Maybe (Located a)
forall a. a -> Maybe a
Just Located a
e else Maybe (Located a)
forall a. Maybe a
Nothing
findOrError ::
forall a modu m.
(Data a, Data modu, MonadIO m) =>
modu ->
AnnSpan ->
m (GHC.Located a)
findOrError :: modu -> SrcSpan -> m (Located a)
findOrError modu
m = (NotFound -> m (Located a))
-> (Located a -> m (Located a))
-> Either NotFound (Located a)
-> m (Located a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either NotFound -> m (Located a)
forall (m :: * -> *) a. MonadIO m => NotFound -> m a
f Located a -> m (Located a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotFound (Located a) -> m (Located a))
-> (SrcSpan -> Either NotFound (Located a))
-> SrcSpan
-> m (Located a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. modu -> SrcSpan -> Either NotFound (Located a)
forall a modu.
(Data a, Data modu) =>
modu -> SrcSpan -> Either NotFound (Located a)
findInModule modu
m
where
f :: NotFound -> m a
f NotFound
nf = 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
doDeleteStmt :: Data a => (Stmt -> Bool) -> a -> a
doDeleteStmt :: (ExprLStmt GhcPs -> Bool) -> a -> a
doDeleteStmt = ([ExprLStmt GhcPs] -> [ExprLStmt GhcPs]) -> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (([ExprLStmt GhcPs] -> [ExprLStmt GhcPs]) -> a -> a)
-> ((ExprLStmt GhcPs -> Bool)
-> [ExprLStmt GhcPs] -> [ExprLStmt GhcPs])
-> (ExprLStmt GhcPs -> Bool)
-> a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExprLStmt GhcPs -> Bool) -> [ExprLStmt GhcPs] -> [ExprLStmt GhcPs]
forall a. (a -> Bool) -> [a] -> [a]
filter
doDeleteImport :: Data a => (Import -> Bool) -> a -> a
doDeleteImport :: (LImportDecl GhcPs -> Bool) -> a -> a
doDeleteImport = ([LImportDecl GhcPs] -> [LImportDecl GhcPs]) -> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (([LImportDecl GhcPs] -> [LImportDecl GhcPs]) -> a -> a)
-> ((LImportDecl GhcPs -> Bool)
-> [LImportDecl GhcPs] -> [LImportDecl GhcPs])
-> (LImportDecl GhcPs -> Bool)
-> a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LImportDecl GhcPs -> Bool)
-> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. (a -> Bool) -> [a] -> [a]
filter
addExtensionsToFlags ::
[Extension] ->
[Extension] ->
FilePath ->
GHC.DynFlags ->
IO (Either String GHC.DynFlags)
addExtensionsToFlags :: [Extension]
-> [Extension] -> String -> DynFlags -> IO (Either String DynFlags)
addExtensionsToFlags [Extension]
es [Extension]
ds String
fp DynFlags
flags = 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
let opts :: [Located String]
opts = DynFlags -> StringBuffer -> String -> [Located String]
getOptions DynFlags
flags StringBuffer
buf String
fp
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 (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 (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 (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 (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.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
GHC.handleSourceError (Either String b -> IO (Either String b)
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 ::
([Extension], [Extension]) ->
FilePath ->
IO (Either Errors (Anns, GHC.ParsedSource))
parseModuleWithArgs :: ([Extension], [Extension])
-> String -> IO (Either ErrorMessages (Anns, Module))
parseModuleWithArgs ([Extension]
es, [Extension]
ds) String
fp = Ghc (Either ErrorMessages (Anns, Module))
-> IO (Either ErrorMessages (Anns, Module))
forall a. Ghc a -> IO a
ghcWrapper (Ghc (Either ErrorMessages (Anns, Module))
-> IO (Either ErrorMessages (Anns, Module)))
-> Ghc (Either ErrorMessages (Anns, Module))
-> IO (Either ErrorMessages (Anns, Module))
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 (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
Left String
err -> Either ErrorMessages (Anns, Module)
-> Ghc (Either ErrorMessages (Anns, Module))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorMessages (Anns, Module)
-> Ghc (Either ErrorMessages (Anns, Module)))
-> (ErrorMessages -> Either ErrorMessages (Anns, Module))
-> ErrorMessages
-> Ghc (Either ErrorMessages (Anns, Module))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessages -> Either ErrorMessages (Anns, Module)
forall a b. a -> Either a b
Left (ErrorMessages -> Ghc (Either ErrorMessages (Anns, Module)))
-> ErrorMessages -> Ghc (Either ErrorMessages (Anns, Module))
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 (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 (ApiAnns, [Comment], DynFlags, Module)
res <- CppOptions
-> DynFlags
-> String
-> Ghc
(Either ErrorMessages (ApiAnns, [Comment], DynFlags, Module))
forall (m :: * -> *).
GhcMonad m =>
CppOptions
-> DynFlags
-> String
-> m (Either ErrorMessages (ApiAnns, [Comment], DynFlags, Module))
parseModuleApiAnnsWithCppInternal CppOptions
defaultCppOptions DynFlags
flags String
fp
Either ErrorMessages (Anns, Module)
-> Ghc (Either ErrorMessages (Anns, Module))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorMessages (Anns, Module)
-> Ghc (Either ErrorMessages (Anns, Module)))
-> Either ErrorMessages (Anns, Module)
-> Ghc (Either ErrorMessages (Anns, Module))
forall a b. (a -> b) -> a -> b
$ Either ErrorMessages (ApiAnns, [Comment], DynFlags, Module)
-> DeltaOptions -> Either ErrorMessages (Anns, Module)
forall a.
Either a (ApiAnns, [Comment], DynFlags, Module)
-> DeltaOptions -> Either a (Anns, Module)
postParseTransform Either ErrorMessages (ApiAnns, [Comment], DynFlags, Module)
res DeltaOptions
rigidLayout
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 (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
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 #-}