{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.GHC.ExactPrint.Transform
--
-- This module is currently under heavy development, and no promises are made
-- about API stability. Use with care.
--
-- We welcome any feedback / contributions on this, as it is the main point of
-- the library.
--
-----------------------------------------------------------------------------
module Language.Haskell.GHC.ExactPrint.Transform
        (
        -- * The Transform Monad
          Transform
        , TransformT(..)
        , hoistTransform
        , runTransform
        , runTransformT
        , runTransformFrom
        , runTransformFromT

        -- * Transform monad operations
        , logTr
        , logDataWithAnnsTr
        , getAnnsT, putAnnsT, modifyAnnsT
        , uniqueSrcSpanT

        , cloneT
        , graftT

        , getEntryDPT
        , setEntryDPT
        , transferEntryDPT
        , setPrecedingLinesDeclT
        , setPrecedingLinesT
        , addSimpleAnnT
        , addTrailingCommaT
        , removeTrailingCommaT

        -- ** Managing declarations, in Transform monad
        , HasTransform (..)
        , HasDecls (..)
        , hasDeclsSybTransform
        , hsDeclsGeneric
        , hsDeclsPatBind, hsDeclsPatBindD
        , replaceDeclsPatBind, replaceDeclsPatBindD
        , modifyDeclsT
        , modifyValD
        -- *** Utility, does not manage layout
        , hsDeclsValBinds, replaceDeclsValbinds

        -- ** Managing lists, Transform monad
        , insertAtStart
        , insertAtEnd
        , insertAfter
        , insertBefore

        -- *** Low level operations used in 'HasDecls'
        , balanceComments
        , balanceTrailingComments
        , moveTrailingComments

        -- ** Managing lists, pure functions
        , captureOrder
        , captureOrderAnnKey

        -- * Operations
        , isUniqueSrcSpan

        -- * Pure functions
        , mergeAnns
        , mergeAnnList
        , setPrecedingLinesDecl
        , setPrecedingLines
        , getEntryDP
        , setEntryDP
        , transferEntryDP
        , addTrailingComma
        , wrapSig, wrapDecl
        , decl2Sig, decl2Bind

        ) where

import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Utils

import Control.Monad.RWS
import qualified Control.Monad.Fail as Fail

import qualified Bag           as GHC
import qualified FastString    as GHC
import qualified GHC           as GHC hiding (parseModule)

import qualified Data.Generics as SYB

import Data.Data
import Data.List
import Data.Maybe

import qualified Data.Map as Map

import Data.Functor.Identity
import Control.Monad.State
import Control.Monad.Writer

-- import Debug.Trace

------------------------------------------------------------------------------
-- Transformation of source elements

-- | Monad type for updating the AST and managing the annotations at the same
-- time. The W state is used to generate logging information if required.
type Transform = TransformT Identity

-- |Monad transformer version of 'Transform' monad
newtype TransformT m a = TransformT { TransformT m a -> RWST () [String] (Anns, Int) m a
unTransformT :: RWST () [String] (Anns,Int) m a }
                deriving (Applicative (TransformT m)
a -> TransformT m a
Applicative (TransformT m)
-> (forall a b.
    TransformT m a -> (a -> TransformT m b) -> TransformT m b)
-> (forall a b. TransformT m a -> TransformT m b -> TransformT m b)
-> (forall a. a -> TransformT m a)
-> Monad (TransformT m)
TransformT m a -> (a -> TransformT m b) -> TransformT m b
TransformT m a -> TransformT m b -> TransformT m b
forall a. a -> TransformT m a
forall a b. TransformT m a -> TransformT m b -> TransformT m b
forall a b.
TransformT m a -> (a -> TransformT m b) -> TransformT m b
forall (m :: * -> *). Monad m => Applicative (TransformT m)
forall (m :: * -> *) a. Monad m => a -> TransformT m a
forall (m :: * -> *) a b.
Monad m =>
TransformT m a -> TransformT m b -> TransformT m b
forall (m :: * -> *) a b.
Monad m =>
TransformT m a -> (a -> TransformT m b) -> TransformT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> TransformT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> TransformT m a
>> :: TransformT m a -> TransformT m b -> TransformT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
TransformT m a -> TransformT m b -> TransformT m b
>>= :: TransformT m a -> (a -> TransformT m b) -> TransformT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
TransformT m a -> (a -> TransformT m b) -> TransformT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (TransformT m)
Monad,Functor (TransformT m)
a -> TransformT m a
Functor (TransformT m)
-> (forall a. a -> TransformT m a)
-> (forall a b.
    TransformT m (a -> b) -> TransformT m a -> TransformT m b)
-> (forall a b c.
    (a -> b -> c)
    -> TransformT m a -> TransformT m b -> TransformT m c)
-> (forall a b. TransformT m a -> TransformT m b -> TransformT m b)
-> (forall a b. TransformT m a -> TransformT m b -> TransformT m a)
-> Applicative (TransformT m)
TransformT m a -> TransformT m b -> TransformT m b
TransformT m a -> TransformT m b -> TransformT m a
TransformT m (a -> b) -> TransformT m a -> TransformT m b
(a -> b -> c) -> TransformT m a -> TransformT m b -> TransformT m c
forall a. a -> TransformT m a
forall a b. TransformT m a -> TransformT m b -> TransformT m a
forall a b. TransformT m a -> TransformT m b -> TransformT m b
forall a b.
TransformT m (a -> b) -> TransformT m a -> TransformT m b
forall a b c.
(a -> b -> c) -> TransformT m a -> TransformT m b -> TransformT m c
forall (m :: * -> *). Monad m => Functor (TransformT m)
forall (m :: * -> *) a. Monad m => a -> TransformT m a
forall (m :: * -> *) a b.
Monad m =>
TransformT m a -> TransformT m b -> TransformT m a
forall (m :: * -> *) a b.
Monad m =>
TransformT m a -> TransformT m b -> TransformT m b
forall (m :: * -> *) a b.
Monad m =>
TransformT m (a -> b) -> TransformT m a -> TransformT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> TransformT m a -> TransformT m b -> TransformT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: TransformT m a -> TransformT m b -> TransformT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
TransformT m a -> TransformT m b -> TransformT m a
*> :: TransformT m a -> TransformT m b -> TransformT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
TransformT m a -> TransformT m b -> TransformT m b
liftA2 :: (a -> b -> c) -> TransformT m a -> TransformT m b -> TransformT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> TransformT m a -> TransformT m b -> TransformT m c
<*> :: TransformT m (a -> b) -> TransformT m a -> TransformT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
TransformT m (a -> b) -> TransformT m a -> TransformT m b
pure :: a -> TransformT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> TransformT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (TransformT m)
Applicative,a -> TransformT m b -> TransformT m a
(a -> b) -> TransformT m a -> TransformT m b
(forall a b. (a -> b) -> TransformT m a -> TransformT m b)
-> (forall a b. a -> TransformT m b -> TransformT m a)
-> Functor (TransformT m)
forall a b. a -> TransformT m b -> TransformT m a
forall a b. (a -> b) -> TransformT m a -> TransformT m b
forall (m :: * -> *) a b.
Functor m =>
a -> TransformT m b -> TransformT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TransformT m a -> TransformT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TransformT m b -> TransformT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> TransformT m b -> TransformT m a
fmap :: (a -> b) -> TransformT m a -> TransformT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TransformT m a -> TransformT m b
Functor
                         ,MonadReader ()
                         ,MonadWriter [String]
                         ,MonadState (Anns,Int)
                         ,m a -> TransformT m a
(forall (m :: * -> *) a. Monad m => m a -> TransformT m a)
-> MonadTrans TransformT
forall (m :: * -> *) a. Monad m => m a -> TransformT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> TransformT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> TransformT m a
MonadTrans
                         )

instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where
    fail :: String -> TransformT m a
fail String
msg = RWST () [String] (Anns, Int) m a -> TransformT m a
forall (m :: * -> *) a.
RWST () [String] (Anns, Int) m a -> TransformT m a
TransformT (RWST () [String] (Anns, Int) m a -> TransformT m a)
-> RWST () [String] (Anns, Int) m a -> TransformT m a
forall a b. (a -> b) -> a -> b
$ (() -> (Anns, Int) -> m (a, (Anns, Int), [String]))
-> RWST () [String] (Anns, Int) m a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWST ((() -> (Anns, Int) -> m (a, (Anns, Int), [String]))
 -> RWST () [String] (Anns, Int) m a)
-> (() -> (Anns, Int) -> m (a, (Anns, Int), [String]))
-> RWST () [String] (Anns, Int) m a
forall a b. (a -> b) -> a -> b
$ \()
_ (Anns, Int)
_ -> String -> m (a, (Anns, Int), [String])
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
msg

-- | Run a transformation in the 'Transform' monad, returning the updated
-- annotations and any logging generated via 'logTr'
runTransform :: Anns -> Transform a -> (a,(Anns,Int),[String])
runTransform :: Anns -> Transform a -> (a, (Anns, Int), [String])
runTransform Anns
ans Transform a
f = Int -> Anns -> Transform a -> (a, (Anns, Int), [String])
forall a. Int -> Anns -> Transform a -> (a, (Anns, Int), [String])
runTransformFrom Int
0 Anns
ans Transform a
f

runTransformT :: Anns -> TransformT m a -> m (a,(Anns,Int),[String])
runTransformT :: Anns -> TransformT m a -> m (a, (Anns, Int), [String])
runTransformT Anns
ans TransformT m a
f = Int -> Anns -> TransformT m a -> m (a, (Anns, Int), [String])
forall (m :: * -> *) a.
Int -> Anns -> TransformT m a -> m (a, (Anns, Int), [String])
runTransformFromT Int
0 Anns
ans TransformT m a
f

-- | Run a transformation in the 'Transform' monad, returning the updated
-- annotations and any logging generated via 'logTr', allocating any new
-- SrcSpans from the provided initial value.
runTransformFrom :: Int -> Anns -> Transform a -> (a,(Anns,Int),[String])
runTransformFrom :: Int -> Anns -> Transform a -> (a, (Anns, Int), [String])
runTransformFrom Int
seed Anns
ans Transform a
f = RWS () [String] (Anns, Int) a
-> () -> (Anns, Int) -> (a, (Anns, Int), [String])
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS (Transform a -> RWS () [String] (Anns, Int) a
forall (m :: * -> *) a.
TransformT m a -> RWST () [String] (Anns, Int) m a
unTransformT Transform a
f) () (Anns
ans,Int
seed)

-- |Run a monad transformer stack for the 'TransformT' monad transformer
runTransformFromT :: Int -> Anns -> TransformT m a -> m (a,(Anns,Int),[String])
runTransformFromT :: Int -> Anns -> TransformT m a -> m (a, (Anns, Int), [String])
runTransformFromT Int
seed Anns
ans TransformT m a
f = RWST () [String] (Anns, Int) m a
-> () -> (Anns, Int) -> m (a, (Anns, Int), [String])
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (TransformT m a -> RWST () [String] (Anns, Int) m a
forall (m :: * -> *) a.
TransformT m a -> RWST () [String] (Anns, Int) m a
unTransformT TransformT m a
f) () (Anns
ans,Int
seed)

-- | Change inner monad of 'TransformT'.
hoistTransform :: (forall x. m x -> n x) -> TransformT m a -> TransformT n a
hoistTransform :: (forall x. m x -> n x) -> TransformT m a -> TransformT n a
hoistTransform forall x. m x -> n x
nt (TransformT RWST () [String] (Anns, Int) m a
m) = RWST () [String] (Anns, Int) n a -> TransformT n a
forall (m :: * -> *) a.
RWST () [String] (Anns, Int) m a -> TransformT m a
TransformT ((m (a, (Anns, Int), [String]) -> n (a, (Anns, Int), [String]))
-> RWST () [String] (Anns, Int) m a
-> RWST () [String] (Anns, Int) n a
forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
mapRWST m (a, (Anns, Int), [String]) -> n (a, (Anns, Int), [String])
forall x. m x -> n x
nt RWST () [String] (Anns, Int) m a
m)

-- |Log a string to the output of the Monad
logTr :: (Monad m) => String -> TransformT m ()
logTr :: String -> TransformT m ()
logTr String
str = [String] -> TransformT m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
str]

-- |Log a representation of the given AST with annotations to the output of the
-- Monad
logDataWithAnnsTr :: (Monad m) => (SYB.Data a) => String -> a -> TransformT m ()
logDataWithAnnsTr :: String -> a -> TransformT m ()
logDataWithAnnsTr String
str a
ast = do
  Anns
anns <- TransformT m Anns
forall (m :: * -> *). Monad m => TransformT m Anns
getAnnsT
  String -> TransformT m ()
forall (m :: * -> *). Monad m => String -> TransformT m ()
logTr (String -> TransformT m ()) -> String -> TransformT m ()
forall a b. (a -> b) -> a -> b
$ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ Anns -> Int -> a -> String
forall a. Data a => Anns -> Int -> a -> String
showAnnData Anns
anns Int
0 a
ast

-- |Access the 'Anns' being modified in this transformation
getAnnsT :: (Monad m) => TransformT m Anns
getAnnsT :: TransformT m Anns
getAnnsT = ((Anns, Int) -> Anns) -> TransformT m Anns
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Anns, Int) -> Anns
forall a b. (a, b) -> a
fst

-- |Replace the 'Anns' after any changes
putAnnsT :: (Monad m) => Anns -> TransformT m ()
putAnnsT :: Anns -> TransformT m ()
putAnnsT Anns
ans = do
  (Anns
_,Int
col) <- TransformT m (Anns, Int)
forall s (m :: * -> *). MonadState s m => m s
get
  (Anns, Int) -> TransformT m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Anns
ans,Int
col)

-- |Change the stored 'Anns'
modifyAnnsT :: (Monad m) => (Anns -> Anns) -> TransformT m ()
modifyAnnsT :: (Anns -> Anns) -> TransformT m ()
modifyAnnsT Anns -> Anns
f = do
  Anns
ans <- TransformT m Anns
forall (m :: * -> *). Monad m => TransformT m Anns
getAnnsT
  Anns -> TransformT m ()
forall (m :: * -> *). Monad m => Anns -> TransformT m ()
putAnnsT (Anns -> Anns
f Anns
ans)

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

-- |Once we have 'Anns', a 'GHC.SrcSpan' is used purely as part of an 'AnnKey'
-- to index into the 'Anns'. If we need to add new elements to the AST, they
-- need their own 'GHC.SrcSpan' for this.
uniqueSrcSpanT :: (Monad m) => TransformT m GHC.SrcSpan
uniqueSrcSpanT :: TransformT m SrcSpan
uniqueSrcSpanT = do
  (Anns
an,Int
col) <- TransformT m (Anns, Int)
forall s (m :: * -> *). MonadState s m => m s
get
  (Anns, Int) -> TransformT m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Anns
an,Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 )
  let pos :: SrcLoc
pos = FastString -> Int -> Int -> SrcLoc
GHC.mkSrcLoc (String -> FastString
GHC.mkFastString String
"ghc-exactprint") (-Int
1) Int
col
  SrcSpan -> TransformT m SrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> TransformT m SrcSpan)
-> SrcSpan -> TransformT m SrcSpan
forall a b. (a -> b) -> a -> b
$ SrcLoc -> SrcLoc -> SrcSpan
GHC.mkSrcSpan SrcLoc
pos SrcLoc
pos

-- |Test whether a given 'GHC.SrcSpan' was generated by 'uniqueSrcSpanT'
isUniqueSrcSpan :: GHC.SrcSpan -> Bool
isUniqueSrcSpan :: SrcSpan -> Bool
isUniqueSrcSpan SrcSpan
ss = SrcSpan -> Int
srcSpanStartLine SrcSpan
ss Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1

-- ---------------------------------------------------------------------
-- |Make a copy of an AST element, replacing the existing SrcSpans with new
-- ones, and duplicating the matching annotations.
cloneT :: (Data a,Monad m) => a -> TransformT m (a, [(GHC.SrcSpan, GHC.SrcSpan)])
cloneT :: a -> TransformT m (a, [(SrcSpan, SrcSpan)])
cloneT a
ast = do
  WriterT [(SrcSpan, SrcSpan)] (TransformT m) a
-> TransformT m (a, [(SrcSpan, SrcSpan)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(SrcSpan, SrcSpan)] (TransformT m) a
 -> TransformT m (a, [(SrcSpan, SrcSpan)]))
-> WriterT [(SrcSpan, SrcSpan)] (TransformT m) a
-> TransformT m (a, [(SrcSpan, SrcSpan)])
forall a b. (a -> b) -> a -> b
$ GenericM (WriterT [(SrcSpan, SrcSpan)] (TransformT m))
-> a -> WriterT [(SrcSpan, SrcSpan)] (TransformT m) a
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
SYB.everywhereM (GenericM (WriterT [(SrcSpan, SrcSpan)] (TransformT m))
forall (m :: * -> *) a. Monad m => a -> m a
return GenericM (WriterT [(SrcSpan, SrcSpan)] (TransformT m))
-> (forall d1 d2.
    (Data d1, Data d2) =>
    GenLocated d1 d2
    -> WriterT [(SrcSpan, SrcSpan)] (TransformT m) (GenLocated d1 d2))
-> a
-> WriterT [(SrcSpan, SrcSpan)] (TransformT m) a
forall (m :: * -> *) d (t :: * -> * -> *).
(Monad m, Data d, Typeable t) =>
(forall e. Data e => e -> m e)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2))
-> d
-> m d
`SYB.ext2M` forall d1 d2.
(Data d1, Data d2) =>
GenLocated d1 d2
-> WriterT [(SrcSpan, SrcSpan)] (TransformT m) (GenLocated d1 d2)
forall loc a (m :: * -> *).
(Typeable loc, Data a, Monad m) =>
GenLocated loc a
-> WriterT [(SrcSpan, SrcSpan)] (TransformT m) (GenLocated loc a)
replaceLocated) a
ast
  where
    replaceLocated :: forall loc a m. (Typeable loc,Data a,Monad m)
                    => (GHC.GenLocated loc a) -> WriterT [(GHC.SrcSpan, GHC.SrcSpan)] (TransformT m) (GHC.GenLocated loc a)
    replaceLocated :: GenLocated loc a
-> WriterT [(SrcSpan, SrcSpan)] (TransformT m) (GenLocated loc a)
replaceLocated (GHC.L loc
l a
t) = do
      case loc -> Maybe SrcSpan
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast loc
l :: Maybe GHC.SrcSpan of
        Just SrcSpan
ss -> do
          SrcSpan
newSpan <- TransformT m SrcSpan
-> WriterT [(SrcSpan, SrcSpan)] (TransformT m) SrcSpan
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TransformT m SrcSpan
forall (m :: * -> *). Monad m => TransformT m SrcSpan
uniqueSrcSpanT
          TransformT m () -> WriterT [(SrcSpan, SrcSpan)] (TransformT m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TransformT m () -> WriterT [(SrcSpan, SrcSpan)] (TransformT m) ())
-> TransformT m ()
-> WriterT [(SrcSpan, SrcSpan)] (TransformT m) ()
forall a b. (a -> b) -> a -> b
$ (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (\Anns
anns -> case AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (GenLocated SrcSpan a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey (SrcSpan -> a -> GenLocated SrcSpan a
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
ss a
t)) Anns
anns of
                                  Maybe Annotation
Nothing -> Anns
anns
                                  Just Annotation
an -> AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (GenLocated SrcSpan a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey (SrcSpan -> a -> GenLocated SrcSpan a
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
newSpan a
t)) Annotation
an Anns
anns)
          [(SrcSpan, SrcSpan)]
-> WriterT [(SrcSpan, SrcSpan)] (TransformT m) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(SrcSpan
ss, SrcSpan
newSpan)]
          GenLocated loc a
-> WriterT [(SrcSpan, SrcSpan)] (TransformT m) (GenLocated loc a)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated loc a
 -> WriterT [(SrcSpan, SrcSpan)] (TransformT m) (GenLocated loc a))
-> GenLocated loc a
-> WriterT [(SrcSpan, SrcSpan)] (TransformT m) (GenLocated loc a)
forall a b. (a -> b) -> a -> b
$ Maybe (GenLocated loc a) -> GenLocated loc a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (GenLocated loc a) -> GenLocated loc a)
-> (GenLocated SrcSpan a -> Maybe (GenLocated loc a))
-> GenLocated SrcSpan a
-> GenLocated loc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan a -> Maybe (GenLocated loc a)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast  (GenLocated SrcSpan a -> GenLocated loc a)
-> GenLocated SrcSpan a -> GenLocated loc a
forall a b. (a -> b) -> a -> b
$ SrcSpan -> a -> GenLocated SrcSpan a
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
newSpan a
t
        Maybe SrcSpan
Nothing -> GenLocated loc a
-> WriterT [(SrcSpan, SrcSpan)] (TransformT m) (GenLocated loc a)
forall (m :: * -> *) a. Monad m => a -> m a
return (loc -> a -> GenLocated loc a
forall l e. l -> e -> GenLocated l e
GHC.L loc
l a
t)

-- ---------------------------------------------------------------------
-- |Slightly more general form of cloneT
graftT :: (Data a,Monad m) => Anns -> a -> TransformT m a
graftT :: Anns -> a -> TransformT m a
graftT Anns
origAnns = GenericM (TransformT m) -> GenericM (TransformT m)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
SYB.everywhereM (GenericM (TransformT m)
forall (m :: * -> *) a. Monad m => a -> m a
return GenericM (TransformT m)
-> (forall d1 d2.
    (Data d1, Data d2) =>
    GenLocated d1 d2 -> TransformT m (GenLocated d1 d2))
-> a
-> TransformT m a
forall (m :: * -> *) d (t :: * -> * -> *).
(Monad m, Data d, Typeable t) =>
(forall e. Data e => e -> m e)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2))
-> d
-> m d
`SYB.ext2M` forall d1 d2.
(Data d1, Data d2) =>
GenLocated d1 d2 -> TransformT m (GenLocated d1 d2)
forall loc a (m :: * -> *).
(Typeable loc, Data a, Monad m) =>
GenLocated loc a -> TransformT m (GenLocated loc a)
replaceLocated)
  where
    replaceLocated :: forall loc a m. (Typeable loc, Data a, Monad m)
                    => GHC.GenLocated loc a -> TransformT m (GHC.GenLocated loc a)
    replaceLocated :: GenLocated loc a -> TransformT m (GenLocated loc a)
replaceLocated (GHC.L loc
l a
t) = do
      case loc -> Maybe SrcSpan
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast loc
l :: Maybe GHC.SrcSpan of
        Just SrcSpan
ss -> do
          SrcSpan
newSpan <- TransformT m SrcSpan
forall (m :: * -> *). Monad m => TransformT m SrcSpan
uniqueSrcSpanT
          (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (\Anns
anns -> case AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (GenLocated SrcSpan a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey (SrcSpan -> a -> GenLocated SrcSpan a
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
ss a
t)) Anns
origAnns of
                                  Maybe Annotation
Nothing -> Anns
anns
                                  Just Annotation
an -> AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (GenLocated SrcSpan a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey (SrcSpan -> a -> GenLocated SrcSpan a
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
newSpan a
t)) Annotation
an Anns
anns)
          GenLocated loc a -> TransformT m (GenLocated loc a)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated loc a -> TransformT m (GenLocated loc a))
-> GenLocated loc a -> TransformT m (GenLocated loc a)
forall a b. (a -> b) -> a -> b
$ Maybe (GenLocated loc a) -> GenLocated loc a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (GenLocated loc a) -> GenLocated loc a)
-> Maybe (GenLocated loc a) -> GenLocated loc a
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan a -> Maybe (GenLocated loc a)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (GenLocated SrcSpan a -> Maybe (GenLocated loc a))
-> GenLocated SrcSpan a -> Maybe (GenLocated loc a)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> a -> GenLocated SrcSpan a
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
newSpan a
t
        Maybe SrcSpan
Nothing -> GenLocated loc a -> TransformT m (GenLocated loc a)
forall (m :: * -> *) a. Monad m => a -> m a
return (loc -> a -> GenLocated loc a
forall l e. l -> e -> GenLocated l e
GHC.L loc
l a
t)

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

-- |If a list has been re-ordered or had items added, capture the new order in
-- the appropriate 'annSortKey' attached to the 'Annotation' for the first
-- parameter.
captureOrder :: (Data a) => GHC.Located a -> [GHC.Located b] -> Anns -> Anns
captureOrder :: Located a -> [Located b] -> Anns -> Anns
captureOrder Located a
parent [Located b]
ls Anns
ans = AnnKey -> [Located b] -> Anns -> Anns
forall b. AnnKey -> [Located b] -> Anns -> Anns
captureOrderAnnKey (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
parent) [Located b]
ls Anns
ans

-- |If a list has been re-ordered or had items added, capture the new order in
-- the appropriate 'annSortKey' item of the supplied 'AnnKey'
captureOrderAnnKey :: AnnKey -> [GHC.Located b] -> Anns -> Anns
captureOrderAnnKey :: AnnKey -> [Located b] -> Anns -> Anns
captureOrderAnnKey AnnKey
parentKey [Located b]
ls Anns
ans = Anns
ans'
  where
    newList :: [SrcSpan]
newList = (Located b -> SrcSpan) -> [Located b] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Located b -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc [Located b]
ls
    reList :: Anns -> Anns
reList = (Annotation -> Annotation) -> AnnKey -> Anns -> Anns
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\Annotation
an -> Annotation
an {annSortKey :: Maybe [SrcSpan]
annSortKey = [SrcSpan] -> Maybe [SrcSpan]
forall a. a -> Maybe a
Just [SrcSpan]
newList }) AnnKey
parentKey
    ans' :: Anns
ans' = Anns -> Anns
reList Anns
ans

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

-- |Pure function to convert a 'GHC.LHsDecl' to a 'GHC.LHsBind'. This does
-- nothing to any annotations that may be attached to either of the elements.
-- It is used as a utility function in 'replaceDecls'
decl2Bind :: GHC.LHsDecl name -> [GHC.LHsBind name]
#if __GLASGOW_HASKELL__ > 804
decl2Bind :: LHsDecl name -> [LHsBind name]
decl2Bind (GHC.L SrcSpan
l (GHC.ValD XValD name
_ HsBind name
s)) = [SrcSpan -> HsBind name -> LHsBind name
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l HsBind name
s]
#else
decl2Bind (GHC.L l (GHC.ValD s)) = [GHC.L l s]
#endif
decl2Bind LHsDecl name
_                      = []

-- |Pure function to convert a 'GHC.LSig' to a 'GHC.LHsBind'. This does
-- nothing to any annotations that may be attached to either of the elements.
-- It is used as a utility function in 'replaceDecls'
decl2Sig :: GHC.LHsDecl name -> [GHC.LSig name]
#if __GLASGOW_HASKELL__ > 804
decl2Sig :: LHsDecl name -> [LSig name]
decl2Sig (GHC.L SrcSpan
l (GHC.SigD XSigD name
_ Sig name
s)) = [SrcSpan -> Sig name -> LSig name
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l Sig name
s]
#else
decl2Sig (GHC.L l (GHC.SigD s)) = [GHC.L l s]
#endif
decl2Sig LHsDecl name
_                      = []

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

-- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl'
wrapSig :: GHC.LSig GhcPs -> GHC.LHsDecl GhcPs
#if __GLASGOW_HASKELL__ > 808
wrapSig :: LSig GhcPs -> LHsDecl GhcPs
wrapSig (GHC.L SrcSpan
l Sig GhcPs
s) = SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
GHC.SigD NoExtField
XSigD GhcPs
GHC.NoExtField Sig GhcPs
s)
#elif __GLASGOW_HASKELL__ > 804
wrapSig (GHC.L l s) = GHC.L l (GHC.SigD GHC.noExt s)
#else
wrapSig (GHC.L l s) = GHC.L l (GHC.SigD s)
#endif

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

-- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl'
wrapDecl :: GHC.LHsBind GhcPs -> GHC.LHsDecl GhcPs
#if __GLASGOW_HASKELL__ > 808
wrapDecl :: LHsBind GhcPs -> LHsDecl GhcPs
wrapDecl (GHC.L SrcSpan
l HsBindLR GhcPs GhcPs
s) = SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XValD GhcPs -> HsBindLR GhcPs GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
GHC.ValD NoExtField
XValD GhcPs
GHC.NoExtField HsBindLR GhcPs GhcPs
s)
#elif __GLASGOW_HASKELL__ > 804
wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD GHC.noExt s)
#else
wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD s)
#endif

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

-- |Create a simple 'Annotation' without comments, and attach it to the first
-- parameter.
addSimpleAnnT :: (Constraints a,Monad m)
#if __GLASGOW_HASKELL__ >= 808
              => a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m ()
#else
              => GHC.Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m ()
#endif
addSimpleAnnT :: a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m ()
addSimpleAnnT a
ast DeltaPos
dp [(KeywordId, DeltaPos)]
kds = do
  let ann :: Annotation
ann = Annotation
annNone { annEntryDelta :: DeltaPos
annEntryDelta = DeltaPos
dp
                    , annsDP :: [(KeywordId, DeltaPos)]
annsDP = [(KeywordId, DeltaPos)]
kds
                    }
  (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey a
ast) Annotation
ann)

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

-- |Add a trailing comma annotation, unless there is already one
addTrailingCommaT :: (Data a,Monad m) => GHC.Located a -> TransformT m ()
addTrailingCommaT :: Located a -> TransformT m ()
addTrailingCommaT Located a
ast = do
  (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (Located a -> DeltaPos -> Anns -> Anns
forall a. Data a => Located a -> DeltaPos -> Anns -> Anns
addTrailingComma Located a
ast ((Int, Int) -> DeltaPos
DP (Int
0,Int
0)))

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

-- |Remove a trailing comma annotation, if there is one one
removeTrailingCommaT :: (Data a,Monad m) => GHC.Located a -> TransformT m ()
removeTrailingCommaT :: Located a -> TransformT m ()
removeTrailingCommaT Located a
ast = do
  (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (Located a -> Anns -> Anns
forall a. Data a => Located a -> Anns -> Anns
removeTrailingComma Located a
ast)

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

-- |'Transform' monad version of 'getEntryDP'
#if __GLASGOW_HASKELL__ >= 808
getEntryDPT :: (Constraints a,Monad m) => a -> TransformT m DeltaPos
#else
getEntryDPT :: (Data a,Monad m) => GHC.Located a -> TransformT m DeltaPos
#endif
getEntryDPT :: a -> TransformT m DeltaPos
getEntryDPT a
ast = do
  Anns
anns <- TransformT m Anns
forall (m :: * -> *). Monad m => TransformT m Anns
getAnnsT
  DeltaPos -> TransformT m DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Anns -> a -> DeltaPos
forall a. Constraints a => Anns -> a -> DeltaPos
getEntryDP Anns
anns a
ast)

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

-- |'Transform' monad version of 'getEntryDP'
#if __GLASGOW_HASKELL__ >= 808
setEntryDPT :: (Constraints a,Monad m) => a -> DeltaPos -> TransformT m ()
#else
setEntryDPT :: (Data a,Monad m) => GHC.Located a -> DeltaPos -> TransformT m ()
#endif
setEntryDPT :: a -> DeltaPos -> TransformT m ()
setEntryDPT a
ast DeltaPos
dp = do
  (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (a -> DeltaPos -> Anns -> Anns
forall a. Constraints a => a -> DeltaPos -> Anns -> Anns
setEntryDP a
ast DeltaPos
dp)

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

-- |'Transform' monad version of 'transferEntryDP'
transferEntryDPT :: (Data a,Data b,Monad m) => GHC.Located a -> GHC.Located b -> TransformT m ()
transferEntryDPT :: Located a -> Located b -> TransformT m ()
transferEntryDPT Located a
a Located b
b =
  (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (Located a -> Located b -> Anns -> Anns
forall a b.
(Data a, Data b) =>
Located a -> Located b -> Anns -> Anns
transferEntryDP Located a
a Located b
b)

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

-- |'Transform' monad version of 'setPrecedingLinesDecl'
setPrecedingLinesDeclT :: (Monad m) => GHC.LHsDecl GhcPs -> Int -> Int -> TransformT m ()
setPrecedingLinesDeclT :: LHsDecl GhcPs -> Int -> Int -> TransformT m ()
setPrecedingLinesDeclT LHsDecl GhcPs
ld Int
n Int
c =
  (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (LHsDecl GhcPs -> Int -> Int -> Anns -> Anns
setPrecedingLinesDecl LHsDecl GhcPs
ld Int
n Int
c)

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

-- |'Transform' monad version of 'setPrecedingLines'
setPrecedingLinesT ::  (SYB.Data a,Monad m) => GHC.Located a -> Int -> Int -> TransformT m ()
setPrecedingLinesT :: Located a -> Int -> Int -> TransformT m ()
setPrecedingLinesT Located a
ld Int
n Int
c =
  (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (Located a -> Int -> Int -> Anns -> Anns
forall a. Data a => Located a -> Int -> Int -> Anns -> Anns
setPrecedingLines Located a
ld Int
n Int
c)

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

-- | Left bias pair union
mergeAnns :: Anns -> Anns -> Anns
mergeAnns :: Anns -> Anns -> Anns
mergeAnns
  = Anns -> Anns -> Anns
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union

-- |Combine a list of annotations
mergeAnnList :: [Anns] -> Anns
mergeAnnList :: [Anns] -> Anns
mergeAnnList [] = String -> Anns
forall a. HasCallStack => String -> a
error String
"mergeAnnList must have at lease one entry"
mergeAnnList (Anns
x:[Anns]
xs) = (Anns -> Anns -> Anns) -> Anns -> [Anns] -> Anns
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Anns -> Anns -> Anns
mergeAnns Anns
x [Anns]
xs

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

-- |Unwrap a HsDecl and call setPrecedingLines on it
-- ++AZ++ TODO: get rid of this, it is a synonym only
setPrecedingLinesDecl :: GHC.LHsDecl GhcPs -> Int -> Int -> Anns -> Anns
setPrecedingLinesDecl :: LHsDecl GhcPs -> Int -> Int -> Anns -> Anns
setPrecedingLinesDecl LHsDecl GhcPs
ld Int
n Int
c Anns
ans = LHsDecl GhcPs -> Int -> Int -> Anns -> Anns
forall a. Data a => Located a -> Int -> Int -> Anns -> Anns
setPrecedingLines LHsDecl GhcPs
ld Int
n Int
c Anns
ans

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

-- | Adjust the entry annotations to provide an `n` line preceding gap
setPrecedingLines :: (SYB.Data a) => GHC.Located a -> Int -> Int -> Anns -> Anns
setPrecedingLines :: Located a -> Int -> Int -> Anns -> Anns
setPrecedingLines Located a
ast Int
n Int
c Anns
anne = Located a -> DeltaPos -> Anns -> Anns
forall a. Constraints a => a -> DeltaPos -> Anns -> Anns
setEntryDP Located a
ast ((Int, Int) -> DeltaPos
DP (Int
n,Int
c)) Anns
anne

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

-- |Return the true entry 'DeltaPos' from the annotation for a given AST
-- element. This is the 'DeltaPos' ignoring any comments.
#if __GLASGOW_HASKELL__ >= 808
getEntryDP :: (Constraints a) => Anns -> a -> DeltaPos
#else
getEntryDP :: (Data a) => Anns -> GHC.Located a -> DeltaPos
#endif
getEntryDP :: Anns -> a -> DeltaPos
getEntryDP Anns
anns a
ast =
  case AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey a
ast) Anns
anns of
    Maybe Annotation
Nothing  -> (Int, Int) -> DeltaPos
DP (Int
0,Int
0)
    Just Annotation
ann -> Annotation -> DeltaPos
annTrueEntryDelta Annotation
ann

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

-- |Set the true entry 'DeltaPos' from the annotation for a given AST
-- element. This is the 'DeltaPos' ignoring any comments.
#if __GLASGOW_HASKELL__ >= 808
setEntryDP :: (Constraints a) => a -> DeltaPos -> Anns -> Anns
#else
setEntryDP :: (Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns
#endif
setEntryDP :: a -> DeltaPos -> Anns -> Anns
setEntryDP a
ast DeltaPos
dp Anns
anns =
  case AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey a
ast) Anns
anns of
    Maybe Annotation
Nothing  -> AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey a
ast) (Annotation
annNone { annEntryDelta :: DeltaPos
annEntryDelta = DeltaPos
dp}) Anns
anns
    Just Annotation
ann -> AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey a
ast) (Annotation
ann'    { annEntryDelta :: DeltaPos
annEntryDelta = Annotation -> DeltaPos -> DeltaPos
annCommentEntryDelta Annotation
ann' DeltaPos
dp}) Anns
anns
      where
        ann' :: Annotation
ann' = Annotation -> DeltaPos -> Annotation
setCommentEntryDP Annotation
ann DeltaPos
dp

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

-- |When setting an entryDP, the leading comment needs to be adjusted too
setCommentEntryDP :: Annotation -> DeltaPos -> Annotation
-- setCommentEntryDP ann dp = error $ "setCommentEntryDP:ann'=" ++ show ann'
setCommentEntryDP :: Annotation -> DeltaPos -> Annotation
setCommentEntryDP Annotation
ann DeltaPos
dp = Annotation
ann'
  where
    ann' :: Annotation
ann' = case (Annotation -> [(Comment, DeltaPos)]
annPriorComments Annotation
ann) of
      [] -> Annotation
ann
      [(Comment
pc,DeltaPos
_)]     -> Annotation
ann { annPriorComments :: [(Comment, DeltaPos)]
annPriorComments = [(Comment
pc,DeltaPos
dp)] }
      ((Comment
pc,DeltaPos
_):[(Comment, DeltaPos)]
pcs) -> Annotation
ann { annPriorComments :: [(Comment, DeltaPos)]
annPriorComments = ((Comment
pc,DeltaPos
dp)(Comment, DeltaPos)
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a. a -> [a] -> [a]
:[(Comment, DeltaPos)]
pcs) }

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

-- |Take the annEntryDelta associated with the first item and associate it with the second.
-- Also transfer any comments occuring before it.
transferEntryDP :: (SYB.Data a, SYB.Data b) => GHC.Located a -> GHC.Located b -> Anns -> Anns
transferEntryDP :: Located a -> Located b -> Anns -> Anns
transferEntryDP Located a
a Located b
b Anns
anns = (Anns -> Anns -> Anns
forall a b. a -> b -> a
const Anns
anns2) Anns
anns
  where
    maybeAnns :: Maybe (Anns, DeltaPos)
maybeAnns = do -- Maybe monad
      Annotation
anA <- AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a) Anns
anns
      Annotation
anB <- AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
b) Anns
anns
      let anB' :: Annotation
anB'  = Ann :: DeltaPos
-> [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)]
-> [(KeywordId, DeltaPos)]
-> Maybe [SrcSpan]
-> Maybe AnnKey
-> Annotation
Ann
            { annEntryDelta :: DeltaPos
annEntryDelta        = (Int, Int) -> DeltaPos
DP (Int
0,Int
0) -- Need to adjust for comments after
            , annPriorComments :: [(Comment, DeltaPos)]
annPriorComments     = Annotation -> [(Comment, DeltaPos)]
annPriorComments     Annotation
anB
            , annFollowingComments :: [(Comment, DeltaPos)]
annFollowingComments = Annotation -> [(Comment, DeltaPos)]
annFollowingComments Annotation
anB
            , annsDP :: [(KeywordId, DeltaPos)]
annsDP               = Annotation -> [(KeywordId, DeltaPos)]
annsDP          Annotation
anB
            , annSortKey :: Maybe [SrcSpan]
annSortKey           = Annotation -> Maybe [SrcSpan]
annSortKey      Annotation
anB
            , annCapturedSpan :: Maybe AnnKey
annCapturedSpan      = Annotation -> Maybe AnnKey
annCapturedSpan Annotation
anB
            }
      (Anns, DeltaPos) -> Maybe (Anns, DeltaPos)
forall (m :: * -> *) a. Monad m => a -> m a
return ((AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
b) Annotation
anB' Anns
anns),Annotation -> DeltaPos
annLeadingCommentEntryDelta Annotation
anA)
    (Anns
anns',DeltaPos
dp) = (Anns, DeltaPos) -> Maybe (Anns, DeltaPos) -> (Anns, DeltaPos)
forall a. a -> Maybe a -> a
fromMaybe
                  (String -> (Anns, DeltaPos)
forall a. HasCallStack => String -> a
error (String -> (Anns, DeltaPos)) -> String -> (Anns, DeltaPos)
forall a b. (a -> b) -> a -> b
$ String
"transferEntryDP: lookup failed (a,b)=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (AnnKey, AnnKey) -> String
forall a. Show a => a -> String
show (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a,Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
b))
                  Maybe (Anns, DeltaPos)
maybeAnns
    anns2 :: Anns
anns2 = Located b -> DeltaPos -> Anns -> Anns
forall a. Constraints a => a -> DeltaPos -> Anns -> Anns
setEntryDP Located b
b DeltaPos
dp Anns
anns'

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

addTrailingComma :: (SYB.Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns
addTrailingComma :: Located a -> DeltaPos -> Anns -> Anns
addTrailingComma Located a
a DeltaPos
dp Anns
anns =
  case AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a) Anns
anns of
    Maybe Annotation
Nothing -> Anns
anns
    Just Annotation
an ->
      case ((KeywordId, DeltaPos) -> Bool)
-> [(KeywordId, DeltaPos)] -> Maybe (KeywordId, DeltaPos)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (KeywordId, DeltaPos) -> Bool
forall b. (KeywordId, b) -> Bool
isAnnComma (Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
an) of
        Maybe (KeywordId, DeltaPos)
Nothing -> AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a) (Annotation
an { annsDP :: [(KeywordId, DeltaPos)]
annsDP = Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
an [(KeywordId, DeltaPos)]
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ [(AnnKeywordId -> KeywordId
G AnnKeywordId
GHC.AnnComma,DeltaPos
dp)]}) Anns
anns
        Just (KeywordId, DeltaPos)
_  -> Anns
anns
      where
        isAnnComma :: (KeywordId, b) -> Bool
isAnnComma (G AnnKeywordId
GHC.AnnComma,b
_) = Bool
True
        isAnnComma (KeywordId, b)
_                  = Bool
False

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

removeTrailingComma :: (SYB.Data a) => GHC.Located a -> Anns -> Anns
removeTrailingComma :: Located a -> Anns -> Anns
removeTrailingComma Located a
a Anns
anns =
  case AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a) Anns
anns of
    Maybe Annotation
Nothing -> Anns
anns
    Just Annotation
an ->
      case ((KeywordId, DeltaPos) -> Bool)
-> [(KeywordId, DeltaPos)] -> Maybe (KeywordId, DeltaPos)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (KeywordId, DeltaPos) -> Bool
forall b. (KeywordId, b) -> Bool
isAnnComma (Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
an) of
        Maybe (KeywordId, DeltaPos)
Nothing -> Anns
anns
        Just (KeywordId, DeltaPos)
_  -> AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
a) (Annotation
an { annsDP :: [(KeywordId, DeltaPos)]
annsDP = ((KeywordId, DeltaPos) -> Bool)
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool)
-> ((KeywordId, DeltaPos) -> Bool) -> (KeywordId, DeltaPos) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(KeywordId, DeltaPos) -> Bool
forall b. (KeywordId, b) -> Bool
isAnnComma) (Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
an) }) Anns
anns
      where
        isAnnComma :: (KeywordId, b) -> Bool
isAnnComma (G AnnKeywordId
GHC.AnnComma,b
_) = Bool
True
        isAnnComma (KeywordId, b)
_                  = Bool
False

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

-- |The relatavise phase puts all comments appearing between the end of one AST
-- item and the beginning of the next as 'annPriorComments' for the second one.
-- This function takes two adjacent AST items and moves any 'annPriorComments'
-- from the second one to the 'annFollowingComments' of the first if they belong
-- to it instead. This is typically required before deleting or duplicating
-- either of the AST elements.
balanceComments :: (Data a,Data b,Monad m) => GHC.Located a -> GHC.Located b -> TransformT m ()
balanceComments :: Located a -> Located b -> TransformT m ()
balanceComments Located a
first Located b
second = do
  -- ++AZ++ : replace the nested casts with appropriate SYB.gmapM
  -- logTr $ "balanceComments entered"
  -- logDataWithAnnsTr "first" first
  case Located a -> Maybe (LHsDecl GhcPs)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Located a
first :: Maybe (GHC.LHsDecl GhcPs) of
#if __GLASGOW_HASKELL__ > 804
    Just (GHC.L SrcSpan
l (GHC.ValD XValD GhcPs
_ fb :: HsBindLR GhcPs GhcPs
fb@(GHC.FunBind{}))) -> do
#else
    Just (GHC.L l (GHC.ValD   fb@(GHC.FunBind{}))) -> do
#endif
      LHsBind GhcPs -> Located b -> TransformT m ()
forall b (m :: * -> *).
(Data b, Monad m) =>
LHsBind GhcPs -> Located b -> TransformT m ()
balanceCommentsFB (SrcSpan -> HsBindLR GhcPs GhcPs -> LHsBind GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l HsBindLR GhcPs GhcPs
fb) Located b
second
    Maybe (LHsDecl GhcPs)
_ -> case Located a -> Maybe (LHsBind GhcPs)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Located a
first :: Maybe (GHC.LHsBind GhcPs) of
      Just fb' :: LHsBind GhcPs
fb'@(GHC.L SrcSpan
_ (GHC.FunBind{})) -> do
        LHsBind GhcPs -> Located b -> TransformT m ()
forall b (m :: * -> *).
(Data b, Monad m) =>
LHsBind GhcPs -> Located b -> TransformT m ()
balanceCommentsFB LHsBind GhcPs
fb' Located b
second
      Maybe (LHsBind GhcPs)
_ -> Located a -> Located b -> TransformT m ()
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Located a -> Located b -> TransformT m ()
balanceComments' Located a
first Located b
second

-- |Prior to moving an AST element, make sure any trailing comments belonging to
-- it are attached to it, and not the following element. Of necessity this is a
-- heuristic process, to be tuned later. Possibly a variant should be provided
-- with a passed-in decision function.
balanceComments' :: (Data a,Data b,Monad m) => GHC.Located a -> GHC.Located b -> TransformT m ()
balanceComments' :: Located a -> Located b -> TransformT m ()
balanceComments' Located a
first Located b
second = do
  let
    k1 :: AnnKey
k1 = Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
first
    k2 :: AnnKey
k2 = Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
second
    moveComments :: ((Comment, DeltaPos) -> Bool) -> Anns -> Anns
moveComments (Comment, DeltaPos) -> Bool
p Anns
ans = Anns
ans'
      where
        an1 :: Annotation
an1 = String -> Maybe Annotation -> Annotation
forall a. String -> Maybe a -> a
gfromJust String
"balanceComments' k1" (Maybe Annotation -> Annotation) -> Maybe Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
k1 Anns
ans
        an2 :: Annotation
an2 = String -> Maybe Annotation -> Annotation
forall a. String -> Maybe a -> a
gfromJust String
"balanceComments' k2" (Maybe Annotation -> Annotation) -> Maybe Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
k2 Anns
ans
        cs1f :: [(Comment, DeltaPos)]
cs1f = Annotation -> [(Comment, DeltaPos)]
annFollowingComments Annotation
an1
        cs2b :: [(Comment, DeltaPos)]
cs2b = Annotation -> [(Comment, DeltaPos)]
annPriorComments Annotation
an2
        ([(Comment, DeltaPos)]
move,[(Comment, DeltaPos)]
stay) = ((Comment, DeltaPos) -> Bool)
-> [(Comment, DeltaPos)]
-> ([(Comment, DeltaPos)], [(Comment, DeltaPos)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Comment, DeltaPos) -> Bool
p [(Comment, DeltaPos)]
cs2b
        an1' :: Annotation
an1' = Annotation
an1 { annFollowingComments :: [(Comment, DeltaPos)]
annFollowingComments = [(Comment, DeltaPos)]
cs1f [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ [(Comment, DeltaPos)]
move}
        an2' :: Annotation
an2' = Annotation
an2 { annPriorComments :: [(Comment, DeltaPos)]
annPriorComments = [(Comment, DeltaPos)]
stay}
        ans' :: Anns
ans' = AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
k1 Annotation
an1' (Anns -> Anns) -> Anns -> Anns
forall a b. (a -> b) -> a -> b
$ AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
k2 Annotation
an2' Anns
ans

    simpleBreak :: (a, DeltaPos) -> Bool
simpleBreak (a
_,DP (Int
r,Int
_c)) = Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

  (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (((Comment, DeltaPos) -> Bool) -> Anns -> Anns
moveComments (Comment, DeltaPos) -> Bool
forall a. (a, DeltaPos) -> Bool
simpleBreak)

-- |Once 'balanceComments' has been called to move trailing comments to a
-- 'GHC.FunBind', these need to be pushed down from the top level to the last
-- 'GHC.Match' if that 'GHC.Match' needs to be manipulated.
balanceCommentsFB :: (Data b,Monad m) => GHC.LHsBind GhcPs -> GHC.Located b -> TransformT m ()
#if __GLASGOW_HASKELL__ > 808
balanceCommentsFB :: LHsBind GhcPs -> Located b -> TransformT m ()
balanceCommentsFB (GHC.L SrcSpan
_ (GHC.FunBind XFunBind GhcPs GhcPs
_ Located (IdP GhcPs)
_ (GHC.MG XMG GhcPs (LHsExpr GhcPs)
_ (GHC.L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
matches) Origin
_) HsWrapper
_ [Tickish Id]
_)) Located b
second = do
#elif __GLASGOW_HASKELL__ > 804
balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) second = do
#elif __GLASGOW_HASKELL__ > 710
balanceCommentsFB (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) second = do
#else
balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do
#endif
  -- logTr $ "balanceCommentsFB entered"
  LMatch GhcPs (LHsExpr GhcPs) -> Located b -> TransformT m ()
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Located a -> Located b -> TransformT m ()
balanceComments' ([LMatch GhcPs (LHsExpr GhcPs)] -> LMatch GhcPs (LHsExpr GhcPs)
forall a. [a] -> a
last [LMatch GhcPs (LHsExpr GhcPs)]
matches) Located b
second
balanceCommentsFB LHsBind GhcPs
f Located b
s = LHsBind GhcPs -> Located b -> TransformT m ()
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Located a -> Located b -> TransformT m ()
balanceComments' LHsBind GhcPs
f Located b
s

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


-- |After moving an AST element, make sure any comments that may belong
-- with the following element in fact do. Of necessity this is a heuristic
-- process, to be tuned later. Possibly a variant should be provided with a
-- passed-in decision function.
balanceTrailingComments :: (Monad m) => (Data a,Data b) => GHC.Located a -> GHC.Located b
                        -> TransformT m [(Comment, DeltaPos)]
balanceTrailingComments :: Located a -> Located b -> TransformT m [(Comment, DeltaPos)]
balanceTrailingComments Located a
first Located b
second = do
  let
    k1 :: AnnKey
k1 = Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
first
    k2 :: AnnKey
k2 = Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
second
    moveComments :: ((Comment, DeltaPos) -> Bool)
-> Anns -> (Anns, [(Comment, DeltaPos)])
moveComments (Comment, DeltaPos) -> Bool
p Anns
ans = (Anns
ans',[(Comment, DeltaPos)]
move)
      where
        an1 :: Annotation
an1 = String -> Maybe Annotation -> Annotation
forall a. String -> Maybe a -> a
gfromJust String
"balanceTrailingComments k1" (Maybe Annotation -> Annotation) -> Maybe Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
k1 Anns
ans
        an2 :: Annotation
an2 = String -> Maybe Annotation -> Annotation
forall a. String -> Maybe a -> a
gfromJust String
"balanceTrailingComments k2" (Maybe Annotation -> Annotation) -> Maybe Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
k2 Anns
ans
        cs1f :: [(Comment, DeltaPos)]
cs1f = Annotation -> [(Comment, DeltaPos)]
annFollowingComments Annotation
an1
        ([(Comment, DeltaPos)]
move,[(Comment, DeltaPos)]
stay) = ((Comment, DeltaPos) -> Bool)
-> [(Comment, DeltaPos)]
-> ([(Comment, DeltaPos)], [(Comment, DeltaPos)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Comment, DeltaPos) -> Bool
p [(Comment, DeltaPos)]
cs1f
        an1' :: Annotation
an1' = Annotation
an1 { annFollowingComments :: [(Comment, DeltaPos)]
annFollowingComments = [(Comment, DeltaPos)]
stay }
        ans' :: Anns
ans' = AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
k1 Annotation
an1' (Anns -> Anns) -> Anns -> Anns
forall a b. (a -> b) -> a -> b
$ AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
k2 Annotation
an2 Anns
ans

    simpleBreak :: (a, DeltaPos) -> Bool
simpleBreak (a
_,DP (Int
r,Int
_c)) = Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

  Anns
ans <- TransformT m Anns
forall (m :: * -> *). Monad m => TransformT m Anns
getAnnsT
  let (Anns
ans',[(Comment, DeltaPos)]
mov) = ((Comment, DeltaPos) -> Bool)
-> Anns -> (Anns, [(Comment, DeltaPos)])
moveComments (Comment, DeltaPos) -> Bool
forall a. (a, DeltaPos) -> Bool
simpleBreak Anns
ans
  Anns -> TransformT m ()
forall (m :: * -> *). Monad m => Anns -> TransformT m ()
putAnnsT Anns
ans'
  [(Comment, DeltaPos)] -> TransformT m [(Comment, DeltaPos)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Comment, DeltaPos)]
mov

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

-- ++AZ++ TODO: This needs to be renamed/reworked, based on what it actually gets used for
-- |Move any 'annFollowingComments' values from the 'Annotation' associated to
-- the first parameter to that of the second.
moveTrailingComments :: (Data a,Data b)
                     => GHC.Located a -> GHC.Located b -> Transform ()
moveTrailingComments :: Located a -> Located b -> Transform ()
moveTrailingComments Located a
first Located b
second = do
  let
    k1 :: AnnKey
k1 = Located a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located a
first
    k2 :: AnnKey
k2 = Located b -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located b
second
    moveComments :: Anns -> Anns
moveComments Anns
ans = Anns
ans'
      where
        an1 :: Annotation
an1 = String -> Maybe Annotation -> Annotation
forall a. String -> Maybe a -> a
gfromJust String
"moveTrailingComments k1" (Maybe Annotation -> Annotation) -> Maybe Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
k1 Anns
ans
        an2 :: Annotation
an2 = String -> Maybe Annotation -> Annotation
forall a. String -> Maybe a -> a
gfromJust String
"moveTrailingComments k2" (Maybe Annotation -> Annotation) -> Maybe Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
k2 Anns
ans
        cs1f :: [(Comment, DeltaPos)]
cs1f = Annotation -> [(Comment, DeltaPos)]
annFollowingComments Annotation
an1
        cs2f :: [(Comment, DeltaPos)]
cs2f = Annotation -> [(Comment, DeltaPos)]
annFollowingComments Annotation
an2
        an1' :: Annotation
an1' = Annotation
an1 { annFollowingComments :: [(Comment, DeltaPos)]
annFollowingComments = [] }
        an2' :: Annotation
an2' = Annotation
an2 { annFollowingComments :: [(Comment, DeltaPos)]
annFollowingComments = [(Comment, DeltaPos)]
cs1f [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ [(Comment, DeltaPos)]
cs2f }
        ans' :: Anns
ans' = AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
k1 Annotation
an1' (Anns -> Anns) -> Anns -> Anns
forall a b. (a -> b) -> a -> b
$ AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
k2 Annotation
an2' Anns
ans

  (Anns -> Anns) -> Transform ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT Anns -> Anns
moveComments

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

-- |Insert a declaration into an AST element having sub-declarations
-- (@HasDecls@) according to the given location function.
insertAt :: (HasDecls (GHC.Located ast))
              => (GHC.LHsDecl GhcPs
                  -> [GHC.LHsDecl GhcPs]
                  -> [GHC.LHsDecl GhcPs])
              -> GHC.Located ast
              -> GHC.LHsDecl GhcPs
              -> Transform (GHC.Located ast)
insertAt :: (LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> Located ast -> LHsDecl GhcPs -> Transform (Located ast)
insertAt LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
f Located ast
t LHsDecl GhcPs
decl = do
  [LHsDecl GhcPs]
oldDecls <- Located ast -> TransformT Identity [LHsDecl GhcPs]
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> TransformT m [LHsDecl GhcPs]
hsDecls Located ast
t
  Located ast -> [LHsDecl GhcPs] -> Transform (Located ast)
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> [LHsDecl GhcPs] -> TransformT m t
replaceDecls Located ast
t (LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
f LHsDecl GhcPs
decl [LHsDecl GhcPs]
oldDecls)

-- |Insert a declaration at the beginning or end of the subdecls of the given
-- AST item
insertAtStart, insertAtEnd :: (HasDecls (GHC.Located ast))
              => GHC.Located ast
              -> GHC.LHsDecl GhcPs
              -> Transform (GHC.Located ast)

insertAtStart :: Located ast -> LHsDecl GhcPs -> Transform (Located ast)
insertAtStart = (LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> Located ast -> LHsDecl GhcPs -> Transform (Located ast)
forall ast.
HasDecls (Located ast) =>
(LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> Located ast -> LHsDecl GhcPs -> Transform (Located ast)
insertAt (:)
insertAtEnd :: Located ast -> LHsDecl GhcPs -> Transform (Located ast)
insertAtEnd   = (LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> Located ast -> LHsDecl GhcPs -> Transform (Located ast)
forall ast.
HasDecls (Located ast) =>
(LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> Located ast -> LHsDecl GhcPs -> Transform (Located ast)
insertAt (\LHsDecl GhcPs
x [LHsDecl GhcPs]
xs -> [LHsDecl GhcPs]
xs [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs
x])

-- |Insert a declaration at a specific location in the subdecls of the given
-- AST item
insertAfter, insertBefore :: (HasDecls (GHC.Located ast))
                          => GHC.Located old
                          -> GHC.Located ast
                          -> GHC.LHsDecl GhcPs
                          -> Transform (GHC.Located ast)
insertAfter :: Located old
-> Located ast -> LHsDecl GhcPs -> Transform (Located ast)
insertAfter (Located old -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc -> SrcSpan
k) = (LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> Located ast -> LHsDecl GhcPs -> Transform (Located ast)
forall ast.
HasDecls (Located ast) =>
(LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> Located ast -> LHsDecl GhcPs -> Transform (Located ast)
insertAt LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall e.
GenLocated SrcSpan e
-> [GenLocated SrcSpan e] -> [GenLocated SrcSpan e]
findAfter
  where
    findAfter :: GenLocated SrcSpan e
-> [GenLocated SrcSpan e] -> [GenLocated SrcSpan e]
findAfter GenLocated SrcSpan e
x [GenLocated SrcSpan e]
xs =
      let ([GenLocated SrcSpan e]
fs, GenLocated SrcSpan e
b:[GenLocated SrcSpan e]
bs) = (GenLocated SrcSpan e -> Bool)
-> [GenLocated SrcSpan e]
-> ([GenLocated SrcSpan e], [GenLocated SrcSpan e])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\(GHC.L SrcSpan
l e
_) -> SrcSpan
l SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcSpan
k) [GenLocated SrcSpan e]
xs
      in [GenLocated SrcSpan e]
fs [GenLocated SrcSpan e]
-> [GenLocated SrcSpan e] -> [GenLocated SrcSpan e]
forall a. [a] -> [a] -> [a]
++ (GenLocated SrcSpan e
b GenLocated SrcSpan e
-> [GenLocated SrcSpan e] -> [GenLocated SrcSpan e]
forall a. a -> [a] -> [a]
: GenLocated SrcSpan e
x GenLocated SrcSpan e
-> [GenLocated SrcSpan e] -> [GenLocated SrcSpan e]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpan e]
bs)
insertBefore :: Located old
-> Located ast -> LHsDecl GhcPs -> Transform (Located ast)
insertBefore (Located old -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc -> SrcSpan
k) = (LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> Located ast -> LHsDecl GhcPs -> Transform (Located ast)
forall ast.
HasDecls (Located ast) =>
(LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> Located ast -> LHsDecl GhcPs -> Transform (Located ast)
insertAt LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall e.
GenLocated SrcSpan e
-> [GenLocated SrcSpan e] -> [GenLocated SrcSpan e]
findBefore
  where
    findBefore :: GenLocated SrcSpan e
-> [GenLocated SrcSpan e] -> [GenLocated SrcSpan e]
findBefore GenLocated SrcSpan e
x [GenLocated SrcSpan e]
xs =
      let ([GenLocated SrcSpan e]
fs, [GenLocated SrcSpan e]
bs) = (GenLocated SrcSpan e -> Bool)
-> [GenLocated SrcSpan e]
-> ([GenLocated SrcSpan e], [GenLocated SrcSpan e])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\(GHC.L SrcSpan
l e
_) -> SrcSpan
l SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcSpan
k) [GenLocated SrcSpan e]
xs
      in [GenLocated SrcSpan e]
fs [GenLocated SrcSpan e]
-> [GenLocated SrcSpan e] -> [GenLocated SrcSpan e]
forall a. [a] -> [a] -> [a]
++ (GenLocated SrcSpan e
x GenLocated SrcSpan e
-> [GenLocated SrcSpan e] -> [GenLocated SrcSpan e]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpan e]
bs)

-- =====================================================================
-- start of HasDecls instances
-- =====================================================================

-- |Provide a means to get and process the immediate child declartions of a
-- given AST element.
class (Data t) => HasDecls t where
-- ++AZ++: TODO: add tests to confirm that hsDecls followed by replaceDecls is idempotent

    -- | Return the 'GHC.HsDecl's that are directly enclosed in the
    -- given syntax phrase. They are always returned in the wrapped 'GHC.HsDecl'
    -- form, even if orginating in local decls. This is safe, as annotations
    -- never attach to the wrapper, only to the wrapped item.
    hsDecls :: (Monad m) => t -> TransformT m [GHC.LHsDecl GhcPs]

    -- | Replace the directly enclosed decl list by the given
    --  decl list. Runs in the 'Transform' monad to be able to update list order
    --  annotations, and rebalance comments and other layout changes as needed.
    --
    -- For example, a call on replaceDecls for a wrapped 'GHC.FunBind' having no
    -- where clause will convert
    --
    -- @
    -- -- |This is a function
    -- foo = x -- comment1
    -- @
    -- in to
    --
    -- @
    -- -- |This is a function
    -- foo = x -- comment1
    --   where
    --     nn = 2
    -- @
    replaceDecls :: (Monad m) => t -> [GHC.LHsDecl GhcPs] -> TransformT m t

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

instance HasDecls GHC.ParsedSource where
  hsDecls :: ParsedSource -> TransformT m [LHsDecl GhcPs]
hsDecls (GHC.L SrcSpan
_ (GHC.HsModule Maybe (Located ModuleName)
_mn Maybe (Located [LIE GhcPs])
_exps [LImportDecl GhcPs]
_imps [LHsDecl GhcPs]
decls Maybe (Located WarningTxt)
_ Maybe LHsDocString
_)) = [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return [LHsDecl GhcPs]
decls
  replaceDecls :: ParsedSource -> [LHsDecl GhcPs] -> TransformT m ParsedSource
replaceDecls m :: ParsedSource
m@(GHC.L SrcSpan
l (GHC.HsModule Maybe (Located ModuleName)
mn Maybe (Located [LIE GhcPs])
exps [LImportDecl GhcPs]
imps [LHsDecl GhcPs]
_decls Maybe (Located WarningTxt)
deps Maybe LHsDocString
haddocks)) [LHsDecl GhcPs]
decls
    = do
        String -> TransformT m ()
forall (m :: * -> *). Monad m => String -> TransformT m ()
logTr String
"replaceDecls LHsModule"
        (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (ParsedSource -> [LHsDecl GhcPs] -> Anns -> Anns
forall a b. Data a => Located a -> [Located b] -> Anns -> Anns
captureOrder ParsedSource
m [LHsDecl GhcPs]
decls)
        ParsedSource -> TransformT m ParsedSource
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsModule GhcPs -> ParsedSource
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (Maybe (Located ModuleName)
-> Maybe (Located [LIE GhcPs])
-> [LImportDecl GhcPs]
-> [LHsDecl GhcPs]
-> Maybe (Located WarningTxt)
-> Maybe LHsDocString
-> HsModule GhcPs
forall pass.
Maybe (Located ModuleName)
-> Maybe (Located [LIE pass])
-> [LImportDecl pass]
-> [LHsDecl pass]
-> Maybe (Located WarningTxt)
-> Maybe LHsDocString
-> HsModule pass
GHC.HsModule Maybe (Located ModuleName)
mn Maybe (Located [LIE GhcPs])
exps [LImportDecl GhcPs]
imps [LHsDecl GhcPs]
decls Maybe (Located WarningTxt)
deps Maybe LHsDocString
haddocks))

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

instance HasDecls (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) where
#if __GLASGOW_HASKELL__ > 804
  hsDecls :: LMatch GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs]
hsDecls d :: LMatch GhcPs (LHsExpr GhcPs)
d@(GHC.L SrcSpan
_ (GHC.Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext (NameOrRdrName (IdP GhcPs))
_ [LPat GhcPs]
_ (GHC.GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_ [LGRHS GhcPs (LHsExpr GhcPs)]
_ (GHC.L SrcSpan
_ HsLocalBinds GhcPs
lb)))) = do
#elif __GLASGOW_HASKELL__ >= 804
  hsDecls d@(GHC.L _ (GHC.Match _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do
#elif __GLASGOW_HASKELL__ >= 800
  hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do
#elif __GLASGOW_HASKELL__ >= 710
  hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do
#else
  hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do
#endif
    [LHsDecl GhcPs]
decls <- HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
hsDeclsValBinds HsLocalBinds GhcPs
lb
    LMatch GhcPs (LHsExpr GhcPs)
-> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall a (m :: * -> *).
(Data a, Monad m) =>
Located a -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
orderedDecls LMatch GhcPs (LHsExpr GhcPs)
d [LHsDecl GhcPs]
decls
#if __GLASGOW_HASKELL__ > 804
  hsDecls (GHC.L SrcSpan
_ (GHC.Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext (NameOrRdrName (IdP GhcPs))
_ [LPat GhcPs]
_ (GHC.XGRHSs XXGRHSs GhcPs (LHsExpr GhcPs)
_))) = [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  hsDecls (GHC.L SrcSpan
_ (GHC.XMatch XXMatch GhcPs (LHsExpr GhcPs)
_))                   = [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return []
#endif


#if __GLASGOW_HASKELL__ > 804
  replaceDecls :: LMatch GhcPs (LHsExpr GhcPs)
-> [LHsDecl GhcPs] -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))
replaceDecls m :: LMatch GhcPs (LHsExpr GhcPs)
m@(GHC.L SrcSpan
l (GHC.Match XCMatch GhcPs (LHsExpr GhcPs)
xm HsMatchContext (NameOrRdrName (IdP GhcPs))
c [LPat GhcPs]
p (GHC.GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
xr [LGRHS GhcPs (LHsExpr GhcPs)]
rhs GenLocated SrcSpan (HsLocalBinds GhcPs)
binds))) []
#elif __GLASGOW_HASKELL__ >= 804
  replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) []
#else
  replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) []
#endif
    = do
        String -> TransformT m ()
forall (m :: * -> *). Monad m => String -> TransformT m ()
logTr String
"replaceDecls LMatch"
        let
          noWhere :: (KeywordId, b) -> Bool
noWhere (G AnnKeywordId
GHC.AnnWhere,b
_) = Bool
False
          noWhere (KeywordId, b)
_                  = Bool
True

          removeWhere :: Anns -> Anns
removeWhere Anns
mkds =
            case AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (LMatch GhcPs (LHsExpr GhcPs) -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey LMatch GhcPs (LHsExpr GhcPs)
m) Anns
mkds of
              Maybe Annotation
Nothing -> String -> Anns
forall a. HasCallStack => String -> a
error String
"wtf"
              Just Annotation
ann -> AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (LMatch GhcPs (LHsExpr GhcPs) -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey LMatch GhcPs (LHsExpr GhcPs)
m) Annotation
ann1 Anns
mkds
                where
                  ann1 :: Annotation
ann1 = Annotation
ann { annsDP :: [(KeywordId, DeltaPos)]
annsDP = ((KeywordId, DeltaPos) -> Bool)
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. (a -> Bool) -> [a] -> [a]
filter (KeywordId, DeltaPos) -> Bool
forall b. (KeywordId, b) -> Bool
noWhere (Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
ann)
                                 }
        (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT Anns -> Anns
removeWhere

#if __GLASGOW_HASKELL__ <= 710
        binds' <- replaceDeclsValbinds binds []
#else
        HsLocalBinds GhcPs
binds'' <- HsLocalBinds GhcPs
-> [LHsDecl GhcPs] -> TransformT m (HsLocalBinds GhcPs)
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs
-> [LHsDecl GhcPs] -> TransformT m (HsLocalBinds GhcPs)
replaceDeclsValbinds (GenLocated SrcSpan (HsLocalBinds GhcPs)
-> SrcSpanLess (GenLocated SrcSpan (HsLocalBinds GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc GenLocated SrcSpan (HsLocalBinds GhcPs)
binds) []
        let binds' :: GenLocated SrcSpan (HsLocalBinds GhcPs)
binds' = SrcSpan
-> HsLocalBinds GhcPs -> GenLocated SrcSpan (HsLocalBinds GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L (GenLocated SrcSpan (HsLocalBinds GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc GenLocated SrcSpan (HsLocalBinds GhcPs)
binds) HsLocalBinds GhcPs
binds''
#endif
#if __GLASGOW_HASKELL__ > 804
        LMatch GhcPs (LHsExpr GhcPs)
-> TransformT m (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XCMatch GhcPs (LHsExpr GhcPs)
-> HsMatchContext (NameOrRdrName (IdP GhcPs))
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Match GhcPs (LHsExpr GhcPs)
forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
GHC.Match XCMatch GhcPs (LHsExpr GhcPs)
xm HsMatchContext (NameOrRdrName (IdP GhcPs))
c [LPat GhcPs]
p (XCGRHSs GhcPs (LHsExpr GhcPs)
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> GenLocated SrcSpan (HsLocalBinds GhcPs)
-> GRHSs GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GHC.GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
xr [LGRHS GhcPs (LHsExpr GhcPs)]
rhs GenLocated SrcSpan (HsLocalBinds GhcPs)
binds')))
#elif __GLASGOW_HASKELL__ >= 804
        return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds')))
#else
        return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))
#endif

#if __GLASGOW_HASKELL__ > 804
  replaceDecls m :: LMatch GhcPs (LHsExpr GhcPs)
m@(GHC.L SrcSpan
l (GHC.Match XCMatch GhcPs (LHsExpr GhcPs)
xm HsMatchContext (NameOrRdrName (IdP GhcPs))
c [LPat GhcPs]
p (GHC.GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
xr [LGRHS GhcPs (LHsExpr GhcPs)]
rhs GenLocated SrcSpan (HsLocalBinds GhcPs)
binds))) [LHsDecl GhcPs]
newBinds
#elif __GLASGOW_HASKELL__ >= 804
  replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) newBinds
#else
  replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) newBinds
#endif
    = do
        String -> TransformT m ()
forall (m :: * -> *). Monad m => String -> TransformT m ()
logTr String
"replaceDecls LMatch"
        -- Need to throw in a fresh where clause if the binds were empty,
        -- in the annotations.
#if __GLASGOW_HASKELL__ <= 710
        case binds of
#else
        case GenLocated SrcSpan (HsLocalBinds GhcPs)
-> SrcSpanLess (GenLocated SrcSpan (HsLocalBinds GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc GenLocated SrcSpan (HsLocalBinds GhcPs)
binds of
#endif
#if __GLASGOW_HASKELL__ > 804
          GHC.EmptyLocalBinds{} -> do
#else
          GHC.EmptyLocalBinds -> do
#endif
            let
              addWhere :: Anns -> Anns
addWhere Anns
mkds =
                case AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (LMatch GhcPs (LHsExpr GhcPs) -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey LMatch GhcPs (LHsExpr GhcPs)
m) Anns
mkds of
                  Maybe Annotation
Nothing -> String -> Anns
forall a. HasCallStack => String -> a
error String
"wtf"
                  Just Annotation
ann -> AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (LMatch GhcPs (LHsExpr GhcPs) -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey LMatch GhcPs (LHsExpr GhcPs)
m) Annotation
ann1 Anns
mkds
                    where
                      ann1 :: Annotation
ann1 = Annotation
ann { annsDP :: [(KeywordId, DeltaPos)]
annsDP = Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
ann [(KeywordId, DeltaPos)]
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ [(AnnKeywordId -> KeywordId
G AnnKeywordId
GHC.AnnWhere,(Int, Int) -> DeltaPos
DP (Int
1,Int
2))]
                                 }
            (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT Anns -> Anns
addWhere
            (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (LHsDecl GhcPs -> Int -> Int -> Anns -> Anns
forall a. Data a => Located a -> Int -> Int -> Anns -> Anns
setPrecedingLines (String -> [LHsDecl GhcPs] -> LHsDecl GhcPs
forall a. String -> [a] -> a
ghead String
"LMatch.replaceDecls" [LHsDecl GhcPs]
newBinds) Int
1 Int
4)

            -- only move the comment if the original where clause was empty.
            [(Comment, DeltaPos)]
toMove <- LMatch GhcPs (LHsExpr GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
-> TransformT m [(Comment, DeltaPos)]
forall (m :: * -> *) a b.
(Monad m, Data a, Data b) =>
Located a -> Located b -> TransformT m [(Comment, DeltaPos)]
balanceTrailingComments LMatch GhcPs (LHsExpr GhcPs)
m LMatch GhcPs (LHsExpr GhcPs)
m
            AnnKey
-> [(Comment, DeltaPos)]
-> ((KeywordId, DeltaPos) -> Bool)
-> TransformT m ()
forall (m :: * -> *).
Monad m =>
AnnKey
-> [(Comment, DeltaPos)]
-> ((KeywordId, DeltaPos) -> Bool)
-> TransformT m ()
insertCommentBefore (LMatch GhcPs (LHsExpr GhcPs) -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey LMatch GhcPs (LHsExpr GhcPs)
m) [(Comment, DeltaPos)]
toMove (AnnKeywordId -> (KeywordId, DeltaPos) -> Bool
matchApiAnn AnnKeywordId
GHC.AnnWhere)
          SrcSpanLess (GenLocated SrcSpan (HsLocalBinds GhcPs))
_ -> () -> TransformT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (AnnKey -> [LHsDecl GhcPs] -> Anns -> Anns
forall b. AnnKey -> [Located b] -> Anns -> Anns
captureOrderAnnKey (LMatch GhcPs (LHsExpr GhcPs) -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey LMatch GhcPs (LHsExpr GhcPs)
m) [LHsDecl GhcPs]
newBinds)
#if __GLASGOW_HASKELL__ <= 710
        binds' <- replaceDeclsValbinds binds newBinds
#else
        HsLocalBinds GhcPs
binds'' <- HsLocalBinds GhcPs
-> [LHsDecl GhcPs] -> TransformT m (HsLocalBinds GhcPs)
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs
-> [LHsDecl GhcPs] -> TransformT m (HsLocalBinds GhcPs)
replaceDeclsValbinds (GenLocated SrcSpan (HsLocalBinds GhcPs)
-> SrcSpanLess (GenLocated SrcSpan (HsLocalBinds GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc GenLocated SrcSpan (HsLocalBinds GhcPs)
binds) [LHsDecl GhcPs]
newBinds
        let binds' :: GenLocated SrcSpan (HsLocalBinds GhcPs)
binds' = SrcSpan
-> HsLocalBinds GhcPs -> GenLocated SrcSpan (HsLocalBinds GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L (GenLocated SrcSpan (HsLocalBinds GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc GenLocated SrcSpan (HsLocalBinds GhcPs)
binds) HsLocalBinds GhcPs
binds''
#endif
        -- logDataWithAnnsTr "Match.replaceDecls:binds'" binds'
#if __GLASGOW_HASKELL__ > 804
        LMatch GhcPs (LHsExpr GhcPs)
-> TransformT m (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XCMatch GhcPs (LHsExpr GhcPs)
-> HsMatchContext (NameOrRdrName (IdP GhcPs))
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Match GhcPs (LHsExpr GhcPs)
forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
GHC.Match XCMatch GhcPs (LHsExpr GhcPs)
xm HsMatchContext (NameOrRdrName (IdP GhcPs))
c [LPat GhcPs]
p (XCGRHSs GhcPs (LHsExpr GhcPs)
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> GenLocated SrcSpan (HsLocalBinds GhcPs)
-> GRHSs GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GHC.GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
xr [LGRHS GhcPs (LHsExpr GhcPs)]
rhs GenLocated SrcSpan (HsLocalBinds GhcPs)
binds')))
#elif __GLASGOW_HASKELL__ >= 804
        return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds')))
#else
        return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))
#endif
#if __GLASGOW_HASKELL__ > 804
  replaceDecls (GHC.L SrcSpan
_ (GHC.Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext (NameOrRdrName (IdP GhcPs))
_ [LPat GhcPs]
_ (GHC.XGRHSs XXGRHSs GhcPs (LHsExpr GhcPs)
_))) [LHsDecl GhcPs]
_ = String -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))
forall a. HasCallStack => String -> a
error String
"replaceDecls"
  replaceDecls (GHC.L SrcSpan
_ (GHC.XMatch XXMatch GhcPs (LHsExpr GhcPs)
_)) [LHsDecl GhcPs]
_                   = String -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))
forall a. HasCallStack => String -> a
error String
"replaceDecls"
#endif

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

instance HasDecls (GHC.LHsExpr GhcPs) where
#if __GLASGOW_HASKELL__ > 804
  hsDecls :: LHsExpr GhcPs -> TransformT m [LHsDecl GhcPs]
hsDecls ls :: LHsExpr GhcPs
ls@(GHC.L SrcSpan
_ (GHC.HsLet XLet GhcPs
_ (GHC.L SrcSpan
_ HsLocalBinds GhcPs
decls) LHsExpr GhcPs
_ex)) = do
#elif __GLASGOW_HASKELL__ > 710
  hsDecls ls@(GHC.L _ (GHC.HsLet (GHC.L _ decls) _ex)) = do
#else
  hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do
#endif
    [LHsDecl GhcPs]
ds <- HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
hsDeclsValBinds HsLocalBinds GhcPs
decls
    LHsExpr GhcPs -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall a (m :: * -> *).
(Data a, Monad m) =>
Located a -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
orderedDecls LHsExpr GhcPs
ls [LHsDecl GhcPs]
ds
  hsDecls LHsExpr GhcPs
_                               = [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return []

#if __GLASGOW_HASKELL__ > 804
  replaceDecls :: LHsExpr GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsExpr GhcPs)
replaceDecls e :: LHsExpr GhcPs
e@(GHC.L SrcSpan
l (GHC.HsLet XLet GhcPs
x GenLocated SrcSpan (HsLocalBinds GhcPs)
decls LHsExpr GhcPs
ex)) [LHsDecl GhcPs]
newDecls
#else
  replaceDecls e@(GHC.L l (GHC.HsLet decls ex)) newDecls
#endif
    = do
        String -> TransformT m ()
forall (m :: * -> *). Monad m => String -> TransformT m ()
logTr String
"replaceDecls HsLet"
        (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (LHsExpr GhcPs -> [LHsDecl GhcPs] -> Anns -> Anns
forall a b. Data a => Located a -> [Located b] -> Anns -> Anns
captureOrder LHsExpr GhcPs
e [LHsDecl GhcPs]
newDecls)
#if __GLASGOW_HASKELL__ <= 710
        decls' <- replaceDeclsValbinds decls newDecls
#else
        HsLocalBinds GhcPs
decls'' <- HsLocalBinds GhcPs
-> [LHsDecl GhcPs] -> TransformT m (HsLocalBinds GhcPs)
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs
-> [LHsDecl GhcPs] -> TransformT m (HsLocalBinds GhcPs)
replaceDeclsValbinds (GenLocated SrcSpan (HsLocalBinds GhcPs)
-> SrcSpanLess (GenLocated SrcSpan (HsLocalBinds GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc GenLocated SrcSpan (HsLocalBinds GhcPs)
decls) [LHsDecl GhcPs]
newDecls
        let decls' :: GenLocated SrcSpan (HsLocalBinds GhcPs)
decls' = SrcSpan
-> HsLocalBinds GhcPs -> GenLocated SrcSpan (HsLocalBinds GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L (GenLocated SrcSpan (HsLocalBinds GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc GenLocated SrcSpan (HsLocalBinds GhcPs)
decls) HsLocalBinds GhcPs
decls''
#endif
#if __GLASGOW_HASKELL__ > 804
        LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XLet GhcPs
-> GenLocated SrcSpan (HsLocalBinds GhcPs)
-> LHsExpr GhcPs
-> HsExpr GhcPs
forall p. XLet p -> LHsLocalBinds p -> LHsExpr p -> HsExpr p
GHC.HsLet XLet GhcPs
x GenLocated SrcSpan (HsLocalBinds GhcPs)
decls' LHsExpr GhcPs
ex))
#else
        return (GHC.L l (GHC.HsLet decls' ex))
#endif

#if __GLASGOW_HASKELL__ > 804
  replaceDecls (GHC.L SrcSpan
l (GHC.HsPar XPar GhcPs
x LHsExpr GhcPs
e)) [LHsDecl GhcPs]
newDecls
#else
  replaceDecls (GHC.L l (GHC.HsPar e)) newDecls
#endif
    = do
        String -> TransformT m ()
forall (m :: * -> *). Monad m => String -> TransformT m ()
logTr String
"replaceDecls HsPar"
        LHsExpr GhcPs
e' <- LHsExpr GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsExpr GhcPs)
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> [LHsDecl GhcPs] -> TransformT m t
replaceDecls LHsExpr GhcPs
e [LHsDecl GhcPs]
newDecls
#if __GLASGOW_HASKELL__ > 804
        LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
GHC.HsPar XPar GhcPs
x LHsExpr GhcPs
e'))
#else
        return (GHC.L l (GHC.HsPar e'))
#endif
  replaceDecls LHsExpr GhcPs
old [LHsDecl GhcPs]
_new = String -> TransformT m (LHsExpr GhcPs)
forall a. HasCallStack => String -> a
error (String -> TransformT m (LHsExpr GhcPs))
-> String -> TransformT m (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ String
"replaceDecls (GHC.LHsExpr GhcPs) undefined for:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LHsExpr GhcPs -> String
forall a. Outputable a => a -> String
showGhc LHsExpr GhcPs
old

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

-- | Extract the immediate declarations for a 'GHC.PatBind' wrapped in a 'GHC.ValD'. This
-- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent
-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is
-- idempotent.
hsDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> TransformT m [GHC.LHsDecl GhcPs]
#if __GLASGOW_HASKELL__ > 804
hsDeclsPatBindD :: LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs]
hsDeclsPatBindD (GHC.L SrcSpan
l (GHC.ValD XValD GhcPs
_ HsBindLR GhcPs GhcPs
d)) = LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
hsDeclsPatBind (SrcSpan -> HsBindLR GhcPs GhcPs -> LHsBind GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l HsBindLR GhcPs GhcPs
d)
#else
hsDeclsPatBindD (GHC.L l (GHC.ValD d)) = hsDeclsPatBind (GHC.L l d)
#endif
hsDeclsPatBindD LHsDecl GhcPs
x = String -> TransformT m [LHsDecl GhcPs]
forall a. HasCallStack => String -> a
error (String -> TransformT m [LHsDecl GhcPs])
-> String -> TransformT m [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ String
"hsDeclsPatBindD called for:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LHsDecl GhcPs -> String
forall a. Outputable a => a -> String
showGhc LHsDecl GhcPs
x

-- | Extract the immediate declarations for a 'GHC.PatBind'. This
-- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent
-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is
-- idempotent.
hsDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs]
#if __GLASGOW_HASKELL__ > 804
hsDeclsPatBind :: LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
hsDeclsPatBind d :: LHsBind GhcPs
d@(GHC.L SrcSpan
_ (GHC.PatBind XPatBind GhcPs GhcPs
_ LPat GhcPs
_ (GHC.GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_ [LGRHS GhcPs (LHsExpr GhcPs)]
_grhs (GHC.L SrcSpan
_ HsLocalBinds GhcPs
lb)) ([Tickish Id], [[Tickish Id]])
_)) = do
#elif __GLASGOW_HASKELL__ > 710
hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs (GHC.L _ lb)) _ _ _)) = do
#else
hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do
#endif
  [LHsDecl GhcPs]
decls <- HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
hsDeclsValBinds HsLocalBinds GhcPs
lb
  LHsBind GhcPs -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall a (m :: * -> *).
(Data a, Monad m) =>
Located a -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
orderedDecls LHsBind GhcPs
d [LHsDecl GhcPs]
decls
hsDeclsPatBind LHsBind GhcPs
x = String -> TransformT m [LHsDecl GhcPs]
forall a. HasCallStack => String -> a
error (String -> TransformT m [LHsDecl GhcPs])
-> String -> TransformT m [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ String
"hsDeclsPatBind called for:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LHsBind GhcPs -> String
forall a. Outputable a => a -> String
showGhc LHsBind GhcPs
x

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

-- | Replace the immediate declarations for a 'GHC.PatBind' wrapped in a 'GHC.ValD'. This
-- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent
-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is
-- idempotent.
replaceDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> [GHC.LHsDecl GhcPs]
                     -> TransformT m (GHC.LHsDecl GhcPs)
#if __GLASGOW_HASKELL__ > 804
replaceDeclsPatBindD :: LHsDecl GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsDecl GhcPs)
replaceDeclsPatBindD (GHC.L SrcSpan
l (GHC.ValD XValD GhcPs
x HsBindLR GhcPs GhcPs
d)) [LHsDecl GhcPs]
newDecls = do
  (GHC.L SrcSpan
_ HsBindLR GhcPs GhcPs
d') <- LHsBind GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsBind GhcPs)
forall (m :: * -> *).
Monad m =>
LHsBind GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsBind GhcPs)
replaceDeclsPatBind (SrcSpan -> HsBindLR GhcPs GhcPs -> LHsBind GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l HsBindLR GhcPs GhcPs
d) [LHsDecl GhcPs]
newDecls
  LHsDecl GhcPs -> TransformT m (LHsDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XValD GhcPs -> HsBindLR GhcPs GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
GHC.ValD XValD GhcPs
x HsBindLR GhcPs GhcPs
d'))
#else
replaceDeclsPatBindD (GHC.L l (GHC.ValD d)) newDecls = do
  (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls
  return (GHC.L l (GHC.ValD d'))
#endif
replaceDeclsPatBindD LHsDecl GhcPs
x [LHsDecl GhcPs]
_ = String -> TransformT m (LHsDecl GhcPs)
forall a. HasCallStack => String -> a
error (String -> TransformT m (LHsDecl GhcPs))
-> String -> TransformT m (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ String
"replaceDeclsPatBindD called for:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LHsDecl GhcPs -> String
forall a. Outputable a => a -> String
showGhc LHsDecl GhcPs
x

-- | Replace the immediate declarations for a 'GHC.PatBind'. This
-- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent
-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is
-- idempotent.
replaceDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> [GHC.LHsDecl GhcPs]
                    -> TransformT m (GHC.LHsBind GhcPs)
#if __GLASGOW_HASKELL__ > 804
replaceDeclsPatBind :: LHsBind GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsBind GhcPs)
replaceDeclsPatBind p :: LHsBind GhcPs
p@(GHC.L SrcSpan
l (GHC.PatBind XPatBind GhcPs GhcPs
x LPat GhcPs
a (GHC.GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
xr [LGRHS GhcPs (LHsExpr GhcPs)]
rhss GenLocated SrcSpan (HsLocalBinds GhcPs)
binds) ([Tickish Id], [[Tickish Id]])
b)) [LHsDecl GhcPs]
newDecls
#else
replaceDeclsPatBind p@(GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds) b c d)) newDecls
#endif
    = do
        String -> TransformT m ()
forall (m :: * -> *). Monad m => String -> TransformT m ()
logTr String
"replaceDecls PatBind"
        -- Need to throw in a fresh where clause if the binds were empty,
        -- in the annotations.
#if __GLASGOW_HASKELL__ <= 710
        case binds of
#else
        case GenLocated SrcSpan (HsLocalBinds GhcPs)
-> SrcSpanLess (GenLocated SrcSpan (HsLocalBinds GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc GenLocated SrcSpan (HsLocalBinds GhcPs)
binds of
#endif
#if __GLASGOW_HASKELL__ > 804
          GHC.EmptyLocalBinds{} -> do
#else
          GHC.EmptyLocalBinds -> do
#endif
            let
              addWhere :: Anns -> Anns
addWhere Anns
mkds =
                case AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (LHsBind GhcPs -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey LHsBind GhcPs
p) Anns
mkds of
                  Maybe Annotation
Nothing -> String -> Anns
forall a. HasCallStack => String -> a
error String
"wtf"
                  Just Annotation
ann -> AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (LHsBind GhcPs -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey LHsBind GhcPs
p) Annotation
ann1 Anns
mkds
                    where
                      ann1 :: Annotation
ann1 = Annotation
ann { annsDP :: [(KeywordId, DeltaPos)]
annsDP = Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
ann [(KeywordId, DeltaPos)]
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ [(AnnKeywordId -> KeywordId
G AnnKeywordId
GHC.AnnWhere,(Int, Int) -> DeltaPos
DP (Int
1,Int
2))]
                                 }
            (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT Anns -> Anns
addWhere
            (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (LHsDecl GhcPs -> Int -> Int -> Anns -> Anns
forall a. Data a => Located a -> Int -> Int -> Anns -> Anns
setPrecedingLines (String -> [LHsDecl GhcPs] -> LHsDecl GhcPs
forall a. String -> [a] -> a
ghead String
"LMatch.replaceDecls" [LHsDecl GhcPs]
newDecls) Int
1 Int
4)

          SrcSpanLess (GenLocated SrcSpan (HsLocalBinds GhcPs))
_ -> () -> TransformT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (AnnKey -> [LHsDecl GhcPs] -> Anns -> Anns
forall b. AnnKey -> [Located b] -> Anns -> Anns
captureOrderAnnKey (LHsBind GhcPs -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey LHsBind GhcPs
p) [LHsDecl GhcPs]
newDecls)
#if __GLASGOW_HASKELL__ <= 710
        binds' <- replaceDeclsValbinds binds newDecls
#else
        HsLocalBinds GhcPs
binds'' <- HsLocalBinds GhcPs
-> [LHsDecl GhcPs] -> TransformT m (HsLocalBinds GhcPs)
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs
-> [LHsDecl GhcPs] -> TransformT m (HsLocalBinds GhcPs)
replaceDeclsValbinds (GenLocated SrcSpan (HsLocalBinds GhcPs)
-> SrcSpanLess (GenLocated SrcSpan (HsLocalBinds GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc GenLocated SrcSpan (HsLocalBinds GhcPs)
binds) [LHsDecl GhcPs]
newDecls
        let binds' :: GenLocated SrcSpan (HsLocalBinds GhcPs)
binds' = SrcSpan
-> HsLocalBinds GhcPs -> GenLocated SrcSpan (HsLocalBinds GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L (GenLocated SrcSpan (HsLocalBinds GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc GenLocated SrcSpan (HsLocalBinds GhcPs)
binds) HsLocalBinds GhcPs
binds''
#endif
#if __GLASGOW_HASKELL__ > 804
        LHsBind GhcPs -> TransformT m (LHsBind GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsBindLR GhcPs GhcPs -> LHsBind GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XPatBind GhcPs GhcPs
-> LPat GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
-> ([Tickish Id], [[Tickish Id]])
-> HsBindLR GhcPs GhcPs
forall idL idR.
XPatBind idL idR
-> LPat idL
-> GRHSs idR (LHsExpr idR)
-> ([Tickish Id], [[Tickish Id]])
-> HsBindLR idL idR
GHC.PatBind XPatBind GhcPs GhcPs
x LPat GhcPs
a (XCGRHSs GhcPs (LHsExpr GhcPs)
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> GenLocated SrcSpan (HsLocalBinds GhcPs)
-> GRHSs GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GHC.GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
xr [LGRHS GhcPs (LHsExpr GhcPs)]
rhss GenLocated SrcSpan (HsLocalBinds GhcPs)
binds') ([Tickish Id], [[Tickish Id]])
b))
#else
        return (GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds') b c d))
#endif
replaceDeclsPatBind LHsBind GhcPs
x [LHsDecl GhcPs]
_ = String -> TransformT m (LHsBind GhcPs)
forall a. HasCallStack => String -> a
error (String -> TransformT m (LHsBind GhcPs))
-> String -> TransformT m (LHsBind GhcPs)
forall a b. (a -> b) -> a -> b
$ String
"replaceDeclsPatBind called for:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LHsBind GhcPs -> String
forall a. Outputable a => a -> String
showGhc LHsBind GhcPs
x

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

instance HasDecls (GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) where
#if __GLASGOW_HASKELL__ > 804
  hsDecls :: LStmt GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs]
hsDecls ls :: LStmt GhcPs (LHsExpr GhcPs)
ls@(GHC.L SrcSpan
_ (GHC.LetStmt XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
_ (GHC.L SrcSpan
_ HsLocalBinds GhcPs
lb))) = do
#elif __GLASGOW_HASKELL__ > 710
  hsDecls ls@(GHC.L _ (GHC.LetStmt (GHC.L _ lb))) = do
#else
  hsDecls ls@(GHC.L _ (GHC.LetStmt lb))       = do
#endif
    [LHsDecl GhcPs]
decls <- HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
hsDeclsValBinds HsLocalBinds GhcPs
lb
    LStmt GhcPs (LHsExpr GhcPs)
-> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall a (m :: * -> *).
(Data a, Monad m) =>
Located a -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
orderedDecls LStmt GhcPs (LHsExpr GhcPs)
ls [LHsDecl GhcPs]
decls
#if __GLASGOW_HASKELL__ > 804
  hsDecls (GHC.L SrcSpan
_ (GHC.LastStmt XLastStmt GhcPs GhcPs (LHsExpr GhcPs)
_ LHsExpr GhcPs
e Bool
_ SyntaxExpr GhcPs
_))    = LHsExpr GhcPs -> TransformT m [LHsDecl GhcPs]
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> TransformT m [LHsDecl GhcPs]
hsDecls LHsExpr GhcPs
e
#elif __GLASGOW_HASKELL__ >= 804
  hsDecls (GHC.L _ (GHC.LastStmt e _ _))      = hsDecls e
#elif __GLASGOW_HASKELL__ > 800
  hsDecls (GHC.L _ (GHC.LastStmt e _ _))      = hsDecls e
#elif __GLASGOW_HASKELL__ > 710
  hsDecls (GHC.L _ (GHC.LastStmt e _ _))      = hsDecls e
#else
  hsDecls (GHC.L _ (GHC.LastStmt e _))        = hsDecls e
#endif
#if __GLASGOW_HASKELL__ > 804
  hsDecls (GHC.L SrcSpan
_ (GHC.BindStmt XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
_ LPat GhcPs
_pat LHsExpr GhcPs
e SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) = LHsExpr GhcPs -> TransformT m [LHsDecl GhcPs]
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> TransformT m [LHsDecl GhcPs]
hsDecls LHsExpr GhcPs
e
#elif __GLASGOW_HASKELL__ > 710
  hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _ _)) = hsDecls e
#else
  hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _)) = hsDecls e
#endif
#if __GLASGOW_HASKELL__ > 804
  hsDecls (GHC.L SrcSpan
_ (GHC.BodyStmt XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
_ LHsExpr GhcPs
e SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_))    = LHsExpr GhcPs -> TransformT m [LHsDecl GhcPs]
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> TransformT m [LHsDecl GhcPs]
hsDecls LHsExpr GhcPs
e
#else
  hsDecls (GHC.L _ (GHC.BodyStmt e _ _ _))    = hsDecls e
#endif
  hsDecls LStmt GhcPs (LHsExpr GhcPs)
_                                   = [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return []

#if __GLASGOW_HASKELL__ > 804
  replaceDecls :: LStmt GhcPs (LHsExpr GhcPs)
-> [LHsDecl GhcPs] -> TransformT m (LStmt GhcPs (LHsExpr GhcPs))
replaceDecls s :: LStmt GhcPs (LHsExpr GhcPs)
s@(GHC.L SrcSpan
l (GHC.LetStmt XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
x GenLocated SrcSpan (HsLocalBinds GhcPs)
lb)) [LHsDecl GhcPs]
newDecls
#else
  replaceDecls s@(GHC.L l (GHC.LetStmt lb)) newDecls
#endif
    = do
        (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT (LStmt GhcPs (LHsExpr GhcPs) -> [LHsDecl GhcPs] -> Anns -> Anns
forall a b. Data a => Located a -> [Located b] -> Anns -> Anns
captureOrder LStmt GhcPs (LHsExpr GhcPs)
s [LHsDecl GhcPs]
newDecls)
#if __GLASGOW_HASKELL__ <= 710
        lb' <- replaceDeclsValbinds lb newDecls
#else
        HsLocalBinds GhcPs
lb'' <- HsLocalBinds GhcPs
-> [LHsDecl GhcPs] -> TransformT m (HsLocalBinds GhcPs)
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs
-> [LHsDecl GhcPs] -> TransformT m (HsLocalBinds GhcPs)
replaceDeclsValbinds (GenLocated SrcSpan (HsLocalBinds GhcPs)
-> SrcSpanLess (GenLocated SrcSpan (HsLocalBinds GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc GenLocated SrcSpan (HsLocalBinds GhcPs)
lb) [LHsDecl GhcPs]
newDecls
        let lb' :: GenLocated SrcSpan (HsLocalBinds GhcPs)
lb' = SrcSpan
-> HsLocalBinds GhcPs -> GenLocated SrcSpan (HsLocalBinds GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L (GenLocated SrcSpan (HsLocalBinds GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc GenLocated SrcSpan (HsLocalBinds GhcPs)
lb) HsLocalBinds GhcPs
lb''
#endif
#if __GLASGOW_HASKELL__ > 804
        LStmt GhcPs (LHsExpr GhcPs)
-> TransformT m (LStmt GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
-> LStmt GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
-> GenLocated SrcSpan (HsLocalBinds GhcPs)
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
GHC.LetStmt XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
x GenLocated SrcSpan (HsLocalBinds GhcPs)
lb'))
#else
        return (GHC.L l (GHC.LetStmt   lb'))
#endif
#if __GLASGOW_HASKELL__ > 804
  replaceDecls (GHC.L SrcSpan
l (GHC.LastStmt XLastStmt GhcPs GhcPs (LHsExpr GhcPs)
x LHsExpr GhcPs
e Bool
d SyntaxExpr GhcPs
se)) [LHsDecl GhcPs]
newDecls
    = do
        LHsExpr GhcPs
e' <- LHsExpr GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsExpr GhcPs)
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> [LHsDecl GhcPs] -> TransformT m t
replaceDecls LHsExpr GhcPs
e [LHsDecl GhcPs]
newDecls
        LStmt GhcPs (LHsExpr GhcPs)
-> TransformT m (LStmt GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
-> LStmt GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XLastStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LHsExpr GhcPs
-> Bool
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XLastStmt idL idR body
-> body -> Bool -> SyntaxExpr idR -> StmtLR idL idR body
GHC.LastStmt XLastStmt GhcPs GhcPs (LHsExpr GhcPs)
x LHsExpr GhcPs
e' Bool
d SyntaxExpr GhcPs
se))
#elif __GLASGOW_HASKELL__ > 710
  replaceDecls (GHC.L l (GHC.LastStmt e d se)) newDecls
    = do
        e' <- replaceDecls e newDecls
        return (GHC.L l (GHC.LastStmt e' d se))
#else
  replaceDecls (GHC.L l (GHC.LastStmt e se)) newDecls
    = do
        e' <- replaceDecls e newDecls
        return (GHC.L l (GHC.LastStmt e' se))
#endif
#if __GLASGOW_HASKELL__ > 804
  replaceDecls (GHC.L SrcSpan
l (GHC.BindStmt XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
x LPat GhcPs
pat LHsExpr GhcPs
e SyntaxExpr GhcPs
a SyntaxExpr GhcPs
b)) [LHsDecl GhcPs]
newDecls
    = do
      LHsExpr GhcPs
e' <- LHsExpr GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsExpr GhcPs)
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> [LHsDecl GhcPs] -> TransformT m t
replaceDecls LHsExpr GhcPs
e [LHsDecl GhcPs]
newDecls
      LStmt GhcPs (LHsExpr GhcPs)
-> TransformT m (LStmt GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
-> LStmt GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LPat GhcPs
-> LHsExpr GhcPs
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
GHC.BindStmt XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
x LPat GhcPs
pat LHsExpr GhcPs
e' SyntaxExpr GhcPs
a SyntaxExpr GhcPs
b))
#elif __GLASGOW_HASKELL__ > 710
  replaceDecls (GHC.L l (GHC.BindStmt pat e a b c)) newDecls
    = do
      e' <- replaceDecls e newDecls
      return (GHC.L l (GHC.BindStmt pat e' a b c))
#else
  replaceDecls (GHC.L l (GHC.BindStmt pat e a b)) newDecls
    = do
      e' <- replaceDecls e newDecls
      return (GHC.L l (GHC.BindStmt pat e' a b))
#endif

#if __GLASGOW_HASKELL__ > 804
  replaceDecls (GHC.L SrcSpan
l (GHC.BodyStmt XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
x LHsExpr GhcPs
e SyntaxExpr GhcPs
a SyntaxExpr GhcPs
b)) [LHsDecl GhcPs]
newDecls
    = do
      LHsExpr GhcPs
e' <- LHsExpr GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsExpr GhcPs)
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> [LHsDecl GhcPs] -> TransformT m t
replaceDecls LHsExpr GhcPs
e [LHsDecl GhcPs]
newDecls
      LStmt GhcPs (LHsExpr GhcPs)
-> TransformT m (LStmt GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
-> LStmt GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LHsExpr GhcPs
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
GHC.BodyStmt XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
x LHsExpr GhcPs
e' SyntaxExpr GhcPs
a SyntaxExpr GhcPs
b))
#else
  replaceDecls (GHC.L l (GHC.BodyStmt e a b c)) newDecls
    = do
      e' <- replaceDecls e newDecls
      return (GHC.L l (GHC.BodyStmt e' a b c))
#endif
  replaceDecls LStmt GhcPs (LHsExpr GhcPs)
x [LHsDecl GhcPs]
_newDecls = LStmt GhcPs (LHsExpr GhcPs)
-> TransformT m (LStmt GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (LHsExpr GhcPs)
x

-- =====================================================================
-- end of HasDecls instances
-- =====================================================================

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

-- |Do a transformation on an AST fragment by providing a function to process
-- the general case and one specific for a 'GHC.LHsBind'. This is required
-- because a 'GHC.FunBind' may have multiple 'GHC.Match' items, so we cannot
-- gurantee that 'replaceDecls' after 'hsDecls' is idempotent.
hasDeclsSybTransform :: (SYB.Data t2,Monad m)
       => (forall t. HasDecls t => t -> m t)
             -- ^Worker function for the general case
       -> (GHC.LHsBind GhcPs -> m (GHC.LHsBind GhcPs))
             -- ^Worker function for FunBind/PatBind
       -> t2 -- ^Item to be updated
       -> m t2
hasDeclsSybTransform :: (forall t. HasDecls t => t -> m t)
-> (LHsBind GhcPs -> m (LHsBind GhcPs)) -> t2 -> m t2
hasDeclsSybTransform forall t. HasDecls t => t -> m t
workerHasDecls LHsBind GhcPs -> m (LHsBind GhcPs)
workerBind t2
t = t2 -> m t2
trf t2
t
  where
    trf :: t2 -> m t2
trf = (ParsedSource -> m ParsedSource) -> t2 -> m t2
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
SYB.mkM   ParsedSource -> m ParsedSource
parsedSource
         (t2 -> m t2)
-> (LMatch GhcPs (LHsExpr GhcPs)
    -> m (LMatch GhcPs (LHsExpr GhcPs)))
-> t2
-> m t2
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`SYB.extM` LMatch GhcPs (LHsExpr GhcPs) -> m (LMatch GhcPs (LHsExpr GhcPs))
lmatch
         (t2 -> m t2) -> (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> t2 -> m t2
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`SYB.extM` LHsExpr GhcPs -> m (LHsExpr GhcPs)
lexpr
         (t2 -> m t2)
-> (LStmt GhcPs (LHsExpr GhcPs) -> m (LStmt GhcPs (LHsExpr GhcPs)))
-> t2
-> m t2
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`SYB.extM` LStmt GhcPs (LHsExpr GhcPs) -> m (LStmt GhcPs (LHsExpr GhcPs))
lstmt
         (t2 -> m t2) -> (LHsBind GhcPs -> m (LHsBind GhcPs)) -> t2 -> m t2
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`SYB.extM` LHsBind GhcPs -> m (LHsBind GhcPs)
lhsbind
         (t2 -> m t2) -> (LHsDecl GhcPs -> m (LHsDecl GhcPs)) -> t2 -> m t2
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`SYB.extM` LHsDecl GhcPs -> m (LHsDecl GhcPs)
lvald

    parsedSource :: ParsedSource -> m ParsedSource
parsedSource (ParsedSource
p::GHC.ParsedSource) = ParsedSource -> m ParsedSource
forall t. HasDecls t => t -> m t
workerHasDecls ParsedSource
p

    lmatch :: LMatch GhcPs (LHsExpr GhcPs) -> m (LMatch GhcPs (LHsExpr GhcPs))
lmatch (LMatch GhcPs (LHsExpr GhcPs)
lm::GHC.LMatch GhcPs (GHC.LHsExpr GhcPs))
      = LMatch GhcPs (LHsExpr GhcPs) -> m (LMatch GhcPs (LHsExpr GhcPs))
forall t. HasDecls t => t -> m t
workerHasDecls LMatch GhcPs (LHsExpr GhcPs)
lm

    lexpr :: LHsExpr GhcPs -> m (LHsExpr GhcPs)
lexpr (LHsExpr GhcPs
le::GHC.LHsExpr GhcPs)
      = LHsExpr GhcPs -> m (LHsExpr GhcPs)
forall t. HasDecls t => t -> m t
workerHasDecls LHsExpr GhcPs
le

    lstmt :: LStmt GhcPs (LHsExpr GhcPs) -> m (LStmt GhcPs (LHsExpr GhcPs))
lstmt (LStmt GhcPs (LHsExpr GhcPs)
d::GHC.LStmt GhcPs (GHC.LHsExpr GhcPs))
      = LStmt GhcPs (LHsExpr GhcPs) -> m (LStmt GhcPs (LHsExpr GhcPs))
forall t. HasDecls t => t -> m t
workerHasDecls LStmt GhcPs (LHsExpr GhcPs)
d

    lhsbind :: LHsBind GhcPs -> m (LHsBind GhcPs)
lhsbind (b :: LHsBind GhcPs
b@(GHC.L SrcSpan
_ GHC.FunBind{}):: GHC.LHsBind GhcPs)
      = LHsBind GhcPs -> m (LHsBind GhcPs)
workerBind LHsBind GhcPs
b
    lhsbind b :: LHsBind GhcPs
b@(GHC.L SrcSpan
_ GHC.PatBind{})
      = LHsBind GhcPs -> m (LHsBind GhcPs)
workerBind LHsBind GhcPs
b
    lhsbind LHsBind GhcPs
x = LHsBind GhcPs -> m (LHsBind GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBind GhcPs
x

#if __GLASGOW_HASKELL__ > 804
    lvald :: LHsDecl GhcPs -> m (LHsDecl GhcPs)
lvald (GHC.L SrcSpan
l (GHC.ValD XValD GhcPs
x HsBindLR GhcPs GhcPs
d)) = do
      (GHC.L SrcSpan
_ HsBindLR GhcPs GhcPs
d') <- LHsBind GhcPs -> m (LHsBind GhcPs)
lhsbind (SrcSpan -> HsBindLR GhcPs GhcPs -> LHsBind GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l HsBindLR GhcPs GhcPs
d)
      LHsDecl GhcPs -> m (LHsDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l (XValD GhcPs -> HsBindLR GhcPs GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
GHC.ValD XValD GhcPs
x HsBindLR GhcPs GhcPs
d'))
#else
    lvald (GHC.L l (GHC.ValD d)) = do
      (GHC.L _ d') <- lhsbind (GHC.L l d)
      return (GHC.L l (GHC.ValD d'))
#endif
    lvald LHsDecl GhcPs
x = LHsDecl GhcPs -> m (LHsDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsDecl GhcPs
x

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

-- |A 'GHC.FunBind' wraps up one or more 'GHC.Match' items. 'hsDecls' cannot
-- return anything for these as there is not meaningful 'replaceDecls' for it.
-- This function provides a version of 'hsDecls' that returns the 'GHC.FunBind'
-- decls too, where they are needed for analysis only.
hsDeclsGeneric :: (SYB.Data t,Monad m) => t -> TransformT m [GHC.LHsDecl GhcPs]
hsDeclsGeneric :: t -> TransformT m [LHsDecl GhcPs]
hsDeclsGeneric t
t = t -> TransformT m [LHsDecl GhcPs]
q t
t
  where
    q :: t -> TransformT m [LHsDecl GhcPs]
q = [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        TransformT m [LHsDecl GhcPs]
-> (ParsedSource -> TransformT m [LHsDecl GhcPs])
-> t
-> TransformT m [LHsDecl GhcPs]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`SYB.mkQ`  ParsedSource -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
ParsedSource -> TransformT m [LHsDecl GhcPs]
parsedSource
        (t -> TransformT m [LHsDecl GhcPs])
-> (LMatch GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs])
-> t
-> TransformT m [LHsDecl GhcPs]
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`SYB.extQ` LMatch GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
LMatch GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs]
lmatch
        (t -> TransformT m [LHsDecl GhcPs])
-> (LHsExpr GhcPs -> TransformT m [LHsDecl GhcPs])
-> t
-> TransformT m [LHsDecl GhcPs]
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`SYB.extQ` LHsExpr GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
LHsExpr GhcPs -> TransformT m [LHsDecl GhcPs]
lexpr
        (t -> TransformT m [LHsDecl GhcPs])
-> (LStmt GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs])
-> t
-> TransformT m [LHsDecl GhcPs]
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`SYB.extQ` LStmt GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
LStmt GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs]
lstmt
        (t -> TransformT m [LHsDecl GhcPs])
-> (LHsBind GhcPs -> TransformT m [LHsDecl GhcPs])
-> t
-> TransformT m [LHsDecl GhcPs]
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`SYB.extQ` LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
lhsbind
        (t -> TransformT m [LHsDecl GhcPs])
-> (LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs])
-> t
-> TransformT m [LHsDecl GhcPs]
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`SYB.extQ` LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs]
lhsbindd
        (t -> TransformT m [LHsDecl GhcPs])
-> (GenLocated SrcSpan (HsLocalBinds GhcPs)
    -> TransformT m [LHsDecl GhcPs])
-> t
-> TransformT m [LHsDecl GhcPs]
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`SYB.extQ` GenLocated SrcSpan (HsLocalBinds GhcPs)
-> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
GenLocated SrcSpan (HsLocalBinds GhcPs)
-> TransformT m [LHsDecl GhcPs]
llocalbinds
        (t -> TransformT m [LHsDecl GhcPs])
-> (HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs])
-> t
-> TransformT m [LHsDecl GhcPs]
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`SYB.extQ` HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
localbinds

    parsedSource :: ParsedSource -> TransformT m [LHsDecl GhcPs]
parsedSource (ParsedSource
p::GHC.ParsedSource) = ParsedSource -> TransformT m [LHsDecl GhcPs]
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> TransformT m [LHsDecl GhcPs]
hsDecls ParsedSource
p

    lmatch :: LMatch GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs]
lmatch (LMatch GhcPs (LHsExpr GhcPs)
lm::GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) = LMatch GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs]
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> TransformT m [LHsDecl GhcPs]
hsDecls LMatch GhcPs (LHsExpr GhcPs)
lm

    lexpr :: LHsExpr GhcPs -> TransformT m [LHsDecl GhcPs]
lexpr (LHsExpr GhcPs
le::GHC.LHsExpr GhcPs) = LHsExpr GhcPs -> TransformT m [LHsDecl GhcPs]
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> TransformT m [LHsDecl GhcPs]
hsDecls LHsExpr GhcPs
le

    lstmt :: LStmt GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs]
lstmt (LStmt GhcPs (LHsExpr GhcPs)
d::GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) = LStmt GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs]
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> TransformT m [LHsDecl GhcPs]
hsDecls LStmt GhcPs (LHsExpr GhcPs)
d

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

    lhsbind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs]
#if __GLASGOW_HASKELL__ > 808
    lhsbind :: LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
lhsbind (GHC.L SrcSpan
_ (GHC.FunBind XFunBind GhcPs GhcPs
_ Located (IdP GhcPs)
_ (GHC.MG XMG GhcPs (LHsExpr GhcPs)
_ (GHC.L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
matches) Origin
_) HsWrapper
_ [Tickish Id]
_)) = do
#elif __GLASGOW_HASKELL__ > 804
    lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) = do
#elif __GLASGOW_HASKELL__ > 710
    lhsbind (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) = do
#else
    lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do
#endif
        [[LHsDecl GhcPs]]
dss <- (LMatch GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs])
-> [LMatch GhcPs (LHsExpr GhcPs)] -> TransformT m [[LHsDecl GhcPs]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LMatch GhcPs (LHsExpr GhcPs) -> TransformT m [LHsDecl GhcPs]
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> TransformT m [LHsDecl GhcPs]
hsDecls [LMatch GhcPs (LHsExpr GhcPs)]
matches
        [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[LHsDecl GhcPs]] -> [LHsDecl GhcPs]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LHsDecl GhcPs]]
dss)
    lhsbind p :: LHsBind GhcPs
p@(GHC.L SrcSpan
_ (GHC.PatBind{})) = do
      LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
hsDeclsPatBind LHsBind GhcPs
p
    lhsbind LHsBind GhcPs
_ = [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return []

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

#if __GLASGOW_HASKELL__ > 804
    lhsbindd :: LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs]
lhsbindd (GHC.L SrcSpan
l (GHC.ValD XValD GhcPs
_ HsBindLR GhcPs GhcPs
d)) = LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
lhsbind (SrcSpan -> HsBindLR GhcPs GhcPs -> LHsBind GhcPs
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l HsBindLR GhcPs GhcPs
d)
#else
    lhsbindd (GHC.L l (GHC.ValD d)) = lhsbind (GHC.L l d)
#endif
    lhsbindd LHsDecl GhcPs
_ = [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return []

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

    llocalbinds :: (Monad m) => GHC.Located (GHC.HsLocalBinds GhcPs) -> TransformT m [GHC.LHsDecl GhcPs]
    llocalbinds :: GenLocated SrcSpan (HsLocalBinds GhcPs)
-> TransformT m [LHsDecl GhcPs]
llocalbinds (GHC.L SrcSpan
_ HsLocalBinds GhcPs
ds) = HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
localbinds HsLocalBinds GhcPs
ds

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

    localbinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> TransformT m [GHC.LHsDecl GhcPs]
    localbinds :: HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
localbinds HsLocalBinds GhcPs
d = HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
hsDeclsValBinds HsLocalBinds GhcPs
d

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

-- |Look up the annotated order and sort the decls accordingly
orderedDecls :: (Data a,Monad m) => GHC.Located a -> [GHC.LHsDecl GhcPs] -> TransformT m [GHC.LHsDecl GhcPs]
orderedDecls :: Located a -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
orderedDecls Located a
parent [LHsDecl GhcPs]
decls = do
  Anns
ans <- TransformT m Anns
forall (m :: * -> *). Monad m => TransformT m Anns
getAnnsT
  case Located a -> Anns -> Maybe Annotation
forall a.
(Data a, Data (SrcSpanLess a), HasSrcSpan a) =>
a -> Anns -> Maybe Annotation
getAnnotationEP Located a
parent Anns
ans of
    Maybe Annotation
Nothing -> String -> TransformT m [LHsDecl GhcPs]
forall a. HasCallStack => String -> a
error (String -> TransformT m [LHsDecl GhcPs])
-> String -> TransformT m [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ String
"orderedDecls:no annotation for:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Anns -> Int -> Located a -> String
forall a. Data a => Anns -> Int -> a -> String
showAnnData Anns
emptyAnns Int
0 Located a
parent
    Just Annotation
ann -> case Annotation -> Maybe [SrcSpan]
annSortKey Annotation
ann of
      Maybe [SrcSpan]
Nothing -> do
        [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return [LHsDecl GhcPs]
decls
      Just [SrcSpan]
keys -> do
        let ds :: [(SrcSpan, LHsDecl GhcPs)]
ds = (LHsDecl GhcPs -> (SrcSpan, LHsDecl GhcPs))
-> [LHsDecl GhcPs] -> [(SrcSpan, LHsDecl GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (\LHsDecl GhcPs
s -> (LHsDecl GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc LHsDecl GhcPs
s,LHsDecl GhcPs
s)) [LHsDecl GhcPs]
decls
            ordered :: [LHsDecl GhcPs]
ordered = ((SrcSpan, LHsDecl GhcPs) -> LHsDecl GhcPs)
-> [(SrcSpan, LHsDecl GhcPs)] -> [LHsDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan, LHsDecl GhcPs) -> LHsDecl GhcPs
forall a b. (a, b) -> b
snd ([(SrcSpan, LHsDecl GhcPs)] -> [LHsDecl GhcPs])
-> [(SrcSpan, LHsDecl GhcPs)] -> [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ [(SrcSpan, LHsDecl GhcPs)]
-> [SrcSpan] -> [(SrcSpan, LHsDecl GhcPs)]
forall a. [(SrcSpan, a)] -> [SrcSpan] -> [(SrcSpan, a)]
orderByKey [(SrcSpan, LHsDecl GhcPs)]
ds [SrcSpan]
keys
        [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return [LHsDecl GhcPs]
ordered

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

-- | Utility function for extracting decls from 'GHC.HsLocalBinds'. Use with
-- care, as this does not necessarily return the declarations in order, the
-- ordering should be done by the calling function from the 'GHC.HsLocalBinds'
-- context in the AST.
hsDeclsValBinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> TransformT m [GHC.LHsDecl GhcPs]
hsDeclsValBinds :: HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
hsDeclsValBinds HsLocalBinds GhcPs
lb = case HsLocalBinds GhcPs
lb of
#if __GLASGOW_HASKELL__ > 804
    GHC.HsValBinds XHsValBinds GhcPs GhcPs
_ (GHC.ValBinds XValBinds GhcPs GhcPs
_ LHsBindsLR GhcPs GhcPs
bs [LSig GhcPs]
sigs) -> do
      let
        bds :: [LHsDecl GhcPs]
bds = (LHsBind GhcPs -> LHsDecl GhcPs)
-> [LHsBind GhcPs] -> [LHsDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsBind GhcPs -> LHsDecl GhcPs
wrapDecl (LHsBindsLR GhcPs GhcPs -> [LHsBind GhcPs]
forall a. Bag a -> [a]
GHC.bagToList LHsBindsLR GhcPs GhcPs
bs)
        sds :: [LHsDecl GhcPs]
sds = (LSig GhcPs -> LHsDecl GhcPs) -> [LSig GhcPs] -> [LHsDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LSig GhcPs -> LHsDecl GhcPs
wrapSig [LSig GhcPs]
sigs
      [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsDecl GhcPs]
bds [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
sds)
    GHC.HsValBinds XHsValBinds GhcPs GhcPs
_ (GHC.XValBindsLR XXValBindsLR GhcPs GhcPs
_) -> String -> TransformT m [LHsDecl GhcPs]
forall a. HasCallStack => String -> a
error (String -> TransformT m [LHsDecl GhcPs])
-> String -> TransformT m [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ String
"hsDecls.XValBindsLR not valid"
    GHC.HsIPBinds {}       -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    GHC.EmptyLocalBinds {} -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    GHC.XHsLocalBindsLR {} -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return []
#else
    GHC.HsValBinds (GHC.ValBindsIn bs sigs) -> do
      let
        bds = map wrapDecl (GHC.bagToList bs)
        sds = map wrapSig sigs
      return (bds ++ sds)
    GHC.HsValBinds (GHC.ValBindsOut _ _) -> error $ "hsDecls.ValbindsOut not valid"
    GHC.HsIPBinds _     -> return []
    GHC.EmptyLocalBinds -> return []
#endif

-- | Utility function for returning decls to 'GHC.HsLocalBinds'. Use with
-- care, as this does not manage the declaration order, the
-- ordering should be done by the calling function from the 'GHC.HsLocalBinds'
-- context in the AST.
replaceDeclsValbinds :: (Monad m)
                     => GHC.HsLocalBinds GhcPs -> [GHC.LHsDecl GhcPs]
                     -> TransformT m (GHC.HsLocalBinds GhcPs)
replaceDeclsValbinds :: HsLocalBinds GhcPs
-> [LHsDecl GhcPs] -> TransformT m (HsLocalBinds GhcPs)
replaceDeclsValbinds HsLocalBinds GhcPs
_ [] = do
#if __GLASGOW_HASKELL__ > 808
  HsLocalBinds GhcPs -> TransformT m (HsLocalBinds GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XEmptyLocalBinds GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
GHC.EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcPs GhcPs
GHC.NoExtField)
#elif __GLASGOW_HASKELL__ > 804
  return (GHC.EmptyLocalBinds GHC.noExt)
#else
  return (GHC.EmptyLocalBinds)
#endif
#if __GLASGOW_HASKELL__ > 804
replaceDeclsValbinds (GHC.HsValBinds XHsValBinds GhcPs GhcPs
_ HsValBindsLR GhcPs GhcPs
_b) [LHsDecl GhcPs]
new
#else
replaceDeclsValbinds (GHC.HsValBinds _b) new
#endif
    = do
        String -> TransformT m ()
forall (m :: * -> *). Monad m => String -> TransformT m ()
logTr String
"replaceDecls HsLocalBinds"
        let decs :: LHsBindsLR GhcPs GhcPs
decs = [LHsBind GhcPs] -> LHsBindsLR GhcPs GhcPs
forall a. [a] -> Bag a
GHC.listToBag ([LHsBind GhcPs] -> LHsBindsLR GhcPs GhcPs)
-> [LHsBind GhcPs] -> LHsBindsLR GhcPs GhcPs
forall a b. (a -> b) -> a -> b
$ (LHsDecl GhcPs -> [LHsBind GhcPs])
-> [LHsDecl GhcPs] -> [LHsBind GhcPs]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsDecl GhcPs -> [LHsBind GhcPs]
forall name. LHsDecl name -> [LHsBind name]
decl2Bind [LHsDecl GhcPs]
new
        let sigs :: [LSig GhcPs]
sigs = (LHsDecl GhcPs -> [LSig GhcPs]) -> [LHsDecl GhcPs] -> [LSig GhcPs]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsDecl GhcPs -> [LSig GhcPs]
forall name. LHsDecl name -> [LSig name]
decl2Sig [LHsDecl GhcPs]
new
#if __GLASGOW_HASKELL__ > 808
        HsLocalBinds GhcPs -> TransformT m (HsLocalBinds GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
GHC.HsValBinds NoExtField
XHsValBinds GhcPs GhcPs
GHC.NoExtField (XValBinds GhcPs GhcPs
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
GHC.ValBinds NoExtField
XValBinds GhcPs GhcPs
GHC.NoExtField LHsBindsLR GhcPs GhcPs
decs [LSig GhcPs]
sigs))
#elif __GLASGOW_HASKELL__ > 804
        return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs))
#else
        return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))
#endif
replaceDeclsValbinds (GHC.HsIPBinds {}) [LHsDecl GhcPs]
_new    = String -> TransformT m (HsLocalBinds GhcPs)
forall a. HasCallStack => String -> a
error String
"undefined replaceDecls HsIPBinds"
#if __GLASGOW_HASKELL__ > 804
replaceDeclsValbinds (GHC.EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_) [LHsDecl GhcPs]
new
#else
replaceDeclsValbinds (GHC.EmptyLocalBinds) new
#endif
    = do
        String -> TransformT m ()
forall (m :: * -> *). Monad m => String -> TransformT m ()
logTr String
"replaceDecls HsLocalBinds"
        let newBinds :: [[LHsBind GhcPs]]
newBinds = (LHsDecl GhcPs -> [LHsBind GhcPs])
-> [LHsDecl GhcPs] -> [[LHsBind GhcPs]]
forall a b. (a -> b) -> [a] -> [b]
map LHsDecl GhcPs -> [LHsBind GhcPs]
forall name. LHsDecl name -> [LHsBind name]
decl2Bind [LHsDecl GhcPs]
new
            newSigs :: [[LSig GhcPs]]
newSigs  = (LHsDecl GhcPs -> [LSig GhcPs])
-> [LHsDecl GhcPs] -> [[LSig GhcPs]]
forall a b. (a -> b) -> [a] -> [b]
map LHsDecl GhcPs -> [LSig GhcPs]
forall name. LHsDecl name -> [LSig name]
decl2Sig  [LHsDecl GhcPs]
new
        let decs :: LHsBindsLR GhcPs GhcPs
decs = [LHsBind GhcPs] -> LHsBindsLR GhcPs GhcPs
forall a. [a] -> Bag a
GHC.listToBag ([LHsBind GhcPs] -> LHsBindsLR GhcPs GhcPs)
-> [LHsBind GhcPs] -> LHsBindsLR GhcPs GhcPs
forall a b. (a -> b) -> a -> b
$ [[LHsBind GhcPs]] -> [LHsBind GhcPs]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LHsBind GhcPs]]
newBinds
        let sigs :: [LSig GhcPs]
sigs = [[LSig GhcPs]] -> [LSig GhcPs]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LSig GhcPs]]
newSigs
#if __GLASGOW_HASKELL__ > 808
        HsLocalBinds GhcPs -> TransformT m (HsLocalBinds GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
GHC.HsValBinds NoExtField
XHsValBinds GhcPs GhcPs
GHC.NoExtField (XValBinds GhcPs GhcPs
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
GHC.ValBinds NoExtField
XValBinds GhcPs GhcPs
GHC.NoExtField LHsBindsLR GhcPs GhcPs
decs [LSig GhcPs]
sigs))
#elif __GLASGOW_HASKELL__ > 804
        return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs))
#else
        return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))
#endif
#if __GLASGOW_HASKELL__ > 804
replaceDeclsValbinds (GHC.XHsLocalBindsLR XXHsLocalBindsLR GhcPs GhcPs
_) [LHsDecl GhcPs]
_ = String -> TransformT m (HsLocalBinds GhcPs)
forall a. HasCallStack => String -> a
error String
"replaceDeclsValbinds. XHsLocalBindsLR"
#endif

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

type Decl  = GHC.LHsDecl GhcPs
type Match = GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)

-- |Modify a 'GHC.LHsBind' wrapped in a 'GHC.ValD'. For a 'GHC.PatBind' the
-- declarations are extracted and returned after modification. For a
-- 'GHC.FunBind' the supplied 'GHC.SrcSpan' is used to identify the specific
-- 'GHC.Match' to be transformed, for when there are multiple of them.
modifyValD :: forall m t. (HasTransform m)
                => GHC.SrcSpan
                -> Decl
                -> (Match -> [Decl] -> m ([Decl], Maybe t))
                -> m (Decl,Maybe t)
#if __GLASGOW_HASKELL__ > 804
modifyValD :: SrcSpan
-> LHsDecl GhcPs
-> (LMatch GhcPs (LHsExpr GhcPs)
    -> [LHsDecl GhcPs] -> m ([LHsDecl GhcPs], Maybe t))
-> m (LHsDecl GhcPs, Maybe t)
modifyValD SrcSpan
p pb :: LHsDecl GhcPs
pb@(GHC.L SrcSpan
ss (GHC.ValD XValD GhcPs
_ (GHC.PatBind {} ))) LMatch GhcPs (LHsExpr GhcPs)
-> [LHsDecl GhcPs] -> m ([LHsDecl GhcPs], Maybe t)
f =
#else
modifyValD p pb@(GHC.L ss (GHC.ValD (GHC.PatBind {} ))) f =
#endif
  if SrcSpan
ss SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
p
     then do
       [LHsDecl GhcPs]
ds <- TransformT Identity [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
forall (m :: * -> *) a. HasTransform m => Transform a -> m a
liftT (TransformT Identity [LHsDecl GhcPs] -> m [LHsDecl GhcPs])
-> TransformT Identity [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ LHsDecl GhcPs -> TransformT Identity [LHsDecl GhcPs]
forall (m :: * -> *).
Monad m =>
LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs]
hsDeclsPatBindD LHsDecl GhcPs
pb
       ([LHsDecl GhcPs]
ds',Maybe t
r) <- LMatch GhcPs (LHsExpr GhcPs)
-> [LHsDecl GhcPs] -> m ([LHsDecl GhcPs], Maybe t)
f (String -> LMatch GhcPs (LHsExpr GhcPs)
forall a. HasCallStack => String -> a
error String
"modifyValD.PatBind should not touch Match") [LHsDecl GhcPs]
ds
       LHsDecl GhcPs
pb' <- Transform (LHsDecl GhcPs) -> m (LHsDecl GhcPs)
forall (m :: * -> *) a. HasTransform m => Transform a -> m a
liftT (Transform (LHsDecl GhcPs) -> m (LHsDecl GhcPs))
-> Transform (LHsDecl GhcPs) -> m (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsDecl GhcPs -> [LHsDecl GhcPs] -> Transform (LHsDecl GhcPs)
forall (m :: * -> *).
Monad m =>
LHsDecl GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsDecl GhcPs)
replaceDeclsPatBindD LHsDecl GhcPs
pb [LHsDecl GhcPs]
ds'
       (LHsDecl GhcPs, Maybe t) -> m (LHsDecl GhcPs, Maybe t)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsDecl GhcPs
pb',Maybe t
r)
     else (LHsDecl GhcPs, Maybe t) -> m (LHsDecl GhcPs, Maybe t)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsDecl GhcPs
pb,Maybe t
forall a. Maybe a
Nothing)
modifyValD SrcSpan
p LHsDecl GhcPs
ast LMatch GhcPs (LHsExpr GhcPs)
-> [LHsDecl GhcPs] -> m ([LHsDecl GhcPs], Maybe t)
f = do
  (LHsDecl GhcPs
ast',Maybe t
r) <- StateT (Maybe t) m (LHsDecl GhcPs)
-> Maybe t -> m (LHsDecl GhcPs, Maybe t)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (GenericM (StateT (Maybe t) m)
-> LHsDecl GhcPs -> StateT (Maybe t) m (LHsDecl GhcPs)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
SYB.everywhereM ((LMatch GhcPs (LHsExpr GhcPs)
 -> StateT (Maybe t) m (LMatch GhcPs (LHsExpr GhcPs)))
-> a -> StateT (Maybe t) m a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
SYB.mkM LMatch GhcPs (LHsExpr GhcPs)
-> StateT (Maybe t) m (LMatch GhcPs (LHsExpr GhcPs))
doModLocal) LHsDecl GhcPs
ast) Maybe t
forall a. Maybe a
Nothing
  (LHsDecl GhcPs, Maybe t) -> m (LHsDecl GhcPs, Maybe t)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsDecl GhcPs
ast',Maybe t
r)
  where
    doModLocal :: Match -> StateT (Maybe t) m Match
    doModLocal :: LMatch GhcPs (LHsExpr GhcPs)
-> StateT (Maybe t) m (LMatch GhcPs (LHsExpr GhcPs))
doModLocal  (match :: LMatch GhcPs (LHsExpr GhcPs)
match@(GHC.L SrcSpan
ss Match GhcPs (LHsExpr GhcPs)
_) :: Match) = do
         let
         if SrcSpan
ss SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
p
           then do
             [LHsDecl GhcPs]
ds <- m [LHsDecl GhcPs] -> StateT (Maybe t) m [LHsDecl GhcPs]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [LHsDecl GhcPs] -> StateT (Maybe t) m [LHsDecl GhcPs])
-> m [LHsDecl GhcPs] -> StateT (Maybe t) m [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ TransformT Identity [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
forall (m :: * -> *) a. HasTransform m => Transform a -> m a
liftT (TransformT Identity [LHsDecl GhcPs] -> m [LHsDecl GhcPs])
-> TransformT Identity [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ LMatch GhcPs (LHsExpr GhcPs) -> TransformT Identity [LHsDecl GhcPs]
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> TransformT m [LHsDecl GhcPs]
hsDecls LMatch GhcPs (LHsExpr GhcPs)
match
             ([LHsDecl GhcPs]
ds',Maybe t
r) <- m ([LHsDecl GhcPs], Maybe t)
-> StateT (Maybe t) m ([LHsDecl GhcPs], Maybe t)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ([LHsDecl GhcPs], Maybe t)
 -> StateT (Maybe t) m ([LHsDecl GhcPs], Maybe t))
-> m ([LHsDecl GhcPs], Maybe t)
-> StateT (Maybe t) m ([LHsDecl GhcPs], Maybe t)
forall a b. (a -> b) -> a -> b
$ LMatch GhcPs (LHsExpr GhcPs)
-> [LHsDecl GhcPs] -> m ([LHsDecl GhcPs], Maybe t)
f LMatch GhcPs (LHsExpr GhcPs)
match [LHsDecl GhcPs]
ds
             Maybe t -> StateT (Maybe t) m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Maybe t
r
             LMatch GhcPs (LHsExpr GhcPs)
match' <- m (LMatch GhcPs (LHsExpr GhcPs))
-> StateT (Maybe t) m (LMatch GhcPs (LHsExpr GhcPs))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (LMatch GhcPs (LHsExpr GhcPs))
 -> StateT (Maybe t) m (LMatch GhcPs (LHsExpr GhcPs)))
-> m (LMatch GhcPs (LHsExpr GhcPs))
-> StateT (Maybe t) m (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Transform (LMatch GhcPs (LHsExpr GhcPs))
-> m (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. HasTransform m => Transform a -> m a
liftT (Transform (LMatch GhcPs (LHsExpr GhcPs))
 -> m (LMatch GhcPs (LHsExpr GhcPs)))
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
-> m (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LMatch GhcPs (LHsExpr GhcPs)
-> [LHsDecl GhcPs] -> Transform (LMatch GhcPs (LHsExpr GhcPs))
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> [LHsDecl GhcPs] -> TransformT m t
replaceDecls LMatch GhcPs (LHsExpr GhcPs)
match [LHsDecl GhcPs]
ds'
             LMatch GhcPs (LHsExpr GhcPs)
-> StateT (Maybe t) m (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return LMatch GhcPs (LHsExpr GhcPs)
match'
           else LMatch GhcPs (LHsExpr GhcPs)
-> StateT (Maybe t) m (LMatch GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return LMatch GhcPs (LHsExpr GhcPs)
match

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

-- |Used to integrate a @Transform@ into other Monad stacks
class (Monad m) => (HasTransform m) where
  liftT :: Transform a -> m a

instance Monad m => HasTransform (TransformT m) where
  liftT :: Transform a -> TransformT m a
liftT = (forall x. Identity x -> m x) -> Transform a -> TransformT m a
forall (m :: * -> *) (n :: * -> *) a.
(forall x. m x -> n x) -> TransformT m a -> TransformT n a
hoistTransform (x -> m x
forall (m :: * -> *) a. Monad m => a -> m a
return (x -> m x) -> (Identity x -> x) -> Identity x -> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity x -> x
forall a. Identity a -> a
runIdentity)

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

-- | Apply a transformation to the decls contained in @t@
modifyDeclsT :: (HasDecls t,HasTransform m)
             => ([GHC.LHsDecl GhcPs] -> m [GHC.LHsDecl GhcPs])
             -> t -> m t
modifyDeclsT :: ([LHsDecl GhcPs] -> m [LHsDecl GhcPs]) -> t -> m t
modifyDeclsT [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
action t
t = do
  [LHsDecl GhcPs]
decls <- TransformT Identity [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
forall (m :: * -> *) a. HasTransform m => Transform a -> m a
liftT (TransformT Identity [LHsDecl GhcPs] -> m [LHsDecl GhcPs])
-> TransformT Identity [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ t -> TransformT Identity [LHsDecl GhcPs]
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> TransformT m [LHsDecl GhcPs]
hsDecls t
t
  [LHsDecl GhcPs]
decls' <- [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
action [LHsDecl GhcPs]
decls
  Transform t -> m t
forall (m :: * -> *) a. HasTransform m => Transform a -> m a
liftT (Transform t -> m t) -> Transform t -> m t
forall a b. (a -> b) -> a -> b
$ t -> [LHsDecl GhcPs] -> Transform t
forall t (m :: * -> *).
(HasDecls t, Monad m) =>
t -> [LHsDecl GhcPs] -> TransformT m t
replaceDecls t
t [LHsDecl GhcPs]
decls'

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

matchApiAnn :: GHC.AnnKeywordId -> (KeywordId,DeltaPos) -> Bool
matchApiAnn :: AnnKeywordId -> (KeywordId, DeltaPos) -> Bool
matchApiAnn AnnKeywordId
mkw (KeywordId
kw,DeltaPos
_)
  = case KeywordId
kw of
     (G AnnKeywordId
akw) -> AnnKeywordId
mkw AnnKeywordId -> AnnKeywordId -> Bool
forall a. Eq a => a -> a -> Bool
== AnnKeywordId
akw
     KeywordId
_       -> Bool
False


-- We comments extracted from annPriorComments or annFollowingComments, which
-- need to move to just before the item identified by the predicate, if it
-- fires, else at the end of the annotations.
insertCommentBefore :: (Monad m) => AnnKey -> [(Comment, DeltaPos)]
                    -> ((KeywordId, DeltaPos) -> Bool) -> TransformT m ()
insertCommentBefore :: AnnKey
-> [(Comment, DeltaPos)]
-> ((KeywordId, DeltaPos) -> Bool)
-> TransformT m ()
insertCommentBefore AnnKey
key [(Comment, DeltaPos)]
toMove (KeywordId, DeltaPos) -> Bool
p = do
  let
    doInsert :: Anns -> Anns
doInsert Anns
ans =
      case AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
key Anns
ans of
        Maybe Annotation
Nothing -> String -> Anns
forall a. HasCallStack => String -> a
error (String -> Anns) -> String -> Anns
forall a b. (a -> b) -> a -> b
$ String
"insertCommentBefore:no AnnKey for:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnnKey -> String
forall a. Outputable a => a -> String
showGhc AnnKey
key
        Just Annotation
ann -> AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
key Annotation
ann' Anns
ans
          where
            ([(KeywordId, DeltaPos)]
before,[(KeywordId, DeltaPos)]
after) = ((KeywordId, DeltaPos) -> Bool)
-> [(KeywordId, DeltaPos)]
-> ([(KeywordId, DeltaPos)], [(KeywordId, DeltaPos)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (KeywordId, DeltaPos) -> Bool
p (Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
ann)
            ann' :: Annotation
ann' = Annotation
ann { annsDP :: [(KeywordId, DeltaPos)]
annsDP = [(KeywordId, DeltaPos)]
before [(KeywordId, DeltaPos)]
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ (((Comment, DeltaPos) -> (KeywordId, DeltaPos))
-> [(Comment, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a b. (a -> b) -> [a] -> [b]
map (Comment, DeltaPos) -> (KeywordId, DeltaPos)
comment2dp [(Comment, DeltaPos)]
toMove) [(KeywordId, DeltaPos)]
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ [(KeywordId, DeltaPos)]
after}

  (Anns -> Anns) -> TransformT m ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT Anns -> Anns
doInsert