diff options
Diffstat (limited to 'utils/check-exact/ExactPrint.hs')
| -rw-r--r-- | utils/check-exact/ExactPrint.hs | 5392 |
1 files changed, 3201 insertions, 2191 deletions
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 25ea557a27..cfa50a9e3b 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE BlockArguments #-} @@ -19,7 +20,14 @@ module ExactPrint ( ExactPrint(..) , exactPrint - -- , exactPrintWithOptions + , exactPrintWithOptions + , makeDeltaAst + + -- * Configuration + , EPOptions(epRigidity, epAstPrint, epTokenPrint, epWhitespacePrint, epUpdateAnchors) + , stringOptions + , epOptions + , deltaOptions ) where import GHC @@ -27,6 +35,7 @@ import GHC.Core.Coercion.Axiom (Role(..)) import GHC.Data.Bag import qualified GHC.Data.BooleanFormula as BF import GHC.Data.FastString +import GHC.TypeLits import GHC.Types.Basic hiding (EP) import GHC.Types.Fixity import GHC.Types.ForeignCall @@ -38,59 +47,71 @@ import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Unit.Module.Warnings import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.TypeLits import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Control.Monad.Identity +import qualified Control.Monad.Reader as Reader import Control.Monad.RWS import Data.Data ( Data ) +import Data.Dynamic import Data.Foldable +import Data.Functor.Const +import qualified Data.Set as Set import Data.Typeable -import Data.List ( partition, sortBy) -import Data.List.NonEmpty ( NonEmpty ) -import Data.Maybe ( isJust ) +import Data.List ( partition, sort, sortBy) +import Data.Maybe ( isJust, mapMaybe ) import Data.Void import Lookup import Utils import Types -import Data.Ord - --- import Debug.Trace -- --------------------------------------------------------------------- -exactPrint :: ExactPrint ast => Located ast -> String -exactPrint ast = runIdentity (runEP stringOptions (markAnnotated ast)) +exactPrint :: ExactPrint ast => ast -> String +exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast)) -type EP w m a = RWST (PrintOptions m w) (EPWriter w) EPState m a -type EPP a = EP String Identity a +-- | The additional option to specify the rigidity and printing +-- configuration. +exactPrintWithOptions :: (ExactPrint ast, Monoid b, Monad m) + => EPOptions m b + -> ast + -> m (ast, b) +exactPrintWithOptions r ast = + runEP r (markAnnotated ast) -runEP :: PrintOptions Identity String - -> Annotated () -> Identity String -runEP epReader action = - fmap (output . snd) . - (\next -> execRWST next epReader defaultEPState) - . xx $ action +-- | Transform concrete annotations into relative annotations which +-- are more useful when transforming an AST. This corresponds to the +-- earlier 'relativiseApiAnns'. +makeDeltaAst :: ExactPrint ast => ast -> ast +makeDeltaAst ast = fst $ runIdentity (runEP deltaOptions (markAnnotated ast)) -xx :: Annotated () -> EP String Identity () --- xx :: Annotated() -> RWST (PrintOptions m w) (EPWriter w) EPState m () -xx = id +------------------------------------------------------ + +type EP w m a = RWST (EPOptions m w) (EPWriter w) EPState m a + +runEP :: (Monad m) + => EPOptions m w + -> EP w m a -> m (a, w) +runEP epReader action = do + (ast, w) <- evalRWST action epReader defaultEPState + return (ast, output w) -- --------------------------------------------------------------------- defaultEPState :: EPState defaultEPState = EPState { epPos = (1,1) - , dLHS = 0 + , dLHS = 1 , pMarkLayout = False - , pLHS = 0 + , pLHS = 1 , dMarkLayout = False , dPriorEndPosition = (1,1) , uAnchorSpan = badRealSrcSpan , uExtraDP = Nothing , epComments = [] + , epCommentsApplied = [] } @@ -99,34 +120,40 @@ defaultEPState = EPState -- | The R part of RWS. The environment. Updated via 'local' as we -- enter a new AST element, having a different anchor point. -data PrintOptions m a = PrintOptions +data EPOptions m a = EPOptions { - epAnn :: !Annotation - , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a + epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a , epTokenPrint :: String -> m a , epWhitespacePrint :: String -> m a , epRigidity :: Rigidity + , epUpdateAnchors :: Bool } --- | Helper to create a 'PrintOptions' -printOptions :: +-- | Helper to create a 'EPOptions' +epOptions :: (forall ast . Data ast => GHC.Located ast -> a -> m a) -> (String -> m a) -> (String -> m a) -> Rigidity - -> PrintOptions m a -printOptions astPrint tokenPrint wsPrint rigidity = PrintOptions + -> Bool + -> EPOptions m a +epOptions astPrint tokenPrint wsPrint rigidity delta = EPOptions { - epAnn = annNone - , epAstPrint = astPrint + epAstPrint = astPrint , epWhitespacePrint = wsPrint , epTokenPrint = tokenPrint , epRigidity = rigidity + , epUpdateAnchors = delta } -- | Options which can be used to print as a normal String. -stringOptions :: PrintOptions Identity String -stringOptions = printOptions (\_ b -> return b) return return NormalLayout +stringOptions :: EPOptions Identity String +stringOptions = epOptions (\_ b -> return b) return return NormalLayout False + +-- | Options which can be used to simply update the AST to be in delta +-- form, without generating output +deltaOptions :: EPOptions Identity () +deltaOptions = epOptions (\_ _ -> return ()) (\_ -> return ()) (\_ -> return ()) NormalLayout True data EPWriter a = EPWriter { output :: !a } @@ -158,6 +185,7 @@ data EPState = EPState -- Shared , epComments :: ![Comment] + , epCommentsApplied :: ![[Comment]] } -- --------------------------------------------------------------------- @@ -168,73 +196,123 @@ class HasEntry ast where -- --------------------------------------------------------------------- --- type Annotated = FreeT AnnotationF Identity -type Annotated a = EP String Identity a - --- --------------------------------------------------------------------- - -- | Key entry point. Switches to an independent AST element with its -- own annotation, calculating new offsets, etc -markAnnotated :: ExactPrint a => a -> Annotated () +markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a markAnnotated a = enterAnn (getAnnotationEntry a) a -data Entry = Entry Anchor EpAnnComments +-- | For HsModule, because we do not have a proper SrcSpan, we must +-- indicate to flush trailing comments when done. +data FlushComments = FlushComments + | NoFlushComments + deriving (Eq, Show) + +-- | For GenLocated SrcSpan, we construct an entry location but cannot update it. +data CanUpdateAnchor = CanUpdateAnchor + | CanUpdateAnchorOnly + | NoCanUpdateAnchor + deriving (Eq, Show) + +data Entry = Entry Anchor EpAnnComments FlushComments CanUpdateAnchor | NoEntryVal -instance (HasEntry (EpAnn an)) => HasEntry (SrcSpanAnn' (EpAnn an)) where - fromAnn (SrcSpanAnn EpAnnNotUsed ss) = Entry (spanAsAnchor ss) emptyComments +-- | For flagging whether to capture comments in an EpaDelta or not +data CaptureComments = CaptureComments + | NoCaptureComments + +mkEntry :: Anchor -> EpAnnComments -> Entry +mkEntry anc cs = Entry anc cs NoFlushComments CanUpdateAnchor + +instance HasEntry (SrcSpanAnn' (EpAnn an)) where + fromAnn (SrcSpanAnn EpAnnNotUsed ss) = mkEntry (spanAsAnchor ss) emptyComments fromAnn (SrcSpanAnn an _) = fromAnn an instance HasEntry (EpAnn a) where - fromAnn (EpAnn anchor _ cs) = Entry anchor cs + fromAnn (EpAnn anchor _ cs) = mkEntry anchor cs fromAnn EpAnnNotUsed = NoEntryVal -- --------------------------------------------------------------------- +fromAnn' :: (HasEntry a) => a -> Entry +fromAnn' an = case fromAnn an of + NoEntryVal -> NoEntryVal + Entry a c _ u -> Entry a c' FlushComments u + where + c' = case c of + EpaComments cs -> EpaCommentsBalanced (filterEofComment False cs) (filterEofComment True cs) + EpaCommentsBalanced cp ct -> EpaCommentsBalanced cp ct + +-- --------------------------------------------------------------------- + astId :: (Typeable a) => a -> String astId a = show (typeOf a) +cua :: (Monad m, Monoid w) => CanUpdateAnchor -> EP w m [a] -> EP w m [a] +cua CanUpdateAnchor f = f +cua CanUpdateAnchorOnly _ = return [] +cua NoCanUpdateAnchor _ = return [] + -- | "Enter" an annotation, by using the associated 'anchor' field as -- the new reference point for calculating all DeltaPos positions. -- -- This is combination of the ghc=exactprint Delta.withAST and -- Print.exactPC functions and effectively does the delta processing -- immediately followed by the print processing. JIT ghc-exactprint. -enterAnn :: (ExactPrint a) => Entry -> a -> Annotated () +enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a enterAnn NoEntryVal a = do p <- getPosP - debugM $ "enterAnn:NO ANN:(p,a) =" ++ show (p, astId a) ++ " starting" - exact a - debugM $ "enterAnn:NO ANN:p =" ++ show (p, astId a) ++ " done" -enterAnn (Entry anchor' cs) a = do + debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a) + r <- exact a + debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a) + return r +enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do p <- getPosP - debugM $ "enterAnn:(p,a) =" ++ show (p, astId a) ++ " starting" + debugM $ "enterAnn:starting:(p,a) =" ++ show (p, astId a) + -- debugM $ "enterAnn:(cs) =" ++ showGhc (cs) let curAnchor = anchor anchor' -- As a base for the current AST element debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor) + case canUpdateAnchor of + CanUpdateAnchor -> pushAppliedComments + _ -> return () addCommentsA (priorComments cs) + debugM $ "enterAnn:Added comments" printComments curAnchor + priorCs <- cua canUpdateAnchor takeAppliedComments -- no pop -- ------------------------- case anchor_op anchor' of MovedAnchor dp -> do debugM $ "enterAnn: MovedAnchor:" ++ show dp -- Set the original anchor as prior end, so the rest of this AST -- fragment has a reference - -- BUT: this means the entry DP can be calculated incorrectly too, - -- for immediately nested items. setPriorEndNoLayoutD (ss2pos curAnchor) _ -> do return () -- ------------------------- - setAnchorU curAnchor + if ((fst $ fst $ rs2range curAnchor) >= 0) + then + setAnchorU curAnchor + else + debugM $ "enterAnn: not calling setAnchorU for : " ++ show (rs2range curAnchor) + -- ------------------------------------------------------------------- + -- Make sure the running dPriorEndPosition gets updated according to + -- the change in the current anchor. + + -- Compute the distance from dPriorEndPosition to the start of the new span. + + -- While processing in the context of the prior anchor, we choose to + -- enter a new Anchor, which has a defined position relative to the + -- prior anchor, even if we do not actively output anything at that + -- point. + -- Is this edp? + -- ------------------------------------------------------------------- -- The first part corresponds to the delta phase, so should only use - -- delta phase variables - -- ----------------------------------- + -- delta phase variables ----------------------------------- -- Calculate offset required to get to the start of the SrcSPan - off <- gets dLHS + off <- getLayoutOffsetD let spanStart = ss2pos curAnchor priorEndAfterComments <- getPriorEndD - let edp' = adjustDeltaForOffset 0 + let edp' = adjustDeltaForOffset -- Use the propagated offset if one is set -- Note that we need to use the new offset if it has -- changed. @@ -254,7 +332,7 @@ enterAnn (Entry anchor' cs) a = do -- list entry values to be DP (1,0) Just (Anchor r _) -> dp where - dp = adjustDeltaForOffset 0 + dp = adjustDeltaForOffset off (ss2delta priorEndAfterComments r) when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ show (med,edp) -- --------------------------------------------- @@ -265,23 +343,43 @@ enterAnn (Entry anchor' cs) a = do debugM $ "enterAnn: (anchor_op, curAnchor):" ++ show (anchor_op anchor', rs2range curAnchor) debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp) + p0 <- getPosP + d <- getPriorEndD + debugM $ "enterAnn: (posp, posd)=" ++ show (p0,d) -- end of delta phase processing -- ------------------------------------------------------------------- -- start of print phase processing - let - st = annNone { annEntryDelta = edp } - withOffset st (advance edp >> exact a) + let mflush = when (flush == FlushComments) $ do + debugM $ "flushing comments in enterAnn:" ++ showAst cs + flushComments (getFollowingComments cs ++ filterEofComment True (priorComments cs)) + + advance edp + a' <- exact a + mflush + + -- end of sub-Anchor processing, start of tail end processing + postCs <- cua canUpdateAnchor takeAppliedCommentsPop + when (flush == NoFlushComments) $ do + when ((getFollowingComments cs) /= []) $ do + debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs) + mapM_ printOneComment (map tokComment $ getFollowingComments cs) + debugM $ "ending trailing comments" - when ((getFollowingComments cs) /= []) $ do - debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs) - mapM_ printOneComment (map tokComment $ getFollowingComments cs) - debugM $ "ending trailing comments" + let newAchor = anchor' { anchor_op = MovedAnchor edp } + let r = case canUpdateAnchor of + CanUpdateAnchor -> setAnnotationAnchor a' newAchor (mkEpaComments (priorCs++ postCs) []) + CanUpdateAnchorOnly -> setAnnotationAnchor a' newAchor emptyComments + NoCanUpdateAnchor -> a' + -- debugM $ "calling setAnnotationAnchor:(curAnchor, newAchor,priorCs,postCs)=" ++ showAst (show (rs2range curAnchor), newAchor, priorCs, postCs) + -- debugM $ "calling setAnnotationAnchor:(newAchor,postCs)=" ++ showAst (newAchor, postCs) + debugM $ "enterAnn:done:(p,a) =" ++ show (p0, astId a') + return r -- --------------------------------------------------------------------- -addCommentsA :: [LEpaComment] -> EPP () +addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () addCommentsA csNew = addComments (map tokComment csNew) {- @@ -300,61 +398,67 @@ By definition it is the current anchor, so work against that. And that also means that the first entry comment that has moved should not have a line offset. -} -addComments :: [Comment] -> EPP () +addComments :: (Monad m, Monoid w) => [Comment] -> EP w m () addComments csNew = do - debugM $ "addComments:" ++ show csNew + -- debugM $ "addComments:" ++ show csNew cs <- getUnallocatedComments - -- Must compare without span filenames, for CPP injected comments with fake filename - let cmp (Comment _ l1 _) (Comment _ l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) - -- AZ:TODO: sortedlist? - putUnallocatedComments (sortBy cmp $ csNew ++ cs) + + putUnallocatedComments (sort (cs ++ csNew)) -- --------------------------------------------------------------------- -- | Just before we print out the EOF comments, flush the remaining -- ones in the state. -flushComments :: EPP () -flushComments = do +flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () +flushComments trailing = do + addCommentsA (filterEofComment False trailing) cs <- getUnallocatedComments - -- Must compare without span filenames, for CPP injected comments with fake filename - let cmp (Comment _ l1 _) (Comment _ l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) - mapM_ printOneComment (sortBy cmp cs) + debugM $ "flushing comments starting" + mapM_ printOneComment (sortComments cs) + debugM $ "flushing comments:EOF:trailing:" ++ showAst (trailing) + debugM $ "flushing comments:EOF:" ++ showAst (filterEofComment True trailing) + mapM_ printOneComment (map tokComment (filterEofComment True trailing)) + debugM $ "flushing comments done" + +filterEofComment :: Bool -> [LEpaComment] -> [LEpaComment] +filterEofComment keep cs = fixCs cs + where + notEof com = case com of + L _ (GHC.EpaComment (EpaEofComment) _) -> keep + _ -> not keep + fixCs c = filter notEof c -- --------------------------------------------------------------------- -- |In order to interleave annotations into the stream, we turn them into --- comments. -annotationsToComments :: [AddEpAnn] -> [AnnKeywordId] -> EPP () -annotationsToComments ans kws = do - let - getSpans _ [] = [] - getSpans k1 (AddEpAnn k2 ss:as) - | k1 == k2 = ss : getSpans k1 as - | otherwise = getSpans k1 as - doOne :: AnnKeywordId -> EPP [Comment] - doOne kw = do - let sps =getSpans kw ans - return $ concatMap (mkKWComment kw ) sps - -- TODO:AZ make sure these are sorted/merged properly when the invariant for - -- allocateComments is re-established. - newComments <- mapM doOne kws - addComments (concat newComments) +-- comments. They are removed from the annotation to avoid duplication. +annotationsToComments :: (Monad m, Monoid w) + => EpAnn a -> Lens a [AddEpAnn] -> [AnnKeywordId] -> EP w m (EpAnn a) +annotationsToComments EpAnnNotUsed _ _kws = return EpAnnNotUsed +annotationsToComments (EpAnn anc a cs) l kws = do + let (newComments, newAnns) = go ([],[]) (view l a) + addComments newComments + return (EpAnn anc (set l (reverse newAnns) a) cs) + where + keywords = Set.fromList kws -annotationsToCommentsA :: EpAnn [AddEpAnn] -> [AnnKeywordId] -> EPP () -annotationsToCommentsA EpAnnNotUsed _ = return () -annotationsToCommentsA an kws = annotationsToComments (anns an) kws + go :: ([Comment], [AddEpAnn]) -> [AddEpAnn] -> ([Comment], [AddEpAnn]) + go acc [] = acc + go (cs',ans) ((AddEpAnn k ss) : ls) + | Set.member k keywords = go ((mkKWComment k ss):cs', ans) ls + | otherwise = go (cs', (AddEpAnn k ss):ans) ls -- --------------------------------------------------------------------- -- Temporary function to simply reproduce the "normal" pretty printer output -withPpr :: (Outputable a) => a -> Annotated () +withPpr :: (Monad m, Monoid w, Outputable a) => a -> EP w m a withPpr a = do ss <- getAnchorU debugM $ "withPpr: ss=" ++ show ss - printStringAtKw' ss (showPprUnsafe a) + printStringAtRs' ss (showPprUnsafe a) + return a -- --------------------------------------------------------------------- --- Modeled on Outputable -- | An AST fragment with an annotation must be able to return the -- requirements for nesting another one, captured in an 'Entry', and @@ -363,331 +467,772 @@ withPpr a = do -- 'ppr'. class (Typeable a) => ExactPrint a where getAnnotationEntry :: a -> Entry - exact :: a -> Annotated () + setAnnotationAnchor :: a -> Anchor -> EpAnnComments -> a + exact :: (Monad m, Monoid w) => a -> EP w m a -- --------------------------------------------------------------------- +-- Start of utility functions +-- --------------------------------------------------------------------- --- | Bare Located elements are simply stripped off without further --- processing. -instance (ExactPrint a) => ExactPrint (Located a) where - getAnnotationEntry (L l _) = Entry (spanAsAnchor l) emptyComments - exact (L _ a) = markAnnotated a - -instance (ExactPrint a) => ExactPrint (LocatedA a) where - getAnnotationEntry = entryFromLocatedA - exact (L la a) = do - debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la) - markAnnotated a - markALocatedA (ann la) +printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m () +printSourceText (NoSourceText) txt = printStringAdvance txt >> return () +printSourceText (SourceText txt) _ = printStringAdvance txt >> return () -instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where - getAnnotationEntry = entryFromLocatedA - exact (L _ a) = markAnnotated a +-- --------------------------------------------------------------------- -instance (ExactPrint a) => ExactPrint [a] where - getAnnotationEntry = const NoEntryVal - exact ls = mapM_ markAnnotated ls +printStringAtSs :: (Monad m, Monoid w) => SrcSpan -> String -> EP w m () +printStringAtSs ss str = printStringAtRs (realSrcSpan ss) str >> return () -instance (ExactPrint a) => ExactPrint (NonEmpty a) where - getAnnotationEntry = const NoEntryVal - exact ls = mapM_ markAnnotated ls +printStringAtRs :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m EpaLocation +printStringAtRs pa str = printStringAtRsC CaptureComments pa str -instance (ExactPrint a) => ExactPrint (Maybe a) where - getAnnotationEntry = const NoEntryVal - exact Nothing = return () - exact (Just a) = markAnnotated a +printStringAtRsC :: (Monad m, Monoid w) + => CaptureComments -> RealSrcSpan -> String -> EP w m EpaLocation +printStringAtRsC capture pa str = do + debugM $ "printStringAtRsC: pa=" ++ showAst pa + printComments pa + pe <- getPriorEndD + debugM $ "printStringAtRsC:pe=" ++ show pe + let p = ss2delta pe pa + p' <- adjustDeltaForOffsetM p + debugM $ "printStringAtRsC:(p,p')=" ++ show (p,p') + printStringAtLsDelta p' str + setPriorEndASTD True pa + cs' <- case capture of + CaptureComments -> takeAppliedComments + NoCaptureComments -> return [] + debugM $ "printStringAtRsC:cs'=" ++ show cs' + debugM $ "printStringAtRsC:p'=" ++ showAst p' + debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' []) + debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta p' (map comment2LEpaComment cs')) + return (EpaDelta p' (map comment2LEpaComment cs')) + +printStringAtRs' :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m () +printStringAtRs' pa str = printStringAtRsC NoCaptureComments pa str >> return () + +-- --------------------------------------------------------------------- + +printStringAtMLoc' :: (Monad m, Monoid w) + => Maybe EpaLocation -> String -> EP w m (Maybe EpaLocation) +printStringAtMLoc' (Just aa) s = Just <$> printStringAtAA aa s +printStringAtMLoc' Nothing s = do + printStringAtLsDelta (SameLine 1) s + return (Just (EpaDelta (SameLine 1) [])) + +printStringAtMLocL :: (Monad m, Monoid w) + => EpAnn a -> Lens a (Maybe EpaLocation) -> String -> EP w m (EpAnn a) +printStringAtMLocL EpAnnNotUsed _ _ = return EpAnnNotUsed +printStringAtMLocL (EpAnn anc an cs) l s = do + r <- go (view l an) s + return (EpAnn anc (set l r an) cs) + where + go (Just aa) str = Just <$> printStringAtAA aa str + go Nothing str = do + printStringAtLsDelta (SameLine 1) str + return (Just (EpaDelta (SameLine 1) [])) + +printStringAtAA :: (Monad m, Monoid w) => EpaLocation -> String -> EP w m EpaLocation +printStringAtAA el str = printStringAtAAC CaptureComments el str + +printStringAtAAL :: (Monad m, Monoid w) + => EpAnn a -> Lens a EpaLocation -> String -> EP w m (EpAnn a) +printStringAtAAL EpAnnNotUsed _ _ = return EpAnnNotUsed +printStringAtAAL (EpAnn anc an cs) l str = do + r <- printStringAtAAC CaptureComments (view l an) str + return (EpAnn anc (set l r an) cs) + +printStringAtAAC :: (Monad m, Monoid w) + => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation +printStringAtAAC capture (EpaSpan r) s = printStringAtRsC capture r s +printStringAtAAC capture (EpaDelta d cs) s = do + mapM_ (printOneComment . tokComment) cs + pe1 <- getPriorEndD + p1 <- getPosP + printStringAtLsDelta d s + p2 <- getPosP + pe2 <- getPriorEndD + debugM $ "printStringAtAA:(pe1,pe2,p1,p2)=" ++ show (pe1,pe2,p1,p2) + setPriorEndASTPD True (pe1,pe2) + cs' <- case capture of + CaptureComments -> takeAppliedComments + NoCaptureComments -> return [] + debugM $ "printStringAtAA:(pe1,pe2,p1,p2,cs')=" ++ show (pe1,pe2,p1,p2,cs') + return (EpaDelta d (map comment2LEpaComment cs')) + +-- --------------------------------------------------------------------- + +markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m () +markExternalSourceText l NoSourceText txt = printStringAtRs (realSrcSpan l) txt >> return () +markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) txt >> return () + +-- --------------------------------------------------------------------- + +markLensMAA :: (Monad m, Monoid w) => EpAnn a -> Lens a (Maybe AddEpAnn) -> EP w m (EpAnn a) +markLensMAA EpAnnNotUsed _ = return EpAnnNotUsed +markLensMAA (EpAnn anc a cs) l = + case view l a of + Nothing -> return (EpAnn anc a cs) + Just aa -> do + aa' <- markAddEpAnn aa + return (EpAnn anc (set l (Just aa') a) cs) + +markLensAA :: (Monad m, Monoid w) => EpAnn a -> Lens a AddEpAnn -> EP w m (EpAnn a) +markLensAA EpAnnNotUsed _ = return EpAnnNotUsed +markLensAA (EpAnn anc a cs) l = do + a' <- markKw (view l a) + return (EpAnn anc (set l a' a) cs) + + +markEpAnnLMS :: (Monad m, Monoid w) + => EpAnn a -> Lens a [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a) +markEpAnnLMS an l kw Nothing = markEpAnnL an l kw +markEpAnnLMS EpAnnNotUsed _ _ _ = return EpAnnNotUsed +markEpAnnLMS (EpAnn anc a cs) l kw (Just str) = do + anns <- mapM go (view l a) + return (EpAnn anc (set l anns a) cs) + where + go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn + go (AddEpAnn kw' r) + | kw' == kw = do + r' <- printStringAtAA r str + return (AddEpAnn kw' r') + | otherwise = return (AddEpAnn kw' r) + +markEpAnnLMS' :: (Monad m, Monoid w) + => EpAnn a -> Lens a AddEpAnn -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a) +markEpAnnLMS' an l _kw Nothing = markLensKwA an l +markEpAnnLMS' EpAnnNotUsed _ _ _ = return EpAnnNotUsed +markEpAnnLMS' (EpAnn anc a cs) l kw (Just str) = do + anns <- go (view l a) + return (EpAnn anc (set l anns a) cs) + where + go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn + go (AddEpAnn kw' r) + | kw' == kw = do + r' <- printStringAtAA r str + return (AddEpAnn kw' r') + | otherwise = return (AddEpAnn kw' r) -- --------------------------------------------------------------------- --- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' -instance ExactPrint (HsModule GhcPs) where - getAnnotationEntry hsmod = fromAnn (hsmodAnn $ hsmodExt hsmod) +markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) + => LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs) +markToken (L NoTokenLoc t) = return (L NoTokenLoc t) +markToken (L (TokenLoc aa) t) = do + aa' <- printStringAtAA aa (symbolVal (Proxy @tok)) + return (L (TokenLoc aa') t) - exact hsmod@(HsModule (XModulePs EpAnnNotUsed _ _ _) _ _ _ _) = withPpr hsmod - exact (HsModule (XModulePs an _lo mdeprec mbDoc) mmn mexports imports decls) = do +markUniToken :: forall m w tok utok. (Monad m, Monoid w, KnownSymbol tok, KnownSymbol utok) + => LHsUniToken tok utok GhcPs -> EP w m (LHsUniToken tok utok GhcPs) +markUniToken (L l HsNormalTok) = do + (L l' _) <- markToken (L l (HsTok @tok)) + return (L l' HsNormalTok) +markUniToken (L l HsUnicodeTok) = do + (L l' _) <- markToken (L l (HsTok @utok)) + return (L l' HsUnicodeTok) - markAnnotated mbDoc +-- --------------------------------------------------------------------- - case mmn of - Nothing -> return () - Just (L ln mn) -> do - markEpAnn' an am_main AnnModule - markAnnotated (L ln mn) +markArrow :: (Monad m, Monoid w) => HsArrow GhcPs -> EP w m (HsArrow GhcPs) +markArrow (HsUnrestrictedArrow arr) = do + arr' <- markUniToken arr + return (HsUnrestrictedArrow arr') +markArrow (HsLinearArrow (HsPct1 pct1 arr)) = do + pct1' <- markToken pct1 + arr' <- markUniToken arr + return (HsLinearArrow (HsPct1 pct1' arr')) +markArrow (HsLinearArrow (HsLolly arr)) = do + arr' <- markToken arr + return (HsLinearArrow (HsLolly arr')) +markArrow (HsExplicitMult pct t arr) = do + pct' <- markToken pct + t' <- markAnnotated t + arr' <- markUniToken arr + return (HsExplicitMult pct' t' arr') + +-- --------------------------------------------------------------------- - -- forM_ mdeprec markLocated - setLayoutTopLevelP $ markAnnotated mdeprec +markAnnCloseP :: (Monad m, Monoid w) => EpAnn AnnPragma -> EP w m (EpAnn AnnPragma) +markAnnCloseP an = markEpAnnLMS' an lapr_close AnnClose (Just "#-}") - setLayoutTopLevelP $ markAnnotated mexports +markAnnOpenP :: (Monad m, Monoid w) => EpAnn AnnPragma -> SourceText -> String -> EP w m (EpAnn AnnPragma) +markAnnOpenP an NoSourceText txt = markEpAnnLMS' an lapr_open AnnOpen (Just txt) +markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just txt) - debugM $ "HsModule.AnnWhere coming" - setLayoutTopLevelP $ markEpAnn' an am_main AnnWhere +markAnnOpen :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> SourceText -> String -> EP w m (EpAnn [AddEpAnn]) +markAnnOpen an NoSourceText txt = markEpAnnLMS an lidl AnnOpen (Just txt) +markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just txt) - markAnnList' False (am_decls $ anns an) $ do - markTopLevelList imports - markTopLevelList decls +markAnnOpen' :: (Monad m, Monoid w) + => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation) +markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt +markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms txt - -- In the weird case of an empty file with comments, make sure - -- they print - flushComments +markAnnOpen'' :: (Monad m, Monoid w) + => EpaLocation -> SourceText -> String -> EP w m EpaLocation +markAnnOpen'' el NoSourceText txt = printStringAtAA el txt +markAnnOpen'' el (SourceText txt) _ = printStringAtAA el txt -- --------------------------------------------------------------------- +{- +data AnnParen + = AnnParen { + ap_adornment :: ParenType, + ap_open :: EpaLocation, + ap_close :: EpaLocation + } deriving (Data) +-} +markOpeningParen, markClosingParen :: (Monad m, Monoid w) => EpAnn AnnParen -> EP w m (EpAnn AnnParen) +markOpeningParen an = markParen an lfst +markClosingParen an = markParen an lsnd + +markParen :: (Monad m, Monoid w) => EpAnn AnnParen -> (forall a. Lens (a,a) a) -> EP w m (EpAnn AnnParen) +markParen EpAnnNotUsed _ = return (EpAnnNotUsed) +markParen (EpAnn anc (AnnParen pt o c) cs) l = do + loc' <- markKwA (view l $ kw pt) (view l (o, c)) + let (o',c') = set l loc' (o,c) + return (EpAnn anc (AnnParen pt o' c') cs) + where + kw AnnParens = (AnnOpenP, AnnCloseP) + kw AnnParensHash = (AnnOpenPH, AnnClosePH) + kw AnnParensSquare = (AnnOpenS, AnnCloseS) --- TODO:AZ: do we *need* the following, or can we capture it in the AST? --- | We can have a list with its own entry point defined. Create a --- data structure to capture this, for defining an ExactPrint instance -data AnnotatedList a = AnnotatedList (Maybe Anchor) a - deriving (Eq,Show) +-- --------------------------------------------------------------------- +-- Bare bones Optics +-- Base on From https://hackage.haskell.org/package/lens-tutorial-1.0.3/docs/Control-Lens-Tutorial.html -instance (ExactPrint a) => ExactPrint (AnnotatedList a) where - getAnnotationEntry (AnnotatedList (Just anc) _) = Entry anc (EpaComments []) - getAnnotationEntry (AnnotatedList Nothing _) = NoEntryVal +type Lens a b = forall f . Functor f => (b -> f b) -> (a -> f a) +type Getting a b = (b -> Const b b) -> (a -> Const b a) +type ASetter a b = (b -> Identity b) -> (a -> Identity a) - exact (AnnotatedList an ls) = do - debugM $ "AnnotatedList:an=" ++ show an - markAnnotatedWithLayout ls +view :: MonadReader s m => Getting s a -> m a +view l = Reader.asks (getConst . l Const) +{-# INLINE view #-} +over :: ASetter a b -> (b -> b) -> (a -> a) +over l f = runIdentity . l (Identity . f) +{-# INLINE over #-} --- --------------------------------------------------------------------- --- Start of utility functions --- --------------------------------------------------------------------- +set :: Lens a b -> b -> a -> a +set lens b = over lens (\_ -> b) +{-# INLINE set #-} -printSourceText :: SourceText -> String -> EPP () -printSourceText NoSourceText txt = printStringAdvance txt -printSourceText (SourceText txt) _ = printStringAdvance txt +{- +Question: How do I combine lenses? --- --------------------------------------------------------------------- +Answer: You compose them, using function composition (Yes, really!) -printStringAtRs :: RealSrcSpan -> String -> EPP () -printStringAtRs ss str = printStringAtKw' ss str +You can think of the function composition operator as having this type: -printStringAtSs :: SrcSpan -> String -> EPP () -printStringAtSs ss str = printStringAtKw' (realSrcSpan ss) str +(.) :: Lens' a b -> Lens' b c -> Lens' a c +-} -- --------------------------------------------------------------------- +-- Lenses --- AZ:TODO get rid of this -printStringAtMkw :: Maybe EpaLocation -> String -> EPP () -printStringAtMkw (Just aa) s = printStringAtAA aa s -printStringAtMkw Nothing s = printStringAtLsDelta (SameLine 1) s +-- data AnnsModule +-- = AnnsModule { +-- am_main :: [AddEpAnn], +-- am_decls :: AnnList +-- } deriving (Data, Eq) -printStringAtAnn :: EpAnn a -> (a -> EpaLocation) -> String -> EPP () -printStringAtAnn EpAnnNotUsed _ _ = return () -printStringAtAnn (EpAnn _ a _) f str = printStringAtAA (f a) str +lam_main :: Lens AnnsModule [AddEpAnn] +lam_main k annsModule = fmap (\newAnns -> annsModule { am_main = newAnns }) + (k (am_main annsModule)) -printStringAtAA :: EpaLocation -> String -> EPP () -printStringAtAA (EpaSpan r) s = printStringAtKw' r s -printStringAtAA (EpaDelta d cs) s = do - mapM_ (printOneComment . tokComment) cs - pe <- getPriorEndD - p1 <- getPosP - printStringAtLsDelta d s - p2 <- getPosP - debugM $ "printStringAtAA:(pe,p1,p2)=" ++ show (pe,p1,p2) - setPriorEndASTPD True (p1,p2) +-- lam_decls :: Lens AnnsModule AnnList +-- lam_decls k annsModule = fmap (\newAnns -> annsModule { am_decls = newAnns }) +-- (k (am_decls annsModule)) --- Based on Delta.addAnnotationWorker -printStringAtKw' :: RealSrcSpan -> String -> EPP () -printStringAtKw' pa str = do - printComments pa - pe <- getPriorEndD - debugM $ "printStringAtKw':pe=" ++ show pe - let p = ss2delta pe pa - p' <- adjustDeltaForOffsetM p - printStringAtLsDelta p' str - setPriorEndASTD True pa --- --------------------------------------------------------------------- +-- data EpAnnImportDecl = EpAnnImportDecl +-- { importDeclAnnImport :: EpaLocation +-- , importDeclAnnPragma :: Maybe (EpaLocation, EpaLocation) +-- , importDeclAnnSafe :: Maybe EpaLocation +-- , importDeclAnnQualified :: Maybe EpaLocation +-- , importDeclAnnPackage :: Maybe EpaLocation +-- , importDeclAnnAs :: Maybe EpaLocation +-- } deriving (Data) -markExternalSourceText :: SrcSpan -> SourceText -> String -> EPP () -markExternalSourceText l NoSourceText txt = printStringAtKw' (realSrcSpan l) txt -markExternalSourceText l (SourceText txt) _ = printStringAtKw' (realSrcSpan l) txt +limportDeclAnnImport :: Lens EpAnnImportDecl EpaLocation +limportDeclAnnImport k annImp = fmap (\new -> annImp { importDeclAnnImport = new }) + (k (importDeclAnnImport annImp)) --- --------------------------------------------------------------------- +-- limportDeclAnnPragma :: Lens EpAnnImportDecl (Maybe (EpaLocation, EpaLocation)) +-- limportDeclAnnPragma k annImp = fmap (\new -> annImp { importDeclAnnPragma = new }) +-- (k (importDeclAnnPragma annImp)) -markAddEpAnn :: AddEpAnn -> EPP () -markAddEpAnn a@(AddEpAnn kw _) = mark [a] kw +limportDeclAnnSafe :: Lens EpAnnImportDecl (Maybe EpaLocation) +limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new }) + (k (importDeclAnnSafe annImp)) -markLocatedMAA :: EpAnn a -> (a -> Maybe AddEpAnn) -> EPP () -markLocatedMAA EpAnnNotUsed _ = return () -markLocatedMAA (EpAnn _ a _) f = - case f a of - Nothing -> return () - Just aa -> markAddEpAnn aa +limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe EpaLocation) +limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new }) + (k (importDeclAnnQualified annImp)) -markLocatedAA :: EpAnn a -> (a -> AddEpAnn) -> EPP () -markLocatedAA EpAnnNotUsed _ = return () -markLocatedAA (EpAnn _ a _) f = markKw (f a) +limportDeclAnnPackage :: Lens EpAnnImportDecl (Maybe EpaLocation) +limportDeclAnnPackage k annImp = fmap (\new -> annImp { importDeclAnnPackage = new }) + (k (importDeclAnnPackage annImp)) -markLocatedAAL :: EpAnn a -> (a -> [AddEpAnn]) -> AnnKeywordId -> EPP () -markLocatedAAL EpAnnNotUsed _ _ = return () -markLocatedAAL (EpAnn _ a _) f kw = go (f a) - where - go [] = return () - go (aa@(AddEpAnn kw' _):as) - | kw' == kw = mark [aa] kw - | otherwise = go as - -markLocatedAALS :: EpAnn a -> (a -> [AddEpAnn]) -> AnnKeywordId -> Maybe String -> EPP () -markLocatedAALS an f kw Nothing = markLocatedAAL an f kw -markLocatedAALS EpAnnNotUsed _ _ _ = return () -markLocatedAALS (EpAnn _ a _) f kw (Just str) = go (f a) - where - go [] = return () - go (AddEpAnn kw' r:as) - | kw' == kw = printStringAtAA r str - | otherwise = go as +-- limportDeclAnnAs :: Lens EpAnnImportDecl (Maybe EpaLocation) +-- limportDeclAnnAs k annImp = fmap (\new -> annImp { importDeclAnnAs = new }) +-- (k (importDeclAnnAs annImp)) --- --------------------------------------------------------------------- +-- ------------------------------------- -markArrow :: HsArrow GhcPs -> EPP () -markArrow (HsUnrestrictedArrow arr) = do - markUniToken arr -markArrow (HsLinearArrow (HsPct1 pct1 arr)) = do - markToken pct1 - markUniToken arr -markArrow (HsLinearArrow (HsLolly arr)) = do - markToken arr -markArrow (HsExplicitMult pct t arr) = do - markToken pct - markAnnotated t - markUniToken arr +-- data AnnList +-- = AnnList { +-- al_anchor :: Maybe Anchor, -- ^ start point of a list having layout +-- al_open :: Maybe AddEpAnn, +-- al_close :: Maybe AddEpAnn, +-- al_rest :: [AddEpAnn], -- ^ context, such as 'where' keyword +-- al_trailing :: [TrailingAnn] -- ^ items appearing after the +-- -- list, such as '=>' for a +-- -- context +-- } deriving (Data,Eq) + +lal_open :: Lens AnnList (Maybe AddEpAnn) +lal_open k parent = fmap (\new -> parent { al_open = new }) + (k (al_open parent)) + +lal_close :: Lens AnnList (Maybe AddEpAnn) +lal_close k parent = fmap (\new -> parent { al_close = new }) + (k (al_close parent)) + +lal_rest :: Lens AnnList [AddEpAnn] +lal_rest k parent = fmap (\new -> parent { al_rest = new }) + (k (al_rest parent)) + +lal_trailing :: Lens AnnList [TrailingAnn] +lal_trailing k parent = fmap (\new -> parent { al_trailing = new }) + (k (al_trailing parent)) --- --------------------------------------------------------------------- +-- ------------------------------------- -markAnnCloseP :: EpAnn AnnPragma -> EPP () -markAnnCloseP an = markLocatedAALS an (pure . apr_close) AnnClose (Just "#-}") +lapr_rest :: Lens AnnPragma [AddEpAnn] +lapr_rest k parent = fmap (\newAnns -> parent { apr_rest = newAnns }) + (k (apr_rest parent)) -markAnnOpenP :: EpAnn AnnPragma -> SourceText -> String -> EPP () -markAnnOpenP an NoSourceText txt = markLocatedAALS an (pure . apr_open) AnnOpen (Just txt) -markAnnOpenP an (SourceText txt) _ = markLocatedAALS an (pure . apr_open) AnnOpen (Just txt) +lapr_open :: Lens AnnPragma AddEpAnn +lapr_open k parent = fmap (\new -> parent { apr_open = new }) + (k (apr_open parent)) -markAnnOpen :: EpAnn [AddEpAnn] -> SourceText -> String -> EPP () -markAnnOpen an NoSourceText txt = markLocatedAALS an id AnnOpen (Just txt) -markAnnOpen an (SourceText txt) _ = markLocatedAALS an id AnnOpen (Just txt) +lapr_close :: Lens AnnPragma AddEpAnn +lapr_close k parent = fmap (\new -> parent { apr_close = new }) + (k (apr_close parent)) -markAnnOpen' :: Maybe EpaLocation -> SourceText -> String -> EPP () -markAnnOpen' ms NoSourceText txt = printStringAtMkw ms txt -markAnnOpen' ms (SourceText txt) _ = printStringAtMkw ms txt +lidl :: Lens [AddEpAnn] [AddEpAnn] +lidl k parent = fmap (\new -> new) + (k parent) --- --------------------------------------------------------------------- +lid :: Lens a a +lid k parent = fmap (\new -> new) + (k parent) -markOpeningParen, markClosingParen :: EpAnn AnnParen -> EPP () -markOpeningParen an = markParen an fst -markClosingParen an = markParen an snd +lfst :: Lens (a,a) a +lfst k parent = fmap (\new -> (new, snd parent)) + (k (fst parent)) -markParen :: EpAnn AnnParen -> (forall a. (a,a) -> a) -> EPP () -markParen EpAnnNotUsed _ = return () -markParen (EpAnn _ (AnnParen pt o c) _) f = markKwA (f $ kw pt) (f (o, c)) - where - kw AnnParens = (AnnOpenP, AnnCloseP) - kw AnnParensHash = (AnnOpenPH, AnnClosePH) - kw AnnParensSquare = (AnnOpenS, AnnCloseS) +lsnd :: Lens (a,a) a +lsnd k parent = fmap (\new -> (fst parent, new)) + (k (snd parent)) +-- ------------------------------------- +-- data AnnExplicitSum +-- = AnnExplicitSum { +-- aesOpen :: EpaLocation, +-- aesBarsBefore :: [EpaLocation], +-- aesBarsAfter :: [EpaLocation], +-- aesClose :: EpaLocation +-- } deriving Data + +laesOpen :: Lens AnnExplicitSum EpaLocation +laesOpen k parent = fmap (\new -> parent { aesOpen = new }) + (k (aesOpen parent)) + +laesBarsBefore :: Lens AnnExplicitSum [EpaLocation] +laesBarsBefore k parent = fmap (\new -> parent { aesBarsBefore = new }) + (k (aesBarsBefore parent)) + +laesBarsAfter :: Lens AnnExplicitSum [EpaLocation] +laesBarsAfter k parent = fmap (\new -> parent { aesBarsAfter = new }) + (k (aesBarsAfter parent)) + +laesClose :: Lens AnnExplicitSum EpaLocation +laesClose k parent = fmap (\new -> parent { aesClose = new }) + (k (aesClose parent)) -markAnnKw :: EpAnn a -> (a -> EpaLocation) -> AnnKeywordId -> EPP () -markAnnKw EpAnnNotUsed _ _ = return () -markAnnKw (EpAnn _ a _) f kw = markKwA kw (f a) +-- ------------------------------------- +-- data AnnFieldLabel +-- = AnnFieldLabel { +-- afDot :: Maybe EpaLocation +-- } deriving Data -markAnnKwAll :: EpAnn a -> (a -> [EpaLocation]) -> AnnKeywordId -> EPP () -markAnnKwAll EpAnnNotUsed _ _ = return () -markAnnKwAll (EpAnn _ a _) f kw = mapM_ (markKwA kw) (sortBy (comparing unsafeGetEpaLoc) (f a)) +lafDot :: Lens AnnFieldLabel (Maybe EpaLocation) +lafDot k parent = fmap (\new -> parent { afDot = new }) + (k (afDot parent)) -markAnnKwM :: EpAnn a -> (a -> Maybe EpaLocation) -> AnnKeywordId -> EPP () -markAnnKwM EpAnnNotUsed _ _ = return () -markAnnKwM (EpAnn _ a _) f kw = go (f a) - where - go Nothing = return () - go (Just s) = markKwA kw s +-- ------------------------------------- +-- data AnnProjection +-- = AnnProjection { +-- apOpen :: EpaLocation, -- ^ '(' +-- apClose :: EpaLocation -- ^ ')' +-- } deriving Data -markALocatedA :: EpAnn AnnListItem -> EPP () -markALocatedA EpAnnNotUsed = return () -markALocatedA (EpAnn _ a _) = markTrailing (lann_trailing a) +lapOpen :: Lens AnnProjection EpaLocation +lapOpen k parent = fmap (\new -> parent { apOpen = new }) + (k (apOpen parent)) -markEpAnn :: EpAnn [AddEpAnn] -> AnnKeywordId -> EPP () -markEpAnn EpAnnNotUsed _ = return () -markEpAnn (EpAnn _ a _) kw = mark a kw +lapClose :: Lens AnnProjection EpaLocation +lapClose k parent = fmap (\new -> parent { apClose = new }) + (k (apClose parent)) -markEpAnn' :: EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP () -markEpAnn' EpAnnNotUsed _ _ = return () -markEpAnn' (EpAnn _ a _) f kw = mark (f a) kw +-- ------------------------------------- +-- data AnnsIf +-- = AnnsIf { +-- aiIf :: EpaLocation, +-- aiThen :: EpaLocation, +-- aiElse :: EpaLocation, +-- aiThenSemi :: Maybe EpaLocation, +-- aiElseSemi :: Maybe EpaLocation +-- } deriving Data + +laiIf :: Lens AnnsIf EpaLocation +laiIf k parent = fmap (\new -> parent { aiIf = new }) + (k (aiIf parent)) + +laiThen :: Lens AnnsIf EpaLocation +laiThen k parent = fmap (\new -> parent { aiThen = new }) + (k (aiThen parent)) + +laiElse :: Lens AnnsIf EpaLocation +laiElse k parent = fmap (\new -> parent { aiElse = new }) + (k (aiElse parent)) + +laiThenSemi :: Lens AnnsIf (Maybe EpaLocation) +laiThenSemi k parent = fmap (\new -> parent { aiThenSemi = new }) + (k (aiThenSemi parent)) + +laiElseSemi :: Lens AnnsIf (Maybe EpaLocation) +laiElseSemi k parent = fmap (\new -> parent { aiElseSemi = new }) + (k (aiElseSemi parent)) -markEpAnnAll :: EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP () -markEpAnnAll EpAnnNotUsed _ _ = return () -markEpAnnAll (EpAnn _ a _) f kw = mapM_ markKw (sortBy (comparing unsafeGetEpAnnLoc) anns) - where - anns = filter (\(AddEpAnn ka _) -> ka == kw) (f a) +-- ------------------------------------- -unsafeGetEpAnnLoc :: AddEpAnn -> RealSrcSpan -unsafeGetEpAnnLoc (AddEpAnn _ ss) = unsafeGetEpaLoc ss +-- data AnnParen +-- = AnnParen { +-- ap_adornment :: ParenType, +-- ap_open :: EpaLocation, +-- ap_close :: EpaLocation +-- } deriving (Data) +-- lap_open :: Lens AnnParen EpaLocation +-- lap_open k parent = fmap (\new -> parent { ap_open = new }) +-- (k (ap_open parent)) -unsafeGetEpaLoc :: EpaLocation -> RealSrcSpan -unsafeGetEpaLoc (EpaSpan real) = real -unsafeGetEpaLoc (EpaDelta _ _) = error "DELTA" +-- lap_close :: Lens AnnParen EpaLocation +-- lap_close k parent = fmap (\new -> parent { ap_close = new }) +-- (k (ap_close parent)) -markAnnAll :: [AddEpAnn] -> AnnKeywordId -> EPP () -markAnnAll a kw = mapM_ markKw (sortBy (comparing unsafeGetEpAnnLoc) anns) - where - anns = filter (\(AddEpAnn ka _) -> ka == kw) a - -mark :: [AddEpAnn] -> AnnKeywordId -> EPP () -mark anns kw = do - case find (\(AddEpAnn k _) -> k == kw) anns of - Just aa -> markKw aa - Nothing -> case find (\(AddEpAnn k _) -> k == (unicodeAnn kw)) anns of - Just aau -> markKw aau - Nothing -> return () +-- ------------------------------------- +-- data EpAnnHsCase = EpAnnHsCase +-- { hsCaseAnnCase :: EpaLocation +-- , hsCaseAnnOf :: EpaLocation +-- , hsCaseAnnsRest :: [AddEpAnn] +-- } deriving Data + +lhsCaseAnnCase :: Lens EpAnnHsCase EpaLocation +lhsCaseAnnCase k parent = fmap (\new -> parent { hsCaseAnnCase = new }) + (k (hsCaseAnnCase parent)) + +lhsCaseAnnOf :: Lens EpAnnHsCase EpaLocation +lhsCaseAnnOf k parent = fmap (\new -> parent { hsCaseAnnOf = new }) + (k (hsCaseAnnOf parent)) + +lhsCaseAnnsRest :: Lens EpAnnHsCase [AddEpAnn] +lhsCaseAnnsRest k parent = fmap (\new -> parent { hsCaseAnnsRest = new }) + (k (hsCaseAnnsRest parent)) + +-- --------------------------------------------------------------------- + +-- data HsRuleAnn +-- = HsRuleAnn +-- { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn) +-- -- ^ The locations of 'forall' and '.' for forall'd type vars +-- -- Using AddEpAnn to capture possible unicode variants +-- , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn) +-- -- ^ The locations of 'forall' and '.' for forall'd term vars +-- -- Using AddEpAnn to capture possible unicode variants +-- , ra_rest :: [AddEpAnn] +-- } deriving (Data, Eq) + +lra_tyanns :: Lens HsRuleAnn (Maybe (AddEpAnn, AddEpAnn)) +lra_tyanns k parent = fmap (\new -> parent { ra_tyanns = new }) + (k (ra_tyanns parent)) + +ff :: Maybe (a,b) -> (Maybe a,Maybe b) +ff Nothing = (Nothing, Nothing) +ff (Just (a,b)) = (Just a, Just b) -markKwT :: TrailingAnn -> EPP () -markKwT (AddSemiAnn ss) = markKwA AnnSemi ss -markKwT (AddCommaAnn ss) = markKwA AnnComma ss -markKwT (AddVbarAnn ss) = markKwA AnnVbar ss -markKw :: AddEpAnn -> EPP () -markKw (AddEpAnn kw ss) = markKwA kw ss +gg :: (Maybe a,Maybe b) -> Maybe (a,b) +gg (Nothing, Nothing) = Nothing +gg (Just a, Just b) = Just (a,b) +gg _ = error "gg:expecting two Nothing or two Just" --- | This should be the main driver of the process, managing comments -markKwA :: AnnKeywordId -> EpaLocation -> EPP () -markKwA kw aa = printStringAtAA aa (keywordToString (G kw)) +lff :: Lens (Maybe (a,b)) (Maybe a,Maybe b) +lff k parent = fmap (\new -> gg new) + (k (ff parent)) -markToken :: forall tok. KnownSymbol tok => LHsToken tok GhcPs -> EPP () -markToken (L NoTokenLoc _) = return () -markToken (L (TokenLoc aa) _) = printStringAtAA aa (symbolVal (Proxy @tok)) +-- (.) :: Lens' a b -> Lens' b c -> Lens' a c +lra_tyanns_fst :: Lens HsRuleAnn (Maybe AddEpAnn) +lra_tyanns_fst = lra_tyanns . lff . lfst + +lra_tyanns_snd :: Lens HsRuleAnn (Maybe AddEpAnn) +lra_tyanns_snd = lra_tyanns . lff . lsnd + +lra_tmanns :: Lens HsRuleAnn (Maybe (AddEpAnn, AddEpAnn)) +lra_tmanns k parent = fmap (\new -> parent { ra_tmanns = new }) + (k (ra_tmanns parent)) + +lra_tmanns_fst :: Lens HsRuleAnn (Maybe AddEpAnn) +lra_tmanns_fst = lra_tmanns . lff . lfst + +lra_tmanns_snd :: Lens HsRuleAnn (Maybe AddEpAnn) +lra_tmanns_snd = lra_tmanns . lff . lsnd + +lra_rest :: Lens HsRuleAnn [AddEpAnn] +lra_rest k parent = fmap (\new -> parent { ra_rest = new }) + (k (ra_rest parent)) -markUniToken :: forall tok utok. (KnownSymbol tok, KnownSymbol utok) => LHsUniToken tok utok GhcPs -> EPP () -markUniToken (L l HsNormalTok) = markToken (L l (HsTok @tok)) -markUniToken (L l HsUnicodeTok) = markToken (L l (HsTok @utok)) -- --------------------------------------------------------------------- +-- data GrhsAnn +-- = GrhsAnn { +-- ga_vbar :: Maybe EpaLocation, -- TODO:AZ do we need this? +-- ga_sep :: AddEpAnn -- ^ Match separator location +-- } deriving (Data) -markAnnList :: Bool -> EpAnn AnnList -> EPP () -> EPP () -markAnnList _ EpAnnNotUsed action = action -markAnnList reallyTrail (EpAnn _ ann _) action = markAnnList' reallyTrail ann action +lga_vbar :: Lens GrhsAnn (Maybe EpaLocation) +lga_vbar k parent = fmap (\new -> parent { ga_vbar = new }) + (k (ga_vbar parent)) -markAnnList' :: Bool -> AnnList -> EPP () -> EPP () -markAnnList' reallyTrail ann action = do - p <- getPosP - debugM $ "markAnnList : " ++ showPprUnsafe (p, ann) - mapM_ markAddEpAnn (al_open ann) - unless reallyTrail $ markTrailing (al_trailing ann) -- Only makes sense for HsModule. - markAnnAll (sortBy (comparing unsafeGetEpAnnLoc) $ al_rest ann) AnnSemi - action - mapM_ markAddEpAnn (al_close ann) - debugM $ "markAnnList: calling markTrailing with:" ++ showPprUnsafe (al_trailing ann) - when reallyTrail $ markTrailing (al_trailing ann) -- normal case +lga_sep :: Lens GrhsAnn AddEpAnn +lga_sep k parent = fmap (\new -> parent { ga_sep = new }) + (k (ga_sep parent)) -- --------------------------------------------------------------------- +-- data AnnSig +-- = AnnSig { +-- asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option +-- asRest :: [AddEpAnn] +-- } deriving Data + +lasDcolon :: Lens AnnSig AddEpAnn +lasDcolon k parent = fmap (\new -> parent { asDcolon = new }) + (k (asDcolon parent)) + +lasRest :: Lens AnnSig [AddEpAnn] +lasRest k parent = fmap (\new -> parent { asRest = new }) + (k (asRest parent)) + +-- --------------------------------------------------------------------- +-- data EpAnnSumPat = EpAnnSumPat +-- { sumPatParens :: [AddEpAnn] +-- , sumPatVbarsBefore :: [EpaLocation] +-- , sumPatVbarsAfter :: [EpaLocation] +-- } deriving Data + +lsumPatParens :: Lens EpAnnSumPat [AddEpAnn] +lsumPatParens k parent = fmap (\new -> parent { sumPatParens = new }) + (k (sumPatParens parent)) + +lsumPatVbarsBefore :: Lens EpAnnSumPat [EpaLocation] +lsumPatVbarsBefore k parent = fmap (\new -> parent { sumPatVbarsBefore = new }) + (k (sumPatVbarsBefore parent)) -printComments :: RealSrcSpan -> EPP () +lsumPatVbarsAfter :: Lens EpAnnSumPat [EpaLocation] +lsumPatVbarsAfter k parent = fmap (\new -> parent { sumPatVbarsAfter = new }) + (k (sumPatVbarsAfter parent)) + +-- End of lenses +-- --------------------------------------------------------------------- + +markLensKwA :: (Monad m, Monoid w) + => EpAnn a -> Lens a AddEpAnn -> EP w m (EpAnn a) +markLensKwA EpAnnNotUsed _ = return EpAnnNotUsed +markLensKwA (EpAnn anc a cs) l = do + loc <- markKw (view l a) + return (EpAnn anc (set l loc a) cs) + +markLensKw :: (Monad m, Monoid w) + => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a) +markLensKw EpAnnNotUsed _ _ = return EpAnnNotUsed +markLensKw (EpAnn anc a cs) l kw = do + loc <- markKwA kw (view l a) + return (EpAnn anc (set l loc a) cs) + +markAnnKwL :: (Monad m, Monoid w) + => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a) +markAnnKwL = markLensKw + +markAnnKwAllL :: (Monad m, Monoid w) + => EpAnn a -> Lens a [EpaLocation] -> AnnKeywordId -> EP w m (EpAnn a) +markAnnKwAllL EpAnnNotUsed _ _ = return EpAnnNotUsed +markAnnKwAllL (EpAnn anc a cs) l kw = do + anns <- mapM (markKwA kw) (view l a) + return (EpAnn anc (set l anns a) cs) + +markLensKwM :: (Monad m, Monoid w) + => EpAnn a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m (EpAnn a) +markLensKwM EpAnnNotUsed _ _ = return EpAnnNotUsed +markLensKwM (EpAnn anc a cs) l kw = do + new <- go (view l a) + return (EpAnn anc (set l new a) cs) + where + go Nothing = return Nothing + go (Just s) = Just <$> markKwA kw s + +-- --------------------------------------------------------------------- + +markALocatedA :: (Monad m, Monoid w) => EpAnn AnnListItem -> EP w m (EpAnn AnnListItem) +markALocatedA EpAnnNotUsed = return EpAnnNotUsed +markALocatedA (EpAnn anc a cs) = do + t <- markTrailing (lann_trailing a) + return (EpAnn anc (a { lann_trailing = t }) cs) + +markEpAnnL :: (Monad m, Monoid w) + => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann) +markEpAnnL EpAnnNotUsed _ _ = return EpAnnNotUsed +markEpAnnL (EpAnn anc a cs) l kw = do + anns <- mark' (view l a) kw + return (EpAnn anc (set l anns a) cs) + +markEpAnnAllL :: (Monad m, Monoid w) + => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann) +markEpAnnAllL EpAnnNotUsed _ _ = return EpAnnNotUsed +markEpAnnAllL (EpAnn anc a cs) l kw = do + anns <- mapM doit (view l a) + return (EpAnn anc (set l anns a) cs) + where + doit an@(AddEpAnn ka _) + = if ka == kw + then markKw an + else return an + +markAddEpAnn :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn +markAddEpAnn a@(AddEpAnn kw _) = do + r <- mark' [a] kw + case r of + [a'] -> return a' + _ -> error "Should not happen: markAddEpAnn" + +mark' :: (Monad m, Monoid w) => [AddEpAnn] -> AnnKeywordId -> EP w m [AddEpAnn] +mark' anns kw = do + case find' kw anns of + (lead, Just aa, end) -> do + aa' <- markKw aa + return (lead ++ [aa'] ++ end) + (_lead, Nothing, _end) -> case find' (unicodeAnn kw) anns of + (leadu, Just aau, endu) -> do + aau' <- markKw aau + return (leadu ++ [aau'] ++ endu) + (_,Nothing,_) -> return anns + +-- | Find for update, returning lead section of the list, item if +-- found, and tail of the list +find' :: AnnKeywordId -> [AddEpAnn] -> ([AddEpAnn], Maybe AddEpAnn, [AddEpAnn]) +find' kw anns = (lead, middle, end) + where + (lead, rest) = break (\(AddEpAnn k _) -> k == kw) anns + (middle,end) = case rest of + [] -> (Nothing, []) + (x:xs) -> (Just x, xs) + +markKw :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn +markKw an = markKwC CaptureComments an + +markKwC :: (Monad m, Monoid w) => CaptureComments -> AddEpAnn -> EP w m AddEpAnn +markKwC capture (AddEpAnn kw ss) = do + ss' <- markKwAC capture kw ss + return (AddEpAnn kw ss') + +-- | This should be the main driver of the process, managing printing keywords. +-- It returns the 'EpaDelta' variant of the passed in 'EpaLocation' +markKwA :: (Monad m, Monoid w) => AnnKeywordId -> EpaLocation -> EP w m EpaLocation +markKwA kw aa = markKwAC CaptureComments kw aa + +markKwAC :: (Monad m, Monoid w) + => CaptureComments -> AnnKeywordId -> EpaLocation -> EP w m EpaLocation +markKwAC capture kw aa = printStringAtAAC capture aa (keywordToString kw) + +-- | Print a keyword encoded in a 'TrailingAnn' +markKwT :: (Monad m, Monoid w) => TrailingAnn -> EP w m TrailingAnn +markKwT (AddSemiAnn ss) = AddSemiAnn <$> markKwA AnnSemi ss +markKwT (AddCommaAnn ss) = AddCommaAnn <$> markKwA AnnComma ss +markKwT (AddVbarAnn ss) = AddVbarAnn <$> markKwA AnnVbar ss + +-- --------------------------------------------------------------------- + +markAnnList :: (Monad m, Monoid w) + => Bool -> EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a) +markAnnList reallyTrail ann action = do + markAnnListA reallyTrail ann $ \a -> do + r <- action + return (a,r) + +markAnnListA :: (Monad m, Monoid w) + => Bool -> EpAnn AnnList + -> (EpAnn AnnList -> EP w m (EpAnn AnnList, a)) + -> EP w m (EpAnn AnnList, a) +markAnnListA _ EpAnnNotUsed action = do + action EpAnnNotUsed +markAnnListA reallyTrail an action = do + debugM $ "markAnnListA: an=" ++ showAst an + an0 <- markLensMAA an lal_open + an1 <- if (not reallyTrail) + then markTrailingL an0 lal_trailing + else return an0 + an2 <- markEpAnnAllL an1 lal_rest AnnSemi + (an3, r) <- action an2 + an4 <- markLensMAA an3 lal_close + an5 <- if reallyTrail + then markTrailingL an4 lal_trailing + else return an4 + debugM $ "markAnnListA: an5=" ++ showAst an + return (an5, r) + + +markAnnList' :: (Monad m, Monoid w) + => Bool -> EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a) +markAnnList' reallyTrail an action = do + p <- getPosP + debugM $ "markAnnList : " ++ showPprUnsafe (p, an) + an0 <- markLensMAA an lal_open + an1 <- if (not reallyTrail) + then markTrailingL an0 lal_trailing + else return an0 + an2 <- markEpAnnAllL an1 lal_rest AnnSemi + r <- action + an3 <- markLensMAA an2 lal_close + an4 <- if reallyTrail + then markTrailingL an3 lal_trailing + else return an3 + return (an4, r) + +-- --------------------------------------------------------------------- + +printComments :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () printComments ss = do cs <- commentAllocation ss + debugM $ "printComments: (ss): " ++ showPprUnsafe (rs2range ss) -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs) mapM_ printOneComment cs -- --------------------------------------------------------------------- -printOneComment :: Comment -> EPP () -printOneComment c@(Comment _str loc _mo) = do +printOneComment :: (Monad m, Monoid w) => Comment -> EP w m () +printOneComment c@(Comment _str loc _r _mo) = do debugM $ "printOneComment:c=" ++ showGhc c dp <-case anchor_op loc of MovedAnchor dp -> return dp @@ -695,48 +1240,172 @@ printOneComment c@(Comment _str loc _mo) = do pe <- getPriorEndD let dp = ss2delta pe (anchor loc) debugM $ "printOneComment:(dp,pe,anchor loc)=" ++ showGhc (dp,pe,ss2pos $ anchor loc) - return dp - dp'' <- adjustDeltaForOffsetM dp + adjustDeltaForOffsetM dp mep <- getExtraDP dp' <- case mep of Just (Anchor _ (MovedAnchor edp)) -> do debugM $ "printOneComment:edp=" ++ show edp - return edp - _ -> return dp'' - LayoutStartCol dOff <- gets dLHS - debugM $ "printOneComment:(dp,dp',dp'',dOff)=" ++ showGhc (dp,dp',dp'',dOff) - setPriorEndD (ss2posEnd (anchor loc)) + ddd <- fmap unTweakDelta $ adjustDeltaForOffsetM edp + debugM $ "printOneComment:ddd=" ++ show ddd + fmap unTweakDelta $ adjustDeltaForOffsetM edp + _ -> return dp + -- Start of debug printing + -- LayoutStartCol dOff <- getLayoutOffsetD + -- debugM $ "printOneComment:(dp,dp',dOff)=" ++ showGhc (dp,dp',dOff) + -- End of debug printing + -- setPriorEndD (ss2posEnd (anchor loc)) + updateAndApplyComment c dp' printQueuedComment (anchor loc) c dp' --- --------------------------------------------------------------------- +-- | For comment-related deltas starting on a new line we have an +-- off-by-one problem. Adjust +unTweakDelta :: DeltaPos -> DeltaPos +unTweakDelta (SameLine d) = SameLine d +unTweakDelta (DifferentLine l d) = DifferentLine l (d+1) + -commentAllocation :: RealSrcSpan -> EPP [Comment] +updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () +updateAndApplyComment (Comment str anc pp mo) dp = do + -- debugM $ "updateAndApplyComment: (dp,anc',co)=" ++ showAst (dp,anc',co) + applyComment (Comment str anc' pp mo) + where + anc' = anc { anchor_op = op} + + (r,c) = ss2posEnd pp + la = anchor anc + dp'' = if r == 0 + then (ss2delta (r,c+0) la) + else (ss2delta (r,c) la) + dp' = if pp == anchor anc + then dp + else dp'' + op' = case dp' of + SameLine n -> if n >= 0 + then MovedAnchor dp' + else MovedAnchor dp + _ -> MovedAnchor dp' + op = if str == "" && op' == MovedAnchor (SameLine 0) -- EOF comment + then MovedAnchor dp + -- else op' + else MovedAnchor dp + +-- --------------------------------------------------------------------- + +commentAllocation :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment] commentAllocation ss = do cs <- getUnallocatedComments -- Note: The CPP comment injection may change the file name in the -- RealSrcSpan, which affects comparison, as the Ord instance for -- RealSrcSpan compares the file first. So we sort via ss2pos -- TODO: this is inefficient, use Pos all the way through - let (earlier,later) = partition (\(Comment _str loc _mo) -> (ss2pos $ anchor loc) <= (ss2pos ss)) cs + let (earlier,later) = partition (\(Comment _str loc _r _mo) -> (ss2pos $ anchor loc) <= (ss2pos ss)) cs putUnallocatedComments later -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) return earlier -- --------------------------------------------------------------------- - -markAnnotatedWithLayout :: ExactPrint ast => ast -> EPP () +markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a -- --------------------------------------------------------------------- -markTopLevelList :: ExactPrint ast => [ast] -> EPP () -markTopLevelList ls = mapM_ (\a -> setLayoutTopLevelP $ markAnnotated a) ls +markTopLevelList :: (Monad m, Monoid w) => ExactPrint ast => [ast] -> EP w m [ast] +markTopLevelList ls = mapM (\a -> setLayoutTopLevelP $ markAnnotated a) ls + +-- --------------------------------------------------------------------- +-- End of utility functions +-- --------------------------------------------------------------------- +-- Start of ExactPrint instances +-- --------------------------------------------------------------------- + +-- | Bare Located elements are simply stripped off without further +-- processing. +instance (ExactPrint a) => ExactPrint (Located a) where + getAnnotationEntry (L l _) = case l of + UnhelpfulSpan _ -> NoEntryVal + _ -> Entry (hackSrcSpanToAnchor l) emptyComments NoFlushComments CanUpdateAnchorOnly + + setAnnotationAnchor (L _ a) anc _cs = (L (hackAnchorToSrcSpan anc) a) + `debug` ("setAnnotationAnchor(Located):" ++ showAst anc) + + exact (L l a) = L l <$> markAnnotated a + +instance (ExactPrint a) => ExactPrint (LocatedA a) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor la anc cs = setAnchorAn la anc cs + exact (L la a) = do + debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la) + a' <- markAnnotated a + ann' <- markALocatedA (ann la) + return (L (la { ann = ann'}) a') + +instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor la anc cs = setAnchorAn la anc cs + exact (L la a) = do + a' <- markAnnotated a + return (L la a') + +instance (ExactPrint a) => ExactPrint [a] where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor ls _ _ = ls + exact ls = mapM markAnnotated ls + +instance (ExactPrint a) => ExactPrint (Maybe a) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor ma _ _ = ma + exact ma = mapM markAnnotated ma + +-- --------------------------------------------------------------------- + +-- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' +instance ExactPrint (HsModule GhcPs) where + getAnnotationEntry hsmod = fromAnn' (hsmodAnn $ hsmodExt hsmod) + -- A bit pointless actually changing anything here + setAnnotationAnchor hsmod anc cs = setAnchorHsModule hsmod anc cs + `debug` ("setAnnotationAnchor hsmod called" ++ showAst (anc,cs)) + + exact hsmod@(HsModule {hsmodExt = XModulePs { hsmodAnn = EpAnnNotUsed }}) = withPpr hsmod >> return hsmod + exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do + + mbDoc' <- markAnnotated mbDoc + + (an0, mmn' , mdeprec', mexports') <- + case mmn of + Nothing -> return (an, mmn, mdeprec, mexports) + Just m -> do + an0 <- markEpAnnL an lam_main AnnModule + m' <- markAnnotated m + + mdeprec' <- setLayoutTopLevelP $ markAnnotated mdeprec + + mexports' <- setLayoutTopLevelP $ markAnnotated mexports + + an1 <- setLayoutTopLevelP $ markEpAnnL an0 lam_main AnnWhere + + return (an1, Just m', mdeprec', mexports') + + let ann_decls = EpAnn (entry an) (am_decls $ anns an0) emptyComments + (ann_decls', (decls', imports')) <- markAnnList' False ann_decls $ do + imports' <- markTopLevelList imports + decls' <- markTopLevelList decls + return (decls', imports') + let am_decls' = case ann_decls' of + EpAnnNotUsed -> (am_decls $ anns an0) + EpAnn _ r _ -> r + + let anf = an0 { anns = (anns an0) { am_decls = am_decls' }} + debugM $ "HsModule, anf=" ++ showAst anf + + return (HsModule (XModulePs anf lo mdeprec' mbDoc') mmn' mexports' imports' decls') -- --------------------------------------------------------------------- instance ExactPrint ModuleName where getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor n _anc cs = n + `debug` ("ModuleName.setAnnotationAnchor:cs=" ++ showAst cs) exact n = do debugM $ "ModuleName: " ++ showPprUnsafe n withPpr n @@ -745,76 +1414,113 @@ instance ExactPrint ModuleName where instance ExactPrint (LocatedP (WarningTxt GhcPs)) where getAnnotationEntry = entryFromLocatedA - exact (L (SrcSpanAnn an _) (WarningTxt (L _ src) ws)) = do - markAnnOpenP an src "{-# WARNING" - markLocatedAAL an apr_rest AnnOpenS - markAnnotated ws - markLocatedAAL an apr_rest AnnCloseS - markAnnCloseP an + setAnnotationAnchor = setAnchorAn - exact (L (SrcSpanAnn an _) (DeprecatedTxt (L _ src) ws)) = do - markAnnOpenP an src "{-# DEPRECATED" - markLocatedAAL an apr_rest AnnOpenS - markAnnotated ws - markLocatedAAL an apr_rest AnnCloseS - markAnnCloseP an + exact (L (SrcSpanAnn an l) (WarningTxt (L la src) ws)) = do + an0 <- markAnnOpenP an src "{-# WARNING" + an1 <- markEpAnnL an0 lapr_rest AnnOpenS + ws' <- markAnnotated ws + an2 <- markEpAnnL an1 lapr_rest AnnCloseS + an3 <- markAnnCloseP an2 + return (L (SrcSpanAnn an3 l) (WarningTxt (L la src) ws')) + + exact (L (SrcSpanAnn an l) (DeprecatedTxt (L ls src) ws)) = do + an0 <- markAnnOpenP an src "{-# DEPRECATED" + an1 <- markEpAnnL an0 lapr_rest AnnOpenS + ws' <- markAnnotated ws + an2 <- markEpAnnL an1 lapr_rest AnnCloseS + an3 <- markAnnCloseP an2 + return (L (SrcSpanAnn an3 l) (DeprecatedTxt (L ls src) ws')) -- --------------------------------------------------------------------- instance ExactPrint (ImportDecl GhcPs) where getAnnotationEntry idecl = fromAnn (ideclAnn $ ideclExt idecl) + setAnnotationAnchor idecl anc cs = idecl { ideclExt + = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc cs} } + exact x@(ImportDecl{ ideclExt = XImportDeclPass{ ideclAnn = EpAnnNotUsed } }) = withPpr x - exact (ImportDecl (XImportDeclPass ann@(EpAnn _ an _) msrc _impl) modname mpkg _src safeflag qualFlag mAs hiding) = do + exact (ImportDecl (XImportDeclPass ann msrc impl) + modname mpkg src safeflag qualFlag mAs hiding) = do - markAnnKw ann importDeclAnnImport AnnImport + ann0 <- markLensKw ann limportDeclAnnImport AnnImport + let (EpAnn _anc an _cs) = ann0 -- "{-# SOURCE" and "#-}" - case msrc of - SourceText _txt -> do - debugM $ "ImportDecl sourcetext" - let mo = fmap fst $ importDeclAnnPragma an - let mc = fmap snd $ importDeclAnnPragma an - markAnnOpen' mo msrc "{-# SOURCE" - printStringAtMkw mc "#-}" - NoSourceText -> return () - when safeflag (markAnnKwM ann importDeclAnnSafe AnnSafe) - case qualFlag of - QualifiedPre -- 'qualified' appears in prepositive position. - -> printStringAtMkw (importDeclAnnQualified an) "qualified" - _ -> return () - case mpkg of - RawPkgQual (StringLiteral src v _) -> - printStringAtMkw (importDeclAnnPackage an) (sourceTextToString src (show v)) - _ -> return () - - markAnnotated modname - - case qualFlag of - QualifiedPost -- 'qualified' appears in postpositive position. - -> printStringAtMkw (importDeclAnnQualified an) "qualified" - _ -> return () - - case mAs of - Nothing -> return () - Just mn -> do - printStringAtMkw (importDeclAnnAs an) "as" - markAnnotated mn - - case hiding of - Nothing -> return () - Just (_isHiding,lie) -> exact lie - -- markTrailingSemi + importDeclAnnPragma' <- + case msrc of + SourceText _txt -> do + debugM $ "ImportDecl sourcetext" + case importDeclAnnPragma an of + Just (mo, mc) -> do + mo' <- markAnnOpen'' mo msrc "{-# SOURCE" + mc' <- printStringAtAA mc "#-}" + return $ Just (mo', mc') + Nothing -> do + _ <- markAnnOpen' Nothing msrc "{-# SOURCE" + printStringAtLsDelta (SameLine 1) "#-}" + return Nothing + NoSourceText -> return (importDeclAnnPragma an) + ann1 <- if safeflag + then (markLensKwM ann0 limportDeclAnnSafe AnnSafe) + else return ann0 + ann2 <- + case qualFlag of + QualifiedPre -- 'qualified' appears in prepositive position. + -> printStringAtMLocL ann1 limportDeclAnnQualified "qualified" + _ -> return ann1 + ann3 <- + case mpkg of + RawPkgQual (StringLiteral src' v _) -> + printStringAtMLocL ann2 limportDeclAnnPackage (sourceTextToString src' (show v)) + _ -> return ann2 + modname' <- markAnnotated modname + + ann4 <- + case qualFlag of + QualifiedPost -- 'qualified' appears in postpositive position. + -> printStringAtMLocL ann3 limportDeclAnnQualified "qualified" + _ -> return ann3 + + (importDeclAnnAs', mAs') <- + case mAs of + Nothing -> return (importDeclAnnAs an, Nothing) + Just m0 -> do + a <- printStringAtMLoc' (importDeclAnnAs an) "as" + m'' <- markAnnotated m0 + return (a, Just m'') + + hiding' <- + case hiding of + Nothing -> return hiding + Just (isHiding,lie) -> do + lie' <- markAnnotated lie + return (Just (isHiding, lie')) + + let (EpAnn anc' an' cs') = ann4 + let an2 = an' { importDeclAnnAs = importDeclAnnAs' + , importDeclAnnPragma = importDeclAnnPragma' + } + + return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl) + modname' mpkg src safeflag qualFlag mAs' hiding') -- --------------------------------------------------------------------- instance ExactPrint HsDocString where getAnnotationEntry _ = NoEntryVal - exact = printStringAdvance . exactPrintHsDocString + setAnnotationAnchor a _ _ = a + exact ds = do + (printStringAdvance . exactPrintHsDocString) ds + return ds instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where getAnnotationEntry _ = NoEntryVal - exact = exact . hsDocString + setAnnotationAnchor a _ _ = a + exact (WithHsDocIdentifiers ds ids) = do + ds' <- exact ds + return (WithHsDocIdentifiers ds' ids) -- --------------------------------------------------------------------- @@ -834,20 +1540,24 @@ instance ExactPrint (HsDecl GhcPs) where getAnnotationEntry (DocD _ _) = NoEntryVal getAnnotationEntry (RoleAnnotD _ _) = NoEntryVal - exact (TyClD _ d) = markAnnotated d - exact (InstD _ d) = markAnnotated d - exact (DerivD _ d) = markAnnotated d - exact (ValD _ d) = markAnnotated d - exact (SigD _ d) = markAnnotated d - exact (KindSigD _ d) = markAnnotated d - exact (DefD _ d) = markAnnotated d - exact (ForD _ d) = markAnnotated d - exact (WarningD _ d) = markAnnotated d - exact (AnnD _ d) = markAnnotated d - exact (RuleD _ d) = markAnnotated d - exact (SpliceD _ d) = markAnnotated d - exact (DocD _ d) = markAnnotated d - exact (RoleAnnotD _ d) = markAnnotated d + -- We do not recurse, the generic traversal using this feature + -- should do that for us. + setAnnotationAnchor d _ _ = d + + exact (TyClD x d) = TyClD x <$> markAnnotated d + exact (InstD x d) = InstD x <$> markAnnotated d + exact (DerivD x d) = DerivD x <$> markAnnotated d + exact (ValD x d) = ValD x <$> markAnnotated d + exact (SigD x d) = SigD x <$> markAnnotated d + exact (KindSigD x d) = KindSigD x <$> markAnnotated d + exact (DefD x d) = DefD x <$> markAnnotated d + exact (ForD x d) = ForD x <$> markAnnotated d + exact (WarningD x d) = WarningD x <$> markAnnotated d + exact (AnnD x d) = AnnD x <$> markAnnotated d + exact (RuleD x d) = RuleD x <$> markAnnotated d + exact (SpliceD x d) = SpliceD x <$> markAnnotated d + exact (DocD x d) = DocD x <$> markAnnotated d + exact (RoleAnnotD x d) = RoleAnnotD x <$> markAnnotated d -- --------------------------------------------------------------------- @@ -856,29 +1566,74 @@ instance ExactPrint (InstDecl GhcPs) where getAnnotationEntry (DataFamInstD _ _) = NoEntryVal getAnnotationEntry (TyFamInstD _ _) = NoEntryVal - exact (ClsInstD _ cid) = markAnnotated cid - exact (DataFamInstD _ decl) = do - exactDataFamInstDecl noAnn TopLevel decl - exact (TyFamInstD _ eqn) = do - markAnnotated eqn + setAnnotationAnchor d _ _ = d + + + exact (ClsInstD a cid) = do + cid' <- markAnnotated cid + return (ClsInstD a cid') + exact (DataFamInstD a decl) = do + d' <- markAnnotated (DataFamInstDeclWithContext noAnn TopLevel decl) + return (DataFamInstD a (dc_d d')) + exact (TyFamInstD a eqn) = do + eqn' <- markAnnotated eqn + return (TyFamInstD a eqn') + +-- --------------------------------------------------------------------- + +data DataFamInstDeclWithContext + = DataFamInstDeclWithContext + { _dc_a :: EpAnn [AddEpAnn] + , _dc_f :: TopLevelFlag + , dc_d :: DataFamInstDecl GhcPs + } + +instance ExactPrint DataFamInstDeclWithContext where + getAnnotationEntry (DataFamInstDeclWithContext _ _ (DataFamInstDecl (FamEqn { feqn_ext = an}))) + = fromAnn an + setAnnotationAnchor (DataFamInstDeclWithContext a c (DataFamInstDecl fe)) anc cs + = (DataFamInstDeclWithContext a c (DataFamInstDecl (fe { feqn_ext = (setAnchorEpa (feqn_ext fe) anc cs)}))) + exact (DataFamInstDeclWithContext an c d) = do + debugM $ "starting DataFamInstDeclWithContext:an=" ++ showAst an + (an', d') <- exactDataFamInstDecl an c d + return (DataFamInstDeclWithContext an' c d') -- --------------------------------------------------------------------- -exactDataFamInstDecl :: EpAnn [AddEpAnn] -> TopLevelFlag -> (DataFamInstDecl GhcPs) -> EPP () +exactDataFamInstDecl :: (Monad m, Monoid w) + => EpAnn [AddEpAnn] -> TopLevelFlag -> DataFamInstDecl GhcPs + -> EP w m (EpAnn [AddEpAnn], DataFamInstDecl GhcPs) exactDataFamInstDecl an top_lvl - (DataFamInstDecl ( FamEqn { feqn_ext = an2 - , feqn_tycon = tycon - , feqn_bndrs = bndrs - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = defn })) - = exactDataDefn an2 pp_hdr defn -- See Note [an and an2 in exactDataFamInstDecl] + (DataFamInstDecl (FamEqn { feqn_ext = an2 + , feqn_tycon = tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = defn })) = do + (an', an2', tycon', bndrs', _, _mc, defn') <- exactDataDefn an2 pp_hdr defn + -- See Note [an and an2 in exactDataFamInstDecl] + return + (an', + DataFamInstDecl ( FamEqn { feqn_ext = an2' + , feqn_tycon = tycon' + , feqn_bndrs = bndrs' + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = defn' })) + `debug` ("exactDataFamInstDecl: defn' derivs:" ++ showAst (dd_derivs defn')) where + pp_hdr :: (Monad m, Monoid w) + => Maybe (LHsContext GhcPs) + -> EP w m ( EpAnn [AddEpAnn] + , LocatedN RdrName + , HsOuterTyVarBndrs () GhcPs + , HsTyPats GhcPs + , Maybe (LHsContext GhcPs)) pp_hdr mctxt = do - case top_lvl of - TopLevel -> markEpAnn an AnnInstance -- TODO: maybe in toplevel - NotTopLevel -> return () - exactHsFamInstLHS an tycon bndrs pats fixity mctxt + an0 <- case top_lvl of + TopLevel -> markEpAnnL an lidl AnnInstance -- TODO: maybe in toplevel + NotTopLevel -> return an + exactHsFamInstLHS an0 tycon bndrs pats fixity mctxt {- Note [an and an2 in exactDataFamInstDecl] @@ -894,31 +1649,16 @@ rendering the DataDefn are contained in the FamEqn, and are called -- --------------------------------------------------------------------- -exactTyFamInstDecl :: TopLevelFlag -> (TyFamInstDecl GhcPs) -> EPP () -exactTyFamInstDecl top_lvl (TyFamInstDecl { tfid_xtn = an, tfid_eqn = eqn }) = do - markEpAnn an AnnType - case top_lvl of - TopLevel -> markEpAnn an AnnInstance - NotTopLevel -> return () - markAnnotated eqn - --- --------------------------------------------------------------------- - instance ExactPrint (DerivDecl GhcPs) where getAnnotationEntry (DerivDecl {deriv_ext = an} ) = fromAnn an + setAnnotationAnchor dd anc cs = dd { deriv_ext = setAnchorEpa (deriv_ext dd) anc cs } exact (DerivDecl an typ ms mov) = do - markEpAnn an AnnDeriving - mapM_ markAnnotated ms - markEpAnn an AnnInstance - mapM_ markAnnotated mov - markAnnotated typ - -- markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do - -- mark GHC.AnnDeriving - -- markMaybe ms - -- mark GHC.AnnInstance - -- markMaybe mov - -- markLocated typ - -- markTrailingSemi + an0 <- markEpAnnL an lidl AnnDeriving + ms' <- mapM markAnnotated ms + an1 <- markEpAnnL an0 lidl AnnInstance + mov' <- mapM markAnnotated mov + typ' <- markAnnotated typ + return (DerivDecl an1 typ' ms' mov') -- --------------------------------------------------------------------- @@ -926,397 +1666,452 @@ instance ExactPrint (ForeignDecl GhcPs) where getAnnotationEntry (ForeignImport an _ _ _) = fromAnn an getAnnotationEntry (ForeignExport an _ _ _) = fromAnn an + setAnnotationAnchor (ForeignImport an a b c) anc cs = ForeignImport (setAnchorEpa an anc cs) a b c + setAnnotationAnchor (ForeignExport an a b c) anc cs = ForeignExport (setAnchorEpa an anc cs) a b c + exact (ForeignImport an n ty fimport) = do - markEpAnn an AnnForeign - markEpAnn an AnnImport + an0 <- markEpAnnL an lidl AnnForeign + an1 <- markEpAnnL an0 lidl AnnImport - markAnnotated fimport + fimport' <- markAnnotated fimport - markAnnotated n - markEpAnn an AnnDcolon - markAnnotated ty + n' <- markAnnotated n + an2 <- markEpAnnL an1 lidl AnnDcolon + ty' <- markAnnotated ty + return (ForeignImport an2 n' ty' fimport') exact (ForeignExport an n ty fexport) = do - markEpAnn an AnnForeign - markEpAnn an AnnExport - markAnnotated fexport - markAnnotated n - markEpAnn an AnnDcolon - markAnnotated ty + an0 <- markEpAnnL an lidl AnnForeign + an1 <- markEpAnnL an0 lidl AnnExport + fexport' <- markAnnotated fexport + n' <- markAnnotated n + an2 <- markEpAnnL an1 lidl AnnDcolon + ty' <- markAnnotated ty + return (ForeignExport an2 n' ty' fexport') -- --------------------------------------------------------------------- instance ExactPrint (ForeignImport GhcPs) where getAnnotationEntry = const NoEntryVal - exact (CImport (L ls src) cconv safety@(L ll _) _mh _imp) = do - markAnnotated cconv - unless (ll == noSrcSpan) $ markAnnotated safety - unless (ls == noSrcSpan) $ markExternalSourceText ls src "" + setAnnotationAnchor a _ _ = a + exact (CImport (L ls src) cconv safety@(L ll _) mh imp) = do + cconv' <- markAnnotated cconv + unless (ll == noSrcSpan) $ markAnnotated safety >> return () + unless (ls == noSrcSpan) $ markExternalSourceText ls src "" >> return () + return (CImport (L ls src) cconv' safety mh imp) -- --------------------------------------------------------------------- instance ExactPrint (ForeignExport GhcPs) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a exact (CExport (L ls src) spec) = do debugM $ "CExport starting" - markAnnotated spec + spec' <- markAnnotated spec unless (ls == noSrcSpan) $ markExternalSourceText ls src "" + return (CExport (L ls src) spec') -- --------------------------------------------------------------------- instance ExactPrint CExportSpec where getAnnotationEntry = const NoEntryVal - exact (CExportStatic _st _lbl cconv) = do + setAnnotationAnchor a _ _ = a + exact (CExportStatic st lbl cconv) = do debugM $ "CExportStatic starting" - markAnnotated cconv + cconv' <- markAnnotated cconv + return (CExportStatic st lbl cconv') -- --------------------------------------------------------------------- instance ExactPrint Safety where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a exact = withPpr -- --------------------------------------------------------------------- instance ExactPrint CCallConv where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a exact = withPpr -- --------------------------------------------------------------------- instance ExactPrint (WarnDecls GhcPs) where getAnnotationEntry (Warnings (an,_) _) = fromAnn an + setAnnotationAnchor (Warnings (an,a) b) anc cs = Warnings ((setAnchorEpa an anc cs),a) b + exact (Warnings (an,src) warns) = do - markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED - markAnnotated warns - markLocatedAALS an id AnnClose (Just "#-}") + an0 <- markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED + warns' <- markAnnotated warns + an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") + return (Warnings (an1,src) warns') -- --------------------------------------------------------------------- instance ExactPrint (WarnDecl GhcPs) where getAnnotationEntry (Warning an _ _) = fromAnn an + setAnnotationAnchor (Warning an a b) anc cs = Warning (setAnchorEpa an anc cs) a b exact (Warning an lns txt) = do - markAnnotated lns - markEpAnn an AnnOpenS -- "[" - case txt of - WarningTxt _src ls -> markAnnotated ls - DeprecatedTxt _src ls -> markAnnotated ls - markEpAnn an AnnCloseS -- "]" + lns' <- markAnnotated lns + an0 <- markEpAnnL an lidl AnnOpenS -- "[" + txt' <- + case txt of + WarningTxt src ls -> do + ls' <- markAnnotated ls + return (WarningTxt src ls') + DeprecatedTxt src ls -> do + ls' <- markAnnotated ls + return (DeprecatedTxt src ls') + an1 <- markEpAnnL an0 lidl AnnCloseS -- "]" + return (Warning an1 lns' txt') -- --------------------------------------------------------------------- instance ExactPrint StringLiteral where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a - exact (StringLiteral src fs mcomma) = do + exact l@(StringLiteral src fs mcomma) = do printSourceText src (show (unpackFS fs)) - mapM_ (\r -> printStringAtKw' r ",") mcomma + mapM_ (\r -> printStringAtRs r ",") mcomma + return l -- --------------------------------------------------------------------- instance ExactPrint FastString where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. -- exact fs = printStringAdvance (show (unpackFS fs)) - exact fs = printStringAdvance (unpackFS fs) + exact fs = printStringAdvance (unpackFS fs) >> return fs -- --------------------------------------------------------------------- instance ExactPrint (RuleDecls GhcPs) where getAnnotationEntry (HsRules (an,_) _) = fromAnn an + setAnnotationAnchor (HsRules (an,a) b) anc cs = HsRules ((setAnchorEpa an anc cs),a) b exact (HsRules (an, src) rules) = do - case src of - NoSourceText -> markLocatedAALS an id AnnOpen (Just "{-# RULES") - SourceText srcTxt -> markLocatedAALS an id AnnOpen (Just srcTxt) - markAnnotated rules - markLocatedAALS an id AnnClose (Just "#-}") - -- markTrailingSemi + an0 <- + case src of + NoSourceText -> markEpAnnLMS an lidl AnnOpen (Just "{-# RULES") + SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just srcTxt) + rules' <- markAnnotated rules + an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") + return (HsRules (an1,src) rules') -- --------------------------------------------------------------------- instance ExactPrint (RuleDecl GhcPs) where getAnnotationEntry (HsRule {rd_ext = (an,_)}) = fromAnn an + setAnnotationAnchor r@(HsRule {rd_ext = (an,a)}) anc cs + = r { rd_ext = (setAnchorEpa an anc cs, a)} exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do debugM "HsRule entered" - markAnnotated (L ln (nsrc, n)) + (L ln' _) <- markAnnotated (L ln (nsrc, n)) debugM "HsRule after ln" - markActivation an ra_rest act + an0 <- markActivation an lra_rest act debugM "HsRule after act" - case mtybndrs of - Nothing -> return () - Just bndrs -> do - markLocatedMAA an (\a -> fmap fst (ra_tyanns a)) -- AnnForall - mapM_ markAnnotated bndrs - markLocatedMAA an (\a -> fmap snd (ra_tyanns a)) -- AnnDot - - markLocatedMAA an (\a -> fmap fst (ra_tmanns a)) -- AnnForall - mapM_ markAnnotated termbndrs - markLocatedMAA an (\a -> fmap snd (ra_tmanns a)) -- AnnDot - - markAnnotated lhs - markEpAnn' an ra_rest AnnEqual - markAnnotated rhs - -- markAST l (GHC.HsRule _ ln act mtybndrs termbndrs lhs rhs) = do - -- markLocated ln - -- setContext (Set.singleton ExplicitNeverActive) $ markActivation l act - - - -- mark GHC.AnnForall - -- mapM_ markLocated termbndrs - -- mark GHC.AnnDot - - -- markLocated lhs - -- mark GHC.AnnEqual - -- markLocated rhs - -- inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi - -- markTrailingSemi - -markActivation :: EpAnn a -> (a -> [AddEpAnn]) -> Activation -> Annotated () -markActivation an fn act = do + (an1, mtybndrs') <- + case mtybndrs of + Nothing -> return (an0, Nothing) + Just bndrs -> do + an1 <- markLensMAA an0 lra_tyanns_fst -- AnnForall + bndrs' <- mapM markAnnotated bndrs + an2 <- markLensMAA an1 lra_tyanns_snd -- AnnDot + return (an2, Just bndrs') + + an2 <- markLensMAA an1 lra_tmanns_fst -- AnnForall + termbndrs' <- mapM markAnnotated termbndrs + an3 <- markLensMAA an2 lra_tmanns_snd -- AnnDot + + lhs' <- markAnnotated lhs + an4 <- markEpAnnL an3 lra_rest AnnEqual + rhs' <- markAnnotated rhs + return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs') + +markActivation :: (Monad m, Monoid w) + => EpAnn a -> Lens a [AddEpAnn] -> Activation -> EP w m (EpAnn a) +markActivation an l act = do case act of ActiveBefore src phase -> do - markEpAnn' an fn AnnOpenS -- '[' - markEpAnn' an fn AnnTilde -- ~ - markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) - markEpAnn' an fn AnnCloseS -- ']' + an0 <- markEpAnnL an l AnnOpenS -- '[' + an1 <- markEpAnnL an0 l AnnTilde -- ~ + an2 <- markEpAnnLMS an1 l AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) + an3 <- markEpAnnL an2 l AnnCloseS -- ']' + return an3 ActiveAfter src phase -> do - markEpAnn' an fn AnnOpenS -- '[' - markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) - markEpAnn' an fn AnnCloseS -- ']' + an0 <- markEpAnnL an l AnnOpenS -- '[' + an1 <- markEpAnnLMS an0 l AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) + an2 <- markEpAnnL an1 l AnnCloseS -- ']' + return an2 NeverActive -> do - markEpAnn' an fn AnnOpenS -- '[' - markEpAnn' an fn AnnTilde -- ~ - markEpAnn' an fn AnnCloseS -- ']' - _ -> return () + an0 <- markEpAnnL an l AnnOpenS -- '[' + an1 <- markEpAnnL an0 l AnnTilde -- ~ + an2 <- markEpAnnL an1 l AnnCloseS -- ']' + return an2 + _ -> return an -- --------------------------------------------------------------------- instance ExactPrint (SpliceDecl GhcPs) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a - exact (SpliceDecl _ splice _flag) = do - markAnnotated splice + exact (SpliceDecl x splice flag) = do + splice' <- markAnnotated splice + return (SpliceDecl x splice' flag) -- --------------------------------------------------------------------- instance ExactPrint (DocDecl GhcPs) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a exact v = case v of - (DocCommentNext ds) -> exact ds - (DocCommentPrev ds) -> exact ds - (DocCommentNamed _s ds) -> exact ds - (DocGroup _i ds) -> exact ds + (DocCommentNext ds) -> DocCommentNext <$> exact ds + (DocCommentPrev ds) -> DocCommentPrev <$> exact ds + (DocCommentNamed s ds) -> DocCommentNamed s <$> exact ds + (DocGroup i ds) -> DocGroup i <$> exact ds -- --------------------------------------------------------------------- instance ExactPrint (RoleAnnotDecl GhcPs) where getAnnotationEntry (RoleAnnotDecl an _ _) = fromAnn an + setAnnotationAnchor (RoleAnnotDecl an a b) anc cs = RoleAnnotDecl (setAnchorEpa an anc cs) a b exact (RoleAnnotDecl an ltycon roles) = do - markEpAnn an AnnType - markEpAnn an AnnRole - markAnnotated ltycon - let markRole (L l (Just r)) = markAnnotated (L (locA l) r) - markRole (L l Nothing) = printStringAtSs (locA l) "_" - mapM_ markRole roles + an0 <- markEpAnnL an lidl AnnType + an1 <- markEpAnnL an0 lidl AnnRole + ltycon' <- markAnnotated ltycon + let markRole (L l (Just r)) = do + (L _ r') <- markAnnotated (L l r) + return (L l (Just r')) + markRole (L l Nothing) = do + printStringAtSs (locA l) "_" + return (L l Nothing) + roles' <- mapM markRole roles + return (RoleAnnotDecl an1 ltycon' roles') -- --------------------------------------------------------------------- instance ExactPrint Role where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a exact = withPpr -- --------------------------------------------------------------------- instance ExactPrint (RuleBndr GhcPs) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a -{- - = RuleBndr (XCRuleBndr pass) (Located (IdP pass)) - | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (HsPatSigType pass) --} - exact (RuleBndr _ ln) = markAnnotated ln - exact (RuleBndrSig an ln (HsPS _ ty)) = do - markEpAnn an AnnOpenP -- "(" - markAnnotated ln - markEpAnn an AnnDcolon - markAnnotated ty - markEpAnn an AnnCloseP -- ")" - --- --------------------------------------------------------------------- - --- instance ExactPrint (TyFamInstEqn GhcPs) where --- instance (ExactPrint body) => ExactPrint (FamInstEqn GhcPs body) where --- getAnnotationEntry = const NoEntryVal --- exact (HsIB { hsib_body = FamEqn { feqn_ext = an --- , feqn_tycon = tycon --- , feqn_bndrs = bndrs --- , feqn_pats = pats --- , feqn_fixity = fixity --- , feqn_rhs = rhs }}) = do --- exactHsFamInstLHS an tycon bndrs pats fixity Nothing --- markEpAnn an AnnEqual --- markAnnotated rhs + exact (RuleBndr x ln) = do + ln' <- markAnnotated ln + return (RuleBndr x ln') + exact (RuleBndrSig an ln (HsPS x ty)) = do + an0 <- markEpAnnL an lidl AnnOpenP -- "(" + ln' <- markAnnotated ln + an1 <- markEpAnnL an0 lidl AnnDcolon + ty' <- markAnnotated ty + an2 <- markEpAnnL an1 lidl AnnCloseP -- ")" + return (RuleBndrSig an2 ln' (HsPS x ty')) + +-- --------------------------------------------------------------------- instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where getAnnotationEntry (FamEqn { feqn_ext = an}) = fromAnn an + setAnnotationAnchor fe anc cs = fe {feqn_ext = setAnchorEpa (feqn_ext fe) anc cs} exact (FamEqn { feqn_ext = an , feqn_tycon = tycon , feqn_bndrs = bndrs , feqn_pats = pats , feqn_fixity = fixity , feqn_rhs = rhs }) = do - exactHsFamInstLHS an tycon bndrs pats fixity Nothing - markEpAnn an AnnEqual - markAnnotated rhs + (an0, tycon', bndrs', pats', _) <- exactHsFamInstLHS an tycon bndrs pats fixity Nothing + an1 <- markEpAnnL an0 lidl AnnEqual + rhs' <- markAnnotated rhs + return (FamEqn { feqn_ext = an1 + , feqn_tycon = tycon' + , feqn_bndrs = bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = rhs' }) -- --------------------------------------------------------------------- exactHsFamInstLHS :: - EpAnn [AddEpAnn] + (Monad m, Monoid w) + => EpAnn [AddEpAnn] -> LocatedN RdrName - -- -> Maybe [LHsTyVarBndr () GhcPs] -> HsOuterTyVarBndrs () GhcPs -> HsTyPats GhcPs -> LexicalFixity -> Maybe (LHsContext GhcPs) - -> EPP () + -> EP w m ( EpAnn [AddEpAnn] + , LocatedN RdrName + , HsOuterTyVarBndrs () GhcPs + , HsTyPats GhcPs, Maybe (LHsContext GhcPs)) exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do - markEpAnn an AnnForall - markAnnotated bndrs - markEpAnn an AnnDot - mapM_ markAnnotated mb_ctxt - exact_pats typats + an0 <- markEpAnnL an lidl AnnForall + bndrs' <- markAnnotated bndrs + an1 <- markEpAnnL an0 lidl AnnDot + mb_ctxt' <- mapM markAnnotated mb_ctxt + (an2, thing', typats') <- exact_pats an1 typats + return (an2, thing', bndrs', typats', mb_ctxt') where - exact_pats :: HsTyPats GhcPs -> EPP () - exact_pats (patl:patr:pats) + exact_pats :: (Monad m, Monoid w) + => EpAnn [AddEpAnn] -> HsTyPats GhcPs -> EP w m (EpAnn [AddEpAnn], LocatedN RdrName, HsTyPats GhcPs) + exact_pats an' (patl:patr:pats) | Infix <- fixity = let exact_op_app = do - markAnnotated patl - markAnnotated thing - markAnnotated patr + an0 <- markEpAnnAllL an' lidl AnnOpenP + patl' <- markAnnotated patl + thing' <- markAnnotated thing + patr' <- markAnnotated patr + an1 <- markEpAnnAllL an0 lidl AnnCloseP + return (an1, thing', [patl',patr']) in case pats of [] -> exact_op_app _ -> do - markEpAnn an AnnOpenP - exact_op_app - markEpAnn an AnnCloseP - mapM_ markAnnotated pats + (an0, thing', p) <- exact_op_app + pats' <- mapM markAnnotated pats + return (an0, thing', p++pats') - exact_pats pats = do - markAnnAll (epAnnAnns an) AnnOpenP - markAnnotated thing - markAnnotated pats - markAnnAll (epAnnAnns an) AnnCloseP + exact_pats an' pats = do + an0 <- markEpAnnAllL an' lidl AnnOpenP + thing' <- markAnnotated thing + pats' <- markAnnotated pats + an1 <- markEpAnnAllL an0 lidl AnnCloseP + return (an1, thing', pats') -- --------------------------------------------------------------------- --- instance ExactPrint (LHsTypeArg GhcPs) where instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) => ExactPrint (HsArg tm ty) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a - exact (HsValArg tm) = markAnnotated tm - exact (HsTypeArg ss ty) = printStringAtSs ss "@" >> markAnnotated ty + exact a@(HsValArg tm) = markAnnotated tm >> return a + exact a@(HsTypeArg ss ty) = printStringAtSs ss "@" >> markAnnotated ty >> return a exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source -- --------------------------------------------------------------------- instance ExactPrint (ClsInstDecl GhcPs) where getAnnotationEntry cid = fromAnn (fst $ cid_ext cid) + setAnnotationAnchor cid anc cs + = cid { cid_ext = (setAnchorEpa (fst $ cid_ext cid) anc cs, (snd $ cid_ext cid)) } exact (ClsInstDecl { cid_ext = (an, sortKey) , cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats , cid_overlap_mode = mbOverlap , cid_datafam_insts = adts }) - | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part - = top_matter - - | otherwise -- Laid out = do - top_matter - markEpAnn an AnnWhere - markEpAnn an AnnOpenC - markEpAnnAll an id AnnSemi - -- = vcat [ top_matter <+> text "where" - -- , nest 2 $ pprDeclList $ - -- map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++ - -- map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ - -- pprLHsBindsForUser binds sigs ] - withSortKey sortKey + (an0, mbOverlap', inst_ty') <- top_matter + an1 <- markEpAnnL an0 lidl AnnOpenC + an2 <- markEpAnnAllL an1 lid AnnSemi + ds <- withSortKey sortKey (prepareListAnnotationA ats - ++ prepareListAnnotationF (exactDataFamInstDecl an NotTopLevel ) adts + ++ prepareListAnnotationF an adts ++ prepareListAnnotationA (bagToList binds) ++ prepareListAnnotationA sigs ) - markEpAnn an AnnCloseC -- '}' + an3 <- markEpAnnL an2 lidl AnnCloseC -- '}' + let + ats' = undynamic ds + adts' = undynamic ds + binds' = listToBag $ undynamic ds + sigs' = undynamic ds + return (ClsInstDecl { cid_ext = (an3, sortKey) + , cid_poly_ty = inst_ty', cid_binds = binds' + , cid_sigs = sigs', cid_tyfam_insts = ats' + , cid_overlap_mode = mbOverlap' + , cid_datafam_insts = adts' }) where top_matter = do - markEpAnn an AnnInstance - mapM_ markAnnotated mbOverlap - markAnnotated inst_ty - markEpAnn an AnnWhere -- Optional - -- text "instance" <+> ppOverlapPragma mbOverlap - -- <+> ppr inst_ty + an0 <- markEpAnnL an lidl AnnInstance + mo <- mapM markAnnotated mbOverlap + it <- markAnnotated inst_ty + an1 <- markEpAnnL an0 lidl AnnWhere -- Optional + return (an1, mo,it) -- --------------------------------------------------------------------- instance ExactPrint (TyFamInstDecl GhcPs) where getAnnotationEntry (TyFamInstDecl an _) = fromAnn an - exact d@(TyFamInstDecl _an _eqn) = - exactTyFamInstDecl TopLevel d - --- --------------------------------------------------------------------- + setAnnotationAnchor (TyFamInstDecl an a) anc cs = TyFamInstDecl (setAnchorEpa an anc cs) a --- instance (ExactPrint body) => ExactPrint (HsImplicitBndrs GhcPs body) where --- getAnnotationEntry (HsIB an _) = fromAnn an --- exact (HsIB an t) = markAnnotated t + exact d@(TyFamInstDecl { tfid_xtn = an, tfid_eqn = eqn }) = do + an0 <- markEpAnnL an lidl AnnType + an1 <- markEpAnnL an0 lidl AnnInstance + eqn' <- markAnnotated eqn + return (d { tfid_xtn = an1, tfid_eqn = eqn' }) -- --------------------------------------------------------------------- instance ExactPrint (LocatedP OverlapMode) where getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn -- NOTE: NoOverlap is only used in the typechecker - exact (L (SrcSpanAnn an _) (NoOverlap src)) = do - markAnnOpenP an src "{-# NO_OVERLAP" - markAnnCloseP an + exact (L (SrcSpanAnn an l) (NoOverlap src)) = do + an0 <- markAnnOpenP an src "{-# NO_OVERLAP" + an1 <- markAnnCloseP an0 + return (L (SrcSpanAnn an1 l) (NoOverlap src)) - exact (L (SrcSpanAnn an _) (Overlappable src)) = do - markAnnOpenP an src "{-# OVERLAPPABLE" - markAnnCloseP an + exact (L (SrcSpanAnn an l) (Overlappable src)) = do + an0 <- markAnnOpenP an src "{-# OVERLAPPABLE" + an1 <- markAnnCloseP an0 + return (L (SrcSpanAnn an1 l) (Overlappable src)) - exact (L (SrcSpanAnn an _) (Overlapping src)) = do - markAnnOpenP an src "{-# OVERLAPPING" - markAnnCloseP an + exact (L (SrcSpanAnn an l) (Overlapping src)) = do + an0 <- markAnnOpenP an src "{-# OVERLAPPING" + an1 <- markAnnCloseP an0 + return (L (SrcSpanAnn an1 l) (Overlapping src)) - exact (L (SrcSpanAnn an _) (Overlaps src)) = do - markAnnOpenP an src "{-# OVERLAPS" - markAnnCloseP an + exact (L (SrcSpanAnn an l) (Overlaps src)) = do + an0 <- markAnnOpenP an src "{-# OVERLAPS" + an1 <- markAnnCloseP an0 + return (L (SrcSpanAnn an1 l) (Overlaps src)) - exact (L (SrcSpanAnn an _) (Incoherent src)) = do - markAnnOpenP an src "{-# INCOHERENT" - markAnnCloseP an + exact (L (SrcSpanAnn an l) (Incoherent src)) = do + an0 <- markAnnOpenP an src "{-# INCOHERENT" + an1 <- markAnnCloseP an0 + return (L (SrcSpanAnn an1 l) (Incoherent src)) -- --------------------------------------------------------------------- instance ExactPrint (HsBind GhcPs) where getAnnotationEntry FunBind{} = NoEntryVal - getAnnotationEntry PatBind{} = NoEntryVal + getAnnotationEntry PatBind{pat_ext=an} = fromAnn an getAnnotationEntry VarBind{} = NoEntryVal getAnnotationEntry PatSynBind{} = NoEntryVal - exact (FunBind _ _ matches) = do - markAnnotated matches - exact (PatBind _ pat grhss) = do - markAnnotated pat - markAnnotated grhss - exact (PatSynBind _ bind) = markAnnotated bind + setAnnotationAnchor pb@PatBind{} anc cs = pb { pat_ext = setAnchorEpa (pat_ext pb) anc cs} + setAnnotationAnchor a _ _ = a + + exact (FunBind x fid matches) = do + matches' <- markAnnotated matches + let + fun_id' = case unLoc (mg_alts matches') of + [] -> fid + (L _ m:_) -> case m_ctxt m of + FunRhs f _ _ -> f + _ -> fid + return (FunBind x fun_id' matches') + + exact (PatBind x pat grhss) = do + pat' <- markAnnotated pat + grhss' <- markAnnotated grhss + return (PatBind x pat' grhss') + exact (PatSynBind x bind) = do + bind' <- markAnnotated bind + return (PatSynBind x bind') exact x = error $ "HsBind: exact for " ++ showAst x @@ -1324,182 +2119,163 @@ instance ExactPrint (HsBind GhcPs) where instance ExactPrint (PatSynBind GhcPs GhcPs) where getAnnotationEntry (PSB { psb_ext = an}) = fromAnn an + setAnnotationAnchor p anc cs = p { psb_ext = setAnchorEpa (psb_ext p) anc cs} exact (PSB{ psb_ext = an , psb_id = psyn, psb_args = details , psb_def = pat , psb_dir = dir }) = do - markEpAnn an AnnPattern - case details of - InfixCon v1 v2 -> do - markAnnotated v1 - markAnnotated psyn - markAnnotated v2 - PrefixCon tvs vs -> do - markAnnotated psyn - markAnnotated tvs - markAnnotated vs - RecCon vs -> do - markAnnotated psyn - markEpAnn an AnnOpenC -- '{' - markAnnotated vs - markEpAnn an AnnCloseC -- '}' - - case dir of - Unidirectional -> do - markEpAnn an AnnLarrow - markAnnotated pat - ImplicitBidirectional -> do - markEpAnn an AnnEqual - markAnnotated pat - ExplicitBidirectional mg -> do - markEpAnn an AnnLarrow - markAnnotated pat - markEpAnn an AnnWhere - markAnnotated mg - - -- case dir of - -- GHC.ImplicitBidirectional -> mark GHC.AnnEqual - -- _ -> mark GHC.AnnLarrow - - -- markLocated def - -- case dir of - -- GHC.Unidirectional -> return () - -- GHC.ImplicitBidirectional -> return () - -- GHC.ExplicitBidirectional mg -> do - -- mark GHC.AnnWhere - -- mark GHC.AnnOpenC -- '{' - -- markMatchGroup l mg - -- mark GHC.AnnCloseC -- '}' - - -- markTrailingSemi + an0 <- markEpAnnL an lidl AnnPattern + (an1, psyn', details') <- + case details of + InfixCon v1 v2 -> do + v1' <- markAnnotated v1 + psyn' <- markAnnotated psyn + v2' <- markAnnotated v2 + return (an0, psyn',InfixCon v1' v2') + PrefixCon tvs vs -> do + psyn' <- markAnnotated psyn + tvs' <- markAnnotated tvs + vs' <- markAnnotated vs + return (an0, psyn', PrefixCon tvs' vs') + RecCon vs -> do + psyn' <- markAnnotated psyn + an1 <- markEpAnnL an0 lidl AnnOpenC -- '{' + vs' <- markAnnotated vs + an2 <- markEpAnnL an1 lidl AnnCloseC -- '}' + return (an2, psyn', RecCon vs') + + (an2, pat', dir') <- + case dir of + Unidirectional -> do + an2 <- markEpAnnL an1 lidl AnnLarrow + pat' <- markAnnotated pat + return (an2, pat', dir) + ImplicitBidirectional -> do + an2 <- markEpAnnL an1 lidl AnnEqual + pat' <- markAnnotated pat + return (an2, pat', dir) + ExplicitBidirectional mg -> do + an2 <- markEpAnnL an1 lidl AnnLarrow + pat' <- markAnnotated pat + an3 <- markEpAnnL an2 lidl AnnWhere + mg' <- markAnnotated mg + return (an3, pat', ExplicitBidirectional mg') + + return (PSB{ psb_ext = an2 + , psb_id = psyn', psb_args = details' + , psb_def = pat' + , psb_dir = dir' }) -- --------------------------------------------------------------------- instance ExactPrint (RecordPatSynField GhcPs) where getAnnotationEntry = const NoEntryVal - exact (RecordPatSynField { recordPatSynField = v }) = markAnnotated v + setAnnotationAnchor a _ _ = a + exact r@(RecordPatSynField { recordPatSynField = v }) = markAnnotated v + >> return r -- --------------------------------------------------------------------- instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where getAnnotationEntry (Match ann _ _ _) = fromAnn ann + setAnnotationAnchor (Match an a b c) anc cs = Match (setAnchorEpa an anc cs) a b c - -- exact match@(Match EpAnnNotUsed _ _ _) = withPpr match - exact (Match an mctxt pats grhss) = do + exact (Match an mctxt pats grhss) = exactMatch (Match an mctxt pats grhss) -- ------------------------------------- instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where getAnnotationEntry (Match ann _ _ _) = fromAnn ann + setAnnotationAnchor (Match an a b c) anc cs = Match (setAnchorEpa an anc cs) a b c - -- exact match@(Match EpAnnNotUsed _ _ _) = withPpr match - exact (Match an mctxt pats grhss) = do + exact (Match an mctxt pats grhss) = exactMatch (Match an mctxt pats grhss) - -- -- Based on Expr.pprMatch - - -- debugM $ "exact Match entered" - - -- -- herald - -- case mctxt of - -- FunRhs fun fixity strictness -> do - -- debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun - -- case strictness of - -- SrcStrict -> markEpAnn an AnnBang - -- _ -> pure () - -- case fixity of - -- Prefix -> do - -- markAnnotated fun - -- mapM_ markAnnotated pats - -- Infix -> - -- case pats of - -- (p1:p2:rest) - -- | null rest -> do - -- markAnnotated p1 - -- markAnnotated fun - -- markAnnotated p2 - -- | otherwise -> do - -- markEpAnn an AnnOpenP - -- markAnnotated p1 - -- markAnnotated fun - -- markAnnotated p2 - -- markEpAnn an AnnCloseP - -- mapM_ markAnnotated rest - -- LambdaExpr -> do - -- markEpAnn an AnnLam - -- mapM_ markAnnotated pats - -- CaseAlt -> do - -- mapM_ markAnnotated pats - -- LamCaseAlt _ -> - -- mapM_ markAnnotated pats - -- _ -> withPpr mctxt - - -- markAnnotated grhss - --- --------------------------------------------------------------------- - -exactMatch :: (ExactPrint (GRHSs GhcPs body)) => (Match GhcPs body) -> Annotated () + +-- --------------------------------------------------------------------- + +exactMatch :: (Monad m, Monoid w) => (ExactPrint (GRHSs GhcPs body)) => (Match GhcPs body) -> EP w m (Match GhcPs body) exactMatch (Match an mctxt pats grhss) = do --- Based on Expr.pprMatch debugM $ "exact Match entered" - -- herald - case mctxt of - FunRhs fun fixity strictness -> do - debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun - case strictness of - SrcStrict -> markEpAnn an AnnBang - _ -> pure () - case fixity of - Prefix -> do - annotationsToCommentsA an [AnnOpenP,AnnCloseP] - markAnnotated fun - markAnnotated pats - Infix -> - case pats of - (p1:p2:rest) - | null rest -> do - markAnnotated p1 - markAnnotated fun - markAnnotated p2 - | otherwise -> do - markEpAnn an AnnOpenP - markAnnotated p1 - markAnnotated fun - markAnnotated p2 - markEpAnn an AnnCloseP - mapM_ markAnnotated rest - _ -> panic "FunRhs" - LambdaExpr -> do - markEpAnn an AnnLam - markAnnotated pats - CaseAlt -> do - markAnnotated pats - LamCaseAlt _ -> do - markAnnotated pats - _ -> withPpr mctxt - - markAnnotated grhss + (an0, mctxt', pats') <- + case mctxt of + FunRhs fun fixity strictness -> do + debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun + an0' <- + case strictness of + SrcStrict -> markEpAnnL an lidl AnnBang + _ -> pure an + case fixity of + Prefix -> do + an' <- annotationsToComments an0' lidl [AnnOpenP,AnnCloseP] + fun' <- markAnnotated fun + pats' <- markAnnotated pats + return (an', FunRhs fun' fixity strictness, pats') + Infix -> + case pats of + (p1:p2:rest) + | null rest -> do + p1' <- markAnnotated p1 + fun' <- markAnnotated fun + p2' <- markAnnotated p2 + return (an0', FunRhs fun' fixity strictness, [p1',p2']) + | otherwise -> do + an0 <- markEpAnnL an0' lidl AnnOpenP + p1' <- markAnnotated p1 + fun' <- markAnnotated fun + p2' <- markAnnotated p2 + an1 <- markEpAnnL an0 lidl AnnCloseP + rest' <- mapM markAnnotated rest + return (an1, FunRhs fun' fixity strictness, p1':p2':rest') + _ -> panic "FunRhs" + LambdaExpr -> do + an0' <- markEpAnnL an lidl AnnLam + pats' <- markAnnotated pats + return (an0', LambdaExpr, pats') + CaseAlt -> do + pats' <- markAnnotated pats + return (an, CaseAlt, pats') + LamCaseAlt v -> do + pats' <- markAnnotated pats + return (an, LamCaseAlt v, pats') + _ -> do + mctxt' <- withPpr mctxt + return (an, mctxt', pats) + + grhss' <- markAnnotated grhss + + return (Match an0 mctxt' pats' grhss') -- --------------------------------------------------------------------- instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where getAnnotationEntry (GRHSs _ _ _) = NoEntryVal + setAnnotationAnchor a _ _ = a - exact (GRHSs _ grhss binds) = do - markAnnotated grhss - markAnnotated binds + exact (GRHSs cs grhss binds) = do + addCommentsA $ priorComments cs + addCommentsA $ getFollowingComments cs + grhss' <- markAnnotated grhss + binds' <- markAnnotated binds + -- The comments will be added back as they are printed + return (GRHSs emptyComments grhss' binds') instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where getAnnotationEntry (GRHSs _ _ _) = NoEntryVal + setAnnotationAnchor a _ _ = a - exact (GRHSs _an grhss binds) = do - markAnnotated grhss - markAnnotated binds + exact (GRHSs cs grhss binds) = do + addCommentsA $ priorComments cs + addCommentsA $ getFollowingComments cs + grhss' <- markAnnotated grhss + binds' <- markAnnotated binds + -- The comments will be added back as they are printed + return (GRHSs emptyComments grhss' binds') -- --------------------------------------------------------------------- @@ -1508,8 +2284,13 @@ instance ExactPrint (HsLocalBinds GhcPs) where getAnnotationEntry (HsIPBinds{}) = NoEntryVal getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal + setAnnotationAnchor (HsValBinds an a) anc cs = HsValBinds (setAnchorEpaL an anc cs) a + setAnnotationAnchor a _ _ = a + exact (HsValBinds an valbinds) = do - markLocatedAAL an al_rest AnnWhere + debugM $ "exact HsValBinds: an=" ++ showAst an + an0 <- markEpAnnL an lal_rest AnnWhere + let manc = case an of EpAnnNotUsed -> Nothing _ -> al_anchor $ anns an @@ -1519,60 +2300,88 @@ instance ExactPrint (HsLocalBinds GhcPs) where when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc) _ -> return () - markAnnList False an $ markAnnotatedWithLayout valbinds + (an1, valbinds') <- markAnnList False an0 $ markAnnotatedWithLayout valbinds + debugM $ "exact HsValBinds: an1=" ++ showAst an1 + return (HsValBinds an1 valbinds') - exact (HsIPBinds an bs) - = markAnnList True an (markLocatedAAL an al_rest AnnWhere >> markAnnotated bs) - exact (EmptyLocalBinds _) = return () + exact (HsIPBinds an bs) = do + (as, ipb) <- markAnnList True an (markEpAnnL an lal_rest AnnWhere + >> markAnnotated bs + >>= \bs' -> return (HsIPBinds an bs'::HsLocalBinds GhcPs)) + case ipb of + HsIPBinds _ bs' -> return (HsIPBinds as bs'::HsLocalBinds GhcPs) + _ -> error "should not happen HsIPBinds" + exact b@(EmptyLocalBinds _) = return b -- --------------------------------------------------------------------- instance ExactPrint (HsValBindsLR GhcPs GhcPs) where getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ = a exact (ValBinds sortKey binds sigs) = do - setLayoutBoth $ withSortKey sortKey + ds <- setLayoutBoth $ withSortKey sortKey (prepareListAnnotationA (bagToList binds) ++ prepareListAnnotationA sigs ) + let + binds' = listToBag $ undynamic ds + sigs' = undynamic ds + return (ValBinds sortKey binds' sigs') exact (XValBindsLR _) = panic "XValBindsLR" +undynamic :: Typeable a => [Dynamic] -> [a] +undynamic ds = mapMaybe fromDynamic ds + -- --------------------------------------------------------------------- instance ExactPrint (HsIPBinds GhcPs) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a - exact (IPBinds _ binds) = setLayoutBoth $ markAnnotated binds + exact b@(IPBinds _ binds) = setLayoutBoth $ markAnnotated binds >> return b -- --------------------------------------------------------------------- instance ExactPrint (IPBind GhcPs) where getAnnotationEntry (IPBind an _ _) = fromAnn an + setAnnotationAnchor (IPBind an a b) anc cs = IPBind (setAnchorEpa an anc cs) a b exact (IPBind an lr rhs) = do - markAnnotated lr - markEpAnn an AnnEqual - markAnnotated rhs + lr' <- markAnnotated lr + an0 <- markEpAnnL an lidl AnnEqual + rhs' <- markAnnotated rhs + return (IPBind an0 lr' rhs') + -- --------------------------------------------------------------------- instance ExactPrint HsIPName where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a - exact (HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs)) + exact i@(HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs)) >> return i -- --------------------------------------------------------------------- -- Managing lists which have been separated, e.g. Sigs and Binds -prepareListAnnotationF :: (a -> EPP ()) -> [LocatedAn an a] -> [(RealSrcSpan,EPP ())] -prepareListAnnotationF f ls - = map (\b -> (realSrcSpan $ getLocA b, f (unLoc b))) ls +prepareListAnnotationF :: (Monad m, Monoid w) => + EpAnn [AddEpAnn] -> [LDataFamInstDecl GhcPs] -> [(RealSrcSpan,EP w m Dynamic)] +prepareListAnnotationF an ls = map (\b -> (realSrcSpan $ getLocA b, go b)) ls + where + go (L l a) = do + d' <- markAnnotated (DataFamInstDeclWithContext an NotTopLevel a) + return (toDyn (L l (dc_d d'))) -prepareListAnnotationA :: ExactPrint (LocatedAn an a) - => [LocatedAn an a] -> [(RealSrcSpan,EPP ())] -prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,markAnnotated b)) ls +prepareListAnnotationA :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) + => [LocatedAn an a] -> [(RealSrcSpan,EP w m Dynamic)] +prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,go b)) ls + where + go b = do + b' <- markAnnotated b + return (toDyn b') -withSortKey :: AnnSortKey -> [(RealSrcSpan, EPP ())] -> EPP () +withSortKey :: (Monad m, Monoid w) => AnnSortKey -> [(RealSrcSpan, EP w m Dynamic)] -> EP w m [Dynamic] withSortKey annSortKey xs = do debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey let ordered = case annSortKey of @@ -1584,7 +2393,7 @@ withSortKey annSortKey xs = do -- map fst xs, -- keys) -- ) - mapM_ snd ordered + mapM snd ordered orderByFst :: Ord a => (a, b1) -> (a, b2) -> Ordering orderByFst (a,_) (b,_) = compare a b @@ -1603,222 +2412,217 @@ instance ExactPrint (Sig GhcPs) where getAnnotationEntry (SCCFunSig (a, _) _ _) = fromAnn a getAnnotationEntry (CompleteMatchSig (a, _) _ _) = fromAnn a --- instance Annotate (Sig GhcPs) where - - exact (TypeSig an vars ty) = exactVarSig an vars ty + setAnnotationAnchor (TypeSig a x y) anc cs = (TypeSig (setAnchorEpa a anc cs) x y) + setAnnotationAnchor (PatSynSig a x y) anc cs = (PatSynSig (setAnchorEpa a anc cs) x y) + setAnnotationAnchor (ClassOpSig a x y z) anc cs = (ClassOpSig (setAnchorEpa a anc cs) x y z) + setAnnotationAnchor (FixSig a x) anc cs = (FixSig (setAnchorEpa a anc cs) x) + setAnnotationAnchor (InlineSig a x y) anc cs = (InlineSig (setAnchorEpa a anc cs) x y) + setAnnotationAnchor (SpecSig a x y z) anc cs = (SpecSig (setAnchorEpa a anc cs) x y z) + setAnnotationAnchor (SpecInstSig (a,x) y) anc cs = (SpecInstSig ((setAnchorEpa a anc cs),x) y) + setAnnotationAnchor (MinimalSig (a,x) y) anc cs = (MinimalSig ((setAnchorEpa a anc cs),x) y) + setAnnotationAnchor (SCCFunSig (a,x) y z) anc cs = (SCCFunSig ((setAnchorEpa a anc cs),x) y z) + setAnnotationAnchor (CompleteMatchSig (a,x) y z) anc cs = (CompleteMatchSig ((setAnchorEpa a anc cs),x) y z) + + exact (TypeSig an vars ty) = do + (an', vars', ty') <- exactVarSig an vars ty + return (TypeSig an' vars' ty') exact (PatSynSig an lns typ) = do - markLocatedAAL an asRest AnnPattern - markAnnotated lns - markLocatedAA an asDcolon - markAnnotated typ + an0 <- markEpAnnL an lasRest AnnPattern + lns' <- markAnnotated lns + an1 <- markLensAA an0 lasDcolon + typ' <- markAnnotated typ + return (PatSynSig an1 lns' typ') exact (ClassOpSig an is_deflt vars ty) - | is_deflt = markLocatedAAL an asRest AnnDefault >> exactVarSig an vars ty - | otherwise = exactVarSig an vars ty - - exact (FixSig an (FixitySig _ names (Fixity src v fdir))) = do + | is_deflt = do + an0 <- markEpAnnL an lasRest AnnDefault + (an1, vars',ty') <- exactVarSig an0 vars ty + return (ClassOpSig an1 is_deflt vars' ty') + | otherwise = do + (an0, vars',ty') <- exactVarSig an vars ty + return (ClassOpSig an0 is_deflt vars' ty') + + exact (FixSig an (FixitySig x names (Fixity src v fdir))) = do let fixstr = case fdir of InfixL -> "infixl" InfixR -> "infixr" InfixN -> "infix" - markLocatedAALS an id AnnInfix (Just fixstr) --- markSourceText src (show v) - markLocatedAALS an id AnnVal (Just (sourceTextToString src (show v))) - markAnnotated names - + an0 <- markEpAnnLMS an lidl AnnInfix (Just fixstr) + an1 <- markEpAnnLMS an0 lidl AnnVal (Just (sourceTextToString src (show v))) + names' <- markAnnotated names + return (FixSig an1 (FixitySig x names' (Fixity src v fdir))) exact (InlineSig an ln inl) = do - markAnnOpen an (inl_src inl) "{-# INLINE" - -- markActivation l (inl_act inl) - markActivation an id (inl_act inl) - markAnnotated ln - -- markWithString AnnClose "#-}" -- '#-}' + an0 <- markAnnOpen an (inl_src inl) "{-# INLINE" + an1 <- markActivation an0 id (inl_act inl) + ln' <- markAnnotated ln debugM $ "InlineSig:an=" ++ showAst an p <- getPosP debugM $ "InlineSig: p=" ++ show p - markLocatedAALS an id AnnClose (Just "#-}") + an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}") debugM $ "InlineSig:done" + return (InlineSig an2 ln' inl) exact (SpecSig an ln typs inl) = do - markAnnOpen an (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE - markActivation an id (inl_act inl) - markAnnotated ln - markEpAnn an AnnDcolon - markAnnotated typs - markLocatedAALS an id AnnClose (Just "#-}") - - exact (SpecInstSig (an, src) typ) = do - markAnnOpen an src "{-# SPECIALISE" - markEpAnn an AnnInstance - markAnnotated typ - markLocatedAALS an id AnnClose (Just "#-}") - --- markAST _ (SpecInstSig _ src typ) = do --- markAnnOpen src "{-# SPECIALISE" --- mark AnnInstance --- markLHsSigType typ --- markWithString AnnClose "#-}" -- '#-}' --- markTrailingSemi - - exact (MinimalSig (an, src) formula) = do - markAnnOpen an src "{-# MINIMAL" - markAnnotated formula - markLocatedAALS an id AnnClose (Just "#-}") - --- markAST _ (MinimalSig _ src formula) = do --- markAnnOpen src "{-# MINIMAL" --- markLocated formula --- markWithString AnnClose "#-}" --- markTrailingSemi - - exact (SCCFunSig (an, src) ln ml) = do - markAnnOpen an src "{-# SCC" - markAnnotated ln - markAnnotated ml - markLocatedAALS an id AnnClose (Just "#-}") - - exact (CompleteMatchSig (an, src) cs mty) = do - markAnnOpen an src "{-# COMPLETE" - markAnnotated cs - case mty of - Nothing -> return () - Just ty -> do - markEpAnn an AnnDcolon - markAnnotated ty - markLocatedAALS an id AnnClose (Just "#-}") - --- --------------------------------------------------------------------- - -exactVarSig :: (ExactPrint a) => EpAnn AnnSig -> [LocatedN RdrName] -> a -> EPP () + an0 <- markAnnOpen an (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE + an1 <- markActivation an0 lidl (inl_act inl) + ln' <- markAnnotated ln + an2 <- markEpAnnL an1 lidl AnnDcolon + typs' <- markAnnotated typs + an3 <- markEpAnnLMS an2 lidl AnnClose (Just "#-}") + return (SpecSig an3 ln' typs' inl) + + exact (SpecInstSig (an,src) typ) = do + an0 <- markAnnOpen an src "{-# SPECIALISE" + an1 <- markEpAnnL an0 lidl AnnInstance + typ' <- markAnnotated typ + an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}") + return (SpecInstSig (an2,src) typ') + + exact (MinimalSig (an,src) formula) = do + an0 <- markAnnOpen an src "{-# MINIMAL" + formula' <- markAnnotated formula + an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") + return (MinimalSig (an1,src) formula') + + exact (SCCFunSig (an,src) ln ml) = do + an0 <- markAnnOpen an src "{-# SCC" + ln' <- markAnnotated ln + ml' <- markAnnotated ml + an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") + return (SCCFunSig (an1,src) ln' ml') + + exact (CompleteMatchSig (an,src) cs mty) = do + an0 <- markAnnOpen an src "{-# COMPLETE" + cs' <- markAnnotated cs + (an1, mty') <- + case mty of + Nothing -> return (an0, mty) + Just ty -> do + an1 <- markEpAnnL an0 lidl AnnDcolon + ty' <- markAnnotated ty + return (an1, Just ty') + an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}") + return (CompleteMatchSig (an2,src) cs' mty') + +-- --------------------------------------------------------------------- + +exactVarSig :: (Monad m, Monoid w, ExactPrint a) + => EpAnn AnnSig -> [LocatedN RdrName] -> a -> EP w m (EpAnn AnnSig, [LocatedN RdrName], a) exactVarSig an vars ty = do - mapM_ markAnnotated vars - markLocatedAA an asDcolon - markAnnotated ty - --- --------------------------------------------------------------------- + vars' <- mapM markAnnotated vars + an0 <- markLensAA an lasDcolon + ty' <- markAnnotated ty + return (an0, vars', ty') --- instance ExactPrint (FixitySig GhcPs) where --- getAnnotationEntry = const NoEntryVal - --- exact (FixitySig an names (Fixity src v fdir)) = do --- let fixstr = case fdir of --- InfixL -> "infixl" --- InfixR -> "infixr" --- InfixN -> "infix" --- markAnnotated names --- markLocatedAALS an id AnnInfix (Just fixstr) --- -- markAST _ (FixSig _ (FixitySig _ lns (Fixity src v fdir))) = do --- -- let fixstr = case fdir of --- -- InfixL -> "infixl" --- -- InfixR -> "infixr" --- -- InfixN -> "infix" --- -- markWithString AnnInfix fixstr --- -- markSourceText src (show v) --- -- setContext (Set.singleton InfixOp) $ markListIntercalate lns --- -- markTrailingSemi -- --------------------------------------------------------------------- instance ExactPrint (StandaloneKindSig GhcPs) where getAnnotationEntry (StandaloneKindSig an _ _) = fromAnn an + setAnnotationAnchor (StandaloneKindSig an a b) anc cs = StandaloneKindSig (setAnchorEpa an anc cs) a b exact (StandaloneKindSig an vars sig) = do - markEpAnn an AnnType - markAnnotated vars - markEpAnn an AnnDcolon - markAnnotated sig + an0 <- markEpAnnL an lidl AnnType + vars' <- markAnnotated vars + an1 <- markEpAnnL an0 lidl AnnDcolon + sig' <- markAnnotated sig + return (StandaloneKindSig an1 vars' sig') -- --------------------------------------------------------------------- instance ExactPrint (DefaultDecl GhcPs) where getAnnotationEntry (DefaultDecl an _) = fromAnn an + setAnnotationAnchor (DefaultDecl an a) anc cs = DefaultDecl (setAnchorEpa an anc cs) a exact (DefaultDecl an tys) = do - markEpAnn an AnnDefault - markEpAnn an AnnOpenP - markAnnotated tys - markEpAnn an AnnCloseP + an0 <- markEpAnnL an lidl AnnDefault + an1 <- markEpAnnL an0 lidl AnnOpenP + tys' <- markAnnotated tys + an2 <- markEpAnnL an1 lidl AnnCloseP + return (DefaultDecl an2 tys') -- --------------------------------------------------------------------- instance ExactPrint (AnnDecl GhcPs) where getAnnotationEntry (HsAnnotation (an, _) _ _) = fromAnn an + setAnnotationAnchor (HsAnnotation (an,a) b c) anc cs = HsAnnotation ((setAnchorEpa an anc cs),a) b c exact (HsAnnotation (an, src) prov e) = do - markAnnOpenP an src "{-# ANN" - case prov of - (ValueAnnProvenance n) -> markAnnotated n - (TypeAnnProvenance n) -> do - markLocatedAAL an apr_rest AnnType - markAnnotated n - ModuleAnnProvenance -> markLocatedAAL an apr_rest AnnModule - - markAnnotated e - markAnnCloseP an + an0 <- markAnnOpenP an src "{-# ANN" + (an1, prov') <- + case prov of + (ValueAnnProvenance n) -> do + n' <- markAnnotated n + return (an0, ValueAnnProvenance n') + (TypeAnnProvenance n) -> do + an1 <- markEpAnnL an0 lapr_rest AnnType + n' <- markAnnotated n + return (an1, TypeAnnProvenance n') + ModuleAnnProvenance -> do + an1 <- markEpAnnL an lapr_rest AnnModule + return (an1, prov) + + e' <- markAnnotated e + an2 <- markAnnCloseP an1 + return (HsAnnotation (an2,src) prov' e') -- --------------------------------------------------------------------- instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a exact (BF.Var x) = do - markAnnotated x - exact (BF.Or ls) = markAnnotated ls + x' <- markAnnotated x + return (BF.Var x') + exact (BF.Or ls) = do + ls' <- markAnnotated ls + return (BF.Or ls') exact (BF.And ls) = do - markAnnotated ls + ls' <- markAnnotated ls + return (BF.And ls') exact (BF.Parens x) = do - -- mark AnnOpenP -- '(' - markAnnotated x - -- mark AnnCloseP -- ')' - --- instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where --- markAST _ (GHC.Var x) = do --- setContext (Set.singleton PrefixOp) $ markLocated x --- inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar --- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma --- markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls --- markAST _ (GHC.And ls) = do --- markListIntercalateWithFunLevel markLocated 2 ls --- inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar --- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma --- markAST _ (GHC.Parens x) = do --- mark GHC.AnnOpenP -- '(' --- markLocated x --- mark GHC.AnnCloseP -- ')' --- inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar --- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - --- instance ExactPrint (LHsSigWcType GhcPs) where --- instance ExactPrint (HsWildCardBndrs GhcPs (LHsSigType GhcPs)) where + x' <- markAnnotated x + return (BF.Parens x') + +-- --------------------------------------------------------------------- + instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where getAnnotationEntry = const NoEntryVal - exact (HsWC _ ty) = markAnnotated ty + setAnnotationAnchor a _ _ = a + exact (HsWC x ty) = do + ty' <- markAnnotated ty + return (HsWC x ty') -- --------------------------------------------------------------------- instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where getAnnotationEntry (GRHS an _ _) = fromAnn an + setAnnotationAnchor (GRHS an a b) anc cs = GRHS (setAnchorEpa an anc cs) a b exact (GRHS an guards expr) = do debugM $ "GRHS comments:" ++ showGhc (comments an) - markAnnKwM an ga_vbar AnnVbar - markAnnotated guards + an0 <- if null guards + then return an + else markLensKwM an lga_vbar AnnVbar + guards' <- markAnnotated guards debugM $ "GRHS before matchSeparator" - markLocatedAA an ga_sep -- Mark the matchSeparator for these GRHSs + an1 <- markLensAA an0 lga_sep -- Mark the matchSeparator for these GRHSs debugM $ "GRHS after matchSeparator" - markAnnotated expr - -- markLocatedAA an ga_sep + expr' <- markAnnotated expr + return (GRHS an1 guards' expr') instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where getAnnotationEntry (GRHS ann _ _) = fromAnn ann + setAnnotationAnchor (GRHS an a b) anc cs = GRHS (setAnchorEpa an anc cs) a b exact (GRHS an guards expr) = do - markAnnKwM an ga_vbar AnnVbar - markAnnotated guards - markLocatedAA an ga_sep -- Mark the matchSeparator for these GRHSs - markAnnotated expr + an0 <- markLensKwM an lga_vbar AnnVbar + guards' <- markAnnotated guards + an1 <- markLensAA an0 lga_sep -- Mark the matchSeparator for these GRHSs + expr' <- markAnnotated expr + return (GRHS an1 guards' expr') -- --------------------------------------------------------------------- @@ -1861,302 +2665,364 @@ instance ExactPrint (HsExpr GhcPs) where getAnnotationEntry (HsStatic an _) = fromAnn an getAnnotationEntry (HsPragE{}) = NoEntryVal - - exact (HsVar _ n) = markAnnotated n - exact x@(HsUnboundVar an _v) = do + setAnnotationAnchor a@(HsVar{}) _ _s = a + setAnnotationAnchor (HsUnboundVar an a) anc cs = (HsUnboundVar (setAnchorEpa an anc cs) a) + setAnnotationAnchor a@(HsRecSel{}) _ _s = a + setAnnotationAnchor (HsOverLabel an a) anc cs = (HsOverLabel (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsIPVar an a) anc cs = (HsIPVar (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsOverLit an a) anc cs = (HsOverLit (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsLit an a) anc cs = (HsLit (setAnchorEpa an anc cs) a) + setAnnotationAnchor a@(HsLam _ _) _ _s = a + setAnnotationAnchor (HsLamCase an a b) anc cs = (HsLamCase (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsApp an a b) anc cs = (HsApp (setAnchorEpa an anc cs) a b) + setAnnotationAnchor a@(HsAppType {}) _ _s = a + setAnnotationAnchor (OpApp an a b c) anc cs = (OpApp (setAnchorEpa an anc cs) a b c) + setAnnotationAnchor (NegApp an a b) anc cs = (NegApp (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsPar an a b c) anc cs = (HsPar (setAnchorEpa an anc cs) a b c) + setAnnotationAnchor (SectionL an a b) anc cs = (SectionL (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (SectionR an a b) anc cs = (SectionR (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (ExplicitTuple an a b) anc cs = (ExplicitTuple (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (ExplicitSum an a b c) anc cs = (ExplicitSum (setAnchorEpa an anc cs) a b c) + setAnnotationAnchor (HsCase an a b) anc cs = (HsCase (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsIf an a b c) anc cs = (HsIf (setAnchorEpa an anc cs) a b c) + setAnnotationAnchor (HsMultiIf an a) anc cs = (HsMultiIf (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsLet an a b c d) anc cs = (HsLet (setAnchorEpa an anc cs) a b c d) + setAnnotationAnchor (HsDo an a b) anc cs = (HsDo (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (ExplicitList an a) anc cs = (ExplicitList (setAnchorEpa an anc cs) a) + setAnnotationAnchor (RecordCon an a b) anc cs = (RecordCon (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (RecordUpd an a b) anc cs = (RecordUpd (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsGetField an a b) anc cs = (HsGetField (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsProjection an a) anc cs = (HsProjection (setAnchorEpa an anc cs) a) + setAnnotationAnchor (ExprWithTySig an a b) anc cs = (ExprWithTySig (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (ArithSeq an a b) anc cs = (ArithSeq (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsTypedBracket an a) anc cs = (HsTypedBracket (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsUntypedBracket an a) anc cs = (HsUntypedBracket (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsTypedSplice (x,an) e) anc cs = (HsTypedSplice (x,(setAnchorEpa an anc cs)) e) + setAnnotationAnchor (HsUntypedSplice an e) anc cs = (HsUntypedSplice (setAnchorEpa an anc cs) e) + setAnnotationAnchor (HsProc an a b) anc cs = (HsProc (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsStatic an a) anc cs = (HsStatic (setAnchorEpa an anc cs) a) + setAnnotationAnchor a@(HsPragE{}) _ _s = a + + exact (HsVar x n) = do + n' <- markAnnotated n + return (HsVar x n') + exact x@(HsUnboundVar an _) = do case an of EpAnnNotUsed -> withPpr x EpAnn _ (EpAnnUnboundVar (ob,cb) l) _ -> do - printStringAtAA ob "`" - printStringAtAA l "_" - printStringAtAA cb "`" - -- exact x@(HsRecSel{}) = withPpr x + printStringAtAA ob "`" >> return () + printStringAtAA l "_" >> return () + printStringAtAA cb "`" >> return () + return x exact x@(HsOverLabel _ _) = withPpr x - exact (HsIPVar _ (HsIPName n)) - = printStringAdvance ("?" ++ unpackFS n) + exact x@(HsIPVar _ (HsIPName n)) + = printStringAdvance ("?" ++ unpackFS n) >> return x exact x@(HsOverLit _an ol) = do let str = case ol_val ol of HsIntegral (IL src _ _) -> src HsFractional (FL { fl_text = src }) -> src HsIsString src _ -> src - -- markExternalSourceText l str "" case str of - SourceText s -> printStringAdvance s - NoSourceText -> withPpr x - - exact (HsLit _an lit) = withPpr lit - exact (HsLam _ (MG _ (L _ [match]))) = do - markAnnotated match - -- markExpr _ (HsLam _ (MG _ (L _ [match]) _)) = do - -- setContext (Set.singleton LambdaExpr) $ do - -- -- TODO: Change this, HsLam binds do not need obey layout rules. - -- -- And will only ever have a single match - -- markLocated match - -- markExpr _ (HsLam _ _) = error $ "HsLam with other than one match" - exact (HsLam _ _) = error $ "HsLam with other than one match" + SourceText s -> printStringAdvance s >> return () + NoSourceText -> withPpr x >> return () + return x + + exact (HsLit an lit) = do + lit' <- withPpr lit + return (HsLit an lit') + exact (HsLam x mg) = do + mg' <- markAnnotated mg + return (HsLam x mg') exact (HsLamCase an lc_variant mg) = do - markEpAnn an AnnLam - markEpAnn an case lc_variant of LamCase -> AnnCase - LamCases -> AnnCases - markAnnotated mg + an0 <- markEpAnnL an lidl AnnLam + an1 <- markEpAnnL an0 lidl (case lc_variant of LamCase -> AnnCase + LamCases -> AnnCases) + mg' <- markAnnotated mg + return (HsLamCase an1 lc_variant mg') - exact (HsApp _an e1 e2) = do + exact (HsApp an e1 e2) = do p <- getPosP debugM $ "HsApp entered. p=" ++ show p - markAnnotated e1 - markAnnotated e2 - exact (HsAppType _ fun at arg) = do - markAnnotated fun - markToken at - markAnnotated arg - exact (OpApp _an e1 e2 e3) = do - markAnnotated e1 - markAnnotated e2 - markAnnotated e3 - - exact (NegApp an e _) = do - markEpAnn an AnnMinus - markAnnotated e - - exact (HsPar _an lpar e rpar) = do - markToken lpar - markAnnotated e + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + return (HsApp an e1' e2') + exact (HsAppType ss fun at arg) = do + fun' <- markAnnotated fun + at' <- markToken at + arg' <- markAnnotated arg + return (HsAppType ss fun' at' arg') + exact (OpApp an e1 e2 e3) = do + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + e3' <- markAnnotated e3 + return (OpApp an e1' e2' e3') + + exact (NegApp an e s) = do + an0 <- markEpAnnL an lidl AnnMinus + e' <- markAnnotated e + return (NegApp an0 e' s) + + exact (HsPar an lpar e rpar) = do + lpar' <- markToken lpar + e' <- markAnnotated e debugM $ "HsPar closing paren" - markToken rpar + rpar' <- markToken rpar debugM $ "HsPar done" + return (HsPar an lpar' e' rpar') - exact (SectionL _an expr op) = do - markAnnotated expr - markAnnotated op + exact (SectionL an expr op) = do + expr' <- markAnnotated expr + op' <- markAnnotated op + return (SectionL an expr' op') - exact (SectionR _an op expr) = do - markAnnotated op - markAnnotated expr + exact (SectionR an op expr) = do + op' <- markAnnotated op + expr' <- markAnnotated expr + return (SectionR an op' expr') exact (ExplicitTuple an args b) = do - if b == Boxed then markEpAnn an AnnOpenP - else markEpAnn an AnnOpenPH + an0 <- if b == Boxed then markEpAnnL an lidl AnnOpenP + else markEpAnnL an lidl AnnOpenPH - mapM_ markAnnotated args + args' <- mapM markAnnotated args - if b == Boxed then markEpAnn an AnnCloseP - else markEpAnn an AnnClosePH + an1 <- if b == Boxed then markEpAnnL an0 lidl AnnCloseP + else markEpAnnL an0 lidl AnnClosePH debugM $ "ExplicitTuple done" + return (ExplicitTuple an1 args' b) - exact (ExplicitSum an _alt _arity expr) = do - -- markEpAnn an AnnOpenPH - markAnnKw an aesOpen AnnOpenPH - markAnnKwAll an aesBarsBefore AnnVbar - markAnnotated expr - markAnnKwAll an aesBarsAfter AnnVbar - markAnnKw an aesClose AnnClosePH + exact (ExplicitSum an alt arity expr) = do + an0 <- markLensKw an laesOpen AnnOpenPH + an1 <- markAnnKwAllL an0 laesBarsBefore AnnVbar + expr' <- markAnnotated expr + an2 <- markAnnKwAllL an1 laesBarsAfter AnnVbar + an3 <- markLensKw an2 laesClose AnnClosePH + return (ExplicitSum an3 alt arity expr') exact (HsCase an e alts) = do - markAnnKw an hsCaseAnnCase AnnCase - markAnnotated e - markAnnKw an hsCaseAnnOf AnnOf - markEpAnn' an hsCaseAnnsRest AnnOpenC - markEpAnnAll an hsCaseAnnsRest AnnSemi - setLayoutBoth $ markAnnotated alts - markEpAnn' an hsCaseAnnsRest AnnCloseC - - -- exact x@(HsCase EpAnnNotUsed _ _) = withPpr x + an0 <- markAnnKwL an lhsCaseAnnCase AnnCase + e' <- markAnnotated e + an1 <- markAnnKwL an0 lhsCaseAnnOf AnnOf + an2 <- markEpAnnL an1 lhsCaseAnnsRest AnnOpenC + an3 <- markEpAnnAllL an2 lhsCaseAnnsRest AnnSemi + alts' <- setLayoutBoth $ markAnnotated alts + an4 <- markEpAnnL an3 lhsCaseAnnsRest AnnCloseC + return (HsCase an4 e' alts') + exact (HsIf an e1 e2 e3) = do - markAnnKw an aiIf AnnIf - markAnnotated e1 - markAnnKwM an aiThenSemi AnnSemi - markAnnKw an aiThen AnnThen - markAnnotated e2 - markAnnKwM an aiElseSemi AnnSemi - markAnnKw an aiElse AnnElse - markAnnotated e3 + an0 <- markAnnKwL an laiIf AnnIf + e1' <- markAnnotated e1 + an1 <- markLensKwM an0 laiThenSemi AnnSemi + an2 <- markAnnKwL an1 laiThen AnnThen + e2' <- markAnnotated e2 + an3 <- markLensKwM an2 laiElseSemi AnnSemi + an4 <- markAnnKwL an3 laiElse AnnElse + e3' <- markAnnotated e3 + return (HsIf an4 e1' e2' e3') exact (HsMultiIf an mg) = do - markEpAnn an AnnIf - markEpAnn an AnnOpenC -- optional - markAnnotated mg - markEpAnn an AnnCloseC -- optional + an0 <- markEpAnnL an lidl AnnIf + an1 <- markEpAnnL an0 lidl AnnOpenC -- optional + mg' <- markAnnotated mg + an2 <- markEpAnnL an1 lidl AnnCloseC -- optional + return (HsMultiIf an2 mg') - exact (HsLet _an tkLet binds tkIn e) = do + exact (HsLet an tkLet binds tkIn e) = do setLayoutBoth $ do -- Make sure the 'in' gets indented too - markToken tkLet + tkLet' <- markToken tkLet debugM $ "HSlet:binds coming" - setLayoutBoth $ markAnnotated binds + binds' <- setLayoutBoth $ markAnnotated binds debugM $ "HSlet:binds done" - markToken tkIn + tkIn' <- markToken tkIn debugM $ "HSlet:expr coming" - markAnnotated e + e' <- markAnnotated e + return (HsLet an tkLet' binds' tkIn' e') exact (HsDo an do_or_list_comp stmts) = do debugM $ "HsDo" - markAnnList True an $ exactDo an do_or_list_comp stmts + (an',stmts') <- markAnnListA True an $ \a -> exactDo a do_or_list_comp stmts + return (HsDo an' do_or_list_comp stmts') exact (ExplicitList an es) = do debugM $ "ExplicitList start" - markLocatedMAA an al_open - markAnnotated es - markLocatedMAA an al_close + an0 <- markLensMAA an lal_open + es' <- markAnnotated es + an1 <- markLensMAA an0 lal_close debugM $ "ExplicitList end" + return (ExplicitList an1 es') exact (RecordCon an con_id binds) = do - markAnnotated con_id - markEpAnn an AnnOpenC - markAnnotated binds - markEpAnn an AnnCloseC + con_id' <- markAnnotated con_id + an0 <- markEpAnnL an lidl AnnOpenC + binds' <- markAnnotated binds + an1 <- markEpAnnL an0 lidl AnnCloseC + return (RecordCon an1 con_id' binds') exact (RecordUpd an expr fields) = do - markAnnotated expr - markEpAnn an AnnOpenC - markAnnotated fields - markEpAnn an AnnCloseC - exact (HsGetField _an expr field) = do - markAnnotated expr - markAnnotated field + expr' <- markAnnotated expr + an0 <- markEpAnnL an lidl AnnOpenC + fields' <- markAnnotated fields + an1 <- markEpAnnL an0 lidl AnnCloseC + return (RecordUpd an1 expr' fields') + exact (HsGetField an expr field) = do + expr' <- markAnnotated expr + field' <- markAnnotated field + return (HsGetField an expr' field') exact (HsProjection an flds) = do - markAnnKw an apOpen AnnOpenP - markAnnotated flds - markAnnKw an apClose AnnCloseP + an0 <- markAnnKwL an lapOpen AnnOpenP + flds' <- mapM markAnnotated flds + an1 <- markAnnKwL an0 lapClose AnnCloseP + return (HsProjection an1 flds') exact (ExprWithTySig an expr sig) = do - markAnnotated expr - markEpAnn an AnnDcolon - markAnnotated sig - exact (ArithSeq an _ seqInfo) = do - markEpAnn an AnnOpenS -- '[' - case seqInfo of + expr' <- markAnnotated expr + an0 <- markEpAnnL an lidl AnnDcolon + sig' <- markAnnotated sig + return (ExprWithTySig an0 expr' sig') + exact (ArithSeq an s seqInfo) = do + an0 <- markEpAnnL an lidl AnnOpenS -- '[' + (an1, seqInfo') <- + case seqInfo of From e -> do - markAnnotated e - markEpAnn an AnnDotdot + e' <- markAnnotated e + an' <- markEpAnnL an0 lidl AnnDotdot + return (an', From e') FromTo e1 e2 -> do - markAnnotated e1 - markEpAnn an AnnDotdot - markAnnotated e2 + e1' <- markAnnotated e1 + an' <- markEpAnnL an0 lidl AnnDotdot + e2' <- markAnnotated e2 + return (an', FromTo e1' e2') FromThen e1 e2 -> do - markAnnotated e1 - markEpAnn an AnnComma - markAnnotated e2 - markEpAnn an AnnDotdot + e1' <- markAnnotated e1 + an' <- markEpAnnL an0 lidl AnnComma + e2' <- markAnnotated e2 + an'' <- markEpAnnL an' lidl AnnDotdot + return (an'', FromThen e1' e2') FromThenTo e1 e2 e3 -> do - markAnnotated e1 - markEpAnn an AnnComma - markAnnotated e2 - markEpAnn an AnnDotdot - markAnnotated e3 - markEpAnn an AnnCloseS -- ']' + e1' <- markAnnotated e1 + an' <- markEpAnnL an0 lidl AnnComma + e2' <- markAnnotated e2 + an'' <- markEpAnnL an' lidl AnnDotdot + e3' <- markAnnotated e3 + return (an'', FromThenTo e1' e2' e3') + an2 <- markEpAnnL an1 lidl AnnCloseS -- ']' + return (ArithSeq an2 s seqInfo') exact (HsTypedBracket an e) = do - markLocatedAALS an id AnnOpen (Just "[||") - markLocatedAALS an id AnnOpenE (Just "[e||") - markAnnotated e - markLocatedAALS an id AnnClose (Just "||]") - - exact (HsUntypedBracket an (ExpBr _ e)) = do - markEpAnn an AnnOpenEQ -- "[|" - markEpAnn an AnnOpenE -- "[e|" -- optional - markAnnotated e - markEpAnn an AnnCloseQ -- "|]" - exact (HsUntypedBracket an (PatBr _ e)) = do - markLocatedAALS an id AnnOpen (Just "[p|") - markAnnotated e - markEpAnn an AnnCloseQ -- "|]" - exact (HsUntypedBracket an (DecBrL _ e)) = do - markLocatedAALS an id AnnOpen (Just "[d|") - markAnnotated e - markEpAnn an AnnCloseQ -- "|]" - -- -- exact (HsUntypedBracket an (DecBrG _ _)) = - -- -- traceM "warning: DecBrG introduced after renamer" - exact (HsUntypedBracket an (TypBr _ e)) = do - markLocatedAALS an id AnnOpen (Just "[t|") - markAnnotated e - markEpAnn an AnnCloseQ -- "|]" - exact (HsUntypedBracket an (VarBr _ b e)) = do - if b + an0 <- markEpAnnLMS an lidl AnnOpen (Just "[||") + an1 <- markEpAnnLMS an0 lidl AnnOpenE (Just "[e||") + e' <- markAnnotated e + an2 <- markEpAnnLMS an1 lidl AnnClose (Just "||]") + return (HsTypedBracket an2 e') + + exact (HsUntypedBracket an (ExpBr a e)) = do + an0 <- markEpAnnL an lidl AnnOpenEQ -- "[|" + an1 <- markEpAnnL an0 lidl AnnOpenE -- "[e|" -- optional + e' <- markAnnotated e + an2 <- markEpAnnL an1 lidl AnnCloseQ -- "|]" + return (HsUntypedBracket an2 (ExpBr a e')) + + exact (HsUntypedBracket an (PatBr a e)) = do + an0 <- markEpAnnLMS an lidl AnnOpen (Just "[p|") + e' <- markAnnotated e + an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]" + return (HsUntypedBracket an1 (PatBr a e')) + + exact (HsUntypedBracket an (DecBrL a e)) = do + an0 <- markEpAnnLMS an lidl AnnOpen (Just "[d|") + an1 <- markEpAnnL an lidl AnnOpenC + e' <- markAnnotated e + an2 <- markEpAnnL an1 lidl AnnCloseC + an3 <- markEpAnnL an2 lidl AnnCloseQ -- "|]" + return (HsUntypedBracket an3 (DecBrL a e')) + + exact (HsUntypedBracket an (TypBr a e)) = do + an0 <- markEpAnnLMS an lidl AnnOpen (Just "[t|") + e' <- markAnnotated e + an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]" + return (HsUntypedBracket an1 (TypBr a e')) + + exact (HsUntypedBracket an (VarBr a b e)) = do + (an0, e') <- if b then do - markEpAnn an AnnSimpleQuote - markAnnotated e + an' <- markEpAnnL an lidl AnnSimpleQuote + e' <- markAnnotated e + return (an', e') else do - markEpAnn an AnnThTyQuote - markAnnotated e - - exact (HsTypedSplice (_, an) e) = do - markEpAnn an AnnDollarDollar - markAnnotated e - exact (HsUntypedSplice _ sp) = markAnnotated sp + an' <- markEpAnnL an lidl AnnThTyQuote + e' <- markAnnotated e + return (an', e') + return (HsUntypedBracket an0 (VarBr a b e')) + + exact (HsTypedSplice (x,an) s) = do + an0 <- markEpAnnL an lidl AnnDollarDollar + s' <- exact s + return (HsTypedSplice (x,an0) s') + exact (HsUntypedSplice an s) = do + s' <- exact s + return (HsUntypedSplice an s') exact (HsProc an p c) = do debugM $ "HsProc start" - markEpAnn an AnnProc - markAnnotated p - markEpAnn an AnnRarrow + an0 <- markEpAnnL an lidl AnnProc + p' <- markAnnotated p + an1 <- markEpAnnL an0 lidl AnnRarrow debugM $ "HsProc after AnnRarrow" - markAnnotated c + c' <- markAnnotated c + return (HsProc an1 p' c') exact (HsStatic an e) = do - markEpAnn an AnnStatic - markAnnotated e - - exact (HsPragE _ prag e) = do - markAnnotated prag - markAnnotated e + an0 <- markEpAnnL an lidl AnnStatic + e' <- markAnnotated e + return (HsStatic an0 e') + + exact (HsPragE a prag e) = do + prag' <- markAnnotated prag + e' <- markAnnotated e + return (HsPragE a prag' e') exact x = error $ "exact HsExpr for:" ++ showAst x -- --------------------------------------------------------------------- -exactDo :: (ExactPrint body) - => EpAnn AnnList -> HsDoFlavour -> body -> EPP () -exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >> markAnnotatedWithLayout stmts -exactDo an GhciStmtCtxt stmts = markLocatedAAL an al_rest AnnDo >> markAnnotatedWithLayout stmts -exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >> markAnnotatedWithLayout stmts -exactDo _ ListComp stmts = markAnnotatedWithLayout stmts -exactDo _ MonadComp stmts = markAnnotatedWithLayout stmts +exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) + => EpAnn AnnList -> HsDoFlavour -> LocatedAn an a + -> EP w m (EpAnn AnnList, LocatedAn an a) +exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an GhciStmtCtxt stmts = markEpAnnL an lal_rest AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >>= \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an ListComp stmts = markMaybeDodgyStmts an stmts +exactDo an MonadComp stmts = markMaybeDodgyStmts an stmts -exactMdo :: EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EPP () -exactMdo an Nothing kw = markLocatedAAL an al_rest kw -exactMdo an (Just module_name) kw = markLocatedAALS an al_rest kw (Just n) +exactMdo :: (Monad m, Monoid w) + => EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EP w m (EpAnn AnnList) +exactMdo an Nothing kw = markEpAnnL an lal_rest kw +exactMdo an (Just module_name) kw = markEpAnnLMS an lal_rest kw (Just n) where - n = (moduleNameString module_name) ++ "." ++ (keywordToString (G kw)) + n = (moduleNameString module_name) ++ "." ++ (keywordToString kw) +markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) + => EpAnn AnnList -> LocatedAn an a -> EP w m (EpAnn AnnList, LocatedAn an a) +markMaybeDodgyStmts an stmts = + if isGoodSrcSpan (getLocA stmts) + then do + r <- markAnnotatedWithLayout stmts + return (an, r) + else return (an, stmts) -- --------------------------------------------------------------------- instance ExactPrint (HsPragE GhcPs) where getAnnotationEntry HsPragSCC{} = NoEntryVal + setAnnotationAnchor a _ _ = a - exact (HsPragSCC (an, st) sl) = do - markAnnOpenP an st "{-# SCC" + exact (HsPragSCC (an,st) sl) = do + an0 <- markAnnOpenP an st "{-# SCC" let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl) - markLocatedAALS an apr_rest AnnVal (Just txt) -- optional - markLocatedAALS an apr_rest AnnValStr (Just txt) -- optional - markAnnCloseP an - - -- markExpr _ (GHC.HsPragE _ prag e) = do - -- case prag of - -- (GHC.HsPragSCC _ src csFStr) -> do - -- markAnnOpen src "{-# SCC" - -- let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) - -- markWithStringOptional GHC.AnnVal txt - -- markWithString GHC.AnnValStr txt - -- markWithString GHC.AnnClose "#-}" - -- markLocated e - - -- (GHC.HsPragTick _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4))) -> do - -- -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - -- markAnnOpen src "{-# GENERATED" - -- markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING - - -- let - -- markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) - -- markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s - - -- markOne 1 v1 s1 -- INTEGER - -- markOffset GHC.AnnColon 0 -- ':' - -- markOne 2 v2 s2 -- INTEGER - -- mark GHC.AnnMinus -- '-' - -- markOne 3 v3 s3 -- INTEGER - -- markOffset GHC.AnnColon 1 -- ':' - -- markOne 4 v4 s4 -- INTEGER - -- markWithString GHC.AnnClose "#-}" - -- markLocated e + an1 <- markEpAnnLMS an0 lapr_rest AnnVal (Just txt) -- optional + an2 <- markEpAnnLMS an1 lapr_rest AnnValStr (Just txt) -- optional + an3 <- markAnnCloseP an2 + return (HsPragSCC (an3,st) sl) + -- --------------------------------------------------------------------- @@ -2164,91 +3030,112 @@ instance ExactPrint (HsUntypedSplice GhcPs) where getAnnotationEntry (HsUntypedSpliceExpr an _) = fromAnn an getAnnotationEntry (HsQuasiQuote _ _ _) = NoEntryVal - exact (HsUntypedSpliceExpr an b) = do - markEpAnn an AnnDollar - markAnnotated b + setAnnotationAnchor (HsUntypedSpliceExpr an e) anc cs = HsUntypedSpliceExpr (setAnchorEpa an anc cs) e + setAnnotationAnchor a@HsQuasiQuote {} _ _ = a - exact (HsQuasiQuote _ q (L (SrcSpanAnn _ ss) fs)) = do + exact (HsUntypedSpliceExpr an e) = do + an0 <- markEpAnnL an lidl AnnDollar + e' <- markAnnotated e + return (HsUntypedSpliceExpr an0 e') + + exact (HsQuasiQuote an q (L l fs)) = do -- The quasiquote string does not honour layout offsets. Store -- the colOffset for now. -- TODO: use local? oldOffset <- getLayoutOffsetP - setLayoutOffsetP 0 + EPState{pMarkLayout} <- get + unless pMarkLayout $ setLayoutOffsetP 0 printStringAdvance -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 ("[" ++ (showPprUnsafe q) ++ "|" ++ (unpackFS fs) ++ "|]") - setLayoutOffsetP oldOffset - p <- getPosP - debugM $ "HsQuasiQuote:after:(p,ss)=" ++ show (p,ss2range ss) + unless pMarkLayout $ setLayoutOffsetP oldOffset + return (HsQuasiQuote an q (L l fs)) -- --------------------------------------------------------------------- -- TODO:AZ: combine these instances instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where getAnnotationEntry = const NoEntryVal - exact (MG _ matches) = do + setAnnotationAnchor a _ _ = a + exact (MG x matches) = do -- TODO:AZ use SortKey, in MG ann. - markAnnotated matches + matches' <- if isGoodSrcSpan (getLocA matches) + then markAnnotated matches + else return matches + return (MG x matches') instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where getAnnotationEntry = const NoEntryVal - exact (MG _ matches) = do + setAnnotationAnchor a _ _ = a + exact (MG x matches) = do -- TODO:AZ use SortKey, in MG ann. - markAnnotated matches + matches' <- if isGoodSrcSpan (getLocA matches) + then markAnnotated matches + else return matches + return (MG x matches') -- --------------------------------------------------------------------- instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a exact (HsRecFields fields mdot) = do - markAnnotated fields + fields' <- markAnnotated fields case mdot of Nothing -> return () Just (L ss _) -> - printStringAtSs ss ".." + printStringAtSs ss ".." >> return () -- Note: mdot contains the SrcSpan where the ".." appears, if present + return (HsRecFields fields' mdot) -- --------------------------------------------------------------------- --- instance (ExactPrint body) => ExactPrint (HsRecField GhcPs body) where instance (ExactPrint body) => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) body) where getAnnotationEntry x = fromAnn (hfbAnn x) + setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun) exact (HsFieldBind an f arg isPun) = do debugM $ "HsFieldBind" - markAnnotated f - if isPun then return () + f' <- markAnnotated f + (an0, arg') <- if isPun then return (an, arg) else do - markEpAnn an AnnEqual - markAnnotated arg + an0 <- markEpAnnL an lidl AnnEqual + arg' <- markAnnotated arg + return (an0, arg') + return (HsFieldBind an0 f' arg' isPun) -- --------------------------------------------------------------------- instance (ExactPrint body) => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) body) where getAnnotationEntry x = fromAnn (hfbAnn x) + setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun) + exact (HsFieldBind an f arg isPun) = do debugM $ "HsFieldBind FieldLabelStrings" - markAnnotated f - if isPun then return () + f' <- markAnnotated f + (an0, arg') <- if isPun then return (an, arg) else do - markEpAnn an AnnEqual - markAnnotated arg + an0 <- markEpAnnL an lidl AnnEqual + arg' <- markAnnotated arg + return (an0, arg') + return (HsFieldBind an0 f' arg' isPun) -- --------------------------------------------------------------------- --- instance ExactPrint (HsRecUpdField GhcPs ) where instance (ExactPrint (LocatedA body)) => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where --- instance (ExactPrint body) - -- => ExactPrint (HsFieldBind (AmbiguousFieldOcc GhcPs) body) where getAnnotationEntry x = fromAnn (hfbAnn x) + setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun) exact (HsFieldBind an f arg isPun) = do debugM $ "HsRecUpdField" - markAnnotated f - if isPun then return () - else markEpAnn an AnnEqual - unless ((locA $ getLoc arg) == noSrcSpan ) $ markAnnotated arg + f' <- markAnnotated f + an0 <- if isPun then return an + else markEpAnnL an lidl AnnEqual + arg' <- if ((locA $ getLoc arg) == noSrcSpan ) + then return arg + else markAnnotated arg + return (HsFieldBind an0 f' arg' isPun) -- --------------------------------------------------------------------- instance @@ -2258,25 +3145,31 @@ instance (Either [LocatedA (HsFieldBind (LocatedAn NoEpAnns (a GhcPs)) body)] [LocatedA (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body)]) where getAnnotationEntry = const NoEntryVal - exact (Left rbinds) = markAnnotated rbinds - exact (Right pbinds) = markAnnotated pbinds + setAnnotationAnchor a _ _ = a + + exact (Left rbinds) = Left <$> markAnnotated rbinds + exact (Right pbinds) = Right <$> markAnnotated pbinds -- --------------------------------------------------------------------- instance ExactPrint (FieldLabelStrings GhcPs) where getAnnotationEntry = const NoEntryVal - exact (FieldLabelStrings fs) = markAnnotated fs + setAnnotationAnchor a _ _ = a + exact (FieldLabelStrings fs) = FieldLabelStrings <$> markAnnotated fs -- --------------------------------------------------------------------- instance ExactPrint (DotFieldOcc GhcPs) where getAnnotationEntry (DotFieldOcc an _) = fromAnn an + setAnnotationAnchor (DotFieldOcc an a) anc cs = DotFieldOcc (setAnchorEpa an anc cs) a + exact (DotFieldOcc an (L loc (FieldLabelString fs))) = do - markAnnKwM an afDot AnnDot + an0 <- markLensKwM an lafDot AnnDot -- The field name has a SrcSpanAnnN, print it as a -- LocatedN RdrName - markAnnotated (L loc (mkVarUnqual fs)) + L loc' _ <- markAnnotated (L loc (mkVarUnqual fs)) + return (DotFieldOcc an0 (L loc' (FieldLabelString fs))) -- --------------------------------------------------------------------- @@ -2284,16 +3177,20 @@ instance ExactPrint (HsTupArg GhcPs) where getAnnotationEntry (Present an _) = fromAnn an getAnnotationEntry (Missing an) = fromAnn an - exact (Present _ e) = markAnnotated e + setAnnotationAnchor (Present an a) anc cs = Present (setAnchorEpa an anc cs) a + setAnnotationAnchor (Missing an) anc cs = Missing (setAnchorEpa an anc cs) + + exact (Present a e) = Present a <$> markAnnotated e - exact (Missing EpAnnNotUsed) = return () - exact (Missing _) = printStringAdvance "," + exact a@(Missing EpAnnNotUsed) = return a + exact a@(Missing _) = printStringAdvance "," >> return a -- --------------------------------------------------------------------- instance ExactPrint (HsCmdTop GhcPs) where getAnnotationEntry = const NoEntryVal - exact (HsCmdTop _ cmd) = markAnnotated cmd + setAnnotationAnchor a _ _ = a + exact (HsCmdTop a cmd) = HsCmdTop a <$> markAnnotated cmd -- --------------------------------------------------------------------- @@ -2309,99 +3206,104 @@ instance ExactPrint (HsCmd GhcPs) where getAnnotationEntry (HsCmdLet an _ _ _ _) = fromAnn an getAnnotationEntry (HsCmdDo an _) = fromAnn an - - - exact (HsCmdArrApp an arr arg _o isRightToLeft) = do + setAnnotationAnchor (HsCmdArrApp an a b c d) anc cs = (HsCmdArrApp (setAnchorEpa an anc cs) a b c d) + setAnnotationAnchor (HsCmdArrForm an a b c d ) anc cs = (HsCmdArrForm (setAnchorEpa an anc cs) a b c d ) + setAnnotationAnchor (HsCmdApp an a b ) anc cs = (HsCmdApp (setAnchorEpa an anc cs) a b ) + setAnnotationAnchor a@(HsCmdLam {}) _ _s = a + setAnnotationAnchor (HsCmdPar an a b c) anc cs = (HsCmdPar (setAnchorEpa an anc cs) a b c) + setAnnotationAnchor (HsCmdCase an a b) anc cs = (HsCmdCase (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsCmdLamCase an a b) anc cs = (HsCmdLamCase (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsCmdIf an a b c d) anc cs = (HsCmdIf (setAnchorEpa an anc cs) a b c d) + setAnnotationAnchor (HsCmdLet an a b c d) anc cs = (HsCmdLet (setAnchorEpa an anc cs) a b c d) + setAnnotationAnchor (HsCmdDo an a) anc cs = (HsCmdDo (setAnchorEpa an anc cs) a) + + exact (HsCmdArrApp an arr arg o isRightToLeft) = do if isRightToLeft then do - markAnnotated arr - markKw (anns an) - markAnnotated arg + arr' <- markAnnotated arr + an0 <- markKw (anns an) + arg' <- markAnnotated arg + let an1 = an{anns = an0} + return (HsCmdArrApp an1 arr' arg' o isRightToLeft) else do - markAnnotated arg - markKw (anns an) - markAnnotated arr - - exact (HsCmdArrForm an e fixity _mf cs) = do - markLocatedMAA an al_open - case (fixity, cs) of + arg' <- markAnnotated arg + an0 <- markKw (anns an) + arr' <- markAnnotated arr + let an1 = an {anns = an0} + return (HsCmdArrApp an1 arr' arg' o isRightToLeft) + + exact (HsCmdArrForm an e fixity mf cs) = do + an0 <- markLensMAA an lal_open + (e',cs') <- case (fixity, cs) of (Infix, (arg1:argrest)) -> do - markAnnotated arg1 - markAnnotated e - markAnnotated argrest + arg1' <- markAnnotated arg1 + e' <- markAnnotated e + argrest' <- markAnnotated argrest + return (e', arg1':argrest') (Prefix, _) -> do - markAnnotated e - markAnnotated cs + e' <- markAnnotated e + cs' <- markAnnotated cs + return (e', cs') (Infix, []) -> error "Not possible" - markLocatedMAA an al_close + an1 <- markLensMAA an0 lal_close + return (HsCmdArrForm an1 e' fixity mf cs') - exact (HsCmdApp _an e1 e2) = do - markAnnotated e1 - markAnnotated e2 + exact (HsCmdApp an e1 e2) = do + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + return (HsCmdApp an e1' e2') - exact (HsCmdLam _ match) = markAnnotated match + exact (HsCmdLam a match) = do + match' <- markAnnotated match + return (HsCmdLam a match') - exact (HsCmdPar _an lpar e rpar) = do - markToken lpar - markAnnotated e - markToken rpar + exact (HsCmdPar an lpar e rpar) = do + lpar' <- markToken lpar + e' <- markAnnotated e + rpar' <- markToken rpar + return (HsCmdPar an lpar' e' rpar') exact (HsCmdCase an e alts) = do - markAnnKw an hsCaseAnnCase AnnCase - markAnnotated e - markAnnKw an hsCaseAnnOf AnnOf - markEpAnn' an hsCaseAnnsRest AnnOpenC - markEpAnnAll an hsCaseAnnsRest AnnSemi - markAnnotated alts - markEpAnn' an hsCaseAnnsRest AnnCloseC + an0 <- markLensKw an lhsCaseAnnCase AnnCase + e' <- markAnnotated e + an1 <- markLensKw an0 lhsCaseAnnOf AnnOf + an2 <- markEpAnnL an1 lhsCaseAnnsRest AnnOpenC + an3 <- markEpAnnAllL an2 lhsCaseAnnsRest AnnSemi + alts' <- markAnnotated alts + an4 <- markEpAnnL an3 lhsCaseAnnsRest AnnCloseC + return (HsCmdCase an4 e' alts') exact (HsCmdLamCase an lc_variant matches) = do - markEpAnn an AnnLam - markEpAnn an case lc_variant of LamCase -> AnnCase - LamCases -> AnnCases - markAnnotated matches - - exact (HsCmdIf an _ e1 e2 e3) = do - markAnnKw an aiIf AnnIf - markAnnotated e1 - markAnnKwM an aiThenSemi AnnSemi - markAnnKw an aiThen AnnThen - markAnnotated e2 - markAnnKwM an aiElseSemi AnnSemi - markAnnKw an aiElse AnnElse - markAnnotated e3 - --- markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do --- mark GHC.AnnLet --- markOptional GHC.AnnOpenC --- markLocalBindsWithLayout binds --- markOptional GHC.AnnCloseC --- mark GHC.AnnIn --- markLocated e + an0 <- markEpAnnL an lidl AnnLam + an1 <- markEpAnnL an0 lidl (case lc_variant of LamCase -> AnnCase + LamCases -> AnnCases) + matches' <- markAnnotated matches + return (HsCmdLamCase an1 lc_variant matches') + + exact (HsCmdIf an a e1 e2 e3) = do + an0 <- markLensKw an laiIf AnnIf + e1' <- markAnnotated e1 + an1 <- markLensKwM an0 laiThenSemi AnnSemi + an2 <- markLensKw an1 laiThen AnnThen + e2' <- markAnnotated e2 + an3 <- markLensKwM an2 laiElseSemi AnnSemi + an4 <- markLensKw an3 laiElse AnnElse + e3' <- markAnnotated e3 + return (HsCmdIf an4 a e1' e2' e3') + + exact (HsCmdLet an tkLet binds tkIn e) = do + setLayoutBoth $ do -- Make sure the 'in' gets indented too + tkLet' <- markToken tkLet + binds' <- setLayoutBoth $ markAnnotated binds + tkIn' <- markToken tkIn + e' <- markAnnotated e + return (HsCmdLet an tkLet' binds' tkIn' e') exact (HsCmdDo an es) = do debugM $ "HsCmdDo" - markEpAnn' an al_rest AnnDo - markAnnotated es - --- markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do --- mark GHC.AnnDo --- markOptional GHC.AnnOpenC --- markListWithLayout es --- markOptional GHC.AnnCloseC - --- markAST _ (GHC.HsCmdWrap {}) = --- traceM "warning: HsCmdWrap introduced after renaming" - --- markAST _ (GHC.XCmd x) = error $ "got XCmd for:" ++ showPprUnsafe x - - exact x = error $ "exact HsCmd for:" ++ showAst x - --- --------------------------------------------------------------------- - --- instance ExactPrint (CmdLStmt GhcPs) where --- getAnnotationEntry = const NoEntryVal --- exact (L _ a) = markAnnotated a + an0 <- markEpAnnL an lal_rest AnnDo + es' <- markAnnotated es + return (HsCmdDo an0 es') -- --------------------------------------------------------------------- @@ -2422,142 +3324,95 @@ instance ( ----------------------------------------------------------------- - exact (LastStmt _ body _ _) = do + setAnnotationAnchor a@(LastStmt _ _ _ _) _ _s = a + setAnnotationAnchor (BindStmt an a b) anc cs = (BindStmt (setAnchorEpa an anc cs) a b) + setAnnotationAnchor a@(ApplicativeStmt _ _ _) _ _s = a + setAnnotationAnchor a@(BodyStmt _ _ _ _) _ _s = a + setAnnotationAnchor (LetStmt an a) anc cs = (LetStmt (setAnchorEpa an anc cs) a) + setAnnotationAnchor a@(ParStmt _ _ _ _) _ _s = a + setAnnotationAnchor (TransStmt an a b c d e f g h) anc cs = (TransStmt (setAnchorEpa an anc cs) a b c d e f g h) + setAnnotationAnchor (RecStmt an a b c d e f) anc cs = (RecStmt (setAnchorEpa an anc cs) a b c d e f) + + ----------------------------------------------------------------- + + exact (LastStmt a body b c) = do debugM $ "LastStmt" - markAnnotated body + body' <- markAnnotated body + return (LastStmt a body' b c) exact (BindStmt an pat body) = do debugM $ "BindStmt" - markAnnotated pat - markEpAnn an AnnLarrow - markAnnotated body + pat' <- markAnnotated pat + an0 <- markEpAnnL an lidl AnnLarrow + body' <- markAnnotated body + return (BindStmt an0 pat' body') exact (ApplicativeStmt _ _body _) = do - debugM $ "ApplicativeStmt" - -- TODO: ApplicativeStmt - -- markAnnotated body - error $ "need to complete ApplicativeStmt" + error $ "ApplicativeStmt is introduced in the renamer" - exact (BodyStmt _ body _ _) = do + exact (BodyStmt a body b c) = do debugM $ "BodyStmt" - markAnnotated body + body' <- markAnnotated body + return (BodyStmt a body' b c) exact (LetStmt an binds) = do debugM $ "LetStmt" - markEpAnn an AnnLet - markAnnotated binds + an0 <- markEpAnnL an lidl AnnLet + binds' <- markAnnotated binds + return (LetStmt an0 binds') - exact (ParStmt _ pbs _ _) = do + exact (ParStmt a pbs b c) = do debugM $ "ParStmt" - markAnnotated pbs - - -- markAST l (GHC.ParStmt _ pbs _ _) = do - -- -- Within a given parallel list comprehension,one of the sections to be done - -- -- in parallel. It is a normal list comprehension, so has a list of - -- -- ParStmtBlock, one for each part of the sub- list comprehension - - - -- ifInContext (Set.singleton Intercalate) - -- ( - - -- unsetContext Intercalate $ - -- markListWithContextsFunction - -- (LC (Set.singleton Intercalate) -- only - -- Set.empty -- first - -- Set.empty -- middle - -- (Set.singleton Intercalate) -- last - -- ) (markAST l) pbs - -- ) - -- ( - -- unsetContext Intercalate $ - -- markListWithContextsFunction - -- (LC Set.empty -- only - -- (Set.fromList [AddVbar]) -- first - -- (Set.fromList [AddVbar]) -- middle - -- Set.empty -- last - -- ) (markAST l) pbs - -- ) - -- markTrailingSemi - - --- pprStmt (TransStmt { trS_stmts = stmts, trS_by = by --- , trS_using = using, trS_form = form }) --- = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) - - exact (TransStmt an form stmts _b using by _ _ _) = do - debugM $ "TransStmt" - markAnnotated stmts - exactTransStmt an by using form - - -- markAST _ (GHC.TransStmt _ form stmts _b using by _ _ _) = do - -- setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts - -- case form of - -- GHC.ThenForm -> do - -- mark GHC.AnnThen - -- unsetContext Intercalate $ markLocated using - -- case by of - -- Just b -> do - -- mark GHC.AnnBy - -- unsetContext Intercalate $ markLocated b - -- Nothing -> return () - -- GHC.GroupForm -> do - -- mark GHC.AnnThen - -- mark GHC.AnnGroup - -- case by of - -- Just b -> mark GHC.AnnBy >> markLocated b - -- Nothing -> return () - -- mark GHC.AnnUsing - -- markLocated using - -- inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - -- inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - -- markTrailingSemi - - exact (RecStmt an stmts _ _ _ _ _) = do - debugM $ "RecStmt" - markLocatedAAL an al_rest AnnRec - markAnnList True an (markAnnotated stmts) - - -- markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do - -- mark GHC.AnnRec - -- markOptional GHC.AnnOpenC - -- markInside GHC.AnnSemi - -- markListWithLayout stmts - -- markOptional GHC.AnnCloseC - -- inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - -- inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - -- markTrailingSemi + pbs' <- markAnnotated pbs + return (ParStmt a pbs' b c) - -- exact x = error $ "exact CmdLStmt for:" ++ showAst x - -- exact x = error $ "exact CmdLStmt for:" + exact (TransStmt an form stmts b using by c d e) = do + debugM $ "TransStmt" + stmts' <- markAnnotated stmts + (an', by', using') <- exactTransStmt an by using form + return (TransStmt an' form stmts' b using' by' c d e) + exact (RecStmt an stmts a b c d e) = do + debugM $ "RecStmt" + an0 <- markEpAnnL an lal_rest AnnRec + (an1, stmts') <- markAnnList True an0 (markAnnotated stmts) + return (RecStmt an1 stmts' a b c d e) -- --------------------------------------------------------------------- instance ExactPrint (ParStmtBlock GhcPs GhcPs) where getAnnotationEntry = const NoEntryVal - exact (ParStmtBlock _ stmts _ _) = markAnnotated stmts - -exactTransStmt :: EpAnn [AddEpAnn] -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm -> EPP () + setAnnotationAnchor a _ _ = a + exact (ParStmtBlock a stmts b c) = do + stmts' <- markAnnotated stmts + return (ParStmtBlock a stmts' b c) + +exactTransStmt :: (Monad m, Monoid w) + => EpAnn [AddEpAnn] -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm + -> EP w m (EpAnn [AddEpAnn], Maybe (LHsExpr GhcPs), (LHsExpr GhcPs)) exactTransStmt an by using ThenForm = do debugM $ "exactTransStmt:ThenForm" - markEpAnn an AnnThen - markAnnotated using + an0 <- markEpAnnL an lidl AnnThen + using' <- markAnnotated using case by of - Nothing -> return () + Nothing -> return (an0, by, using') Just b -> do - markEpAnn an AnnBy - markAnnotated b + an1 <- markEpAnnL an0 lidl AnnBy + b' <- markAnnotated b + return (an1, Just b', using') exactTransStmt an by using GroupForm = do debugM $ "exactTransStmt:GroupForm" - markEpAnn an AnnThen - markEpAnn an AnnGroup - case by of + an0 <- markEpAnnL an lidl AnnThen + an1 <- markEpAnnL an0 lidl AnnGroup + (an2, by') <- case by of + Nothing -> return (an1, by) Just b -> do - markEpAnn an AnnBy - markAnnotated b - Nothing -> return () - markEpAnn an AnnUsing - markAnnotated using + an2 <- markEpAnnL an1 lidl AnnBy + b' <- markAnnotated b + return (an2, Just b') + an3 <- markEpAnnL an2 lidl AnnUsing + using' <- markAnnotated using + return (an3, by', using') -- --------------------------------------------------------------------- @@ -2567,57 +3422,44 @@ instance ExactPrint (TyClDecl GhcPs) where getAnnotationEntry (DataDecl { tcdDExt = an }) = fromAnn an getAnnotationEntry (ClassDecl { tcdCExt = (an, _, _) }) = fromAnn an - exact (FamDecl _ decl) = do - markAnnotated decl + setAnnotationAnchor a@FamDecl{} _ _s = a + setAnnotationAnchor x@SynDecl{} anc cs = x { tcdSExt = setAnchorEpa (tcdSExt x) anc cs } + setAnnotationAnchor x@DataDecl{} anc cs = x { tcdDExt = setAnchorEpa (tcdDExt x) anc cs } + setAnnotationAnchor x@ClassDecl{} anc cs = x { tcdCExt = (setAnchorEpa an anc cs, a, b) } + where + (an,a,b) = tcdCExt x + + exact (FamDecl a decl) = do + decl' <- markAnnotated decl + return (FamDecl a decl') exact (SynDecl { tcdSExt = an , tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity , tcdRhs = rhs }) = do - -- There may be arbitrary parens around parts of the constructor that are - -- infix. - -- Turn these into comments so that they feed into the right place automatically - annotationsToComments (epAnnAnns an) [AnnOpenP,AnnCloseP] - markEpAnn an AnnType - - -- markTyClass Nothing fixity ln tyvars - exactVanillaDeclHead ltycon tyvars fixity Nothing - markEpAnn an AnnEqual - markAnnotated rhs - - -- ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity - -- , tcdRhs = rhs }) - -- = hang (text "type" <+> - -- pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> equals) - -- 4 (ppr rhs) --- {- --- SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs --- , tcdLName :: Located (IdP pass) -- ^ Type constructor --- , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an --- -- associated type these --- -- include outer binders --- , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration --- , tcdRhs :: LHsType pass } -- ^ RHS of type declaration - --- -} --- markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity typ) = do --- -- There may be arbitrary parens around parts of the constructor that are --- -- infix. --- -- Turn these into comments so that they feed into the right place automatically --- -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] --- mark GHC.AnnType - --- markTyClass Nothing fixity ln tyvars --- mark GHC.AnnEqual --- markLocated typ --- markTrailingSemi - + -- There may be arbitrary parens around parts of the constructor + -- that are infix. Turn these into comments so that they feed + -- into the right place automatically + an0 <- annotationsToComments an lidl [AnnOpenP,AnnCloseP] + an1 <- markEpAnnL an0 lidl AnnType + + (_anx, ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing + an2 <- markEpAnnL an1 lidl AnnEqual + rhs' <- markAnnotated rhs + return (SynDecl { tcdSExt = an2 + , tcdLName = ltycon', tcdTyVars = tyvars', tcdFixity = fixity + , tcdRhs = rhs' }) + + -- TODO: add a workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/20452 exact (DataDecl { tcdDExt = an, tcdLName = ltycon, tcdTyVars = tyvars - , tcdFixity = fixity, tcdDataDefn = defn }) = - exactDataDefn an (exactVanillaDeclHead ltycon tyvars fixity) defn + , tcdFixity = fixity, tcdDataDefn = defn }) = do + (_, an', ltycon', tyvars', _, _mctxt', defn') <- + exactDataDefn an (exactVanillaDeclHead ltycon tyvars fixity) defn + return (DataDecl { tcdDExt = an', tcdLName = ltycon', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdDataDefn = defn' }) -- ----------------------------------- - exact (ClassDecl {tcdCExt = (an, sortKey, _), + exact (ClassDecl {tcdCExt = (an, sortKey, lo), tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFixity = fixity, tcdFDs = fds, @@ -2627,47 +3469,74 @@ instance ExactPrint (TyClDecl GhcPs) where -- TODO: add a test that demonstrates tcdDocs | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part = do - top_matter - markEpAnn an AnnOpenC - markEpAnn an AnnCloseC + (an0, fds', lclas', tyvars',context') <- top_matter + an1 <- markEpAnnL an0 lidl AnnOpenC + an2 <- markEpAnnL an1 lidl AnnCloseC + return (ClassDecl {tcdCExt = (an2, sortKey, lo), + tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', + tcdFixity = fixity, + tcdFDs = fds', + tcdSigs = sigs, tcdMeths = methods, + tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = _docs}) | otherwise -- Laid out = do - top_matter - markEpAnn an AnnOpenC - markEpAnnAll an id AnnSemi - withSortKey sortKey + (an0, fds', lclas', tyvars',context') <- top_matter + an1 <- markEpAnnL an0 lidl AnnOpenC + an2 <- markEpAnnAllL an1 lidl AnnSemi + ds <- withSortKey sortKey (prepareListAnnotationA sigs ++ prepareListAnnotationA (bagToList methods) ++ prepareListAnnotationA ats ++ prepareListAnnotationA at_defs -- ++ prepareListAnnotation docs ) - markEpAnn an AnnCloseC + an3 <- markEpAnnL an2 lidl AnnCloseC + let + sigs' = undynamic ds + methods' = listToBag $ undynamic ds + ats' = undynamic ds + at_defs' = undynamic ds + return (ClassDecl {tcdCExt = (an3, sortKey, lo), + tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', + tcdFixity = fixity, + tcdFDs = fds', + tcdSigs = sigs', tcdMeths = methods', + tcdATs = ats', tcdATDefs = at_defs', + tcdDocs = _docs}) where top_matter = do - annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP] - markEpAnn an AnnClass - exactVanillaDeclHead lclas tyvars fixity context - unless (null fds) $ do - markEpAnn an AnnVbar - markAnnotated fds - markEpAnn an AnnWhere + an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] + an0 <- markEpAnnL an' lidl AnnClass + (_, lclas', tyvars',_,context') <- exactVanillaDeclHead lclas tyvars fixity context + (an1, fds') <- if (null fds) + then return (an0, fds) + else do + an1 <- markEpAnnL an0 lidl AnnVbar + fds' <- markAnnotated fds + return (an1, fds') + an2 <- markEpAnnL an1 lidl AnnWhere + return (an2, fds', lclas', tyvars',context') + -- --------------------------------------------------------------------- instance ExactPrint (FunDep GhcPs) where getAnnotationEntry (FunDep an _ _) = fromAnn an + setAnnotationAnchor (FunDep an a b) anc cs = FunDep (setAnchorEpa an anc cs) a b exact (FunDep an ls rs') = do - markAnnotated ls - markEpAnn an AnnRarrow - markAnnotated rs' + ls' <- markAnnotated ls + an0 <- markEpAnnL an lidl AnnRarrow + rs'' <- markAnnotated rs' + return (FunDep an0 ls' rs'') -- --------------------------------------------------------------------- instance ExactPrint (FamilyDecl GhcPs) where getAnnotationEntry (FamilyDecl { fdExt = an }) = fromAnn an + setAnnotationAnchor x anc cs = x { fdExt = setAnchorEpa (fdExt x) anc cs} exact (FamilyDecl { fdExt = an , fdInfo = info @@ -2675,162 +3544,192 @@ instance ExactPrint (FamilyDecl GhcPs) where , fdLName = ltycon , fdTyVars = tyvars , fdFixity = fixity - , fdResultSig = L _ result + , fdResultSig = L lr result , fdInjectivityAnn = mb_inj }) = do - -- = vcat [ pprFlavour info <+> pp_top_level <+> - -- pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> - -- pp_kind <+> pp_inj <+> pp_where - -- , nest 2 $ pp_eqns ] - exactFlavour an info - exact_top_level - annotationsToCommentsA an [AnnOpenP,AnnCloseP] - exactVanillaDeclHead ltycon tyvars fixity Nothing - exact_kind - case mb_inj of - Nothing -> return () - Just inj -> do - markEpAnn an AnnVbar - markAnnotated inj - case info of - ClosedTypeFamily mb_eqns -> do - markEpAnn an AnnWhere - markEpAnn an AnnOpenC - case mb_eqns of - Nothing -> markEpAnn an AnnDotdot - Just eqns -> markAnnotated eqns - markEpAnn an AnnCloseC - _ -> return () + an0 <- exactFlavour an info + an1 <- exact_top_level an0 + an2 <- annotationsToComments an1 lidl [AnnOpenP,AnnCloseP] + (_, ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing + (an3, result') <- exact_kind an2 + (an4, mb_inj') <- + case mb_inj of + Nothing -> return (an3, mb_inj) + Just inj -> do + an4 <- markEpAnnL an3 lidl AnnVbar + inj' <- markAnnotated inj + return (an4, Just inj') + (an5, info') <- + case info of + ClosedTypeFamily mb_eqns -> do + an5 <- markEpAnnL an4 lidl AnnWhere + an6 <- markEpAnnL an5 lidl AnnOpenC + (an7, mb_eqns') <- + case mb_eqns of + Nothing -> do + an7 <- markEpAnnL an6 lidl AnnDotdot + return (an7, mb_eqns) + Just eqns -> do + eqns' <- markAnnotated eqns + return (an6, Just eqns') + an8 <- markEpAnnL an7 lidl AnnCloseC + return (an8, ClosedTypeFamily mb_eqns') + _ -> return (an4, info) + return (FamilyDecl { fdExt = an5 + , fdInfo = info' + , fdTopLevel = top_level + , fdLName = ltycon' + , fdTyVars = tyvars' + , fdFixity = fixity + , fdResultSig = L lr result' + , fdInjectivityAnn = mb_inj' }) where - exact_top_level = case top_level of - TopLevel -> markEpAnn an AnnFamily - NotTopLevel -> do - -- It seems that in some kind of legacy - -- mode the 'family' keyword is still - -- accepted. - markEpAnn an AnnFamily - return () - - exact_kind = case result of - NoSig _ -> return () - KindSig _ kind -> markEpAnn an AnnDcolon >> markAnnotated kind - TyVarSig _ tv_bndr -> markEpAnn an AnnEqual >> markAnnotated tv_bndr - - -- exact_inj = case mb_inj of - -- Just (L _ (InjectivityAnn _ lhs rhs)) -> - -- hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] - -- Nothing -> empty - -- (pp_where, pp_eqns) = case info of - -- ClosedTypeFamily mb_eqns -> - -- ( text "where" - -- , case mb_eqns of - -- Nothing -> text ".." - -- Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) - -- _ -> (empty, empty) - -exactFlavour :: EpAnn [AddEpAnn] -> FamilyInfo GhcPs -> EPP () -exactFlavour an DataFamily = markEpAnn an AnnData -exactFlavour an OpenTypeFamily = markEpAnn an AnnType -exactFlavour an (ClosedTypeFamily {}) = markEpAnn an AnnType - --- instance Outputable (FamilyInfo pass) where --- ppr info = pprFlavour info <+> text "family" - --- --------------------------------------------------------------------- - -exactDataDefn :: EpAnn [AddEpAnn] - -> (Maybe (LHsContext GhcPs) -> EPP ()) -- Printing the header - -> HsDataDefn GhcPs - -> EPP () + exact_top_level an' = + case top_level of + TopLevel -> markEpAnnL an' lidl AnnFamily + NotTopLevel -> do + -- It seems that in some kind of legacy + -- mode the 'family' keyword is still + -- accepted. + markEpAnnL an' lidl AnnFamily + + exact_kind an' = + case result of + NoSig _ -> return (an', result) + KindSig x kind -> do + an0 <- markEpAnnL an' lidl AnnDcolon + kind' <- markAnnotated kind + return (an0, KindSig x kind') + TyVarSig x tv_bndr -> do + an0 <- markEpAnnL an' lidl AnnEqual + tv_bndr' <- markAnnotated tv_bndr + return (an0, TyVarSig x tv_bndr') + + +exactFlavour :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> FamilyInfo GhcPs -> EP w m (EpAnn [AddEpAnn]) +exactFlavour an DataFamily = markEpAnnL an lidl AnnData +exactFlavour an OpenTypeFamily = markEpAnnL an lidl AnnType +exactFlavour an (ClosedTypeFamily {}) = markEpAnnL an lidl AnnType + +-- --------------------------------------------------------------------- + +exactDataDefn + :: (Monad m, Monoid w) + => EpAnn [AddEpAnn] + -> (Maybe (LHsContext GhcPs) -> EP w m (EpAnn [AddEpAnn] + , LocatedN RdrName + , a + , b + , Maybe (LHsContext GhcPs))) -- Printing the header + -> HsDataDefn GhcPs + -> EP w m ( EpAnn [AddEpAnn] -- ^ from exactHdr + , EpAnn [AddEpAnn] -- ^ updated one passed in + , LocatedN RdrName, a, b, Maybe (LHsContext GhcPs), HsDataDefn GhcPs) exactDataDefn an exactHdr - (HsDataDefn { dd_ctxt = context + (HsDataDefn { dd_ext = x, dd_ctxt = context , dd_cType = mb_ct , dd_kindSig = mb_sig , dd_cons = condecls, dd_derivs = derivings }) = do - annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP] - markEpAnn an $ case condecls of + + an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] + + an0 <- markEpAnnL an' lidl $ case condecls of DataTypeCons _ _ -> AnnData - NewTypeCon _ -> AnnNewtype - markEpAnn an AnnInstance -- optional - mapM_ markAnnotated mb_ct - exactHdr context - case mb_sig of - Nothing -> return () - Just kind -> do - markEpAnn an AnnDcolon - markAnnotated kind - when (isGadt condecls) $ markEpAnn an AnnWhere - markEpAnn an AnnOpenC - exact_condecls an (toList condecls) - markEpAnn an AnnCloseC - mapM_ markAnnotated derivings - return () + NewTypeCon _ -> AnnNewtype -exactVanillaDeclHead :: LocatedN RdrName + an1 <- markEpAnnL an0 lidl AnnInstance -- optional + mb_ct' <- mapM markAnnotated mb_ct + (anx, ln', tvs', b, mctxt') <- exactHdr context + (an2, mb_sig') <- case mb_sig of + Nothing -> return (an1, Nothing) + Just kind -> do + an2 <- markEpAnnL an1 lidl AnnDcolon + kind' <- markAnnotated kind + return (an2, Just kind') + an3 <- if (needsWhere condecls) + then markEpAnnL an2 lidl AnnWhere + else return an2 + an4 <- markEpAnnL an3 lidl AnnOpenC + (an5, condecls') <- exact_condecls an4 (toList condecls) + let condecls'' = case condecls of + DataTypeCons d _ -> DataTypeCons d condecls' + NewTypeCon _ -> case condecls' of + [decl] -> NewTypeCon decl + _ -> panic "exacprint NewTypeCon" + an6 <- markEpAnnL an5 lidl AnnCloseC + derivings' <- mapM markAnnotated derivings + return (anx, an6, ln', tvs', b, mctxt', + (HsDataDefn { dd_ext = x, dd_ctxt = context + , dd_cType = mb_ct' + , dd_kindSig = mb_sig' + , dd_cons = condecls'', dd_derivs = derivings' })) + + +exactVanillaDeclHead :: (Monad m, Monoid w) + => LocatedN RdrName -> LHsQTyVars GhcPs -> LexicalFixity -> Maybe (LHsContext GhcPs) - -> EPP () -exactVanillaDeclHead thing (HsQTvs { hsq_explicit = tyvars }) fixity context = do + -> EP w m ( EpAnn [AddEpAnn] + , LocatedN RdrName + , LHsQTyVars GhcPs + , (), Maybe (LHsContext GhcPs)) +exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context = do let - exact_tyvars :: [LHsTyVarBndr () GhcPs] -> EPP () exact_tyvars (varl:varsr) | fixity == Infix && length varsr > 1 = do - -- = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing) - -- , (ppr.unLoc) (head varsr), char ')' - -- , hsep (map (ppr.unLoc) (tail vaprsr))] - markAnnotated varl - markAnnotated thing - markAnnotated (head varsr) - markAnnotated (tail varsr) - return () + varl' <- markAnnotated varl + thing' <- markAnnotated thing + hvarsr <- markAnnotated (head varsr) + tvarsr <- markAnnotated (tail varsr) + return (thing', varl':hvarsr:tvarsr) | fixity == Infix = do - -- = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) - -- , hsep (map (ppr.unLoc) varsr)] - markAnnotated varl - markAnnotated thing - markAnnotated varsr - return () + varl' <- markAnnotated varl + thing' <- markAnnotated thing + varsr' <- markAnnotated varsr + return (thing', varl':varsr') | otherwise = do - -- hsep [ pprPrefixOcc (unLoc thing) - -- , hsep (map (ppr.unLoc) (varl:varsr))] - markAnnotated thing - mapM_ markAnnotated (varl:varsr) - return () + thing' <- markAnnotated thing + vs <- mapM markAnnotated (varl:varsr) + return (thing', vs) exact_tyvars [] = do - -- pprPrefixOcc (unLoc thing) - markAnnotated thing - mapM_ markAnnotated context - exact_tyvars tyvars + thing' <- markAnnotated thing + return (thing', []) + context' <- mapM markAnnotated context + (thing', tyvars') <- exact_tyvars tyvars + return (EpAnnNotUsed, thing', tvs { hsq_explicit = tyvars' }, (), context') -- --------------------------------------------------------------------- instance ExactPrint (InjectivityAnn GhcPs) where getAnnotationEntry (InjectivityAnn an _ _) = fromAnn an + setAnnotationAnchor (InjectivityAnn an a b) anc cs = InjectivityAnn (setAnchorEpa an anc cs) a b exact (InjectivityAnn an lhs rhs) = do - markEpAnn an AnnVbar - markAnnotated lhs - markEpAnn an AnnRarrow - mapM_ markAnnotated rhs - -- Just (L _ (InjectivityAnn _ lhs rhs)) -> - -- hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] - -- Nothing -> empty + an0 <- markEpAnnL an lidl AnnVbar + lhs' <- markAnnotated lhs + an1 <- markEpAnnL an0 lidl AnnRarrow + rhs' <- mapM markAnnotated rhs + return (InjectivityAnn an1 lhs' rhs') -- --------------------------------------------------------------------- class Typeable flag => ExactPrintTVFlag flag where - exactTVDelimiters :: EpAnn [AddEpAnn] -> flag -> Annotated () -> Annotated () + exactTVDelimiters :: (Monad m, Monoid w) + => EpAnn [AddEpAnn] -> flag -> EP w m (HsTyVarBndr flag GhcPs) + -> EP w m (EpAnn [AddEpAnn], (HsTyVarBndr flag GhcPs)) instance ExactPrintTVFlag () where exactTVDelimiters an _ thing_inside = do - markEpAnnAll an id AnnOpenP - thing_inside - markEpAnnAll an id AnnCloseP + an0 <- markEpAnnAllL an lid AnnOpenP + r <- thing_inside + an1 <- markEpAnnAllL an0 lid AnnCloseP + return (an1, r) instance ExactPrintTVFlag Specificity where exactTVDelimiters an s thing_inside = do - markEpAnnAll an id open - thing_inside - markEpAnnAll an id close + an0 <- markEpAnnAllL an lid open + r <- thing_inside + an1 <- markEpAnnAllL an0 lid close + return (an1, r) where (open, close) = case s of SpecifiedSpec -> (AnnOpenP, AnnCloseP) @@ -2840,19 +3739,27 @@ instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where getAnnotationEntry (UserTyVar an _ _) = fromAnn an getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an - exact (UserTyVar an flag n) = - exactTVDelimiters an flag $ markAnnotated n - exact (KindedTyVar an flag n k) = exactTVDelimiters an flag $ do - markAnnotated n - markEpAnn an AnnDcolon - markAnnotated k + setAnnotationAnchor (UserTyVar an a b) anc cs = UserTyVar (setAnchorEpa an anc cs) a b + setAnnotationAnchor (KindedTyVar an a b c) anc cs = KindedTyVar (setAnchorEpa an anc cs) a b c --- --------------------------------------------------------------------- + exact (UserTyVar an flag n) = do + r <- exactTVDelimiters an flag $ do + n' <- markAnnotated n + return (UserTyVar an flag n') + case r of + (an', UserTyVar _ flag'' n'') -> return (UserTyVar an' flag'' n'') + _ -> error "KindedTyVar should never happen here" + exact (KindedTyVar an flag n k) = do + r <- exactTVDelimiters an flag $ do + n' <- markAnnotated n + an0 <- markEpAnnL an lidl AnnDcolon + k' <- markAnnotated k + return (KindedTyVar an0 flag n' k') + case r of + (an',KindedTyVar _ flag'' n'' k'') -> return (KindedTyVar an' flag'' n'' k'') + _ -> error "UserTyVar should never happen here" --- NOTE: this is also an alias for LHsKind --- instance ExactPrint (LHsType GhcPs) where --- getAnnotationEntry = entryFromLocatedA --- exact (L _ a) = markAnnotated a +-- --------------------------------------------------------------------- instance ExactPrint (HsType GhcPs) where getAnnotationEntry (HsForAllTy _ _ _) = NoEntryVal @@ -2879,95 +3786,145 @@ instance ExactPrint (HsType GhcPs) where getAnnotationEntry (HsWildCardTy _) = NoEntryVal getAnnotationEntry (XHsType _) = NoEntryVal - - exact (HsForAllTy { hst_xforall = _an + setAnnotationAnchor a@(HsForAllTy _ _ _) _ _s = a + setAnnotationAnchor a@(HsQualTy _ _ _) _ _s = a + setAnnotationAnchor (HsTyVar an a b) anc cs = (HsTyVar (setAnchorEpa an anc cs) a b) + setAnnotationAnchor a@(HsAppTy _ _ _) _ _s = a + setAnnotationAnchor a@(HsAppKindTy _ _ _) _ _s = a + setAnnotationAnchor (HsFunTy an a b c) anc cs = (HsFunTy (setAnchorEpa an anc cs) a b c) + setAnnotationAnchor (HsListTy an a) anc cs = (HsListTy (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsTupleTy an a b) anc cs = (HsTupleTy (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsSumTy an a) anc cs = (HsSumTy (setAnchorEpa an anc cs) a) + setAnnotationAnchor a@(HsOpTy _ _ _ _ _) _ _s = a + setAnnotationAnchor (HsParTy an a) anc cs = (HsParTy (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsIParamTy an a b) anc cs = (HsIParamTy (setAnchorEpa an anc cs) a b) + setAnnotationAnchor a@(HsStarTy _ _) _ _s = a + setAnnotationAnchor (HsKindSig an a b) anc cs = (HsKindSig (setAnchorEpa an anc cs) a b) + setAnnotationAnchor a@(HsSpliceTy _ _) _ _s = a + setAnnotationAnchor (HsDocTy an a b) anc cs = (HsDocTy (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsBangTy an a b) anc cs = (HsBangTy (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsRecTy an a) anc cs = (HsRecTy (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsExplicitListTy an a b) anc cs = (HsExplicitListTy (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsExplicitTupleTy an a) anc cs = (HsExplicitTupleTy (setAnchorEpa an anc cs) a) + setAnnotationAnchor a@(HsTyLit _ _) _ _s = a + setAnnotationAnchor a@(HsWildCardTy _) _ _s = a + setAnnotationAnchor a@(XHsType _) _ _s = a + + exact (HsForAllTy { hst_xforall = an , hst_tele = tele, hst_body = ty }) = do - markAnnotated tele - markAnnotated ty - - exact (HsQualTy _ ctxt ty) = do - markAnnotated ctxt - -- markEpAnn an AnnDarrow - markAnnotated ty + tele' <- markAnnotated tele + ty' <- markAnnotated ty + return (HsForAllTy { hst_xforall = an + , hst_tele = tele', hst_body = ty' }) + + exact (HsQualTy an ctxt ty) = do + ctxt' <- markAnnotated ctxt + ty' <- markAnnotated ty + return (HsQualTy an ctxt' ty') exact (HsTyVar an promoted name) = do - when (promoted == IsPromoted) $ markEpAnn an AnnSimpleQuote - markAnnotated name - - exact (HsAppTy _ t1 t2) = markAnnotated t1 >> markAnnotated t2 + an0 <- if (promoted == IsPromoted) + then markEpAnnL an lidl AnnSimpleQuote + else return an + name' <- markAnnotated name + return (HsTyVar an0 promoted name') + exact (HsAppTy an t1 t2) = do + t1' <- markAnnotated t1 + t2' <- markAnnotated t2 + return (HsAppTy an t1' t2') exact (HsAppKindTy ss ty ki) = do - markAnnotated ty + ty' <- markAnnotated ty printStringAtSs ss "@" - markAnnotated ki - exact (HsFunTy _an mult ty1 ty2) = do - markAnnotated ty1 - markArrow mult - markAnnotated ty2 + ki' <- markAnnotated ki + return (HsAppKindTy ss ty' ki') + exact (HsFunTy an mult ty1 ty2) = do + ty1' <- markAnnotated ty1 + mult' <- markArrow mult + ty2' <- markAnnotated ty2 + return (HsFunTy an mult' ty1' ty2') exact (HsListTy an tys) = do - markOpeningParen an - markAnnotated tys - markClosingParen an - exact (HsTupleTy an _con tys) = do - markOpeningParen an - markAnnotated tys - markClosingParen an + an0 <- markOpeningParen an + tys' <- markAnnotated tys + an1 <- markClosingParen an0 + return (HsListTy an1 tys') + exact (HsTupleTy an con tys) = do + an0 <- markOpeningParen an + tys' <- markAnnotated tys + an1 <- markClosingParen an0 + return (HsTupleTy an1 con tys') exact (HsSumTy an tys) = do - markOpeningParen an - markAnnotated tys - markClosingParen an + an0 <- markOpeningParen an + tys' <- markAnnotated tys + an1 <- markClosingParen an0 + return (HsSumTy an1 tys') exact (HsOpTy an promoted t1 lo t2) = do - when (isPromoted promoted) $ markEpAnn an AnnSimpleQuote - markAnnotated t1 - markAnnotated lo - markAnnotated t2 + an0 <- if (isPromoted promoted) + then markEpAnnL an lidl AnnSimpleQuote + else return an + t1' <- markAnnotated t1 + lo' <- markAnnotated lo + t2' <- markAnnotated t2 + return (HsOpTy an0 promoted t1' lo' t2') exact (HsParTy an ty) = do - markOpeningParen an - markAnnotated ty - markClosingParen an + an0 <- markOpeningParen an + ty' <- markAnnotated ty + an1 <- markClosingParen an0 + return (HsParTy an1 ty') exact (HsIParamTy an n t) = do - markAnnotated n - markEpAnn an AnnDcolon - markAnnotated t - exact (HsStarTy _an isUnicode) - = if isUnicode + n' <- markAnnotated n + an0 <- markEpAnnL an lidl AnnDcolon + t' <- markAnnotated t + return (HsIParamTy an0 n' t') + exact (HsStarTy an isUnicode) = do + if isUnicode then printStringAdvance "\x2605" -- Unicode star else printStringAdvance "*" + return (HsStarTy an isUnicode) exact (HsKindSig an ty k) = do - markAnnotated ty - markEpAnn an AnnDcolon - markAnnotated k - exact (HsSpliceTy _ splice) = do - markAnnotated splice - -- exact x@(HsDocTy an _ _) = withPpr x - exact (HsBangTy an (HsSrcBang mt _up str) ty) = do - case mt of - NoSourceText -> return () - SourceText src -> do - debugM $ "HsBangTy: src=" ++ showAst src - markLocatedAALS an id AnnOpen (Just src) - markLocatedAALS an id AnnClose (Just "#-}") - debugM $ "HsBangTy: done unpackedness" - case str of - SrcLazy -> markEpAnn an AnnTilde - SrcStrict -> markEpAnn an AnnBang - NoSrcStrict -> return () - markAnnotated ty - -- exact x@(HsRecTy an _) = withPpr x + ty' <- markAnnotated ty + an0 <- markEpAnnL an lidl AnnDcolon + k' <- markAnnotated k + return (HsKindSig an0 ty' k') + exact (HsSpliceTy a splice) = do + splice' <- markAnnotated splice + return (HsSpliceTy a splice') + exact (HsBangTy an (HsSrcBang mt up str) ty) = do + an0 <- + case mt of + NoSourceText -> return an + SourceText src -> do + debugM $ "HsBangTy: src=" ++ showAst src + an0 <- markEpAnnLMS an lid AnnOpen (Just src) + an1 <- markEpAnnLMS an0 lid AnnClose (Just "#-}") + debugM $ "HsBangTy: done unpackedness" + return an1 + an1 <- + case str of + SrcLazy -> markEpAnnL an0 lidl AnnTilde + SrcStrict -> markEpAnnL an0 lidl AnnBang + NoSrcStrict -> return an0 + ty' <- markAnnotated ty + return (HsBangTy an1 (HsSrcBang mt up str) ty') exact (HsExplicitListTy an prom tys) = do - when (isPromoted prom) $ markEpAnn an AnnSimpleQuote - markEpAnn an AnnOpenS - markAnnotated tys - markEpAnn an AnnCloseS + an0 <- if (isPromoted prom) + then markEpAnnL an lidl AnnSimpleQuote + else return an + an1 <- markEpAnnL an0 lidl AnnOpenS + tys' <- markAnnotated tys + an2 <- markEpAnnL an1 lidl AnnCloseS + return (HsExplicitListTy an2 prom tys') exact (HsExplicitTupleTy an tys) = do - markEpAnn an AnnSimpleQuote - markEpAnn an AnnOpenP - markAnnotated tys - markEpAnn an AnnCloseP - exact (HsTyLit _ lit) = do + an0 <- markEpAnnL an lidl AnnSimpleQuote + an1 <- markEpAnnL an0 lidl AnnOpenP + tys' <- markAnnotated tys + an2 <- markEpAnnL an1 lidl AnnCloseP + return (HsExplicitTupleTy an2 tys') + exact (HsTyLit a lit) = do case lit of (HsNumTy src v) -> printSourceText src (show v) (HsStrTy src v) -> printSourceText src (show v) (HsCharTy src v) -> printSourceText src (show v) - exact (HsWildCardTy _) = printStringAdvance "_" + return (HsTyLit a lit) + exact t@(HsWildCardTy _) = printStringAdvance "_" >> return t exact x = error $ "missing match for HsType:" ++ showAst x -- --------------------------------------------------------------------- @@ -2976,45 +3933,42 @@ instance ExactPrint (HsForAllTelescope GhcPs) where getAnnotationEntry (HsForAllVis an _) = fromAnn an getAnnotationEntry (HsForAllInvis an _) = fromAnn an + setAnnotationAnchor (HsForAllVis an a) anc cs = HsForAllVis (setAnchorEpa an anc cs) a + setAnnotationAnchor (HsForAllInvis an a) anc cs = HsForAllInvis (setAnchorEpa an anc cs) a + exact (HsForAllVis an bndrs) = do - markLocatedAA an fst -- AnnForall - markAnnotated bndrs - markLocatedAA an snd -- AnnRarrow + an0 <- markLensAA an lfst -- AnnForall + bndrs' <- markAnnotated bndrs + an1 <- markLensAA an0 lsnd -- AnnRarrow + return (HsForAllVis an1 bndrs') exact (HsForAllInvis an bndrs) = do - markLocatedAA an fst -- AnnForall - markAnnotated bndrs - markLocatedAA an snd -- AnnDot + an0 <- markLensAA an lfst -- AnnForall + bndrs' <- markAnnotated bndrs + an1 <- markLensAA an0 lsnd -- AnnDot + return (HsForAllInvis an1 bndrs') -- --------------------------------------------------------------------- instance ExactPrint (HsDerivingClause GhcPs) where getAnnotationEntry d@(HsDerivingClause{}) = fromAnn (deriv_clause_ext d) + setAnnotationAnchor x anc cs = (x { deriv_clause_ext = setAnchorEpa (deriv_clause_ext x) anc cs}) + `debug` ("setAnnotationAnchor HsDerivingClause: (anc,cs):" ++ showAst (anc,cs)) exact (HsDerivingClause { deriv_clause_ext = an , deriv_clause_strategy = dcs , deriv_clause_tys = dct }) = do - -- = hsep [ text "deriving" - -- , pp_strat_before - -- , pp_dct dct - -- , pp_strat_after ] - markEpAnn an AnnDeriving + an0 <- markEpAnnL an lidl AnnDeriving exact_strat_before - markAnnotated dct + dct' <- markAnnotated dct exact_strat_after + return (HsDerivingClause { deriv_clause_ext = an0 + , deriv_clause_strategy = dcs + , deriv_clause_tys = dct' }) where - -- -- This complexity is to distinguish between - -- -- deriving Show - -- -- deriving (Show) - -- pp_dct [HsIB { hsib_body = ty }] - -- = ppr (parenthesizeHsType appPrec ty) - -- pp_dct _ = parens (interpp'SP dct) - - -- @via@ is unique in that in comes /after/ the class being derived, - -- so we must special-case it. (exact_strat_before, exact_strat_after) = case dcs of - Just v@(L _ ViaStrategy{}) -> (pure (), markAnnotated v) + Just v@(L _ ViaStrategy{}) -> (pure (), markAnnotated v >> pure ()) _ -> (mapM_ markAnnotated dcs, pure ()) -- --------------------------------------------------------------------- @@ -3025,104 +3979,151 @@ instance ExactPrint (DerivStrategy GhcPs) where getAnnotationEntry (NewtypeStrategy an) = fromAnn an getAnnotationEntry (ViaStrategy (XViaStrategyPs an _)) = fromAnn an - exact (StockStrategy an) = markEpAnn an AnnStock - exact (AnyclassStrategy an) = markEpAnn an AnnAnyclass - exact (NewtypeStrategy an) = markEpAnn an AnnNewtype - exact (ViaStrategy (XViaStrategyPs an ty)) - = markEpAnn an AnnVia >> markAnnotated ty + setAnnotationAnchor (StockStrategy an) anc cs = (StockStrategy (setAnchorEpa an anc cs)) + setAnnotationAnchor (AnyclassStrategy an) anc cs = (AnyclassStrategy (setAnchorEpa an anc cs)) + setAnnotationAnchor (NewtypeStrategy an) anc cs = (NewtypeStrategy (setAnchorEpa an anc cs)) + setAnnotationAnchor (ViaStrategy (XViaStrategyPs an a)) anc cs = (ViaStrategy (XViaStrategyPs (setAnchorEpa an anc cs) a)) + + exact (StockStrategy an) = do + an0 <- markEpAnnL an lid AnnStock + return (StockStrategy an0) + exact (AnyclassStrategy an) = do + an0 <- markEpAnnL an lid AnnAnyclass + return (AnyclassStrategy an0) + exact (NewtypeStrategy an) = do + an0 <- markEpAnnL an lid AnnNewtype + return (NewtypeStrategy an0) + exact (ViaStrategy (XViaStrategyPs an ty)) = do + an0 <- markEpAnnL an lid AnnVia + ty' <- markAnnotated ty + return (ViaStrategy (XViaStrategyPs an0 ty')) -- --------------------------------------------------------------------- instance (ExactPrint a) => ExactPrint (LocatedC a) where getAnnotationEntry (L sann _) = fromAnn sann + setAnnotationAnchor = setAnchorAn - exact (L (SrcSpanAnn EpAnnNotUsed _) a) = markAnnotated a - exact (L (SrcSpanAnn (EpAnn _ (AnnContext ma opens closes) _) _) a) = do - -- case ma of - -- Just (UnicodeSyntax, rs) -> markKw' AnnDarrowU rs - -- Just (NormalSyntax, rs) -> markKw' AnnDarrow rs - -- Nothing -> pure () - mapM_ (markKwA AnnOpenP) (sortBy (comparing unsafeGetEpaLoc) opens) - markAnnotated a - mapM_ (markKwA AnnCloseP) (sortBy (comparing unsafeGetEpaLoc) closes) - case ma of - Just (UnicodeSyntax, r) -> markKwA AnnDarrowU r - Just (NormalSyntax, r) -> markKwA AnnDarrow r - Nothing -> pure () + exact (L (SrcSpanAnn EpAnnNotUsed l) a) = do + a' <- markAnnotated a + return (L (SrcSpanAnn EpAnnNotUsed l) a') + exact (L (SrcSpanAnn (EpAnn anc (AnnContext ma opens closes) cs) l) a) = do + opens' <- mapM (markKwA AnnOpenP) opens + a' <- markAnnotated a + closes' <- mapM (markKwA AnnCloseP) closes + ma' <- case ma of + Just (UnicodeSyntax, r) -> Just . (UnicodeSyntax,) <$> markKwA AnnDarrowU r + Just (NormalSyntax, r) -> Just . (NormalSyntax,) <$> markKwA AnnDarrow r + Nothing -> pure Nothing + return (L (SrcSpanAnn (EpAnn anc (AnnContext ma' opens' closes') cs) l) a') -- --------------------------------------------------------------------- instance ExactPrint (DerivClauseTys GhcPs) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a - exact (DctSingle _ ty) = markAnnotated ty - exact (DctMulti _ tys) = do - -- parens (interpp'SP tys) - markAnnotated tys + exact (DctSingle x ty) = do + ty' <- markAnnotated ty + return (DctSingle x ty') + exact (DctMulti x tys) = do + tys' <- markAnnotated tys + return (DctMulti x tys') -- --------------------------------------------------------------------- instance ExactPrint (HsSigType GhcPs) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a - exact (HsSig _ bndrs ty) = do - markAnnotated bndrs - markAnnotated ty + exact (HsSig a bndrs ty) = do + bndrs' <- markAnnotated bndrs + ty' <- markAnnotated ty + return (HsSig a bndrs' ty') -- --------------------------------------------------------------------- instance ExactPrint (LocatedN RdrName) where getAnnotationEntry (L sann _) = fromAnn sann - - exact (L (SrcSpanAnn EpAnnNotUsed l) n) = do - p <- getPosP - debugM $ "LocatedN RdrName:NOANN: (p,l,str)=" ++ show (p,ss2range l, showPprUnsafe n) - let str = case (showPprUnsafe n) of - -- TODO: unicode support? - "forall" -> if spanLength (realSrcSpan l) == 1 then "∀" else "forall" - s -> s - printStringAtSs l str - exact (L (SrcSpanAnn (EpAnn _anchor ann _cs) _ll) n) = do - case ann of - NameAnn a o l c t -> do - markName a o (Just (l,n)) c - markTrailing t - NameAnnCommas a o cs c t -> do - let (kwo,kwc) = adornments a - markKw (AddEpAnn kwo o) - forM_ cs (\loc -> markKw (AddEpAnn AnnComma loc)) - markKw (AddEpAnn kwc c) - markTrailing t - NameAnnBars a o bs c t -> do - let (kwo,kwc) = adornments a - markKw (AddEpAnn kwo o) - forM_ bs (\loc -> markKw (AddEpAnn AnnVbar loc)) - markKw (AddEpAnn kwc c) - markTrailing t - NameAnnOnly a o c t -> do - markName a o Nothing c - markTrailing t - NameAnnRArrow nl t -> do - markKw (AddEpAnn AnnRarrow nl) - markTrailing t - NameAnnQuote q name t -> do - debugM $ "NameAnnQuote" - markKw (AddEpAnn AnnSimpleQuote q) - markAnnotated (L name n) - markTrailing t - NameAnnTrailing t -> do - printStringAdvance (showPprUnsafe n) - markTrailing t - -markName :: NameAdornment - -> EpaLocation -> Maybe (EpaLocation,RdrName) -> EpaLocation -> EPP () + setAnnotationAnchor = setAnchorAn + + exact x@(L (SrcSpanAnn EpAnnNotUsed l) n) = do + _ <- printUnicode (spanAsAnchor l) n + return x + exact (L (SrcSpanAnn (EpAnn anc ann cs) ll) n) = do + ann' <- + case ann of + NameAnn a o l c t -> do + mn <- markName a o (Just (l,n)) c + case mn of + (o', (Just (l',_n)), c') -> do -- (o', (Just (l',n')), c') + t' <- markTrailing t + return (NameAnn a o' l' c' t') + _ -> error "ExactPrint (LocatedN RdrName)" + NameAnnCommas a o commas c t -> do + let (kwo,kwc) = adornments a + (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o) + commas' <- forM commas (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnComma loc)) + (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c) + t' <- markTrailing t + return (NameAnnCommas a o' commas' c' t') + NameAnnBars a o bars c t -> do + let (kwo,kwc) = adornments a + (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o) + bars' <- forM bars (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnVbar loc)) + (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c) + t' <- markTrailing t + return (NameAnnBars a o' bars' c' t') + NameAnnOnly a o c t -> do + (o',_,c') <- markName a o Nothing c + t' <- markTrailing t + return (NameAnnOnly a o' c' t') + NameAnnRArrow nl t -> do + (AddEpAnn _ nl') <- markKwC NoCaptureComments (AddEpAnn AnnRarrow nl) + t' <- markTrailing t + return (NameAnnRArrow nl' t') + NameAnnQuote q name t -> do + debugM $ "NameAnnQuote" + (AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q) + (L name' _) <- markAnnotated (L name n) + t' <- markTrailing t + return (NameAnnQuote q' name' t') + NameAnnTrailing t -> do + _anc' <- printUnicode anc n + t' <- markTrailing t + return (NameAnnTrailing t') + return (L (SrcSpanAnn (EpAnn anc ann' cs) ll) n) + +locFromAdd :: AddEpAnn -> EpaLocation +locFromAdd (AddEpAnn _ loc) = loc + +printUnicode :: (Monad m, Monoid w) => Anchor -> RdrName -> EP w m Anchor +printUnicode anc n = do + let str = case (showPprUnsafe n) of + -- TODO: unicode support? + "forall" -> if spanLength (anchor anc) == 1 then "∀" else "forall" + s -> s + loc <- printStringAtAAC NoCaptureComments (EpaDelta (SameLine 0) []) str + case loc of + EpaSpan _ -> return anc + EpaDelta dp [] -> return anc { anchor_op = MovedAnchor dp } + EpaDelta _ _cs -> error "printUnicode should not capture comments" + + +markName :: (Monad m, Monoid w) + => NameAdornment -> EpaLocation -> Maybe (EpaLocation,RdrName) -> EpaLocation + -> EP w m (EpaLocation, Maybe (EpaLocation,RdrName), EpaLocation) markName adorn open mname close = do let (kwo,kwc) = adornments adorn - markKw (AddEpAnn kwo open) - case mname of - Nothing -> return () - Just (name, a) -> printStringAtAA name (showPprUnsafe a) - markKw (AddEpAnn kwc close) + (AddEpAnn _ open') <- markKwC CaptureComments (AddEpAnn kwo open) + mname' <- + case mname of + Nothing -> return Nothing + Just (name, a) -> do + name' <- printStringAtAAC CaptureComments name (showPprUnsafe a) + return (Just (name',a)) + (AddEpAnn _ close') <- markKwC CaptureComments (AddEpAnn kwc close) + return (open', mname', close') adornments :: NameAdornment -> (AnnKeywordId, AnnKeywordId) adornments NameParens = (AnnOpenP, AnnCloseP) @@ -3130,32 +4131,34 @@ adornments NameParensHash = (AnnOpenPH, AnnClosePH) adornments NameBackquotes = (AnnBackquote, AnnBackquote) adornments NameSquare = (AnnOpenS, AnnCloseS) -markTrailing :: [TrailingAnn] -> EPP () + +markTrailingL :: (Monad m, Monoid w) => EpAnn a -> Lens a [TrailingAnn] -> EP w m (EpAnn a) +markTrailingL EpAnnNotUsed _ = return EpAnnNotUsed +markTrailingL (EpAnn anc an cs) l = do + ts <- mapM markKwT (view l an) + return (EpAnn anc (set l ts an) cs) + +markTrailing :: (Monad m, Monoid w) => [TrailingAnn] -> EP w m [TrailingAnn] markTrailing ts = do p <- getPosP debugM $ "markTrailing:" ++ showPprUnsafe (p,ts) - mapM_ markKwT (sortBy (comparing (unsafeGetEpaLoc . k)) ts) - where - k (AddSemiAnn l) = l - k (AddCommaAnn l) = l - k (AddVbarAnn l) = l + mapM markKwT ts -- --------------------------------------------------------------------- -- based on pp_condecls in Decls.hs -exact_condecls :: EpAnn [AddEpAnn] -> [LConDecl GhcPs] -> EPP () +exact_condecls :: (Monad m, Monoid w) + => EpAnn [AddEpAnn] -> [LConDecl GhcPs] -> EP w m (EpAnn [AddEpAnn],[LConDecl GhcPs]) exact_condecls an cs | gadt_syntax -- In GADT syntax - -- = hang (text "where") 2 (vcat (map ppr cs)) = do - -- printStringAdvance "exact_condecls:gadt" - mapM_ markAnnotated cs + cs' <- mapM markAnnotated cs + return (an, cs') | otherwise -- In H98 syntax - -- = equals <+> sep (punctuate (text " |") (map ppr cs)) = do - -- printStringAdvance "exact_condecls:not gadt" - markEpAnn an AnnEqual - mapM_ markAnnotated cs + an0 <- markEpAnnL an lidl AnnEqual + cs' <- mapM markAnnotated cs + return (an0, cs') where gadt_syntax = case cs of [] -> False @@ -3168,6 +4171,9 @@ instance ExactPrint (ConDecl GhcPs) where getAnnotationEntry x@(ConDeclGADT{}) = fromAnn (con_g_ext x) getAnnotationEntry x@(ConDeclH98{}) = fromAnn (con_ext x) + setAnnotationAnchor x@ConDeclGADT{} anc cs = x { con_g_ext = setAnchorEpa (con_g_ext x) anc cs} + setAnnotationAnchor x@ConDeclH98{} anc cs = x { con_ext = setAnchorEpa (con_ext x) anc cs} + -- based on pprConDecl exact (ConDeclH98 { con_ext = an , con_name = con @@ -3176,36 +4182,45 @@ instance ExactPrint (ConDecl GhcPs) where , con_mb_cxt = mcxt , con_args = args , con_doc = doc }) = do - -- = sep [ ppr_mbDoc doc - -- , pprHsForAll (mkHsForAllInvisTele ex_tvs) mcxt - -- , ppr_details args ] - mapM_ markAnnotated doc - when has_forall $ markEpAnn an AnnForall - mapM_ markAnnotated ex_tvs - when has_forall $ markEpAnn an AnnDot - -- exactHsForall (mkHsForAllInvisTele ex_tvs) mcxt - mapM_ markAnnotated mcxt - when (isJust mcxt) $ markEpAnn an AnnDarrow - - exact_details args - - -- case args of - -- InfixCon _ _ -> return () - -- _ -> markAnnotated con + doc' <- mapM markAnnotated doc + an0 <- if has_forall + then markEpAnnL an lidl AnnForall + else return an + ex_tvs' <- mapM markAnnotated ex_tvs + an1 <- if has_forall + then markEpAnnL an0 lidl AnnDot + else return an0 + mcxt' <- mapM markAnnotated mcxt + an2 <- if (isJust mcxt) + then markEpAnnL an1 lidl AnnDarrow + else return an1 + + (con', args') <- exact_details args + return (ConDeclH98 { con_ext = an2 + , con_name = con' + , con_forall = has_forall + , con_ex_tvs = ex_tvs' + , con_mb_cxt = mcxt' + , con_args = args' + , con_doc = doc' }) + where -- -- In ppr_details: let's not print the multiplicities (they are always 1, by -- -- definition) as they do not appear in an actual declaration. exact_details (InfixCon t1 t2) = do - markAnnotated t1 - markAnnotated con - markAnnotated t2 + t1' <- markAnnotated t1 + con' <- markAnnotated con + t2' <- markAnnotated t2 + return (con', InfixCon t1' t2') exact_details (PrefixCon tyargs tys) = do - markAnnotated con - markAnnotated tyargs - markAnnotated tys + con' <- markAnnotated con + tyargs' <- markAnnotated tyargs + tys' <- markAnnotated tys + return (con', PrefixCon tyargs' tys') exact_details (RecCon fields) = do - markAnnotated con - markAnnotated fields + con' <- markAnnotated con + fields' <- markAnnotated fields + return (con', RecCon fields') -- ----------------------------------- @@ -3215,77 +4230,43 @@ instance ExactPrint (ConDecl GhcPs) where , con_bndrs = bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) = do - mapM_ markAnnotated doc - mapM_ markAnnotated cons - markUniToken dcol - markEpAnn an AnnDcolon - annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP] - -- when has_forall $ markEpAnn an AnnForall - markAnnotated bndrs - -- mapM_ markAnnotated qvars - -- when has_forall $ markEpAnn an AnnDot - mapM_ markAnnotated mcxt - when (isJust mcxt) $ markEpAnn an AnnDarrow - -- mapM_ markAnnotated args - case args of - PrefixConGADT args' -> mapM_ markAnnotated args' - RecConGADT fields arr -> do - markAnnotated fields - markUniToken arr - -- mapM_ markAnnotated (unLoc fields) - markAnnotated res_ty - -- markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) qvars mbCxt args typ _) = do - -- setContext (Set.singleton PrefixOp) $ markListIntercalate lns - -- mark GHC.AnnDcolon - -- annotationsToComments [GHC.AnnOpenP] - -- markLocated (GHC.L l (ResTyGADTHook forall qvars)) - -- markMaybe mbCxt - -- markHsConDeclDetails False True lns args - -- markLocated typ - -- markManyOptional GHC.AnnCloseP - -- markTrailingSemi - --- pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars --- , con_mb_cxt = mcxt, con_args = args --- , con_res_ty = res_ty, con_doc = doc }) --- = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon --- <+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) mcxt, --- ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) --- where --- get_args (PrefixCon args) = map ppr args --- get_args (RecCon fields) = [pprConDeclFields (unLoc fields)] --- get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr_con_names cons) - --- ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) --- ppr_arrow_chain [] = empty - --- ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc --- ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) - - --- --------------------------------------------------------------------- - --- exactHsForall :: HsForAllTelescope GhcPs --- -> Maybe (LHsContext GhcPs) -> EPP () --- exactHsForall = exactHsForAllExtra False - --- exactHsForAllExtra :: Bool --- -> HsForAllTelescope GhcPs --- -> Maybe (LHsContext GhcPs) -> EPP () --- exactHsForAllExtra show_extra Nothing = return () --- exactHsForAllExtra show_extra lctxt@(Just ctxt) --- | not show_extra = markAnnotated ctxt --- -- | null ctxt = char '_' <+> darrow --- | null ctxt = return () --- | otherwise = parens (sep (punctuate comma ctxt')) <+> darrow --- where --- ctxt' = map ppr ctxt ++ [char '_'] + doc' <- mapM markAnnotated doc + cons' <- mapM markAnnotated cons + dcol' <- markUniToken dcol + an1 <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] + + -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558 + bndrs' <- case bndrs of + L _ (HsOuterImplicit _) -> return bndrs + _ -> markAnnotated bndrs + + mcxt' <- mapM markAnnotated mcxt + an2 <- if (isJust mcxt) + then markEpAnnL an1 lidl AnnDarrow + else return an1 + args' <- + case args of + (PrefixConGADT args0) -> do + args0' <- mapM markAnnotated args0 + return (PrefixConGADT args0') + (RecConGADT fields rarr) -> do + fields' <- markAnnotated fields + rarr' <- markUniToken rarr + return (RecConGADT fields' rarr') + res_ty' <- markAnnotated res_ty + return (ConDeclGADT { con_g_ext = an2 + , con_names = cons' + , con_dcolon = dcol' + , con_bndrs = bndrs' + , con_mb_cxt = mcxt', con_g_args = args' + , con_res_ty = res_ty', con_doc = doc' }) -- --------------------------------------------------------------------- instance ExactPrint Void where getAnnotationEntry = const NoEntryVal - exact _ = return () + setAnnotationAnchor a _ _ = a + exact x = return x -- --------------------------------------------------------------------- @@ -3293,74 +4274,84 @@ instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) wher getAnnotationEntry (HsOuterImplicit _) = NoEntryVal getAnnotationEntry (HsOuterExplicit an _) = fromAnn an - exact (HsOuterImplicit _) = pure () + setAnnotationAnchor (HsOuterImplicit a) _ _ = HsOuterImplicit a + setAnnotationAnchor (HsOuterExplicit an a) anc cs = HsOuterExplicit (setAnchorEpa an anc cs) a + + exact b@(HsOuterImplicit _) = pure b exact (HsOuterExplicit an bndrs) = do - markLocatedAA an fst -- "forall" - markAnnotated bndrs - markLocatedAA an snd -- "." + an0 <- markLensAA an lfst -- "forall" + bndrs' <- markAnnotated bndrs + an1 <- markLensAA an0 lsnd -- "." + return (HsOuterExplicit an1 bndrs') -- --------------------------------------------------------------------- instance ExactPrint (ConDeclField GhcPs) where getAnnotationEntry f@(ConDeclField{}) = fromAnn (cd_fld_ext f) + setAnnotationAnchor x anc cs = x { cd_fld_ext = setAnchorEpa (cd_fld_ext x) anc cs} + exact (ConDeclField an names ftype mdoc) = do - markAnnotated names - markEpAnn an AnnDcolon - markAnnotated ftype - mapM_ markAnnotated mdoc + names' <- markAnnotated names + an0 <- markEpAnnL an lidl AnnDcolon + ftype' <- markAnnotated ftype + mdoc' <- mapM markAnnotated mdoc + return (ConDeclField an0 names' ftype' mdoc') -- --------------------------------------------------------------------- instance ExactPrint (FieldOcc GhcPs) where getAnnotationEntry = const NoEntryVal - exact (FieldOcc _ n) = markAnnotated n + setAnnotationAnchor a _ _ = a + exact f@(FieldOcc _ n) = markAnnotated n >> return f -- --------------------------------------------------------------------- instance ExactPrint (AmbiguousFieldOcc GhcPs) where getAnnotationEntry = const NoEntryVal - exact (Unambiguous _ n) = markAnnotated n - exact (Ambiguous _ n) = markAnnotated n + setAnnotationAnchor a _ _ = a + exact f@(Unambiguous _ n) = markAnnotated n >> return f + exact f@(Ambiguous _ n) = markAnnotated n >> return f -- --------------------------------------------------------------------- instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a exact (HsScaled arr t) = do - markAnnotated t - markArrow arr - --- --------------------------------------------------------------------- - --- instance ExactPrint (LHsContext GhcPs) where --- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann --- exact = withPpr + t' <- markAnnotated t + arr' <- markArrow arr + return (HsScaled arr' t') -- --------------------------------------------------------------------- instance ExactPrint (LocatedP CType) where getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn - exact (L (SrcSpanAnn EpAnnNotUsed _) ct) = withPpr ct - exact (L (SrcSpanAnn an _ll) + exact x@(L (SrcSpanAnn EpAnnNotUsed _) ct) = withPpr ct >> return x + exact (L (SrcSpanAnn an ll) (CType stp mh (stct,ct))) = do - markAnnOpenP an stp "{-# CTYPE" - case mh of - Nothing -> return () - Just (Header srcH _h) -> - markLocatedAALS an apr_rest AnnHeader (Just (toSourceTextWithSuffix srcH "" "")) - markLocatedAALS an apr_rest AnnVal (Just (toSourceTextWithSuffix stct (unpackFS ct) "")) - markAnnCloseP an + an0 <- markAnnOpenP an stp "{-# CTYPE" + an1 <- case mh of + Nothing -> return an0 + Just (Header srcH _h) -> + markEpAnnLMS an0 lapr_rest AnnHeader (Just (toSourceTextWithSuffix srcH "" "")) + an2 <- markEpAnnLMS an1 lapr_rest AnnVal (Just (toSourceTextWithSuffix stct (unpackFS ct) "")) + an3 <- markAnnCloseP an2 + return (L (SrcSpanAnn an3 ll) + (CType stp mh (stct,ct))) -- --------------------------------------------------------------------- instance ExactPrint (SourceText, RuleName) where -- We end up at the right place from the Located wrapper getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a exact (st, rn) = printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "") + >> return (st, rn) -- ===================================================================== @@ -3374,98 +4365,75 @@ instance ExactPrint (SourceText, RuleName) where -- applied. -- --------------------------------------------------------------------- --- instance (ExactPrint body) => ExactPrint (LocatedL body) where --- getAnnotationEntry = entryFromLocatedA --- exact (L (SrcSpanAnn an _) b) = do --- markLocatedMAA an al_open --- markEpAnnAll an al_rest AnnSemi --- markAnnotated b --- markLocatedMAA an al_close - instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn - exact (L (SrcSpanAnn ann _) ies) = do + exact (L (SrcSpanAnn an l) ies) = do debugM $ "LocatedL [LIE" - markLocatedAAL ann al_rest AnnHiding + an0 <- markEpAnnL an lal_rest AnnHiding p <- getPosP debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p - markAnnList True ann (markAnnotated ies) + (an1, ies') <- markAnnList True an0 (markAnnotated ies) + return (L (SrcSpanAnn an1 l) ies') --- instance (ExactPrint (LocatedA body), (ExactPrint (Match GhcPs (LocatedA body)))) => ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA body))]) where instance (ExactPrint (Match GhcPs (LocatedA body))) => ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA body))]) where getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn exact (L la a) = do + let an = ann la debugM $ "LocatedL [LMatch" -- TODO: markAnnList? - markEpAnnAll (ann la) al_rest AnnWhere - markLocatedMAA (ann la) al_open - markEpAnnAll (ann la) al_rest AnnSemi - markAnnotated a - markLocatedMAA (ann la) al_close - -{- --- AZ:TODO: combine with next instance -instance ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))]) where - getAnnotationEntry = entryFromLocatedA - exact (L la a) = do - debugM $ "LocatedL [LMatch" - -- TODO: markAnnList? - markEpAnnAll (ann la) al_rest AnnWhere - markLocatedMAA (ann la) al_open - markEpAnnAll (ann la) al_rest AnnSemi - markAnnotated a - markLocatedMAA (ann la) al_close - -instance ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA (HsCmd GhcPs)))]) where - getAnnotationEntry = entryFromLocatedA - exact (L la a) = do - debugM $ "LocatedL [LMatch" - -- TODO: markAnnList? - markEpAnnAll (ann la) al_rest AnnWhere - markLocatedMAA (ann la) al_open - markEpAnnAll (ann la) al_rest AnnSemi - markAnnotated a - markLocatedMAA (ann la) al_close --} + an0 <- markEpAnnAllL an lal_rest AnnWhere + an1 <- markLensMAA an0 lal_open + an2 <- markEpAnnAllL an1 lal_rest AnnSemi + a' <- markAnnotated a + an3 <- markLensMAA an2 lal_close + return (L (la { ann = an3}) a') --- instance ExactPrint (LocatedL [ExprLStmt GhcPs]) where instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where getAnnotationEntry = entryFromLocatedA - exact (L (SrcSpanAnn an _) stmts) = do + setAnnotationAnchor = setAnchorAn + exact (L (SrcSpanAnn an l) stmts) = do debugM $ "LocatedL [ExprLStmt" - markAnnList True an $ do - -- markLocatedMAA an al_open + (an'', stmts') <- markAnnList True an $ do case snocView stmts of Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do debugM $ "LocatedL [ExprLStmt: snocView" - markAnnotated ls - markAnnotated initStmts - _ -> markAnnotated stmts - -- x -> error $ "pprDo:ListComp" ++ showAst x - -- markLocatedMAA an al_close + ls' <- markAnnotated ls + initStmts' <- markAnnotated initStmts + return (initStmts' ++ [ls']) + _ -> do + markAnnotated stmts + return (L (SrcSpanAnn an'' l) stmts') -- instance ExactPrint (LocatedL [CmdLStmt GhcPs]) where instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where getAnnotationEntry = entryFromLocatedA - exact (L (SrcSpanAnn ann _) es) = do + setAnnotationAnchor = setAnchorAn + exact (L (SrcSpanAnn ann l) es) = do debugM $ "LocatedL [CmdLStmt" - markLocatedMAA ann al_open - mapM_ markAnnotated es - markLocatedMAA ann al_close + an0 <- markLensMAA ann lal_open + es' <- mapM markAnnotated es + an1 <- markLensMAA an0 lal_close + return (L (SrcSpanAnn an1 l) es') instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where getAnnotationEntry = entryFromLocatedA - exact (L (SrcSpanAnn an _) fs) = do + setAnnotationAnchor = setAnchorAn + exact (L (SrcSpanAnn an l) fs) = do debugM $ "LocatedL [LConDeclField" - markAnnList True an (mapM_ markAnnotated fs) -- AZ:TODO get rid of mapM_ + (an', fs') <- markAnnList True an (markAnnotated fs) + return (L (SrcSpanAnn an' l) fs') instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where getAnnotationEntry = entryFromLocatedA - exact (L (SrcSpanAnn an _) bf) = do + setAnnotationAnchor = setAnchorAn + exact (L (SrcSpanAnn an l) bf) = do debugM $ "LocatedL [LBooleanFormula" - markAnnList True an (markAnnotated bf) + (an', bf') <- markAnnList True an (markAnnotated bf) + return (L (SrcSpanAnn an' l) bf') -- --------------------------------------------------------------------- -- LocatedL instances end -- @@ -3481,66 +4449,73 @@ instance ExactPrint (IE GhcPs) where getAnnotationEntry (IEDoc _ _) = NoEntryVal getAnnotationEntry (IEDocNamed _ _) = NoEntryVal - exact (IEVar _ ln) = markAnnotated ln - exact (IEThingAbs _ thing) = markAnnotated thing + setAnnotationAnchor a@(IEVar _ _) _ _s = a + setAnnotationAnchor (IEThingAbs an a) anc cs = (IEThingAbs (setAnchorEpa an anc cs) a) + setAnnotationAnchor (IEThingAll an a) anc cs = (IEThingAll (setAnchorEpa an anc cs) a) + setAnnotationAnchor (IEThingWith an a b c) anc cs = (IEThingWith (setAnchorEpa an anc cs) a b c) + setAnnotationAnchor (IEModuleContents an a) anc cs = (IEModuleContents (setAnchorEpa an anc cs) a) + setAnnotationAnchor a@(IEGroup _ _ _) _ _s = a + setAnnotationAnchor a@(IEDoc _ _) _ _s = a + setAnnotationAnchor a@(IEDocNamed _ _) _ _s = a + + exact (IEVar x ln) = do + ln' <- markAnnotated ln + return (IEVar x ln') + exact (IEThingAbs x thing) = do + thing' <- markAnnotated thing + return (IEThingAbs x thing') exact (IEThingAll an thing) = do - markAnnotated thing - markEpAnn an AnnOpenP - markEpAnn an AnnDotdot - markEpAnn an AnnCloseP + thing' <- markAnnotated thing + an0 <- markEpAnnL an lidl AnnOpenP + an1 <- markEpAnnL an0 lidl AnnDotdot + an2 <- markEpAnnL an1 lidl AnnCloseP + return (IEThingAll an2 thing') exact (IEThingWith an thing wc withs) = do - markAnnotated thing - markEpAnn an AnnOpenP - case wc of - NoIEWildcard -> markAnnotated withs - IEWildcard pos -> do - let (bs, as) = splitAt pos withs - markAnnotated bs - markEpAnn an AnnDotdot - markEpAnn an AnnComma - markAnnotated as - markEpAnn an AnnCloseP - - exact (IEModuleContents an mn) = do - markEpAnn an AnnModule - markAnnotated mn - - -- exact (IEGroup _ _ _) = NoEntryVal - -- exact (IEDoc _ _) = NoEntryVal - -- exact (IEDocNamed _ _) = NoEntryVal + thing' <- markAnnotated thing + an0 <- markEpAnnL an lidl AnnOpenP + (an1, wc', withs') <- + case wc of + NoIEWildcard -> do + withs'' <- markAnnotated withs + return (an0, wc, withs'') + IEWildcard pos -> do + let (bs, as) = splitAt pos withs + bs' <- markAnnotated bs + an1 <- markEpAnnL an0 lidl AnnDotdot + an2 <- markEpAnnL an1 lidl AnnComma + as' <- markAnnotated as + return (an2, wc, bs'++as') + an2 <- markEpAnnL an1 lidl AnnCloseP + return (IEThingWith an2 thing' wc' withs') + + exact (IEModuleContents an m) = do + an0 <- markEpAnnL an lidl AnnModule + m' <- markAnnotated m + return (IEModuleContents an0 m') + exact x = error $ "missing match for IE:" ++ showAst x -- --------------------------------------------------------------------- instance ExactPrint (IEWrappedName GhcPs) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a - exact (IEName _ n) = markAnnotated n + exact (IEName x n) = do + n' <- markAnnotated n + return (IEName x n') exact (IEPattern r n) = do - printStringAtAA r "pattern" - markAnnotated n + r' <- printStringAtAA r "pattern" + n' <- markAnnotated n + return (IEPattern r' n') exact (IEType r n) = do - printStringAtAA r "type" - markAnnotated n - --- markIEWrapped :: EpAnn -> LIEWrappedName RdrName -> EPP () --- markIEWrapped an (L _ (IEName n)) --- = markAnnotated n --- markIEWrapped an (L _ (IEPattern n)) --- = markEpAnn an AnnPattern >> markAnnotated n --- markIEWrapped an (L _ (IEType n)) --- = markEpAnn an AnnType >> markAnnotated n + r' <- printStringAtAA r "type" + n' <- markAnnotated n + return (IEType r' n') -- --------------------------------------------------------------------- --- instance ExactPrint (LocatedA (Pat GhcPs)) where --- -- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann --- getAnnotationEntry = entryFromLocatedA --- exact (L _ a) = do --- debugM $ "exact:LPat:" ++ showPprUnsafe a --- markAnnotated a - instance ExactPrint (Pat GhcPs) where getAnnotationEntry (WildPat _) = NoEntryVal getAnnotationEntry (VarPat _ _) = NoEntryVal @@ -3559,84 +4534,126 @@ instance ExactPrint (Pat GhcPs) where getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an getAnnotationEntry (SigPat an _ _) = fromAnn an - exact (WildPat _) = do + setAnnotationAnchor a@(WildPat _) _ _s = a + setAnnotationAnchor a@(VarPat _ _) _ _s = a + setAnnotationAnchor (LazyPat an a) anc cs = (LazyPat (setAnchorEpa an anc cs) a) + setAnnotationAnchor (AsPat an a at b) anc cs = (AsPat (setAnchorEpa an anc cs) a at b) + setAnnotationAnchor (ParPat an a b c) anc cs = (ParPat (setAnchorEpa an anc cs) a b c) + setAnnotationAnchor (BangPat an a) anc cs = (BangPat (setAnchorEpa an anc cs) a) + setAnnotationAnchor (ListPat an a) anc cs = (ListPat (setAnchorEpa an anc cs) a) + setAnnotationAnchor (TuplePat an a b) anc cs = (TuplePat (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (SumPat an a b c) anc cs = (SumPat (setAnchorEpa an anc cs) a b c) + setAnnotationAnchor (ConPat an a b) anc cs = (ConPat (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (ViewPat an a b) anc cs = (ViewPat (setAnchorEpa an anc cs) a b) + setAnnotationAnchor a@(SplicePat _ _) _ _s = a + setAnnotationAnchor a@(LitPat _ _) _ _s = a + setAnnotationAnchor (NPat an a b c) anc cs = (NPat (setAnchorEpa an anc cs) a b c) + setAnnotationAnchor (NPlusKPat an a b c d e) anc cs = (NPlusKPat (setAnchorEpa an anc cs) a b c d e) + setAnnotationAnchor (SigPat an a b) anc cs = (SigPat (setAnchorEpa an anc cs) a b) + + exact (WildPat w) = do anchor <- getAnchorU debugM $ "WildPat:anchor=" ++ show anchor - printStringAtRs anchor "_" - exact (VarPat _ n) = do - -- The parser inserts a placeholder value for a record pun rhs. This must be - -- filtered. - let pun_RDR = "pun-right-hand-side" - when (showPprUnsafe n /= pun_RDR) $ markAnnotated n + _ <- printStringAtRs anchor "_" + return (WildPat w) + exact (VarPat x n) = do + -- The parser inserts a placeholder value for a record pun rhs. This must be + -- filtered. + let pun_RDR = "pun-right-hand-side" + n' <- if (showPprUnsafe n /= pun_RDR) + then markAnnotated n + else return n + return (VarPat x n') exact (LazyPat an pat) = do - markEpAnn an AnnTilde - markAnnotated pat - exact (AsPat _an n at pat) = do - markAnnotated n - markToken at - markAnnotated pat - exact (ParPat _an lpar pat rpar) = do - markToken lpar - markAnnotated pat - markToken rpar + an0 <- markEpAnnL an lidl AnnTilde + pat' <- markAnnotated pat + return (LazyPat an0 pat') + exact (AsPat an n at pat) = do + n' <- markAnnotated n + at' <- markToken at + pat' <- markAnnotated pat + return (AsPat an n' at' pat') + exact (ParPat an lpar pat rpar) = do + lpar' <- markToken lpar + pat' <- markAnnotated pat + rpar' <- markToken rpar + return (ParPat an lpar' pat' rpar') exact (BangPat an pat) = do - markEpAnn an AnnBang - markAnnotated pat + an0 <- markEpAnnL an lidl AnnBang + pat' <- markAnnotated pat + return (BangPat an0 pat') - exact (ListPat an pats) = markAnnList True an (markAnnotated pats) + exact (ListPat an pats) = do + (an', pats') <- markAnnList True an (markAnnotated pats) + return (ListPat an' pats') exact (TuplePat an pats boxity) = do - case boxity of - Boxed -> markEpAnn an AnnOpenP - Unboxed -> markEpAnn an AnnOpenPH - markAnnotated pats - case boxity of - Boxed -> markEpAnn an AnnCloseP - Unboxed -> markEpAnn an AnnClosePH - - exact (SumPat an pat _alt _arity) = do - markLocatedAAL an sumPatParens AnnOpenPH - markAnnKwAll an sumPatVbarsBefore AnnVbar - markAnnotated pat - markAnnKwAll an sumPatVbarsAfter AnnVbar - markLocatedAAL an sumPatParens AnnClosePH + an0 <- case boxity of + Boxed -> markEpAnnL an lidl AnnOpenP + Unboxed -> markEpAnnL an lidl AnnOpenPH + pats' <- markAnnotated pats + an1 <- case boxity of + Boxed -> markEpAnnL an0 lidl AnnCloseP + Unboxed -> markEpAnnL an0 lidl AnnClosePH + return (TuplePat an1 pats' boxity) + + exact (SumPat an pat alt arity) = do + an0 <- markEpAnnL an lsumPatParens AnnOpenPH + an1 <- markAnnKwAllL an0 lsumPatVbarsBefore AnnVbar + pat' <- markAnnotated pat + an2 <- markAnnKwAllL an1 lsumPatVbarsAfter AnnVbar + an3 <- markEpAnnL an2 lsumPatParens AnnClosePH + return (SumPat an3 pat' alt arity) -- | ConPat an con args) - exact (ConPat an con details) = exactUserCon an con details + exact (ConPat an con details) = do + (an', con', details') <- exactUserCon an con details + return (ConPat an' con' details') exact (ViewPat an expr pat) = do - markAnnotated expr - markEpAnn an AnnRarrow - markAnnotated pat - exact (SplicePat _ splice) = markAnnotated splice - exact (LitPat _ lit) = printStringAdvance (hsLit2String lit) - exact (NPat an ol mn _) = do - when (isJust mn) $ markEpAnn an AnnMinus - markAnnotated ol + expr' <- markAnnotated expr + an0 <- markEpAnnL an lidl AnnRarrow + pat' <- markAnnotated pat + return (ViewPat an0 expr' pat') + exact (SplicePat x splice) = do + splice' <- markAnnotated splice + return (SplicePat x splice') + exact p@(LitPat _ lit) = printStringAdvance (hsLit2String lit) >> return p + exact (NPat an ol mn z) = do + an0 <- if (isJust mn) + then markEpAnnL an lidl AnnMinus + else return an + ol' <- markAnnotated ol + return (NPat an0 ol' mn z) -- | NPlusKPat an n lit1 lit2 _ _) - exact (NPlusKPat an n k _lit2 _ _) = do - markAnnotated n - printStringAtAnn an id "+" - markAnnotated k - + exact (NPlusKPat an n k lit2 a b) = do + n' <- markAnnotated n + an' <- printStringAtAAL an lid "+" + k' <- markAnnotated k + return (NPlusKPat an' n' k' lit2 a b) exact (SigPat an pat sig) = do - markAnnotated pat - markEpAnn an AnnDcolon - markAnnotated sig - -- exact x = error $ "missing match for Pat:" ++ showAst x + pat' <- markAnnotated pat + an0 <- markEpAnnL an lidl AnnDcolon + sig' <- markAnnotated sig + return (SigPat an0 pat' sig') -- --------------------------------------------------------------------- instance ExactPrint (HsPatSigType GhcPs) where getAnnotationEntry = const NoEntryVal - exact (HsPS _ ty) = markAnnotated ty + setAnnotationAnchor a _ _ = a + + exact (HsPS an ty) = do + ty' <- markAnnotated ty + return (HsPS an ty') -- --------------------------------------------------------------------- instance ExactPrint (HsOverLit GhcPs) where getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a exact ol = let str = case ol_val ol of @@ -3645,8 +4662,8 @@ instance ExactPrint (HsOverLit GhcPs) where HsIsString src _ -> src in case str of - SourceText s -> printStringAdvance s - NoSourceText -> return () + SourceText s -> printStringAdvance s >> return ol + NoSourceText -> return ol -- --------------------------------------------------------------------- @@ -3668,7 +4685,6 @@ hsLit2String lit = HsRat _ fl@(FL{fl_text = src }) _ -> toSourceTextWithSuffix src fl "" HsFloatPrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "#" HsDoublePrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "##" - -- (XLit x) -> error $ "got XLit for:" ++ showPprUnsafe x toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix @@ -3680,22 +4696,42 @@ sourceTextToString (SourceText txt) _ = txt -- --------------------------------------------------------------------- -exactUserCon :: (ExactPrint con) => EpAnn [AddEpAnn] -> con -> HsConPatDetails GhcPs -> EPP () -exactUserCon _ c (InfixCon p1 p2) = markAnnotated p1 >> markAnnotated c >> markAnnotated p2 -exactUserCon an c details = do - markAnnotated c - markEpAnn an AnnOpenC - exactConArgs details - markEpAnn an AnnCloseC +exactUserCon :: (Monad m, Monoid w, ExactPrint con) + => EpAnn [AddEpAnn] -> con -> HsConPatDetails GhcPs + -> EP w m (EpAnn [AddEpAnn], con, HsConPatDetails GhcPs) +exactUserCon an c (InfixCon p1 p2) = do + p1' <- markAnnotated p1 + c' <- markAnnotated c + p2' <- markAnnotated p2 + return (an, c', InfixCon p1' p2') +exactUserCon an c details = do + c' <- markAnnotated c + an0 <- markEpAnnL an lidl AnnOpenC + details' <- exactConArgs details + an1 <- markEpAnnL an0 lidl AnnCloseC + return (an1, c', details') instance ExactPrint (HsConPatTyArg GhcPs) where getAnnotationEntry _ = NoEntryVal - exact (HsConPatTyArg at tyarg) = markToken at >> markAnnotated tyarg - -exactConArgs ::HsConPatDetails GhcPs -> EPP () -exactConArgs (PrefixCon tyargs pats) = markAnnotated tyargs >> markAnnotated pats -exactConArgs (InfixCon p1 p2) = markAnnotated p1 >> markAnnotated p2 -exactConArgs (RecCon rpats) = markAnnotated rpats + setAnnotationAnchor a _ _ = a + exact (HsConPatTyArg at tyarg) = do + at' <- markToken at + tyarg' <- markAnnotated tyarg + return (HsConPatTyArg at' tyarg') + +exactConArgs :: (Monad m, Monoid w) + => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs) +exactConArgs (PrefixCon tyargs pats) = do + tyargs' <- markAnnotated tyargs + pats' <- markAnnotated pats + return (PrefixCon tyargs' pats') +exactConArgs (InfixCon p1 p2) = do + p1' <- markAnnotated p1 + p2' <- markAnnotated p2 + return (InfixCon p1' p2') +exactConArgs (RecCon rpats) = do + rpats' <- markAnnotated rpats + return (RecCon rpats') -- --------------------------------------------------------------------- @@ -3717,7 +4753,10 @@ printStringAtLsDelta cl s = do if isGoodDeltaWithOffset cl colOffset then do printStringAt (undelta p cl colOffset) s - `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s)) + -- `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s)) + p' <- getPosP + d <- getPriorEndD + debugM $ "printStringAtLsDelta:(pos,p',d,s):" ++ show (undelta p cl colOffset,p',d,s) else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s)) -- --------------------------------------------------------------------- @@ -3726,53 +4765,27 @@ isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool isGoodDeltaWithOffset dp colOffset = isGoodDelta (deltaPos l c) where (l,c) = undelta (0,0) dp colOffset +-- | Print a comment, using the current layout offset to convert the +-- @DeltaPos@ to an absolute position. printQueuedComment :: (Monad m, Monoid w) => RealSrcSpan -> Comment -> DeltaPos -> EP w m () -printQueuedComment loc Comment{commentContents} dp = do +printQueuedComment _loc Comment{commentContents} dp = do p <- getPosP + d <- getPriorEndD colOffset <- getLayoutOffsetP let (dr,dc) = undelta (0,0) dp colOffset -- do not lose comments against the left margin when (isGoodDelta (deltaPos dr (max 0 dc))) $ do printCommentAt (undelta p dp colOffset) commentContents - setPriorEndASTD False loc p' <- getPosP + d' <- getPriorEndD + debugM $ "printQueuedComment: (p,p',d,d')=" ++ show (p,p',d,d') debugM $ "printQueuedComment: (p,p',dp,colOffset,undelta)=" ++ show (p,p',dp,colOffset,undelta p dp colOffset) -{- --- Print version -printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () -printQueuedComment Comment{commentContents} dp = do - p <- getPos - colOffset <- getLayoutOffset - let (dr,dc) = undelta (0,0) dp colOffset - -- do not lose comments against the left margin - when (isGoodDelta (DP (dr,max 0 dc))) $ - printCommentAt (undelta p dp colOffset) commentContents - --} - --- --------------------------------------------------------------------- - --- withContext :: (Monad m, Monoid w) --- => [(KeywordId, DeltaPos)] --- -> Annotation --- -> EP w m a -> EP w m a --- withContext kds an x = withKds kds (withOffset an x) - --- --------------------------------------------------------------------- --- --- | Given an annotation associated with a specific SrcSpan, --- determines a new offset relative to the previous offset --- -withOffset :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a) -withOffset a = - local (\s -> s { epAnn = a }) - ------------------------------------------------------------------------ -setLayoutBoth :: (Monad m, Monoid w) => EP w m () -> EP w m () +setLayoutBoth :: (Monad m, Monoid w) => EP w m a -> EP w m a setLayoutBoth k = do - oldLHS <- gets dLHS + oldLHS <- getLayoutOffsetD oldAnchorOffset <- getLayoutOffsetP debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) modify (\a -> a { dMarkLayout = True @@ -3786,15 +4799,16 @@ setLayoutBoth k = do k <* reset -- Use 'local', designed for this -setLayoutTopLevelP :: (Monad m, Monoid w) => EP w m () -> EP w m () +setLayoutTopLevelP :: (Monad m, Monoid w) => EP w m a -> EP w m a setLayoutTopLevelP k = do debugM $ "setLayoutTopLevelP entered" oldAnchorOffset <- getLayoutOffsetP modify (\a -> a { pMarkLayout = False - , pLHS = 0} ) - k + , pLHS = 1} ) + r <- k debugM $ "setLayoutTopLevelP:resetting" setLayoutOffsetP oldAnchorOffset + return r ------------------------------------------------------------------------ @@ -3803,7 +4817,7 @@ getPosP = gets epPos setPosP :: (Monad m, Monoid w) => Pos -> EP w m () setPosP l = do - debugM $ "setPosP:" ++ show l + -- debugM $ "setPosP:" ++ show l modify (\s -> s {epPos = l}) getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe Anchor) @@ -3822,12 +4836,11 @@ getAnchorU = gets uAnchorSpan setPriorEndD :: (Monad m, Monoid w) => Pos -> EP w m () setPriorEndD pe = do - -- setLayoutStartIfNeededD (snd pe) setPriorEndNoLayoutD pe setPriorEndNoLayoutD :: (Monad m, Monoid w) => Pos -> EP w m () setPriorEndNoLayoutD pe = do - debugM $ "setPriorEndNoLayout:pe=" ++ show pe + debugM $ "setPriorEndNoLayoutD:pe=" ++ show pe modify (\s -> s { dPriorEndPosition = pe }) setPriorEndASTD :: (Monad m, Monoid w) => Bool -> RealSrcSpan -> EP w m () @@ -3847,6 +4860,9 @@ setLayoutStartD p = do modify (\s -> s { dMarkLayout = False , dLHS = LayoutStartCol p}) +getLayoutOffsetD :: (Monad m, Monoid w) => EP w m LayoutStartCol +getLayoutOffsetD = gets dLHS + setAnchorU :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () setAnchorU rss = do debugM $ "setAnchorU:" ++ show (rs2range rss) @@ -3858,6 +4874,45 @@ getUnallocatedComments = gets epComments putUnallocatedComments :: (Monad m, Monoid w) => [Comment] -> EP w m () putUnallocatedComments cs = modify (\s -> s { epComments = cs } ) +-- | Push a fresh stack frame for the applied comments gatherer +pushAppliedComments :: (Monad m, Monoid w) => EP w m () +pushAppliedComments = modify (\s -> s { epCommentsApplied = []:(epCommentsApplied s) }) + +-- | Return the comments applied since the last call +-- takeAppliedComments, and clear them, not popping the stack +takeAppliedComments :: (Monad m, Monoid w) => EP w m [Comment] +takeAppliedComments = do + ccs <- gets epCommentsApplied + case ccs of + [] -> do + modify (\s -> s { epCommentsApplied = [] }) + return [] + h:t -> do + modify (\s -> s { epCommentsApplied = []:t }) + return (reverse h) + +-- | Return the comments applied since the last call +-- takeAppliedComments, and clear them, popping the stack +takeAppliedCommentsPop :: (Monad m, Monoid w) => EP w m [Comment] +takeAppliedCommentsPop = do + ccs <- gets epCommentsApplied + case ccs of + [] -> do + modify (\s -> s { epCommentsApplied = [] }) + return [] + h:t -> do + modify (\s -> s { epCommentsApplied = t }) + return (reverse h) + +-- | Mark a comment as being applied. This is used to update comments +-- when doing delta processing +applyComment :: (Monad m, Monoid w) => Comment -> EP w m () +applyComment c = do + ccs <- gets epCommentsApplied + case ccs of + [] -> modify (\s -> s { epCommentsApplied = [[c]] } ) + (h:t) -> modify (\s -> s { epCommentsApplied = (c:h):t } ) + getLayoutOffsetP :: (Monad m, Monoid w) => EP w m LayoutStartCol getLayoutOffsetP = gets pLHS @@ -3868,59 +4923,31 @@ setLayoutOffsetP c = do -- --------------------------------------------------------------------- -------------------------------------------------------------------------- --- |First move to the given location, then call exactP --- exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a --- exactPC :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w) --- exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a --- exactPC ast action = --- do --- return () `debug` ("exactPC entered for:" ++ show (mkAnnKey ast)) --- ma <- getAndRemoveAnnotation ast --- let an@Ann{ annEntryDelta=edp --- , annPriorComments=comments --- , annFollowingComments=fcomments --- , annsDP=kds --- } = fromMaybe annNone ma --- PrintOptions{epAstPrint} <- ask --- r <- withContext kds an --- (mapM_ (uncurry printQueuedComment) comments --- >> advance edp --- >> censorM (epAstPrint ast) action --- <* mapM_ (uncurry printQueuedComment) fcomments) --- return r `debug` ("leaving exactPCfor:" ++ show (mkAnnKey ast)) - --- censorM :: (Monoid w, Monad m) => (w -> m w) -> EP w m a -> EP w m a --- censorM f m = passM (liftM (\x -> (x,f)) m) - --- passM :: (Monad m) => EP w m (a, w -> m w) -> EP w m a --- passM m = RWST $ \r s -> do --- ~((a, f),s', EPWriter w) <- runRWST m r s --- w' <- f w --- return (a, s', EPWriter w') advance :: (Monad m, Monoid w) => DeltaPos -> EP w m () advance dp = do p <- getPosP colOffset <- getLayoutOffsetP debugM $ "advance:(p,dp,colOffset,ws)=" ++ show (p,dp,colOffset,undelta p dp colOffset) - printWhitespace (undelta p dp colOffset) - -{- -Version from Print.advance -advance :: (Monad m, Monoid w) => DeltaPos -> EP w m () -advance cl = do - p <- getPos - colOffset <- getLayoutOffset - printWhitespace (undelta p cl colOffset) --} + if isGoodDelta dp + then do + printWhitespace (undelta p dp colOffset) + -- Sync point. We only call advance as we start the sub-span + -- processing, so force the dPriorEndPosition to ??? + p0 <- getPosP + d <- getPriorEndD + r <- getAnchorU + setPriorEndD (fst $ rs2range r) + debugM $ "advance:after: (posp, posd, posd')=" ++ show (p0,d,fst $ rs2range r) + else + return () -- --------------------------------------------------------------------- -adjustDeltaForOffsetM :: DeltaPos -> EPP DeltaPos +adjustDeltaForOffsetM :: (Monad m, Monoid w) => DeltaPos -> EP w m DeltaPos adjustDeltaForOffsetM dp = do - colOffset <- gets dLHS - return (adjustDeltaForOffset 0 colOffset dp) + colOffset <- getLayoutOffsetD + return (adjustDeltaForOffset colOffset dp) -- --------------------------------------------------------------------- -- Printing functions @@ -3928,7 +4955,7 @@ adjustDeltaForOffsetM dp = do printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () printString layout str = do EPState{epPos = (_,c), pMarkLayout} <- get - PrintOptions{epTokenPrint, epWhitespacePrint} <- ask + EPOptions{epTokenPrint, epWhitespacePrint} <- ask when (pMarkLayout && layout) $ do debugM $ "printString: setting pLHS to " ++ show c modify (\s -> s { pLHS = LayoutStartCol c, pMarkLayout = False } ) @@ -3937,11 +4964,17 @@ printString layout str = do let strDP = dpFromString str cr = getDeltaLine strDP p <- getPosP - colOffset <- getLayoutOffsetP + d <- getPriorEndD + colOffsetP <- getLayoutOffsetP + colOffsetD <- getLayoutOffsetD -- debugM $ "printString:(p,colOffset,strDP,cr)=" ++ show (p,colOffset,strDP,cr) if cr == 0 - then setPosP (undelta p strDP colOffset) - else setPosP (undelta p strDP 1) + then do + setPosP (undelta p strDP colOffsetP) + setPriorEndD (undelta d strDP colOffsetD) + else do + setPosP (undelta p strDP 1) + setPriorEndD (undelta d strDP 1) -- Debug stuff -- pp <- getPosP @@ -3953,46 +4986,23 @@ printString layout str = do then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s} else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s} - -{- - --- Print.printString -printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () -printString layout str = do - EPState{epPos = (_,c), epMarkLayout} <- get - PrintOptions{epTokenPrint, epWhitespacePrint} <- ask - when (epMarkLayout && layout) $ - modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } ) - - -- Advance position, taking care of any newlines in the string - let strDP@(DP (cr,_cc)) = dpFromString str - p <- getPos - colOffset <- getLayoutOffset - if cr == 0 - then setPos (undelta p strDP colOffset) - else setPos (undelta p strDP 1) - - -- - if not layout && c == 0 - then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s} - else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s} - --} - -------------------------------------------------------- -printStringAdvance :: String -> EPP () +printStringAdvance :: (Monad m, Monoid w) => String -> EP w m () printStringAdvance str = do ss <- getAnchorU - printStringAtKw' ss str + _ <- printStringAtRs ss str + return () -------------------------------------------------------- newLine :: (Monad m, Monoid w) => EP w m () newLine = do (l,_) <- getPosP + (ld,_) <- getPriorEndD printString False "\n" setPosP (l+1,1) + setPriorEndNoLayoutD (ld+1,1) padUntil :: (Monad m, Monoid w) => Pos -> EP w m () padUntil (l,c) = do |