1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE NamedFieldPuns #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ViewPatterns #-}
7
8-----------------------------------------------------------------------------
9-- |
10-- Module      :  Language.Haskell.GHC.ExactPrint.Pretty
11--
12-- This module adds default annotations to an AST fragment that does not have
13-- them, to be able to exactprint it in a way that preserves the orginal AST
14-- when re-parsed.
15--
16-----------------------------------------------------------------------------
17
18module Language.Haskell.GHC.ExactPrint.Pretty
19        (
20        addAnnotationsForPretty
21        ) where
22
23import Language.Haskell.GHC.ExactPrint.Types
24import Language.Haskell.GHC.ExactPrint.Utils
25import Language.Haskell.GHC.ExactPrint.Annotate
26
27import Control.Monad.RWS
28import Control.Monad.Trans.Free
29import Data.Generics
30import Data.List
31import Data.Ord (comparing)
32
33
34#if __GLASGOW_HASKELL__ <= 710
35import qualified BooleanFormula as GHC
36import qualified Outputable     as GHC
37#endif
38import qualified GHC
39
40import qualified Data.Map as Map
41import qualified Data.Set as Set
42
43{-# ANN module "HLint: ignore Eta reduce" #-}
44{-# ANN module "HLint: ignore Redundant do" #-}
45{-# ANN module "HLint: ignore Reduce duplication" #-}
46
47-- ---------------------------------------------------------------------
48
49-- |Add any missing annotations so that the full AST element will exactprint
50-- properly when done.
51addAnnotationsForPretty :: (Annotate a) => [Comment] -> GHC.Located a -> Anns -> Anns
52addAnnotationsForPretty cs ast ans
53  = runPrettyWithComments opts cs (annotate ast) ans (0,0)
54  where
55    opts = prettyOptions NormalLayout
56
57-- ---------------------------------------------------------------------
58--
59-- | Type used in the Pretty Monad.
60type Pretty a = RWS PrettyOptions PrettyWriter PrettyState a
61
62runPrettyWithComments :: PrettyOptions -> [Comment] -> Annotated () -> Anns -> Pos -> Anns
63runPrettyWithComments opts cs action ans priorEnd =
64  mkAnns . snd
65  . (\next -> execRWS next opts (defaultPrettyState cs priorEnd ans))
66  . prettyInterpret $ action
67  where
68    mkAnns :: PrettyWriter -> Anns
69    mkAnns = f . dwAnns
70    f :: Monoid a => Endo a -> a
71    f = ($ mempty) . appEndo
72
73-- ---------------------------------------------------------------------
74
75-- TODO: rename this, it is the R part of the RWS
76data PrettyOptions = PrettyOptions
77       {
78         -- | Current `SrcSpan, part of current AnnKey`
79         curSrcSpan  :: !GHC.SrcSpan
80
81         -- | Constuctor of current AST element, part of current AnnKey
82       , annConName       :: !AnnConName
83
84        -- | Whether to use rigid or normal layout rules
85       , drRigidity :: !Rigidity
86
87       -- | Current higher level context. e.g. whether a Match is part of a
88       -- LambdaExpr or a FunBind
89       , prContext :: !AstContextSet
90       } deriving Show
91
92data PrettyWriter = PrettyWriter
93       { -- | Final list of annotations, and sort keys
94         dwAnns :: Endo (Map.Map AnnKey Annotation)
95
96         -- | Used locally to pass Keywords, delta pairs relevant to a specific
97         -- subtree to the parent.
98       , annKds          :: ![(KeywordId, DeltaPos)]
99       , sortKeys        :: !(Maybe [AnnSpan])
100       , dwCapturedSpan  :: !(First AnnKey)
101       , prLayoutContext :: !(ACS' AstContext)
102       }
103
104data PrettyState = PrettyState
105       { -- | Position reached when processing the last element
106         priorEndPosition    :: !Pos
107
108         -- | Ordered list of comments still to be allocated
109       , apComments :: ![Comment]
110
111       , apMarkLayout  :: Bool
112       , apLayoutStart :: LayoutStartCol
113
114       , apNoPrecedingSpace :: Bool
115
116       }
117
118#if __GLASGOW_HASKELL__ >= 804
119instance Semigroup PrettyWriter where
120  (<>) = mappend
121#endif
122
123instance Monoid PrettyWriter where
124  mempty = PrettyWriter mempty mempty mempty mempty mempty
125  (PrettyWriter a b e g i) `mappend` (PrettyWriter c d f h j)
126    = PrettyWriter (a <> c) (b <> d) (e <> f) (g <> h) (i <> j)
127
128-- ---------------------------------------------------------------------
129
130prettyOptions :: Rigidity -> PrettyOptions
131prettyOptions ridigity =
132  PrettyOptions
133    { curSrcSpan = GHC.noSrcSpan
134    , annConName = annGetConstr ()
135    , drRigidity = ridigity
136    , prContext  = defaultACS
137    }
138
139defaultPrettyState :: [Comment] -> Pos -> Anns -> PrettyState
140defaultPrettyState injectedComments priorEnd _ans =
141    PrettyState
142      { priorEndPosition    = priorEnd
143      , apComments = cs ++ injectedComments
144      , apLayoutStart = 1
145      , apMarkLayout = False
146      , apNoPrecedingSpace = False
147      }
148  where
149    cs :: [Comment]
150    cs = []
151
152-- ---------------------------------------------------------------------
153-- Free Monad Interpretation code
154
155prettyInterpret :: Annotated a -> Pretty a
156prettyInterpret = iterTM go
157  where
158    go :: AnnotationF (Pretty a) -> Pretty a
159    go (MarkPrim kwid _ next)           = addPrettyAnnotation (G kwid) >> next
160    go (MarkPPOptional _kwid _ next)    = next
161    go (MarkEOF next)                   = addEofAnnotation >> next
162    go (MarkExternal _ss akwid _ next)  = addPrettyAnnotation (G akwid) >> next
163#if __GLASGOW_HASKELL__ >= 800
164    go (MarkInstead akwid kwid next)    = addPrettyAnnotationsInstead akwid kwid >> next
165#endif
166    go (MarkOutside akwid kwid next)    = addPrettyAnnotationsOutside akwid kwid >> next
167    -- go (MarkOutside akwid kwid next)    = addPrettyAnnotation kwid >> next
168    go (MarkInside akwid next)          = addPrettyAnnotationsInside akwid >> next
169    go (MarkMany akwid next)            = addPrettyAnnotation (G akwid) >> next
170    go (MarkManyOptional _akwid next)   = next
171    go (MarkOffsetPrim akwid n _ next)  = addPrettyAnnotationLs akwid n >> next
172    go (MarkOffsetPrimOptional _akwid _n _ next)  = next
173    go (WithAST lss prog next)          = withAST lss (prettyInterpret prog) >> next
174    go (CountAnns kwid next)            = countAnnsPretty kwid >>= next
175    go (WithSortKey             kws next) = withSortKey             kws >> next
176    go (WithSortKeyContexts ctx kws next) = withSortKeyContexts ctx kws >> next
177    go (SetLayoutFlag r action next)    = do
178      rigidity <- asks drRigidity
179      (if r <= rigidity then setLayoutFlag else id) (prettyInterpret action)
180      next
181    go (StoreOriginalSrcSpan l key next) = storeOriginalSrcSpanPretty l key >>= next
182    go (MarkAnnBeforeAnn _ann1 _ann2 next) = next
183    go (GetSrcSpanForKw ss kw next)      = getSrcSpanForKw ss kw >>= next
184#if __GLASGOW_HASKELL__ <= 710
185    go (StoreString s ss next)           = storeString s ss >> next
186#endif
187    go (AnnotationsToComments kws next)       = annotationsToCommentsPretty kws >> next
188#if __GLASGOW_HASKELL__ <= 710
189    go (AnnotationsToCommentsBF bf kws next)  = annotationsToCommentsBFPretty bf kws >> next
190    go (FinalizeBF l next)                    = finalizeBFPretty l >> next
191#endif
192
193    go (SetContextLevel ctxt lvl action next)  = setContextPretty ctxt lvl (prettyInterpret action) >> next
194    go (UnsetContext    ctxt     action next)  = unsetContextPretty ctxt (prettyInterpret action) >> next
195    go (IfInContext ctxt ia ea next)           = ifInContextPretty ctxt ia ea >> next
196    go (TellContext c next)                    = tellContext c >> next
197
198-- ---------------------------------------------------------------------
199
200addEofAnnotation :: Pretty ()
201addEofAnnotation = do
202#if __GLASGOW_HASKELL__ >= 900
203  tellKd (AnnEofPos, DP (1,0))
204#else
205  tellKd (G GHC.AnnEofPos, DP (1,0))
206#endif
207
208-- ---------------------------------------------------------------------
209
210addPrettyAnnotation :: KeywordId -> Pretty ()
211addPrettyAnnotation ann = do
212  noPrec <- gets apNoPrecedingSpace
213  ctx <- asks prContext
214  _ <- debugP ("Pretty.addPrettyAnnotation:=" ++ showGhc (ann,noPrec,ctx)) $ asks prContext
215  let
216    dp = case ann of
217           (G GHC.AnnAs)           -> tellKd (ann,DP (0,1))
218           (G GHC.AnnAt)           -> tellKd (ann,DP (0,0))
219#if __GLASGOW_HASKELL__ >= 806
220           (G GHC.AnnAnyclass)     -> tellKd (ann,DP (0,1))
221#endif
222           (G GHC.AnnBackquote)    -> tellKd (ann,DP (0,1))
223           (G GHC.AnnBang)         -> tellKd (ann,DP (0,1))
224           (G GHC.AnnBy)           -> tellKd (ann,DP (0,1))
225           (G GHC.AnnCase )        -> tellKd (ann,DP (0,1))
226           (G GHC.AnnClass)        -> tellKd (ann,DP (0,1))
227           (G GHC.AnnClose)        -> tellKd (ann,DP (0,1))
228           (G GHC.AnnCloseC)       -> tellKd (ann,DP (0,0))
229#if __GLASGOW_HASKELL__ >= 802
230           (G GHC.AnnCloseQ)       -> tellKd (ann,DP (0,1))
231#endif
232           (G GHC.AnnDcolon)       -> tellKd (ann,DP (0,1))
233           (G GHC.AnnDeriving)     -> tellKd (ann,DP (0,1))
234           (G GHC.AnnDo)           -> tellKd (ann,DP (0,1))
235#if __GLASGOW_HASKELL__ >= 900
236           (G GHC.AnnDollar)       -> tellKd (ann,DP (0,1))
237           (G GHC.AnnDollarDollar) -> tellKd (ann,DP (0,1))
238#endif
239           (G GHC.AnnDotdot)       -> tellKd (ann,DP (0,1))
240           (G GHC.AnnElse)         -> tellKd (ann,DP (1,2))
241           (G GHC.AnnEqual)        -> tellKd (ann,DP (0,1))
242           (G GHC.AnnExport)       -> tellKd (ann,DP (0,1))
243           (G GHC.AnnFamily)       -> tellKd (ann,DP (0,1))
244           (G GHC.AnnForall)       -> tellKd (ann,DP (0,1))
245           (G GHC.AnnGroup)        -> tellKd (ann,DP (0,1))
246           (G GHC.AnnHiding)       -> tellKd (ann,DP (0,1))
247           (G GHC.AnnIf)           -> tellKd (ann,DP (0,1))
248           (G GHC.AnnImport)       -> tellKd (ann,DP (0,1))
249           (G GHC.AnnIn)           -> tellKd (ann,DP (1,0))
250           (G GHC.AnnInstance)     -> tellKd (ann,DP (0,1))
251           (G GHC.AnnLam)          -> tellKd (ann,DP (0,1))
252           (G GHC.AnnLet)          -> tellKd (ann,DP (0,1))
253#if __GLASGOW_HASKELL__ >= 900
254           -- (G GHC.AnnLolly)        -> tellKd (ann,DP (0,1))
255           (G GHC.AnnLollyU)       -> tellKd (ann,DP (0,1))
256           (G GHC.AnnPercentOne)   -> tellKd (ann,DP (0,1))
257           (G GHC.AnnPercent)      -> tellKd (ann,DP (0,1))
258#endif
259           (G GHC.AnnMinus)        -> tellKd (ann,DP (0,1)) -- need to separate from preceding operator
260           (G GHC.AnnModule)       -> tellKd (ann,DP (0,1))
261           (G GHC.AnnNewtype)      -> tellKd (ann,DP (0,1))
262           (G GHC.AnnOf)           -> tellKd (ann,DP (0,1))
263           (G GHC.AnnOpenC)        -> tellKd (ann,DP (0,0))
264           (G GHC.AnnOpenP)        -> tellKd (ann,DP (0,1))
265           (G GHC.AnnOpenS)        -> tellKd (ann,DP (0,1))
266#if __GLASGOW_HASKELL__ < 900
267           (G GHC.AnnOpenPE)       -> tellKd (ann,DP (0,1))
268           (G GHC.AnnOpenPTE)      -> tellKd (ann,DP (0,1))
269#endif
270           (G GHC.AnnQualified)    -> tellKd (ann,DP (0,1))
271           (G GHC.AnnRarrow)       -> tellKd (ann,DP (0,1))
272#if __GLASGOW_HASKELL__ > 710
273           (G GHC.AnnRarrowU)      -> tellKd (ann,DP (0,1))
274#endif
275           (G GHC.AnnRole)         -> tellKd (ann,DP (0,1))
276           (G GHC.AnnSafe)         -> tellKd (ann,DP (0,1))
277#if __GLASGOW_HASKELL__ >= 806
278           (G GHC.AnnStock)        -> tellKd (ann,DP (0,1))
279#endif
280           (G GHC.AnnSimpleQuote)  -> tellKd (ann,DP (0,1))
281#if __GLASGOW_HASKELL__ < 900
282           (G GHC.AnnThIdSplice)   -> tellKd (ann,DP (0,1))
283           (G GHC.AnnThIdTySplice) -> tellKd (ann,DP (0,1))
284#endif
285           (G GHC.AnnThTyQuote)    -> tellKd (ann,DP (0,1))
286           (G GHC.AnnThen)         -> tellKd (ann,DP (1,2))
287           (G GHC.AnnTilde)        -> tellKd (ann,DP (0,1))
288           (G GHC.AnnType)         -> tellKd (ann,DP (0,1))
289           (G GHC.AnnUsing)        -> tellKd (ann,DP (0,1))
290           (G GHC.AnnVal)          -> tellKd (ann,DP (0,1))
291           (G GHC.AnnValStr)       -> tellKd (ann,DP (0,1))
292           (G GHC.AnnVbar)         -> tellKd (ann,DP (0,1))
293#if __GLASGOW_HASKELL__ >= 806
294           (G GHC.AnnVia)          -> tellKd (ann,DP (0,1))
295#endif
296           (G GHC.AnnWhere)        -> tellKd (ann,DP (1,2))
297#if __GLASGOW_HASKELL__ >= 800
298           AnnTypeApp              -> tellKd (ann,DP (0,1))
299#endif
300           _ ->                tellKd (ann,DP (0,0))
301  fromNoPrecedingSpace (tellKd (ann,DP (0,0))) dp
302
303-- ---------------------------------------------------------------------
304
305#if __GLASGOW_HASKELL__ >= 800
306addPrettyAnnotationsInstead :: GHC.AnnKeywordId -> KeywordId -> Pretty ()
307addPrettyAnnotationsInstead _akwid AnnSemiSep = return ()
308addPrettyAnnotationsInstead _akwid kwid = addPrettyAnnotation kwid
309#endif
310
311-- ---------------------------------------------------------------------
312
313addPrettyAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Pretty ()
314addPrettyAnnotationsOutside _akwid AnnSemiSep = return ()
315addPrettyAnnotationsOutside _akwid kwid = addPrettyAnnotation kwid
316
317-- ---------------------------------------------------------------------
318
319addPrettyAnnotationsInside :: GHC.AnnKeywordId -> Pretty ()
320addPrettyAnnotationsInside _ann = return ()
321
322-- ---------------------------------------------------------------------
323
324addPrettyAnnotationLs :: GHC.AnnKeywordId -> Int -> Pretty ()
325addPrettyAnnotationLs ann _off = addPrettyAnnotation (G ann)
326
327-- ---------------------------------------------------------------------
328
329#if __GLASGOW_HASKELL__ <= 710
330getUnallocatedComments :: Pretty [Comment]
331getUnallocatedComments = gets apComments
332
333putUnallocatedComments :: [Comment] -> Pretty ()
334putUnallocatedComments cs = modify (\s -> s { apComments = cs } )
335#endif
336
337-- ---------------------------------------------------------------------
338
339#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900)
340withSrcSpanPretty :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b
341withSrcSpanPretty (GHC.dL->GHC.L l a) action = do
342#else
343withSrcSpanPretty :: Data a => GHC.Located a -> Pretty b -> Pretty b
344withSrcSpanPretty (GHC.L l a) action = do
345#endif
346  -- peek into the current state of the output, to extract the layout context
347  -- flags passed up from subelements of the AST.
348  (_,w) <- listen (return () :: Pretty ())
349
350  _ <- debugP ("withSrcSpanPretty: prLayoutContext w=" ++ show (prLayoutContext w) ) (return ())
351
352  local (\s -> s { curSrcSpan = l
353                 , annConName = annGetConstr a
354                 -- , prContext  = pushAcs (prContext s)
355                 , prContext  = (pushAcs (prContext s)) <> (prLayoutContext w)
356                 })
357        action
358
359-- ---------------------------------------------------------------------
360
361-- | Enter a new AST element. Maintain SrcSpan stack
362#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900)
363withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a)
364        => a
365        -> Pretty b -> Pretty b
366withAST lss@(GHC.dL->GHC.L ss t) action = do
367#else
368withAST :: Data a
369        => GHC.Located a
370        -> Pretty b -> Pretty b
371withAST lss@(GHC.L ss t) action = do
372#endif
373  return () `debug` ("Pretty.withAST:enter 1:(ss)=" ++ showGhc (ss,showConstr (toConstr t)))
374  -- Calculate offset required to get to the start of the SrcSPan
375  -- off <- gets apLayoutStart
376  withSrcSpanPretty lss $ do
377    return () `debug` ("Pretty.withAST:enter:(ss)=" ++ showGhc (ss,showConstr (toConstr t)))
378
379    let maskWriter s = s { annKds          = []
380                         , sortKeys        = Nothing
381                         , dwCapturedSpan  = mempty
382                         -- , prLayoutContext = pushAcs (prLayoutContext s)
383                         }
384
385#if __GLASGOW_HASKELL__ <= 710
386    let spanStart = ss2pos ss
387    cs <- do
388      if GHC.isGoodSrcSpan ss
389        then
390          commentAllocation (priorComment spanStart) return
391        else
392          return []
393#else
394    let cs = []
395#endif
396
397    -- ctx <- debugP ("Pretty.withAST:cs:(ss,cs,uncs)=" ++ showGhc (ss,cs,uncs)) $ asks prContext
398    ctx <- asks prContext
399
400    noPrec <- gets apNoPrecedingSpace
401    edp <- debugP ("Pretty.withAST:enter:(ss,constr,noPrec,ctx)=" ++ showGhc (ss,showConstr (toConstr t),noPrec,ctx)) $ entryDpFor ctx t
402    -- edp <- entryDpFor ctx t
403
404    let ctx1 = debugP ("Pretty.withAST:edp:(ss,constr,edp)=" ++ showGhc (ss,showConstr (toConstr t),edp)) ctx
405    -- (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel]) ctx1
406    (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel,InTypeApp]) ctx1
407      then
408           -- debugP ("Pretty.withAST:setNoPrecedingSpace") $
409             censor maskWriter (listen (setNoPrecedingSpace action))
410      else
411           -- debugP ("Pretty.withAST:setNoPrecedingSpace") $
412            censor maskWriter (listen action)
413
414    let kds = annKds w
415        an = Ann
416               { annEntryDelta        = edp
417               , annPriorComments     = cs
418               , annFollowingComments = [] -- only used in Transform and Print
419               , annsDP               = kds
420               , annSortKey           = sortKeys w
421               , annCapturedSpan      = getFirst $ dwCapturedSpan w
422               }
423
424    addAnnotationsPretty an
425     `debug` ("Pretty.withAST:(annkey,an)=" ++ show (mkAnnKey lss,an))
426    return res
427
428-- ---------------------------------------------------------------------
429
430entryDpFor :: Typeable a => AstContextSet -> a -> Pretty DeltaPos
431entryDpFor ctx a = (def `extQ` grhs) a
432  where
433    lineDefault = if inAcs (Set.singleton AdvanceLine) ctx
434                    then 1 else 0
435    noAdvanceLine = inAcs (Set.singleton NoAdvanceLine) ctx &&
436                    inAcs (Set.singleton ListStart) ctx
437
438    def :: a -> Pretty DeltaPos
439    def _ =
440      debugP ("entryDpFor:(topLevel,listStart,inList,noAdvanceLine,ctx)=" ++ show (topLevel,listStart,inList,noAdvanceLine,ctx)) $
441        if noAdvanceLine
442          then (if inTypeApp then return (DP (0,0)) else return (DP (0,1)))
443          -- then (if inTypeApp then error "inTypeAp" else return (DP (0,1)))
444          else
445            if listStart
446              then return (DP (1,2))
447              else if inList
448                then if topLevel then return (DP (2,0)) else return (DP (1,0))
449                else if topLevel then return (DP (2,0)) else return (DP (lineDefault,0))
450
451    topLevel = inAcs (Set.singleton TopLevel) ctx
452    listStart = inAcs (Set.singleton ListStart) ctx
453              && not (inAcs (Set.singleton TopLevel) ctx)
454    inList = inAcs (Set.singleton ListItem) ctx
455    inLambda = inAcs (Set.singleton LambdaExpr) ctx
456    inTypeApp = inAcs (Set.singleton InTypeApp) ctx
457
458    grhs :: GHC.GRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Pretty DeltaPos
459    grhs _ = do
460      if inLambda
461        then return (DP (0,1))
462        else return (DP (1,2))
463
464-- ---------------------------------------------------------------------
465
466fromNoPrecedingSpace :: Pretty a -> Pretty a -> Pretty a
467fromNoPrecedingSpace def lay = do
468  PrettyState{apNoPrecedingSpace} <- get
469  -- ctx <- asks prContext
470  if apNoPrecedingSpace
471    then do
472      modify (\s -> s { apNoPrecedingSpace = False
473                      })
474      debugP ("fromNoPrecedingSpace:def") def
475      -- def
476    else
477      -- lay
478      debugP ("fromNoPrecedingSpace:lay") lay
479
480
481-- ---------------------------------------------------------------------
482
483-- |Add some annotation to the currently active SrcSpan
484addAnnotationsPretty :: Annotation -> Pretty ()
485addAnnotationsPretty ann = do
486    l <- ask
487    return () `debug` ("addAnnotationsPretty:=" ++ showGhc (curSrcSpan l,prContext l))
488    tellFinalAnn (getAnnKey l,ann)
489
490getAnnKey :: PrettyOptions -> AnnKey
491getAnnKey PrettyOptions {curSrcSpan, annConName}
492  = AnnKey (rs curSrcSpan) annConName
493
494-- ---------------------------------------------------------------------
495
496countAnnsPretty :: GHC.AnnKeywordId -> Pretty Int
497countAnnsPretty _ann = return 0
498
499-- ---------------------------------------------------------------------
500
501withSortKey :: [(AnnSpan, Annotated b)] -> Pretty ()
502withSortKey kws =
503  let order = sortBy (comparing fst) kws
504  in do
505    tellSortKey (map fst order)
506    mapM_ (prettyInterpret . snd) order
507
508withSortKeyContexts :: ListContexts -> [(AnnSpan, Annotated ())] -> Pretty ()
509withSortKeyContexts ctxts kws =
510  let order = sortBy (comparing fst) kws
511  in do
512    tellSortKey (map fst order)
513    withSortKeyContextsHelper prettyInterpret ctxts order
514
515-- ---------------------------------------------------------------------
516
517storeOriginalSrcSpanPretty :: GHC.SrcSpan -> AnnKey -> Pretty AnnKey
518storeOriginalSrcSpanPretty _s key = do
519  tellCapturedSpan key
520  return key
521
522-- ---------------------------------------------------------------------
523
524getSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> Pretty GHC.SrcSpan
525getSrcSpanForKw ss _kw = return ss
526
527-- ---------------------------------------------------------------------
528
529#if __GLASGOW_HASKELL__ <= 710
530storeString :: String -> GHC.SrcSpan -> Pretty ()
531storeString s _ss = addPrettyAnnotation (AnnString s)
532#endif
533
534-- ---------------------------------------------------------------------
535
536setLayoutFlag :: Pretty () -> Pretty ()
537setLayoutFlag action = do
538  oldLay <- gets apLayoutStart
539  modify (\s -> s { apMarkLayout = True } )
540  let reset = modify (\s -> s { apMarkLayout = False
541                              , apLayoutStart = oldLay })
542  action <* reset
543
544-- ---------------------------------------------------------------------
545
546setNoPrecedingSpace :: Pretty a -> Pretty a
547setNoPrecedingSpace action = do
548  oldVal <- gets apNoPrecedingSpace
549  modify (\s -> s { apNoPrecedingSpace = True } )
550  let reset = modify (\s -> s { apNoPrecedingSpace = oldVal })
551  action <* reset
552
553-- ---------------------------------------------------------------------
554
555setContextPretty :: Set.Set AstContext -> Int -> Pretty () -> Pretty ()
556setContextPretty ctxt lvl =
557  local (\s -> s { prContext = setAcsWithLevel ctxt lvl (prContext s) } )
558
559unsetContextPretty :: AstContext -> Pretty () -> Pretty ()
560unsetContextPretty ctxt =
561  local (\s -> s { prContext = unsetAcs ctxt (prContext s) } )
562
563
564ifInContextPretty :: Set.Set AstContext -> Annotated () -> Annotated () -> Pretty ()
565ifInContextPretty ctxt ifAction elseAction = do
566  cur <- asks prContext
567  let inContext = inAcs ctxt cur
568  if inContext
569    then prettyInterpret ifAction
570    else prettyInterpret elseAction
571
572-- ---------------------------------------------------------------------
573
574annotationsToCommentsPretty :: [GHC.AnnKeywordId] -> Pretty ()
575annotationsToCommentsPretty _kws = return ()
576
577-- ---------------------------------------------------------------------
578
579#if __GLASGOW_HASKELL__ <= 710
580annotationsToCommentsBFPretty :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> Pretty ()
581annotationsToCommentsBFPretty bf _kws = do
582  -- cs <- gets apComments
583  cs <- debugP ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) $ gets apComments
584  -- return$ debugP ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) ()
585  -- error ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf))
586  let
587    kws = makeBooleanFormulaAnns bf
588    newComments = map (uncurry mkKWComment ) kws
589  putUnallocatedComments (cs ++ newComments)
590
591
592finalizeBFPretty :: GHC.SrcSpan -> Pretty ()
593finalizeBFPretty _ss = do
594  commentAllocation (const True) (mapM_ (uncurry addPrettyComment))
595  return ()
596#endif
597
598-- ---------------------------------------------------------------------
599#if __GLASGOW_HASKELL__ <= 710
600-- |Split the ordered list of comments into ones that occur prior to
601-- the give SrcSpan and the rest
602priorComment :: Pos -> Comment -> Bool
603priorComment start c = (ss2pos . commentIdentifier $ c) < start
604
605-- TODO:AZ: We scan the entire comment list here. It may be better to impose an
606-- invariant that the comments are sorted, and consume them as the pos
607-- advances. It then becomes a process of using `takeWhile p` rather than a full
608-- partition.
609allocateComments :: (Comment -> Bool) -> [Comment] -> ([Comment], [Comment])
610allocateComments = partition
611#endif
612
613-- ---------------------------------------------------------------------
614
615#if __GLASGOW_HASKELL__ <= 710
616commentAllocation :: (Comment -> Bool)
617                  -> ([(Comment, DeltaPos)] -> Pretty a)
618                  -> Pretty a
619commentAllocation p k = do
620  cs <- getUnallocatedComments
621  let (allocated,cs') = allocateComments p cs
622  putUnallocatedComments cs'
623  k =<< mapM makeDeltaComment (sortBy (comparing commentIdentifier) allocated)
624
625makeDeltaComment :: Comment -> Pretty (Comment, DeltaPos)
626makeDeltaComment c = do
627  return (c, DP (0,1))
628
629addPrettyComment :: Comment -> DeltaPos -> Pretty ()
630addPrettyComment d p = do
631  tellKd (AnnComment d, p)
632#endif
633
634-- ---------------------------------------------------------------------
635
636-- Writer helpers
637
638tellFinalAnn :: (AnnKey, Annotation) -> Pretty ()
639tellFinalAnn (k, v) =
640  tell (mempty { dwAnns = Endo (Map.insert k v) })
641
642tellCapturedSpan :: AnnKey -> Pretty ()
643tellCapturedSpan key = tell ( mempty { dwCapturedSpan = First $ Just key })
644
645tellKd :: (KeywordId, DeltaPos) -> Pretty ()
646tellKd kd = tell (mempty { annKds = [kd] })
647
648tellSortKey :: [AnnSpan] -> Pretty ()
649tellSortKey xs = tell (mempty { sortKeys = Just xs } )
650
651tellContext :: Set.Set AstContext -> Pretty ()
652tellContext lc = tell (mempty { prLayoutContext = setAcsWithLevel lc 2 mempty} )
653