{-# LANGUAGE CPP #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
module Refact.Internal
  ( apply
  , runRefactoring
  , addExtensionsToFlags
  , parseModuleWithArgs
  , parseExtensions

  -- * Support for runPipe in the main process
  , 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 qualified Data.Map as Map
import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe)
import Data.List.Extra
import Data.Ord (comparing)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Tuple.Extra
import DynFlags hiding (initDynFlags)
import FastString (unpackFS)
import HeaderInfo (getOptions)
import HscTypes (handleSourceError)
import GHC.IO.Exception (IOErrorType(..))
import GHC.LanguageExtensions.Type (Extension(..))
import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.Annotate
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, GhcTc, GhcRn)
import Language.Haskell.GHC.ExactPrint.Utils
import Panic (handleGhcException)
import StringBuffer (stringToStringBuffer)
import System.IO.Error (mkIOError)
import System.IO.Extra
import System.IO.Unsafe (unsafePerformIO)

import Debug.Trace

#if __GLASGOW_HASKELL__ >= 810
import GHC.Hs.Expr as GHC hiding (Stmt)
import GHC.Hs.ImpExp
import GHC.Hs hiding (Pat, Stmt)
import ErrUtils
import Bag
#else
import HsExpr as GHC hiding (Stmt)
import HsImpExp
import HsSyn hiding (Pat, Stmt, noExt)
#endif

import Outputable hiding ((<>))
import SrcLoc hiding (spans)
import qualified GHC hiding (parseModule)
import qualified Name as GHC
import qualified RdrName as GHC

import Refact.Types hiding (SrcSpan)
import qualified Refact.Types as R
import Refact.Utils (Stmt, Pat, Name, Decl, M, Module, Expr, Type, FunBind, AnnKeyMap
                    , modifyAnnKey, replaceAnnKey, Import, toGhcSrcSpan, toGhcSrcSpan', setSrcSpanFile)

#if __GLASGOW_HASKELL__ >= 810
type Errors = ErrorMessages
onError :: String -> Errors -> a
onError :: String -> Errors -> a
onError String
s = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
s (SDoc -> a) -> (Errors -> SDoc) -> Errors -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> (Errors -> [SDoc]) -> Errors -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Errors -> [SDoc]
pprErrMsgBagWithLoc
#else
type Errors = (SrcSpan, String)
onError :: String -> Errors -> a
onError _ = error . show
#endif

#if __GLASGOW_HASKELL__ <= 806
composeSrcSpan :: a -> a
composeSrcSpan = id

decomposeSrcSpan :: a -> a
decomposeSrcSpan = id

type SrcSpanLess a = a
#endif

-- library access to perform the substitutions

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 a set of refactorings as supplied by hlint
apply
  :: Maybe (Int, Int)
  -> Bool
  -> [(String, [Refactoring R.SrcSpan])]
  -> Maybe FilePath
  -> Verbosity
  -> Anns
  -> Module
  -> IO String
apply :: Maybe (Int, Int)
-> Bool
-> [(String, [Refactoring SrcSpan])]
-> Maybe String
-> Verbosity
-> 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
getLoc Module
m0 of
          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
unpackFS 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
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 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
<> -- s1 first if it starts on earlier line
        (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
<>  --             or on earlier column
        (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
<>   -- they start in same place, s2 comes
        (SrcSpan -> Int) -> SrcSpan -> SrcSpan -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SrcSpan -> Int
endCol SrcSpan
s2 SrcSpan
s1       -- first if it ends later
        -- else, completely same span, so s1 will be first

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Normal) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    String
"Applying " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ([((String, [Refactoring SrcSpan]), SrcSpan)] -> Int)
-> [((String, [Refactoring SrcSpan]), SrcSpan)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall (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 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 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 =
  -- We know s1 always starts <= s2, due to our sort
  case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SrcSpan -> Int
startLine SrcSpan
s2) (SrcSpan -> Int
endLine SrcSpan
s1) of
    Ordering
LT -> Bool
True
    Ordering
EQ -> SrcSpan -> Int
startCol SrcSpan
s2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= SrcSpan -> Int
endCol SrcSpan
s1
    Ordering
GT -> Bool
False

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

refactoringLoop
  :: Anns
  -> Module
  -> [((String, [Refactoring 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
"]"
      -- In case that the input also comes from stdin
      String -> IOMode -> (Handle -> IO String) -> IO String
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
"/dev/tty" IOMode
ReadMode Handle -> IO String
hGetLine
    MaybeT IO (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)

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

-- Perform the substitutions

-- | Peform a @Refactoring@.
runRefactoring
  :: Data a
  => Anns
  -> a
  -> AnnKeyMap
  -> Refactoring 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.
(Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) =>
Anns
-> mod
-> AnnKeyMap
-> Parser a
-> Int
-> Refactoring SrcSpan
-> IO (Anns, mod, AnnKeyMap)
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.
(Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) =>
Anns
-> mod
-> AnnKeyMap
-> Parser a
-> Int
-> Refactoring SrcSpan
-> IO (Anns, mod, AnnKeyMap)
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.
(Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) =>
Anns
-> mod
-> AnnKeyMap
-> Parser a
-> Int
-> Refactoring SrcSpan
-> IO (Anns, mod, AnnKeyMap)
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.
(Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) =>
Anns
-> mod
-> AnnKeyMap
-> Parser a
-> Int
-> Refactoring SrcSpan
-> IO (Anns, mod, AnnKeyMap)
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.
(Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) =>
Anns
-> mod
-> AnnKeyMap
-> Parser a
-> Int
-> Refactoring SrcSpan
-> IO (Anns, mod, AnnKeyMap)
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.
(Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) =>
Anns
-> mod
-> AnnKeyMap
-> Parser a
-> Int
-> Refactoring SrcSpan
-> IO (Anns, mod, AnnKeyMap)
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.
(Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) =>
Anns
-> mod
-> AnnKeyMap
-> Parser a
-> Int
-> Refactoring SrcSpan
-> IO (Anns, mod, AnnKeyMap)
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.
(Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) =>
Anns
-> mod
-> AnnKeyMap
-> Parser a
-> Int
-> Refactoring SrcSpan
-> IO (Anns, mod, AnnKeyMap)
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.
(Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) =>
Anns
-> mod
-> AnnKeyMap
-> Parser a
-> Int
-> Refactoring SrcSpan
-> IO (Anns, mod, AnnKeyMap)
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
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
      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
pos) (SrcSpan -> Bool)
-> (ExprLStmt GhcPs -> SrcSpan) -> ExprLStmt GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExprLStmt GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc)
        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
pos) (SrcSpan -> Bool)
-> (LImportDecl GhcPs -> SrcSpan) -> LImportDecl GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LImportDecl GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc)
        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 @(HsDecl GhcPs) a
m 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 :: LImportDecl GHC.GhcPs -> LImportDecl GHC.GhcPs
      go :: LImportDecl GhcPs -> LImportDecl GhcPs
go imp :: LImportDecl GhcPs
imp@(GHC.L SrcSpan
l ImportDecl GhcPs
i)
        | SrcSpan
l SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== 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)
ideclAs = Maybe (Located ModuleName)
forall a. Maybe a
Nothing })
        | Bool
otherwise =  LImportDecl GhcPs
imp

droppedComments :: Anns -> Module -> AnnKeyMap -> Bool
droppedComments :: Anns -> Module -> AnnKeyMap -> Bool
droppedComments 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 SrcSpan
    allSpans :: Set SrcSpan
allSpans = [SrcSpan] -> Set SrcSpan
forall a. Ord a => [a] -> Set a
Set.fromList (Module -> [SrcSpan]
forall from to. Biplate from to => from -> [to]
universeBi Module
m)

-- Specialised parsers
mkErr :: GHC.DynFlags -> SrcSpan -> String -> Errors
#if __GLASGOW_HASKELL__ >= 810
mkErr :: DynFlags -> SrcSpan -> String -> Errors
mkErr DynFlags
df SrcSpan
l String
s = ErrMsg -> Errors
forall a. a -> Bag a
unitBag (DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
df SrcSpan
l (String -> SDoc
text String
s))
#else
mkErr = const (,)
#endif

parseModuleName :: SrcSpan -> Parser (GHC.Located GHC.ModuleName)
parseModuleName :: SrcSpan -> Parser (Located ModuleName)
parseModuleName SrcSpan
ss DynFlags
_ String
_ String
s =
  let newMN :: Located ModuleName
newMN =  SrcSpan -> ModuleName -> Located ModuleName
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
ss (String -> ModuleName
GHC.mkModuleName String
s)
      newAnns :: Anns
newAnns = Located ModuleName -> ApiAnns -> Anns
forall ast.
(Data (SrcSpanLess ast), Annotate ast, HasSrcSpan ast) =>
ast -> ApiAnns -> Anns
relativiseApiAnns Located ModuleName
newMN (Map ApiAnnKey [SrcSpan]
forall k a. Map k a
Map.empty, Map SrcSpan [Located AnnotationComment]
forall k a. Map k a
Map.empty)
  in (Anns, Located ModuleName)
-> Either Errors (Anns, Located ModuleName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
newAnns, Located ModuleName
newMN)
parseBind :: Parser (GHC.LHsBind GHC.GhcPs)
parseBind :: Parser (LHsBind GhcPs)
parseBind DynFlags
dyn String
fname String
s =
  case Parser (LHsDecl GhcPs)
parseDecl DynFlags
dyn String
fname String
s of
    -- Safe as we add no annotations to the ValD
    Right (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
_) -> Errors -> ParseResult (LHsBind GhcPs)
forall a b. a -> Either a b
Left (DynFlags -> SrcSpan -> String -> Errors
mkErr DynFlags
dyn SrcSpan
l String
"Not a HsBind")
    Left Errors
e -> Errors -> ParseResult (LHsBind GhcPs)
forall a b. a -> Either a b
Left Errors
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
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)])
_   -> Errors -> ParseResult (LMatch GhcPs (LHsExpr GhcPs))
forall a b. a -> Either a b
Left (DynFlags -> SrcSpan -> String -> Errors
mkErr DynFlags
dyn SrcSpan
l String
"Not a single match")
    Right (Anns
_, GHC.L SrcSpan
l HsBind GhcPs
_) -> Errors -> ParseResult (LMatch GhcPs (LHsExpr GhcPs))
forall a b. a -> Either a b
Left (DynFlags -> SrcSpan -> String -> Errors
mkErr DynFlags
dyn SrcSpan
l String
"Not a funbind")
    Left Errors
e -> Errors -> ParseResult (LMatch GhcPs (LHsExpr GhcPs))
forall a b. a -> Either a b
Left Errors
e

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

substTransform :: (Data a, Data b) => b -> [(String, 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, 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
_ (BodyStmt XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
_ (GHC.L SrcSpan
_ (HsVar XVar GhcPs
_ (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, 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
_ (VarPat XVarPat GhcPs
_ (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, 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
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (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, 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
_ (HsVar XVar GhcPs
_ (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

-- Used for Monad10, Monad11 tests.
-- The issue being that in one case the information is attached to a VarPat
-- but we need to move the annotations onto the actual name
--
-- This looks convoluted but we can't match directly on a located name as
-- it is not specific enough. Instead we match on some bigger context which
-- is contains the located name we want to replace.
identSub :: Data a => a -> [(String, 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 :: Located (GHC.Pat GhcPs)
          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
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)
      -- Low level version as we need to combine the annotation information
      -- from the template RdrName and the original VarPat.
      ((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


-- g is usually modifyAnnKey
-- f is usually a function which checks the locations are equal
resolveRdrName' :: (a -> b -> M a)  -- How to combine the value to insert and the replaced value
               -> (SrcSpan -> M b)    -- How to find the new value, when given the location it is in
               -> a                 -- The old thing which we are going to possibly replace
               -> [(String, SrcSpan)] -- Substs
               -> GHC.RdrName       -- The name of the position in the template
                                    --we are replacing into
               -> 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
    -- Todo: this should replace anns as well?
    GHC.Unqual (OccName -> String
GHC.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
GHC.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
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
               -> (SrcSpan -> M (Located old))
               -> Located old
               -> [(String, SrcSpan)]
               -> GHC.RdrName
               -> M (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
insertComment :: AnnKey -> String -> Anns -> Anns
insertComment AnnKey
k String
s Anns
as =
  let comment :: Comment
comment = String -> SrcSpan -> Maybe AnnKeywordId -> Comment
Comment String
s SrcSpan
GHC.noSrcSpan 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


-- Substitute the template into the original AST.
#if __GLASGOW_HASKELL__ <= 806
doGenReplacement
  :: forall ast a. (Data ast, Data a)
  => a
  -> (GHC.Located ast -> Bool)
  -> GHC.Located ast
  -> GHC.Located ast
  -> StateT ((Anns, AnnKeyMap), Bool) IO (GHC.Located ast)
#else
doGenReplacement
  :: forall ast a. (Data (SrcSpanLess ast), HasSrcSpan ast, Data a)
  => a
  -> (ast -> Bool)
  -> ast
  -> ast
  -> StateT ((Anns, AnnKeyMap), Bool) IO ast
#endif
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
  -- If "f a = body where local" doesn't satisfy the predicate, but "f a = body" does,
  -- run the replacement on "f a = body", and add "local" back afterwards.
  -- This is useful for hints like "Eta reduce" and "Redundant where".
  | Just 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) @(HsDecl GHC.GhcPs)
  , L SrcSpan
_ (ValD xvald newBind@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
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
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
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)
fun_matches HsBind GhcPs
newBind
          L SrcSpan
locMG [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]
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
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

          -- Ensure the new Anns properly reflects the local binds we added back.
          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, Annotation) -> Bool
po = \case
                      (AnnKey loc :: SrcSpan
loc@(RealSrcSpan RealSrcSpan
r) AnnConName
con, Annotation
_) ->
                        SrcSpan
loc SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== ast -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
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
srcSpanFile RealSrcSpan
r FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
/= FastString
newFile
                      (AnnKey, Annotation)
_ -> Bool
False
                    pn :: (AnnKey, Annotation) -> Bool
pn = \case
                      (AnnKey loc :: SrcSpan
loc@(RealSrcSpan RealSrcSpan
r) AnnConName
con, Annotation
_) ->
                        SrcSpan
loc SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== 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
srcSpanFile RealSrcSpan
r FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
newFile
                      (AnnKey, Annotation)
_ -> Bool
False
                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, Annotation) -> Bool
po [(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
setSrcSpanFile 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, Annotation) -> Bool
pn [(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

              -- Expand the SrcSpan of the "GRHS" entry in the new file to include the local binds
              expandGRHSLoc :: AnnKey -> AnnKey
expandGRHSLoc = \case
                AnnKey loc :: SrcSpan
loc@(RealSrcSpan RealSrcSpan
r) AnnConName
con
                  | AnnConName
con AnnConName -> AnnConName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> AnnConName
CN String
"GRHS", RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
r FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
newFile -> SrcSpan -> AnnConName -> AnnKey
AnnKey (SrcSpan -> SrcSpan
ensureLoc SrcSpan
loc) AnnConName
con
                AnnKey
other -> AnnKey
other

              -- If an Anns entry corresponds to the local binds, update its file to point to the new file.
              updateFile :: AnnKey -> AnnKey
updateFile = \case
                AnnKey SrcSpan
loc AnnConName
con
                  | SrcSpan
loc SrcSpan -> SrcSpan -> Bool
`isSubspanOf` LHsLocalBinds GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsLocalBinds GhcPs
oldLocal -> SrcSpan -> AnnConName -> AnnKey
AnnKey (FastString -> SrcSpan -> SrcSpan
setSrcSpanFile FastString
newFile SrcSpan
loc) AnnConName
con
                AnnKey
other -> AnnKey
other

              -- For each SrcSpan in the new file that is the entire newLoc, set it to finalLoc
              expandTemplateLoc :: AnnKey -> AnnKey
expandTemplateLoc = \case
                AnnKey SrcSpan
loc AnnConName
con
                  | SrcSpan
loc SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
newLoc -> SrcSpan -> AnnConName -> AnnKey
AnnKey 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

-- | If the input is a FunBind with a single match, e.g., "foo a = body where x = y"
-- return "Just (foo a = body, x = y)". Otherwise return Nothing.
stripLocalBind
  :: LHsDecl GHC.GhcPs
  -> Maybe (LHsDecl GHC.GhcPs, LHsLocalBinds GHC.GhcPs)
stripLocalBind :: LHsDecl GhcPs -> Maybe (LHsDecl GhcPs, LHsLocalBinds GhcPs)
stripLocalBind = \case
  L SrcSpan
_ (ValD XValD GhcPs
xvald origBind :: HsBind GhcPs
origBind@FunBind{})
    | let origMG :: MatchGroup GhcPs (LHsExpr GhcPs)
origMG = HsBind GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs)
forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches HsBind GhcPs
origBind
    , L SrcSpan
locMG [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]
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
m_grhss Match GhcPs (LHsExpr GhcPs)
origMatch
    , [L SrcSpan
_ (GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [ExprLStmt GhcPs]
_ (L SrcSpan
loc2 HsExpr GhcPs
_))] <- GRHSs GhcPs (LHsExpr GhcPs) -> [LGRHS GhcPs (LHsExpr GhcPs)]
forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs GRHSs GhcPs (LHsExpr GhcPs)
origGRHSs ->
      let loc1 :: SrcSpan
loc1 = GenLocated SrcSpan RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (HsBind GhcPs -> GenLocated SrcSpan (IdP GhcPs)
forall idL idR. HsBindLR idL idR -> Located (IdP idL)
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
noLoc (XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
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
grhssLocalBinds GRHSs GhcPs (LHsExpr GhcPs)
origGRHSs)
  LHsDecl GhcPs
_ -> Maybe (LHsDecl GhcPs, LHsLocalBinds GhcPs)
forall a. Maybe a
Nothing

-- | Set the local binds in a HsBind.
setLocalBind
  :: LHsLocalBinds GHC.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
-> 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
L SrcSpan
newLoc (XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD GhcPs
xvald HsBind GhcPs
newBind)
  where
    newGRHSs :: GRHSs GhcPs (LHsExpr GhcPs)
newGRHSs = GRHSs GhcPs (LHsExpr GhcPs)
origGRHSs{grhssLocalBinds :: LHsLocalBinds GhcPs
grhssLocalBinds = LHsLocalBinds GhcPs
newLocalBinds}
    newMatch :: Match GhcPs (LHsExpr GhcPs)
newMatch = Match GhcPs (LHsExpr GhcPs)
origMatch{m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
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)]
mg_alts = SrcSpan
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
locMG [SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
locMatch Match GhcPs (LHsExpr GhcPs)
newMatch]}
    newBind :: HsBind GhcPs
newBind = HsBind GhcPs
origBind{fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = MatchGroup GhcPs (LHsExpr GhcPs)
newMG}

#if __GLASGOW_HASKELL__ <= 806
replaceWorker :: (Annotate a, Data mod)
              => Anns
              -> mod
              -> AnnKeyMap
              -> Parser (GHC.Located a)
              -> Int
              -> Refactoring SrcSpan
              -> IO (Anns, mod, AnnKeyMap)
#else
replaceWorker :: (Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a))
              => Anns
              -> mod
              -> AnnKeyMap
              -> Parser a
              -> Int
              -> Refactoring SrcSpan
              -> IO (Anns, mod, AnnKeyMap)
#endif
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
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
    (Errors -> IO (Anns, a))
-> ((Anns, a) -> IO (Anns, a))
-> Either Errors (Anns, a)
-> IO (Anns, a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Errors -> IO (Anns, a)
forall a. String -> Errors -> a
onError String
"replaceWorker") (Anns, a) -> IO (Anns, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Errors (Anns, a) -> IO (Anns, a))
-> Either Errors (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
GHC.occNameString (OccName -> String) -> (RdrName -> OccName) -> RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
GHC.rdrNameOcc
      adjacent :: SrcSpan -> SrcSpan -> Bool
adjacent (SrcSpan -> SrcLoc
srcSpanEnd -> RealSrcLoc RealSrcLoc
loc1) (SrcSpan -> SrcLoc
srcSpanStart -> RealSrcLoc RealSrcLoc
loc2) = RealSrcLoc
loc1 RealSrcLoc -> RealSrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcLoc
loc2
      adjacent SrcSpan
_ SrcSpan
_ = Bool
False

      -- Return @True@ if the start position of the two spans are on the same line, and differ
      -- by the given number of columns.
      diffStartCols :: Int -> SrcSpan -> SrcSpan -> Bool
      diffStartCols :: Int -> SrcSpan -> SrcSpan -> Bool
diffStartCols Int
x (SrcSpan -> SrcLoc
srcSpanStart -> RealSrcLoc RealSrcLoc
loc1) (SrcSpan -> SrcLoc
srcSpanStart -> RealSrcLoc RealSrcLoc
loc2) =
        RealSrcLoc -> Int
srcLocLine RealSrcLoc
loc1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcLoc -> Int
srcLocLine RealSrcLoc
loc2 Bool -> Bool -> Bool
&& RealSrcLoc -> Int
srcLocCol RealSrcLoc
loc1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- RealSrcLoc -> Int
srcLocCol RealSrcLoc
loc2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
x
      diffStartCols Int
_ SrcSpan
_ SrcSpan
_ = Bool
False

      -- Add a space if needed, so that we avoid refactoring `y = f(x)` into `y = fx`.
      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
        (L SrcSpan
_ (HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
newName))) :: LHsExpr GhcPs <- 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
          GHC.Unqual occName -> OccName -> String
GHC.occNameString OccName
occName
          GHC.Qual moduleName _ -> ModuleName -> String
GHC.moduleNameString ModuleName
moduleName
          GHC.Orig modu _ -> ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
GHC.moduleName Module
modu)
          GHC.Exact name -> OccName -> String
GHC.occNameString (Name -> OccName
GHC.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 :: [LHsExpr GhcPs] =
              (LHsExpr GhcPs -> Bool) -> mod -> [LHsExpr GhcPs]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify
                (\case
                   (L SrcSpan
loc (HsVar XVar GhcPs
_ (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

      -- Add a space if needed, so that we avoid refactoring `y = do(foo bar)` into `y = dofoo bar`.
      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 :: [LHsExpr GhcPs] =
              (LHsExpr GhcPs -> Bool) -> mod -> [LHsExpr GhcPs]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify
                (\case
                  (L SrcSpan
_ HsDo{}) -> Bool
True
                  LHsExpr GhcPs
_ -> Bool
False
                )
                mod
m
            doBlocks' :: [(SrcSpan, Int)]
            doBlocks' :: [(SrcSpan, Int)]
doBlocks' =
              (LHsExpr GhcPs -> (SrcSpan, Int))
-> [LHsExpr GhcPs] -> [(SrcSpan, Int)]
forall a b. (a -> b) -> [a] -> [b]
map
                ( \case
                    L SrcSpan
loc (HsDo XDo GhcPs
_ HsStmtContext Name
MDoExpr Located [ExprLStmt GhcPs]
_) -> (SrcSpan
loc, Int
3)
                    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 :: GenLocated SrcSpan (SrcSpanLess a) -> Bool
replacementPred (GHC.L SrcSpan
l SrcSpanLess a
_) = SrcSpan
l SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
replExprLocation
      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.
(Data (SrcSpanLess ast), HasSrcSpan ast, Data a) =>
a
-> (ast -> Bool)
-> ast
-> ast
-> StateT ((Anns, AnnKeyMap), Bool) IO ast
doGenReplacement mod
m (GenLocated SrcSpan (SrcSpanLess a) -> Bool
replacementPred (GenLocated SrcSpan (SrcSpanLess a) -> Bool)
-> (a -> GenLocated SrcSpan (SrcSpanLess a)) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> GenLocated SrcSpan (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)
    -- Failed to find a replacment so don't make any changes
    (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 :: SrcSpan
  }

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)

-- Find a given type with a given SrcSpan
findInModule :: forall a modu. (Data a, Data modu) => modu -> SrcSpan -> 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. 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 :: SrcSpan -> GHC.Located a -> Maybe (GHC.Located a)
findLargestExpression :: SrcSpan -> Located a -> Maybe (Located a)
findLargestExpression SrcSpan
ss e :: Located a
e@(GHC.L SrcSpan
l a
_)
  | SrcSpan
l SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
ss = Located a -> Maybe (Located a)
forall a. a -> Maybe a
Just Located a
e
  | Bool
otherwise = Maybe (Located a)
forall a. Maybe a
Nothing

findOrError
  :: forall a modu m. (Data a, Data modu, MonadIO m)
  => modu -> SrcSpan -> 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

-- Deletion from a list

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

{-
-- Renaming

doRename :: [(String, String)] -> Module -> Module
doRename ss = everywhere (mkT rename)
  where
    rename :: GHC.OccName -> GHC.OccName
    rename v = GHC.mkOccName n s'
      where
          (s, n) = (GHC.occNameString v, GHC.occNameSpace v)
          s' = fromMaybe s (lookup s ss)
-}

addExtensionsToFlags
  :: [Extension] -> [Extension] -> FilePath -> DynFlags
  -> IO (Either String 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
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
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 Errors (Anns, Module))
parseModuleWithArgs ([Extension]
es, [Extension]
ds) String
fp = Ghc (Either Errors (Anns, Module))
-> IO (Either Errors (Anns, Module))
forall a. Ghc a -> IO a
ghcWrapper (Ghc (Either Errors (Anns, Module))
 -> IO (Either Errors (Anns, Module)))
-> Ghc (Either Errors (Anns, Module))
-> IO (Either Errors (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
    -- TODO: report error properly.
    Left String
err -> Either Errors (Anns, Module) -> Ghc (Either Errors (Anns, Module))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Errors (Anns, Module)
 -> Ghc (Either Errors (Anns, Module)))
-> (Errors -> Either Errors (Anns, Module))
-> Errors
-> Ghc (Either Errors (Anns, Module))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Errors -> Either Errors (Anns, Module)
forall a b. a -> Either a b
Left (Errors -> Ghc (Either Errors (Anns, Module)))
-> Errors -> Ghc (Either Errors (Anns, Module))
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> String -> Errors
mkErr DynFlags
initFlags (FastString -> SrcSpan
UnhelpfulSpan FastString
forall a. Monoid a => a
mempty) 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 Errors (ApiAnns, [Comment], DynFlags, Module)
res <- CppOptions
-> DynFlags
-> String
-> Ghc (Either Errors (ApiAnns, [Comment], DynFlags, Module))
forall (m :: * -> *).
GhcMonad m =>
CppOptions
-> DynFlags
-> String
-> m (Either Errors (ApiAnns, [Comment], DynFlags, Module))
parseModuleApiAnnsWithCppInternal CppOptions
defaultCppOptions DynFlags
flags String
fp
      Either Errors (Anns, Module) -> Ghc (Either Errors (Anns, Module))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Errors (Anns, Module)
 -> Ghc (Either Errors (Anns, Module)))
-> Either Errors (Anns, Module)
-> Ghc (Either Errors (Anns, Module))
forall a b. (a -> b) -> a -> b
$ Either Errors (ApiAnns, [Comment], DynFlags, Module)
-> DeltaOptions -> Either Errors (Anns, Module)
forall a.
Either a (ApiAnns, [Comment], DynFlags, Module)
-> DeltaOptions -> Either a (Anns, Module)
postParseTransform Either Errors (ApiAnns, [Comment], DynFlags, Module)
res DeltaOptions
rigidLayout

-- | Parse the input into (enabled extensions, disabled extensions, invalid input).
-- Implied extensions are automatically added. For example, @FunctionalDependencies@
-- implies @MultiParamTypeClasses@, and @RebindableSyntax@ implies @NoImplicitPrelude@.
--
-- The input is processed from left to right. An extension (e.g., @StarIsType@)
-- may be overridden later (e.g., by @NoStarIsType@).
--
-- Extensions that appear earlier in the input will appear later in the output.
-- Implied extensions appear in the end. If an extension occurs multiple times in the input,
-- the last one is used.
--
-- >>> parseExtensions ["GADTs", "RebindableSyntax", "StarIsType", "GADTs", "InvalidExtension", "NoStarIsType"]
-- ([GADTs, RebindableSyntax, GADTSyntax, MonoLocalBinds], [StarIsType, ImplicitPrelude], ["InvalidExtension"])
parseExtensions :: [String] -> ([Extension], [Extension], [String])
parseExtensions :: [String] -> ([Extension], [Extension], [String])
parseExtensions = ([Extension], [Extension], [String])
-> ([Extension], [Extension], [String])
addImplied (([Extension], [Extension], [String])
 -> ([Extension], [Extension], [String]))
-> ([String] -> ([Extension], [Extension], [String]))
-> [String]
-> ([Extension], [Extension], [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Extension], [Extension], [String])
 -> String -> ([Extension], [Extension], [String]))
-> ([Extension], [Extension], [String])
-> [String]
-> ([Extension], [Extension], [String])
forall (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

-- | Copied from "Language.Haskell.GhclibParserEx.GHC.Driver.Session", in order to
-- support GHC 8.6
impliedXFlags :: [(Extension, Bool, Extension)]
impliedXFlags :: [(Extension, Bool, Extension)]
impliedXFlags
-- See Note [Updating flag description in the User's Guide]
  = [ (Extension
RankNTypes,                Bool
True, Extension
ExplicitForAll)
    , (Extension
QuantifiedConstraints,     Bool
True, Extension
ExplicitForAll)
    , (Extension
ScopedTypeVariables,       Bool
True, Extension
ExplicitForAll)
    , (Extension
LiberalTypeSynonyms,       Bool
True, Extension
ExplicitForAll)
    , (Extension
ExistentialQuantification, Bool
True, Extension
ExplicitForAll)
    , (Extension
FlexibleInstances,         Bool
True, Extension
TypeSynonymInstances)
    , (Extension
FunctionalDependencies,    Bool
True, Extension
MultiParamTypeClasses)
    , (Extension
MultiParamTypeClasses,     Bool
True, Extension
ConstrainedClassMethods)  -- c.f. #7854
    , (Extension
TypeFamilyDependencies,    Bool
True, Extension
TypeFamilies)

    , (Extension
RebindableSyntax, Bool
False, Extension
ImplicitPrelude)      -- NB: turn off!

    , (Extension
DerivingVia, Bool
True, Extension
DerivingStrategies)

    , (Extension
GADTs,            Bool
True, Extension
GADTSyntax)
    , (Extension
GADTs,            Bool
True, Extension
MonoLocalBinds)
    , (Extension
TypeFamilies,     Bool
True, Extension
MonoLocalBinds)

    , (Extension
TypeFamilies,     Bool
True, Extension
KindSignatures)  -- Type families use kind signatures
    , (Extension
PolyKinds,        Bool
True, Extension
KindSignatures)  -- Ditto polymorphic kinds

    -- TypeInType is now just a synonym for a couple of other extensions.
    , (Extension
TypeInType,       Bool
True, Extension
DataKinds)
    , (Extension
TypeInType,       Bool
True, Extension
PolyKinds)
    , (Extension
TypeInType,       Bool
True, Extension
KindSignatures)

    -- AutoDeriveTypeable is not very useful without DeriveDataTypeable
    , (Extension
AutoDeriveTypeable, Bool
True, Extension
DeriveDataTypeable)

    -- We turn this on so that we can export associated type
    -- type synonyms in subordinates (e.g. MyClass(type AssocType))
    , (Extension
TypeFamilies,     Bool
True, Extension
ExplicitNamespaces)
    , (Extension
TypeOperators, Bool
True, Extension
ExplicitNamespaces)

    , (Extension
ImpredicativeTypes,  Bool
True, Extension
RankNTypes)

        -- Record wild-cards implies field disambiguation
        -- Otherwise if you write (C {..}) you may well get
        -- stuff like " 'a' not in scope ", which is a bit silly
        -- if the compiler has just filled in field 'a' of constructor 'C'
    , (Extension
RecordWildCards,     Bool
True, Extension
DisambiguateRecordFields)

    , (Extension
ParallelArrays, Bool
True, Extension
ParallelListComp)

    , (Extension
JavaScriptFFI, Bool
True, Extension
InterruptibleFFI)

    , (Extension
DeriveTraversable, Bool
True, Extension
DeriveFunctor)
    , (Extension
DeriveTraversable, Bool
True, Extension
DeriveFoldable)

    -- Duplicate record fields require field disambiguation
    , (Extension
DuplicateRecordFields, Bool
True, Extension
DisambiguateRecordFields)

    , (Extension
TemplateHaskell, Bool
True, Extension
TemplateHaskellQuotes)
    , (Extension
Strict, Bool
True, Extension
StrictData)
#if __GLASGOW_HASKELL__ >= 810
    , (Extension
StandaloneKindSignatures, Bool
False, Extension
CUSKs)
#endif
  ]

-- TODO: This is added to avoid a breaking change. We should remove it and
-- directly pass the `DynFlags` as arguments, before the 0.10 release.
dynFlagsRef :: IORef (Maybe 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 #-}