{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}

-- |  This module converts 'GHC.ApiAnns' into 'Anns' by traversing a
-- structure created by the "Annotate" module.
--
-- == Structure of an Annotation
--
-- As a rule of thumb, every located element in the GHC AST will have
-- a corresponding entry in 'Anns'. An 'Annotation' contains 6 fields which
-- can be modifed to change how the AST is printed.
--
-- == Layout Calculation
--
-- In order to properly place syntax nodes and comments properly after
-- refactoring them (in such a way that the indentation level changes), their
-- position (encoded in the 'addEntryDelta' field) is not expressed as absolute
-- but relative to their context. As further motivation, consider the simple
-- let-into-where-block refactoring, from:
--
-- @
-- foo = do
--   let bar = do
--         x
--         -- comment
--         y
--   bar
-- @
--
-- to
--
-- @
-- foo = do
--   bar
--  where
--   bar = do
--     x
--     -- comment
--     y
-- @
--
-- Notice how the column of @x@, @y@ and the comment change due to this
-- refactoring but certain relative positions (e.g. the comment starting at the
-- same column as @x@) remain unchanged.
--
-- Now, what does "context" mean exactly? Here we reference the
-- "indentation level" as used in the haskell report (see chapter 2.7:
-- <https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-210002.7>):
-- 'addEntryDelta' is mostly relative to the current (inner-most) indentation
-- level. But in order to get better results, for the purpose of defining
-- relative positions a the offside-rule is modified slightly: Normally it
-- fires (only) at the first elements after where/let/do/of, introducing a new
-- indentation level. In addition, the rule here fires also at the "@let@"
-- keyword (when it is part of a "@let-in@" construct) and at the "@if@" keyword.
--
-- The effect of this additional applications of the offside-rule is that any
-- elements (more or less directly) following the "@let@" ("@if@"")
-- keyword have a position relative to the "@let@" ("@if@")
-- keyword position, even when the regular offside-rule does apply not yet/not
-- anymore. This affects two concrete things: Comments directly following
-- "@let@"/"@if@", and the respective follow-up keywords: "@in@" or
-- "@then@"/"@else@".
--
-- Due to this additional indentation level, it is possible to observe/obtain
-- negative delta-positions; consider:
--
-- @
-- foo = let x = 1
--   in x
-- @
--
-- Here, the @in@ keyword has an 'annEntryDelta' of @DP (1, -4)@ as it appears
-- one line below the previous elements and 4 columns /left/ relative to the
-- start of the @let@ keyword.
--
-- In general, the element that defines such an indentation level (i.e. the
-- first element after a where/let/do/of) will have an 'annEntryDelta' relative
-- to the previous inner-most indentation level; in other words: a new
-- indentation level becomes relevant only after the construct introducing the
-- element received its 'annEntryDelta' position. (Otherwise these elements
-- always would have a zero horizontal position - relative to itself.)
--
-- (This affects comments, too: A comment preceding the first element of a
-- layout block will have a position relative to the outer block, not of the
-- newly introduced layout block.)
--
-- For example, in the following expression the statement corresponding to
-- @baz@ will be given a 'annEntryDelta' of @DP (1, 2)@ as it appears
-- 1 line and 2 columns after the @do@ keyword. On the other hand, @bar@
-- will be given a 'annEntryDelta' of @DP (1,0)@ as it appears 1 line
-- further than @baz@ but in the same column as the start of the layout
-- block.
--
-- @
-- foo = do
--   baz
--   bar
-- @
--
-- A useful way to think of these rules is that the 'DeltaPos' is relative
-- to the further left an expression could have been placed. In the
-- previous example, we could have placed @baz@ anywhere on the line as its
-- position determines where the other statements must be. @bar@ could have
-- not been placed any further left without resulting in a syntax error
-- which is why the relative column is 0.
--
-- === annTrueEntryDelta
-- A very useful function is 'annTrueEntryDelta' which calculates the
-- offset from the last syntactic element (ignoring comments). This is
-- different to 'annEntryDelta' which does not ignore comments.
--
--
--
module Language.Haskell.GHC.ExactPrint.Delta
  ( relativiseApiAnns
  , relativiseApiAnnsWithComments
  , relativiseApiAnnsWithOptions

  -- * Configuration
  , DeltaOptions(drRigidity)
  , deltaOptions
  , normalLayout
  ) where

-- import Control.Exception
import Control.Monad.RWS
import Control.Monad.Trans.Free

import Data.Data (Data)
import Data.List (sort, nub, partition, sortBy, sortOn)

import Data.Ord

import Language.Haskell.GHC.ExactPrint.Utils
#if __GLASGOW_HASKELL__ <= 710
import Language.Haskell.GHC.ExactPrint.Lookup
#endif
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Annotate

import qualified GHC

import qualified Data.Map as Map
import qualified Data.Set as Set

-- import Debug.Trace

{-# ANN module "HLint: ignore Eta reduce" #-}
{-# ANN module "HLint: ignore Redundant do" #-}
{-# ANN module "HLint: ignore Reduce duplication" #-}

-- ---------------------------------------------------------------------
-- | Transform concrete annotations into relative annotations which are
-- more useful when transforming an AST.
#if __GLASGOW_HASKELL__ > 806
relativiseApiAnns :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)
                  => ast
#else
relativiseApiAnns :: Annotate ast
                  => GHC.Located ast
#endif
                  -> GHC.ApiAnns
                  -> Anns
relativiseApiAnns :: ast -> ApiAnns -> Anns
relativiseApiAnns = [Comment] -> ast -> ApiAnns -> Anns
forall ast.
(Data (SrcSpanLess ast), Annotate ast, HasSrcSpan ast) =>
[Comment] -> ast -> ApiAnns -> Anns
relativiseApiAnnsWithComments []

-- | Exactly the same as 'relativiseApiAnns' but with the possibilty to
-- inject comments. This is typically used if the source has been preprocessed
-- by e.g. CPP, and the parts stripped out of the original source are re-added
-- as comments so they are not lost for round tripping.
relativiseApiAnnsWithComments ::
#if __GLASGOW_HASKELL__ > 806
                     (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)
                  => [Comment]
                  -> ast
#else
                     Annotate ast
                  => [Comment]
                  -> GHC.Located ast
#endif
                  -> GHC.ApiAnns
                  -> Anns
relativiseApiAnnsWithComments :: [Comment] -> ast -> ApiAnns -> Anns
relativiseApiAnnsWithComments =
    DeltaOptions -> [Comment] -> ast -> ApiAnns -> Anns
forall ast.
(Data (SrcSpanLess ast), Annotate ast, HasSrcSpan ast) =>
DeltaOptions -> [Comment] -> ast -> ApiAnns -> Anns
relativiseApiAnnsWithOptions DeltaOptions
normalLayout

relativiseApiAnnsWithOptions ::
#if __GLASGOW_HASKELL__ > 806
                     (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast)
                  => DeltaOptions
                  -> [Comment]
                  -> ast
#else
                     Annotate ast
                  => DeltaOptions
                  -> [Comment]
                  -> GHC.Located ast
#endif
                  -> GHC.ApiAnns
                  -> Anns
relativiseApiAnnsWithOptions :: DeltaOptions -> [Comment] -> ast -> ApiAnns -> Anns
relativiseApiAnnsWithOptions DeltaOptions
opts [Comment]
cs ast
modu ApiAnns
ghcAnns
   = DeltaOptions -> [Comment] -> Annotated () -> ApiAnns -> Pos -> Anns
runDeltaWithComments
      DeltaOptions
opts [Comment]
cs (ast -> Annotated ()
forall ast.
(Annotate ast, Data (SrcSpanLess ast), HasSrcSpan ast) =>
ast -> Annotated ()
annotate ast
modu) ApiAnns
ghcAnns
      (SrcSpan -> Pos
ss2pos (SrcSpan -> Pos) -> SrcSpan -> Pos
forall a b. (a -> b) -> a -> b
$ ast -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc ast
modu)

-- ---------------------------------------------------------------------
--
-- | Type used in the Delta Monad.
type Delta a = RWS DeltaOptions DeltaWriter DeltaState a

runDeltaWithComments :: DeltaOptions -> [Comment] -> Annotated () -> GHC.ApiAnns -> Pos -> Anns
runDeltaWithComments :: DeltaOptions -> [Comment] -> Annotated () -> ApiAnns -> Pos -> Anns
runDeltaWithComments DeltaOptions
opts [Comment]
cs Annotated ()
action ApiAnns
ga Pos
priorEnd =
  DeltaWriter -> Anns
mkAnns (DeltaWriter -> Anns)
-> (Annotated () -> DeltaWriter) -> Annotated () -> Anns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeltaState, DeltaWriter) -> DeltaWriter
forall a b. (a, b) -> b
snd
  ((DeltaState, DeltaWriter) -> DeltaWriter)
-> (Annotated () -> (DeltaState, DeltaWriter))
-> Annotated ()
-> DeltaWriter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\RWS DeltaOptions DeltaWriter DeltaState ()
next -> RWS DeltaOptions DeltaWriter DeltaState ()
-> DeltaOptions -> DeltaState -> (DeltaState, DeltaWriter)
forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS RWS DeltaOptions DeltaWriter DeltaState ()
next DeltaOptions
opts ([Comment] -> Pos -> ApiAnns -> DeltaState
defaultDeltaState [Comment]
cs Pos
priorEnd ApiAnns
ga))
  (RWS DeltaOptions DeltaWriter DeltaState ()
 -> (DeltaState, DeltaWriter))
-> (Annotated () -> RWS DeltaOptions DeltaWriter DeltaState ())
-> Annotated ()
-> (DeltaState, DeltaWriter)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotated () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall a. Annotated a -> Delta a
deltaInterpret (Annotated () -> Anns) -> Annotated () -> Anns
forall a b. (a -> b) -> a -> b
$ Annotated ()
action
  where
    mkAnns :: DeltaWriter -> Anns
    mkAnns :: DeltaWriter -> Anns
mkAnns = Endo Anns -> Anns
forall a. Monoid a => Endo a -> a
f (Endo Anns -> Anns)
-> (DeltaWriter -> Endo Anns) -> DeltaWriter -> Anns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeltaWriter -> Endo Anns
dwAnns
    f :: Monoid a => Endo a -> a
    f :: Endo a -> a
f = ((a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
forall a. Monoid a => a
mempty) ((a -> a) -> a) -> (Endo a -> a -> a) -> Endo a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endo a -> a -> a
forall a. Endo a -> a -> a
appEndo

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

-- TODO: rename this, it is the R part of the RWS
data DeltaOptions = DeltaOptions
       {
         -- | Current `SrcSpan, part of current AnnKey`
         DeltaOptions -> SrcSpan
curSrcSpan :: !GHC.SrcSpan

         -- | Constuctor of current AST element, part of current AnnKey
       , DeltaOptions -> AnnConName
annConName :: !AnnConName

        -- | Whether to use rigid or normal layout rules
       , DeltaOptions -> Rigidity
drRigidity :: !Rigidity

       -- | Current higher level context. e.g. whether a Match is part of a
       -- LambdaExpr or a FunBind
       , DeltaOptions -> AstContextSet
drContext :: !AstContextSet
       }

data DeltaWriter = DeltaWriter
       { -- | Final list of annotations, and sort keys
         DeltaWriter -> Endo Anns
dwAnns :: Endo (Map.Map AnnKey Annotation)

         -- | Used locally to pass Keywords, delta pairs relevant to a specific
         -- subtree to the parent.
       , DeltaWriter -> [(KeywordId, DeltaPos)]
annKds         :: ![(KeywordId, DeltaPos)]
       , DeltaWriter -> Maybe [SrcSpan]
sortKeys       :: !(Maybe [GHC.SrcSpan])
       , DeltaWriter -> First AnnKey
dwCapturedSpan :: !(First AnnKey)
       }

data DeltaState = DeltaState
       { -- | Position reached when processing the last element
         DeltaState -> Pos
priorEndPosition    :: !Pos

         -- | Ordered list of comments still to be allocated
       , DeltaState -> [Comment]
apComments :: ![Comment]

         -- | The original GHC Delta Annotations
       , DeltaState -> ApiAnns
apAnns :: !GHC.ApiAnns

       , DeltaState -> Bool
apMarkLayout :: Bool
       , DeltaState -> LayoutStartCol
apLayoutStart :: LayoutStartCol

       }

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

deltaOptions :: Rigidity -> DeltaOptions
deltaOptions :: Rigidity -> DeltaOptions
deltaOptions Rigidity
ridigity =
  DeltaOptions :: SrcSpan -> AnnConName -> Rigidity -> AstContextSet -> DeltaOptions
DeltaOptions
    { curSrcSpan :: SrcSpan
curSrcSpan = SrcSpan
GHC.noSrcSpan
    , annConName :: AnnConName
annConName = () -> AnnConName
forall a. Data a => a -> AnnConName
annGetConstr ()
    , drRigidity :: Rigidity
drRigidity = Rigidity
ridigity
    , drContext :: AstContextSet
drContext  = AstContextSet
defaultACS
    }

normalLayout :: DeltaOptions
normalLayout :: DeltaOptions
normalLayout = Rigidity -> DeltaOptions
deltaOptions Rigidity
NormalLayout

defaultDeltaState :: [Comment] -> Pos -> GHC.ApiAnns -> DeltaState
defaultDeltaState :: [Comment] -> Pos -> ApiAnns -> DeltaState
defaultDeltaState [Comment]
injectedComments Pos
priorEnd ApiAnns
ga =
    DeltaState :: Pos -> [Comment] -> ApiAnns -> Bool -> LayoutStartCol -> DeltaState
DeltaState
      { priorEndPosition :: Pos
priorEndPosition    = Pos
priorEnd
      , apComments :: [Comment]
apComments = [Comment]
cs [Comment] -> [Comment] -> [Comment]
forall a. [a] -> [a] -> [a]
++ [Comment]
injectedComments
      , apAnns :: ApiAnns
apAnns     = ApiAnns
ga
      , apLayoutStart :: LayoutStartCol
apLayoutStart = LayoutStartCol
1
      , apMarkLayout :: Bool
apMarkLayout = Bool
False
      }
  where
    cs :: [Comment]
    cs :: [Comment]
cs = ApiAnns -> [Comment]
extractComments ApiAnns
ga


-- Writer helpers

tellFinalAnn :: (AnnKey, Annotation) -> Delta ()
tellFinalAnn :: (AnnKey, Annotation) -> RWS DeltaOptions DeltaWriter DeltaState ()
tellFinalAnn (AnnKey
k, Annotation
v) =
  -- tell (mempty { dwAnns = Endo (Map.insertWith (<>) k v) })
  DeltaWriter -> RWS DeltaOptions DeltaWriter DeltaState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (DeltaWriter
forall a. Monoid a => a
mempty { dwAnns :: Endo Anns
dwAnns = (Anns -> Anns) -> Endo Anns
forall a. (a -> a) -> Endo a
Endo (AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
k Annotation
v) })

tellSortKey :: [GHC.SrcSpan] -> Delta ()
tellSortKey :: [SrcSpan] -> RWS DeltaOptions DeltaWriter DeltaState ()
tellSortKey [SrcSpan]
xs = DeltaWriter -> RWS DeltaOptions DeltaWriter DeltaState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (DeltaWriter
forall a. Monoid a => a
mempty { sortKeys :: Maybe [SrcSpan]
sortKeys = [SrcSpan] -> Maybe [SrcSpan]
forall a. a -> Maybe a
Just [SrcSpan]
xs } )

tellCapturedSpan :: AnnKey -> Delta ()
tellCapturedSpan :: AnnKey -> RWS DeltaOptions DeltaWriter DeltaState ()
tellCapturedSpan AnnKey
key = DeltaWriter -> RWS DeltaOptions DeltaWriter DeltaState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ( DeltaWriter
forall a. Monoid a => a
mempty { dwCapturedSpan :: First AnnKey
dwCapturedSpan = Maybe AnnKey -> First AnnKey
forall a. Maybe a -> First a
First (Maybe AnnKey -> First AnnKey) -> Maybe AnnKey -> First AnnKey
forall a b. (a -> b) -> a -> b
$ AnnKey -> Maybe AnnKey
forall a. a -> Maybe a
Just AnnKey
key })

tellKd :: (KeywordId, DeltaPos) -> Delta ()
tellKd :: (KeywordId, DeltaPos) -> RWS DeltaOptions DeltaWriter DeltaState ()
tellKd (KeywordId, DeltaPos)
kd = DeltaWriter -> RWS DeltaOptions DeltaWriter DeltaState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (DeltaWriter
forall a. Monoid a => a
mempty { annKds :: [(KeywordId, DeltaPos)]
annKds = [(KeywordId, DeltaPos)
kd] })

#if __GLASGOW_HASKELL__ >= 804
instance Semigroup DeltaWriter where
  <> :: DeltaWriter -> DeltaWriter -> DeltaWriter
(<>) = DeltaWriter -> DeltaWriter -> DeltaWriter
forall a. Monoid a => a -> a -> a
mappend
#endif

instance Monoid DeltaWriter where
  mempty :: DeltaWriter
mempty = Endo Anns
-> [(KeywordId, DeltaPos)]
-> Maybe [SrcSpan]
-> First AnnKey
-> DeltaWriter
DeltaWriter Endo Anns
forall a. Monoid a => a
mempty [(KeywordId, DeltaPos)]
forall a. Monoid a => a
mempty Maybe [SrcSpan]
forall a. Monoid a => a
mempty First AnnKey
forall a. Monoid a => a
mempty
  (DeltaWriter Endo Anns
a [(KeywordId, DeltaPos)]
b Maybe [SrcSpan]
e First AnnKey
g) mappend :: DeltaWriter -> DeltaWriter -> DeltaWriter
`mappend` (DeltaWriter Endo Anns
c [(KeywordId, DeltaPos)]
d Maybe [SrcSpan]
f First AnnKey
h)
    = Endo Anns
-> [(KeywordId, DeltaPos)]
-> Maybe [SrcSpan]
-> First AnnKey
-> DeltaWriter
DeltaWriter (Endo Anns
a Endo Anns -> Endo Anns -> Endo Anns
forall a. Semigroup a => a -> a -> a
<> Endo Anns
c) ([(KeywordId, DeltaPos)]
b [(KeywordId, DeltaPos)]
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. Semigroup a => a -> a -> a
<> [(KeywordId, DeltaPos)]
d) (Maybe [SrcSpan]
e Maybe [SrcSpan] -> Maybe [SrcSpan] -> Maybe [SrcSpan]
forall a. Semigroup a => a -> a -> a
<> Maybe [SrcSpan]
f) (First AnnKey
g First AnnKey -> First AnnKey -> First AnnKey
forall a. Semigroup a => a -> a -> a
<> First AnnKey
h)

-----------------------------------
-- Free Monad Interpretation code

deltaInterpret :: Annotated a -> Delta a
deltaInterpret :: Annotated a -> Delta a
deltaInterpret = (AnnotationF (Delta a) -> Delta a) -> Annotated a -> Delta a
forall (f :: * -> *) (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Functor f, Monad m, MonadTrans t, Monad (t m)) =>
(f (t m a) -> t m a) -> FreeT f m a -> t m a
iterTM AnnotationF (Delta a) -> Delta a
forall a. AnnotationF (Delta a) -> Delta a
go
  where
    go :: AnnotationF (Delta a) -> Delta a
    go :: AnnotationF (Delta a) -> Delta a
go (MarkEOF Delta a
next)                   = RWS DeltaOptions DeltaWriter DeltaState ()
addEofAnnotation RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (MarkPrim AnnKeywordId
kwid Maybe String
_ Delta a
next)           = AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotation AnnKeywordId
kwid RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (MarkPPOptional AnnKeywordId
kwid Maybe String
_ Delta a
next)     = AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotation AnnKeywordId
kwid RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
#if __GLASGOW_HASKELL__ >= 800
    go (MarkInstead AnnKeywordId
akwid KeywordId
kwid Delta a
next)    = AnnKeywordId
-> KeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotationInstead AnnKeywordId
akwid KeywordId
kwid RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
#endif
    go (MarkOutside AnnKeywordId
akwid KeywordId
kwid Delta a
next)    = AnnKeywordId
-> KeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotationsOutside AnnKeywordId
akwid KeywordId
kwid RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (MarkInside AnnKeywordId
akwid Delta a
next)          = AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotationsInside AnnKeywordId
akwid RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (MarkMany AnnKeywordId
akwid Delta a
next)            = AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotations AnnKeywordId
akwid RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (MarkManyOptional AnnKeywordId
akwid Delta a
next)    = AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotations AnnKeywordId
akwid RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (MarkOffsetPrim AnnKeywordId
akwid Int
n Maybe String
_ Delta a
next)  = AnnKeywordId -> Int -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotationLs AnnKeywordId
akwid Int
n RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (MarkOffsetPrimOptional AnnKeywordId
akwid Int
n Maybe String
_ Delta a
next) = AnnKeywordId -> Int -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotationLs AnnKeywordId
akwid Int
n RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (WithAST a
lss Annotated b
prog Delta a
next)          = a -> Delta b -> Delta b
forall a b.
(Data a, Data (SrcSpanLess a), HasSrcSpan a) =>
a -> Delta b -> Delta b
withAST a
lss (Annotated b -> Delta b
forall a. Annotated a -> Delta a
deltaInterpret Annotated b
prog) Delta b -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (CountAnns AnnKeywordId
kwid Int -> Delta a
next)            = AnnKeywordId -> Delta Int
countAnnsDelta AnnKeywordId
kwid Delta Int -> (Int -> Delta a) -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Delta a
next
    go (SetLayoutFlag Rigidity
r Annotated ()
action Delta a
next)    = do
      Rigidity
rigidity <- (DeltaOptions -> Rigidity)
-> RWST DeltaOptions DeltaWriter DeltaState Identity Rigidity
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DeltaOptions -> Rigidity
drRigidity
      (if Rigidity
r Rigidity -> Rigidity -> Bool
forall a. Ord a => a -> a -> Bool
<= Rigidity
rigidity then RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
setLayoutFlag else RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall a. a -> a
id) (Annotated () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall a. Annotated a -> Delta a
deltaInterpret Annotated ()
action)
      Delta a
next
    go (MarkAnnBeforeAnn AnnKeywordId
ann1 AnnKeywordId
ann2 Delta a
next) = AnnKeywordId
-> AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
deltaMarkAnnBeforeAnn AnnKeywordId
ann1 AnnKeywordId
ann2 RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (MarkExternal SrcSpan
ss AnnKeywordId
akwid String
_ Delta a
next)    = SrcSpan
-> AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotationExt SrcSpan
ss AnnKeywordId
akwid RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (StoreOriginalSrcSpan SrcSpan
_ AnnKey
key AnnKey -> Delta a
next) = AnnKey -> Delta AnnKey
storeOriginalSrcSpanDelta AnnKey
key Delta AnnKey -> (AnnKey -> Delta a) -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AnnKey -> Delta a
next
    go (GetSrcSpanForKw SrcSpan
ss AnnKeywordId
kw SrcSpan -> Delta a
next)      = SrcSpan -> AnnKeywordId -> Delta SrcSpan
getSrcSpanForKw SrcSpan
ss AnnKeywordId
kw Delta SrcSpan -> (SrcSpan -> Delta a) -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SrcSpan -> Delta a
next
#if __GLASGOW_HASKELL__ <= 710
    go (StoreString s ss next)           = storeString s ss >> next
#endif
    go (AnnotationsToComments     [AnnKeywordId]
kws Delta a
next) = [AnnKeywordId] -> RWS DeltaOptions DeltaWriter DeltaState ()
annotationsToCommentsDelta [AnnKeywordId]
kws RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
#if __GLASGOW_HASKELL__ <= 710
    go (AnnotationsToCommentsBF _ kws next) = annotationsToCommentsDelta kws >> next
    go (FinalizeBF _ next)                  = next
#endif
    go (WithSortKey             [(SrcSpan, Annotated ())]
kws Delta a
next) = [(SrcSpan, Annotated ())]
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall b.
[(SrcSpan, Annotated b)]
-> RWS DeltaOptions DeltaWriter DeltaState ()
withSortKey [(SrcSpan, Annotated ())]
kws RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (WithSortKeyContexts ListContexts
ctx [(SrcSpan, Annotated ())]
kws Delta a
next) = ListContexts
-> [(SrcSpan, Annotated ())]
-> RWS DeltaOptions DeltaWriter DeltaState ()
withSortKeyContexts ListContexts
ctx [(SrcSpan, Annotated ())]
kws RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next

    go (SetContextLevel Set AstContext
ctxt Int
lvl Annotated ()
action Delta a
next) = Set AstContext
-> Int
-> RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
setContextDelta Set AstContext
ctxt Int
lvl (Annotated () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall a. Annotated a -> Delta a
deltaInterpret Annotated ()
action) RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (UnsetContext   AstContext
_ctxt Annotated ()
action Delta a
next) = Annotated () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall a. Annotated a -> Delta a
deltaInterpret Annotated ()
action RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (IfInContext    Set AstContext
ctxt Annotated ()
ifAction Annotated ()
elseAction Delta a
next) = Set AstContext
-> Annotated ()
-> Annotated ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
ifInContextDelta Set AstContext
ctxt Annotated ()
ifAction Annotated ()
elseAction RWS DeltaOptions DeltaWriter DeltaState () -> Delta a -> Delta a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delta a
next
    go (TellContext Set AstContext
_ Delta a
next)                  = Delta a
next

withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Delta ()
withSortKey :: [(SrcSpan, Annotated b)]
-> RWS DeltaOptions DeltaWriter DeltaState ()
withSortKey [(SrcSpan, Annotated b)]
kws =
  let order :: [(SrcSpan, Annotated b)]
order = ((SrcSpan, Annotated b) -> (SrcSpan, Annotated b) -> Ordering)
-> [(SrcSpan, Annotated b)] -> [(SrcSpan, Annotated b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((SrcSpan, Annotated b) -> SrcSpan)
-> (SrcSpan, Annotated b) -> (SrcSpan, Annotated b) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (SrcSpan, Annotated b) -> SrcSpan
forall a b. (a, b) -> a
fst) [(SrcSpan, Annotated b)]
kws
  in do
    [SrcSpan] -> RWS DeltaOptions DeltaWriter DeltaState ()
tellSortKey (((SrcSpan, Annotated b) -> SrcSpan)
-> [(SrcSpan, Annotated b)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan, Annotated b) -> SrcSpan
forall a b. (a, b) -> a
fst [(SrcSpan, Annotated b)]
order)
    ((SrcSpan, Annotated b)
 -> RWST DeltaOptions DeltaWriter DeltaState Identity b)
-> [(SrcSpan, Annotated b)]
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Annotated b -> RWST DeltaOptions DeltaWriter DeltaState Identity b
forall a. Annotated a -> Delta a
deltaInterpret (Annotated b
 -> RWST DeltaOptions DeltaWriter DeltaState Identity b)
-> ((SrcSpan, Annotated b) -> Annotated b)
-> (SrcSpan, Annotated b)
-> RWST DeltaOptions DeltaWriter DeltaState Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcSpan, Annotated b) -> Annotated b
forall a b. (a, b) -> b
snd) [(SrcSpan, Annotated b)]
order


withSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Delta ()
withSortKeyContexts :: ListContexts
-> [(SrcSpan, Annotated ())]
-> RWS DeltaOptions DeltaWriter DeltaState ()
withSortKeyContexts ListContexts
ctxts [(SrcSpan, Annotated ())]
kws = do
  [SrcSpan] -> RWS DeltaOptions DeltaWriter DeltaState ()
tellSortKey (((SrcSpan, Annotated ()) -> SrcSpan)
-> [(SrcSpan, Annotated ())] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan, Annotated ()) -> SrcSpan
forall a b. (a, b) -> a
fst [(SrcSpan, Annotated ())]
order)
  (Annotated () -> RWS DeltaOptions DeltaWriter DeltaState ())
-> ListContexts
-> [(SrcSpan, Annotated ())]
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall (m :: * -> *).
Monad m =>
(Annotated () -> m ())
-> ListContexts -> [(SrcSpan, Annotated ())] -> m ()
withSortKeyContextsHelper Annotated () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall a. Annotated a -> Delta a
deltaInterpret ListContexts
ctxts [(SrcSpan, Annotated ())]
order
  where
    order :: [(SrcSpan, Annotated ())]
order = ((SrcSpan, Annotated ()) -> (SrcSpan, Annotated ()) -> Ordering)
-> [(SrcSpan, Annotated ())] -> [(SrcSpan, Annotated ())]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((SrcSpan, Annotated ()) -> SrcSpan)
-> (SrcSpan, Annotated ()) -> (SrcSpan, Annotated ()) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (SrcSpan, Annotated ()) -> SrcSpan
forall a b. (a, b) -> a
fst) [(SrcSpan, Annotated ())]
kws


setLayoutFlag :: Delta () -> Delta ()
setLayoutFlag :: RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
setLayoutFlag RWS DeltaOptions DeltaWriter DeltaState ()
action = do
  LayoutStartCol
oldLay <- (DeltaState -> LayoutStartCol)
-> RWST DeltaOptions DeltaWriter DeltaState Identity LayoutStartCol
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DeltaState -> LayoutStartCol
apLayoutStart
  (DeltaState -> DeltaState)
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DeltaState
s -> DeltaState
s { apMarkLayout :: Bool
apMarkLayout = Bool
True } )
  let reset :: RWS DeltaOptions DeltaWriter DeltaState ()
reset = do
                (DeltaState -> DeltaState)
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DeltaState
s -> DeltaState
s { apMarkLayout :: Bool
apMarkLayout = Bool
False
                                , apLayoutStart :: LayoutStartCol
apLayoutStart = LayoutStartCol
oldLay })
  RWS DeltaOptions DeltaWriter DeltaState ()
action RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* RWS DeltaOptions DeltaWriter DeltaState ()
reset

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

setContextDelta :: Set.Set AstContext -> Int -> Delta () -> Delta ()
setContextDelta :: Set AstContext
-> Int
-> RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
setContextDelta Set AstContext
ctxt Int
lvl =
  (DeltaOptions -> DeltaOptions)
-> RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\DeltaOptions
s -> DeltaOptions
s { drContext :: AstContextSet
drContext = Set AstContext -> Int -> AstContextSet -> AstContextSet
forall a. Ord a => Set a -> Int -> ACS' a -> ACS' a
setAcsWithLevel Set AstContext
ctxt Int
lvl (DeltaOptions -> AstContextSet
drContext DeltaOptions
s) } )

ifInContextDelta :: Set.Set AstContext -> Annotated () -> Annotated () -> Delta ()
ifInContextDelta :: Set AstContext
-> Annotated ()
-> Annotated ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
ifInContextDelta Set AstContext
ctxt Annotated ()
ifAction Annotated ()
elseAction = do
  AstContextSet
cur <- (DeltaOptions -> AstContextSet)
-> RWST DeltaOptions DeltaWriter DeltaState Identity AstContextSet
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DeltaOptions -> AstContextSet
drContext
  let inContext :: Bool
inContext = Set AstContext -> AstContextSet -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs Set AstContext
ctxt AstContextSet
cur
  if Bool
inContext
    then Annotated () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall a. Annotated a -> Delta a
deltaInterpret Annotated ()
ifAction
    else Annotated () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall a. Annotated a -> Delta a
deltaInterpret Annotated ()
elseAction

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

storeOriginalSrcSpanDelta :: AnnKey -> Delta AnnKey
storeOriginalSrcSpanDelta :: AnnKey -> Delta AnnKey
storeOriginalSrcSpanDelta AnnKey
key = do
  AnnKey -> RWS DeltaOptions DeltaWriter DeltaState ()
tellCapturedSpan AnnKey
key
  AnnKey -> Delta AnnKey
forall (m :: * -> *) a. Monad m => a -> m a
return AnnKey
key

#if __GLASGOW_HASKELL__ <= 710
storeString :: String -> GHC.SrcSpan -> Delta ()
storeString s ss = addAnnotationWorker (AnnString s) ss
#endif

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

-- |In order to interleave annotations into the stream, we turn them into
-- comments.
annotationsToCommentsDelta :: [GHC.AnnKeywordId] -> Delta ()
annotationsToCommentsDelta :: [AnnKeywordId] -> RWS DeltaOptions DeltaWriter DeltaState ()
annotationsToCommentsDelta [AnnKeywordId]
kws = do
  SrcSpan
ss <- Delta SrcSpan
getSrcSpan
  [Comment]
cs <- (DeltaState -> [Comment])
-> RWST DeltaOptions DeltaWriter DeltaState Identity [Comment]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DeltaState -> [Comment]
apComments
  let
    doOne :: GHC.AnnKeywordId -> Delta [Comment]
    doOne :: AnnKeywordId
-> RWST DeltaOptions DeltaWriter DeltaState Identity [Comment]
doOne AnnKeywordId
kw = do
      ([SrcSpan]
spans,AnnKeywordId
_) <- SrcSpan -> AnnKeywordId -> Delta ([SrcSpan], AnnKeywordId)
getAndRemoveAnnotationDelta SrcSpan
ss AnnKeywordId
kw
      [Comment]
-> RWST DeltaOptions DeltaWriter DeltaState Identity [Comment]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Comment]
 -> RWST DeltaOptions DeltaWriter DeltaState Identity [Comment])
-> [Comment]
-> RWST DeltaOptions DeltaWriter DeltaState Identity [Comment]
forall a b. (a -> b) -> a -> b
$ (SrcSpan -> Comment) -> [SrcSpan] -> [Comment]
forall a b. (a -> b) -> [a] -> [b]
map (AnnKeywordId -> SrcSpan -> Comment
mkKWComment AnnKeywordId
kw) [SrcSpan]
spans
    -- TODO:AZ make sure these are sorted/merged properly when the invariant for
    -- allocateComments is re-established.
  [[Comment]]
newComments <- (AnnKeywordId
 -> RWST DeltaOptions DeltaWriter DeltaState Identity [Comment])
-> [AnnKeywordId]
-> RWST DeltaOptions DeltaWriter DeltaState Identity [[Comment]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AnnKeywordId
-> RWST DeltaOptions DeltaWriter DeltaState Identity [Comment]
doOne [AnnKeywordId]
kws
  [Comment] -> RWS DeltaOptions DeltaWriter DeltaState ()
putUnallocatedComments ([Comment]
cs [Comment] -> [Comment] -> [Comment]
forall a. [a] -> [a] -> [a]
++ [[Comment]] -> [Comment]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Comment]]
newComments)

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

-- | This function exists to overcome a shortcoming in the GHC AST for 7.10.1
getSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta GHC.SrcSpan
getSrcSpanForKw :: SrcSpan -> AnnKeywordId -> Delta SrcSpan
getSrcSpanForKw SrcSpan
_ AnnKeywordId
kw = do
    ApiAnns
ga <- (DeltaState -> ApiAnns)
-> RWST DeltaOptions DeltaWriter DeltaState Identity ApiAnns
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DeltaState -> ApiAnns
apAnns
    SrcSpan
ss <- Delta SrcSpan
getSrcSpan
    case ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan]
GHC.getAnnotation ApiAnns
ga SrcSpan
ss AnnKeywordId
kw of
      []     -> SrcSpan -> Delta SrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return SrcSpan
GHC.noSrcSpan
      (SrcSpan
sp:[SrcSpan]
_) -> SrcSpan -> Delta SrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return SrcSpan
sp

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

getSrcSpan :: Delta GHC.SrcSpan
getSrcSpan :: Delta SrcSpan
getSrcSpan = (DeltaOptions -> SrcSpan) -> Delta SrcSpan
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DeltaOptions -> SrcSpan
curSrcSpan

#if __GLASGOW_HASKELL__ > 806
withSrcSpanDelta :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b
withSrcSpanDelta :: a -> Delta b -> Delta b
withSrcSpanDelta (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
GHC.dL->GHC.L SrcSpan
l SrcSpanLess a
a) =
#else
withSrcSpanDelta :: Data a => GHC.Located a -> Delta b -> Delta b
withSrcSpanDelta (GHC.L l a) =
#endif
  (DeltaOptions -> DeltaOptions) -> Delta b -> Delta b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\DeltaOptions
s -> DeltaOptions
s { curSrcSpan :: SrcSpan
curSrcSpan = SrcSpan
l
                 , annConName :: AnnConName
annConName = SrcSpanLess a -> AnnConName
forall a. Data a => a -> AnnConName
annGetConstr SrcSpanLess a
a
                 , drContext :: AstContextSet
drContext = AstContextSet -> AstContextSet
forall a. ACS' a -> ACS' a
pushAcs (DeltaOptions -> AstContextSet
drContext DeltaOptions
s)
                    AstContextSet -> String -> AstContextSet
forall c. c -> String -> c
`debug` (String
"withSrcSpanDelta: (l,annConName,drContext)=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (SrcSpan, AnnConName, AstContextSet) -> String
forall a. Outputable a => a -> String
showGhc (SrcSpan
l,SrcSpanLess a -> AnnConName
forall a. Data a => a -> AnnConName
annGetConstr SrcSpanLess a
a, AstContextSet -> AstContextSet
forall a. ACS' a -> ACS' a
pushAcs (DeltaOptions -> AstContextSet
drContext DeltaOptions
s)))
                 })


getUnallocatedComments :: Delta [Comment]
getUnallocatedComments :: RWST DeltaOptions DeltaWriter DeltaState Identity [Comment]
getUnallocatedComments = (DeltaState -> [Comment])
-> RWST DeltaOptions DeltaWriter DeltaState Identity [Comment]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DeltaState -> [Comment]
apComments

putUnallocatedComments :: [Comment] -> Delta ()
putUnallocatedComments :: [Comment] -> RWS DeltaOptions DeltaWriter DeltaState ()
putUnallocatedComments [Comment]
cs = (DeltaState -> DeltaState)
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DeltaState
s -> DeltaState
s { apComments :: [Comment]
apComments = [Comment]
cs } )

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

adjustDeltaForOffsetM :: DeltaPos -> Delta DeltaPos
adjustDeltaForOffsetM :: DeltaPos -> Delta DeltaPos
adjustDeltaForOffsetM DeltaPos
dp = do
  LayoutStartCol
colOffset <- (DeltaState -> LayoutStartCol)
-> RWST DeltaOptions DeltaWriter DeltaState Identity LayoutStartCol
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DeltaState -> LayoutStartCol
apLayoutStart
  DeltaPos -> Delta DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (LayoutStartCol -> DeltaPos -> DeltaPos
adjustDeltaForOffset LayoutStartCol
colOffset DeltaPos
dp)

adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos
adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos
adjustDeltaForOffset LayoutStartCol
_colOffset              dp :: DeltaPos
dp@(DP (Int
0,Int
_)) = DeltaPos
dp -- same line
adjustDeltaForOffset (LayoutStartCol Int
colOffset) (DP (Int
l,Int
c)) = Pos -> DeltaPos
DP (Int
l,Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
colOffset)

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

getPriorEnd :: Delta Pos
getPriorEnd :: Delta Pos
getPriorEnd = (DeltaState -> Pos) -> Delta Pos
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DeltaState -> Pos
priorEndPosition

setPriorEnd :: Pos -> Delta ()
setPriorEnd :: Pos -> RWS DeltaOptions DeltaWriter DeltaState ()
setPriorEnd Pos
pe =
  (DeltaState -> DeltaState)
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DeltaState
s -> DeltaState
s { priorEndPosition :: Pos
priorEndPosition = Pos
pe })

setPriorEndAST :: GHC.SrcSpan -> Delta ()
setPriorEndAST :: SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
setPriorEndAST SrcSpan
pe = do
  Int -> RWS DeltaOptions DeltaWriter DeltaState ()
setLayoutStart (Pos -> Int
forall a b. (a, b) -> b
snd (SrcSpan -> Pos
ss2pos SrcSpan
pe))
  (DeltaState -> DeltaState)
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DeltaState
s -> DeltaState
s { priorEndPosition :: Pos
priorEndPosition    = SrcSpan -> Pos
ss2posEnd SrcSpan
pe } )

setLayoutStart :: Int -> Delta ()
setLayoutStart :: Int -> RWS DeltaOptions DeltaWriter DeltaState ()
setLayoutStart Int
p = do
  DeltaState{Bool
apMarkLayout :: Bool
apMarkLayout :: DeltaState -> Bool
apMarkLayout} <- RWST DeltaOptions DeltaWriter DeltaState Identity DeltaState
forall s (m :: * -> *). MonadState s m => m s
get
  Bool
-> RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
apMarkLayout (
                      (DeltaState -> DeltaState)
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DeltaState
s -> DeltaState
s { apMarkLayout :: Bool
apMarkLayout = Bool
False
                                     , apLayoutStart :: LayoutStartCol
apLayoutStart = Int -> LayoutStartCol
LayoutStartCol Int
p}))


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

peekAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan]
peekAnnotationDelta :: AnnKeywordId -> Delta [SrcSpan]
peekAnnotationDelta AnnKeywordId
an = do
    ApiAnns
ga <- (DeltaState -> ApiAnns)
-> RWST DeltaOptions DeltaWriter DeltaState Identity ApiAnns
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DeltaState -> ApiAnns
apAnns
    SrcSpan
ss <- Delta SrcSpan
getSrcSpan
#if __GLASGOW_HASKELL__ <= 710
    return $ GHC.getAnnotation ga ss an
#else
    let unicodeAnns :: [SrcSpan]
unicodeAnns = case AnnKeywordId -> [AnnKeywordId]
unicodeEquivalent AnnKeywordId
an of
          [] -> []
          [AnnKeywordId
kw] -> ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan]
GHC.getAnnotation ApiAnns
ga SrcSpan
ss AnnKeywordId
kw
          (AnnKeywordId
kw:[AnnKeywordId]
_) -> ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan]
GHC.getAnnotation ApiAnns
ga SrcSpan
ss AnnKeywordId
kw -- Keep exhaustiveness checker happy
    [SrcSpan] -> Delta [SrcSpan]
forall (m :: * -> *) a. Monad m => a -> m a
return ([SrcSpan] -> Delta [SrcSpan]) -> [SrcSpan] -> Delta [SrcSpan]
forall a b. (a -> b) -> a -> b
$ [SrcSpan]
unicodeAnns [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan]
GHC.getAnnotation ApiAnns
ga SrcSpan
ss AnnKeywordId
an
#endif

getAnnotationDelta :: GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)
getAnnotationDelta :: AnnKeywordId -> Delta ([SrcSpan], AnnKeywordId)
getAnnotationDelta AnnKeywordId
an = do
    SrcSpan
ss <- Delta SrcSpan
getSrcSpan
    SrcSpan -> AnnKeywordId -> Delta ([SrcSpan], AnnKeywordId)
getAndRemoveAnnotationDelta SrcSpan
ss AnnKeywordId
an

getAndRemoveAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)
getAndRemoveAnnotationDelta :: SrcSpan -> AnnKeywordId -> Delta ([SrcSpan], AnnKeywordId)
getAndRemoveAnnotationDelta SrcSpan
sp AnnKeywordId
an = do
    ApiAnns
ga <- (DeltaState -> ApiAnns)
-> RWST DeltaOptions DeltaWriter DeltaState Identity ApiAnns
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DeltaState -> ApiAnns
apAnns
#if __GLASGOW_HASKELL__ <= 710
    let (r,ga') = GHC.getAndRemoveAnnotation ga sp an
        kw = an
#else
    let ([SrcSpan]
r,ApiAnns
ga',AnnKeywordId
kw) = case ApiAnns -> SrcSpan -> AnnKeywordId -> ([SrcSpan], ApiAnns)
GHC.getAndRemoveAnnotation ApiAnns
ga SrcSpan
sp AnnKeywordId
an of
                    ([],ApiAnns
_) -> ([SrcSpan]
ss,ApiAnns
g,AnnKeywordId
k)
                      where
                        k :: AnnKeywordId
k = AnnKeywordId -> AnnKeywordId
GHC.unicodeAnn AnnKeywordId
an
                        ([SrcSpan]
ss,ApiAnns
g) = ApiAnns -> SrcSpan -> AnnKeywordId -> ([SrcSpan], ApiAnns)
GHC.getAndRemoveAnnotation ApiAnns
ga SrcSpan
sp AnnKeywordId
k
                    ([SrcSpan]
ss,ApiAnns
g)  -> ([SrcSpan]
ss,ApiAnns
g,AnnKeywordId
an)
#endif
    (DeltaState -> DeltaState)
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DeltaState
s -> DeltaState
s { apAnns :: ApiAnns
apAnns = ApiAnns
ga' })
    ([SrcSpan], AnnKeywordId) -> Delta ([SrcSpan], AnnKeywordId)
forall (m :: * -> *) a. Monad m => a -> m a
return ([SrcSpan]
r,AnnKeywordId
kw)

getOneAnnotationDelta :: GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)
getOneAnnotationDelta :: AnnKeywordId -> Delta ([SrcSpan], AnnKeywordId)
getOneAnnotationDelta AnnKeywordId
an = do
    SrcSpan
ss <- Delta SrcSpan
getSrcSpan
    SrcSpan -> AnnKeywordId -> Delta ([SrcSpan], AnnKeywordId)
getAndRemoveOneAnnotationDelta SrcSpan
ss AnnKeywordId
an

getAndRemoveOneAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId)
getAndRemoveOneAnnotationDelta :: SrcSpan -> AnnKeywordId -> Delta ([SrcSpan], AnnKeywordId)
getAndRemoveOneAnnotationDelta SrcSpan
sp AnnKeywordId
an = do
    (Map ApiAnnKey [SrcSpan]
anns,Map SrcSpan [Located AnnotationComment]
cs) <- (DeltaState -> ApiAnns)
-> RWST DeltaOptions DeltaWriter DeltaState Identity ApiAnns
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DeltaState -> ApiAnns
apAnns
#if __GLASGOW_HASKELL__ <= 710
    let (r,ga',kw) = case Map.lookup (sp,an) anns of
                    Nothing -> ([],(anns,cs),an)
                    Just []     -> ([], (Map.delete (sp,an)    anns,cs),an)
                    Just (s:ss) -> ([s],(Map.insert (sp,an) ss anns,cs),an)
#else
    let getKw :: AnnKeywordId -> ([SrcSpan], ApiAnns, AnnKeywordId)
getKw AnnKeywordId
kw =
          case ApiAnnKey -> Map ApiAnnKey [SrcSpan] -> Maybe [SrcSpan]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (SrcSpan
sp,AnnKeywordId
kw) Map ApiAnnKey [SrcSpan]
anns of
            Maybe [SrcSpan]
Nothing -> ([],(Map ApiAnnKey [SrcSpan]
anns,Map SrcSpan [Located AnnotationComment]
cs),AnnKeywordId
kw)
            Just []     -> ([], (ApiAnnKey -> Map ApiAnnKey [SrcSpan] -> Map ApiAnnKey [SrcSpan]
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (SrcSpan
sp,AnnKeywordId
kw)    Map ApiAnnKey [SrcSpan]
anns,Map SrcSpan [Located AnnotationComment]
cs),AnnKeywordId
kw)
            Just (SrcSpan
s:[SrcSpan]
ss) -> ([SrcSpan
s],(ApiAnnKey
-> [SrcSpan] -> Map ApiAnnKey [SrcSpan] -> Map ApiAnnKey [SrcSpan]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (SrcSpan
sp,AnnKeywordId
kw) [SrcSpan]
ss Map ApiAnnKey [SrcSpan]
anns,Map SrcSpan [Located AnnotationComment]
cs),AnnKeywordId
kw)

    let ([SrcSpan]
r,ApiAnns
ga',AnnKeywordId
kw) =
          case AnnKeywordId -> ([SrcSpan], ApiAnns, AnnKeywordId)
getKw AnnKeywordId
an of
            ([],ApiAnns
_,AnnKeywordId
_) -> AnnKeywordId -> ([SrcSpan], ApiAnns, AnnKeywordId)
getKw (AnnKeywordId -> AnnKeywordId
GHC.unicodeAnn AnnKeywordId
an)
            ([SrcSpan], ApiAnns, AnnKeywordId)
v        -> ([SrcSpan], ApiAnns, AnnKeywordId)
v
#endif
    (DeltaState -> DeltaState)
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DeltaState
s -> DeltaState
s { apAnns :: ApiAnns
apAnns = ApiAnns
ga' })
    ([SrcSpan], AnnKeywordId) -> Delta ([SrcSpan], AnnKeywordId)
forall (m :: * -> *) a. Monad m => a -> m a
return ([SrcSpan]
r,AnnKeywordId
kw)

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

-- |Add some annotation to the currently active SrcSpan
addAnnotationsDelta :: Annotation -> Delta ()
addAnnotationsDelta :: Annotation -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationsDelta Annotation
ann = do
    DeltaOptions
l <- RWST DeltaOptions DeltaWriter DeltaState Identity DeltaOptions
forall r (m :: * -> *). MonadReader r m => m r
ask
    (AnnKey, Annotation) -> RWS DeltaOptions DeltaWriter DeltaState ()
tellFinalAnn (DeltaOptions -> AnnKey
getAnnKey DeltaOptions
l,Annotation
ann)

getAnnKey :: DeltaOptions -> AnnKey
getAnnKey :: DeltaOptions -> AnnKey
getAnnKey DeltaOptions {SrcSpan
curSrcSpan :: SrcSpan
curSrcSpan :: DeltaOptions -> SrcSpan
curSrcSpan, AnnConName
annConName :: AnnConName
annConName :: DeltaOptions -> AnnConName
annConName}
  = SrcSpan -> AnnConName -> AnnKey
AnnKey SrcSpan
curSrcSpan AnnConName
annConName

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

addAnnDeltaPos :: KeywordId -> DeltaPos -> Delta ()
addAnnDeltaPos :: KeywordId -> DeltaPos -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnDeltaPos KeywordId
kw DeltaPos
dp = (KeywordId, DeltaPos) -> RWS DeltaOptions DeltaWriter DeltaState ()
tellKd (KeywordId
kw, DeltaPos
dp)

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

-- | Enter a new AST element. Maintain SrcSpan stack
#if __GLASGOW_HASKELL__ > 806
withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)
        => a
        -> Delta b -> Delta b
withAST :: a -> Delta b -> Delta b
withAST lss :: a
lss@(a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
GHC.dL->GHC.L SrcSpan
ss SrcSpanLess a
_) Delta b
action = do
#else
withAST :: Data a
        => GHC.Located a
        -> Delta b -> Delta b
withAST lss@(GHC.L ss _) action = do
#endif
  -- Calculate offset required to get to the start of the SrcSPan
  LayoutStartCol
off <- (DeltaState -> LayoutStartCol)
-> RWST DeltaOptions DeltaWriter DeltaState Identity LayoutStartCol
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DeltaState -> LayoutStartCol
apLayoutStart
  (Delta b -> Delta b
forall a. Delta a -> Delta a
resetAnns (Delta b -> Delta b) -> (Delta b -> Delta b) -> Delta b -> Delta b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  a -> Delta b -> Delta b
forall a b.
(Data (SrcSpanLess a), HasSrcSpan a) =>
a -> Delta b -> Delta b
withSrcSpanDelta a
lss) (do

    let maskWriter :: DeltaWriter -> DeltaWriter
maskWriter DeltaWriter
s = DeltaWriter
s { annKds :: [(KeywordId, DeltaPos)]
annKds = []
                         , sortKeys :: Maybe [SrcSpan]
sortKeys = Maybe [SrcSpan]
forall a. Maybe a
Nothing
                         , dwCapturedSpan :: First AnnKey
dwCapturedSpan = First AnnKey
forall a. Monoid a => a
mempty }

    -- make sure all kds are relative to the start of the SrcSpan
    let spanStart :: Pos
spanStart = SrcSpan -> Pos
ss2pos SrcSpan
ss

    [(Comment, DeltaPos)]
cs <- do
      Pos
priorEndBeforeComments <- Delta Pos
getPriorEnd
      if SrcSpan -> Bool
GHC.isGoodSrcSpan SrcSpan
ss Bool -> Bool -> Bool
&& Pos
priorEndBeforeComments Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< SrcSpan -> Pos
ss2pos SrcSpan
ss
        then
          (Comment -> Bool)
-> ([(Comment, DeltaPos)]
    -> RWST
         DeltaOptions DeltaWriter DeltaState Identity [(Comment, DeltaPos)])
-> RWST
     DeltaOptions DeltaWriter DeltaState Identity [(Comment, DeltaPos)]
forall a.
(Comment -> Bool) -> ([(Comment, DeltaPos)] -> Delta a) -> Delta a
commentAllocation (Pos -> Comment -> Bool
priorComment Pos
spanStart) [(Comment, DeltaPos)]
-> RWST
     DeltaOptions DeltaWriter DeltaState Identity [(Comment, DeltaPos)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        else
          [(Comment, DeltaPos)]
-> RWST
     DeltaOptions DeltaWriter DeltaState Identity [(Comment, DeltaPos)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Pos
priorEndAfterComments <- Delta Pos
getPriorEnd
    let edp :: DeltaPos
edp = LayoutStartCol -> DeltaPos -> DeltaPos
adjustDeltaForOffset
                -- Use the propagated offset if one is set
                -- Note that we need to use the new offset if it has
                -- changed.
                LayoutStartCol
off (Pos -> SrcSpan -> DeltaPos
ss2delta Pos
priorEndAfterComments SrcSpan
ss)
    -- Preparation complete, perform the action
    Bool
-> RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SrcSpan -> Bool
GHC.isGoodSrcSpan SrcSpan
ss Bool -> Bool -> Bool
&& Pos
priorEndAfterComments Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< SrcSpan -> Pos
ss2pos SrcSpan
ss) (do
      (DeltaState -> DeltaState)
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DeltaState
s -> DeltaState
s { priorEndPosition :: Pos
priorEndPosition    = SrcSpan -> Pos
ss2pos SrcSpan
ss } ))
    (b
res, DeltaWriter
w) <- (DeltaWriter -> DeltaWriter)
-> RWST
     DeltaOptions DeltaWriter DeltaState Identity (b, DeltaWriter)
-> RWST
     DeltaOptions DeltaWriter DeltaState Identity (b, DeltaWriter)
forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor DeltaWriter -> DeltaWriter
maskWriter (Delta b
-> RWST
     DeltaOptions DeltaWriter DeltaState Identity (b, DeltaWriter)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen Delta b
action)

    let kds :: [(KeywordId, DeltaPos)]
kds = DeltaWriter -> [(KeywordId, DeltaPos)]
annKds DeltaWriter
w
        an :: Annotation
an = Ann :: DeltaPos
-> [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)]
-> [(KeywordId, DeltaPos)]
-> Maybe [SrcSpan]
-> Maybe AnnKey
-> Annotation
Ann
               { annEntryDelta :: DeltaPos
annEntryDelta        = DeltaPos
edp
               , annPriorComments :: [(Comment, DeltaPos)]
annPriorComments     = [(Comment, DeltaPos)]
cs
               , annFollowingComments :: [(Comment, DeltaPos)]
annFollowingComments = [] -- only used in Transform and Print
               , annsDP :: [(KeywordId, DeltaPos)]
annsDP               = [(KeywordId, DeltaPos)]
kds
               , annSortKey :: Maybe [SrcSpan]
annSortKey           = DeltaWriter -> Maybe [SrcSpan]
sortKeys DeltaWriter
w
               , annCapturedSpan :: Maybe AnnKey
annCapturedSpan      = First AnnKey -> Maybe AnnKey
forall a. First a -> Maybe a
getFirst (First AnnKey -> Maybe AnnKey) -> First AnnKey -> Maybe AnnKey
forall a b. (a -> b) -> a -> b
$ DeltaWriter -> First AnnKey
dwCapturedSpan DeltaWriter
w }

    Annotation -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationsDelta Annotation
an
     RWS DeltaOptions DeltaWriter DeltaState ()
-> String -> RWS DeltaOptions DeltaWriter DeltaState ()
forall c. c -> String -> c
`debug` (String
"leaveAST:(annkey,an)=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (AnnKey, Annotation) -> String
forall a. Show a => a -> String
show (a -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey a
lss,Annotation
an))
    b -> Delta b
forall (m :: * -> *) a. Monad m => a -> m a
return b
res)

resetAnns :: Delta a -> Delta a
resetAnns :: Delta a -> Delta a
resetAnns Delta a
action = do
  ApiAnns
ans <- (DeltaState -> ApiAnns)
-> RWST DeltaOptions DeltaWriter DeltaState Identity ApiAnns
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DeltaState -> ApiAnns
apAnns
  Delta a
action Delta a -> RWS DeltaOptions DeltaWriter DeltaState () -> Delta a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (DeltaState -> DeltaState)
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DeltaState
s -> DeltaState
s { apAnns :: ApiAnns
apAnns = ApiAnns
ans })


-- ---------------------------------------------------------------------
-- |Split the ordered list of comments into ones that occur prior to
-- the give SrcSpan and the rest
priorComment :: Pos -> Comment -> Bool
priorComment :: Pos -> Comment -> Bool
priorComment Pos
start Comment
c = (SrcSpan -> Pos
ss2pos (SrcSpan -> Pos) -> (Comment -> SrcSpan) -> Comment -> Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comment -> SrcSpan
commentIdentifier (Comment -> Pos) -> Comment -> Pos
forall a b. (a -> b) -> a -> b
$ Comment
c) Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< Pos
start

-- TODO:AZ: We scan the entire comment list here. It may be better to impose an
-- invariant that the comments are sorted, and consume them as the pos
-- advances. It then becomes a process of using `takeWhile p` rather than a full
-- partition.
allocateComments :: (Comment -> Bool) -> [Comment] -> ([Comment], [Comment])
allocateComments :: (Comment -> Bool) -> [Comment] -> ([Comment], [Comment])
allocateComments = (Comment -> Bool) -> [Comment] -> ([Comment], [Comment])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition

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

addAnnotationWorker :: KeywordId -> GHC.SrcSpan -> Delta ()
addAnnotationWorker :: KeywordId -> SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationWorker KeywordId
ann SrcSpan
pa =
  -- Zero-width source spans are injected by the GHC Lexer when it puts virtual
  -- '{', ';' and '}' tokens in for layout
  Bool
-> RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SrcSpan -> Bool
isPointSrcSpan SrcSpan
pa) (RWS DeltaOptions DeltaWriter DeltaState ()
 -> RWS DeltaOptions DeltaWriter DeltaState ())
-> RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall a b. (a -> b) -> a -> b
$
    do
      Pos
pe <- Delta Pos
getPriorEnd
      SrcSpan
ss <- Delta SrcSpan
getSrcSpan
      let p :: DeltaPos
p = Pos -> SrcSpan -> DeltaPos
ss2delta Pos
pe SrcSpan
pa
      case (KeywordId
ann,DeltaPos -> Bool
isGoodDelta DeltaPos
p) of
        (G AnnKeywordId
GHC.AnnComma,Bool
False) -> () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (G AnnKeywordId
GHC.AnnSemi, Bool
False) -> () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (G AnnKeywordId
GHC.AnnOpen, Bool
False) -> () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (G AnnKeywordId
GHC.AnnClose,Bool
False) -> () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (KeywordId, Bool)
_ -> do
          DeltaPos
p' <- DeltaPos -> Delta DeltaPos
adjustDeltaForOffsetM DeltaPos
p
          (Comment -> Bool)
-> ([(Comment, DeltaPos)]
    -> RWS DeltaOptions DeltaWriter DeltaState ())
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall a.
(Comment -> Bool) -> ([(Comment, DeltaPos)] -> Delta a) -> Delta a
commentAllocation (Pos -> Comment -> Bool
priorComment (SrcSpan -> Pos
ss2pos SrcSpan
pa)) (((Comment, DeltaPos) -> RWS DeltaOptions DeltaWriter DeltaState ())
-> [(Comment, DeltaPos)]
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Comment -> DeltaPos -> RWS DeltaOptions DeltaWriter DeltaState ())
-> (Comment, DeltaPos)
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Comment -> DeltaPos -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaComment))
#if __GLASGOW_HASKELL__ <= 710
          addAnnDeltaPos (checkUnicode ann pa) p'
#else
          KeywordId -> DeltaPos -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnDeltaPos KeywordId
ann DeltaPos
p'
#endif
          SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
setPriorEndAST SrcSpan
pa
              RWS DeltaOptions DeltaWriter DeltaState ()
-> String -> RWS DeltaOptions DeltaWriter DeltaState ()
forall c. c -> String -> c
`debug` (String
"addAnnotationWorker:(ss,ss,pe,pa,p,p',ann)=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, String, Pos, String, DeltaPos, DeltaPos, KeywordId)
-> String
forall a. Show a => a -> String
show (SrcSpan -> String
forall a. Outputable a => a -> String
showGhc SrcSpan
ss,SrcSpan -> String
forall a. Outputable a => a -> String
showGhc SrcSpan
ss,Pos
pe,SrcSpan -> String
forall a. Outputable a => a -> String
showGhc SrcSpan
pa,DeltaPos
p,DeltaPos
p',KeywordId
ann))

#if __GLASGOW_HASKELL__ <= 710
checkUnicode :: KeywordId -> GHC.SrcSpan -> KeywordId
checkUnicode gkw@(G kw) ss =
  if kw `Set.member` unicodeSyntax
    then
      let s = keywordToString gkw in
      if length s /= spanLength ss
        then AnnUnicode kw
        else gkw
  else
    gkw
  where
    unicodeSyntax = Set.fromList
      [ GHC.AnnDcolon
      , GHC.AnnDarrow
      , GHC.AnnForall
      , GHC.AnnRarrow
      , GHC.AnnLarrow
      , GHC.Annlarrowtail
      , GHC.Annrarrowtail
      , GHC.AnnLarrowtail
      , GHC.AnnRarrowtail]
checkUnicode kwid _ = kwid
#else

unicodeEquivalent :: GHC.AnnKeywordId -> [GHC.AnnKeywordId]
unicodeEquivalent :: AnnKeywordId -> [AnnKeywordId]
unicodeEquivalent AnnKeywordId
kw =
  case AnnKeywordId -> Map AnnKeywordId AnnKeywordId -> Maybe AnnKeywordId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKeywordId
kw Map AnnKeywordId AnnKeywordId
unicodeSyntax of
    Maybe AnnKeywordId
Nothing -> []
    Just AnnKeywordId
kwu -> [AnnKeywordId
kwu]
  where
    unicodeSyntax :: Map AnnKeywordId AnnKeywordId
unicodeSyntax = [(AnnKeywordId, AnnKeywordId)] -> Map AnnKeywordId AnnKeywordId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (AnnKeywordId
GHC.AnnDcolon,     AnnKeywordId
GHC.AnnDcolonU)
      , (AnnKeywordId
GHC.AnnDarrow,     AnnKeywordId
GHC.AnnDarrowU)
      , (AnnKeywordId
GHC.AnnForall,     AnnKeywordId
GHC.AnnForallU)
      , (AnnKeywordId
GHC.AnnRarrow,     AnnKeywordId
GHC.AnnRarrowU)
      , (AnnKeywordId
GHC.AnnLarrow,     AnnKeywordId
GHC.AnnLarrowU)
      , (AnnKeywordId
GHC.Annlarrowtail, AnnKeywordId
GHC.AnnlarrowtailU)
      , (AnnKeywordId
GHC.Annrarrowtail, AnnKeywordId
GHC.AnnrarrowtailU)
      , (AnnKeywordId
GHC.AnnLarrowtail, AnnKeywordId
GHC.AnnLarrowtailU)
      , (AnnKeywordId
GHC.AnnRarrowtail, AnnKeywordId
GHC.AnnRarrowtailU)
#if __GLASGOW_HASKELL__ > 801
      , (AnnKeywordId
GHC.AnnCloseB,     AnnKeywordId
GHC.AnnCloseBU)
      , (AnnKeywordId
GHC.AnnCloseQ,     AnnKeywordId
GHC.AnnCloseQU)
      , (AnnKeywordId
GHC.AnnOpenB,      AnnKeywordId
GHC.AnnOpenBU)
      , (AnnKeywordId
GHC.AnnOpenEQ,     AnnKeywordId
GHC.AnnOpenEQU)
#endif
      ]
#endif


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

commentAllocation :: (Comment -> Bool)
                  -> ([(Comment, DeltaPos)] -> Delta a)
                  -> Delta a
commentAllocation :: (Comment -> Bool) -> ([(Comment, DeltaPos)] -> Delta a) -> Delta a
commentAllocation Comment -> Bool
p [(Comment, DeltaPos)] -> Delta a
k = do
  [Comment]
cs <- RWST DeltaOptions DeltaWriter DeltaState Identity [Comment]
getUnallocatedComments
  let ([Comment]
allocated,[Comment]
cs') = (Comment -> Bool) -> [Comment] -> ([Comment], [Comment])
allocateComments Comment -> Bool
p [Comment]
cs
  [Comment] -> RWS DeltaOptions DeltaWriter DeltaState ()
putUnallocatedComments [Comment]
cs'
  [(Comment, DeltaPos)] -> Delta a
k ([(Comment, DeltaPos)] -> Delta a)
-> RWST
     DeltaOptions DeltaWriter DeltaState Identity [(Comment, DeltaPos)]
-> Delta a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Comment
 -> RWST
      DeltaOptions DeltaWriter DeltaState Identity (Comment, DeltaPos))
-> [Comment]
-> RWST
     DeltaOptions DeltaWriter DeltaState Identity [(Comment, DeltaPos)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Comment
-> RWST
     DeltaOptions DeltaWriter DeltaState Identity (Comment, DeltaPos)
makeDeltaComment ((Comment -> Maybe (Pos, Pos)) -> [Comment] -> [Comment]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (SrcSpan -> Maybe (Pos, Pos)
unpack (SrcSpan -> Maybe (Pos, Pos))
-> (Comment -> SrcSpan) -> Comment -> Maybe (Pos, Pos)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comment -> SrcSpan
commentIdentifier) [Comment]
allocated)
  where
    -- unpack a RealSrcSpan into ((start line, start col), (end line, end col)).
    -- The file name is ignored.
    unpack :: GHC.SrcSpan -> Maybe ((Int, Int), (Int, Int))
    unpack :: SrcSpan -> Maybe (Pos, Pos)
unpack (GHC.RealSrcSpan RealSrcSpan
x) =
       (Pos, Pos) -> Maybe (Pos, Pos)
forall a. a -> Maybe a
Just ( (RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
x, RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
x)
            , (RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
x, RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
x) )
    unpack SrcSpan
_ = Maybe (Pos, Pos)
forall a. Maybe a
Nothing

makeDeltaComment :: Comment -> Delta (Comment, DeltaPos)
makeDeltaComment :: Comment
-> RWST
     DeltaOptions DeltaWriter DeltaState Identity (Comment, DeltaPos)
makeDeltaComment Comment
c = do
  let pa :: SrcSpan
pa = Comment -> SrcSpan
commentIdentifier Comment
c
  Pos
pe <- Delta Pos
getPriorEnd
  let p :: DeltaPos
p = Pos -> SrcSpan -> DeltaPos
ss2delta Pos
pe SrcSpan
pa
  DeltaPos
p' <- DeltaPos -> Delta DeltaPos
adjustDeltaForOffsetM DeltaPos
p
  Pos -> RWS DeltaOptions DeltaWriter DeltaState ()
setPriorEnd (SrcSpan -> Pos
ss2posEnd SrcSpan
pa)
  (Comment, DeltaPos)
-> RWST
     DeltaOptions DeltaWriter DeltaState Identity (Comment, DeltaPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (Comment
c, DeltaPos
p')

addDeltaComment :: Comment -> DeltaPos -> Delta ()
addDeltaComment :: Comment -> DeltaPos -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaComment Comment
d DeltaPos
p = do
  KeywordId -> DeltaPos -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnDeltaPos (Comment -> KeywordId
AnnComment Comment
d) DeltaPos
p

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

-- |If the first annotation has a smaller SrcSpan than the second, then mark it.
deltaMarkAnnBeforeAnn :: GHC.AnnKeywordId -> GHC.AnnKeywordId -> Delta ()
deltaMarkAnnBeforeAnn :: AnnKeywordId
-> AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
deltaMarkAnnBeforeAnn AnnKeywordId
annBefore AnnKeywordId
annAfter = do
  SrcSpan
ss <- Delta SrcSpan
getSrcSpan
  [SrcSpan]
mb <- AnnKeywordId -> Delta [SrcSpan]
peekAnnotationDelta AnnKeywordId
annBefore
  [SrcSpan]
ma <- AnnKeywordId -> Delta [SrcSpan]
peekAnnotationDelta AnnKeywordId
annAfter
  let
    before :: [SrcSpan]
before = [SrcSpan] -> [SrcSpan]
forall a. Ord a => [a] -> [a]
sort ([SrcSpan] -> [SrcSpan]) -> [SrcSpan] -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ (SrcSpan -> Bool) -> [SrcSpan] -> [SrcSpan]
forall a. (a -> Bool) -> [a] -> [a]
filter (\SrcSpan
s -> SrcSpan -> SrcSpan -> Bool
GHC.isSubspanOf SrcSpan
s SrcSpan
ss) [SrcSpan]
mb
    after :: [SrcSpan]
after  = [SrcSpan] -> [SrcSpan]
forall a. Ord a => [a] -> [a]
sort ([SrcSpan] -> [SrcSpan]) -> [SrcSpan] -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ (SrcSpan -> Bool) -> [SrcSpan] -> [SrcSpan]
forall a. (a -> Bool) -> [a] -> [a]
filter (\SrcSpan
s -> SrcSpan -> SrcSpan -> Bool
GHC.isSubspanOf SrcSpan
s SrcSpan
ss) [SrcSpan]
ma
  case ([SrcSpan]
before,[SrcSpan]
after) of
    (SrcSpan
b:[SrcSpan]
_, SrcSpan
a:[SrcSpan]
_) -> Bool
-> RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SrcSpan
b SrcSpan -> SrcSpan -> Bool
forall a. Ord a => a -> a -> Bool
< SrcSpan
a) (RWS DeltaOptions DeltaWriter DeltaState ()
 -> RWS DeltaOptions DeltaWriter DeltaState ())
-> RWS DeltaOptions DeltaWriter DeltaState ()
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall a b. (a -> b) -> a -> b
$ AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotation AnnKeywordId
annBefore
    ([SrcSpan], [SrcSpan])
_ -> () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

-- | Look up and add a Delta annotation at the current position, and
-- advance the position to the end of the annotation
addDeltaAnnotation :: GHC.AnnKeywordId -> Delta ()
addDeltaAnnotation :: AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotation AnnKeywordId
ann' = do
  SrcSpan
ss <- Delta SrcSpan
getSrcSpan
  ([SrcSpan]
ma,AnnKeywordId
ann) <- AnnKeywordId -> Delta ([SrcSpan], AnnKeywordId)
getOneAnnotationDelta AnnKeywordId
ann'
  case [SrcSpan] -> [SrcSpan]
forall a. Eq a => [a] -> [a]
nub [SrcSpan]
ma of -- ++AZ++ TODO: get rid of duplicates earlier
    []     -> () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall (m :: * -> *) a. Monad m => a -> m a
return () RWS DeltaOptions DeltaWriter DeltaState ()
-> String -> RWS DeltaOptions DeltaWriter DeltaState ()
forall c. c -> String -> c
`debug` (String
"addDeltaAnnotation empty ma for:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ApiAnnKey -> String
forall a. Show a => a -> String
show (SrcSpan
ss,AnnKeywordId
ann))
    [SrcSpan
pa]   -> KeywordId -> SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationWorker (AnnKeywordId -> KeywordId
G AnnKeywordId
ann) SrcSpan
pa
    (SrcSpan
pa:[SrcSpan]
_) -> KeywordId -> SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationWorker (AnnKeywordId -> KeywordId
G AnnKeywordId
ann) SrcSpan
pa RWS DeltaOptions DeltaWriter DeltaState ()
-> String -> RWS DeltaOptions DeltaWriter DeltaState ()
forall c. c -> String -> c
`warn` (String
"addDeltaAnnotation:(ss,ann,ma)=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (SrcSpan, AnnKeywordId, [SrcSpan]) -> String
forall a. Outputable a => a -> String
showGhc (SrcSpan
ss,AnnKeywordId
ann,[SrcSpan]
ma))

-- | Look up and add a Delta annotation at the current position, and
-- advance the position to the end of the annotation
addDeltaAnnotationLs :: GHC.AnnKeywordId -> Int -> Delta ()
addDeltaAnnotationLs :: AnnKeywordId -> Int -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotationLs AnnKeywordId
ann Int
off = do
  SrcSpan
ss <- Delta SrcSpan
getSrcSpan
  [SrcSpan]
ma <- AnnKeywordId -> Delta [SrcSpan]
peekAnnotationDelta AnnKeywordId
ann
  let ma' :: [SrcSpan]
ma' = (SrcSpan -> Bool) -> [SrcSpan] -> [SrcSpan]
forall a. (a -> Bool) -> [a] -> [a]
filter (\SrcSpan
s -> SrcSpan -> SrcSpan -> Bool
GHC.isSubspanOf SrcSpan
s SrcSpan
ss) [SrcSpan]
ma
  case Int -> [SrcSpan] -> [SrcSpan]
forall a. Int -> [a] -> [a]
drop Int
off [SrcSpan]
ma' of
    [] -> () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        RWS DeltaOptions DeltaWriter DeltaState ()
-> String -> RWS DeltaOptions DeltaWriter DeltaState ()
forall c. c -> String -> c
`debug` (String
"addDeltaAnnotationLs:missed:(off,ann,ma)=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, SrcSpan, AnnKeywordId) -> String
forall a. Outputable a => a -> String
showGhc (Int
off,SrcSpan
ss,AnnKeywordId
ann))
    (SrcSpan
pa:[SrcSpan]
_) -> KeywordId -> SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationWorker (AnnKeywordId -> KeywordId
G AnnKeywordId
ann) SrcSpan
pa

-- | Look up and add possibly multiple Delta annotation at the current
-- position, and advance the position to the end of the annotations
addDeltaAnnotations :: GHC.AnnKeywordId -> Delta ()
addDeltaAnnotations :: AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotations AnnKeywordId
ann = do
  ([SrcSpan]
ma,AnnKeywordId
kw) <- AnnKeywordId -> Delta ([SrcSpan], AnnKeywordId)
getAnnotationDelta AnnKeywordId
ann
  let do_one :: SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
do_one SrcSpan
ap' = KeywordId -> SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationWorker (AnnKeywordId -> KeywordId
G AnnKeywordId
kw) SrcSpan
ap'
                    RWS DeltaOptions DeltaWriter DeltaState ()
-> String -> RWS DeltaOptions DeltaWriter DeltaState ()
forall c. c -> String -> c
`debug` (String
"addDeltaAnnotations:do_one:(ap',ann)=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ApiAnnKey -> String
forall a. Outputable a => a -> String
showGhc (SrcSpan
ap',AnnKeywordId
ann))
  (SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ())
-> [SrcSpan] -> RWS DeltaOptions DeltaWriter DeltaState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
do_one ([SrcSpan] -> [SrcSpan]
forall a. Ord a => [a] -> [a]
sort [SrcSpan]
ma)

-- | Look up and add possibly multiple Delta annotations enclosed by
-- the current SrcSpan at the current position, and advance the
-- position to the end of the annotations
addDeltaAnnotationsInside :: GHC.AnnKeywordId -> Delta ()
addDeltaAnnotationsInside :: AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotationsInside AnnKeywordId
ann = do
  SrcSpan
ss <- Delta SrcSpan
getSrcSpan
  [SrcSpan]
ma <- AnnKeywordId -> Delta [SrcSpan]
peekAnnotationDelta AnnKeywordId
ann
  let do_one :: SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
do_one SrcSpan
ap' = KeywordId -> SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationWorker (AnnKeywordId -> KeywordId
G AnnKeywordId
ann) SrcSpan
ap'
                    -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))
  let filtered :: [SrcSpan]
filtered = [SrcSpan] -> [SrcSpan]
forall a. Ord a => [a] -> [a]
sort ([SrcSpan] -> [SrcSpan]) -> [SrcSpan] -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ (SrcSpan -> Bool) -> [SrcSpan] -> [SrcSpan]
forall a. (a -> Bool) -> [a] -> [a]
filter (\SrcSpan
s -> SrcSpan -> SrcSpan -> Bool
GHC.isSubspanOf SrcSpan
s SrcSpan
ss) [SrcSpan]
ma
  (SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ())
-> [SrcSpan] -> RWS DeltaOptions DeltaWriter DeltaState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
do_one [SrcSpan]
filtered

-- ---------------------------------------------------------------------
#if __GLASGOW_HASKELL__ >= 800
addDeltaAnnotationInstead :: GHC.AnnKeywordId  -> KeywordId -> Delta ()
addDeltaAnnotationInstead :: AnnKeywordId
-> KeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotationInstead AnnKeywordId
ann' KeywordId
kw = do
  SrcSpan
ss <- Delta SrcSpan
getSrcSpan
  ([SrcSpan]
ma,AnnKeywordId
ann) <- AnnKeywordId -> Delta ([SrcSpan], AnnKeywordId)
getOneAnnotationDelta AnnKeywordId
ann'
  case [SrcSpan] -> [SrcSpan]
forall a. Eq a => [a] -> [a]
nub [SrcSpan]
ma of -- ++AZ++ TODO: get rid of duplicates earlier
    []     -> () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall (m :: * -> *) a. Monad m => a -> m a
return () RWS DeltaOptions DeltaWriter DeltaState ()
-> String -> RWS DeltaOptions DeltaWriter DeltaState ()
forall c. c -> String -> c
`debug` (String
"addDeltaAnnotation empty ma for:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ApiAnnKey -> String
forall a. Show a => a -> String
show (SrcSpan
ss,AnnKeywordId
ann))
    [SrcSpan
pa]   -> KeywordId -> SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationWorker KeywordId
kw SrcSpan
pa
    (SrcSpan
pa:[SrcSpan]
_) -> KeywordId -> SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationWorker KeywordId
kw SrcSpan
pa RWS DeltaOptions DeltaWriter DeltaState ()
-> String -> RWS DeltaOptions DeltaWriter DeltaState ()
forall c. c -> String -> c
`warn` (String
"addDeltaAnnotationInstead:(ss,ann,kw,ma)=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (SrcSpan, AnnKeywordId, KeywordId, [SrcSpan]) -> String
forall a. Outputable a => a -> String
showGhc (SrcSpan
ss,AnnKeywordId
ann,KeywordId
kw,[SrcSpan]
ma))
#endif
-- ---------------------------------------------------------------------

-- | Look up and add possibly multiple Delta annotations not enclosed by
-- the current SrcSpan at the current position, and advance the
-- position to the end of the annotations
-- The first argument (gann) is the one to look up in the GHC annotations, the
-- second is the one to apply in the ghc-exactprint ones. These are different
-- for GHC.AnnSemi mapping to AnnSemiSep, to ensure that it reflects the ';'
-- outside the current span.
addDeltaAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Delta ()
addDeltaAnnotationsOutside :: AnnKeywordId
-> KeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotationsOutside AnnKeywordId
gann KeywordId
ann = do
  SrcSpan
ss <- Delta SrcSpan
getSrcSpan
  ([SrcSpan]
ma,AnnKeywordId
kw) <- SrcSpan -> AnnKeywordId -> Delta ([SrcSpan], AnnKeywordId)
getAndRemoveAnnotationDelta SrcSpan
ss AnnKeywordId
gann
  let do_one :: SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
do_one SrcSpan
ap' = if KeywordId
ann KeywordId -> KeywordId -> Bool
forall a. Eq a => a -> a -> Bool
== KeywordId
AnnSemiSep
                     then KeywordId -> SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationWorker KeywordId
ann    SrcSpan
ap'
                     else KeywordId -> SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationWorker (AnnKeywordId -> KeywordId
G AnnKeywordId
kw) SrcSpan
ap'
  (SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ())
-> [SrcSpan] -> RWS DeltaOptions DeltaWriter DeltaState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
do_one ([SrcSpan] -> [SrcSpan]
forall a. Ord a => [a] -> [a]
sort ([SrcSpan] -> [SrcSpan]) -> [SrcSpan] -> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ (SrcSpan -> Bool) -> [SrcSpan] -> [SrcSpan]
forall a. (a -> Bool) -> [a] -> [a]
filter (\SrcSpan
s -> Bool -> Bool
not (SrcSpan -> SrcSpan -> Bool
GHC.isSubspanOf SrcSpan
s SrcSpan
ss)) [SrcSpan]
ma)

-- | Add a Delta annotation at the current position, and advance the
-- position to the end of the annotation
addDeltaAnnotationExt :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ()
addDeltaAnnotationExt :: SrcSpan
-> AnnKeywordId -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaAnnotationExt SrcSpan
s AnnKeywordId
ann = KeywordId -> SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnotationWorker (AnnKeywordId -> KeywordId
G AnnKeywordId
ann) SrcSpan
s

addEofAnnotation :: Delta ()
addEofAnnotation :: RWS DeltaOptions DeltaWriter DeltaState ()
addEofAnnotation = do
  Pos
pe <- Delta Pos
getPriorEnd
  ([SrcSpan]
ma,AnnKeywordId
_kw) <- GenLocated SrcSpan ()
-> Delta ([SrcSpan], AnnKeywordId)
-> Delta ([SrcSpan], AnnKeywordId)
forall a b.
(Data (SrcSpanLess a), HasSrcSpan a) =>
a -> Delta b -> Delta b
withSrcSpanDelta (SrcSpanLess (GenLocated SrcSpan ()) -> GenLocated SrcSpan ()
forall a. HasSrcSpan a => SrcSpanLess a -> a
GHC.noLoc () :: GHC.GenLocated GHC.SrcSpan ()) (AnnKeywordId -> Delta ([SrcSpan], AnnKeywordId)
getAnnotationDelta AnnKeywordId
GHC.AnnEofPos)
  case [SrcSpan]
ma of
    [] -> () -> RWS DeltaOptions DeltaWriter DeltaState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (SrcSpan
pa:[SrcSpan]
pss) -> do
      (Comment -> Bool)
-> ([(Comment, DeltaPos)]
    -> RWS DeltaOptions DeltaWriter DeltaState ())
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall a.
(Comment -> Bool) -> ([(Comment, DeltaPos)] -> Delta a) -> Delta a
commentAllocation (Bool -> Comment -> Bool
forall a b. a -> b -> a
const Bool
True) (((Comment, DeltaPos) -> RWS DeltaOptions DeltaWriter DeltaState ())
-> [(Comment, DeltaPos)]
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Comment -> DeltaPos -> RWS DeltaOptions DeltaWriter DeltaState ())
-> (Comment, DeltaPos)
-> RWS DeltaOptions DeltaWriter DeltaState ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Comment -> DeltaPos -> RWS DeltaOptions DeltaWriter DeltaState ()
addDeltaComment))
      let DP (Int
r,Int
c) = Pos -> SrcSpan -> DeltaPos
ss2delta Pos
pe SrcSpan
pa
      KeywordId -> DeltaPos -> RWS DeltaOptions DeltaWriter DeltaState ()
addAnnDeltaPos (AnnKeywordId -> KeywordId
G AnnKeywordId
GHC.AnnEofPos) (Pos -> DeltaPos
DP (Int
r, Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
      SrcSpan -> RWS DeltaOptions DeltaWriter DeltaState ()
setPriorEndAST SrcSpan
pa RWS DeltaOptions DeltaWriter DeltaState ()
-> String -> RWS DeltaOptions DeltaWriter DeltaState ()
forall c. c -> String -> c
`warn` (String
"Trailing annotations after Eof: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [SrcSpan] -> String
forall a. Outputable a => a -> String
showGhc [SrcSpan]
pss)

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

countAnnsDelta :: GHC.AnnKeywordId -> Delta Int
countAnnsDelta :: AnnKeywordId -> Delta Int
countAnnsDelta AnnKeywordId
ann = do
  [SrcSpan]
ma <- AnnKeywordId -> Delta [SrcSpan]
peekAnnotationDelta AnnKeywordId
ann
  Int -> Delta Int
forall (m :: * -> *) a. Monad m => a -> m a
return ([SrcSpan] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SrcSpan]
ma)