{-# 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 cs :: [Comment]
cs ast :: Located a
ast ans :: 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 (0,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 opts :: PrettyOptions
opts cs :: [Comment]
cs action :: Annotated ()
action ans :: Anns
ans priorEnd :: 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
. (\next :: 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 a :: Endo Anns
a b :: [(KeywordId, DeltaPos)]
b e :: Maybe [SrcSpan]
e g :: First AnnKey
g i :: AstContextSet
i) mappend :: PrettyWriter -> PrettyWriter -> PrettyWriter
`mappend` (PrettyWriter c :: Endo Anns
c d :: [(KeywordId, DeltaPos)]
d f :: Maybe [SrcSpan]
f h :: First AnnKey
h j :: 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 ridigity :: Rigidity
ridigity =
  $WPrettyOptions :: 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 injectedComments :: [Comment]
injectedComments priorEnd :: Pos
priorEnd _ans :: Anns
_ans =
    $WPrettyState :: 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 = 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 kwid :: AnnKeywordId
kwid _ next :: 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 _kwid :: AnnKeywordId
_kwid _ next :: Pretty a
next)    = Pretty a
next
    go (MarkEOF next :: 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 _ss :: SrcSpan
_ss akwid :: AnnKeywordId
akwid _ next :: 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 akwid :: AnnKeywordId
akwid kwid :: KeywordId
kwid next :: 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 akwid :: AnnKeywordId
akwid kwid :: KeywordId
kwid next :: 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 akwid :: AnnKeywordId
akwid next :: 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 akwid :: AnnKeywordId
akwid next :: 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 _akwid :: AnnKeywordId
_akwid next :: Pretty a
next)   = Pretty a
next
    go (MarkOffsetPrim akwid :: AnnKeywordId
akwid n :: Int
n _ next :: 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 _akwid :: AnnKeywordId
_akwid _n :: Int
_n _ next :: Pretty a
next)  = Pretty a
next
    go (WithAST lss :: a
lss prog :: Annotated b
prog next :: 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 kwid :: AnnKeywordId
kwid next :: 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             kws :: [(SrcSpan, Annotated ())]
kws next :: 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 ctx :: ListContexts
ctx kws :: [(SrcSpan, Annotated ())]
kws next :: 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 r :: Rigidity
r action :: Annotated ()
action next :: 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 l :: SrcSpan
l key :: AnnKey
key next :: 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 _ann1 :: AnnKeywordId
_ann1 _ann2 :: AnnKeywordId
_ann2 next :: Pretty a
next) = Pretty a
next
    go (GetSrcSpanForKw ss :: SrcSpan
ss kw :: AnnKeywordId
kw next :: 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 kws :: [AnnKeywordId]
kws next :: 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 ctxt :: Set AstContext
ctxt lvl :: Int
lvl action :: Annotated ()
action next :: 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    ctxt :: AstContext
ctxt     action :: Annotated ()
action next :: 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 ctxt :: Set AstContext
ctxt ia :: Annotated ()
ia ea :: Annotated ()
ea next :: 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 c :: Set AstContext
c next :: 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 (1,0))

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

addPrettyAnnotation :: KeywordId -> Pretty ()
addPrettyAnnotation :: KeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotation ann :: 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 ("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 GHC.AnnAs)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnAt)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,0))
#if __GLASGOW_HASKELL__ >= 806
           (G GHC.AnnAnyclass)     -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
#endif
           (G GHC.AnnBackquote)    -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnBang)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnBy)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnCase )        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnClass)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnClose)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnCloseC)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,0))
#if __GLASGOW_HASKELL__ >= 802
           (G GHC.AnnCloseQ)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
#endif
           (G GHC.AnnDcolon)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnDeriving)     -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnDo)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnDotdot)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnElse)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (1,2))
           (G GHC.AnnEqual)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnExport)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnFamily)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnForall)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnGroup)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnHiding)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnIf)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnImport)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnIn)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (1,0))
           (G GHC.AnnInstance)     -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnLam)          -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnLet)          -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnMinus)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1)) -- need to separate from preceding operator
           (G GHC.AnnModule)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnNewtype)      -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnOf)           -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnOpenC)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,0))
           (G GHC.AnnOpenPE)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnOpenPTE)      -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnQualified)    -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnRarrow)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnRole)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnSafe)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
#if __GLASGOW_HASKELL__ >= 806
           (G GHC.AnnStock)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
#endif
           (G GHC.AnnSimpleQuote)  -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnThIdSplice)   -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnThIdTySplice) -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnThTyQuote)    -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnThen)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (1,2))
           (G GHC.AnnTilde)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnType)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnUsing)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnVal)          -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnValStr)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
           (G GHC.AnnVbar)         -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
#if __GLASGOW_HASKELL__ >= 806
           (G GHC.AnnVia)          -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
#endif
           (G GHC.AnnWhere)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (1,2))
#if __GLASGOW_HASKELL__ >= 800
           AnnTypeApp              -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,1))
#endif
           _ ->                (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (0,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 (0,0))) RWS PrettyOptions PrettyWriter PrettyState ()
dp

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

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

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

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

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

addPrettyAnnotationsInside :: GHC.AnnKeywordId -> Pretty ()
addPrettyAnnotationsInside :: AnnKeywordId -> RWS PrettyOptions PrettyWriter PrettyState ()
addPrettyAnnotationsInside _ann :: 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 ann :: AnnKeywordId
ann _off :: 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 a, 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 l :: SrcSpan
l a :: SrcSpanLess a
a) action :: 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.
  (_,w :: 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 ("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 (\s :: 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 ss :: SrcSpan
ss t :: SrcSpanLess a
t) action :: 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` ("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 a, 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` ("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 s :: 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 ("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 ("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
    (res :: b
res, w :: 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 = $WAnn :: 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` ("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 ctx :: AstContextSet
ctx a :: 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 1 else 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 _ =
      String -> Pretty DeltaPos -> Pretty DeltaPos
forall c. String -> c -> c
debugP ("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 (0,1))
          else
            if Bool
listStart
              then DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (1,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 (2,0)) else DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (1,0))
                else if Bool
topLevel then DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (2,0)) else DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (Int
lineDefault,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 _ = do
      if Bool
inLambda
        then DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (0,1))
        else DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (1,2))

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

fromNoPrecedingSpace :: Pretty a -> Pretty a -> Pretty a
fromNoPrecedingSpace :: Pretty a -> Pretty a -> Pretty a
fromNoPrecedingSpace def :: Pretty a
def lay :: 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 (\s :: PrettyState
s -> PrettyState
s { apNoPrecedingSpace :: Bool
apNoPrecedingSpace = Bool
False
                      })
      String -> Pretty a -> Pretty a
forall c. String -> c -> c
debugP ("fromNoPrecedingSpace:def") Pretty a
def
      -- def
    else
      -- lay
      String -> Pretty a -> Pretty a
forall c. String -> c -> c
debugP ("fromNoPrecedingSpace:lay") Pretty a
lay


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

-- |Add some annotation to the currently active SrcSpan
addAnnotationsPretty :: Annotation -> Pretty ()
addAnnotationsPretty :: Annotation -> RWS PrettyOptions PrettyWriter PrettyState ()
addAnnotationsPretty ann :: 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` ("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 _ann :: AnnKeywordId
_ann = Int -> Pretty Int
forall (m :: * -> *) a. Monad m => a -> m a
return 0

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

withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Pretty ()
withSortKey :: [(SrcSpan, Annotated b)]
-> RWS PrettyOptions PrettyWriter PrettyState ()
withSortKey kws :: [(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 ctxts :: ListContexts
ctxts kws :: [(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 _s :: SrcSpan
_s key :: 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 ss :: SrcSpan
ss _kw :: 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 action :: 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 (\s :: 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 (\s :: 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 action :: 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 (\s :: 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 (\s :: 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 ctxt :: Set AstContext
ctxt lvl :: 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 (\s :: 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 ctxt :: 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 (\s :: 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 ctxt :: Set AstContext
ctxt ifAction :: Annotated ()
ifAction elseAction :: 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 _kws :: [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 (k :: AnnKey
k, v :: 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 key :: 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 kd :: (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 xs :: [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 lc :: 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 2 AstContextSet
forall a. Monoid a => a
mempty} )