{-# 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 :: forall a.
Annotate a =>
[Comment]
-> Located a -> Map AnnKey Annotation -> Map AnnKey Annotation
addAnnotationsForPretty [Comment]
cs Located a
ast Map AnnKey Annotation
ans
  = PrettyOptions
-> [Comment]
-> Annotated ()
-> Map AnnKey Annotation
-> Pos
-> Map AnnKey Annotation
runPrettyWithComments PrettyOptions
opts [Comment]
cs (Located a -> Annotated ()
forall ast. Annotate ast => Located ast -> Annotated ()
annotate Located a
ast) Map AnnKey Annotation
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 ()
-> Map AnnKey Annotation
-> Pos
-> Map AnnKey Annotation
runPrettyWithComments PrettyOptions
opts [Comment]
cs Annotated ()
action Map AnnKey Annotation
ans Pos
priorEnd =
  PrettyWriter -> Map AnnKey Annotation
mkAnns (PrettyWriter -> Map AnnKey Annotation)
-> (Annotated () -> PrettyWriter)
-> Annotated ()
-> Map AnnKey Annotation
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 -> Map AnnKey Annotation -> PrettyState
defaultPrettyState [Comment]
cs Pos
priorEnd Map AnnKey Annotation
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 () -> Map AnnKey Annotation)
-> Annotated () -> Map AnnKey Annotation
forall a b. (a -> b) -> a -> b
$ Annotated ()
action
  where
    mkAnns :: PrettyWriter -> Anns
    mkAnns :: PrettyWriter -> Map AnnKey Annotation
mkAnns = Endo (Map AnnKey Annotation) -> Map AnnKey Annotation
forall a. Monoid a => Endo a -> a
f (Endo (Map AnnKey Annotation) -> Map AnnKey Annotation)
-> (PrettyWriter -> Endo (Map AnnKey Annotation))
-> PrettyWriter
-> Map AnnKey Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyWriter -> Endo (Map AnnKey Annotation)
dwAnns
    f :: Monoid a => Endo a -> a
    f :: forall a. Monoid a => 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 -> ACS' AstContext
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 (Map AnnKey Annotation)
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 [AnnSpan]
sortKeys        :: !(Maybe [AnnSpan])
       , PrettyWriter -> First AnnKey
dwCapturedSpan  :: !(First AnnKey)
       , PrettyWriter -> ACS' AstContext
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 (Map AnnKey Annotation)
-> [(KeywordId, DeltaPos)]
-> Maybe [AnnSpan]
-> First AnnKey
-> ACS' AstContext
-> PrettyWriter
PrettyWriter Endo (Map AnnKey Annotation)
forall a. Monoid a => a
mempty [(KeywordId, DeltaPos)]
forall a. Monoid a => a
mempty Maybe [AnnSpan]
forall a. Monoid a => a
mempty First AnnKey
forall a. Monoid a => a
mempty ACS' AstContext
forall a. Monoid a => a
mempty
  (PrettyWriter Endo (Map AnnKey Annotation)
a [(KeywordId, DeltaPos)]
b Maybe [AnnSpan]
e First AnnKey
g ACS' AstContext
i) mappend :: PrettyWriter -> PrettyWriter -> PrettyWriter
`mappend` (PrettyWriter Endo (Map AnnKey Annotation)
c [(KeywordId, DeltaPos)]
d Maybe [AnnSpan]
f First AnnKey
h ACS' AstContext
j)
    = Endo (Map AnnKey Annotation)
-> [(KeywordId, DeltaPos)]
-> Maybe [AnnSpan]
-> First AnnKey
-> ACS' AstContext
-> PrettyWriter
PrettyWriter (Endo (Map AnnKey Annotation)
a Endo (Map AnnKey Annotation)
-> Endo (Map AnnKey Annotation) -> Endo (Map AnnKey Annotation)
forall a. Semigroup a => a -> a -> a
<> Endo (Map AnnKey Annotation)
c) ([(KeywordId, DeltaPos)]
b [(KeywordId, DeltaPos)]
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. Semigroup a => a -> a -> a
<> [(KeywordId, DeltaPos)]
d) (Maybe [AnnSpan]
e Maybe [AnnSpan] -> Maybe [AnnSpan] -> Maybe [AnnSpan]
forall a. Semigroup a => a -> a -> a
<> Maybe [AnnSpan]
f) (First AnnKey
g First AnnKey -> First AnnKey -> First AnnKey
forall a. Semigroup a => a -> a -> a
<> First AnnKey
h) (ACS' AstContext
i ACS' AstContext -> ACS' AstContext -> ACS' AstContext
forall a. Semigroup a => a -> a -> a
<> ACS' AstContext
j)

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

prettyOptions :: Rigidity -> PrettyOptions
prettyOptions :: Rigidity -> PrettyOptions
prettyOptions Rigidity
ridigity =
  PrettyOptions :: SrcSpan
-> AnnConName -> Rigidity -> ACS' AstContext -> 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 :: ACS' AstContext
prContext  = ACS' AstContext
defaultACS
    }

defaultPrettyState :: [Comment] -> Pos -> Anns -> PrettyState
defaultPrettyState :: [Comment] -> Pos -> Map AnnKey Annotation -> PrettyState
defaultPrettyState [Comment]
injectedComments Pos
priorEnd Map AnnKey Annotation
_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 :: forall a. Annotated a -> Pretty a
prettyInterpret = (AnnotationF
   (RWST PrettyOptions PrettyWriter PrettyState Identity a)
 -> RWST PrettyOptions PrettyWriter PrettyState Identity a)
-> FreeT AnnotationF Identity a
-> RWST PrettyOptions PrettyWriter PrettyState Identity 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
  (RWST PrettyOptions PrettyWriter PrettyState Identity a)
-> RWST PrettyOptions PrettyWriter PrettyState Identity a
forall a. AnnotationF (Pretty a) -> Pretty a
go
  where
    go :: AnnotationF (Pretty a) -> Pretty a
    go :: forall a. 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 Located a
lss Annotated b
prog Pretty a
next)          = Located a -> Pretty b -> Pretty b
forall a b. Data a => Located a -> Pretty b -> Pretty b
withAST Located 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             [(AnnSpan, Annotated ())]
kws Pretty a
next) = [(AnnSpan, Annotated ())]
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall b.
[(AnnSpan, Annotated b)]
-> RWS PrettyOptions PrettyWriter PrettyState ()
withSortKey             [(AnnSpan, 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 [(AnnSpan, Annotated ())]
kws Pretty a
next) = ListContexts
-> [(AnnSpan, Annotated ())]
-> RWS PrettyOptions PrettyWriter PrettyState ()
withSortKeyContexts ListContexts
ctx [(AnnSpan, 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
#if __GLASGOW_HASKELL__ >= 900
  (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
AnnEofPos, Pos -> DeltaPos
DP (Int
1,Int
0))
#else
  tellKd (G GHC.AnnEofPos, DP (1,0))
#endif

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

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
  ACS' AstContext
ctx <- (PrettyOptions -> ACS' AstContext)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (ACS' AstContext)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrettyOptions -> ACS' AstContext
prContext
  ACS' AstContext
_ <- String
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (ACS' AstContext)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (ACS' AstContext)
forall c. String -> c -> c
debugP (String
"Pretty.addPrettyAnnotation:=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (KeywordId, Bool, ACS' AstContext) -> String
forall a. Outputable a => a -> String
showGhc (KeywordId
ann,Bool
noPrec,ACS' AstContext
ctx)) (RWST
   PrettyOptions PrettyWriter PrettyState Identity (ACS' AstContext)
 -> RWST
      PrettyOptions PrettyWriter PrettyState Identity (ACS' AstContext))
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (ACS' AstContext)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (ACS' AstContext)
forall a b. (a -> b) -> a -> b
$ (PrettyOptions -> ACS' AstContext)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (ACS' AstContext)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrettyOptions -> ACS' AstContext
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))
#if __GLASGOW_HASKELL__ >= 900
           (G AnnKeywordId
GHC.AnnDollar)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnDollarDollar) -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
#endif
           (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))
#if __GLASGOW_HASKELL__ >= 900
           -- (G GHC.AnnLolly)        -> tellKd (ann,DP (0,1))
           (G AnnKeywordId
GHC.AnnLollyU)       -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnPercentOne)   -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnPercent)      -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
#endif
           (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.AnnOpenP)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
           (G AnnKeywordId
GHC.AnnOpenS)        -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
#if __GLASGOW_HASKELL__ < 900
           (G GHC.AnnOpenPE)       -> tellKd (ann,DP (0,1))
           (G GHC.AnnOpenPTE)      -> tellKd (ann,DP (0,1))
#endif
           (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))
#if __GLASGOW_HASKELL__ > 710
           (G AnnKeywordId
GHC.AnnRarrowU)      -> (KeywordId, DeltaPos)
-> RWS PrettyOptions PrettyWriter PrettyState ()
tellKd (KeywordId
ann,Pos -> DeltaPos
DP (Int
0,Int
1))
#endif
           (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))
#if __GLASGOW_HASKELL__ < 900
           (G GHC.AnnThIdSplice)   -> tellKd (ann,DP (0,1))
           (G GHC.AnnThIdTySplice) -> tellKd (ann,DP (0,1))
#endif
           (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) && (__GLASGOW_HASKELL__ < 900)
withSrcSpanPretty :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b
withSrcSpanPretty (GHC.dL->GHC.L l a) action = do
#else
withSrcSpanPretty :: Data a => GHC.Located a -> Pretty b -> Pretty b
withSrcSpanPretty :: forall a b. Data a => Located a -> Pretty b -> Pretty b
withSrcSpanPretty (GHC.L SrcSpan
l a
a) Pretty b
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]
++ ACS' AstContext -> String
forall a. Show a => a -> String
show (PrettyWriter -> ACS' AstContext
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 = a -> AnnConName
forall a. Data a => a -> AnnConName
annGetConstr a
a
                 -- , prContext  = pushAcs (prContext s)
                 , prContext :: ACS' AstContext
prContext  = (ACS' AstContext -> ACS' AstContext
forall a. ACS' a -> ACS' a
pushAcs (PrettyOptions -> ACS' AstContext
prContext PrettyOptions
s)) ACS' AstContext -> ACS' AstContext -> ACS' AstContext
forall a. Semigroup a => a -> a -> a
<> (PrettyWriter -> ACS' AstContext
prLayoutContext PrettyWriter
w)
                 })
        Pretty b
action

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

-- | Enter a new AST element. Maintain SrcSpan stack
#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900)
withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)
        => a
        -> Pretty b -> Pretty b
withAST lss@(GHC.dL->GHC.L ss t) action = do
#else
withAST :: Data a
        => GHC.Located a
        -> Pretty b -> Pretty b
withAST :: forall a b. Data a => Located a -> Pretty b -> Pretty b
withAST lss :: Located a
lss@(GHC.L SrcSpan
ss a
t) Pretty b
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 (a -> Constr
forall a. Data a => a -> Constr
toConstr a
t)))
  -- Calculate offset required to get to the start of the SrcSPan
  -- off <- gets apLayoutStart
  Located a -> Pretty b -> Pretty b
forall a b. Data a => Located a -> Pretty b -> Pretty b
withSrcSpanPretty Located 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 (a -> Constr
forall a. Data a => a -> Constr
toConstr a
t)))

    let maskWriter :: PrettyWriter -> PrettyWriter
maskWriter PrettyWriter
s = PrettyWriter
s { annKds :: [(KeywordId, DeltaPos)]
annKds          = []
                         , sortKeys :: Maybe [AnnSpan]
sortKeys        = Maybe [AnnSpan]
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
    ACS' AstContext
ctx <- (PrettyOptions -> ACS' AstContext)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (ACS' AstContext)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrettyOptions -> ACS' AstContext
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, ACS' AstContext) -> String
forall a. Outputable a => a -> String
showGhc (SrcSpan
ss,Constr -> String
showConstr (a -> Constr
forall a. Data a => a -> Constr
toConstr a
t),Bool
noPrec,ACS' AstContext
ctx)) (Pretty DeltaPos -> Pretty DeltaPos)
-> Pretty DeltaPos -> Pretty DeltaPos
forall a b. (a -> b) -> a -> b
$ ACS' AstContext -> a -> Pretty DeltaPos
forall a. Typeable a => ACS' AstContext -> a -> Pretty DeltaPos
entryDpFor ACS' AstContext
ctx a
t
    -- edp <- entryDpFor ctx t

    let ctx1 :: ACS' AstContext
ctx1 = String -> ACS' AstContext -> ACS' AstContext
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 (a -> Constr
forall a. Data a => a -> Constr
toConstr a
t),DeltaPos
edp)) ACS' AstContext
ctx
    -- (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel]) ctx1
    (b
res, PrettyWriter
w) <- if Set AstContext -> ACS' AstContext -> 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,AstContext
InTypeApp]) ACS' AstContext
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 [AnnSpan]
-> 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 [AnnSpan]
annSortKey           = PrettyWriter -> Maybe [AnnSpan]
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 (Located a -> AnnKey
forall a. Data a => Located a -> AnnKey
mkAnnKey Located 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 :: forall a. Typeable a => ACS' AstContext -> a -> Pretty DeltaPos
entryDpFor ACS' AstContext
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 -> ACS' AstContext -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
AdvanceLine) ACS' AstContext
ctx
                    then Int
1 else Int
0
    noAdvanceLine :: Bool
noAdvanceLine = Set AstContext -> ACS' AstContext -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
NoAdvanceLine) ACS' AstContext
ctx Bool -> Bool -> Bool
&&
                    Set AstContext -> ACS' AstContext -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
ListStart) ACS' AstContext
ctx

    def :: a -> Pretty DeltaPos
    def :: forall a. 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, ACS' AstContext) -> String
forall a. Show a => a -> String
show (Bool
topLevel,Bool
listStart,Bool
inList,Bool
noAdvanceLine,ACS' AstContext
ctx)) (Pretty DeltaPos -> Pretty DeltaPos)
-> Pretty DeltaPos -> Pretty DeltaPos
forall a b. (a -> b) -> a -> b
$
        if Bool
noAdvanceLine
          then (if Bool
inTypeApp then DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (Int
0,Int
0)) else DeltaPos -> Pretty DeltaPos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> DeltaPos
DP (Int
0,Int
1)))
          -- then (if inTypeApp then error "inTypeAp" else return (DP (0,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 -> ACS' AstContext -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
TopLevel) ACS' AstContext
ctx
    listStart :: Bool
listStart = Set AstContext -> ACS' AstContext -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
ListStart) ACS' AstContext
ctx
              Bool -> Bool -> Bool
&& Bool -> Bool
not (Set AstContext -> ACS' AstContext -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
TopLevel) ACS' AstContext
ctx)
    inList :: Bool
inList = Set AstContext -> ACS' AstContext -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
ListItem) ACS' AstContext
ctx
    inLambda :: Bool
inLambda = Set AstContext -> ACS' AstContext -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
LambdaExpr) ACS' AstContext
ctx
    inTypeApp :: Bool
inTypeApp = Set AstContext -> ACS' AstContext -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs (AstContext -> Set AstContext
forall a. a -> Set a
Set.singleton AstContext
InTypeApp) ACS' AstContext
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 :: forall a. 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, ACS' AstContext) -> String
forall a. Outputable a => a -> String
showGhc (PrettyOptions -> SrcSpan
curSrcSpan PrettyOptions
l,PrettyOptions -> ACS' AstContext
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}
  = AnnSpan -> AnnConName -> AnnKey
AnnKey (SrcSpan -> AnnSpan
rs 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 :: [(AnnSpan, Annotated b)] -> Pretty ()
withSortKey :: forall b.
[(AnnSpan, Annotated b)]
-> RWS PrettyOptions PrettyWriter PrettyState ()
withSortKey [(AnnSpan, Annotated b)]
kws =
  let order :: [(AnnSpan, Annotated b)]
order = ((AnnSpan, Annotated b) -> (AnnSpan, Annotated b) -> Ordering)
-> [(AnnSpan, Annotated b)] -> [(AnnSpan, Annotated b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((AnnSpan, Annotated b) -> AnnSpan)
-> (AnnSpan, Annotated b) -> (AnnSpan, Annotated b) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (AnnSpan, Annotated b) -> AnnSpan
forall a b. (a, b) -> a
fst) [(AnnSpan, Annotated b)]
kws
  in do
    [AnnSpan] -> RWS PrettyOptions PrettyWriter PrettyState ()
tellSortKey (((AnnSpan, Annotated b) -> AnnSpan)
-> [(AnnSpan, Annotated b)] -> [AnnSpan]
forall a b. (a -> b) -> [a] -> [b]
map (AnnSpan, Annotated b) -> AnnSpan
forall a b. (a, b) -> a
fst [(AnnSpan, Annotated b)]
order)
    ((AnnSpan, Annotated b)
 -> RWST PrettyOptions PrettyWriter PrettyState Identity b)
-> [(AnnSpan, 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)
-> ((AnnSpan, Annotated b) -> Annotated b)
-> (AnnSpan, Annotated b)
-> RWST PrettyOptions PrettyWriter PrettyState Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnnSpan, Annotated b) -> Annotated b
forall a b. (a, b) -> b
snd) [(AnnSpan, Annotated b)]
order

withSortKeyContexts :: ListContexts -> [(AnnSpan, Annotated ())] -> Pretty ()
withSortKeyContexts :: ListContexts
-> [(AnnSpan, Annotated ())]
-> RWS PrettyOptions PrettyWriter PrettyState ()
withSortKeyContexts ListContexts
ctxts [(AnnSpan, Annotated ())]
kws =
  let order :: [(AnnSpan, Annotated ())]
order = ((AnnSpan, Annotated ()) -> (AnnSpan, Annotated ()) -> Ordering)
-> [(AnnSpan, Annotated ())] -> [(AnnSpan, Annotated ())]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((AnnSpan, Annotated ()) -> AnnSpan)
-> (AnnSpan, Annotated ()) -> (AnnSpan, Annotated ()) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (AnnSpan, Annotated ()) -> AnnSpan
forall a b. (a, b) -> a
fst) [(AnnSpan, Annotated ())]
kws
  in do
    [AnnSpan] -> RWS PrettyOptions PrettyWriter PrettyState ()
tellSortKey (((AnnSpan, Annotated ()) -> AnnSpan)
-> [(AnnSpan, Annotated ())] -> [AnnSpan]
forall a b. (a -> b) -> [a] -> [b]
map (AnnSpan, Annotated ()) -> AnnSpan
forall a b. (a, b) -> a
fst [(AnnSpan, Annotated ())]
order)
    (Annotated () -> RWS PrettyOptions PrettyWriter PrettyState ())
-> ListContexts
-> [(AnnSpan, Annotated ())]
-> RWS PrettyOptions PrettyWriter PrettyState ()
forall (m :: * -> *).
Monad m =>
(Annotated () -> m ())
-> ListContexts -> [(AnnSpan, Annotated ())] -> m ()
withSortKeyContextsHelper Annotated () -> RWS PrettyOptions PrettyWriter PrettyState ()
forall a. Annotated a -> Pretty a
prettyInterpret ListContexts
ctxts [(AnnSpan, 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 :: forall a. 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 :: ACS' AstContext
prContext = Set AstContext -> Int -> ACS' AstContext -> ACS' AstContext
forall a. Ord a => Set a -> Int -> ACS' a -> ACS' a
setAcsWithLevel Set AstContext
ctxt Int
lvl (PrettyOptions -> ACS' AstContext
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 :: ACS' AstContext
prContext = AstContext -> ACS' AstContext -> ACS' AstContext
forall a. Ord a => a -> ACS' a -> ACS' a
unsetAcs AstContext
ctxt (PrettyOptions -> ACS' AstContext
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
  ACS' AstContext
cur <- (PrettyOptions -> ACS' AstContext)
-> RWST
     PrettyOptions PrettyWriter PrettyState Identity (ACS' AstContext)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrettyOptions -> ACS' AstContext
prContext
  let inContext :: Bool
inContext = Set AstContext -> ACS' AstContext -> Bool
forall a. Ord a => Set a -> ACS' a -> Bool
inAcs Set AstContext
ctxt ACS' AstContext
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 (Map AnnKey Annotation)
dwAnns = (Map AnnKey Annotation -> Map AnnKey Annotation)
-> Endo (Map AnnKey Annotation)
forall a. (a -> a) -> Endo a
Endo (AnnKey
-> Annotation -> Map AnnKey Annotation -> Map AnnKey Annotation
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 :: [AnnSpan] -> Pretty ()
tellSortKey :: [AnnSpan] -> RWS PrettyOptions PrettyWriter PrettyState ()
tellSortKey [AnnSpan]
xs = PrettyWriter -> RWS PrettyOptions PrettyWriter PrettyState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (PrettyWriter
forall a. Monoid a => a
mempty { sortKeys :: Maybe [AnnSpan]
sortKeys = [AnnSpan] -> Maybe [AnnSpan]
forall a. a -> Maybe a
Just [AnnSpan]
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 :: ACS' AstContext
prLayoutContext = Set AstContext -> Int -> ACS' AstContext -> ACS' AstContext
forall a. Ord a => Set a -> Int -> ACS' a -> ACS' a
setAcsWithLevel Set AstContext
lc Int
2 ACS' AstContext
forall a. Monoid a => a
mempty} )