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

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.GHC.ExactPrint.Pretty
--
-- This module adds default annotations to an AST fragment that does not have
-- them, to be able to exactprint it in a way that preserves the orginal AST
-- when re-parsed.
--
-----------------------------------------------------------------------------

module Language.Haskell.GHC.ExactPrint.Pretty
        (
        addAnnotationsForPretty
        ) where

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

import Control.Monad.RWS
import Control.Monad.Trans.Free
import Data.Generics
import Data.List
import Data.Ord (comparing)


#if __GLASGOW_HASKELL__ <= 710
import qualified BooleanFormula as GHC
import qualified Outputable     as GHC
#endif
import qualified GHC

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

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

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

-- |Add any missing annotations so that the full AST element will exactprint
-- properly when done.
addAnnotationsForPretty :: (Annotate a) => [Comment] -> GHC.Located a -> Anns -> Anns
addAnnotationsForPretty :: [Comment] -> Located a -> Anns -> Anns
addAnnotationsForPretty [Comment]
cs Located a
ast Anns
ans
  = PrettyOptions -> [Comment] -> Annotated () -> Anns -> Pos -> Anns
runPrettyWithComments PrettyOptions
opts [Comment]
cs (Located a -> Annotated ()
forall ast.
(Annotate ast, Data (SrcSpanLess ast), HasSrcSpan ast) =>
ast -> Annotated ()
annotate Located a
ast) Anns
ans (Int
0,Int
0)
  where
    opts :: PrettyOptions
opts = Rigidity -> PrettyOptions
prettyOptions Rigidity
NormalLayout

-- ---------------------------------------------------------------------
--
-- | Type used in the Pretty Monad.
type Pretty a = RWS PrettyOptions PrettyWriter PrettyState a

runPrettyWithComments :: PrettyOptions -> [Comment] -> Annotated () -> Anns -> Pos -> Anns
runPrettyWithComments :: PrettyOptions -> [Comment] -> Annotated () -> Anns -> Pos -> Anns
runPrettyWithComments PrettyOptions
opts [Comment]
cs Annotated ()
action Anns
ans Pos
priorEnd =
  PrettyWriter -> Anns
mkAnns (PrettyWriter -> Anns)
-> (Annotated () -> PrettyWriter) -> Annotated () -> Anns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrettyState, PrettyWriter) -> PrettyWriter
forall a b. (a, b) -> b
snd
  ((PrettyState, PrettyWriter) -> PrettyWriter)
-> (Annotated () -> (PrettyState, PrettyWriter))
-> Annotated ()
-> PrettyWriter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\RWS PrettyOptions PrettyWriter PrettyState ()
next -> RWS PrettyOptions PrettyWriter PrettyState ()
-> PrettyOptions -> PrettyState -> (PrettyState, PrettyWriter)
forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS RWS PrettyOptions PrettyWriter PrettyState ()
next PrettyOptions
opts ([Comment] -> Pos -> Anns -> PrettyState
defaultPrettyState [Comment]
cs Pos
priorEnd Anns
ans))
  (RWS PrettyOptions PrettyWriter PrettyState ()
 -> (PrettyState, PrettyWriter))
-> (Annotated () -> RWS PrettyOptions PrettyWriter PrettyState ())
-> Annotated ()
-> (PrettyState, PrettyWriter)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotated () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall a. Annotated a -> Pretty a
prettyInterpret (Annotated () -> Anns) -> Annotated () -> Anns
forall a b. (a -> b) -> a -> b
$ Annotated ()
action
  where
    mkAnns :: PrettyWriter -> Anns
    mkAnns :: PrettyWriter -> Anns
mkAnns = Endo Anns -> Anns
forall a. Monoid a => Endo a -> a
f (Endo Anns -> Anns)
-> (PrettyWriter -> Endo Anns) -> PrettyWriter -> Anns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyWriter -> 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 PrettyOptions = PrettyOptions
       {
         -- | Current `SrcSpan, part of current AnnKey`
         PrettyOptions -> SrcSpan
curSrcSpan  :: !GHC.SrcSpan

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

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

       -- | Current higher level context. e.g. whether a Match is part of a
       -- LambdaExpr or a FunBind
       , PrettyOptions -> AstContextSet
prContext :: !AstContextSet
       } deriving Int -> PrettyOptions -> ShowS
[PrettyOptions] -> ShowS
PrettyOptions -> String
(Int -> PrettyOptions -> ShowS)
-> (PrettyOptions -> String)
-> ([PrettyOptions] -> ShowS)
-> Show PrettyOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrettyOptions] -> ShowS
$cshowList :: [PrettyOptions] -> ShowS
show :: PrettyOptions -> String
$cshow :: PrettyOptions -> String
showsPrec :: Int -> PrettyOptions -> ShowS
$cshowsPrec :: Int -> PrettyOptions -> ShowS
Show

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

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

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

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

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

       , PrettyState -> Bool
apNoPrecedingSpace :: Bool

       }

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

instance Monoid PrettyWriter where
  mempty :: PrettyWriter
mempty = Endo Anns
-> [(KeywordId, DeltaPos)]
-> Maybe [SrcSpan]
-> First AnnKey
-> AstContextSet
-> PrettyWriter
PrettyWriter 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 AstContextSet
forall a. Monoid a => a
mempty
  (PrettyWriter Endo Anns
a [(KeywordId, DeltaPos)]
b Maybe [SrcSpan]
e First AnnKey
g AstContextSet
i) mappend :: PrettyWriter -> PrettyWriter -> PrettyWriter
`mappend` (PrettyWriter Endo Anns
c [(KeywordId, DeltaPos)]
d Maybe [SrcSpan]
f First AnnKey
h AstContextSet
j)
    = Endo Anns
-> [(KeywordId, DeltaPos)]
-> Maybe [SrcSpan]
-> First AnnKey
-> AstContextSet
-> PrettyWriter
PrettyWriter (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) (AstContextSet
i AstContextSet -> AstContextSet -> AstContextSet
forall a. Semigroup a => a -> a -> a
<> AstContextSet
j)

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

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

defaultPrettyState :: [Comment] -> Pos -> Anns -> PrettyState
defaultPrettyState :: [Comment] -> Pos -> Anns -> PrettyState
defaultPrettyState [Comment]
injectedComments Pos
priorEnd Anns
_ans =
    PrettyState :: Pos -> [Comment] -> Bool -> LayoutStartCol -> Bool -> PrettyState
PrettyState
      { priorEndPosition :: Pos
priorEndPosition    = Pos
priorEnd
      , apComments :: [Comment]
apComments = [Comment]
cs [Comment] -> [Comment] -> [Comment]
forall a. [a] -> [a] -> [a]
++ [Comment]
injectedComments
      , apLayoutStart :: LayoutStartCol
apLayoutStart = LayoutStartCol
1
      , apMarkLayout :: Bool
apMarkLayout = Bool
False
      , apNoPrecedingSpace :: Bool
apNoPrecedingSpace = Bool
False
      }
  where
    cs :: [Comment]
    cs :: [Comment]
cs = []

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

prettyInterpret :: Annotated a -> Pretty a
prettyInterpret :: Annotated a -> Pretty a
prettyInterpret = (AnnotationF (Pretty a) -> Pretty a) -> Annotated a -> Pretty 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 (Pretty a) -> Pretty a
forall a. AnnotationF (Pretty a) -> Pretty a
go
  where
    go :: AnnotationF (Pretty a) -> Pretty a
    go :: AnnotationF (Pretty a) -> Pretty a
go (MarkPrim AnnKeywordId
kwid Maybe String
_ Pretty a
next)           = KeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotation (AnnKeywordId -> KeywordId
G AnnKeywordId
kwid) RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
    go (MarkPPOptional AnnKeywordId
_kwid Maybe String
_ Pretty a
next)    = Pretty a
next
    go (MarkEOF Pretty a
next)                   = RWS PrettyOptions PrettyWriter PrettyState ()
addEofAnnotation RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
    go (MarkExternal SrcSpan
_ss AnnKeywordId
akwid String
_ Pretty a
next)  = KeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotation (AnnKeywordId -> KeywordId
G AnnKeywordId
akwid) RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
#if __GLASGOW_HASKELL__ >= 800
    go (MarkInstead AnnKeywordId
akwid KeywordId
kwid Pretty a
next)    = AnnKeywordId
-> KeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotationsInstead AnnKeywordId
akwid KeywordId
kwid RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
#endif
    go (MarkOutside AnnKeywordId
akwid KeywordId
kwid Pretty a
next)    = AnnKeywordId
-> KeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotationsOutside AnnKeywordId
akwid KeywordId
kwid RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
    -- go (MarkOutside akwid kwid next)    = addPrettyAnnotation kwid >> next
    go (MarkInside AnnKeywordId
akwid Pretty a
next)          = AnnKeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotationsInside AnnKeywordId
akwid RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
    go (MarkMany AnnKeywordId
akwid Pretty a
next)            = KeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotation (AnnKeywordId -> KeywordId
G AnnKeywordId
akwid) RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
    go (MarkManyOptional AnnKeywordId
_akwid Pretty a
next)   = Pretty a
next
    go (MarkOffsetPrim AnnKeywordId
akwid Int
n Maybe String
_ Pretty a
next)  = AnnKeywordId
-> Int -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotationLs AnnKeywordId
akwid Int
n RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
    go (MarkOffsetPrimOptional AnnKeywordId
_akwid Int
_n Maybe String
_ Pretty a
next)  = Pretty a
next
    go (WithAST a
lss Annotated b
prog Pretty a
next)          = a -> Pretty b -> Pretty b
forall a b.
(Data a, Data (SrcSpanLess a), HasSrcSpan a) =>
a -> Pretty b -> Pretty b
withAST a
lss (Annotated b -> Pretty b
forall a. Annotated a -> Pretty a
prettyInterpret Annotated b
prog) Pretty b -> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
    go (CountAnns AnnKeywordId
kwid Int -> Pretty a
next)            = AnnKeywordId -> Pretty Int
countAnnsPretty AnnKeywordId
kwid Pretty Int -> (Int -> Pretty a) -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Pretty a
next
    go (WithSortKey             [(SrcSpan, Annotated ())]
kws Pretty a
next) = [(SrcSpan, Annotated ())]
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall b.
[(SrcSpan, Annotated b)]
-> RWS PrettyOptions PrettyWriter PrettyState ()
withSortKey             [(SrcSpan, Annotated ())]
kws RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
    go (WithSortKeyContexts ListContexts
ctx [(SrcSpan, Annotated ())]
kws Pretty a
next) = ListContexts
-> [(SrcSpan, Annotated ())]
-> RWS PrettyOptions PrettyWriter PrettyState ()
withSortKeyContexts ListContexts
ctx [(SrcSpan, Annotated ())]
kws RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
    go (SetLayoutFlag Rigidity
r Annotated ()
action Pretty a
next)    = do
      Rigidity
rigidity <- (PrettyOptions -> Rigidity)
-> RWST PrettyOptions PrettyWriter PrettyState Identity Rigidity
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrettyOptions -> Rigidity
drRigidity
      (if Rigidity
r Rigidity -> Rigidity -> Bool
forall a. Ord a => a -> a -> Bool
<= Rigidity
rigidity then RWS PrettyOptions PrettyWriter PrettyState ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
setLayoutFlag else RWS PrettyOptions PrettyWriter PrettyState ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall a. a -> a
id) (Annotated () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall a. Annotated a -> Pretty a
prettyInterpret Annotated ()
action)
      Pretty a
next
    go (StoreOriginalSrcSpan SrcSpan
l AnnKey
key AnnKey -> Pretty a
next) = SrcSpan -> AnnKey -> Pretty AnnKey
storeOriginalSrcSpanPretty SrcSpan
l AnnKey
key Pretty AnnKey -> (AnnKey -> Pretty a) -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AnnKey -> Pretty a
next
    go (MarkAnnBeforeAnn AnnKeywordId
_ann1 AnnKeywordId
_ann2 Pretty a
next) = Pretty a
next
    go (GetSrcSpanForKw SrcSpan
ss AnnKeywordId
kw SrcSpan -> Pretty a
next)      = SrcSpan -> AnnKeywordId -> Pretty SrcSpan
getSrcSpanForKw SrcSpan
ss AnnKeywordId
kw Pretty SrcSpan -> (SrcSpan -> Pretty a) -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SrcSpan -> Pretty a
next
#if __GLASGOW_HASKELL__ <= 710
    go (StoreString s ss next)           = storeString s ss >> next
#endif
    go (AnnotationsToComments [AnnKeywordId]
kws Pretty a
next)       = [AnnKeywordId] -> RWS PrettyOptions PrettyWriter PrettyState ()
annotationsToCommentsPretty [AnnKeywordId]
kws RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
#if __GLASGOW_HASKELL__ <= 710
    go (AnnotationsToCommentsBF bf kws next)  = annotationsToCommentsBFPretty bf kws >> next
    go (FinalizeBF l next)                    = finalizeBFPretty l >> next
#endif

    go (SetContextLevel Set AstContext
ctxt Int
lvl Annotated ()
action Pretty a
next)  = Set AstContext
-> Int
-> RWS PrettyOptions PrettyWriter PrettyState ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
setContextPretty Set AstContext
ctxt Int
lvl (Annotated () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall a. Annotated a -> Pretty a
prettyInterpret Annotated ()
action) RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
    go (UnsetContext    AstContext
ctxt     Annotated ()
action Pretty a
next)  = AstContext
-> RWS PrettyOptions PrettyWriter PrettyState ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
unsetContextPretty AstContext
ctxt (Annotated () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall a. Annotated a -> Pretty a
prettyInterpret Annotated ()
action) RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
    go (IfInContext Set AstContext
ctxt Annotated ()
ia Annotated ()
ea Pretty a
next)           = Set AstContext
-> Annotated ()
-> Annotated ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
ifInContextPretty Set AstContext
ctxt Annotated ()
ia Annotated ()
ea RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next
    go (TellContext Set AstContext
c Pretty a
next)                    = Set AstContext -> RWS PrettyOptions PrettyWriter PrettyState ()
tellContext Set AstContext
c RWS PrettyOptions PrettyWriter PrettyState ()
-> Pretty a -> Pretty a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pretty a
next

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

addEofAnnotation :: Pretty ()
addEofAnnotation :: RWS PrettyOptions PrettyWriter PrettyState ()
addEofAnnotation = do
  (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (AnnKeywordId -> KeywordId
G AnnKeywordId
GHC.AnnEofPos, Pos -> DeltaPos
DP (Int
1,Int
0))

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

addPrettyAnnotation :: KeywordId -> Pretty ()
addPrettyAnnotation :: KeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotation KeywordId
ann = do
  Bool
noPrec <- (PrettyState -> Bool)
-> RWST PrettyOptions PrettyWriter PrettyState Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrettyState -> Bool
apNoPrecedingSpace
  AstContextSet
ctx <- (PrettyOptions -> AstContextSet)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity AstContextSet
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrettyOptions -> AstContextSet
prContext
  AstContextSet
_ <- String
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity AstContextSet
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity AstContextSet
forall c. String -> c -> c
debugP (String
"Pretty.addPrettyAnnotation:=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (KeywordId, Bool, AstContextSet) -> String
forall a. Outputable a => a -> String
showGhc (KeywordId
ann,Bool
noPrec,AstContextSet
ctx)) (RWST PrettyOptions PrettyWriter PrettyState Identity AstContextSet
 -> RWST
      PrettyOptions PrettyWriter PrettyState Identity AstContextSet)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity AstContextSet
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity AstContextSet
forall a b. (a -> b) -> a -> b
$ (PrettyOptions -> AstContextSet)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity AstContextSet
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrettyOptions -> AstContextSet
prContext
  let
    dp :: RWS PrettyOptions PrettyWriter PrettyState ()
dp = case KeywordId
ann of
           (G AnnKeywordId
GHC.AnnAs)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnAt)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
0))
#if __GLASGOW_HASKELL__ >= 806
           (G AnnKeywordId
GHC.AnnAnyclass)     -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
#endif
           (G AnnKeywordId
GHC.AnnBackquote)    -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnBang)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnBy)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnCase )        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnClass)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnClose)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnCloseC)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
0))
#if __GLASGOW_HASKELL__ >= 802
           (G AnnKeywordId
GHC.AnnCloseQ)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
#endif
           (G AnnKeywordId
GHC.AnnDcolon)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnDeriving)     -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnDo)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnDotdot)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnElse)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
1,Int
2))
           (G AnnKeywordId
GHC.AnnEqual)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnExport)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnFamily)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnForall)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnGroup)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnHiding)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnIf)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnImport)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnIn)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
1,Int
0))
           (G AnnKeywordId
GHC.AnnInstance)     -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnLam)          -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnLet)          -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnMinus)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1)) -- need to separate from preceding operator
           (G AnnKeywordId
GHC.AnnModule)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnNewtype)      -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnOf)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnOpenC)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
0))
           (G AnnKeywordId
GHC.AnnOpenPE)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnOpenPTE)      -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnQualified)    -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnRarrow)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnRole)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnSafe)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
#if __GLASGOW_HASKELL__ >= 806
           (G AnnKeywordId
GHC.AnnStock)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
#endif
           (G AnnKeywordId
GHC.AnnSimpleQuote)  -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnThIdSplice)   -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnThIdTySplice) -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnThTyQuote)    -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnThen)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
1,Int
2))
           (G AnnKeywordId
GHC.AnnTilde)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnType)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnUsing)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnVal)          -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnValStr)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnVbar)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
#if __GLASGOW_HASKELL__ >= 806
           (G AnnKeywordId
GHC.AnnVia)          -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
#endif
           (G AnnKeywordId
GHC.AnnWhere)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
1,Int
2))
#if __GLASGOW_HASKELL__ >= 800
           KeywordId
AnnTypeApp              -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
#endif
           KeywordId
_ ->                (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
0))
  RWS PrettyOptions PrettyWriter PrettyState ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall a. Pretty a -> Pretty a -> Pretty a
fromNoPrecedingSpace ((KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
0))) RWS PrettyOptions PrettyWriter PrettyState ()
dp

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

#if __GLASGOW_HASKELL__ >= 800
addPrettyAnnotationsInstead :: GHC.AnnKeywordId -> KeywordId -> Pretty ()
addPrettyAnnotationsInstead :: AnnKeywordId
-> KeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotationsInstead AnnKeywordId
_akwid KeywordId
AnnSemiSep = () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addPrettyAnnotationsInstead AnnKeywordId
_akwid KeywordId
kwid = KeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotation KeywordId
kwid
#endif

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

addPrettyAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Pretty ()
addPrettyAnnotationsOutside :: AnnKeywordId
-> KeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotationsOutside AnnKeywordId
_akwid KeywordId
AnnSemiSep = () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addPrettyAnnotationsOutside AnnKeywordId
_akwid KeywordId
kwid = KeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotation KeywordId
kwid

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

addPrettyAnnotationsInside :: GHC.AnnKeywordId -> Pretty ()
addPrettyAnnotationsInside :: AnnKeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotationsInside AnnKeywordId
_ann = () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

addPrettyAnnotationLs :: GHC.AnnKeywordId -> Int -> Pretty ()
addPrettyAnnotationLs :: AnnKeywordId
-> Int -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotationLs AnnKeywordId
ann Int
_off = KeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotation (AnnKeywordId -> KeywordId
G AnnKeywordId
ann)

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

#if __GLASGOW_HASKELL__ <= 710
getUnallocatedComments :: Pretty [Comment]
getUnallocatedComments = gets apComments

putUnallocatedComments :: [Comment] -> Pretty ()
putUnallocatedComments cs = modify (\s -> s { apComments = cs } )
#endif

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

#if __GLASGOW_HASKELL__ > 806
withSrcSpanPretty :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b
withSrcSpanPretty :: a -> Pretty b -> Pretty b
withSrcSpanPretty (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
GHC.dL->GHC.L SrcSpan
l SrcSpanLess a
a) Pretty b
action = do
#else
withSrcSpanPretty :: Data a => GHC.Located a -> Pretty b -> Pretty b
withSrcSpanPretty (GHC.L l a) action = do
#endif
  -- peek into the current state of the output, to extract the layout context
  -- flags passed up from subelements of the AST.
  (()
_,PrettyWriter
w) <- RWS PrettyOptions PrettyWriter PrettyState ()
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity ((), PrettyWriter)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (() -> RWS PrettyOptions PrettyWriter PrettyState ()
forall (m :: * -> *) a. Monad m => a -> m a
return () :: Pretty ())

  ()
_ <- String
-> RWS PrettyOptions PrettyWriter PrettyState ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall c. String -> c -> c
debugP (String
"withSrcSpanPretty: prLayoutContext w=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ AstContextSet -> String
forall a. Show a => a -> String
show (PrettyWriter -> AstContextSet
prLayoutContext PrettyWriter
w) ) (() -> RWS PrettyOptions PrettyWriter PrettyState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

  (PrettyOptions -> PrettyOptions) -> Pretty b -> Pretty b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\PrettyOptions
s -> PrettyOptions
s { curSrcSpan :: SrcSpan
curSrcSpan = SrcSpan
l
                 , annConName :: AnnConName
annConName = SrcSpanLess a -> AnnConName
forall a. Data a => a -> AnnConName
annGetConstr SrcSpanLess a
a
                 -- , prContext  = pushAcs (prContext s)
                 , prContext :: AstContextSet
prContext  = (AstContextSet -> AstContextSet
forall a. ACS' a -> ACS' a
pushAcs (PrettyOptions -> AstContextSet
prContext PrettyOptions
s)) AstContextSet -> AstContextSet -> AstContextSet
forall a. Semigroup a => a -> a -> a
<> (PrettyWriter -> AstContextSet
prLayoutContext PrettyWriter
w)
                 })
        Pretty b
action

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

-- | Enter a new AST element. Maintain SrcSpan stack
#if __GLASGOW_HASKELL__ > 806
withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)
        => a
        -> Pretty b -> Pretty b
withAST :: a -> Pretty b -> Pretty 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
t) Pretty b
action = do
#else
withAST :: Data a
        => GHC.Located a
        -> Pretty b -> Pretty b
withAST lss@(GHC.L ss t) action = do
#endif
  () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall (m :: * -> *) a. Monad m => a -> m a
return () RWS PrettyOptions PrettyWriter PrettyState ()
-> String -> RWS PrettyOptions PrettyWriter PrettyState ()
forall c. c -> String -> c
`debug` (String
"Pretty.withAST:enter 1:(ss)=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (SrcSpan, String) -> String
forall a. Outputable a => a -> String
showGhc (SrcSpan
ss,Constr -> String
showConstr (SrcSpanLess a -> Constr
forall a. Data a => a -> Constr
toConstr SrcSpanLess a
t)))
  -- Calculate offset required to get to the start of the SrcSPan
  -- off <- gets apLayoutStart
  a -> Pretty b -> Pretty b
forall a b.
(Data (SrcSpanLess a), HasSrcSpan a) =>
a -> Pretty b -> Pretty b
withSrcSpanPretty a
lss (Pretty b -> Pretty b) -> Pretty b -> Pretty b
forall a b. (a -> b) -> a -> b
$ do
    () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall (m :: * -> *) a. Monad m => a -> m a
return () RWS PrettyOptions PrettyWriter PrettyState ()
-> String -> RWS PrettyOptions PrettyWriter PrettyState ()
forall c. c -> String -> c
`debug` (String
"Pretty.withAST:enter:(ss)=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (SrcSpan, String) -> String
forall a. Outputable a => a -> String
showGhc (SrcSpan
ss,Constr -> String
showConstr (SrcSpanLess a -> Constr
forall a. Data a => a -> Constr
toConstr SrcSpanLess a
t)))

    let maskWriter :: PrettyWriter -> PrettyWriter
maskWriter PrettyWriter
s = PrettyWriter
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
                         -- , prLayoutContext = pushAcs (prLayoutContext s)
                         }

#if __GLASGOW_HASKELL__ <= 710
    let spanStart = ss2pos ss
    cs <- do
      if GHC.isGoodSrcSpan ss
        then
          commentAllocation (priorComment spanStart) return
        else
          return []
#else
    let cs :: [a]
cs = []
#endif

    -- ctx <- debugP ("Pretty.withAST:cs:(ss,cs,uncs)=" ++ showGhc (ss,cs,uncs)) $ asks prContext
    AstContextSet
ctx <- (PrettyOptions -> AstContextSet)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity AstContextSet
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrettyOptions -> AstContextSet
prContext

    Bool
noPrec <- (PrettyState -> Bool)
-> RWST PrettyOptions PrettyWriter PrettyState Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrettyState -> Bool
apNoPrecedingSpace
    DeltaPos
edp <- String -> Pretty DeltaPos -> Pretty DeltaPos
forall c. String -> c -> c
debugP (String
"Pretty.withAST:enter:(ss,constr,noPrec,ctx)=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (SrcSpan, String, Bool, AstContextSet) -> String
forall a. Outputable a => a -> String
showGhc (SrcSpan
ss,Constr -> String
showConstr (SrcSpanLess a -> Constr
forall a. Data a => a -> Constr
toConstr SrcSpanLess a
t),Bool
noPrec,AstContextSet
ctx)) (Pretty DeltaPos -> Pretty DeltaPos)
-> Pretty DeltaPos -> Pretty DeltaPos
forall a b. (a -> b) -> a -> b
$ AstContextSet -> SrcSpanLess a -> Pretty DeltaPos
forall a. Typeable a => AstContextSet -> a -> Pretty DeltaPos
entryDpFor AstContextSet
ctx SrcSpanLess a
t
    -- edp <- entryDpFor ctx t

    let ctx1 :: AstContextSet
ctx1 = String -> AstContextSet -> AstContextSet
forall c. String -> c -> c
debugP (String
"Pretty.withAST:edp:(ss,constr,edp)=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (SrcSpan, String, DeltaPos) -> String
forall a. Outputable a => a -> String
showGhc (SrcSpan
ss,Constr -> String
showConstr (SrcSpanLess a -> Constr
forall a. Data a => a -> Constr
toConstr SrcSpanLess a
t),DeltaPos
edp)) AstContextSet
ctx
    (b
res, PrettyWriter
w) <- if Set AstContext -> AstContextSet -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs ([AstContext] -> Set AstContext
forall a. Ord a => [a] -> Set a
Set.fromList [AstContext
ListItem,AstContext
TopLevel]) AstContextSet
ctx1
      then
           -- debugP ("Pretty.withAST:setNoPrecedingSpace") $
             (PrettyWriter -> PrettyWriter)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (b, PrettyWriter)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (b, PrettyWriter)
forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor PrettyWriter -> PrettyWriter
maskWriter (Pretty b
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (b, PrettyWriter)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (Pretty b -> Pretty b
forall a. Pretty a -> Pretty a
setNoPrecedingSpace Pretty b
action))
      else
           -- debugP ("Pretty.withAST:setNoPrecedingSpace") $
            (PrettyWriter -> PrettyWriter)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (b, PrettyWriter)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (b, PrettyWriter)
forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor PrettyWriter -> PrettyWriter
maskWriter (Pretty b
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (b, PrettyWriter)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen Pretty b
action)

    let kds :: [(KeywordId, DeltaPos)]
kds = PrettyWriter -> [(KeywordId, DeltaPos)]
annKds PrettyWriter
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)]
forall a. [a]
cs
               , annFollowingComments :: [(Comment, DeltaPos)]
annFollowingComments = [] -- only used in Transform and Print
               , annsDP :: [(KeywordId, DeltaPos)]
annsDP               = [(KeywordId, DeltaPos)]
kds
               , annSortKey :: Maybe [SrcSpan]
annSortKey           = PrettyWriter -> Maybe [SrcSpan]
sortKeys PrettyWriter
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
$ PrettyWriter -> First AnnKey
dwCapturedSpan PrettyWriter
w
               }

    Annotation -> RWS PrettyOptions PrettyWriter PrettyState ()
addAnnotationsPretty Annotation
an
     RWS PrettyOptions PrettyWriter PrettyState ()
-> String -> RWS PrettyOptions PrettyWriter PrettyState ()
forall c. c -> String -> c
`debug` (String
"Pretty.withAST:(annkey,an)=" String -> ShowS
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 -> Pretty b
forall (m :: * -> *) a. Monad m => a -> m a
return b
res

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

entryDpFor :: Typeable a => AstContextSet -> a -> Pretty DeltaPos
entryDpFor :: AstContextSet -> a -> Pretty DeltaPos
entryDpFor AstContextSet
ctx a
a = (a -> Pretty DeltaPos
forall a. a -> Pretty DeltaPos
def (a -> Pretty DeltaPos)
-> (GRHS RdrName (LHsExpr RdrName) -> Pretty DeltaPos)
-> a
-> Pretty DeltaPos
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` GRHS RdrName (LHsExpr RdrName) -> Pretty DeltaPos
grhs) a
a
  where
    lineDefault :: Int
lineDefault = if Set AstContext -> AstContextSet -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
AdvanceLine) AstContextSet
ctx
                    then Int
1 else Int
0
    noAdvanceLine :: Bool
noAdvanceLine = Set AstContext -> AstContextSet -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
NoAdvanceLine) AstContextSet
ctx Bool -> Bool -> Bool
&&
                    Set AstContext -> AstContextSet -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
ListStart) AstContextSet
ctx

    def :: a -> Pretty DeltaPos
    def :: a -> Pretty DeltaPos
def a
_ =
      String -> Pretty DeltaPos -> Pretty DeltaPos
forall c. String -> c -> c
debugP (String
"entryDpFor:(topLevel,listStart,inList,noAdvanceLine,ctx)=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Bool, Bool, Bool, Bool, AstContextSet) -> String
forall a. Show a => a -> String
show (Bool
topLevel,Bool
listStart,Bool
inList,Bool
noAdvanceLine,AstContextSet
ctx)) (Pretty DeltaPos -> Pretty DeltaPos)
-> Pretty DeltaPos -> Pretty DeltaPos
forall a b. (a -> b) -> a -> b
$
        if Bool
noAdvanceLine
          then DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (Int
0,Int
1))
          else
            if Bool
listStart
              then DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (Int
1,Int
2))
              else if Bool
inList
                then if Bool
topLevel then DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (Int
2,Int
0)) else DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (Int
1,Int
0))
                else if Bool
topLevel then DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (Int
2,Int
0)) else DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (Int
lineDefault,Int
0))

    topLevel :: Bool
topLevel = Set AstContext -> AstContextSet -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
TopLevel) AstContextSet
ctx
    listStart :: Bool
listStart = Set AstContext -> AstContextSet -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
ListStart) AstContextSet
ctx
              Bool -> Bool -> Bool
&& Bool -> Bool
not (Set AstContext -> AstContextSet -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
TopLevel) AstContextSet
ctx)
    inList :: Bool
inList = Set AstContext -> AstContextSet -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
ListItem) AstContextSet
ctx
    inLambda :: Bool
inLambda = Set AstContext -> AstContextSet -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
LambdaExpr) AstContextSet
ctx

    grhs :: GHC.GRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Pretty DeltaPos
    grhs :: GRHS RdrName (LHsExpr RdrName) -> Pretty DeltaPos
grhs GRHS RdrName (LHsExpr RdrName)
_ = do
      if Bool
inLambda
        then DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (Int
0,Int
1))
        else DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (Int
1,Int
2))

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

fromNoPrecedingSpace :: Pretty a -> Pretty a -> Pretty a
fromNoPrecedingSpace :: Pretty a -> Pretty a -> Pretty a
fromNoPrecedingSpace Pretty a
def Pretty a
lay = do
  PrettyState{Bool
apNoPrecedingSpace :: Bool
apNoPrecedingSpace :: PrettyState -> Bool
apNoPrecedingSpace} <- RWST PrettyOptions PrettyWriter PrettyState Identity PrettyState
forall s (m :: * -> *). MonadState s m => m s
get
  -- ctx <- asks prContext
  if Bool
apNoPrecedingSpace
    then do
      (PrettyState -> PrettyState)
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PrettyState
s -> PrettyState
s { apNoPrecedingSpace :: Bool
apNoPrecedingSpace = Bool
False
                      })
      String -> Pretty a -> Pretty a
forall c. String -> c -> c
debugP (String
"fromNoPrecedingSpace:def") Pretty a
def
      -- def
    else
      -- lay
      String -> Pretty a -> Pretty a
forall c. String -> c -> c
debugP (String
"fromNoPrecedingSpace:lay") Pretty a
lay


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

-- |Add some annotation to the currently active SrcSpan
addAnnotationsPretty :: Annotation -> Pretty ()
addAnnotationsPretty :: Annotation -> RWS PrettyOptions PrettyWriter PrettyState ()
addAnnotationsPretty Annotation
ann = do
    PrettyOptions
l <- RWST PrettyOptions PrettyWriter PrettyState Identity PrettyOptions
forall r (m :: * -> *). MonadReader r m => m r
ask
    () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall (m :: * -> *) a. Monad m => a -> m a
return () RWS PrettyOptions PrettyWriter PrettyState ()
-> String -> RWS PrettyOptions PrettyWriter PrettyState ()
forall c. c -> String -> c
`debug` (String
"addAnnotationsPretty:=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (SrcSpan, AstContextSet) -> String
forall a. Outputable a => a -> String
showGhc (PrettyOptions -> SrcSpan
curSrcSpan PrettyOptions
l,PrettyOptions -> AstContextSet
prContext PrettyOptions
l))
    (AnnKey, Annotation)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellFinalAnn (PrettyOptions -> AnnKey
getAnnKey PrettyOptions
l,Annotation
ann)

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

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

countAnnsPretty :: GHC.AnnKeywordId -> Pretty Int
countAnnsPretty :: AnnKeywordId -> Pretty Int
countAnnsPretty AnnKeywordId
_ann = Int -> Pretty Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0

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

withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Pretty ()
withSortKey :: [(SrcSpan, Annotated b)]
-> RWS PrettyOptions PrettyWriter PrettyState ()
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 PrettyOptions PrettyWriter PrettyState ()
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 PrettyOptions PrettyWriter PrettyState Identity b)
-> [(SrcSpan, Annotated b)]
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Annotated b
-> RWST PrettyOptions PrettyWriter PrettyState Identity b
forall a. Annotated a -> Pretty a
prettyInterpret (Annotated b
 -> RWST PrettyOptions PrettyWriter PrettyState Identity b)
-> ((SrcSpan, Annotated b) -> Annotated b)
-> (SrcSpan, Annotated b)
-> RWST PrettyOptions PrettyWriter PrettyState 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 ())] -> Pretty ()
withSortKeyContexts :: ListContexts
-> [(SrcSpan, Annotated ())]
-> RWS PrettyOptions PrettyWriter PrettyState ()
withSortKeyContexts ListContexts
ctxts [(SrcSpan, Annotated ())]
kws =
  let 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
  in do
    [SrcSpan] -> RWS PrettyOptions PrettyWriter PrettyState ()
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 PrettyOptions PrettyWriter PrettyState ())
-> ListContexts
-> [(SrcSpan, Annotated ())]
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall (m :: * -> *).
Monad m =>
(Annotated () -> m ())
-> ListContexts -> [(SrcSpan, Annotated ())] -> m ()
withSortKeyContextsHelper Annotated () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall a. Annotated a -> Pretty a
prettyInterpret ListContexts
ctxts [(SrcSpan, Annotated ())]
order

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

storeOriginalSrcSpanPretty :: GHC.SrcSpan -> AnnKey -> Pretty AnnKey
storeOriginalSrcSpanPretty :: SrcSpan -> AnnKey -> Pretty AnnKey
storeOriginalSrcSpanPretty SrcSpan
_s AnnKey
key = do
  AnnKey -> RWS PrettyOptions PrettyWriter PrettyState ()
tellCapturedSpan AnnKey
key
  AnnKey -> Pretty AnnKey
forall (m :: * -> *) a. Monad m => a -> m a
return AnnKey
key

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

getSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> Pretty GHC.SrcSpan
getSrcSpanForKw :: SrcSpan -> AnnKeywordId -> Pretty SrcSpan
getSrcSpanForKw SrcSpan
ss AnnKeywordId
_kw = SrcSpan -> Pretty SrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return SrcSpan
ss

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

#if __GLASGOW_HASKELL__ <= 710
storeString :: String -> GHC.SrcSpan -> Pretty ()
storeString s _ss = addPrettyAnnotation (AnnString s)
#endif

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

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

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

setNoPrecedingSpace :: Pretty a -> Pretty a
setNoPrecedingSpace :: Pretty a -> Pretty a
setNoPrecedingSpace Pretty a
action = do
  Bool
oldVal <- (PrettyState -> Bool)
-> RWST PrettyOptions PrettyWriter PrettyState Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrettyState -> Bool
apNoPrecedingSpace
  (PrettyState -> PrettyState)
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PrettyState
s -> PrettyState
s { apNoPrecedingSpace :: Bool
apNoPrecedingSpace = Bool
True } )
  let reset :: RWS PrettyOptions PrettyWriter PrettyState ()
reset = (PrettyState -> PrettyState)
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PrettyState
s -> PrettyState
s { apNoPrecedingSpace :: Bool
apNoPrecedingSpace = Bool
oldVal })
  Pretty a
action Pretty a
-> RWS PrettyOptions PrettyWriter PrettyState () -> Pretty a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* RWS PrettyOptions PrettyWriter PrettyState ()
reset

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

setContextPretty :: Set.Set AstContext -> Int -> Pretty () -> Pretty ()
setContextPretty :: Set AstContext
-> Int
-> RWS PrettyOptions PrettyWriter PrettyState ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
setContextPretty Set AstContext
ctxt Int
lvl =
  (PrettyOptions -> PrettyOptions)
-> RWS PrettyOptions PrettyWriter PrettyState ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\PrettyOptions
s -> PrettyOptions
s { prContext :: AstContextSet
prContext = Set AstContext -> Int -> AstContextSet -> AstContextSet
forall a. Ord a => Set a -> Int -> ACS' a -> ACS' a
setAcsWithLevel Set AstContext
ctxt Int
lvl (PrettyOptions -> AstContextSet
prContext PrettyOptions
s) } )

unsetContextPretty :: AstContext -> Pretty () -> Pretty ()
unsetContextPretty :: AstContext
-> RWS PrettyOptions PrettyWriter PrettyState ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
unsetContextPretty AstContext
ctxt =
  (PrettyOptions -> PrettyOptions)
-> RWS PrettyOptions PrettyWriter PrettyState ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\PrettyOptions
s -> PrettyOptions
s { prContext :: AstContextSet
prContext = AstContext -> AstContextSet -> AstContextSet
forall a. Ord a => a -> ACS' a -> ACS' a
unsetAcs AstContext
ctxt (PrettyOptions -> AstContextSet
prContext PrettyOptions
s) } )


ifInContextPretty :: Set.Set AstContext -> Annotated () -> Annotated () -> Pretty ()
ifInContextPretty :: Set AstContext
-> Annotated ()
-> Annotated ()
-> RWS PrettyOptions PrettyWriter PrettyState ()
ifInContextPretty Set AstContext
ctxt Annotated ()
ifAction Annotated ()
elseAction = do
  AstContextSet
cur <- (PrettyOptions -> AstContextSet)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity AstContextSet
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrettyOptions -> AstContextSet
prContext
  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 PrettyOptions PrettyWriter PrettyState ()
forall a. Annotated a -> Pretty a
prettyInterpret Annotated ()
ifAction
    else Annotated () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall a. Annotated a -> Pretty a
prettyInterpret Annotated ()
elseAction

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

annotationsToCommentsPretty :: [GHC.AnnKeywordId] -> Pretty ()
annotationsToCommentsPretty :: [AnnKeywordId] -> RWS PrettyOptions PrettyWriter PrettyState ()
annotationsToCommentsPretty [AnnKeywordId]
_kws = () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

#if __GLASGOW_HASKELL__ <= 710
annotationsToCommentsBFPretty :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> Pretty ()
annotationsToCommentsBFPretty bf _kws = do
  -- cs <- gets apComments
  cs <- debugP ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) $ gets apComments
  -- return$ debugP ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) ()
  -- error ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf))
  let
    kws = makeBooleanFormulaAnns bf
    newComments = map (uncurry mkKWComment ) kws
  putUnallocatedComments (cs ++ newComments)


finalizeBFPretty :: GHC.SrcSpan -> Pretty ()
finalizeBFPretty _ss = do
  commentAllocation (const True) (mapM_ (uncurry addPrettyComment))
  return ()
#endif

-- ---------------------------------------------------------------------
#if __GLASGOW_HASKELL__ <= 710
-- |Split the ordered list of comments into ones that occur prior to
-- the give SrcSpan and the rest
priorComment :: Pos -> Comment -> Bool
priorComment start c = (ss2pos . commentIdentifier $ c) < 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 = partition
#endif

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

#if __GLASGOW_HASKELL__ <= 710
commentAllocation :: (Comment -> Bool)
                  -> ([(Comment, DeltaPos)] -> Pretty a)
                  -> Pretty a
commentAllocation p k = do
  cs <- getUnallocatedComments
  let (allocated,cs') = allocateComments p cs
  putUnallocatedComments cs'
  k =<< mapM makeDeltaComment (sortBy (comparing commentIdentifier) allocated)

makeDeltaComment :: Comment -> Pretty (Comment, DeltaPos)
makeDeltaComment c = do
  return (c, DP (0,1))

addPrettyComment :: Comment -> DeltaPos -> Pretty ()
addPrettyComment d p = do
  tellKd (AnnComment d, p)
#endif

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

-- Writer helpers

tellFinalAnn :: (AnnKey, Annotation) -> Pretty ()
tellFinalAnn :: (AnnKey, Annotation)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellFinalAnn (AnnKey
k, Annotation
v) =
  PrettyWriter -> RWS PrettyOptions PrettyWriter PrettyState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (PrettyWriter
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) })

tellCapturedSpan :: AnnKey -> Pretty ()
tellCapturedSpan :: AnnKey -> RWS PrettyOptions PrettyWriter PrettyState ()
tellCapturedSpan AnnKey
key = PrettyWriter -> RWS PrettyOptions PrettyWriter PrettyState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ( PrettyWriter
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) -> Pretty ()
tellKd :: (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId, DeltaPos)
kd = PrettyWriter -> RWS PrettyOptions PrettyWriter PrettyState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (PrettyWriter
forall a. Monoid a => a
mempty { annKds :: [(KeywordId, DeltaPos)]
annKds = [(KeywordId, DeltaPos)
kd] })

tellSortKey :: [GHC.SrcSpan] -> Pretty ()
tellSortKey :: [SrcSpan] -> RWS PrettyOptions PrettyWriter PrettyState ()
tellSortKey [SrcSpan]
xs = PrettyWriter -> RWS PrettyOptions PrettyWriter PrettyState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (PrettyWriter
forall a. Monoid a => a
mempty { sortKeys :: Maybe [SrcSpan]
sortKeys = [SrcSpan] -> Maybe [SrcSpan]
forall a. a -> Maybe a
Just [SrcSpan]
xs } )

tellContext :: Set.Set AstContext -> Pretty ()
tellContext :: Set AstContext -> RWS PrettyOptions PrettyWriter PrettyState ()
tellContext Set AstContext
lc = PrettyWriter -> RWS PrettyOptions PrettyWriter PrettyState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (PrettyWriter
forall a. Monoid a => a
mempty { prLayoutContext :: AstContextSet
prLayoutContext = Set AstContext -> Int -> AstContextSet -> AstContextSet
forall a. Ord a => Set a -> Int -> ACS' a -> ACS' a
setAcsWithLevel Set AstContext
lc Int
2 AstContextSet
forall a. Monoid a => a
mempty} )