diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +2021-11-23 v1.3 + * Update for GHC 9.2.1 as released + * Introduce makeDeltaAst command to convert all EpaSpan's to equivalent EpaDelta versions 2021-08-23 v1.2 * Remove types and functions from previous version, now obsolete 2021-08-23 v1.1 diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,5 +1,5 @@ name: ghc-exactprint -version: 1.2.0 +version: 1.3.0 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 9.2.1, this library provides a means to round trip any code that can @@ -15,8 +15,7 @@ maintainer: alan.zimm@gmail.com category: Development build-type: Simple --- tested-with: GHC == 9.2.1 -tested-with: GHC == 9.2.0.20210821 +tested-with: GHC == 9.2.1 extra-source-files: ChangeLog tests/examples/failing/*.hs tests/examples/ghc710-only/*.hs @@ -58,6 +57,7 @@ exposed-modules: Language.Haskell.GHC.ExactPrint , Language.Haskell.GHC.ExactPrint.ExactPrint , Language.Haskell.GHC.ExactPrint.Lookup + , Language.Haskell.GHC.ExactPrint.Orphans , Language.Haskell.GHC.ExactPrint.Parsers , Language.Haskell.GHC.ExactPrint.Preprocess , Language.Haskell.GHC.ExactPrint.Transform diff --git a/src/Language/Haskell/GHC/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint.hs @@ -11,8 +11,11 @@ , module Language.Haskell.GHC.ExactPrint.Transform -- * Printing + , ExactPrint(..) , exactPrint + -- * Relativising + , makeDeltaAst ) where import Language.Haskell.GHC.ExactPrint.ExactPrint diff --git a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs @@ -15,3438 +15,5137 @@ ( ExactPrint(..) , exactPrint - -- , exactPrintWithOptions - ) where - -import GHC -import GHC.Core.Coercion.Axiom (Role(..)) -import GHC.Data.Bag -import qualified GHC.Data.BooleanFormula as BF -import GHC.Data.FastString -import GHC.Types.Basic hiding (EP) -import GHC.Types.Fixity -import GHC.Types.ForeignCall -import GHC.Types.SourceText -import GHC.Types.Var -import GHC.Utils.Outputable hiding ( (<>) ) -import GHC.Unit.Module.Warnings -import GHC.Utils.Misc -import GHC.Utils.Panic - -import Control.Monad.Identity -import Control.Monad.RWS -import Data.Data ( Data ) -import Data.Foldable -import qualified Data.Set.Ordered as OSet -import Data.Typeable -import Data.List ( partition, sort, sortBy) -import Data.Maybe ( isJust ) - -import Data.Void - -import Language.Haskell.GHC.ExactPrint.Lookup -import Language.Haskell.GHC.ExactPrint.Utils -import Language.Haskell.GHC.ExactPrint.Types - --- import Debug.Trace - --- --------------------------------------------------------------------- - -exactPrint :: ExactPrint ast => Located ast -> String -exactPrint ast = 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 - -runEP :: PrintOptions Identity String - -> Annotated () -> Identity String -runEP epReader action = - fmap (output . snd) . - (\next -> execRWST next epReader defaultEPState) - . xx $ action - -xx :: Annotated () -> EP String Identity () --- xx :: Annotated() -> RWST (PrintOptions m w) (EPWriter w) EPState m () -xx = id - --- --------------------------------------------------------------------- - -defaultEPState :: EPState -defaultEPState = EPState - { epPos = (1,1) - , dLHS = 0 - , pMarkLayout = False - , pLHS = 0 - , dMarkLayout = False - , dPriorEndPosition = (1,1) - , uAnchorSpan = badRealSrcSpan - , uExtraDP = Nothing - , epComments = [] - } - - --- --------------------------------------------------------------------- --- The EP monad and basic combinators - --- | 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 - { - epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a - , epTokenPrint :: String -> m a - , epWhitespacePrint :: String -> m a - , epRigidity :: Rigidity - } - --- | Helper to create a 'PrintOptions' -printOptions :: - (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 - { - epAstPrint = astPrint - , epWhitespacePrint = wsPrint - , epTokenPrint = tokenPrint - , epRigidity = rigidity - } - --- | Options which can be used to print as a normal String. -stringOptions :: PrintOptions Identity String -stringOptions = printOptions (\_ b -> return b) return return NormalLayout - -data EPWriter a = EPWriter - { output :: !a } - -instance Monoid w => Semigroup (EPWriter w) where - (EPWriter a) <> (EPWriter b) = EPWriter (a <> b) - -instance Monoid w => Monoid (EPWriter w) where - mempty = EPWriter mempty - -data EPState = EPState - { uAnchorSpan :: !RealSrcSpan -- ^ in pre-changed AST - -- reference frame, from - -- Annotation - , uExtraDP :: !(Maybe Anchor) -- ^ Used to anchor a - -- list - - -- Print phase - , epPos :: !Pos -- ^ Current output position - , pMarkLayout :: !Bool - , pLHS :: !LayoutStartCol - - -- Delta phase - , dPriorEndPosition :: !Pos -- ^ End of Position reached - -- when processing the - -- preceding element - , dMarkLayout :: !Bool - , dLHS :: !LayoutStartCol - - -- Shared - , epComments :: ![Comment] - } - --- --------------------------------------------------------------------- - --- AZ:TODO: this can just be a function :: (EpAnn a) -> Entry -class HasEntry ast where - fromAnn :: ast -> Entry - --- --------------------------------------------------------------------- - --- 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 a = enterAnn (getAnnotationEntry a) a - --- | 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) - -data Entry = Entry Anchor EpAnnComments FlushComments - | NoEntryVal - -instance HasEntry (SrcSpanAnn' (EpAnn an)) where - fromAnn (SrcSpanAnn EpAnnNotUsed ss) = Entry (spanAsAnchor ss) emptyComments NoFlushComments - fromAnn (SrcSpanAnn an _) = fromAnn an - -instance HasEntry (EpAnn a) where - fromAnn (EpAnn anchor _ cs) = Entry anchor cs NoFlushComments - fromAnn EpAnnNotUsed = NoEntryVal - --- --------------------------------------------------------------------- - -fromAnn' :: (HasEntry a) => a -> Entry -fromAnn' an = case fromAnn an of - NoEntryVal -> NoEntryVal - Entry a c _ -> Entry a c FlushComments - --- --------------------------------------------------------------------- - -astId :: (Typeable a) => a -> String -astId a = show (typeOf a) - --- | "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 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 flush) a = do - p <- getPosP - debugM $ "enterAnn:(p,a) =" ++ show (p, astId a) ++ " starting" - -- debugM $ "enterAnn:(cs) =" ++ showGhc (cs) - let curAnchor = anchor anchor' -- As a base for the current AST element - debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor) - addCommentsA (priorComments cs) - printComments curAnchor - -- ------------------------- - 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 - -- ------------------------------------------------------------------- - -- The first part corresponds to the delta phase, so should only use - -- delta phase variables - -- ----------------------------------- - -- Calculate offset required to get to the start of the SrcSPan - off <- gets dLHS - let spanStart = ss2pos curAnchor - priorEndAfterComments <- getPriorEndD - let edp' = adjustDeltaForOffset 0 - -- Use the propagated offset if one is set - -- Note that we need to use the new offset if it has - -- changed. - off (ss2delta priorEndAfterComments curAnchor) - debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor) - let edp'' = case anchor_op anchor' of - MovedAnchor dp -> dp - _ -> edp' - -- --------------------------------------------- - -- let edp = edp'' - med <- getExtraDP - setExtraDP Nothing - let edp = case med of - Nothing -> edp'' - Just (Anchor _ (MovedAnchor dp)) -> dp - -- Replace original with desired one. Allows all - -- list entry values to be DP (1,0) - Just (Anchor r _) -> dp - where - dp = adjustDeltaForOffset 0 - off (ss2delta priorEndAfterComments r) - when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ show (med,edp) - -- --------------------------------------------- - -- Preparation complete, perform the action - when (priorEndAfterComments < spanStart) (do - debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart - modify (\s -> s { dPriorEndPosition = spanStart } )) - - debugM $ "enterAnn: (anchor_op, curAnchor):" ++ show (anchor_op anchor', rs2range curAnchor) - debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp) - - -- end of delta phase processing - -- ------------------------------------------------------------------- - -- start of print phase processing - - let mflush = when (flush == FlushComments) $ do - debugM $ "flushing comments in enterAnn" - flushComments (getFollowingComments cs) - -- flushComments [] - - -- let - -- st = annNone - -- withOffset st (advance edp >> exact a >> mflush) - (advance edp >> exact a >> mflush) - - 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" - --- --------------------------------------------------------------------- - -addCommentsA :: [LEpaComment] -> EPP () -addCommentsA csNew = addComments (map tokComment csNew) - -addComments :: [Comment] -> EPP () -addComments csNew = do - debugM $ "addComments:" ++ show csNew - cs <- getUnallocatedComments - -- Make sure we merge duplicates while sorting, needed until - -- https://gitlab.haskell.org/ghc/ghc/-/issues/20239 is resolved - let ocs = OSet.fromList cs - let ncs = OSet.fromList csNew - putUnallocatedComments (OSet.toAscList (ocs OSet.<>| ncs)) - - --- --------------------------------------------------------------------- - --- | Just before we print out the EOF comments, flush the remaining --- ones in the state. -flushComments :: [LEpaComment] -> EPP () -flushComments trailing = do - addCommentsA 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) - debugM $ "flushing comments starting" - mapM_ printOneComment (sortBy cmp cs) - debugM $ "flushing comments done" - --- --------------------------------------------------------------------- - --- |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 $ map (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) - -annotationsToCommentsA :: EpAnn [AddEpAnn] -> [AnnKeywordId] -> EPP () -annotationsToCommentsA EpAnnNotUsed _ = return () -annotationsToCommentsA an kws = annotationsToComments (anns an) kws - --- --------------------------------------------------------------------- - --- Temporary function to simply reproduce the "normal" pretty printer output -withPpr :: (Outputable a) => a -> Annotated () -withPpr a = do - ss <- getAnchorU - debugM $ "withPpr: ss=" ++ show ss - printStringAtKw' ss (showPprUnsafe 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 --- to be able to use the rest of the exactprint machinery to print the --- element. In the analogy to Outputable, 'exact' plays the role of --- 'ppr'. -class (Typeable a) => ExactPrint a where - getAnnotationEntry :: a -> Entry - exact :: a -> Annotated () - --- --------------------------------------------------------------------- - --- | Bare Located elements are simply stripped off without further --- processing. -instance (ExactPrint a) => ExactPrint (Located a) where - getAnnotationEntry (L l _) = Entry (spanAsAnchor l) emptyComments NoFlushComments - 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) - -instance (ExactPrint a) => ExactPrint [a] where - getAnnotationEntry = const NoEntryVal - exact ls = mapM_ markAnnotated ls - -instance (ExactPrint a) => ExactPrint (Maybe a) where - getAnnotationEntry = const NoEntryVal - exact Nothing = return () - exact (Just a) = markAnnotated a - --- --------------------------------------------------------------------- - --- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' -instance ExactPrint HsModule where - getAnnotationEntry hsmod = fromAnn' (hsmodAnn hsmod) - - exact hsmod@(HsModule EpAnnNotUsed _ _ _ _ _ _ _) = withPpr hsmod - exact (HsModule an _lo mmn mexports imports decls mdeprec mbDoc) = do - - markAnnotated mbDoc - - case mmn of - Nothing -> return () - Just (L ln mn) -> do - markEpAnn' an am_main AnnModule - markAnnotated (L ln mn) - - -- forM_ mdeprec markLocated - setLayoutTopLevelP $ markAnnotated mdeprec - - setLayoutTopLevelP $ markAnnotated mexports - - debugM $ "HsModule.AnnWhere coming" - setLayoutTopLevelP $ markEpAnn' an am_main AnnWhere - - markAnnList' False (am_decls $ anns an) $ do - markTopLevelList imports - markTopLevelList decls - --- --------------------------------------------------------------------- - --- 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) - -instance (ExactPrint a) => ExactPrint (AnnotatedList a) where - getAnnotationEntry (AnnotatedList (Just anc) _) = Entry anc (EpaComments []) NoFlushComments - getAnnotationEntry (AnnotatedList Nothing _) = NoEntryVal - - exact (AnnotatedList an ls) = do - debugM $ "AnnotatedList:an=" ++ show an - markAnnotatedWithLayout ls - - --- --------------------------------------------------------------------- --- Start of utility functions --- --------------------------------------------------------------------- - -printSourceText :: SourceText -> String -> EPP () -printSourceText NoSourceText txt = printStringAdvance txt -printSourceText (SourceText txt) _ = printStringAdvance txt - --- --------------------------------------------------------------------- - -printStringAtRs :: RealSrcSpan -> String -> EPP () -printStringAtRs ss str = printStringAtKw' ss str - -printStringAtSs :: SrcSpan -> String -> EPP () -printStringAtSs ss str = printStringAtKw' (realSrcSpan ss) str - --- --------------------------------------------------------------------- - --- 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 - - -printStringAtAA :: EpaLocation -> String -> EPP () -printStringAtAA (EpaSpan r) s = printStringAtKw' r s -printStringAtAA (EpaDelta d) s = do - pe <- getPriorEndD - p1 <- getPosP - printStringAtLsDelta d s - p2 <- getPosP - debugM $ "printStringAtAA:(pe,p1,p2)=" ++ show (pe,p1,p2) - setPriorEndASTPD True (p1,p2) - --- 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 - --- --------------------------------------------------------------------- - -markExternalSourceText :: SrcSpan -> SourceText -> String -> EPP () -markExternalSourceText l NoSourceText txt = printStringAtKw' (realSrcSpan l) txt -markExternalSourceText l (SourceText txt) _ = printStringAtKw' (realSrcSpan l) txt - --- --------------------------------------------------------------------- - -markAddEpAnn :: AddEpAnn -> EPP () -markAddEpAnn a@(AddEpAnn kw _) = mark [a] kw - -markLocatedMAA :: EpAnn a -> (a -> Maybe AddEpAnn) -> EPP () -markLocatedMAA EpAnnNotUsed _ = return () -markLocatedMAA (EpAnn _ a _) f = - case f a of - Nothing -> return () - Just aa -> markAddEpAnn aa - -markLocatedAA :: EpAnn a -> (a -> AddEpAnn) -> EPP () -markLocatedAA EpAnnNotUsed _ = return () -markLocatedAA (EpAnn _ a _) f = markKw (f a) - -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 - --- --------------------------------------------------------------------- - -markArrow :: EpAnn TrailingAnn -> HsArrow GhcPs -> EPP () -markArrow an arr = do - case arr of - HsUnrestrictedArrow _u -> - return () - HsLinearArrow _u ma -> do - mapM_ markAddEpAnn ma - HsExplicitMult _u ma t -> do - mapM_ markAddEpAnn ma - markAnnotated t - - case an of - EpAnnNotUsed -> pure () - _ -> markKwT (anns an) - --- --------------------------------------------------------------------- - -markAnnCloseP :: EpAnn AnnPragma -> EPP () -markAnnCloseP an = markLocatedAALS an (pure . apr_close) AnnClose (Just "#-}") - -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) - -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) - -markAnnOpen' :: Maybe EpaLocation -> SourceText -> String -> EPP () -markAnnOpen' ms NoSourceText txt = printStringAtMkw ms txt -markAnnOpen' ms (SourceText txt) _ = printStringAtMkw ms txt - --- --------------------------------------------------------------------- - -markOpeningParen, markClosingParen :: EpAnn AnnParen -> EPP () -markOpeningParen an = markParen an fst -markClosingParen an = markParen an snd - -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) - - -markAnnKw :: EpAnn a -> (a -> EpaLocation) -> AnnKeywordId -> EPP () -markAnnKw EpAnnNotUsed _ _ = return () -markAnnKw (EpAnn _ a _) f kw = markKwA kw (f a) - -markAnnKwAll :: EpAnn a -> (a -> [EpaLocation]) -> AnnKeywordId -> EPP () -markAnnKwAll EpAnnNotUsed _ _ = return () -markAnnKwAll (EpAnn _ a _) f kw = mapM_ (markKwA kw) (sort (f a)) - -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 - -markALocatedA :: EpAnn AnnListItem -> EPP () -markALocatedA EpAnnNotUsed = return () -markALocatedA (EpAnn _ a _) = markTrailing (lann_trailing a) - -markEpAnn :: EpAnn [AddEpAnn] -> AnnKeywordId -> EPP () -markEpAnn EpAnnNotUsed _ = return () -markEpAnn (EpAnn _ a _) kw = mark a kw - -markEpAnn' :: EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP () -markEpAnn' EpAnnNotUsed _ _ = return () -markEpAnn' (EpAnn _ a _) f kw = mark (f a) kw - -markEpAnnAll :: EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP () -markEpAnnAll EpAnnNotUsed _ _ = return () -markEpAnnAll (EpAnn _ a _) f kw = mapM_ markKw (sort anns) - where - anns = filter (\(AddEpAnn ka _) -> ka == kw) (f a) - -markAnnAll :: [AddEpAnn] -> AnnKeywordId -> EPP () -markAnnAll a kw = mapM_ markKw (sort 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 () - -markKwT :: TrailingAnn -> EPP () -markKwT (AddSemiAnn ss) = markKwA AnnSemi ss -markKwT (AddCommaAnn ss) = markKwA AnnComma ss -markKwT (AddVbarAnn ss) = markKwA AnnVbar ss -markKwT (AddRarrowAnn ss) = markKwA AnnRarrow ss -markKwT (AddRarrowAnnU ss) = markKwA AnnRarrowU ss -markKwT (AddLollyAnnU ss) = markKwA AnnLollyU ss - -markKw :: AddEpAnn -> EPP () -markKw (AddEpAnn kw ss) = markKwA kw ss - --- | This should be the main driver of the process, managing comments -markKwA :: AnnKeywordId -> EpaLocation -> EPP () -markKwA kw aa = printStringAtAA aa (keywordToString (G kw)) - --- --------------------------------------------------------------------- - -markAnnList :: Bool -> EpAnn AnnList -> EPP () -> EPP () -markAnnList _ EpAnnNotUsed action = action -markAnnList reallyTrail (EpAnn _ ann _) action = markAnnList' reallyTrail ann action - -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 (sort $ 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 - --- --------------------------------------------------------------------- - -printComments :: RealSrcSpan -> EPP () -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 - debugM $ "printOneComment:c=" ++ showGhc c - dp <-case anchor_op loc of - MovedAnchor dp -> return dp - _ -> 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 - 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)) - printQueuedComment (anchor loc) c dp' - --- --------------------------------------------------------------------- - -commentAllocation :: RealSrcSpan -> EPP [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 - putUnallocatedComments later - -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) - return earlier - --- --------------------------------------------------------------------- - - -markAnnotatedWithLayout :: ExactPrint ast => ast -> EPP () -markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a - --- --------------------------------------------------------------------- - -markTopLevelList :: ExactPrint ast => [ast] -> EPP () -markTopLevelList ls = mapM_ (\a -> setLayoutTopLevelP $ markAnnotated a) ls - --- --------------------------------------------------------------------- - -instance ExactPrint ModuleName where - getAnnotationEntry _ = NoEntryVal - exact n = do - debugM $ "ModuleName: " ++ showPprUnsafe n - withPpr n - --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedP WarningTxt) 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 - - 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 - --- --------------------------------------------------------------------- - -instance ExactPrint (ImportDecl GhcPs) where - getAnnotationEntry idecl = fromAnn (ideclExt idecl) - exact x@(ImportDecl EpAnnNotUsed _ _ _ _ _ _ _ _ _) = withPpr x - exact (ImportDecl ann@(EpAnn _ an _) msrc (L lm modname) mpkg _src safeflag qualFlag _impl mAs hiding) = do - - markAnnKw ann importDeclAnnImport AnnImport - - -- "{-# 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 - Just (StringLiteral src v _) -> - printStringAtMkw (importDeclAnnPackage an) (sourceTextToString src (show v)) - _ -> return () - - printStringAtKw' (realSrcSpan lm) (moduleNameString modname) - - case qualFlag of - QualifiedPost -- 'qualified' appears in postpositive position. - -> printStringAtMkw (importDeclAnnQualified an) "qualified" - _ -> return () - - case mAs of - Nothing -> return () - Just (L l mn) -> do - printStringAtMkw (importDeclAnnAs an) "as" - printStringAtKw' (realSrcSpan l) (moduleNameString mn) - - case hiding of - Nothing -> return () - Just (_isHiding,lie) -> markAnnotated lie - -- markTrailingSemi - - --- --------------------------------------------------------------------- - -instance ExactPrint HsDocString where - getAnnotationEntry _ = NoEntryVal - exact = withPpr -- TODO:AZ use annotations - --- --------------------------------------------------------------------- - -instance ExactPrint (HsDecl GhcPs) where - getAnnotationEntry (TyClD _ _) = NoEntryVal - getAnnotationEntry (InstD _ _) = NoEntryVal - getAnnotationEntry (DerivD _ _) = NoEntryVal - getAnnotationEntry (ValD _ _) = NoEntryVal - getAnnotationEntry (SigD _ _) = NoEntryVal - getAnnotationEntry (KindSigD _ _) = NoEntryVal - getAnnotationEntry (DefD _ _) = NoEntryVal - getAnnotationEntry (ForD _ _) = NoEntryVal - getAnnotationEntry (WarningD _ _) = NoEntryVal - getAnnotationEntry (AnnD _ _) = NoEntryVal - getAnnotationEntry (RuleD _ _) = NoEntryVal - getAnnotationEntry (SpliceD _ _) = NoEntryVal - 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 - --- --------------------------------------------------------------------- - -instance ExactPrint (InstDecl GhcPs) where - getAnnotationEntry (ClsInstD _ _) = NoEntryVal - getAnnotationEntry (DataFamInstD an _) = fromAnn an - getAnnotationEntry (TyFamInstD _ _) = NoEntryVal - - - exact (ClsInstD _ cid) = markAnnotated cid - exact (DataFamInstD an decl) = do - exactDataFamInstDecl an TopLevel decl - exact (TyFamInstD _ eqn) = do - markAnnotated eqn - --- --------------------------------------------------------------------- - -exactDataFamInstDecl :: EpAnn [AddEpAnn] -> TopLevelFlag -> (DataFamInstDecl GhcPs) -> EPP () -exactDataFamInstDecl an top_lvl - (DataFamInstDecl ( FamEqn { feqn_ext = an2 - , feqn_tycon = tycon - , feqn_bndrs = bndrs - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = defn })) - = markAnnotated (DataDefnWithContext an2 pp_hdr defn) -- See Note [an and an2 in exactDataFamInstDecl] - where - 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 - -{- -Note [an and an2 in exactDataFamInstDecl] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The exactDataFamInstDecl function is called to render a -DataFamInstDecl within its surrounding context. This context is -rendered via the 'pp_hdr' function, which uses the exact print -annotations from that context, named 'an'. The EPAs used for -rendering the DataDefn are contained in the FamEqn, and are called -'an2'. - --} - --- --------------------------------------------------------------------- - -instance ExactPrint (DerivDecl GhcPs) where - getAnnotationEntry (DerivDecl {deriv_ext = an} ) = fromAnn an - exact (DerivDecl an typ ms mov) = do - markEpAnn an AnnDeriving - mapM_ markAnnotated ms - markEpAnn an AnnInstance - mapM_ markAnnotated mov - markAnnotated typ - --- --------------------------------------------------------------------- - -instance ExactPrint (ForeignDecl GhcPs) where - getAnnotationEntry (ForeignImport an _ _ _) = fromAnn an - getAnnotationEntry (ForeignExport an _ _ _) = fromAnn an - - exact (ForeignImport an n ty fimport) = do - markEpAnn an AnnForeign - markEpAnn an AnnImport - - markAnnotated fimport - - markAnnotated n - markEpAnn an AnnDcolon - markAnnotated ty - - exact (ForeignExport an n ty fexport) = do - markEpAnn an AnnForeign - markEpAnn an AnnExport - markAnnotated fexport - markAnnotated n - markEpAnn an AnnDcolon - markAnnotated ty - --- --------------------------------------------------------------------- - -instance ExactPrint ForeignImport where - getAnnotationEntry = const NoEntryVal - exact (CImport cconv safety@(L ll _) _mh _imp (L ls src)) = do - markAnnotated cconv - unless (ll == noSrcSpan) $ markAnnotated safety - unless (ls == noSrcSpan) $ markExternalSourceText ls src "" - --- --------------------------------------------------------------------- - -instance ExactPrint ForeignExport where - getAnnotationEntry = const NoEntryVal - exact (CExport spec (L ls src)) = do - debugM $ "CExport starting" - markAnnotated spec - unless (ls == noSrcSpan) $ markExternalSourceText ls src "" - --- --------------------------------------------------------------------- - -instance ExactPrint CExportSpec where - getAnnotationEntry = const NoEntryVal - exact (CExportStatic _st _lbl cconv) = do - debugM $ "CExportStatic starting" - markAnnotated cconv - --- --------------------------------------------------------------------- - -instance ExactPrint Safety where - getAnnotationEntry = const NoEntryVal - exact = withPpr - --- --------------------------------------------------------------------- - -instance ExactPrint CCallConv where - getAnnotationEntry = const NoEntryVal - exact = withPpr - --- --------------------------------------------------------------------- - -instance ExactPrint (WarnDecls GhcPs) where - getAnnotationEntry (Warnings an _ _) = fromAnn an - exact (Warnings an src warns) = do - markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED - markAnnotated warns - markLocatedAALS an id AnnClose (Just "#-}") - --- --------------------------------------------------------------------- - -instance ExactPrint (WarnDecl GhcPs) where - getAnnotationEntry (Warning an _ _) = fromAnn an - - 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 -- "]" - --- --------------------------------------------------------------------- - -instance ExactPrint StringLiteral where - getAnnotationEntry = const NoEntryVal - - exact (StringLiteral src fs mcomma) = do - printSourceText src (show (unpackFS fs)) - mapM_ (\r -> printStringAtKw' r ",") mcomma - --- --------------------------------------------------------------------- - -instance ExactPrint FastString where - getAnnotationEntry = const NoEntryVal - - -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. - -- exact fs = printStringAdvance (show (unpackFS fs)) - exact fs = printStringAdvance (unpackFS fs) - - --- --------------------------------------------------------------------- - -instance ExactPrint (RuleDecls GhcPs) where - getAnnotationEntry (HsRules an _ _) = fromAnn an - 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 - --- --------------------------------------------------------------------- - -instance ExactPrint (RuleDecl GhcPs) where - getAnnotationEntry (HsRule {rd_ext = an}) = fromAnn an - exact (HsRule an ln act mtybndrs termbndrs lhs rhs) = do - debugM "HsRule entered" - markAnnotated ln - debugM "HsRule after ln" - markActivation an ra_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 - -markActivation :: EpAnn a -> (a -> [AddEpAnn]) -> Activation -> Annotated () -markActivation an fn 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 -- ']' - ActiveAfter src phase -> do - markEpAnn' an fn AnnOpenS -- '[' - markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) - markEpAnn' an fn AnnCloseS -- ']' - NeverActive -> do - markEpAnn' an fn AnnOpenS -- '[' - markEpAnn' an fn AnnTilde -- ~ - markEpAnn' an fn AnnCloseS -- ']' - _ -> return () - --- --------------------------------------------------------------------- - -instance ExactPrint (SpliceDecl GhcPs) where - getAnnotationEntry = const NoEntryVal - - exact (SpliceDecl _ splice _flag) = do - markAnnotated splice - --- --------------------------------------------------------------------- - -instance ExactPrint DocDecl where - getAnnotationEntry = const NoEntryVal - - exact v = - let str = - case v of - (DocCommentNext ds) -> unpackHDS ds - (DocCommentPrev ds) -> unpackHDS ds - (DocCommentNamed _s ds) -> unpackHDS ds - (DocGroup _i ds) -> unpackHDS ds - in - printStringAdvance str - --- --------------------------------------------------------------------- - -instance ExactPrint (RoleAnnotDecl GhcPs) where - getAnnotationEntry (RoleAnnotDecl an _ _) = fromAnn an - exact (RoleAnnotDecl an ltycon roles) = do - markEpAnn an AnnType - markEpAnn an AnnRole - markAnnotated ltycon - let markRole (L l (Just r)) = markAnnotated (L l r) - markRole (L l Nothing) = printStringAtSs l "_" - mapM_ markRole roles - --- --------------------------------------------------------------------- - -instance ExactPrint Role where - getAnnotationEntry = const NoEntryVal - exact = withPpr - --- --------------------------------------------------------------------- - -instance ExactPrint (RuleBndr GhcPs) where - getAnnotationEntry = const NoEntryVal - - 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 body) => ExactPrint (FamEqn GhcPs body) where - getAnnotationEntry (FamEqn { feqn_ext = an}) = fromAnn an - 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 - --- --------------------------------------------------------------------- - -exactHsFamInstLHS :: - EpAnn [AddEpAnn] - -> LocatedN RdrName - -> HsOuterTyVarBndrs () GhcPs - -> HsTyPats GhcPs - -> LexicalFixity - -> Maybe (LHsContext GhcPs) - -> EPP () -exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do - markEpAnn an AnnForall - markAnnotated bndrs - markEpAnn an AnnDot - mapM_ markAnnotated mb_ctxt - exact_pats typats - where - exact_pats :: HsTyPats GhcPs -> EPP () - exact_pats (patl:patr:pats) - | Infix <- fixity - = let exact_op_app = do - markAnnAll (epAnnAnns an) AnnOpenP - markAnnotated patl - markAnnotated thing - markAnnotated patr - markAnnAll (epAnnAnns an) AnnCloseP - in case pats of - [] -> exact_op_app - _ -> do - -- markEpAnn an AnnOpenP - exact_op_app - -- markEpAnn an AnnCloseP - mapM_ markAnnotated pats - - exact_pats pats = do - markAnnAll (epAnnAnns an) AnnOpenP - markAnnotated thing - markAnnotated pats - markAnnAll (epAnnAnns an) AnnCloseP - --- --------------------------------------------------------------------- - --- instance ExactPrint (LHsTypeArg GhcPs) where -instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) - => ExactPrint (HsArg tm ty) where - getAnnotationEntry = const NoEntryVal - - exact (HsValArg tm) = markAnnotated tm - exact (HsTypeArg ss ty) = printStringAtSs ss "@" >> markAnnotated ty - exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source - --- --------------------------------------------------------------------- - -instance ExactPrint (ClsInstDecl GhcPs) where - getAnnotationEntry cid = fromAnn (fst $ 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 }) - = do - top_matter - markEpAnn an AnnWhere - markEpAnn an AnnOpenC - markEpAnnAll an id AnnSemi - withSortKey sortKey - (prepareListAnnotationA ats - ++ prepareListAnnotationF (exactDataFamInstDecl an NotTopLevel ) adts - ++ prepareListAnnotationA (bagToList binds) - ++ prepareListAnnotationA sigs - ) - markEpAnn an AnnCloseC -- '}' - - where - top_matter = do - markEpAnn an AnnInstance - mapM_ markAnnotated mbOverlap - markAnnotated inst_ty - markEpAnn an AnnWhere -- Optional - --- --------------------------------------------------------------------- - -instance ExactPrint (TyFamInstDecl GhcPs) where - getAnnotationEntry (TyFamInstDecl an _) = fromAnn an - - exact (TyFamInstDecl { tfid_xtn = an, tfid_eqn = eqn }) = do - markEpAnn an AnnType - markEpAnn an AnnInstance - markAnnotated eqn - --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedP OverlapMode) where - getAnnotationEntry = entryFromLocatedA - - -- 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 _) (Overlappable src)) = do - markAnnOpenP an src "{-# OVERLAPPABLE" - markAnnCloseP an - - exact (L (SrcSpanAnn an _) (Overlapping src)) = do - markAnnOpenP an src "{-# OVERLAPPING" - markAnnCloseP an - - exact (L (SrcSpanAnn an _) (Overlaps src)) = do - markAnnOpenP an src "{-# OVERLAPS" - markAnnCloseP an - - exact (L (SrcSpanAnn an _) (Incoherent src)) = do - markAnnOpenP an src "{-# INCOHERENT" - markAnnCloseP an - --- --------------------------------------------------------------------- - -instance ExactPrint (HsBind GhcPs) where - getAnnotationEntry FunBind{} = NoEntryVal - getAnnotationEntry PatBind{pat_ext=an} = fromAnn an - getAnnotationEntry VarBind{} = NoEntryVal - getAnnotationEntry AbsBinds{} = NoEntryVal - getAnnotationEntry PatSynBind{} = NoEntryVal - - exact (FunBind _ _ matches _) = do - markAnnotated matches - exact (PatBind _ pat grhss _) = do - markAnnotated pat - markAnnotated grhss - exact (PatSynBind _ bind) = markAnnotated bind - - exact x = error $ "HsBind: exact for " ++ showAst x - --- --------------------------------------------------------------------- - -instance ExactPrint (PatSynBind GhcPs GhcPs) where - getAnnotationEntry (PSB { psb_ext = an}) = fromAnn an - - 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 - - --- --------------------------------------------------------------------- - -instance ExactPrint (RecordPatSynField GhcPs) where - getAnnotationEntry = const NoEntryVal - exact (RecordPatSynField { recordPatSynField = v }) = markAnnotated v - --- --------------------------------------------------------------------- - -instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry (Match ann _ _ _) = fromAnn ann - - exact (Match an mctxt pats grhss) = do - exactMatch (Match an mctxt pats grhss) - --- ------------------------------------- - -instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry (Match ann _ _ _) = fromAnn ann - - exact (Match an mctxt pats grhss) = do - exactMatch (Match an mctxt pats grhss) - --- --------------------------------------------------------------------- - -exactMatch :: (ExactPrint (GRHSs GhcPs body)) => (Match GhcPs body) -> Annotated () -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 - GHC.CaseAlt -> do - markAnnotated pats - _ -> withPpr mctxt - - markAnnotated grhss - --- --------------------------------------------------------------------- - -instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry (GRHSs _ _ _) = NoEntryVal - - exact (GRHSs _ grhss binds) = do - markAnnotated grhss - markAnnotated binds - - -instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry (GRHSs _ _ _) = NoEntryVal - - exact (GRHSs _an grhss binds) = do - markAnnotated grhss - markAnnotated binds - --- --------------------------------------------------------------------- - --- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/20247 --- is fixed -fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList -fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed -fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs) - = (EpAnn (widenAnchor anchor (map toEpaAnn t)) (AnnList ma o c r t) cs) - where - toEpaAnn (AddSemiAnn ss) = AddEpAnn AnnSemi ss - toEpaAnn (AddCommaAnn ss) = AddEpAnn AnnComma ss - toEpaAnn (AddVbarAnn ss) = AddEpAnn AnnVbar ss - toEpaAnn (AddRarrowAnn ss) = AddEpAnn AnnRarrow ss - toEpaAnn (AddRarrowAnnU ss) = AddEpAnn AnnRarrowU ss - toEpaAnn (AddLollyAnnU ss) = AddEpAnn AnnLollyU ss - --- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256 -fixAnnListAnn :: EpAnn AnnList -> EpAnn AnnList -fixAnnListAnn EpAnnNotUsed = EpAnnNotUsed -fixAnnListAnn (EpAnn anchor (AnnList ma o c r t) cs) - = (EpAnn (widenAnchor anchor r) (AnnList ma o c r t) cs) - --- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256 -fixSrcAnnL :: SrcSpanAnnL -> SrcSpanAnnL -fixSrcAnnL (SrcSpanAnn an l) = SrcSpanAnn (fixAnnListAnn an) l - --- --------------------------------------------------------------------- - -instance ExactPrint (HsLocalBinds GhcPs) where - getAnnotationEntry (HsValBinds an _) = fromAnn (fixValbindsAnn an) - getAnnotationEntry (HsIPBinds{}) = NoEntryVal - getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal - - exact (HsValBinds an' valbinds) = do - let an = fixValbindsAnn an' - markLocatedAAL an al_rest AnnWhere - let manc = case an of - EpAnnNotUsed -> Nothing - _ -> al_anchor $ anns an - - case manc of - Just anc -> do - when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc) - _ -> return () - - markAnnList False an $ markAnnotatedWithLayout valbinds - - exact (HsIPBinds an bs) - = markAnnList True an (markLocatedAAL an al_rest AnnWhere >> markAnnotated bs) - exact (EmptyLocalBinds _) = return () - - --- --------------------------------------------------------------------- -instance ExactPrint (HsValBindsLR GhcPs GhcPs) where - getAnnotationEntry _ = NoEntryVal - - exact (ValBinds sortKey binds sigs) = do - setLayoutBoth $ withSortKey sortKey - (prepareListAnnotationA (bagToList binds) - ++ prepareListAnnotationA sigs - ) - exact (XValBindsLR _) = panic "XValBindsLR" - --- --------------------------------------------------------------------- - -instance ExactPrint (HsIPBinds GhcPs) where - getAnnotationEntry = const NoEntryVal - - exact (IPBinds _ binds) = setLayoutBoth $ markAnnotated binds - --- --------------------------------------------------------------------- - -instance ExactPrint (IPBind GhcPs) where - getAnnotationEntry (IPBind an _ _) = fromAnn an - - exact (IPBind an (Left lr) rhs) = do - markAnnotated lr - markEpAnn an AnnEqual - markAnnotated rhs - - exact (IPBind _ (Right _) _) = error $ "ExactPrint IPBind: Right only after typechecker" - --- --------------------------------------------------------------------- - -instance ExactPrint HsIPName where - getAnnotationEntry = const NoEntryVal - - exact (HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs)) - --- --------------------------------------------------------------------- --- 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 - -prepareListAnnotationA :: ExactPrint (LocatedAn an a) - => [LocatedAn an a] -> [(RealSrcSpan,EPP ())] -prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,markAnnotated b)) ls - -withSortKey :: AnnSortKey -> [(RealSrcSpan, EPP ())] -> EPP () -withSortKey annSortKey xs = do - debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey - let ordered = case annSortKey of - NoAnnSortKey -> sortBy orderByFst xs - -- Just keys -> error $ "withSortKey: keys" ++ show keys - AnnSortKey keys -> orderByKey xs keys - -- `debug` ("withSortKey:" ++ - -- showPprUnsafe (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs), - -- map fst xs, - -- keys) - -- ) - mapM_ snd ordered - -orderByFst :: Ord a => (a, b1) -> (a, b2) -> Ordering -orderByFst (a,_) (b,_) = compare a b - --- --------------------------------------------------------------------- - -instance ExactPrint (Sig GhcPs) where - getAnnotationEntry (TypeSig a _ _) = fromAnn a - getAnnotationEntry (PatSynSig a _ _) = fromAnn a - getAnnotationEntry (ClassOpSig a _ _ _) = fromAnn a - getAnnotationEntry (IdSig {}) = NoEntryVal - getAnnotationEntry (FixSig a _) = fromAnn a - getAnnotationEntry (InlineSig a _ _) = fromAnn a - getAnnotationEntry (SpecSig a _ _ _) = fromAnn a - getAnnotationEntry (SpecInstSig a _ _) = fromAnn a - getAnnotationEntry (MinimalSig a _ _) = fromAnn a - getAnnotationEntry (SCCFunSig a _ _ _) = fromAnn a - getAnnotationEntry (CompleteMatchSig a _ _ _) = fromAnn a - - exact (TypeSig an vars ty) = exactVarSig an vars ty - - exact (PatSynSig an lns typ) = do - markLocatedAAL an asRest AnnPattern - markAnnotated lns - markLocatedAA an asDcolon - markAnnotated 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 - let fixstr = case fdir of - InfixL -> "infixl" - InfixR -> "infixr" - InfixN -> "infix" - markLocatedAALS an id AnnInfix (Just fixstr) - markLocatedAALS an id AnnVal (Just (sourceTextToString src (show v))) - markAnnotated names - - - exact (InlineSig an ln inl) = do - markAnnOpen an (inl_src inl) "{-# INLINE" - markActivation an id (inl_act inl) - markAnnotated ln - debugM $ "InlineSig:an=" ++ showAst an - p <- getPosP - debugM $ "InlineSig: p=" ++ show p - markLocatedAALS an id AnnClose (Just "#-}") - debugM $ "InlineSig:done" - - 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 "#-}") - - - exact (MinimalSig an src formula) = do - markAnnOpen an src "{-# MINIMAL" - markAnnotated formula - markLocatedAALS an id AnnClose (Just "#-}") - - 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 "#-}") - - exact x = error $ "exact Sig for:" ++ showAst x - --- --------------------------------------------------------------------- - -exactVarSig :: (ExactPrint a) => EpAnn AnnSig -> [LocatedN RdrName] -> a -> EPP () -exactVarSig an vars ty = do - mapM_ markAnnotated vars - markLocatedAA an asDcolon - markAnnotated ty - --- --------------------------------------------------------------------- - -instance ExactPrint (StandaloneKindSig GhcPs) where - getAnnotationEntry (StandaloneKindSig an _ _) = fromAnn an - - exact (StandaloneKindSig an vars sig) = do - markEpAnn an AnnType - markAnnotated vars - markEpAnn an AnnDcolon - markAnnotated sig - --- --------------------------------------------------------------------- - -instance ExactPrint (DefaultDecl GhcPs) where - getAnnotationEntry (DefaultDecl an _) = fromAnn an - - exact (DefaultDecl an tys) = do - markEpAnn an AnnDefault - markEpAnn an AnnOpenP - markAnnotated tys - markEpAnn an AnnCloseP - --- --------------------------------------------------------------------- - -instance ExactPrint (AnnDecl GhcPs) where - getAnnotationEntry (HsAnnotation an _ _ _) = fromAnn an - - 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 - --- --------------------------------------------------------------------- - -instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where - getAnnotationEntry = const NoEntryVal - - exact (BF.Var x) = do - markAnnotated x - exact (BF.Or ls) = markAnnotated ls - exact (BF.And ls) = do - markAnnotated ls - exact (BF.Parens x) = do - markAnnotated x - --- --------------------------------------------------------------------- - -instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where - getAnnotationEntry = const NoEntryVal - exact (HsWC _ ty) = markAnnotated ty - --- --------------------------------------------------------------------- - -instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry (GRHS an _ _) = fromAnn an - - exact (GRHS an guards expr) = do - debugM $ "GRHS comments:" ++ showGhc (comments an) - markAnnKwM an ga_vbar AnnVbar - markAnnotated guards - debugM $ "GRHS before matchSeparator" - markLocatedAA an ga_sep -- Mark the matchSeparator for these GRHSs - debugM $ "GRHS after matchSeparator" - markAnnotated expr - -instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry (GRHS ann _ _) = fromAnn ann - - 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 - --- --------------------------------------------------------------------- - -instance ExactPrint (HsExpr GhcPs) where - getAnnotationEntry (HsVar{}) = NoEntryVal - getAnnotationEntry (HsUnboundVar an _) = fromAnn an - getAnnotationEntry (HsConLikeOut{}) = NoEntryVal - getAnnotationEntry (HsRecFld{}) = NoEntryVal - getAnnotationEntry (HsOverLabel an _) = fromAnn an - getAnnotationEntry (HsIPVar an _) = fromAnn an - getAnnotationEntry (HsOverLit an _) = fromAnn an - getAnnotationEntry (HsLit an _) = fromAnn an - getAnnotationEntry (HsLam _ _) = NoEntryVal - getAnnotationEntry (HsLamCase an _) = fromAnn an - getAnnotationEntry (HsApp an _ _) = fromAnn an - getAnnotationEntry (HsAppType _ _ _) = NoEntryVal - getAnnotationEntry (OpApp an _ _ _) = fromAnn an - getAnnotationEntry (NegApp an _ _) = fromAnn an - getAnnotationEntry (HsPar an _) = fromAnn an - getAnnotationEntry (SectionL an _ _) = fromAnn an - getAnnotationEntry (SectionR an _ _) = fromAnn an - getAnnotationEntry (ExplicitTuple an _ _) = fromAnn an - getAnnotationEntry (ExplicitSum an _ _ _) = fromAnn an - getAnnotationEntry (HsCase an _ _) = fromAnn an - getAnnotationEntry (HsIf an _ _ _) = fromAnn an - getAnnotationEntry (HsMultiIf an _) = fromAnn an - getAnnotationEntry (HsLet an _ _) = fromAnn an - getAnnotationEntry (HsDo an _ _) = fromAnn an - getAnnotationEntry (ExplicitList an _) = fromAnn an - getAnnotationEntry (RecordCon an _ _) = fromAnn an - getAnnotationEntry (RecordUpd an _ _) = fromAnn an - getAnnotationEntry (HsGetField an _ _) = fromAnn an - getAnnotationEntry (HsProjection an _) = fromAnn an - getAnnotationEntry (ExprWithTySig an _ _) = fromAnn an - getAnnotationEntry (ArithSeq an _ _) = fromAnn an - getAnnotationEntry (HsBracket an _) = fromAnn an - getAnnotationEntry (HsRnBracketOut{}) = NoEntryVal - getAnnotationEntry (HsTcBracketOut{}) = NoEntryVal - getAnnotationEntry (HsSpliceE an _) = fromAnn an - getAnnotationEntry (HsProc an _ _) = fromAnn an - getAnnotationEntry (HsStatic an _) = fromAnn an - getAnnotationEntry (HsTick {}) = NoEntryVal - getAnnotationEntry (HsBinTick {}) = NoEntryVal - getAnnotationEntry (HsPragE{}) = NoEntryVal - - - exact (HsVar _ n) = markAnnotated n - exact x@(HsUnboundVar an _v) = do - case an of - EpAnnNotUsed -> withPpr x - EpAnn _ (EpAnnUnboundVar (ob,cb) l) _ -> do - printStringAtAA ob "`" - printStringAtAA l "_" - printStringAtAA cb "`" - -- exact x@(HsConLikeOut{}) = withPpr x - -- exact x@(HsRecFld{}) = withPpr x - exact x@(HsOverLabel _ _) = withPpr x - - exact (HsIPVar _ (HsIPName n)) - = printStringAdvance ("?" ++ unpackFS n) - - 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 - exact (HsLam _ _) = error $ "HsLam with other than one match" - - exact (HsLamCase an mg) = do - markEpAnn an AnnLam - markEpAnn an AnnCase - markAnnotated mg - - exact (HsApp _an e1 e2) = do - p <- getPosP - debugM $ "HsApp entered. p=" ++ show p - markAnnotated e1 - markAnnotated e2 - exact (HsAppType ss fun arg) = do - markAnnotated fun - printStringAtSs ss "@" - 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 e) = do - markOpeningParen an - markAnnotated e - debugM $ "HsPar closing paren" - markClosingParen an - debugM $ "HsPar done" - - exact (SectionL _an expr op) = do - markAnnotated expr - markAnnotated op - - exact (SectionR _an op expr) = do - markAnnotated op - markAnnotated expr - - exact (ExplicitTuple an args b) = do - if b == Boxed then markEpAnn an AnnOpenP - else markEpAnn an AnnOpenPH - - mapM_ markAnnotated args - - if b == Boxed then markEpAnn an AnnCloseP - else markEpAnn an AnnClosePH - debugM $ "ExplicitTuple done" - - exact (ExplicitSum an _alt _arity expr) = do - markAnnKw an aesOpen AnnOpenPH - markAnnKwAll an aesBarsBefore AnnVbar - markAnnotated expr - markAnnKwAll an aesBarsAfter AnnVbar - markAnnKw an aesClose AnnClosePH - - 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 (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 - - exact (HsMultiIf an mg) = do - markEpAnn an AnnIf - markEpAnn an AnnOpenC -- optional - markAnnotated mg - markEpAnn an AnnCloseC -- optional - - exact (HsLet an binds e) = do - setLayoutBoth $ do -- Make sure the 'in' gets indented too - markAnnKw an alLet AnnLet - debugM $ "HSlet:binds coming" - setLayoutBoth $ markAnnotated binds - debugM $ "HSlet:binds done" - markAnnKw an alIn AnnIn - debugM $ "HSlet:expr coming" - markAnnotated e - - exact (HsDo an do_or_list_comp stmts) = do - debugM $ "HsDo" - markAnnList True an $ exactDo an do_or_list_comp stmts - - exact (ExplicitList an es) = do - debugM $ "ExplicitList start" - markLocatedMAA an al_open - markAnnotated es - markLocatedMAA an al_close - debugM $ "ExplicitList end" - exact (RecordCon an con_id binds) = do - markAnnotated con_id - markEpAnn an AnnOpenC - markAnnotated binds - markEpAnn an AnnCloseC - 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 - exact (HsProjection an flds) = do - markAnnKw an apOpen AnnOpenP - markAnnotated flds - markAnnKw an apClose AnnCloseP - exact (ExprWithTySig an expr sig) = do - markAnnotated expr - markEpAnn an AnnDcolon - markAnnotated sig - exact (ArithSeq an _ seqInfo) = do - markEpAnn an AnnOpenS -- '[' - case seqInfo of - From e -> do - markAnnotated e - markEpAnn an AnnDotdot - FromTo e1 e2 -> do - markAnnotated e1 - markEpAnn an AnnDotdot - markAnnotated e2 - FromThen e1 e2 -> do - markAnnotated e1 - markEpAnn an AnnComma - markAnnotated e2 - markEpAnn an AnnDotdot - FromThenTo e1 e2 e3 -> do - markAnnotated e1 - markEpAnn an AnnComma - markAnnotated e2 - markEpAnn an AnnDotdot - markAnnotated e3 - markEpAnn an AnnCloseS -- ']' - - - exact (HsBracket an (ExpBr _ e)) = do - markEpAnn an AnnOpenEQ -- "[|" - markEpAnn an AnnOpenE -- "[e|" -- optional - markAnnotated e - markEpAnn an AnnCloseQ -- "|]" - exact (HsBracket an (PatBr _ e)) = do - markLocatedAALS an id AnnOpen (Just "[p|") - markAnnotated e - markEpAnn an AnnCloseQ -- "|]" - exact (HsBracket an (DecBrL _ e)) = do - - markLocatedAALS an id AnnOpen (Just "[d|") - -- See https://gitlab.haskell.org/ghc/ghc/-/issues/20257, we need - -- to mark braces here for the time being - markEpAnn an AnnOpenC -- "{" - markAnnotated e - markEpAnn an AnnCloseC -- "}" - markEpAnn an AnnCloseQ -- "|]" - -- -- exact (HsBracket an (DecBrG _ _)) = - -- -- traceM "warning: DecBrG introduced after renamer" - exact (HsBracket an (TypBr _ e)) = do - markLocatedAALS an id AnnOpen (Just "[t|") - markAnnotated e - markEpAnn an AnnCloseQ -- "|]" - exact (HsBracket an (VarBr _ b e)) = do - if b - then do - markEpAnn an AnnSimpleQuote - markAnnotated e - else do - markEpAnn an AnnThTyQuote - markAnnotated e - exact (HsBracket an (TExpBr _ e)) = do - markLocatedAALS an id AnnOpen (Just "[||") - markLocatedAALS an id AnnOpenE (Just "[e||") - markAnnotated e - markLocatedAALS an id AnnClose (Just "||]") - - - -- exact x@(HsRnBracketOut{}) = withPpr x - -- exact x@(HsTcBracketOut{}) = withPpr x - exact (HsSpliceE _ sp) = markAnnotated sp - - exact (HsProc an p c) = do - debugM $ "HsProc start" - markEpAnn an AnnProc - markAnnotated p - markEpAnn an AnnRarrow - debugM $ "HsProc after AnnRarrow" - markAnnotated c - - exact (HsStatic an e) = do - markEpAnn an AnnStatic - markAnnotated e - - -- exact x@(HsTick {}) = withPpr x - -- exact x@(HsBinTick {}) = withPpr x - exact (HsPragE _ prag e) = do - markAnnotated prag - markAnnotated e - exact x = error $ "exact HsExpr for:" ++ showAst x - --- --------------------------------------------------------------------- - -exactDo :: (ExactPrint body) - => EpAnn AnnList -> (HsStmtContext any) -> 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 ArrowExpr 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 _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt - -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) - where - n = (moduleNameString module_name) ++ "." ++ (keywordToString (G kw)) - - --- --------------------------------------------------------------------- -instance ExactPrint (HsPragE GhcPs) where - getAnnotationEntry HsPragSCC{} = NoEntryVal - - exact (HsPragSCC an st sl) = do - 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 - - --- --------------------------------------------------------------------- - -instance ExactPrint (HsSplice GhcPs) where - getAnnotationEntry (HsTypedSplice an _ _ _) = fromAnn an - getAnnotationEntry (HsUntypedSplice an _ _ _) = fromAnn an - getAnnotationEntry (HsQuasiQuote _ _ _ _ _) = NoEntryVal - getAnnotationEntry (HsSpliced _ _ _) = NoEntryVal - - exact (HsTypedSplice an DollarSplice _n e) = do - markEpAnn an AnnDollarDollar - markAnnotated e - - exact (HsUntypedSplice an decoration _n b) = do - when (decoration == DollarSplice) $ markEpAnn an AnnDollar - markAnnotated b - - exact (HsQuasiQuote _ _ q ss fs) = do - -- The quasiquote string does not honour layout offsets. Store - -- the colOffset for now. - -- TODO: use local? - oldOffset <- getLayoutOffsetP - EPState{pMarkLayout} <- get - unless pMarkLayout $ setLayoutOffsetP 0 - printStringAdvance - -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 - ("[" ++ (showPprUnsafe q) ++ "|" ++ (unpackFS fs) ++ "|]") - unless pMarkLayout $ setLayoutOffsetP oldOffset - p <- getPosP - debugM $ "HsQuasiQuote:after:(p,ss)=" ++ show (p,ss2range ss) - - exact x = error $ "exact HsSplice for:" ++ showAst x - --- --------------------------------------------------------------------- - --- TODO:AZ: combine these instances -instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry = const NoEntryVal - exact (MG _ matches _) = do - -- TODO:AZ use SortKey, in MG ann. - markAnnotated matches - -instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry = const NoEntryVal - exact (MG _ matches _) = do - -- TODO:AZ use SortKey, in MG ann. - markAnnotated matches - --- --------------------------------------------------------------------- - -instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where - getAnnotationEntry = const NoEntryVal - exact (HsRecFields fields mdot) = do - markAnnotated fields - case mdot of - Nothing -> return () - Just (L ss _) -> - printStringAtSs ss ".." - -- Note: mdot contains the SrcSpan where the ".." appears, if present - --- --------------------------------------------------------------------- - -instance (ExactPrint body) - => ExactPrint (HsRecField' (FieldOcc GhcPs) body) where - getAnnotationEntry x = fromAnn (hsRecFieldAnn x) - exact (HsRecField an f arg isPun) = do - debugM $ "HsRecField" - markAnnotated f - if isPun then return () - else do - markEpAnn an AnnEqual - markAnnotated arg - --- --------------------------------------------------------------------- - -instance (ExactPrint body) - => ExactPrint (HsRecField' (FieldLabelStrings GhcPs) body) where - getAnnotationEntry x = fromAnn (hsRecFieldAnn x) - exact (HsRecField an f arg isPun) = do - debugM $ "HsRecField FieldLabelStrings" - markAnnotated f - if isPun then return () - else do - markEpAnn an AnnEqual - markAnnotated arg - --- --------------------------------------------------------------------- - -instance (ExactPrint (LocatedA body)) - => ExactPrint (HsRecField' (AmbiguousFieldOcc GhcPs) (LocatedA body)) where - getAnnotationEntry x = fromAnn (hsRecFieldAnn x) - exact (HsRecField an f arg isPun) = do - debugM $ "HsRecUpdField" - markAnnotated f - if isPun then return () - else markEpAnn an AnnEqual - unless ((locA $ getLoc arg) == noSrcSpan ) $ markAnnotated arg - --- --------------------------------------------------------------------- -instance - (ExactPrint (HsRecField' (a GhcPs) body), - ExactPrint (HsRecField' (b GhcPs) body)) - => ExactPrint - (Either [LocatedA (HsRecField' (a GhcPs) body)] - [LocatedA (HsRecField' (b GhcPs) body)]) where - getAnnotationEntry = const NoEntryVal - exact (Left rbinds) = markAnnotated rbinds - exact (Right pbinds) = markAnnotated pbinds - --- --------------------------------------------------------------------- - -instance ExactPrint (FieldLabelStrings GhcPs) where - getAnnotationEntry = const NoEntryVal - exact (FieldLabelStrings fs) = markAnnotated fs - --- --------------------------------------------------------------------- - -instance ExactPrint (HsFieldLabel GhcPs) where - getAnnotationEntry (HsFieldLabel an _) = fromAnn an - - exact (HsFieldLabel an fs) = do - markAnnKwM an afDot AnnDot - markAnnotated fs - --- --------------------------------------------------------------------- - -instance ExactPrint (HsTupArg GhcPs) where - getAnnotationEntry (Present an _) = fromAnn an - getAnnotationEntry (Missing an) = fromAnn an - - exact (Present _ e) = markAnnotated e - - exact (Missing EpAnnNotUsed) = return () - exact (Missing _) = printStringAdvance "," - --- --------------------------------------------------------------------- - -instance ExactPrint (HsCmdTop GhcPs) where - getAnnotationEntry = const NoEntryVal - exact (HsCmdTop _ cmd) = markAnnotated cmd - --- --------------------------------------------------------------------- - -instance ExactPrint (HsCmd GhcPs) where - getAnnotationEntry (HsCmdArrApp an _ _ _ _) = fromAnn an - getAnnotationEntry (HsCmdArrForm an _ _ _ _ ) = fromAnn an - getAnnotationEntry (HsCmdApp an _ _ ) = fromAnn an - getAnnotationEntry (HsCmdLam {}) = NoEntryVal - getAnnotationEntry (HsCmdPar an _) = fromAnn an - getAnnotationEntry (HsCmdCase an _ _) = fromAnn an - getAnnotationEntry (HsCmdLamCase an _) = fromAnn an - getAnnotationEntry (HsCmdIf an _ _ _ _) = fromAnn an - getAnnotationEntry (HsCmdLet an _ _) = fromAnn an - getAnnotationEntry (HsCmdDo an _) = fromAnn an - - - - exact (HsCmdArrApp an arr arg _o isRightToLeft) = do - if isRightToLeft - then do - markAnnotated arr - markKw (anns an) - markAnnotated arg - 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 - (Infix, (arg1:argrest)) -> do - markAnnotated arg1 - markAnnotated e - markAnnotated argrest - (Prefix, _) -> do - markAnnotated e - markAnnotated cs - (Infix, []) -> error "Not possible" - markLocatedMAA an al_close - - exact (HsCmdApp _an e1 e2) = do - markAnnotated e1 - markAnnotated e2 - - exact (HsCmdLam _ match) = markAnnotated match - - exact (HsCmdPar an e) = do - markOpeningParen an - markAnnotated e - markClosingParen an - - 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 - - exact (HsCmdLamCase an matches) = do - markEpAnn an AnnLam - markEpAnn an AnnCase - 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 - - exact (HsCmdLet an binds e) = do - markAnnKw an alLet AnnLet - markAnnotated binds - markAnnKw an alIn AnnIn - markAnnotated e - - exact (HsCmdDo an es) = do - debugM $ "HsCmdDo" - markEpAnn' an al_rest AnnDo - markAnnotated es - - -- exact x = error $ "exact HsCmd for:" ++ showAst x - --- --------------------------------------------------------------------- - -instance ( - ExactPrint (LocatedA (body GhcPs)), - Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA, - Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL, - (ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) - => ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where - getAnnotationEntry (LastStmt _ _ _ _) = NoEntryVal - getAnnotationEntry (BindStmt an _ _) = fromAnn an - getAnnotationEntry (ApplicativeStmt _ _ _) = NoEntryVal - getAnnotationEntry (BodyStmt _ _ _ _) = NoEntryVal - getAnnotationEntry (LetStmt an _) = fromAnn an - getAnnotationEntry (ParStmt _ _ _ _) = NoEntryVal - getAnnotationEntry (TransStmt an _ _ _ _ _ _ _ _) = fromAnn an - getAnnotationEntry (RecStmt an _ _ _ _ _ _) = fromAnn an - - ----------------------------------------------------------------- - - exact (LastStmt _ body _ _) = do - debugM $ "LastStmt" - markAnnotated body - - exact (BindStmt an pat body) = do - debugM $ "BindStmt" - markAnnotated pat - markEpAnn an AnnLarrow - markAnnotated body - - exact (ApplicativeStmt _ _body _) = do - debugM $ "ApplicativeStmt" - -- TODO: ApplicativeStmt - -- markAnnotated body - error $ "need to complete ApplicativeStmt" - - exact (BodyStmt _ body _ _) = do - debugM $ "BodyStmt" - markAnnotated body - - exact (LetStmt an binds) = do - debugM $ "LetStmt" - markEpAnn an AnnLet - markAnnotated binds - - exact (ParStmt _ pbs _ _) = do - debugM $ "ParStmt" - markAnnotated pbs - - - exact (TransStmt an form stmts _b using by _ _ _) = do - debugM $ "TransStmt" - markAnnotated stmts - exactTransStmt an by using form - - - exact (RecStmt an stmts _ _ _ _ _) = do - debugM $ "RecStmt" - markLocatedAAL an al_rest AnnRec - markAnnList True an (markAnnotated stmts) - - -- exact x = error $ "exact CmdLStmt for:" ++ showAst x - -- exact x = error $ "exact CmdLStmt for:" - - --- --------------------------------------------------------------------- - -instance ExactPrint (ParStmtBlock GhcPs GhcPs) where - getAnnotationEntry = const NoEntryVal - exact (ParStmtBlock _ stmts _ _) = markAnnotated stmts - -exactTransStmt :: EpAnn [AddEpAnn] -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm -> EPP () -exactTransStmt an by using ThenForm = do - debugM $ "exactTransStmt:ThenForm" - markEpAnn an AnnThen - markAnnotated using - case by of - Nothing -> return () - Just b -> do - markEpAnn an AnnBy - markAnnotated b -exactTransStmt an by using GroupForm = do - debugM $ "exactTransStmt:GroupForm" - markEpAnn an AnnThen - markEpAnn an AnnGroup - case by of - Just b -> do - markEpAnn an AnnBy - markAnnotated b - Nothing -> return () - markEpAnn an AnnUsing - markAnnotated using - --- --------------------------------------------------------------------- - -instance ExactPrint (TyClDecl GhcPs) where - getAnnotationEntry (FamDecl { }) = NoEntryVal - getAnnotationEntry (SynDecl { tcdSExt = an }) = fromAnn an - getAnnotationEntry (DataDecl { tcdDExt = an }) = fromAnn an - getAnnotationEntry (ClassDecl { tcdCExt = (an, _, _) }) = fromAnn an - - exact (FamDecl _ decl) = do - markAnnotated 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 - - exactVanillaDeclHead ltycon tyvars fixity Nothing - markEpAnn an AnnEqual - markAnnotated rhs - - exact (DataDecl { tcdDExt = an, tcdLName = ltycon, tcdTyVars = tyvars - , tcdFixity = fixity, tcdDataDefn = defn }) = - exactDataDefn an (exactVanillaDeclHead ltycon tyvars fixity) defn - - -- ----------------------------------- - - exact (ClassDecl {tcdCExt = (an, sortKey, _), - tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdFDs = fds, - tcdSigs = sigs, tcdMeths = methods, - tcdATs = ats, tcdATDefs = at_defs, - tcdDocs = _docs}) - -- 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 - - | otherwise -- Laid out - = do - top_matter - markEpAnn an AnnOpenC - markEpAnnAll an id AnnSemi - withSortKey sortKey - (prepareListAnnotationA sigs - ++ prepareListAnnotationA (bagToList methods) - ++ prepareListAnnotationA ats - ++ prepareListAnnotationA at_defs - -- ++ prepareListAnnotation docs - ) - markEpAnn an AnnCloseC - 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 - --- --------------------------------------------------------------------- - -instance ExactPrint (FunDep GhcPs) where - getAnnotationEntry (FunDep an _ _) = fromAnn an - - exact (FunDep an ls rs') = do - markAnnotated ls - markEpAnn an AnnRarrow - markAnnotated rs' - --- --------------------------------------------------------------------- - -instance ExactPrint (FamilyDecl GhcPs) where - getAnnotationEntry (FamilyDecl { fdExt = an }) = fromAnn an - - exact (FamilyDecl { fdExt = an - , fdInfo = info - , fdTopLevel = top_level - , fdLName = ltycon - , fdTyVars = tyvars - , fdFixity = fixity - , fdResultSig = L _ 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 () - 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 - - -exactFlavour :: EpAnn [AddEpAnn] -> FamilyInfo GhcPs -> EPP () -exactFlavour an DataFamily = markEpAnn an AnnData -exactFlavour an OpenTypeFamily = markEpAnn an AnnType -exactFlavour an (ClosedTypeFamily {}) = markEpAnn an AnnType - --- --------------------------------------------------------------------- - -data DataDefnWithContext - = DataDefnWithContext - { ddwc_an :: EpAnn [AddEpAnn] - , ddwc_hdr:: (Maybe (LHsContext GhcPs) -> EPP ()) -- Printing the header - , ddwc_defn:: HsDataDefn GhcPs - } - -instance ExactPrint DataDefnWithContext where - getAnnotationEntry DataDefnWithContext{ddwc_an = an} = fromAnn an - - exact (DataDefnWithContext an exactHdr defn) - = exactDataDefn an exactHdr defn - -exactDataDefn :: EpAnn [AddEpAnn] - -> (Maybe (LHsContext GhcPs) -> EPP ()) -- Printing the header - -> HsDataDefn GhcPs - -> EPP () -exactDataDefn an exactHdr - (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context - , dd_cType = mb_ct - , dd_kindSig = mb_sig - , dd_cons = condecls, dd_derivs = derivings }) = do - annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP] - if new_or_data == DataType - then markEpAnn an AnnData - else markEpAnn an 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 condecls - markEpAnn an AnnCloseC - mapM_ markAnnotated derivings - return () - - -exactVanillaDeclHead :: LocatedN RdrName - -> LHsQTyVars GhcPs - -> LexicalFixity - -> Maybe (LHsContext GhcPs) - -> EPP () -exactVanillaDeclHead thing (HsQTvs { hsq_explicit = tyvars }) fixity context = do - let - exact_tyvars :: [LHsTyVarBndr () GhcPs] -> EPP () - exact_tyvars (varl:varsr) - | fixity == Infix && length varsr > 1 = do - markAnnotated varl - markAnnotated thing - markAnnotated (head varsr) - markAnnotated (tail varsr) - return () - | fixity == Infix = do - markAnnotated varl - markAnnotated thing - markAnnotated varsr - return () - | otherwise = do - markAnnotated thing - mapM_ markAnnotated (varl:varsr) - return () - exact_tyvars [] = do - markAnnotated thing - mapM_ markAnnotated context - exact_tyvars tyvars - --- --------------------------------------------------------------------- - -instance ExactPrint (InjectivityAnn GhcPs) where - getAnnotationEntry (InjectivityAnn an _ _) = fromAnn an - exact (InjectivityAnn an lhs rhs) = do - markEpAnn an AnnVbar - markAnnotated lhs - markEpAnn an AnnRarrow - mapM_ markAnnotated rhs - --- --------------------------------------------------------------------- - -class Typeable flag => ExactPrintTVFlag flag where - exactTVDelimiters :: EpAnn [AddEpAnn] -> flag -> Annotated () -> Annotated () - -instance ExactPrintTVFlag () where - exactTVDelimiters an _ thing_inside = do - markEpAnnAll an id AnnOpenP - thing_inside - markEpAnnAll an id AnnCloseP - -instance ExactPrintTVFlag Specificity where - exactTVDelimiters an s thing_inside = do - markEpAnnAll an id open - thing_inside - markEpAnnAll an id close - where - (open, close) = case s of - SpecifiedSpec -> (AnnOpenP, AnnCloseP) - InferredSpec -> (AnnOpenC, AnnCloseC) - -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 - --- --------------------------------------------------------------------- - -instance ExactPrint (HsType GhcPs) where - getAnnotationEntry (HsForAllTy _ _ _) = NoEntryVal - getAnnotationEntry (HsQualTy _ _ _) = NoEntryVal - getAnnotationEntry (HsTyVar an _ _) = fromAnn an - getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal - getAnnotationEntry (HsAppKindTy _ _ _) = NoEntryVal - getAnnotationEntry (HsFunTy an _ _ _) = fromAnn an - getAnnotationEntry (HsListTy an _) = fromAnn an - getAnnotationEntry (HsTupleTy an _ _) = fromAnn an - getAnnotationEntry (HsSumTy an _) = fromAnn an - getAnnotationEntry (HsOpTy _ _ _ _) = NoEntryVal - getAnnotationEntry (HsParTy an _) = fromAnn an - getAnnotationEntry (HsIParamTy an _ _) = fromAnn an - getAnnotationEntry (HsStarTy _ _) = NoEntryVal - getAnnotationEntry (HsKindSig an _ _) = fromAnn an - getAnnotationEntry (HsSpliceTy _ _) = NoEntryVal - getAnnotationEntry (HsDocTy an _ _) = fromAnn an - getAnnotationEntry (HsBangTy an _ _) = fromAnn an - getAnnotationEntry (HsRecTy an _) = fromAnn an - getAnnotationEntry (HsExplicitListTy an _ _) = fromAnn an - getAnnotationEntry (HsExplicitTupleTy an _) = fromAnn an - getAnnotationEntry (HsTyLit _ _) = NoEntryVal - getAnnotationEntry (HsWildCardTy _) = NoEntryVal - getAnnotationEntry (XHsType _) = NoEntryVal - - - exact (HsForAllTy { hst_xforall = _an - , hst_tele = tele, hst_body = ty }) = do - markAnnotated tele - markAnnotated ty - - exact (HsQualTy _ ctxt ty) = do - markAnnotated ctxt - markAnnotated ty - exact (HsTyVar an promoted name) = do - when (promoted == IsPromoted) $ markEpAnn an AnnSimpleQuote - markAnnotated name - - exact (HsAppTy _ t1 t2) = markAnnotated t1 >> markAnnotated t2 - exact (HsAppKindTy ss ty ki) = do - markAnnotated ty - printStringAtSs ss "@" - markAnnotated ki - exact (HsFunTy an mult ty1 ty2) = do - markAnnotated ty1 - markArrow an mult - markAnnotated ty2 - exact (HsListTy an tys) = do - markOpeningParen an - markAnnotated tys - markClosingParen an - exact (HsTupleTy an _con tys) = do - markOpeningParen an - markAnnotated tys - markClosingParen an - exact (HsSumTy an tys) = do - markOpeningParen an - markAnnotated tys - markClosingParen an - exact (HsOpTy _an t1 lo t2) = do - markAnnotated t1 - markAnnotated lo - markAnnotated t2 - exact (HsParTy an ty) = do - markOpeningParen an - markAnnotated ty - markClosingParen an - exact (HsIParamTy an n t) = do - markAnnotated n - markEpAnn an AnnDcolon - markAnnotated t - exact (HsStarTy _an isUnicode) - = if isUnicode - then printStringAdvance "\x2605" -- Unicode star - else printStringAdvance "*" - 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 - exact (HsExplicitListTy an prom tys) = do - when (isPromoted prom) $ markEpAnn an AnnSimpleQuote - markEpAnn an AnnOpenS - markAnnotated tys - markEpAnn an AnnCloseS - exact (HsExplicitTupleTy an tys) = do - markEpAnn an AnnSimpleQuote - markEpAnn an AnnOpenP - markAnnotated tys - markEpAnn an AnnCloseP - exact (HsTyLit _ 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 "_" - exact x = error $ "missing match for HsType:" ++ showAst x - --- --------------------------------------------------------------------- - -instance ExactPrint (HsForAllTelescope GhcPs) where - getAnnotationEntry (HsForAllVis an _) = fromAnn an - getAnnotationEntry (HsForAllInvis an _) = fromAnn an - - exact (HsForAllVis an bndrs) = do - markLocatedAA an fst -- AnnForall - markAnnotated bndrs - markLocatedAA an snd -- AnnRarrow - - exact (HsForAllInvis an bndrs) = do - markLocatedAA an fst -- AnnForall - markAnnotated bndrs - markLocatedAA an snd -- AnnDot - --- --------------------------------------------------------------------- - -instance ExactPrint (HsDerivingClause GhcPs) where - getAnnotationEntry d@(HsDerivingClause{}) = fromAnn (deriv_clause_ext d) - - exact (HsDerivingClause { deriv_clause_ext = an - , deriv_clause_strategy = dcs - , deriv_clause_tys = dct }) = do - markEpAnn an AnnDeriving - exact_strat_before - markAnnotated dct - exact_strat_after - 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) - _ -> (mapM_ markAnnotated dcs, pure ()) - --- --------------------------------------------------------------------- - -instance ExactPrint (DerivStrategy GhcPs) where - getAnnotationEntry (StockStrategy an) = fromAnn an - getAnnotationEntry (AnyclassStrategy an) = fromAnn an - 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 - --- --------------------------------------------------------------------- - -instance (ExactPrint a) => ExactPrint (LocatedC a) where - getAnnotationEntry (L sann _) = fromAnn sann - - exact (L (SrcSpanAnn EpAnnNotUsed _) a) = markAnnotated a - exact (L (SrcSpanAnn (EpAnn _ (AnnContext ma opens closes) _) _) a) = do - mapM_ (markKwA AnnOpenP) (sort opens) - markAnnotated a - mapM_ (markKwA AnnCloseP) (sort closes) - case ma of - Just (UnicodeSyntax, r) -> markKwA AnnDarrowU r - Just (NormalSyntax, r) -> markKwA AnnDarrow r - Nothing -> pure () - --- --------------------------------------------------------------------- - -instance ExactPrint (DerivClauseTys GhcPs) where - getAnnotationEntry = const NoEntryVal - - exact (DctSingle _ ty) = markAnnotated ty - exact (DctMulti _ tys) = do - markAnnotated tys - --- --------------------------------------------------------------------- - -instance ExactPrint (HsSigType GhcPs) where - getAnnotationEntry = const NoEntryVal - - exact (HsSig _ bndrs ty) = do - markAnnotated bndrs - markAnnotated 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 - 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 () -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) - -adornments :: NameAdornment -> (AnnKeywordId, AnnKeywordId) -adornments NameParens = (AnnOpenP, AnnCloseP) -adornments NameParensHash = (AnnOpenPH, AnnClosePH) -adornments NameBackquotes = (AnnBackquote, AnnBackquote) -adornments NameSquare = (AnnOpenS, AnnCloseS) - -markTrailing :: [TrailingAnn] -> EPP () -markTrailing ts = do - p <- getPosP - debugM $ "markTrailing:" ++ showPprUnsafe (p,ts) - mapM_ markKwT (sort ts) - --- --------------------------------------------------------------------- - --- based on pp_condecls in Decls.hs -exact_condecls :: EpAnn [AddEpAnn] -> [LConDecl GhcPs] -> EPP () -exact_condecls an cs - | gadt_syntax -- In GADT syntax - = do - mapM_ markAnnotated cs - | otherwise -- In H98 syntax - = do - markEpAnn an AnnEqual - mapM_ markAnnotated cs - where - gadt_syntax = case cs of - [] -> False - (L _ ConDeclH98{} : _) -> False - (L _ ConDeclGADT{} : _) -> True - --- --------------------------------------------------------------------- - -instance ExactPrint (ConDecl GhcPs) where - getAnnotationEntry x@(ConDeclGADT{}) = fromAnn (con_g_ext x) - getAnnotationEntry x@(ConDeclH98{}) = fromAnn (con_ext x) - --- based on pprConDecl - exact (ConDeclH98 { con_ext = an - , con_name = con - , con_forall = has_forall - , con_ex_tvs = ex_tvs - , con_mb_cxt = mcxt - , con_args = args - , con_doc = doc }) = do - mapM_ markAnnotated doc - when has_forall $ markEpAnn an AnnForall - mapM_ markAnnotated ex_tvs - when has_forall $ markEpAnn an AnnDot - mapM_ markAnnotated mcxt - when (isJust mcxt) $ markEpAnn an AnnDarrow - - exact_details args - - 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 - exact_details (PrefixCon tyargs tys) = do - markAnnotated con - markAnnotated tyargs - markAnnotated tys - exact_details (RecCon fields) = do - markAnnotated con - markAnnotated fields - - -- ----------------------------------- - - exact (ConDeclGADT { con_g_ext = an - , con_names = cons - , 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 - markEpAnn an AnnDcolon - annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP] - markAnnotated bndrs - mapM_ markAnnotated mcxt - when (isJust mcxt) $ markEpAnn an AnnDarrow - case args of - (PrefixConGADT args') -> mapM_ markScaled args' - (RecConGADT fields) -> markAnnotated fields - markAnnotated res_ty - --- --------------------------------------------------------------------- - -instance ExactPrint Void where - getAnnotationEntry = const NoEntryVal - exact _ = return () - --- --------------------------------------------------------------------- - -instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) where - getAnnotationEntry (HsOuterImplicit _) = NoEntryVal - getAnnotationEntry (HsOuterExplicit an _) = fromAnn an - - exact (HsOuterImplicit _) = pure () - exact (HsOuterExplicit an bndrs) = do - markLocatedAA an fst -- "forall" - markAnnotated bndrs - markLocatedAA an snd -- "." - --- --------------------------------------------------------------------- - -instance ExactPrint (ConDeclField GhcPs) where - getAnnotationEntry f@(ConDeclField{}) = fromAnn (cd_fld_ext f) - - exact (ConDeclField an names ftype mdoc) = do - markAnnotated names - markEpAnn an AnnDcolon - markAnnotated ftype - mapM_ markAnnotated mdoc - --- --------------------------------------------------------------------- - -instance ExactPrint (FieldOcc GhcPs) where - getAnnotationEntry = const NoEntryVal - exact (FieldOcc _ n) = markAnnotated n - --- --------------------------------------------------------------------- - -instance ExactPrint (AmbiguousFieldOcc GhcPs) where - getAnnotationEntry = const NoEntryVal - exact (Unambiguous _ n) = markAnnotated n - exact (Ambiguous _ n) = markAnnotated n - --- --------------------------------------------------------------------- - -markScaled :: (HsScaled GhcPs (LBangType GhcPs)) -> Annotated () -markScaled (HsScaled arr (L l c)) = - markAnnotated ((L l (HsScaled arr (L (noAnnSrcSpan $ locA l) c))) - :: LocatedA (HsScaled GhcPs (LBangType GhcPs))) - -instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where - getAnnotationEntry = const NoEntryVal - exact (HsScaled arr t) = do - markAnnotated t - markArrow EpAnnNotUsed arr - --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedP CType) where - getAnnotationEntry = entryFromLocatedA - - exact (L (SrcSpanAnn EpAnnNotUsed _) ct) = withPpr ct - 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 - --- --------------------------------------------------------------------- - -instance ExactPrint (SourceText, RuleName) where - -- We end up at the right place from the Located wrapper - getAnnotationEntry = const NoEntryVal - - exact (st, rn) - = printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "") - - --- ===================================================================== --- LocatedL instances start -- --- --- Each is dealt with specifically, as they have --- different wrapping annotations in the al_rest zone. --- --- In future, the annotation could perhaps be improved, with an --- 'al_pre' and 'al_post' set of annotations to be simply sorted and --- applied. --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where - getAnnotationEntry = entryFromLocatedA - - exact (L (SrcSpanAnn ann _) ies) = do - debugM $ "LocatedL [LIE" - markLocatedAAL ann al_rest AnnHiding - p <- getPosP - debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p - markAnnList True ann (markAnnotated ies) - -instance (ExactPrint (Match GhcPs (LocatedA body))) - => ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA body))]) 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 [ExprLStmt GhcPs]) where -instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where - getAnnotationEntry = entryFromLocatedAFixed - exact (L (SrcSpanAnn an' _) stmts) = do - let an = fixAnnListAnn an' - debugM $ "LocatedL [ExprLStmt" - markAnnList True an $ do - -- markLocatedMAA an al_open - 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 - --- instance ExactPrint (LocatedL [CmdLStmt GhcPs]) where -instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where - getAnnotationEntry = entryFromLocatedAFixed - exact (L (SrcSpanAnn ann' _) es) = do - let ann = fixAnnListAnn ann' - debugM $ "LocatedL [CmdLStmt" - markLocatedMAA ann al_open - mapM_ markAnnotated es - markLocatedMAA ann al_close - -instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where - getAnnotationEntry = entryFromLocatedA - exact (L (SrcSpanAnn an _) fs) = do - debugM $ "LocatedL [LConDeclField" - markAnnList True an (mapM_ markAnnotated fs) -- AZ:TODO get rid of mapM_ - -instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where - getAnnotationEntry = entryFromLocatedA - exact (L (SrcSpanAnn an _) bf) = do - debugM $ "LocatedL [LBooleanFormula" - markAnnList True an (markAnnotated bf) - --- --------------------------------------------------------------------- --- LocatedL instances end -- --- ===================================================================== - -instance ExactPrint (IE GhcPs) where - getAnnotationEntry (IEVar _ _) = NoEntryVal - getAnnotationEntry (IEThingAbs an _) = fromAnn an - getAnnotationEntry (IEThingAll an _) = fromAnn an - getAnnotationEntry (IEThingWith an _ _ _) = fromAnn an - getAnnotationEntry (IEModuleContents an _)= fromAnn an - getAnnotationEntry (IEGroup _ _ _) = NoEntryVal - getAnnotationEntry (IEDoc _ _) = NoEntryVal - getAnnotationEntry (IEDocNamed _ _) = NoEntryVal - - exact (IEVar _ ln) = markAnnotated ln - exact (IEThingAbs _ thing) = markAnnotated thing - exact (IEThingAll an thing) = do - markAnnotated thing - markEpAnn an AnnOpenP - markEpAnn an AnnDotdot - markEpAnn an AnnCloseP - - 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 (L lm mn)) = do - markEpAnn an AnnModule - printStringAtSs lm (moduleNameString mn) - - -- exact (IEGroup _ _ _) = NoEntryVal - -- exact (IEDoc _ _) = NoEntryVal - -- exact (IEDocNamed _ _) = NoEntryVal - exact x = error $ "missing match for IE:" ++ showAst x - --- --------------------------------------------------------------------- - -instance ExactPrint (IEWrappedName RdrName) where - getAnnotationEntry = const NoEntryVal - - exact (IEName n) = markAnnotated n - exact (IEPattern r n) = do - printStringAtAA r "pattern" - markAnnotated n - exact (IEType r n) = do - printStringAtAA r "type" - markAnnotated n - --- --------------------------------------------------------------------- - -instance ExactPrint (Pat GhcPs) where - getAnnotationEntry (WildPat _) = NoEntryVal - getAnnotationEntry (VarPat _ _) = NoEntryVal - getAnnotationEntry (LazyPat an _) = fromAnn an - getAnnotationEntry (AsPat an _ _) = fromAnn an - getAnnotationEntry (ParPat an _) = fromAnn an - getAnnotationEntry (BangPat an _) = fromAnn an - getAnnotationEntry (ListPat an _) = fromAnn an - getAnnotationEntry (TuplePat an _ _) = fromAnn an - getAnnotationEntry (SumPat an _ _ _) = fromAnn an - getAnnotationEntry (ConPat an _ _) = fromAnn an - getAnnotationEntry (ViewPat an _ _) = fromAnn an - getAnnotationEntry (SplicePat _ _) = NoEntryVal - getAnnotationEntry (LitPat _ _) = NoEntryVal - getAnnotationEntry (NPat an _ _ _) = fromAnn an - getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an - getAnnotationEntry (SigPat an _ _) = fromAnn an - - exact (WildPat _) = 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 - exact (LazyPat an pat) = do - markEpAnn an AnnTilde - markAnnotated pat - exact (AsPat an n pat) = do - markAnnotated n - markEpAnn an AnnAt - markAnnotated pat - exact (ParPat an pat) = do - markAnnKw an ap_open AnnOpenP - markAnnotated pat - markAnnKw an ap_close AnnCloseP - - exact (BangPat an pat) = do - markEpAnn an AnnBang - markAnnotated pat - - exact (ListPat an pats) = markAnnList True an (markAnnotated 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 - - -- | ConPat an con args) - exact (ConPat an con details) = exactUserCon 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 - - -- | NPlusKPat an n lit1 lit2 _ _) - exact (NPlusKPat an n k lit2 _ _) = do - markAnnotated n - -- We need a fix for - -- https://gitlab.haskell.org/ghc/ghc/-/issues/20243 to complete - -- this - markAnnotated k - - exact (SigPat an pat sig) = do - markAnnotated pat - markEpAnn an AnnDcolon - markAnnotated sig - -- exact x = error $ "missing match for Pat:" ++ showAst x - --- --------------------------------------------------------------------- - -instance ExactPrint (HsPatSigType GhcPs) where - getAnnotationEntry = const NoEntryVal - - exact (HsPS an ty) = do - markAnnKw an id AnnAt - markAnnotated ty - --- --------------------------------------------------------------------- - -instance ExactPrint (HsOverLit GhcPs) where - getAnnotationEntry = const NoEntryVal - - exact ol = - let str = case ol_val ol of - HsIntegral (IL src _ _) -> src - HsFractional (FL{ fl_text = src }) -> src - HsIsString src _ -> src - in - case str of - SourceText s -> printStringAdvance s - NoSourceText -> return () - --- --------------------------------------------------------------------- - -hsLit2String :: HsLit GhcPs -> String -hsLit2String lit = - case lit of - HsChar src v -> toSourceTextWithSuffix src v "" - -- It should be included here - -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 - HsCharPrim src p -> toSourceTextWithSuffix src p "#" - HsString src v -> toSourceTextWithSuffix src v "" - HsStringPrim src v -> toSourceTextWithSuffix src v "" - HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v "" - HsIntPrim src v -> toSourceTextWithSuffix src v "" - HsWordPrim src v -> toSourceTextWithSuffix src v "" - HsInt64Prim src v -> toSourceTextWithSuffix src v "" - HsWord64Prim src v -> toSourceTextWithSuffix src v "" - HsInteger src v _ -> toSourceTextWithSuffix src v "" - 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 -toSourceTextWithSuffix (SourceText txt) _alt suffix = txt ++ suffix - -sourceTextToString :: SourceText -> String -> String -sourceTextToString NoSourceText alt = alt -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 - - -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 - --- --------------------------------------------------------------------- - -entryFromLocatedA :: LocatedAn ann a -> Entry -entryFromLocatedA (L la _) = fromAnn la - --- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256 -entryFromLocatedAFixed :: LocatedL a -> Entry -entryFromLocatedAFixed (L la _) - = fromAnn (fixSrcAnnL la) - --- ===================================================================== --- Utility stuff --- --------------------------------------------------------------------- - --- |This should be the final point where things are mode concrete, --- before output. --- NOTE: despite the name, this is the ghc-exactprint final output for --- the PRINT phase. -printStringAtLsDelta :: (Monad m, Monoid w) => DeltaPos -> String -> EP w m () -printStringAtLsDelta cl s = do - p <- getPosP - colOffset <- getLayoutOffsetP - if isGoodDeltaWithOffset cl colOffset - then do - printStringAt (undelta p cl colOffset) s - `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s)) - else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s)) - --- --------------------------------------------------------------------- - -isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool -isGoodDeltaWithOffset dp colOffset = isGoodDelta (deltaPos l c) - where (l,c) = undelta (0,0) dp colOffset - -printQueuedComment :: (Monad m, Monoid w) => RealSrcSpan -> Comment -> DeltaPos -> EP w m () -printQueuedComment loc Comment{commentContents} dp = do - p <- getPosP - 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 - debugM $ "printQueuedComment: (p,p',dp,colOffset,undelta)=" ++ show (p,p',dp,colOffset,undelta p dp colOffset) - ------------------------------------------------------------------------- - -setLayoutBoth :: (Monad m, Monoid w) => EP w m () -> EP w m () -setLayoutBoth k = do - oldLHS <- gets dLHS - oldAnchorOffset <- getLayoutOffsetP - debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) - modify (\a -> a { dMarkLayout = True - , pMarkLayout = True } ) - let reset = do - debugM $ "setLayoutBoth:reset: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) - modify (\a -> a { dMarkLayout = False - , dLHS = oldLHS - , pMarkLayout = False - , pLHS = oldAnchorOffset} ) - k <* reset - --- Use 'local', designed for this -setLayoutTopLevelP :: (Monad m, Monoid w) => EP w m () -> EP w m () -setLayoutTopLevelP k = do - debugM $ "setLayoutTopLevelP entered" - oldAnchorOffset <- getLayoutOffsetP - modify (\a -> a { pMarkLayout = False - , pLHS = 0} ) - k - debugM $ "setLayoutTopLevelP:resetting" - setLayoutOffsetP oldAnchorOffset - ------------------------------------------------------------------------- - -getPosP :: (Monad m, Monoid w) => EP w m Pos -getPosP = gets epPos - -setPosP :: (Monad m, Monoid w) => Pos -> EP w m () -setPosP l = do - -- debugM $ "setPosP:" ++ show l - modify (\s -> s {epPos = l}) - -getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe Anchor) -getExtraDP = gets uExtraDP - -setExtraDP :: (Monad m, Monoid w) => Maybe Anchor -> EP w m () -setExtraDP md = do - debugM $ "setExtraDP:" ++ show md - modify (\s -> s {uExtraDP = md}) - -getPriorEndD :: (Monad m, Monoid w) => EP w m Pos -getPriorEndD = gets dPriorEndPosition - -getAnchorU :: (Monad m, Monoid w) => EP w m RealSrcSpan -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 - modify (\s -> s { dPriorEndPosition = pe }) - -setPriorEndASTD :: (Monad m, Monoid w) => Bool -> RealSrcSpan -> EP w m () -setPriorEndASTD layout pe = setPriorEndASTPD layout (rs2range pe) - -setPriorEndASTPD :: (Monad m, Monoid w) => Bool -> (Pos,Pos) -> EP w m () -setPriorEndASTPD layout pe@(fm,to) = do - debugM $ "setPriorEndASTD:pe=" ++ show pe - when layout $ setLayoutStartD (snd fm) - modify (\s -> s { dPriorEndPosition = to } ) - -setLayoutStartD :: (Monad m, Monoid w) => Int -> EP w m () -setLayoutStartD p = do - EPState{dMarkLayout} <- get - when dMarkLayout $ do - debugM $ "setLayoutStartD: setting dLHS=" ++ show p - modify (\s -> s { dMarkLayout = False - , dLHS = LayoutStartCol p}) - -setAnchorU :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () -setAnchorU rss = do - debugM $ "setAnchorU:" ++ show (rs2range rss) - modify (\s -> s { uAnchorSpan = rss }) - -getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment] -getUnallocatedComments = gets epComments - -putUnallocatedComments :: (Monad m, Monoid w) => [Comment] -> EP w m () -putUnallocatedComments cs = modify (\s -> s { epComments = cs } ) - -getLayoutOffsetP :: (Monad m, Monoid w) => EP w m LayoutStartCol -getLayoutOffsetP = gets pLHS - -setLayoutOffsetP :: (Monad m, Monoid w) => LayoutStartCol -> EP w m () -setLayoutOffsetP c = do - debugM $ "setLayoutOffsetP:" ++ show c - modify (\s -> s { pLHS = c }) - - --- --------------------------------------------------------------------- - -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) - --- --------------------------------------------------------------------- - -adjustDeltaForOffsetM :: DeltaPos -> EPP DeltaPos -adjustDeltaForOffsetM dp = do - colOffset <- gets dLHS - return (adjustDeltaForOffset 0 colOffset dp) - --- --------------------------------------------------------------------- --- Printing functions - -printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () -printString layout str = do - EPState{epPos = (_,c), pMarkLayout} <- get - PrintOptions{epTokenPrint, epWhitespacePrint} <- ask - when (pMarkLayout && layout) $ do - debugM $ "printString: setting pLHS to " ++ show c - modify (\s -> s { pLHS = LayoutStartCol c, pMarkLayout = False } ) - - -- Advance position, taking care of any newlines in the string - let strDP = dpFromString str - cr = getDeltaLine strDP - p <- getPosP - colOffset <- getLayoutOffsetP - -- 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) - - -- Debug stuff - -- pp <- getPosP - -- debugM $ "printString: (p,pp,str)" ++ show (p,pp,str) - -- Debug end - - -- - 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 str = do - ss <- getAnchorU - printStringAtKw' ss str - --------------------------------------------------------- - -newLine :: (Monad m, Monoid w) => EP w m () -newLine = do - (l,_) <- getPosP - printString False "\n" - setPosP (l+1,1) + , exactPrintWithOptions + , makeDeltaAst + + -- * Configuration + , EPOptions(epRigidity, epAstPrint, epTokenPrint, epWhitespacePrint, epUpdateAnchors) + , stringOptions + , epOptions + , deltaOptions + ) where + +import GHC +import GHC.Base (NonEmpty(..)) +import GHC.Core.Coercion.Axiom (Role(..)) +import GHC.Data.Bag +import qualified GHC.Data.BooleanFormula as BF +import GHC.Data.FastString +import GHC.Types.Basic hiding (EP) +import GHC.Types.Fixity +import GHC.Types.ForeignCall +import GHC.Types.SourceText +import GHC.Types.Var +import GHC.Utils.Outputable hiding ( (<>) ) +import GHC.Unit.Module.Warnings +import GHC.Utils.Misc +import GHC.Utils.Panic + +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.Ordered as OSet +import qualified Data.Set as Set +import Data.Typeable +import Data.List ( partition, sortBy) +import Data.Maybe ( isJust, mapMaybe ) + +import Data.Void + +import Language.Haskell.GHC.ExactPrint.Lookup +import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Types + +-- import Debug.Trace + +-- --------------------------------------------------------------------- + +exactPrint :: ExactPrint ast => ast -> String +exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast)) + +-- | 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) + +makeDeltaAst :: ExactPrint ast => ast -> ast +makeDeltaAst ast = fst $ runIdentity (runEP deltaOptions (markAnnotated ast)) + +------------------------------------------------------ + +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 + , pMarkLayout = False + , pLHS = 0 + , dMarkLayout = False + , dPriorEndPosition = (1,1) + , uAnchorSpan = badRealSrcSpan + , uExtraDP = Nothing + , epComments = [] + , epCommentsApplied = [] + } + + +-- --------------------------------------------------------------------- +-- The EP monad and basic combinators + +-- | The R part of RWS. The environment. Updated via 'local' as we +-- enter a new AST element, having a different anchor point. +data EPOptions m a = EPOptions + { + 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 'EPOptions' +epOptions :: + (forall ast . Data ast => GHC.Located ast -> a -> m a) + -> (String -> m a) + -> (String -> m a) + -> Rigidity + -> Bool + -> EPOptions m a +epOptions astPrint tokenPrint wsPrint rigidity delta = EPOptions + { + epAstPrint = astPrint + , epWhitespacePrint = wsPrint + , epTokenPrint = tokenPrint + , epRigidity = rigidity + , epUpdateAnchors = delta + } + +-- | Options which can be used to print as a normal String. +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 } + +instance Monoid w => Semigroup (EPWriter w) where + (EPWriter a) <> (EPWriter b) = EPWriter (a <> b) + +instance Monoid w => Monoid (EPWriter w) where + mempty = EPWriter mempty + +data EPState = EPState + { uAnchorSpan :: !RealSrcSpan -- ^ in pre-changed AST + -- reference frame, from + -- Annotation + , uExtraDP :: !(Maybe Anchor) -- ^ Used to anchor a + -- list + + -- Print phase + , epPos :: !Pos -- ^ Current output position + , pMarkLayout :: !Bool + , pLHS :: !LayoutStartCol + + -- Delta phase + , dPriorEndPosition :: !Pos -- ^ End of Position reached + -- when processing the + -- preceding element + , dMarkLayout :: !Bool + , dLHS :: !LayoutStartCol + + -- Shared + , epComments :: ![Comment] + , epCommentsApplied :: ![[Comment]] + } + +-- --------------------------------------------------------------------- + +-- AZ:TODO: this can just be a function :: (EpAnn a) -> Entry +class HasEntry ast where + fromAnn :: ast -> Entry + +-- --------------------------------------------------------------------- + +-- type Annotated = FreeT AnnotationF Identity +-- type Annotated a = EP w m a + +-- --------------------------------------------------------------------- + +-- | Key entry point. Switches to an independent AST element with its +-- own annotation, calculating new offsets, etc +markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a +markAnnotated a = enterAnn (getAnnotationEntry a) a + +-- | 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 + +-- | 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) = 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 + +-- --------------------------------------------------------------------- + +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 :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a +enterAnn NoEntryVal a = do + p <- getPosP + 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: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 + setPriorEndNoLayoutD (ss2pos curAnchor) + _ -> do + return () + -- ------------------------- + 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 ----------------------------------- + -- Calculate offset required to get to the start of the SrcSPan + off <- getLayoutOffsetD + let spanStart = ss2pos curAnchor + priorEndAfterComments <- getPriorEndD + let edp' = adjustDeltaForOffset + -- Use the propagated offset if one is set + -- Note that we need to use the new offset if it has + -- changed. + off (ss2delta priorEndAfterComments curAnchor) + debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor) + let edp'' = case anchor_op anchor' of + MovedAnchor dp -> dp + _ -> edp' + -- --------------------------------------------- + -- let edp = edp'' + med <- getExtraDP + setExtraDP Nothing + let edp = case med of + Nothing -> edp'' + Just (Anchor _ (MovedAnchor dp)) -> dp + -- Replace original with desired one. Allows all + -- list entry values to be DP (1,0) + Just (Anchor r _) -> dp + where + dp = adjustDeltaForOffset + off (ss2delta priorEndAfterComments r) + when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ show (med,edp) + -- --------------------------------------------- + -- Preparation complete, perform the action + when (priorEndAfterComments < spanStart) (do + debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart + modify (\s -> s { dPriorEndPosition = spanStart } )) + + debugM $ "enterAnn: (anchor_op, curAnchor):" ++ show (anchor_op anchor', rs2range curAnchor) + debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp) + p <- getPosP + d <- getPriorEndD + debugM $ "enterAnn: (posp, posd)=" ++ show (p,d) + + -- end of delta phase processing + -- ------------------------------------------------------------------- + -- start of print phase processing + + let mflush = when (flush == FlushComments) $ do + debugM $ "flushing comments in enterAnn" + flushComments (getFollowingComments cs) + + -- let + -- st = annNone + -- withOffset st (advance edp >> exact a >> mflush) +-- local :: (r -> r) -> RWST r w s m a -> RWST r w s m a + 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" + + 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' + -- let r = (setAnnotationAnchor a' newAchor (mkEpaComments [] postCs)) + pure () -- monadic action to flush debugM + -- 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 (p, astId a') + return r + +-- --------------------------------------------------------------------- + +-- withComments :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a) +-- withComments a = +-- local (\s -> s { epAnn = a, epContext = pushAcs (epContext s) }) + + +-- --------------------------------------------------------------------- + +addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () +addCommentsA csNew = addComments (map tokComment csNew) + +{- +TODO: When we addComments, some may have an anchor that is no longer +valid, as it has been moved and has an anchor_op. + +Does an Anchor even make sense for a comment, perhaps it should be an +EpaLocation? + +How do we sort them? do we assign a location based on when we add them +to the list, based on the current output pos? Except the offset is a +delta compared to a reference location. Need to nail the concept of +the reference location. + +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 :: (Monad m, Monoid w) => [Comment] -> EP w m () +addComments csNew = do + -- debugM $ "addComments:" ++ show csNew + cs <- getUnallocatedComments + -- Make sure we merge duplicates while sorting, needed until + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20239 is resolved + let ocs = OSet.fromList cs + let ncs = OSet.fromList csNew + putUnallocatedComments (OSet.toAscList (ocs OSet.<>| ncs)) + + +-- --------------------------------------------------------------------- + +-- | Just before we print out the EOF comments, flush the remaining +-- ones in the state. +flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () +flushComments trailing = do + addCommentsA trailing + cs <- getUnallocatedComments + debugM $ "flushing comments starting" + mapM_ printOneComment (sortComments cs) + debugM $ "flushing comments done" + +-- --------------------------------------------------------------------- + +-- |In order to interleave annotations into the stream, we turn them into +-- 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 + + 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 + + +-- -- |In order to interleave annotations into the stream, we turn them into +-- -- comments. +-- annotationsToComments' :: (Monad m, Monoid w) => [AddEpAnn] -> [AnnKeywordId] -> EP w m () +-- annotationsToComments' ans kws = do +-- let +-- getSpans _ [] = [] +-- getSpans k1 (AddEpAnn k2 ss:as) +-- | k1 == k2 = ss : getSpans k1 as +-- | otherwise = getSpans k1 as +-- doOne :: (Monad m, Monoid w) => AnnKeywordId -> EP w m [Comment] +-- doOne kw = do +-- let sps =getSpans kw ans +-- return $ map (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) + +-- annotationsToCommentsA :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> [AnnKeywordId] -> EP w m () +-- annotationsToCommentsA EpAnnNotUsed _ = return () +-- annotationsToCommentsA an kws = annotationsToComments' (anns an) kws + +-- --------------------------------------------------------------------- + +-- Temporary function to simply reproduce the "normal" pretty printer output +withPpr :: (Monad m, Monoid w, Outputable a) => a -> EP w m a +withPpr a = do + ss <- getAnchorU + debugM $ "withPpr: ss=" ++ show ss + printStringAtRs' ss (showPprUnsafe a) + return a + +-- --------------------------------------------------------------------- + +-- | An AST fragment with an annotation must be able to return the +-- requirements for nesting another one, captured in an 'Entry', and +-- to be able to use the rest of the exactprint machinery to print the +-- element. In the analogy to Outputable, 'exact' plays the role of +-- 'ppr'. +class (Typeable a) => ExactPrint a where + getAnnotationEntry :: a -> Entry + setAnnotationAnchor :: a -> Anchor -> EpAnnComments -> a + exact :: (Monad m, Monoid w) => a -> EP w m a + +-- --------------------------------------------------------------------- +-- Start of utility functions +-- --------------------------------------------------------------------- + +printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m () +printSourceText (NoSourceText) txt = printStringAdvance txt >> return () +printSourceText (SourceText txt) _ = printStringAdvance txt >> return () + +-- --------------------------------------------------------------------- + +printStringAtSs :: (Monad m, Monoid w) => SrcSpan -> String -> EP w m () +printStringAtSs ss str = printStringAtRs (realSrcSpan ss) str >> return () + +printStringAtRs :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m EpaLocation +printStringAtRs pa str = printStringAtRsC CaptureComments pa str + +printStringAtRsC :: (Monad m, Monoid w) + => CaptureComments -> RealSrcSpan -> String -> EP w m EpaLocation +printStringAtRsC capture pa str = do + printComments pa + pe <- getPriorEndD + debugM $ "printStringAtRs:pe=" ++ show pe + let p = ss2delta pe pa + p' <- adjustDeltaForOffsetM p + printStringAtLsDelta p' str + setPriorEndASTD True pa + cs' <- case capture of + CaptureComments -> takeAppliedComments + NoCaptureComments -> return [] + debugM $ "printStringAtRs:cs'=" ++ show cs' + -- return (EpaDelta p' (map comment2LEpaComment (noKWComments 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 () + +-- --------------------------------------------------------------------- + +-- AZ:TODO get rid of this +printStringAtMLoc :: (Monad m, Monoid w) => Maybe EpaLocation -> String -> EP w m () +printStringAtMLoc (Just aa) s = printStringAtAA aa s >> return () +printStringAtMLoc Nothing s = printStringAtLsDelta (SameLine 1) s >> 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 (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 (noKWComments 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 () + +-- --------------------------------------------------------------------- + +-- -- TODO: remove in favour of markLensMAA +-- markLocatedMAA :: (Monad m, Monoid w) => EpAnn a -> (a -> Maybe AddEpAnn) -> EP w m () +-- markLocatedMAA EpAnnNotUsed _ = return () +-- markLocatedMAA (EpAnn _ a _) f = +-- case f a of +-- Nothing -> return () +-- Just aa -> markAddEpAnn aa >> 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) + + +-- TODO: removein favour of markEpAnnL +markLocatedAAL :: (Monad m, Monoid w) => EpAnn a -> (a -> [AddEpAnn]) -> AnnKeywordId -> EP w m Int +markLocatedAAL EpAnnNotUsed _ _ = return 1 +markLocatedAAL (EpAnn _ a _) f kw = go (f a) + where + go [] = return 1 + go (aa@(AddEpAnn kw' _):as) + | kw' == kw = mark [aa] kw + | otherwise = go as + + +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) + +-- --------------------------------------------------------------------- + +markArrow :: (Monad m, Monoid w) + => EpAnn TrailingAnn -> HsArrow GhcPs -> EP w m (EpAnn TrailingAnn, HsArrow GhcPs) +markArrow an arr = do + arr' <- + case arr of + HsUnrestrictedArrow _u -> + return arr + HsLinearArrow u ma -> do + ma' <- mapM markAddEpAnn ma + return (HsLinearArrow u ma') + HsExplicitMult u ma t -> do + ma' <- mapM markAddEpAnn ma + t' <- markAnnotated t + return (HsExplicitMult u ma' t') + + an' <- case an of + EpAnnNotUsed -> pure EpAnnNotUsed + EpAnn anc a cs -> do + a' <- markKwT a + return (EpAnn anc a' cs) + return (an', arr') + +-- --------------------------------------------------------------------- + +markAnnCloseP :: (Monad m, Monoid w) => EpAnn AnnPragma -> EP w m (EpAnn AnnPragma) +markAnnCloseP an = markEpAnnLMS' an lapr_close AnnClose (Just "#-}") + +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) + +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) + +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 + +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) +-- markParen' :: (Monad m, Monoid w) => EpAnn AnnParen -> (forall a. (a,a) -> a) -> EP w m (EpAnn AnnParen) +-- markParen' EpAnnNotUsed _ = return (EpAnnNotUsed) +-- markParen' (EpAnn anc (AnnParen pt o c) cs) f = do +-- markKwA (f $ kw pt) (f (o, c)) +-- return (EpAnn anc (AnnParen pt o c) cs) +-- where +-- kw AnnParens = (AnnOpenP, AnnCloseP) +-- kw AnnParensHash = (AnnOpenPH, AnnClosePH) +-- kw AnnParensSquare = (AnnOpenS, AnnCloseS) + +-- --------------------------------------------------------------------- +-- Bare bones Optics +-- Base on From https://hackage.haskell.org/package/lens-tutorial-1.0.3/docs/Control-Lens-Tutorial.html + +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) + +view :: MonadReader s m => Getting s a -> m a +-- view l = Reader.asks (getConst #. l Const) +view l = Reader.asks (getConst . l Const) +{-# INLINE view #-} + +over :: ASetter a b -> (b -> b) -> (a -> a) +-- over l f = runIdentity #. l (Identity #. f) +over l f = runIdentity . l (Identity . f) +{-# INLINE over #-} + +set :: Lens a b -> b -> a -> a +set lens b = over lens (\_ -> b) +{-# INLINE set #-} + +{- +Question: How do I combine lenses? + +Answer: You compose them, using function composition (Yes, really!) + +You can think of the function composition operator as having this type: + +(.) :: Lens' a b -> Lens' b c -> Lens' a c +-} + +-- --------------------------------------------------------------------- +-- Lenses + +lalLet :: Lens AnnsLet EpaLocation +lalLet k annsLet = fmap (\newLoc -> annsLet { alLet = newLoc }) + (k (alLet annsLet)) + +lalIn :: Lens AnnsLet EpaLocation +lalIn k annsLet = fmap (\newLoc -> annsLet { alIn = newLoc }) + (k (alIn annsLet)) +-- data AnnsModule +-- = AnnsModule { +-- am_main :: [AddEpAnn], +-- am_decls :: AnnList +-- } deriving (Data, Eq) + +lam_main :: Lens AnnsModule [AddEpAnn] +lam_main k annsModule = fmap (\newAnns -> annsModule { am_main = newAnns }) + (k (am_main annsModule)) + +-- lam_decls :: Lens AnnsModule AnnList +-- lam_decls k annsModule = fmap (\newAnns -> annsModule { am_decls = newAnns }) +-- (k (am_decls annsModule)) + + +-- data EpAnnImportDecl = EpAnnImportDecl +-- { importDeclAnnImport :: EpaLocation +-- , importDeclAnnPragma :: Maybe (EpaLocation, EpaLocation) +-- , importDeclAnnSafe :: Maybe EpaLocation +-- , importDeclAnnQualified :: Maybe EpaLocation +-- , importDeclAnnPackage :: Maybe EpaLocation +-- , importDeclAnnAs :: Maybe EpaLocation +-- } deriving (Data) + +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)) + +limportDeclAnnSafe :: Lens EpAnnImportDecl (Maybe EpaLocation) +limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new }) + (k (importDeclAnnSafe annImp)) + +limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe EpaLocation) +limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new }) + (k (importDeclAnnQualified annImp)) + +limportDeclAnnPackage :: Lens EpAnnImportDecl (Maybe EpaLocation) +limportDeclAnnPackage k annImp = fmap (\new -> annImp { importDeclAnnPackage = new }) + (k (importDeclAnnPackage annImp)) + +-- limportDeclAnnAs :: Lens EpAnnImportDecl (Maybe EpaLocation) +-- limportDeclAnnAs k annImp = fmap (\new -> annImp { importDeclAnnAs = new }) +-- (k (importDeclAnnAs annImp)) + +-- ------------------------------------- + +-- 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)) + +-- ------------------------------------- + +lapr_rest :: Lens AnnPragma [AddEpAnn] +lapr_rest k parent = fmap (\newAnns -> parent { apr_rest = newAnns }) + (k (apr_rest parent)) + +lapr_open :: Lens AnnPragma AddEpAnn +lapr_open k parent = fmap (\new -> parent { apr_open = new }) + (k (apr_open parent)) + +lapr_close :: Lens AnnPragma AddEpAnn +lapr_close k parent = fmap (\new -> parent { apr_close = new }) + (k (apr_close parent)) + +lidl :: Lens [AddEpAnn] [AddEpAnn] +lidl k parent = fmap (\new -> new) + (k parent) + +lid :: Lens a a +lid k parent = fmap (\new -> new) + (k parent) + +lfst :: Lens (a,a) a +lfst k parent = fmap (\new -> (new, snd parent)) + (k (fst parent)) + +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)) + +-- ------------------------------------- +-- data AnnFieldLabel +-- = AnnFieldLabel { +-- afDot :: Maybe EpaLocation +-- } deriving Data + +lafDot :: Lens AnnFieldLabel (Maybe EpaLocation) +lafDot k parent = fmap (\new -> parent { afDot = new }) + (k (afDot parent)) + +-- ------------------------------------- +-- data AnnProjection +-- = AnnProjection { +-- apOpen :: EpaLocation, -- ^ '(' +-- apClose :: EpaLocation -- ^ ')' +-- } deriving Data + +lapOpen :: Lens AnnProjection EpaLocation +lapOpen k parent = fmap (\new -> parent { apOpen = new }) + (k (apOpen parent)) + +lapClose :: Lens AnnProjection EpaLocation +lapClose k parent = fmap (\new -> parent { apClose = new }) + (k (apClose parent)) + +-- ------------------------------------- +-- 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)) + +-- ------------------------------------- + +-- 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)) + +lap_close :: Lens AnnParen EpaLocation +lap_close k parent = fmap (\new -> parent { ap_close = new }) + (k (ap_close parent)) + +-- ------------------------------------- +-- 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) + + +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" + +lff :: Lens (Maybe (a,b)) (Maybe a,Maybe b) +lff k parent = fmap (\new -> gg new) + (k (ff parent)) + +-- (.) :: 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)) + + +-- --------------------------------------------------------------------- +-- data GrhsAnn +-- = GrhsAnn { +-- ga_vbar :: Maybe EpaLocation, -- TODO:AZ do we need this? +-- ga_sep :: AddEpAnn -- ^ Match separator location +-- } deriving (Data) + +lga_vbar :: Lens GrhsAnn (Maybe EpaLocation) +lga_vbar k parent = fmap (\new -> parent { ga_vbar = new }) + (k (ga_vbar parent)) + +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)) + +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 _ a _) f kw = mapM_ (markKwA kw) (sort (f a)) +markAnnKwAllL (EpAnn anc a cs) l kw = do + -- anns <- mapM (markKwA kw) (sort (view l a)) + 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) + +-- Deprecate in favour of markEpAnnL +markEpAnn :: (Monad m, Monoid w) + => EpAnn [AddEpAnn] -> AnnKeywordId -> EP w m Int -- Return something to trigger not used warning +markEpAnn EpAnnNotUsed _ = return 1 +markEpAnn (EpAnn _ a _) kw = mark a kw >> return 1 + +-- -- Deprecate in favour of markEpAnnL +-- markEpAnn' :: (Monad m, Monoid w) +-- => EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EP w m () +-- markEpAnn' EpAnnNotUsed _ _ = return () +-- markEpAnn' (EpAnn _anc a _cs) f kw = mark' (f a) kw >> return () + +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 Int +mark anns kw = do + case find (\(AddEpAnn k _) -> k == kw) anns of + Just aa -> markKw aa >> return 1 + Nothing -> case find (\(AddEpAnn k _) -> k == (unicodeAnn kw)) anns of + Just aau -> markKw aau >> return 1 + Nothing -> return 1 + +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 +markKwT (AddRarrowAnn ss) = AddRarrowAnn <$> markKwA AnnRarrow ss +markKwT (AddRarrowAnnU ss) = AddRarrowAnnU <$> markKwA AnnRarrowU ss +markKwT (AddLollyAnnU ss) = AddLollyAnnU <$> markKwA AnnLollyU 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 :: (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 + _ -> do + pe <- getPriorEndD + let dp = ss2delta pe (anchor loc) + debugM $ "printOneComment:(dp,pe,anchor loc)=" ++ showGhc (dp,pe,ss2pos $ anchor loc) + adjustDeltaForOffsetM dp + mep <- getExtraDP + dp' <- case mep of + Just (Anchor _ (MovedAnchor edp)) -> do + debugM $ "printOneComment:edp=" ++ show edp + 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' + +updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () +updateAndApplyComment co@(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 = MovedAnchor dp } + anc' = anc { anchor_op = op} + + (r,c) = ss2posEnd pp + la = anchor anc + dp'' = if r == 0 + then (ss2delta (r,c+1) 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 _r _mo) -> (ss2pos $ anchor loc) <= (ss2pos ss)) cs + putUnallocatedComments later + -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) + return earlier + +-- --------------------------------------------------------------------- + +markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast +markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a + +-- --------------------------------------------------------------------- + +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 _) = Entry (spanAsAnchor l) emptyComments NoFlushComments NoCanUpdateAnchor + getAnnotationEntry (L l _) = case l of + UnhelpfulSpan _ -> NoEntryVal + _ -> Entry (hackSrcSpanToAnchor l) emptyComments NoFlushComments CanUpdateAnchorOnly + -- getAnnotationEntry (L l _) = NoEntryVal + + -- setAnnotationAnchor _la _anc _cs = error "should not be called:setAnnotationAnchor (Located a)" + setAnnotationAnchor (L _ a) anc _cs = L (hackAnchorToSrcSpan anc) a + + 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 [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 where + getAnnotationEntry hsmod = fromAnn' (hsmodAnn 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 EpAnnNotUsed _ _ _ _ _ _ _) = withPpr hsmod >> return hsmod + exact (HsModule an lo mmn mexports imports decls mdeprec mbDoc) = do + + debugM "HsModule Entered" + + 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 + + debugM $ "HsModule.AnnWhere coming" + an1 <- setLayoutTopLevelP $ markEpAnnL an0 lam_main AnnWhere + debugM $ "HsModule.AnnWhere done, an1=" ++ showAst (anns an1) + + return (an1, Just m', mdeprec', mexports') + + -- debugM $ "After HsModule.AnnWhere done, an0=" ++ showAst (anns an0) + 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 anf lo mmn' mexports' imports' decls' mdeprec' mbDoc') + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP WarningTxt) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + + 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 (ideclExt idecl) + setAnnotationAnchor idecl anc cs = idecl { ideclExt = setAnchorEpa (ideclExt idecl) anc cs } + + exact x@(ImportDecl EpAnnNotUsed _ _ _ _ _ _ _ _ _) = withPpr x + exact (ImportDecl ann msrc m mpkg src safeflag qualFlag impl mAs hiding) = do + + ann0 <- markLensKw ann limportDeclAnnImport AnnImport + let (EpAnn _anc an _cs) = ann0 + + -- "{-# SOURCE" and "#-}" + 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" + printStringAtMLoc Nothing "#-}" + 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 + Just (StringLiteral src' v _) -> + printStringAtMLocL ann2 limportDeclAnnPackage (sourceTextToString src' (show v)) + _ -> return ann2 + + m' <- markAnnotated m + + 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 (EpAnn anc' an2 cs') msrc m' mpkg src safeflag qualFlag impl mAs' hiding') + + +-- --------------------------------------------------------------------- + +instance ExactPrint HsDocString where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ = a + exact = withPpr -- TODO:AZ use annotations + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsDecl GhcPs) where + getAnnotationEntry (TyClD _ _) = NoEntryVal + getAnnotationEntry (InstD _ _) = NoEntryVal + getAnnotationEntry (DerivD _ _) = NoEntryVal + getAnnotationEntry (ValD _ _) = NoEntryVal + getAnnotationEntry (SigD _ _) = NoEntryVal + getAnnotationEntry (KindSigD _ _) = NoEntryVal + getAnnotationEntry (DefD _ _) = NoEntryVal + getAnnotationEntry (ForD _ _) = NoEntryVal + getAnnotationEntry (WarningD _ _) = NoEntryVal + getAnnotationEntry (AnnD _ _) = NoEntryVal + getAnnotationEntry (RuleD _ _) = NoEntryVal + getAnnotationEntry (SpliceD _ _) = NoEntryVal + getAnnotationEntry (DocD _ _) = NoEntryVal + getAnnotationEntry (RoleAnnotD _ _) = NoEntryVal + + -- 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 + +-- --------------------------------------------------------------------- + +instance ExactPrint (InstDecl GhcPs) where + getAnnotationEntry (ClsInstD _ _) = NoEntryVal + getAnnotationEntry (DataFamInstD an _) = fromAnn an + getAnnotationEntry (TyFamInstD _ _) = NoEntryVal + + setAnnotationAnchor (DataFamInstD an d) anc cs = DataFamInstD (setAnchorEpa an anc cs) d + setAnnotationAnchor d _ _ = d + + + exact (ClsInstD a cid) = do + cid' <- markAnnotated cid + return (ClsInstD a cid') + exact (DataFamInstD an decl) = do + d' <- markAnnotated (DataFamInstDeclWithContext an TopLevel decl) + return (DataFamInstD an (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 :: (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 })) = do + (an', an2', tycon', bndrs', _, _mc, defn') <- exactDataDefn an2 pp_hdr defn + 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 + 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The exactDataFamInstDecl function is called to render a +DataFamInstDecl within its surrounding context. This context is +rendered via the 'pp_hdr' function, which uses the exact print +annotations from that context, named 'an'. The EPAs used for +rendering the DataDefn are contained in the FamEqn, and are called +'an2'. + +-} + +-- --------------------------------------------------------------------- + +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 + 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') + +-- --------------------------------------------------------------------- + +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 + an0 <- markEpAnnL an lidl AnnForeign + an1 <- markEpAnnL an0 lidl AnnImport + + fimport' <- markAnnotated fimport + + n' <- markAnnotated n + an2 <- markEpAnnL an1 lidl AnnDcolon + ty' <- markAnnotated ty + return (ForeignImport an2 n' ty' fimport') + + exact (ForeignExport an n ty fexport) = do + 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 where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + exact (CImport cconv safety@(L ll _) mh imp (L ls src)) = do + cconv' <- markAnnotated cconv + unless (ll == noSrcSpan) $ markAnnotated safety >> return () + unless (ls == noSrcSpan) $ markExternalSourceText ls src "" >> return () + return (CImport cconv' safety mh imp (L ls src)) + +-- --------------------------------------------------------------------- + +instance ExactPrint ForeignExport where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + exact (CExport spec (L ls src)) = do + debugM $ "CExport starting" + spec' <- markAnnotated spec + unless (ls == noSrcSpan) $ markExternalSourceText ls src "" + return (CExport spec' (L ls src)) + +-- --------------------------------------------------------------------- + +instance ExactPrint CExportSpec where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + exact (CExportStatic st lbl cconv) = do + debugM $ "CExportStatic starting" + 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 + 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 + 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 l@(StringLiteral src fs mcomma) = do + printSourceText src (show (unpackFS fs)) + 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) >> 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 + 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 anc cs = r { rd_ext = setAnchorEpa (rd_ext r) anc cs} + exact (HsRule an ln act mtybndrs termbndrs lhs rhs) = do + debugM "HsRule entered" + ln' <- markAnnotated ln + debugM "HsRule after ln" + an0 <- markActivation an lra_rest act + debugM "HsRule after act" + (an1, mtybndrs') <- + case mtybndrs of + Nothing -> return (an0, Nothing) + Just bndrs -> do + -- an1 <- markLensMAA an0 (\a -> fmap fst (ra_tyanns a)) -- AnnForall + an1 <- markLensMAA an0 lra_tyanns_fst -- AnnForall + bndrs' <- mapM markAnnotated bndrs + -- an2 <- markLensMAA an1 (\a -> fmap snd (ra_tyanns a)) -- AnnDot + an2 <- markLensMAA an1 lra_tyanns_snd -- AnnDot + return (an2, Just bndrs') + + -- an2 <- markLensMAA an1 (\a -> fmap fst (ra_tmanns a)) -- AnnForall + an2 <- markLensMAA an1 lra_tmanns_fst -- AnnForall + termbndrs' <- mapM markAnnotated termbndrs + -- an3 <- markLensMAA an2 (\a -> fmap snd (ra_tmanns a)) -- AnnDot + an3 <- markLensMAA an2 lra_tmanns_snd -- AnnDot + + lhs' <- markAnnotated lhs + an4 <- markEpAnnL an3 lra_rest AnnEqual + rhs' <- markAnnotated rhs + return (HsRule an4 ln' 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 + 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 + an0 <- markEpAnnL an l AnnOpenS -- '[' + an1 <- markEpAnnLMS an0 l AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) + an2 <- markEpAnnL an1 l AnnCloseS -- ']' + return an2 + NeverActive -> do + 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 x splice flag) = do + splice' <- markAnnotated splice + return (SpliceDecl x splice' flag) + +-- --------------------------------------------------------------------- + +instance ExactPrint DocDecl where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + + exact v = + let str = + case v of + (DocCommentNext ds) -> unpackHDS ds + (DocCommentPrev ds) -> unpackHDS ds + (DocCommentNamed _s ds) -> unpackHDS ds + (DocGroup _i ds) -> unpackHDS ds + in + printStringAdvance str >> return v + +-- --------------------------------------------------------------------- + +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 + 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 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 + + 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 + (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 :: + (Monad m, Monoid w) + => EpAnn [AddEpAnn] + -> LocatedN RdrName + -> HsOuterTyVarBndrs () GhcPs + -> HsTyPats GhcPs + -> LexicalFixity + -> Maybe (LHsContext GhcPs) + -> EP w m ( EpAnn [AddEpAnn] + , LocatedN RdrName + , HsOuterTyVarBndrs () GhcPs + , HsTyPats GhcPs, Maybe (LHsContext GhcPs)) +exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do + 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 :: (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 + 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 + (an0, thing', p) <- exact_op_app + pats' <- mapM markAnnotated pats + return (an0, thing', p++pats') + + 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 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 }) + = do + (an0, mbOverlap', inst_ty') <- top_matter + -- an0 <- markEpAnnL an' lidl AnnWhere + an1 <- markEpAnnL an0 lidl AnnOpenC + an2 <- markEpAnnAllL an1 lid AnnSemi + ds <- withSortKey sortKey + (prepareListAnnotationA ats + ++ prepareListAnnotationF an adts + ++ prepareListAnnotationA (bagToList binds) + ++ prepareListAnnotationA sigs + ) + 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 + 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 + setAnnotationAnchor (TyFamInstDecl an a) anc cs = TyFamInstDecl (setAnchorEpa an anc cs) a + + 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 l) (NoOverlap src)) = do + an0 <- markAnnOpenP an src "{-# NO_OVERLAP" + an1 <- markAnnCloseP an0 + return (L (SrcSpanAnn an1 l) (NoOverlap src)) + + 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 l) (Overlapping src)) = do + an0 <- markAnnOpenP an src "{-# OVERLAPPING" + an1 <- markAnnCloseP an0 + return (L (SrcSpanAnn an1 l) (Overlapping src)) + + 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 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{pat_ext=an} = fromAnn an + getAnnotationEntry VarBind{} = NoEntryVal + getAnnotationEntry AbsBinds{} = NoEntryVal + getAnnotationEntry PatSynBind{} = NoEntryVal + + setAnnotationAnchor pb@PatBind{} anc cs = pb { pat_ext = setAnchorEpa (pat_ext pb) anc cs} + setAnnotationAnchor a _ _ = a + + exact (FunBind x fid matches t) = 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' t) + exact (PatBind x pat grhss t) = do + pat' <- markAnnotated pat + grhss' <- markAnnotated grhss + return (PatBind x pat' grhss' t) + exact (PatSynBind x bind) = do + bind' <- markAnnotated bind + return (PatSynBind x bind') + + exact x = error $ "HsBind: exact for " ++ showAst x + +-- --------------------------------------------------------------------- + +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 + 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 + 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 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 an mctxt pats grhss) = + exactMatch (Match an mctxt pats grhss) + +-- --------------------------------------------------------------------- + +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 + + debugM $ "exact Match entered" + + (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') + _ -> 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 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 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') + +-- --------------------------------------------------------------------- + +-- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/20247 +-- is fixed +fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList +fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed +fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs) + = (EpAnn (widenAnchor anchor (map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs) + + +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256 +fixAnnListAnn :: EpAnn AnnList -> EpAnn AnnList +fixAnnListAnn EpAnnNotUsed = EpAnnNotUsed +fixAnnListAnn (EpAnn anchor (AnnList ma o c r t) cs) + = (EpAnn (widenAnchor anchor r) (AnnList ma o c r t) cs) + +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256 +fixSrcAnnL :: SrcSpanAnnL -> SrcSpanAnnL +fixSrcAnnL (SrcSpanAnn an l) = SrcSpanAnn (fixAnnListAnn an) l + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsLocalBinds GhcPs) where + getAnnotationEntry (HsValBinds an _) = fromAnn (fixValbindsAnn an) + 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 + let an = fixValbindsAnn an' + debugM $ "exact HsValBinds: an=" ++ showAst an + an0 <- markEpAnnL an lal_rest AnnWhere + + let manc = case an of + EpAnnNotUsed -> Nothing + _ -> al_anchor $ anns an + + case manc of + Just anc -> do + when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc) + _ -> return () + + (an1, valbinds') <- markAnnList False an0 $ markAnnotatedWithLayout valbinds + debugM $ "exact HsValBinds: an1=" ++ showAst an1 + return (HsValBinds an1 valbinds') + + exact (HsIPBinds an bs) = do + (as, ipb) <- markAnnList True an (markLocatedAAL an al_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 + 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 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 (Left lr) rhs) = do + lr' <- markAnnotated lr + an0 <- markEpAnnL an lidl AnnEqual + rhs' <- markAnnotated rhs + return (IPBind an0 (Left lr') rhs') + + exact (IPBind _ (Right _) _) = error $ "ExactPrint IPBind: Right only after typechecker" + +-- --------------------------------------------------------------------- + +instance ExactPrint HsIPName where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + + exact i@(HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs)) >> return i + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + +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 TopLevel a) + d' <- markAnnotated (DataFamInstDeclWithContext an NotTopLevel a) + return (toDyn (L l (dc_d d'))) + +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 :: (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 + NoAnnSortKey -> sortBy orderByFst xs + -- Just keys -> error $ "withSortKey: keys" ++ show keys + AnnSortKey keys -> orderByKey xs keys + -- `debug` ("withSortKey:" ++ + -- showPprUnsafe (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs), + -- map fst xs, + -- keys) + -- ) + mapM snd ordered + +orderByFst :: Ord a => (a, b1) -> (a, b2) -> Ordering +orderByFst (a,_) (b,_) = compare a b + +-- --------------------------------------------------------------------- + +instance ExactPrint (Sig GhcPs) where + getAnnotationEntry (TypeSig a _ _) = fromAnn a + getAnnotationEntry (PatSynSig a _ _) = fromAnn a + getAnnotationEntry (ClassOpSig a _ _ _) = fromAnn a + getAnnotationEntry (IdSig {}) = NoEntryVal + getAnnotationEntry (FixSig a _) = fromAnn a + getAnnotationEntry (InlineSig a _ _) = fromAnn a + getAnnotationEntry (SpecSig a _ _ _) = fromAnn a + getAnnotationEntry (SpecInstSig a _ _) = fromAnn a + getAnnotationEntry (MinimalSig a _ _) = fromAnn a + getAnnotationEntry (SCCFunSig a _ _ _) = fromAnn a + getAnnotationEntry (CompleteMatchSig a _ _ _) = fromAnn a + + 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 i@(IdSig {}) _ _s = i + 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 + 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 = 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" + 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 + 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 + an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}") + debugM $ "InlineSig:done" + return (InlineSig an2 ln' inl) + + exact (SpecSig an ln typs inl) = do + 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') + + exact x = error $ "exact Sig for:" ++ showAst x + +-- --------------------------------------------------------------------- + +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 + vars' <- mapM markAnnotated vars + an0 <- markLensAA an lasDcolon + ty' <- markAnnotated ty + return (an0, vars', ty') + +-- --------------------------------------------------------------------- + +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 + 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 + 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 + 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 + x' <- markAnnotated x + return (BF.Var x') + exact (BF.Or ls) = do + ls' <- markAnnotated ls + return (BF.Or ls') + exact (BF.And ls) = do + ls' <- markAnnotated ls + return (BF.And ls') + exact (BF.Parens x) = do + x' <- markAnnotated x + return (BF.Parens x') + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where + getAnnotationEntry = const NoEntryVal + 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) + an0 <- markLensKwM an lga_vbar AnnVbar + guards' <- markAnnotated guards + debugM $ "GRHS before matchSeparator" + an1 <- markLensAA an0 lga_sep -- Mark the matchSeparator for these GRHSs + debugM $ "GRHS after matchSeparator" + 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 + 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') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsExpr GhcPs) where + getAnnotationEntry (HsVar{}) = NoEntryVal + getAnnotationEntry (HsUnboundVar an _) = fromAnn an + getAnnotationEntry (HsConLikeOut{}) = NoEntryVal + getAnnotationEntry (HsRecFld{}) = NoEntryVal + getAnnotationEntry (HsOverLabel an _) = fromAnn an + getAnnotationEntry (HsIPVar an _) = fromAnn an + getAnnotationEntry (HsOverLit an _) = fromAnn an + getAnnotationEntry (HsLit an _) = fromAnn an + getAnnotationEntry (HsLam _ _) = NoEntryVal + getAnnotationEntry (HsLamCase an _) = fromAnn an + getAnnotationEntry (HsApp an _ _) = fromAnn an + getAnnotationEntry (HsAppType _ _ _) = NoEntryVal + getAnnotationEntry (OpApp an _ _ _) = fromAnn an + getAnnotationEntry (NegApp an _ _) = fromAnn an + getAnnotationEntry (HsPar an _) = fromAnn an + getAnnotationEntry (SectionL an _ _) = fromAnn an + getAnnotationEntry (SectionR an _ _) = fromAnn an + getAnnotationEntry (ExplicitTuple an _ _) = fromAnn an + getAnnotationEntry (ExplicitSum an _ _ _) = fromAnn an + getAnnotationEntry (HsCase an _ _) = fromAnn an + getAnnotationEntry (HsIf an _ _ _) = fromAnn an + getAnnotationEntry (HsMultiIf an _) = fromAnn an + getAnnotationEntry (HsLet an _ _) = fromAnn an + getAnnotationEntry (HsDo an _ _) = fromAnn an + getAnnotationEntry (ExplicitList an _) = fromAnn an + getAnnotationEntry (RecordCon an _ _) = fromAnn an + getAnnotationEntry (RecordUpd an _ _) = fromAnn an + getAnnotationEntry (HsGetField an _ _) = fromAnn an + getAnnotationEntry (HsProjection an _) = fromAnn an + getAnnotationEntry (ExprWithTySig an _ _) = fromAnn an + getAnnotationEntry (ArithSeq an _ _) = fromAnn an + getAnnotationEntry (HsBracket an _) = fromAnn an + getAnnotationEntry (HsRnBracketOut{}) = NoEntryVal + getAnnotationEntry (HsTcBracketOut{}) = NoEntryVal + getAnnotationEntry (HsSpliceE an _) = fromAnn an + getAnnotationEntry (HsProc an _ _) = fromAnn an + getAnnotationEntry (HsStatic an _) = fromAnn an + getAnnotationEntry (HsTick {}) = NoEntryVal + getAnnotationEntry (HsBinTick {}) = NoEntryVal + getAnnotationEntry (HsPragE{}) = NoEntryVal + + setAnnotationAnchor a@(HsVar{}) _ _s = a + setAnnotationAnchor (HsUnboundVar an a) anc cs = (HsUnboundVar (setAnchorEpa an anc cs) a) + setAnnotationAnchor a@(HsConLikeOut{}) _ _s = a + setAnnotationAnchor a@(HsRecFld{}) _ _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) anc cs = (HsLamCase (setAnchorEpa an anc cs) a) + 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) anc cs = (HsPar (setAnchorEpa an anc cs) a) + 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) anc cs = (HsLet (setAnchorEpa an anc cs) a b) + 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 (HsBracket an a) anc cs = (HsBracket (setAnchorEpa an anc cs) a) + setAnnotationAnchor a@(HsRnBracketOut{}) _ _s = a + setAnnotationAnchor a@(HsTcBracketOut{}) _ _s = a + setAnnotationAnchor (HsSpliceE an a) anc cs = (HsSpliceE (setAnchorEpa an anc cs) a) + 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@(HsTick {}) _ _s = a + setAnnotationAnchor a@(HsBinTick {}) _ _s = 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 "`" >> return () + printStringAtAA l "_" >> return () + printStringAtAA cb "`" >> return () + return x + -- exact x@(HsConLikeOut{}) = withPpr x + -- exact x@(HsRecFld{}) = withPpr x + exact x@(HsOverLabel _ _) = withPpr x + + 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 >> 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 mg) = do + an0 <- markEpAnnL an lidl AnnLam + an1 <- markEpAnnL an0 lidl AnnCase + mg' <- markAnnotated mg + return (HsLamCase an1 mg') + + exact (HsApp an e1 e2) = do + p <- getPosP + debugM $ "HsApp entered. p=" ++ show p + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + return (HsApp an e1' e2') + exact (HsAppType ss fun arg) = do + fun' <- markAnnotated fun + printStringAtSs ss "@" + arg' <- markAnnotated arg + return (HsAppType ss fun' 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 e) = do + an0 <- markOpeningParen an + e' <- markAnnotated e + debugM $ "HsPar closing paren" + an1 <- markClosingParen an0 + debugM $ "HsPar done" + return (HsPar an1 e') + + exact (SectionL an expr op) = do + expr' <- markAnnotated expr + op' <- markAnnotated op + return (SectionL an expr' op') + + exact (SectionR an op expr) = do + op' <- markAnnotated op + expr' <- markAnnotated expr + return (SectionR an op' expr') + + exact (ExplicitTuple an args b) = do + an0 <- if b == Boxed then markEpAnnL an lidl AnnOpenP + else markEpAnnL an lidl AnnOpenPH + + args' <- mapM markAnnotated args + + 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 + 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 + 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 + 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 + 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 binds e) = do + setLayoutBoth $ do -- Make sure the 'in' gets indented too + an0 <- markLensKw an lalLet AnnLet + debugM $ "HSlet:binds coming" + binds' <- setLayoutBoth $ markAnnotated binds + debugM $ "HSlet:binds done" + an1 <- markLensKw an0 lalIn AnnIn + debugM $ "HSlet:expr coming" + e' <- markAnnotated e + return (HsLet an1 binds' e') + + exact (HsDo an do_or_list_comp stmts) = do + debugM $ "HsDo" + (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" + 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 + 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 + 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 + an0 <- markAnnKwL an lapOpen AnnOpenP + flds' <- markAnnotated flds + an1 <- markAnnKwL an0 lapClose AnnCloseP + return (HsProjection an1 flds') + exact (ExprWithTySig an expr sig) = do + 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 + e' <- markAnnotated e + an' <- markEpAnnL an0 lidl AnnDotdot + return (an', From e') + FromTo e1 e2 -> do + e1' <- markAnnotated e1 + an' <- markEpAnnL an0 lidl AnnDotdot + e2' <- markAnnotated e2 + return (an', FromTo e1' e2') + FromThen e1 e2 -> do + 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 + 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 (HsBracket 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 (HsBracket an2 (ExpBr a e')) + exact (HsBracket an (PatBr a e)) = do + an0 <- markEpAnnLMS an lidl AnnOpen (Just "[p|") + e' <- markAnnotated e + an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]" + return (HsBracket an1 (PatBr a e')) + exact (HsBracket an (DecBrL a e)) = do + an0 <- markEpAnnLMS an lidl AnnOpen (Just "[d|") + -- See https://gitlab.haskell.org/ghc/ghc/-/issues/20257, we need + -- to mark braces here for the time being + an1 <- markEpAnnL an0 lidl AnnOpenC -- "{" + e' <- markAnnotated e + an2 <- markEpAnnL an1 lidl AnnCloseC -- "}" + an3 <- markEpAnnL an2 lidl AnnCloseQ -- "|]" + return (HsBracket an3 (DecBrL a e')) + -- -- exact (HsBracket an (DecBrG _ _)) = + -- -- traceM "warning: DecBrG introduced after renamer" + exact (HsBracket an (TypBr a e)) = do + an0 <- markEpAnnLMS an lidl AnnOpen (Just "[t|") + e' <- markAnnotated e + an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]" + return (HsBracket an1 (TypBr a e')) + exact (HsBracket an (VarBr a b e)) = do + (an0, e') <- + if b + then do + an' <- markEpAnnL an lidl AnnSimpleQuote + e' <- markAnnotated e + return (an', e') + else do + an' <- markEpAnnL an lidl AnnThTyQuote + e' <- markAnnotated e + return (an', e') + return (HsBracket an0 (VarBr a b e')) + exact (HsBracket an (TExpBr a e)) = do + an0 <- markEpAnnLMS an lidl AnnOpen (Just "[||") + an1 <- markEpAnnLMS an0 lidl AnnOpenE (Just "[e||") + e' <- markAnnotated e + an2 <- markEpAnnLMS an1 lidl AnnClose (Just "||]") + return (HsBracket an2 (TExpBr a e')) + + + -- exact x@(HsRnBracketOut{}) = withPpr x + -- exact x@(HsTcBracketOut{}) = withPpr x + exact (HsSpliceE a sp) = do + sp' <- markAnnotated sp + return (HsSpliceE a sp') + + exact (HsProc an p c) = do + debugM $ "HsProc start" + an0 <- markEpAnnL an lidl AnnProc + p' <- markAnnotated p + an1 <- markEpAnnL an0 lidl AnnRarrow + debugM $ "HsProc after AnnRarrow" + c' <- markAnnotated c + return (HsProc an1 p' c') + + exact (HsStatic an e) = do + an0 <- markEpAnnL an lidl AnnStatic + e' <- markAnnotated e + return (HsStatic an0 e') + + -- exact x@(HsTick {}) = withPpr x + -- exact x@(HsBinTick {}) = withPpr x + 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 :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) + => EpAnn AnnList -> HsStmtContext any -> 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 ArrowExpr 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 +exactDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt + +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 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 + an0 <- markAnnOpenP an st "{-# SCC" + let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl) + 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) + + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsSplice GhcPs) where + getAnnotationEntry (HsTypedSplice an _ _ _) = fromAnn an + getAnnotationEntry (HsUntypedSplice an _ _ _) = fromAnn an + getAnnotationEntry (HsQuasiQuote _ _ _ _ _) = NoEntryVal + getAnnotationEntry (HsSpliced _ _ _) = NoEntryVal + + setAnnotationAnchor (HsTypedSplice an a b c) anc cs = (HsTypedSplice (setAnchorEpa an anc cs) a b c) + setAnnotationAnchor (HsUntypedSplice an a b c) anc cs = (HsUntypedSplice (setAnchorEpa an anc cs) a b c) + setAnnotationAnchor a@(HsQuasiQuote _ _ _ _ _) _ _ = a + setAnnotationAnchor a@(HsSpliced _ _ _) _ _ = a + + exact (HsTypedSplice an DollarSplice n e) = do + an0 <- markEpAnnL an lidl AnnDollarDollar + e' <- markAnnotated e + return (HsTypedSplice an0 DollarSplice n e') + + exact (HsUntypedSplice an decoration n b) = do + an0 <- if (decoration == DollarSplice) + then markEpAnnL an lidl AnnDollar + else return an + b' <- markAnnotated b + return (HsUntypedSplice an0 decoration n b') + + exact (HsQuasiQuote a b q ss fs) = do + -- The quasiquote string does not honour layout offsets. Store + -- the colOffset for now. + -- TODO: use local? + oldOffset <- getLayoutOffsetP + EPState{pMarkLayout} <- get + unless pMarkLayout $ setLayoutOffsetP 0 + printStringAdvance + -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 + ("[" ++ (showPprUnsafe q) ++ "|" ++ (unpackFS fs) ++ "|]") + unless pMarkLayout $ setLayoutOffsetP oldOffset + p <- getPosP + debugM $ "HsQuasiQuote:after:(p,ss)=" ++ show (p,ss2range ss) + return (HsQuasiQuote a b q ss fs) + + exact x = error $ "exact HsSplice for:" ++ showAst x + +-- --------------------------------------------------------------------- + +-- TODO:AZ: combine these instances +instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + exact (MG x matches o) = do + -- TODO:AZ use SortKey, in MG ann. + -- matches' <- markAnnotated matches + matches' <- if isGoodSrcSpan (getLocA matches) + then markAnnotated matches + else return matches + return (MG x matches' o) + +instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + exact (MG x matches o) = do + -- TODO:AZ use SortKey, in MG ann. + matches' <- if isGoodSrcSpan (getLocA matches) + then markAnnotated matches + else return matches + return (MG x matches' o) + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + exact (HsRecFields fields mdot) = do + fields' <- markAnnotated fields + case mdot of + Nothing -> return () + Just (L ss _) -> + printStringAtSs ss ".." >> return () + -- Note: mdot contains the SrcSpan where the ".." appears, if present + return (HsRecFields fields' mdot) + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) + => ExactPrint (HsRecField' (FieldOcc GhcPs) body) where + getAnnotationEntry x = fromAnn (hsRecFieldAnn x) + setAnnotationAnchor x anc cs = x { hsRecFieldAnn = setAnchorEpa (hsRecFieldAnn x) anc cs} + exact (HsRecField an f arg isPun) = do + debugM $ "HsRecField" + f' <- markAnnotated f + (an0, arg') <- if isPun + then return (an, arg) + else do + an0 <- markEpAnnL an lidl AnnEqual + arg' <- markAnnotated arg + return (an0, arg') + return (HsRecField an0 f' arg' isPun) + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) + => ExactPrint (HsRecField' (FieldLabelStrings GhcPs) body) where + getAnnotationEntry x = fromAnn (hsRecFieldAnn x) + setAnnotationAnchor x anc cs = x { hsRecFieldAnn = setAnchorEpa (hsRecFieldAnn x) anc cs} + exact (HsRecField an f arg isPun) = do + debugM $ "HsRecField FieldLabelStrings" + f' <- markAnnotated f + (an0, arg') <- if isPun + then return (an, arg) + else do + an0 <- markEpAnnL an lidl AnnEqual + arg' <- markAnnotated arg + return (an0, arg') + return (HsRecField an0 f' arg' isPun) + +-- --------------------------------------------------------------------- + +instance (ExactPrint (LocatedA body)) + => ExactPrint (HsRecField' (AmbiguousFieldOcc GhcPs) (LocatedA body)) where + getAnnotationEntry x = fromAnn (hsRecFieldAnn x) + setAnnotationAnchor x anc cs = x { hsRecFieldAnn = setAnchorEpa (hsRecFieldAnn x) anc cs} + exact (HsRecField an f arg isPun) = do + debugM $ "HsRecUpdField" + 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 (HsRecField an0 f' arg' isPun) + +-- --------------------------------------------------------------------- + +instance + (ExactPrint (HsRecField' (a GhcPs) body), + ExactPrint (HsRecField' (b GhcPs) body)) + => ExactPrint + (Either [LocatedA (HsRecField' (a GhcPs) body)] + [LocatedA (HsRecField' (b GhcPs) body)]) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + exact (Left rbinds) = do + rbinds' <- markAnnotated rbinds + return (Left rbinds') + exact (Right pbinds) = do + pbinds' <- markAnnotated pbinds + return (Right pbinds') + +-- --------------------------------------------------------------------- + +instance ExactPrint (FieldLabelStrings GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + exact (FieldLabelStrings fs) = FieldLabelStrings <$> markAnnotated fs + +-- --------------------------------------------------------------------- + +instance ExactPrint (NonEmpty (Located (HsFieldLabel GhcPs))) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + exact (h :| t) = do + h' <- markAnnotated h + t' <- markAnnotated t + return (h' :| t') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsFieldLabel GhcPs) where + getAnnotationEntry (HsFieldLabel an _) = fromAnn an + setAnnotationAnchor (HsFieldLabel an a) anc cs = HsFieldLabel (setAnchorEpa an anc cs) a + + exact (HsFieldLabel an fs) = do + an0 <- markLensKwM an lafDot AnnDot + fs' <- markAnnotated fs + return (HsFieldLabel an0 fs') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsTupArg GhcPs) where + getAnnotationEntry (Present an _) = fromAnn an + getAnnotationEntry (Missing an) = fromAnn an + + 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 a@(Missing EpAnnNotUsed) = return a + exact a@(Missing _) = printStringAdvance "," >> return a + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsCmdTop GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + exact (HsCmdTop a cmd) = HsCmdTop a <$> markAnnotated cmd + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsCmd GhcPs) where + getAnnotationEntry (HsCmdArrApp an _ _ _ _) = fromAnn an + getAnnotationEntry (HsCmdArrForm an _ _ _ _ ) = fromAnn an + getAnnotationEntry (HsCmdApp an _ _ ) = fromAnn an + getAnnotationEntry (HsCmdLam {}) = NoEntryVal + getAnnotationEntry (HsCmdPar an _) = fromAnn an + getAnnotationEntry (HsCmdCase an _ _) = fromAnn an + getAnnotationEntry (HsCmdLamCase an _) = fromAnn an + getAnnotationEntry (HsCmdIf an _ _ _ _) = fromAnn an + getAnnotationEntry (HsCmdLet an _ _) = fromAnn an + getAnnotationEntry (HsCmdDo an _) = fromAnn an + + 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) anc cs = (HsCmdPar (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsCmdCase an a b) anc cs = (HsCmdCase (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsCmdLamCase an a) anc cs = (HsCmdLamCase (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsCmdIf an a b c d) anc cs = (HsCmdIf (setAnchorEpa an anc cs) a b c d) + setAnnotationAnchor (HsCmdLet an a b) anc cs = (HsCmdLet (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsCmdDo an a) anc cs = (HsCmdDo (setAnchorEpa an anc cs) a) + + exact (HsCmdArrApp an arr arg o isRightToLeft) = do + if isRightToLeft + then do + arr' <- markAnnotated arr + an0 <- markKw (anns an) + arg' <- markAnnotated arg + let an1 = an{anns = an0} + return (HsCmdArrApp an1 arr' arg' o isRightToLeft) + else do + 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 + -- markLocatedMAA an al_open + an0 <- markLensMAA an lal_open + (e',cs') <- case (fixity, cs) of + (Infix, (arg1:argrest)) -> do + arg1' <- markAnnotated arg1 + e' <- markAnnotated e + argrest' <- markAnnotated argrest + return (e', arg1':argrest') + (Prefix, _) -> do + e' <- markAnnotated e + cs' <- markAnnotated cs + return (e', cs') + (Infix, []) -> error "Not possible" + an1 <- markLensMAA an0 lal_close + return (HsCmdArrForm an1 e' fixity mf cs') + + exact (HsCmdApp an e1 e2) = do + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + return (HsCmdApp an e1' e2') + + exact (HsCmdLam a match) = do + match' <- markAnnotated match + return (HsCmdLam a match') + + exact (HsCmdPar an e) = do + an0 <- markOpeningParen an + e' <- markAnnotated e + an1 <- markClosingParen an0 + return (HsCmdPar an1 e') + + exact (HsCmdCase an e alts) = do + 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 matches) = do + an0 <- markEpAnnL an lidl AnnLam + an1 <- markEpAnnL an0 lidl AnnCase + matches' <- markAnnotated matches + return (HsCmdLamCase an1 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 binds e) = do + an0 <- markLensKw an lalLet AnnLet + binds' <- markAnnotated binds + an1 <- markLensKw an0 lalIn AnnIn + e' <- markAnnotated e + return (HsCmdLet an1 binds' e') + + exact (HsCmdDo an es) = do + debugM $ "HsCmdDo" + an0 <- markEpAnnL an lal_rest AnnDo + es' <- markAnnotated es + return (HsCmdDo an0 es') + + -- exact x = error $ "exact HsCmd for:" ++ showAst x + +-- --------------------------------------------------------------------- + +instance ( + ExactPrint (LocatedA (body GhcPs)), + Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA, + Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL, + (ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) + => ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where + getAnnotationEntry (LastStmt _ _ _ _) = NoEntryVal + getAnnotationEntry (BindStmt an _ _) = fromAnn an + getAnnotationEntry (ApplicativeStmt _ _ _) = NoEntryVal + getAnnotationEntry (BodyStmt _ _ _ _) = NoEntryVal + getAnnotationEntry (LetStmt an _) = fromAnn an + getAnnotationEntry (ParStmt _ _ _ _) = NoEntryVal + getAnnotationEntry (TransStmt an _ _ _ _ _ _ _ _) = fromAnn an + getAnnotationEntry (RecStmt an _ _ _ _ _ _) = fromAnn an + + ----------------------------------------------------------------- + + 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" + body' <- markAnnotated body + return (LastStmt a body' b c) + + exact (BindStmt an pat body) = do + debugM $ "BindStmt" + 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" + + exact (BodyStmt a body b c) = do + debugM $ "BodyStmt" + body' <- markAnnotated body + return (BodyStmt a body' b c) + + exact (LetStmt an binds) = do + debugM $ "LetStmt" + an0 <- markEpAnnL an lidl AnnLet + binds' <- markAnnotated binds + return (LetStmt an0 binds') + + exact (ParStmt a pbs b c) = do + debugM $ "ParStmt" + pbs' <- markAnnotated pbs + return (ParStmt a pbs' b c) + + 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" + -- markLocatedAAL an al_rest AnnRec + an0 <- markEpAnnL an lal_rest AnnRec + (an1, stmts') <- markAnnList True an0 (markAnnotated stmts) + return (RecStmt an1 stmts' a b c d e) + + -- exact x = error $ "exact CmdLStmt for:" ++ showAst x + -- exact x = error $ "exact CmdLStmt for:" + + +-- --------------------------------------------------------------------- + +instance ExactPrint (ParStmtBlock GhcPs GhcPs) where + getAnnotationEntry = const NoEntryVal + 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" + an0 <- markEpAnnL an lidl AnnThen + using' <- markAnnotated using + case by of + Nothing -> return (an0, by, using') + Just b -> do + an1 <- markEpAnnL an0 lidl AnnBy + b' <- markAnnotated b + return (an1, Just b', using') +exactTransStmt an by using GroupForm = do + debugM $ "exactTransStmt:GroupForm" + an0 <- markEpAnnL an lidl AnnThen + an1 <- markEpAnnL an0 lidl AnnGroup + (an2, by') <- case by of + Nothing -> return (an1, by) + Just b -> do + an2 <- markEpAnnL an1 lidl AnnBy + b' <- markAnnotated b + return (an2, Just b') + an3 <- markEpAnnL an2 lidl AnnUsing + using' <- markAnnotated using + return (an3, by', using') + +-- --------------------------------------------------------------------- + +instance ExactPrint (TyClDecl GhcPs) where + getAnnotationEntry (FamDecl { }) = NoEntryVal + getAnnotationEntry (SynDecl { tcdSExt = an }) = fromAnn an + getAnnotationEntry (DataDecl { tcdDExt = an }) = fromAnn an + getAnnotationEntry (ClassDecl { tcdCExt = (an, _, _) }) = fromAnn an + + 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 + 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 }) = 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, lo), + tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdFDs = fds, + tcdSigs = sigs, tcdMeths = methods, + tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = _docs}) + -- TODO: add a test that demonstrates tcdDocs + | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part + = do + (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 + (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 + ) + 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 + 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 + 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 + , fdTopLevel = top_level + , fdLName = ltycon + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = L lr result + , fdInjectivityAnn = mb_inj }) = do + 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 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_ext = x, dd_ND = new_or_data, dd_ctxt = context + , dd_cType = mb_ct + , dd_kindSig = mb_sig + , dd_cons = condecls, dd_derivs = derivings }) = do + an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] + an0 <- if new_or_data == DataType + then markEpAnnL an' lidl AnnData + else markEpAnnL an' lidl AnnNewtype + 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 (isGadt condecls) + then markEpAnnL an2 lidl AnnWhere + else return an2 + an4 <- markEpAnnL an3 lidl AnnOpenC + (an5, condecls') <- exact_condecls an4 condecls + an6 <- markEpAnnL an5 lidl AnnCloseC + derivings' <- mapM markAnnotated derivings + return (anx, an6, ln', tvs', b, mctxt', + (HsDataDefn { dd_ext = x, dd_ND = new_or_data, 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) + -> 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 (varl:varsr) + | fixity == Infix && length varsr > 1 = do + varl' <- markAnnotated varl + thing' <- markAnnotated thing + hvarsr <- markAnnotated (head varsr) + tvarsr <- markAnnotated (tail varsr) + return (thing', varl':hvarsr:tvarsr) + | fixity == Infix = do + varl' <- markAnnotated varl + thing' <- markAnnotated thing + varsr' <- markAnnotated varsr + return (thing', varl':varsr') + | otherwise = do + thing' <- markAnnotated thing + vs <- mapM markAnnotated (varl:varsr) + return (thing', vs) + exact_tyvars [] = do + 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 + 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 :: (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 + 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 + 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) + InferredSpec -> (AnnOpenC, AnnCloseC) + +instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where + getAnnotationEntry (UserTyVar an _ _) = fromAnn an + getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an + + 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" + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsType GhcPs) where + getAnnotationEntry (HsForAllTy _ _ _) = NoEntryVal + getAnnotationEntry (HsQualTy _ _ _) = NoEntryVal + getAnnotationEntry (HsTyVar an _ _) = fromAnn an + getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal + getAnnotationEntry (HsAppKindTy _ _ _) = NoEntryVal + getAnnotationEntry (HsFunTy an _ _ _) = fromAnn an + getAnnotationEntry (HsListTy an _) = fromAnn an + getAnnotationEntry (HsTupleTy an _ _) = fromAnn an + getAnnotationEntry (HsSumTy an _) = fromAnn an + getAnnotationEntry (HsOpTy _ _ _ _) = NoEntryVal + getAnnotationEntry (HsParTy an _) = fromAnn an + getAnnotationEntry (HsIParamTy an _ _) = fromAnn an + getAnnotationEntry (HsStarTy _ _) = NoEntryVal + getAnnotationEntry (HsKindSig an _ _) = fromAnn an + getAnnotationEntry (HsSpliceTy _ _) = NoEntryVal + getAnnotationEntry (HsDocTy an _ _) = fromAnn an + getAnnotationEntry (HsBangTy an _ _) = fromAnn an + getAnnotationEntry (HsRecTy an _) = fromAnn an + getAnnotationEntry (HsExplicitListTy an _ _) = fromAnn an + getAnnotationEntry (HsExplicitTupleTy an _) = fromAnn an + getAnnotationEntry (HsTyLit _ _) = NoEntryVal + getAnnotationEntry (HsWildCardTy _) = NoEntryVal + getAnnotationEntry (XHsType _) = NoEntryVal + + 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 + 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 + 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 + ty' <- markAnnotated ty + printStringAtSs ss "@" + ki' <- markAnnotated ki + return (HsAppKindTy ss ty' ki') + exact (HsFunTy an mult ty1 ty2) = do + ty1' <- markAnnotated ty1 + (an', mult') <- markArrow an mult + ty2' <- markAnnotated ty2 + return (HsFunTy an' mult' ty1' ty2') + exact (HsListTy an tys) = do + 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 + an0 <- markOpeningParen an + tys' <- markAnnotated tys + an1 <- markClosingParen an0 + return (HsSumTy an1 tys') + exact (HsOpTy an t1 lo t2) = do + t1' <- markAnnotated t1 + lo' <- markAnnotated lo + t2' <- markAnnotated t2 + return (HsOpTy an t1' lo' t2') + exact (HsParTy an ty) = do + an0 <- markOpeningParen an + ty' <- markAnnotated ty + an1 <- markClosingParen an0 + return (HsParTy an1 ty') + exact (HsIParamTy an n t) = do + 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 + 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 x@(HsDocTy an _ _) = withPpr x + 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 x@(HsRecTy an _) = withPpr x + exact (HsExplicitListTy an prom tys) = do + 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 + 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) + return (HsTyLit a lit) + exact t@(HsWildCardTy _) = printStringAdvance "_" >> return t + exact x = error $ "missing match for HsType:" ++ showAst x + +-- --------------------------------------------------------------------- + +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 + an0 <- markLensAA an lfst -- AnnForall + bndrs' <- markAnnotated bndrs + an1 <- markLensAA an0 lsnd -- AnnRarrow + return (HsForAllVis an1 bndrs') + + exact (HsForAllInvis an bndrs) = do + 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 + an0 <- markEpAnnL an lidl AnnDeriving + exact_strat_before + 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 >> pure ()) + _ -> (mapM_ markAnnotated dcs, pure ()) + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivStrategy GhcPs) where + getAnnotationEntry (StockStrategy an) = fromAnn an + getAnnotationEntry (AnyclassStrategy an) = fromAnn an + getAnnotationEntry (NewtypeStrategy an) = fromAnn an + getAnnotationEntry (ViaStrategy (XViaStrategyPs an _)) = fromAnn an + + 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 s@(StockStrategy an) = markEpAnn an AnnStock >> return s + exact s@(AnyclassStrategy an) = markEpAnn an AnnAnyclass >> return s + exact s@(NewtypeStrategy an) = markEpAnn an AnnNewtype >> return s + exact s@(ViaStrategy (XViaStrategyPs an ty)) + = markEpAnn an AnnVia >> markAnnotated ty >> return s + +-- --------------------------------------------------------------------- + +instance (ExactPrint a) => ExactPrint (LocatedC a) where + getAnnotationEntry (L sann _) = fromAnn sann + setAnnotationAnchor = setAnchorAn + + 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 + -- mapM_ (markKwA AnnOpenP) (sort opens) + mapM_ (markKwA AnnOpenP) opens + a' <- markAnnotated a + -- mapM_ (markKwA AnnCloseP) (sort closes) + mapM_ (markKwA AnnCloseP) closes + case ma of + Just (UnicodeSyntax, r) -> markKwA AnnDarrowU r >> pure () + Just (NormalSyntax, r) -> markKwA AnnDarrow r >> pure () + Nothing -> pure () + 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 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 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 + 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 + -- let (o', (Just (l',_)), c') = + -- case mn of + -- (o', (Just (l',n')), c') -> (o', (Just (l',n')), c') + -- _ -> error "ExactPrint (LocatedN RdrName)" + -- t' <- markTrailing t + -- return (NameAnn a o' l' c' t') + 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') + 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 + (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) +adornments NameParensHash = (AnnOpenPH, AnnClosePH) +adornments NameBackquotes = (AnnBackquote, AnnBackquote) +adornments NameSquare = (AnnOpenS, AnnCloseS) + + +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 ts + +-- --------------------------------------------------------------------- + +-- based on pp_condecls in Decls.hs +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 + = do + cs' <- mapM markAnnotated cs + return (an, cs') + | otherwise -- In H98 syntax + = do + an0 <- markEpAnnL an lidl AnnEqual + cs' <- mapM markAnnotated cs + return (an0, cs') + where + gadt_syntax = case cs of + [] -> False + (L _ ConDeclH98{} : _) -> False + (L _ ConDeclGADT{} : _) -> True + +-- --------------------------------------------------------------------- + +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 + , con_forall = has_forall + , con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt + , con_args = args + , con_doc = doc }) = do + 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 + t1' <- markAnnotated t1 + con' <- markAnnotated con + t2' <- markAnnotated t2 + return (con', InfixCon t1' t2') + exact_details (PrefixCon tyargs tys) = do + con' <- markAnnotated con + tyargs' <- markAnnotated tyargs + tys' <- markAnnotated tys + return (con', PrefixCon tyargs' tys') + exact_details (RecCon fields) = do + con' <- markAnnotated con + fields' <- markAnnotated fields + return (con', RecCon fields') + + -- ----------------------------------- + + exact (ConDeclGADT { con_g_ext = an + , con_names = cons + , con_bndrs = bndrs + , con_mb_cxt = mcxt, con_g_args = args + , con_res_ty = res_ty, con_doc = doc }) = do + doc' <- mapM markAnnotated doc + cons' <- mapM markAnnotated cons + an0 <- markEpAnnL an lidl AnnDcolon + an1 <- annotationsToComments an0 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 markScaled args0 + return (PrefixConGADT args0') + (RecConGADT fields) -> do + fields' <- markAnnotated fields + return (RecConGADT fields') + res_ty' <- markAnnotated res_ty + return (ConDeclGADT { con_g_ext = an2 + , con_names = cons' + , 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 + setAnnotationAnchor a _ _ = a + exact x = return x + +-- --------------------------------------------------------------------- + +instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) where + getAnnotationEntry (HsOuterImplicit _) = NoEntryVal + getAnnotationEntry (HsOuterExplicit an _) = fromAnn an + + 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 + 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 + 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 + setAnnotationAnchor a _ _ = a + exact f@(FieldOcc _ n) = markAnnotated n >> return f + +-- --------------------------------------------------------------------- + +instance ExactPrint (AmbiguousFieldOcc GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + exact f@(Unambiguous _ n) = markAnnotated n >> return f + exact f@(Ambiguous _ n) = markAnnotated n >> return f + +-- --------------------------------------------------------------------- + +markScaled :: (Monad m, Monoid w) + => HsScaled GhcPs (LBangType GhcPs) -> EP w m (HsScaled GhcPs (LBangType GhcPs)) +markScaled (HsScaled arr (L l c)) = do + (L l1 (HsScaled arr' (L l2 c'))) <- markAnnotated (L l (HsScaled arr (L (noAnnSrcSpan $ locA l) c)) + :: LocatedA (HsScaled GhcPs (LBangType GhcPs))) + let l' = l1 <> l2 + return (HsScaled arr' (L l' c')) + +instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + exact (HsScaled arr t) = do + t' <- markAnnotated t + (_, arr') <- markArrow EpAnnNotUsed arr + return (HsScaled arr' t') + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP CType) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + + exact x@(L (SrcSpanAnn EpAnnNotUsed _) ct) = withPpr ct >> return x + exact (L (SrcSpanAnn an ll) + (CType stp mh (stct,ct))) = do + 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) + + +-- ===================================================================== +-- LocatedL instances start -- +-- +-- Each is dealt with specifically, as they have +-- different wrapping annotations in the al_rest zone. +-- +-- In future, the annotation could perhaps be improved, with an +-- 'al_pre' and 'al_post' set of annotations to be simply sorted and +-- applied. +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + + exact (L (SrcSpanAnn an l) ies) = do + debugM $ "LocatedL [LIE" + an0 <- markEpAnnL an lal_rest AnnHiding + p <- getPosP + debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p + (an1, ies') <- markAnnList True an0 (markAnnotated ies) + return (L (SrcSpanAnn an1 l) ies') + +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? + 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 = entryFromLocatedAFixed + setAnnotationAnchor = setAnchorAn + exact (L (SrcSpanAnn an' l) stmts) = do + let an = fixAnnListAnn an' + debugM $ "LocatedL [ExprLStmt" + (an'', stmts') <- markAnnList True an $ do + -- markLocatedMAA an al_open + case snocView stmts of + Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do + debugM $ "LocatedL [ExprLStmt: snocView" + ls' <- markAnnotated ls + initStmts' <- markAnnotated initStmts + return (initStmts' ++ [ls']) + _ -> do + markAnnotated stmts + -- x -> error $ "pprDo:ListComp" ++ showAst x + -- markLocatedMAA an al_close + return (L (SrcSpanAnn an'' l) stmts') + +-- instance ExactPrint (LocatedL [CmdLStmt GhcPs]) where +instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where + getAnnotationEntry = entryFromLocatedAFixed + setAnnotationAnchor = setAnchorAn + exact (L (SrcSpanAnn ann' l) es) = do + let ann = fixAnnListAnn ann' + debugM $ "LocatedL [CmdLStmt" + 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 + setAnnotationAnchor = setAnchorAn + exact (L (SrcSpanAnn an l) fs) = do + debugM $ "LocatedL [LConDeclField" + (an', fs') <- markAnnList True an (markAnnotated fs) + return (L (SrcSpanAnn an' l) fs') + +instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + exact (L (SrcSpanAnn an l) bf) = do + debugM $ "LocatedL [LBooleanFormula" + (an', bf') <- markAnnList True an (markAnnotated bf) + return (L (SrcSpanAnn an' l) bf') + +-- --------------------------------------------------------------------- +-- LocatedL instances end -- +-- ===================================================================== + +instance ExactPrint (IE GhcPs) where + getAnnotationEntry (IEVar _ _) = NoEntryVal + getAnnotationEntry (IEThingAbs an _) = fromAnn an + getAnnotationEntry (IEThingAll an _) = fromAnn an + getAnnotationEntry (IEThingWith an _ _ _) = fromAnn an + getAnnotationEntry (IEModuleContents an _)= fromAnn an + getAnnotationEntry (IEGroup _ _ _) = NoEntryVal + getAnnotationEntry (IEDoc _ _) = NoEntryVal + getAnnotationEntry (IEDocNamed _ _) = NoEntryVal + + 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 + 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 + 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 (IEGroup _ _ _) = NoEntryVal + -- exact (IEDoc _ _) = NoEntryVal + -- exact (IEDocNamed _ _) = NoEntryVal + exact x = error $ "missing match for IE:" ++ showAst x + +-- --------------------------------------------------------------------- + +instance ExactPrint (IEWrappedName RdrName) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + + exact (IEName n) = do + n' <- markAnnotated n + return (IEName n') + exact (IEPattern r n) = do + r' <- printStringAtAA r "pattern" + n' <- markAnnotated n + return (IEPattern r' n') + exact (IEType r n) = do + r' <- printStringAtAA r "type" + n' <- markAnnotated n + return (IEType r' n') + +-- --------------------------------------------------------------------- + +instance ExactPrint (Pat GhcPs) where + getAnnotationEntry (WildPat _) = NoEntryVal + getAnnotationEntry (VarPat _ _) = NoEntryVal + getAnnotationEntry (LazyPat an _) = fromAnn an + getAnnotationEntry (AsPat an _ _) = fromAnn an + getAnnotationEntry (ParPat an _) = fromAnn an + getAnnotationEntry (BangPat an _) = fromAnn an + getAnnotationEntry (ListPat an _) = fromAnn an + getAnnotationEntry (TuplePat an _ _) = fromAnn an + getAnnotationEntry (SumPat an _ _ _) = fromAnn an + getAnnotationEntry (ConPat an _ _) = fromAnn an + getAnnotationEntry (ViewPat an _ _) = fromAnn an + getAnnotationEntry (SplicePat _ _) = NoEntryVal + getAnnotationEntry (LitPat _ _) = NoEntryVal + getAnnotationEntry (NPat an _ _ _) = fromAnn an + getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an + getAnnotationEntry (SigPat an _ _) = fromAnn an + + 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 b) anc cs = (AsPat (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (ParPat an a) anc cs = (ParPat (setAnchorEpa an anc cs) a) + 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 "_" + 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 + an0 <- markEpAnnL an lidl AnnTilde + pat' <- markAnnotated pat + return (LazyPat an0 pat') + exact (AsPat an n pat) = do + n' <- markAnnotated n + an0 <- markEpAnnL an lidl AnnAt + pat' <- markAnnotated pat + return (AsPat an0 n' pat') + exact (ParPat an pat) = do + an0 <- markAnnKwL an lap_open AnnOpenP + pat' <- markAnnotated pat + an1 <- markAnnKwL an0 lap_close AnnCloseP + return (ParPat an1 pat') + exact (BangPat an pat) = do + an0 <- markEpAnnL an lidl AnnBang + pat' <- markAnnotated pat + return (BangPat an0 pat') + + exact (ListPat an pats) = do + (an', pats') <- markAnnList True an (markAnnotated pats) + return (ListPat an' pats') + + exact (TuplePat an pats boxity) = do + 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) = do + (an', con', details') <- exactUserCon an con details + return (ConPat an' con' details') + exact (ViewPat an expr pat) = do + 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 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 + pat' <- markAnnotated pat + an0 <- markEpAnnL an lidl AnnDcolon + sig' <- markAnnotated sig + return (SigPat an0 pat' sig') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsPatSigType GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + + exact (HsPS an ty) = do + an0 <- markAnnKwL an lid AnnAt + ty' <- markAnnotated ty + return (HsPS an0 ty') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsOverLit GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ = a + + exact ol = + let str = case ol_val ol of + HsIntegral (IL src _ _) -> src + HsFractional (FL{ fl_text = src }) -> src + HsIsString src _ -> src + in + case str of + SourceText s -> printStringAdvance s >> return ol + NoSourceText -> return ol + +-- --------------------------------------------------------------------- + +hsLit2String :: HsLit GhcPs -> String +hsLit2String lit = + case lit of + HsChar src v -> toSourceTextWithSuffix src v "" + -- It should be included here + -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 + HsCharPrim src p -> toSourceTextWithSuffix src p "#" + HsString src v -> toSourceTextWithSuffix src v "" + HsStringPrim src v -> toSourceTextWithSuffix src v "" + HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v "" + HsIntPrim src v -> toSourceTextWithSuffix src v "" + HsWordPrim src v -> toSourceTextWithSuffix src v "" + HsInt64Prim src v -> toSourceTextWithSuffix src v "" + HsWord64Prim src v -> toSourceTextWithSuffix src v "" + HsInteger src v _ -> toSourceTextWithSuffix src v "" + 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 +toSourceTextWithSuffix (SourceText txt) _alt suffix = txt ++ suffix + +sourceTextToString :: SourceText -> String -> String +sourceTextToString NoSourceText alt = alt +sourceTextToString (SourceText txt) _ = txt + +-- --------------------------------------------------------------------- + +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') + +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') + +-- --------------------------------------------------------------------- + +entryFromLocatedA :: LocatedAn ann a -> Entry +entryFromLocatedA (L la _) = fromAnn la + +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256 +entryFromLocatedAFixed :: LocatedL a -> Entry +entryFromLocatedAFixed (L la _) + = fromAnn (fixSrcAnnL la) + +-- ===================================================================== +-- Utility stuff +-- --------------------------------------------------------------------- + +-- |This should be the final point where things are mode concrete, +-- before output. +-- NOTE: despite the name, this is the ghc-exactprint final output for +-- the PRINT phase. +printStringAtLsDelta :: (Monad m, Monoid w) => DeltaPos -> String -> EP w m () +printStringAtLsDelta cl s = do + p <- getPosP + colOffset <- getLayoutOffsetP + if isGoodDeltaWithOffset cl colOffset + then do + printStringAt (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)) + +-- --------------------------------------------------------------------- + +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 + 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) + +------------------------------------------------------------------------ + +setLayoutBoth :: (Monad m, Monoid w) => EP w m a -> EP w m a +setLayoutBoth k = do + oldLHS <- getLayoutOffsetD + oldAnchorOffset <- getLayoutOffsetP + debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) + modify (\a -> a { dMarkLayout = True + , pMarkLayout = True } ) + let reset = do + debugM $ "setLayoutBoth:reset: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) + modify (\a -> a { dMarkLayout = False + , dLHS = oldLHS + , pMarkLayout = False + , pLHS = oldAnchorOffset} ) + k <* reset + +-- Use 'local', designed for this +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} ) + r <- k + debugM $ "setLayoutTopLevelP:resetting" + setLayoutOffsetP oldAnchorOffset + return r + +------------------------------------------------------------------------ + +getPosP :: (Monad m, Monoid w) => EP w m Pos +getPosP = gets epPos + +setPosP :: (Monad m, Monoid w) => Pos -> EP w m () +setPosP l = do + -- debugM $ "setPosP:" ++ show l + modify (\s -> s {epPos = l}) + +getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe Anchor) +getExtraDP = gets uExtraDP + +setExtraDP :: (Monad m, Monoid w) => Maybe Anchor -> EP w m () +setExtraDP md = do + debugM $ "setExtraDP:" ++ show md + modify (\s -> s {uExtraDP = md}) + +getPriorEndD :: (Monad m, Monoid w) => EP w m Pos +getPriorEndD = gets dPriorEndPosition + +getAnchorU :: (Monad m, Monoid w) => EP w m RealSrcSpan +getAnchorU = gets uAnchorSpan + +setPriorEndD :: (Monad m, Monoid w) => Pos -> EP w m () +setPriorEndD pe = do + setPriorEndNoLayoutD pe + +setPriorEndNoLayoutD :: (Monad m, Monoid w) => Pos -> EP w m () +setPriorEndNoLayoutD pe = do + debugM $ "setPriorEndNoLayoutD:pe=" ++ show pe + modify (\s -> s { dPriorEndPosition = pe }) + +setPriorEndASTD :: (Monad m, Monoid w) => Bool -> RealSrcSpan -> EP w m () +setPriorEndASTD layout pe = setPriorEndASTPD layout (rs2range pe) + +setPriorEndASTPD :: (Monad m, Monoid w) => Bool -> (Pos,Pos) -> EP w m () +setPriorEndASTPD layout pe@(fm,to) = do + debugM $ "setPriorEndASTD:pe=" ++ show pe + when layout $ setLayoutStartD (snd fm) + modify (\s -> s { dPriorEndPosition = to } ) + +setLayoutStartD :: (Monad m, Monoid w) => Int -> EP w m () +setLayoutStartD p = do + EPState{dMarkLayout} <- get + when dMarkLayout $ do + debugM $ "setLayoutStartD: setting dLHS=" ++ show p + 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) + modify (\s -> s { uAnchorSpan = rss }) + +getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment] +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 + +setLayoutOffsetP :: (Monad m, Monoid w) => LayoutStartCol -> EP w m () +setLayoutOffsetP c = do + debugM $ "setLayoutOffsetP:" ++ show c + modify (\s -> s { pLHS = c }) + + +-- --------------------------------------------------------------------- + +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) + 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 ??? + p <- getPosP + d <- getPriorEndD + r <- getAnchorU + setPriorEndD (fst $ rs2range r) + debugM $ "advance:after: (posp, posd, posd')=" ++ show (p,d,fst $ rs2range r) + else + return () + +-- --------------------------------------------------------------------- + +adjustDeltaForOffsetM :: (Monad m, Monoid w) => DeltaPos -> EP w m DeltaPos +adjustDeltaForOffsetM dp = do + colOffset <- getLayoutOffsetD + return (adjustDeltaForOffset colOffset dp) + +-- --------------------------------------------------------------------- +-- Printing functions + +printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () +printString layout str = do + EPState{epPos = (_,c), pMarkLayout} <- get + EPOptions{epTokenPrint, epWhitespacePrint} <- ask + when (pMarkLayout && layout) $ do + debugM $ "printString: setting pLHS to " ++ show c + modify (\s -> s { pLHS = LayoutStartCol c, pMarkLayout = False } ) + + -- Advance position, taking care of any newlines in the string + let strDP = dpFromString str + cr = getDeltaLine strDP + p <- getPosP + d <- getPriorEndD + colOffsetP <- getLayoutOffsetP + colOffsetD <- getLayoutOffsetD + -- debugM $ "printString:(p,colOffset,strDP,cr)=" ++ show (p,colOffset,strDP,cr) + if cr == 0 + 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 + -- debugM $ "printString: (p,pp,str)" ++ show (p,pp,str) + -- Debug end + + -- + if not layout && c == 0 + then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s} + else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s} + +-------------------------------------------------------- + +printStringAdvance :: (Monad m, Monoid w) => String -> EP w m () +printStringAdvance str = do + ss <- getAnchorU + _ <- 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 diff --git a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs --- a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs @@ -1,7 +1,7 @@ module Language.Haskell.GHC.ExactPrint.Lookup ( keywordToString - , KeywordId(..) + , AnnKeywordId(..) , Comment(..) ) where @@ -12,118 +12,115 @@ -- There is no specific mapping for the following constructors. -- `AnnOpen`, `AnnClose`, `AnnVal`, `AnnPackageName`, `AnnHeader`, `AnnFunId`, -- `AnnInfix` -keywordToString :: KeywordId -> String +keywordToString :: AnnKeywordId -> String keywordToString kw = let mkErr x = error $ "keywordToString: missing case for:" ++ show x in case kw of -- Specifically handle all cases so that there are pattern match -- warnings if new constructors are added. - AnnComment _ -> mkErr kw - AnnString _ -> mkErr kw - AnnSemiSep -> ";" - (G AnnAnyclass) -> "anyclass" - (G AnnOpen ) -> mkErr kw - (G AnnClose ) -> mkErr kw - (G AnnVal ) -> mkErr kw - (G AnnPackageName) -> mkErr kw - (G AnnHeader ) -> mkErr kw - (G AnnFunId ) -> mkErr kw - (G AnnInfix ) -> mkErr kw - (G AnnValStr ) -> mkErr kw - (G AnnName ) -> mkErr kw - (G AnnAs ) -> "as" - (G AnnAt ) -> "@" - (G AnnBang ) -> "!" - (G AnnBackquote ) -> "`" - (G AnnBy ) -> "by" - (G AnnCase ) -> "case" - (G AnnClass ) -> "class" - (G AnnCloseB ) -> "|)" - (G AnnCloseBU ) -> "⦈" - (G AnnCloseC ) -> "}" - (G AnnCloseP ) -> ")" - (G AnnClosePH ) -> "#)" - (G AnnCloseQ ) -> "|]" - (G AnnCloseQU ) -> "⟧" - (G AnnCloseS ) -> "]" - (G AnnColon ) -> ":" - (G AnnComma ) -> "," - (G AnnCommaTuple ) -> "," - (G AnnDarrow ) -> "=>" - (G AnnData ) -> "data" - (G AnnDcolon ) -> "::" - (G AnnDefault ) -> "default" - (G AnnDeriving ) -> "deriving" - (G AnnDo ) -> "do" - (G AnnDot ) -> "." - (G AnnDotdot ) -> ".." - (G AnnElse ) -> "else" - (G AnnEqual ) -> "=" - (G AnnExport ) -> "export" - (G AnnFamily ) -> "family" - (G AnnForall ) -> "forall" - (G AnnForeign ) -> "foreign" - (G AnnGroup ) -> "group" - (G AnnHiding ) -> "hiding" - (G AnnIf ) -> "if" - (G AnnImport ) -> "import" - (G AnnIn ) -> "in" - (G AnnInstance ) -> "instance" - (G AnnLam ) -> "\\" - (G AnnLarrow ) -> "<-" - (G AnnLet ) -> "let" - (G AnnLollyU ) -> "⊸" - (G AnnMdo ) -> "mdo" - (G AnnMinus ) -> "-" - (G AnnModule ) -> "module" - (G AnnNewtype ) -> "newtype" - (G AnnOf ) -> "of" - (G AnnOpenB ) -> "(|" - (G AnnOpenBU ) -> "⦇" - (G AnnOpenC ) -> "{" - (G AnnOpenE ) -> "[e|" - (G AnnOpenEQ ) -> "[|" - (G AnnOpenEQU ) -> "⟦" - (G AnnOpenP ) -> "(" - (G AnnOpenPH ) -> "(#" - (G AnnOpenS ) -> "[" - (G AnnPattern ) -> "pattern" - (G AnnPercent ) -> "%" - (G AnnPercentOne) -> "%1" - (G AnnProc ) -> "proc" - (G AnnQualified ) -> "qualified" - (G AnnRarrow ) -> "->" - (G AnnRec ) -> "rec" - (G AnnRole ) -> "role" - (G AnnSafe ) -> "safe" - (G AnnSemi ) -> ";" - (G AnnSignature) -> "signature" - (G AnnStock ) -> "stock" - (G AnnStatic ) -> "static" - (G AnnThen ) -> "then" - (G AnnTilde ) -> "~" - (G AnnType ) -> "type" - (G AnnUnit ) -> "()" - (G AnnUsing ) -> "using" - (G AnnVbar ) -> "|" - (G AnnWhere ) -> "where" - (G Annlarrowtail ) -> "-<" - (G Annrarrowtail ) -> ">-" - (G AnnLarrowtail ) -> "-<<" - (G AnnRarrowtail ) -> ">>-" - (G AnnSimpleQuote ) -> "'" - (G AnnThTyQuote ) -> "''" - (G AnnDollar ) -> "$" - (G AnnDollarDollar ) -> "$$" - (G AnnDarrowU) -> "⇒" - (G AnnDcolonU) -> "∷" - (G AnnForallU) -> "∀" - (G AnnLarrowU) -> "←" - (G AnnLarrowtailU) -> "⤛" - (G AnnRarrowU) -> "→" - (G AnnRarrowtailU) -> "⤜" - (G AnnlarrowtailU) -> "⤙" - (G AnnrarrowtailU) -> "⤚" - AnnTypeApp -> "@" - (G AnnVia) -> "via" + AnnAnyclass -> "anyclass" + AnnOpen -> mkErr kw + AnnClose-> mkErr kw + AnnVal -> mkErr kw + AnnPackageName -> mkErr kw + AnnHeader-> mkErr kw + AnnFunId -> mkErr kw + AnnInfix -> mkErr kw + AnnValStr-> mkErr kw + AnnName -> mkErr kw + AnnAs -> "as" + AnnAt -> "@" + AnnBang -> "!" + AnnBackquote-> "`" + AnnBy -> "by" + AnnCase -> "case" + AnnClass -> "class" + AnnCloseB -> "|)" + AnnCloseBU-> "⦈" + AnnCloseC -> "}" + AnnCloseP -> ")" + AnnClosePH-> "#)" + AnnCloseQ -> "|]" + AnnCloseQU-> "⟧" + AnnCloseS -> "]" + AnnColon -> ":" + AnnComma -> "," + AnnCommaTuple-> "," + AnnDarrow -> "=>" + AnnData -> "data" + AnnDcolon -> "::" + AnnDefault-> "default" + AnnDeriving-> "deriving" + AnnDo -> "do" + AnnDot -> "." + AnnDotdot -> ".." + AnnElse -> "else" + AnnEqual -> "=" + AnnExport -> "export" + AnnFamily -> "family" + AnnForall -> "forall" + AnnForeign -> "foreign" + AnnGroup -> "group" + AnnHiding -> "hiding" + AnnIf -> "if" + AnnImport -> "import" + AnnIn -> "in" + AnnInstance-> "instance" + AnnLam -> "\\" + AnnLarrow -> "<-" + AnnLet -> "let" + AnnLollyU -> "⊸" + AnnMdo -> "mdo" + AnnMinus -> "-" + AnnModule -> "module" + AnnNewtype -> "newtype" + AnnOf -> "of" + AnnOpenB -> "(|" + AnnOpenBU -> "⦇" + AnnOpenC -> "{" + AnnOpenE -> "[e|" + AnnOpenEQ -> "[|" + AnnOpenEQU -> "⟦" + AnnOpenP -> "(" + AnnOpenPH -> "(#" + AnnOpenS -> "[" + AnnPattern -> "pattern" + AnnPercent -> "%" + AnnPercentOne -> "%1" + AnnProc -> "proc" + AnnQualified-> "qualified" + AnnRarrow -> "->" + AnnRec -> "rec" + AnnRole -> "role" + AnnSafe -> "safe" + AnnSemi -> ";" + AnnSignature -> "signature" + AnnStock -> "stock" + AnnStatic -> "static" + AnnThen -> "then" + AnnTilde -> "~" + AnnType -> "type" + AnnUnit -> "()" + AnnUsing -> "using" + AnnVbar -> "|" + AnnWhere -> "where" + Annlarrowtail-> "-<" + Annrarrowtail-> ">-" + AnnLarrowtail-> "-<<" + AnnRarrowtail-> ">>-" + AnnSimpleQuote -> "'" + AnnThTyQuote -> "''" + AnnDollar -> "$" + AnnDollarDollar-> "$$" + AnnDarrowU -> "⇒" + AnnDcolonU -> "∷" + AnnForallU -> "∀" + AnnLarrowU -> "←" + AnnLarrowtailU -> "⤛" + AnnRarrowU -> "→" + AnnRarrowtailU -> "⤜" + AnnlarrowtailU -> "⤙" + AnnrarrowtailU -> "⤚" + -- AnnTypeApp -> "@" + AnnVia -> "via" diff --git a/src/Language/Haskell/GHC/ExactPrint/Orphans.hs b/src/Language/Haskell/GHC/ExactPrint/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/ExactPrint/Orphans.hs @@ -0,0 +1,108 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.Haskell.GHC.ExactPrint.Orphans where + +import GHC hiding (EpaComment) + +-- --------------------------------------------------------------------- +-- Orphan Monoid instances. See https://gitlab.haskell.org/ghc/ghc/-/issues/20372 + +instance Semigroup AnnPragma where + (<>) = error "unimplemented" +instance Monoid AnnPragma where + mempty = error "meaningless" + +instance Semigroup EpAnnImportDecl where + (<>) = error "unimplemented" +instance Monoid EpAnnImportDecl where + mempty = error "meaningless" + +instance Semigroup HsRuleAnn where + (<>) = error "unimplemented" +instance Monoid HsRuleAnn where + mempty = error "meaningless" + +instance Semigroup AnnSig where + (<>) = error "unimplemented" +instance Monoid AnnSig where + mempty = error "meaningless" + +instance Semigroup GrhsAnn where + (<>) = error "unimplemented" +instance Monoid GrhsAnn where + mempty = error "meaningless" + +instance Semigroup EpAnnUnboundVar where + (<>) = error "unimplemented" +instance Monoid EpAnnUnboundVar where + mempty = error "meaningless" + +instance Semigroup NoEpAnns where + (<>) = error "unimplemented" +instance Monoid NoEpAnns where + mempty = error "meaningless" + +instance Semigroup AnnParen where + (<>) = error "unimplemented" +instance Monoid AnnParen where + mempty = error "meaningless" + +instance Semigroup AnnExplicitSum where + (<>) = error "unimplemented" +instance Monoid AnnExplicitSum where + mempty = error "meaningless" + +instance Semigroup EpAnnHsCase where + (<>) = error "unimplemented" +instance Monoid EpAnnHsCase where + mempty = error "meaningless" + +instance Semigroup AnnsIf where + (<>) = error "unimplemented" +instance Monoid AnnsIf where + mempty = error "meaningless" + +instance Semigroup AnnsLet where + (<>) = error "unimplemented" +instance Monoid AnnsLet where + mempty = error "meaningless" + +instance Semigroup AnnProjection where + (<>) = error "unimplemented" +instance Monoid AnnProjection where + mempty = error "meaningless" + +instance Semigroup AnnFieldLabel where + (<>) = error "unimplemented" +instance Monoid AnnFieldLabel where + mempty = error "meaningless" + +instance Semigroup EpaLocation where + (<>) = error "unimplemented" +instance Monoid EpaLocation where + mempty = error "meaningless" + +instance Semigroup AddEpAnn where + (<>) = error "unimplemented" +instance Monoid AddEpAnn where + mempty = error "meaningless" + +instance Semigroup TrailingAnn where + (<>) = error "unimplemented" +instance Monoid TrailingAnn where + mempty = error "meaningless" + +instance Semigroup AnnContext where + (<>) = error "unimplemented" +instance Monoid AnnContext where + mempty = AnnContext Nothing [] [] + +instance Semigroup EpAnnSumPat where + (<>) = error "unimplemented" +instance Monoid EpAnnSumPat where + mempty = error "meaningless" + +instance Semigroup AnnsModule where + (<>) = error "unimplemented" +instance Monoid AnnsModule where + mempty = error "meaningless" diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs --- a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs @@ -111,7 +111,7 @@ -- @ -- myParser fname expr = withDynFlags (\\d -> parseExpr d fname expr) -- @ -withDynFlags :: FilePath -> (GHC.DynFlags -> a) -> IO a +withDynFlags :: LibDir -> (GHC.DynFlags -> a) -> IO a withDynFlags libdir action = ghcWrapper libdir $ do dflags <- GHC.getSessionDynFlags void $ GHC.setSessionDynFlags dflags @@ -171,7 +171,7 @@ -- string; the `FilePath` parameter solely exists to provide a name -- in source location annotations. parseModuleFromString - :: FilePath -- GHC libdir + :: LibDir -- GHC libdir -> FilePath -> String -> IO (ParseResult GHC.ParsedSource) @@ -188,7 +188,7 @@ GHC.POk _ pmod -> Right (lp, dflags, pmod) in postParseTransform res -parseModuleWithOptions :: FilePath -- ^ GHC libdir +parseModuleWithOptions :: LibDir -- ^ GHC libdir -> FilePath -> IO (ParseResult GHC.ParsedSource) parseModuleWithOptions libdir fp = @@ -197,7 +197,7 @@ -- | Parse a module with specific instructions for the C pre-processor. parseModuleWithCpp - :: FilePath -- ^ GHC libdir + :: LibDir -- ^ GHC libdir -> CppOptions -> FilePath -- ^ File to be parsed -> IO (ParseResult GHC.ParsedSource) @@ -211,7 +211,7 @@ -- It is advised to use 'parseModule' or 'parseModuleWithCpp' instead of -- this function. parseModuleEpAnnsWithCpp - :: FilePath -- ^ GHC libdir + :: LibDir -- ^ GHC libdir -> CppOptions -> FilePath -- ^ File to be parsed -> IO @@ -224,7 +224,7 @@ parseModuleEpAnnsWithCppInternal cppOptions dflags file -- | Internal function. Default runner of GHC.Ghc action in IO. -ghcWrapper :: FilePath -> GHC.Ghc a -> IO a +ghcWrapper :: LibDir -> GHC.Ghc a -> IO a ghcWrapper libdir a = GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ GHC.runGhc (Just libdir) a diff --git a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs --- a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs @@ -76,14 +76,14 @@ size = length pragma mSrcLoc = mkSrcLoc (mkFastString "LINE") ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1)) - in (res, Just $ mkLEpaComment pragma (GHC.spanAsAnchor ss)) + in (res, Just $ mkLEpaComment pragma (GHC.spanAsAnchor ss) (GHC.realSrcSpan ss)) -- Deal with shebang/cpp directives too -- x | "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s) | "#!" `isPrefixOf` s = let mSrcLoc = mkSrcLoc (mkFastString "SHEBANG") ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s)) in - ("",Just $ mkLEpaComment s (GHC.spanAsAnchor ss)) + ("",Just $ mkLEpaComment s (GHC.spanAsAnchor ss) (GHC.realSrcSpan ss)) | otherwise = (s, Nothing) getPragma :: String -> (String, String) @@ -126,8 +126,8 @@ goodComment c = isGoodComment (tokComment c) where isGoodComment :: Comment -> Bool - isGoodComment (Comment "" _ _) = False - isGoodComment _ = True + isGoodComment (Comment "" _ _ _) = False + isGoodComment _ = True toRealLocated :: GHC.Located a -> GHC.RealLocated a @@ -169,7 +169,7 @@ missingAsComments = map mkCommentTok missingToks where mkCommentTok :: (GHC.Located GHC.Token,String) -> (GHC.Located GHC.Token,String) - mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s placeholderBufSpan),s) + mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s (makeBufSpan l)),s) toks = mergeBy locFn directiveToks missingAsComments @@ -258,7 +258,7 @@ let directives = filter (\(_lineNum,line) -> line /= [] && head line == '#') $ zip [1..] (lines fcontents) - let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line placeholderBufSpan),line) + let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line (makeBufSpan l)),line) where start = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum 1 end = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum (length line) @@ -267,11 +267,11 @@ let toks = map mkTok directives return toks -placeholderBufSpan :: GHC.PsSpan -placeholderBufSpan = pspan +makeBufSpan :: GHC.SrcSpan -> GHC.PsSpan +makeBufSpan ss = pspan where bl = GHC.BufPos 0 - pspan = GHC.PsSpan GHC.placeholderRealSpan (GHC.BufSpan bl bl) + pspan = GHC.PsSpan (GHC.realSrcSpan ss) (GHC.BufSpan bl bl) -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs --- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -19,8 +20,10 @@ ----------------------------------------------------------------------------- module Language.Haskell.GHC.ExactPrint.Transform ( + -- * Delta is still here + makeDeltaAst' -- * The Transform Monad - Transform + , Transform , TransformT(..) , hoistTransform , runTransform @@ -77,6 +80,7 @@ -- * Pure functions , setEntryDP + , getEntryDP , transferEntryDP , transferEntryDP' , wrapSig, wrapDecl @@ -93,13 +97,13 @@ import GHC.Data.Bag import GHC.Data.FastString +import Data.Maybe import Data.Generics import Data.List (sort, sortBy) import Data.Functor.Identity import Control.Monad.State - ------------------------------------------------------------------------------ -- Transformation of source elements @@ -188,7 +192,7 @@ captureMatchLineSpacing d = d captureLineSpacing :: Monoid t - => [LocatedAn t e] -> [GenLocated (SrcSpanAnn' (EpAnn t)) e] + => [LocatedAn t e] -> [LocatedAn t e] captureLineSpacing [] = [] captureLineSpacing [d] = [d] captureLineSpacing (de1:d2:ds) = de1:captureLineSpacing (d2':ds) @@ -211,8 +215,8 @@ L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor? -- DP (line, col) = ss2delta (ss2pos $ anchor $ getLoc lc) r dc' = case dca of - EpaSpan r -> AddEpAnn kw (EpaDelta $ ss2delta (ss2posEnd rd) r) - EpaDelta _ -> AddEpAnn kw dca + EpaSpan r -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) []) + EpaDelta _ _ -> AddEpAnn kw dca -- --------------------------------- @@ -222,7 +226,7 @@ -> let op = case dca of EpaSpan r -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll)) - EpaDelta _ -> MovedAnchor (SameLine 1) + EpaDelta _ _ -> MovedAnchor (SameLine 1) in (L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan ll) op) mempty emptyComments) ll) b) (L (SrcSpanAnn (EpAnn (Anchor r op) a c) ll) b) -> let @@ -230,7 +234,7 @@ MovedAnchor _ -> op _ -> case dca of EpaSpan dcr -> MovedAnchor (ss2delta (ss2posEnd dcr) r) - EpaDelta _ -> MovedAnchor (SameLine 1) + EpaDelta _ _ -> MovedAnchor (SameLine 1) in (L (SrcSpanAnn (EpAnn (Anchor r op') a c) ll) b) captureTypeSigSpacing s = s @@ -289,8 +293,32 @@ = L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor dp)) an (EpaComments [])) l) a +setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor d)) an cs) l) a) dp + = L (SrcSpanAnn + (EpAnn (Anchor r (MovedAnchor d')) an cs') + l) a + where + (d',cs') = case cs of + EpaComments (h:t) -> + let + (dp0,c') = go h + in + (dp0, EpaComments (c':t)) + EpaCommentsBalanced (h:t) ts -> + let + (dp0,c') = go h + in + (dp0, EpaCommentsBalanced (c':t) ts) + _ -> (dp, cs) + -- go (L (Anchor rr (MovedAnchor ma)) c) = (dp, L (Anchor rr (MovedAnchor ma)) c) + go (L (Anchor rr (MovedAnchor ma)) c) = (d, L (Anchor rr (MovedAnchor ma)) c) + go (L (Anchor rr _) c) = (d, L (Anchor rr (MovedAnchor dp)) c) +-- setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor _)) an cs) l) a) dp +-- = L (SrcSpanAnn +-- (EpAnn (Anchor r (MovedAnchor dp)) an cs) +-- l) a setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp - = case sort (priorComments cs) of + = case sortEpaComments (priorComments cs) of [] -> L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor dp)) an cs) @@ -305,49 +333,57 @@ delta = ss2delta (ss2pos $ anchor $ getLoc lc) r line = getDeltaLine delta col = deltaColumn delta - -- TODO: this adjustment by 1 happens all over the place. Generalise it edp' = if line == 0 then SameLine col else DifferentLine line col edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r)) + -- --------------------------------------------------------------------- +getEntryDP :: LocatedAn t a -> DeltaPos +getEntryDP (L (SrcSpanAnn (EpAnn (Anchor _ (MovedAnchor dp)) _ _) _) _) = dp +getEntryDP _ = SameLine 1 + +-- --------------------------------------------------------------------- + addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation -addEpaLocationDelta _off _anc (EpaDelta d) = EpaDelta d +addEpaLocationDelta _off _anc (EpaDelta d cs) = EpaDelta d cs addEpaLocationDelta off anc (EpaSpan r) - = EpaDelta (adjustDeltaForOffset 0 off (ss2deltaEnd anc r)) + = EpaDelta (adjustDeltaForOffset off (ss2deltaEnd anc r)) [] -- Set the entry DP for an element coming after an existing keyword annotation setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t -setEntryDPFromAnchor _off (EpaDelta _) (L la a) = L la a +setEntryDPFromAnchor _off (EpaDelta _ _) (L la a) = L la a setEntryDPFromAnchor off (EpaSpan anc) ll@(L la _) = setEntryDP ll dp' where r = case la of (SrcSpanAnn EpAnnNotUsed l) -> realSrcSpan l (SrcSpanAnn (EpAnn (Anchor r' _) _ _) _) -> r' - dp' = adjustDeltaForOffset 0 off (ss2deltaEnd anc r) + dp' = adjustDeltaForOffset off (ss2deltaEnd anc r) -- --------------------------------------------------------------------- -- |Take the annEntryDelta associated with the first item and associate it with the second. -- Also transfer any comments occuring before it. -transferEntryDP :: (Monad m, Monoid t) => LocatedAn t a -> LocatedAn t b -> TransformT m (LocatedAn t b) +transferEntryDP :: (Monad m, Monoid t2, Typeable t1, Typeable t2) + => LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b) transferEntryDP (L (SrcSpanAnn EpAnnNotUsed l1) _) (L (SrcSpanAnn EpAnnNotUsed _) b) = do logTr $ "transferEntryDP': EpAnnNotUsed,EpAnnNotUsed" return (L (SrcSpanAnn EpAnnNotUsed l1) b) transferEntryDP (L (SrcSpanAnn (EpAnn anc _an cs) _l1) _) (L (SrcSpanAnn EpAnnNotUsed l2) b) = do logTr $ "transferEntryDP': EpAnn,EpAnnNotUsed" return (L (SrcSpanAnn (EpAnn anc mempty cs) l2) b) -transferEntryDP (L (SrcSpanAnn (EpAnn anc1 _an1 cs1) _l1) _) (L (SrcSpanAnn (EpAnn _anc2 an2 cs2) l2) b) = do +transferEntryDP (L (SrcSpanAnn (EpAnn anc1 an1 cs1) _l1) _) (L (SrcSpanAnn (EpAnn _anc2 an2 cs2) l2) b) = do logTr $ "transferEntryDP': EpAnn,EpAnn" -- Problem: if the original had preceding comments, blindly -- transferring the location is not correct case priorComments cs1 of - [] -> return (L (SrcSpanAnn (EpAnn anc1 an2 cs2) l2) b) + [] -> return (L (SrcSpanAnn (EpAnn anc1 (combine an1 an2) cs2) l2) b) -- TODO: what happens if the receiving side already has comments? (L anc _:_) -> do logDataWithAnnsTr "transferEntryDP':priorComments anc=" anc - return (L (SrcSpanAnn (EpAnn anc an2 cs2) l2) b) + -- return (L (SrcSpanAnn (EpAnn anc an2 cs2) l2) b) + return (L (SrcSpanAnn (EpAnn anc1 (combine an1 an2) (cs1 <> cs2)) l2) b) transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 an2 cs2) l2) b) = do logTr $ "transferEntryDP': EpAnnNotUsed,EpAnn" return (L (SrcSpanAnn (EpAnn anc2' an2 cs2) l2) b) @@ -355,6 +391,11 @@ anc2' = case anc2 of Anchor _a op -> Anchor (realSrcSpan l2) op + +-- |If a and b are the same type return first arg, else return second +combine :: (Typeable a, Typeable b) => a -> b -> b +combine x y = fromMaybe y (cast x) + -- |Take the annEntryDelta associated with the first item and associate it with the second. -- Also transfer any comments occuring before it. -- TODO: call transferEntryDP, and use pushDeclDP @@ -378,11 +419,14 @@ -- --------------------------------------------------------------------- balanceCommentsList :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] -balanceCommentsList [] = return [] -balanceCommentsList [x] = return [x] -balanceCommentsList (a:b:ls) = do +balanceCommentsList ds = balanceCommentsList'' (map tweakListComments ds) + +balanceCommentsList'' :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] +balanceCommentsList'' [] = return [] +balanceCommentsList'' [x] = return [x] +balanceCommentsList'' (a:b:ls) = do (a',b') <- balanceComments a b - r <- balanceCommentsList (b':ls) + r <- balanceCommentsList'' (b':ls) return (a':r) -- |The GHC parser puts all comments appearing between the end of one AST @@ -411,14 +455,37 @@ => LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b) balanceCommentsFB (L lf (FunBind x n (MG mx (L lm matches) o) t)) second = do logTr $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf) - matches' <- balanceCommentsList' matches - let (m,ms) = case reverse matches' of - (m':ms') -> (m',ms') + -- There are comments on lf. We need to + -- + Keep the prior ones here + -- + move the interior ones to the first match, + -- + move the trailing ones to the last match. + let + split = splitCommentsEnd (realSrcSpan $ locA lf) (epAnnComments $ ann lf) + split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sortEpaComments $ priorComments split)) + + before = sortEpaComments $ priorComments split2 + middle = sortEpaComments $ getFollowingComments split2 + after = sortEpaComments $ getFollowingComments split + + lf' = setCommentsSrcAnn lf (EpaComments before) + logTr $ "balanceCommentsFB (before, after): " ++ showAst (before, after) + let matches' = case matches of + (L lm' m':ms') -> + (L (addCommentsToSrcAnn lm' (EpaComments middle )) m':ms') + _ -> error "balanceCommentsFB" + matches'' <- balanceCommentsList' matches' + let (m,ms) = case reverse matches'' of + (L lm' m':ms') -> + (L (addCommentsToSrcAnn lm' (EpaCommentsBalanced [] after)) m',ms') _ -> error "balanceCommentsFB" (m',second') <- balanceComments' m second m'' <- balanceCommentsMatch m' + let (m''',lf'') = case ms of + [] -> moveLeadingComments m'' lf' + _ -> (m'',lf') logTr $ "balanceCommentsMatch done" - return (L lf (FunBind x n (MG mx (L lm (reverse (m'':ms))) o) t), second') + -- return (L lf'' (FunBind x n (MG mx (L lm (reverse (m''':ms))) o) t), second') + balanceComments' (L lf'' (FunBind x n (MG mx (L lm (reverse (m''':ms))) o) t)) second' balanceCommentsFB f s = balanceComments' f s -- | Move comments on the same line as the end of the match into the @@ -427,10 +494,11 @@ => LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs)) balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l)) - logTr $ "balanceCommentsMatch: (move',stay')=" ++ showAst (move',stay') + -- logTr $ "balanceCommentsMatch: (move',stay')=" ++ showAst (move',stay') logTr $ "balanceCommentsMatch: (logInfo)=" ++ showAst (logInfo) - logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l)) + -- logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l)) logTr $ "balanceCommentsMatch: (anc1,cs1f)=" ++ showAst (anc1,cs1f) + logTr $ "balanceCommentsMatch: (move,stay)=" ++ showAst (move,stay) logTr $ "balanceCommentsMatch: (l'', grhss')=" ++ showAst (l'', grhss') return (L l'' (Match am mctxt pats (GRHSs xg grhss' binds'))) where @@ -455,7 +523,7 @@ -- --------------------------------- (EpAnn anc an lgc) = ag - lgc' = splitComments (realSrcSpan lg) $ addCommentOrigDeltas lgc + lgc' = splitCommentsEnd (realSrcSpan lg) $ addCommentOrigDeltas lgc ag' = if moved then EpAnn anc an lgc' else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move)) @@ -473,7 +541,7 @@ (an', decls') = case reverse decls of [] -> (addCommentsToEpAnn (spanHsLocaLBinds lb) an cs, decls) (L la d:ds) -> (an, L (addCommentsToSrcAnn la cs) d:ds) - (vb,_ws2) = case runTransform (replaceDeclsValbinds w lb decls') of + (vb,_ws2) = case runTransform (replaceDeclsValbinds w lb (reverse decls')) of ((HsValBinds _ vb'), _, ws2') -> (vb', ws2') _ -> (ValBinds NoAnnSortKey emptyBag [], []) @@ -496,11 +564,11 @@ balanceComments' :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA a, LocatedA b) balanceComments' la1 la2 = do logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2) - logTr $ "balanceComments': (anchorFromLocatedA la1)=" ++ showGhc (anchorFromLocatedA la1) - logTr $ "balanceComments': (sort cs2b)=" ++ showAst (sort cs2b) - logTr $ "balanceComments': (move',stay')=" ++ showAst (move',stay') - logTr $ "balanceComments': (move'',stay'')=" ++ showAst (move'',stay'') - logTr $ "balanceComments': (move,stay)=" ++ showAst (move,stay) + logTr $ "balanceComments': (anc1)=" ++ showAst (anc1) + logTr $ "balanceComments': (cs1s)=" ++ showAst (cs1s) + logTr $ "balanceComments': (sort cs1f)=" ++ showAst (sort cs1f) + logTr $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move) + logTr $ "balanceComments': (an1',an2')=" ++ showAst (an1',an2') return (la1', la2') where simpleBreak n (r,_) = r > n @@ -508,19 +576,27 @@ L (SrcSpanAnn an2 loc2) s = la2 anc1 = addCommentOrigDeltas $ epAnnComments an1 anc2 = addCommentOrigDeltas $ epAnnComments an2 - cs1f = getFollowingComments anc1 - cs2b = priorComments anc2 - (stay'',move') = break (simpleBreak 1) (priorCommentsDeltas (anchorFromLocatedA la2) cs2b) + + cs1s = splitCommentsEnd (anchorFromLocatedA la1) anc1 + cs1p = priorCommentsDeltas (anchorFromLocatedA la1) (priorComments cs1s) + cs1f = trailingCommentsDeltas (anchorFromLocatedA la1) (getFollowingComments cs1s) + + cs2s = splitCommentsEnd (anchorFromLocatedA la2) anc2 + cs2p = priorCommentsDeltas (anchorFromLocatedA la2) (priorComments cs2s) + cs2f = trailingCommentsDeltas (anchorFromLocatedA la2) (getFollowingComments cs2s) + + -- Split cs1f into those that belong on an1 and ones that must move to an2 + (cs1move,cs1stay) = break (simpleBreak 1) cs1f + + (stay'',move') = break (simpleBreak 1) cs2p -- Need to also check for comments more closely attached to la1, -- ie trailing on the same line (move'',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchorFromLocatedA la1) (map snd stay'')) - move = map snd (move'' ++ move') - stay = map snd stay' - cs1 = setFollowingComments anc1 (sort $ cs1f ++ move) - cs2 = setPriorComments anc2 stay + move = sortEpaComments $ map snd (cs1move ++ move'' ++ move') + stay = sortEpaComments $ map snd (cs1stay ++ stay') - an1' = setCommentsSrcAnn (getLoc la1) cs1 - an2' = setCommentsSrcAnn (getLoc la2) cs2 + an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced (map snd cs1p) move) + an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced stay (map snd cs2f)) la1' = L an1' f la2' = L an2' s @@ -539,7 +615,7 @@ -- AZ:TODO: this is identical to commentsDeltas priorCommentsDeltas :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] -priorCommentsDeltas anc cs = go anc (reverse $ sort cs) +priorCommentsDeltas anc cs = go anc (reverse $ sortEpaComments cs) where go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] go _ [] = [] @@ -554,21 +630,54 @@ -- | Split comments into ones occuring before the end of the reference -- span, and those after it. -splitComments :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitComments p (EpaComments cs) = cs' +splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsEnd p (EpaComments cs) = cs' where - cmp (L (Anchor l _) _) = ss2pos l < ss2posEnd p + cmp (L (Anchor l _) _) = ss2pos l > ss2posEnd p (before, after) = break cmp cs cs' = case after of [] -> EpaComments cs _ -> EpaCommentsBalanced before after -splitComments p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' +splitCommentsEnd p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' where - cmp (L (Anchor l _) _) = ss2pos l < ss2posEnd p + cmp (L (Anchor l _) _) = ss2pos l > ss2posEnd p (before, after) = break cmp cs cs' = before ts' = after <> ts +-- | Split comments into ones occuring before the start of the reference +-- span, and those after it. +splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsStart p (EpaComments cs) = cs' + where + cmp (L (Anchor l _) _) = ss2pos l > ss2pos p + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> EpaCommentsBalanced before after +splitCommentsStart p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' + where + cmp (L (Anchor l _) _) = ss2pos l > ss2pos p + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +moveLeadingComments :: (Data t, Data u, Monoid t, Monoid u) + => LocatedAn t a -> SrcAnn u -> (LocatedAn t a, SrcAnn u) +moveLeadingComments from@(L (SrcSpanAnn EpAnnNotUsed _) _) to = (from, to) +moveLeadingComments (L la a) lb = (L la' a, lb') + `debug` ("moveLeadingComments: (before, after, la', lb'):" ++ showAst (before, after, la', lb')) + where + split = splitCommentsEnd (realSrcSpan $ locA la) (epAnnComments $ ann la) + before = sortEpaComments $ priorComments split + after = sortEpaComments $ getFollowingComments split + + -- TODO: need to set an entry delta on lb' to zero, and move the + -- original spacing to the first comment. + + la' = setCommentsSrcAnn la (EpaComments after) + lb' = addCommentsToSrcAnn lb (EpaCommentsBalanced before []) + -- | A GHC comment includes the span of the preceding (non-comment) -- token. Takes an original list of comments, and converts the -- 'Anchor's to have a have a `MovedAnchor` operation based on the @@ -610,8 +719,110 @@ then MovedAnchor (DifferentLine 1 0) else op' +spanOrigDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos +spanOrigDelta prior cur = dp + where + (r,c) = ss2posEnd prior + dp = if r == 0 + then (ss2delta (r,c+1) cur) + else (ss2delta (r,c) cur) + -- --------------------------------------------------------------------- +-- TODO: Until https://gitlab.haskell.org/ghc/ghc/-/issues/20715 is +-- fixed we have to special-case a funbind. Damn. +tweakListComments :: LHsDecl GhcPs -> LHsDecl GhcPs +tweakListComments a@(L l (ValD x fb@(FunBind{}))) = tweakListCommentsFB a +tweakListComments a = tweakListComments' a + +-- A LocatedA item may have both trailing comments and trailing list items. +-- Move any relevant comments preceding a list item into an EpaDelta instead. +tweakListComments' :: LocatedA a -> LocatedA a +tweakListComments' (L (SrcSpanAnn EpAnnNotUsed l) a) = L (SrcSpanAnn EpAnnNotUsed l) a +tweakListComments' (L (SrcSpanAnn (EpAnn anc an cs) l) a) = L (SrcSpanAnn (EpAnn anc an' cs') l) a + where + -- Note: until https://gitlab.haskell.org/ghc/ghc/-/issues/20718 is + -- resolved, the comments may be in reverse order. + (an', cs') = case cs of + EpaComments [] -> (an,cs) + EpaComments c -> go (\cc -> EpaComments cc) an (sortEpaComments c) + EpaCommentsBalanced _ [] -> (an,cs) + EpaCommentsBalanced p c -> go (\cc -> EpaCommentsBalanced (sortEpaComments p) cc) an (sortEpaComments c) + + go :: Data b => ([LEpaComment] -> b) + -> AnnListItem + -> [LEpaComment] + -> (AnnListItem, b) + go f (AnnListItem []) c = (AnnListItem [], f c) + go f (AnnListItem lis) c = process f ([],[]) lis (sortEpaComments c) + + process :: Data b => ([LEpaComment] -> b) + -> ([TrailingAnn], [LEpaComment]) + -> [TrailingAnn] + -> [LEpaComment] + -> (AnnListItem, b) + process f (ll,cc) [] cs = (AnnListItem (reverse ll), f (cc++cs)) + process f (ll,cc) li [] = (AnnListItem (reverse $ ll++li), f cc) + process f (ll,cc) (l:li) cs@(L lc c:_) = r + where + r = case trailingAnnLoc l of + EpaSpan s -> r + where + condp (L lc _) = anchor lc >= anchor anc + (before,rest) = break condp cs + cond (L lc _) = anchor lc >= s + (these,those) = break cond rest + r = case these of + [] -> process f (l:ll,cc) li cs + priors -> + -- We have at least one comment preceding the list item + let + -- dp is the delta from the end of the last comment to + -- the start of the AddXXXAnn delta + dp = spanOrigDelta (anchor $ getLoc $ last priors) s + + l' = EpaDelta dp (commentOrigDeltas these) + cs' = those + in + process f (setTrailingAnnLoc l l':ll,before++cc) li cs' + EpaDelta d' cs' -> process f (l:ll,cc) li cs + + +-- TODO: Until https://gitlab.haskell.org/ghc/ghc/-/issues/20715 is +-- fixed we have to special-case a funbind. Damn. +-- The problem seems to depend on whether the funbind has params +-- or not. If not, we can do a normal tweakListComments. +tweakListCommentsFB :: LHsDecl GhcPs -> LHsDecl GhcPs +tweakListCommentsFB (L l (ValD xv (FunBind x n (MG mx (L lm matches) o) t))) = r + where + -- We need to pass any comments from the outer location into the + -- first match for processing + (l',matches') = case matches of + [] -> (l,matches) + (L lm m:ms) -> (l', L lm' m:ms) + `debug` ("tweakListCommentsFB:(l',lm')=" ++ showAst (l',lm')) + -- (L lm m:ms) -> error $ "lm'=\n" ++ showAst lm' + where + (l',cs',as) = case l of + SrcSpanAnn EpAnnNotUsed _ -> (l,[], []) + SrcSpanAnn (EpAnn anc an (EpaComments cs)) l + -> (SrcSpanAnn (EpAnn anc (AnnListItem []) (EpaComments [])) l, cs, lann_trailing an) + SrcSpanAnn (EpAnn anc an (EpaCommentsBalanced ls ts)) l + -> (SrcSpanAnn (EpAnn anc (AnnListItem []) (EpaCommentsBalanced ls [])) l, ts, lann_trailing an) + + lm' = case lm of + SrcSpanAnn EpAnnNotUsed l + -> SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem as) (EpaComments cs')) l + SrcSpanAnn (EpAnn anc (AnnListItem is) (EpaComments cs)) l + -> SrcSpanAnn (EpAnn anc (AnnListItem (as<>is)) (EpaComments (cs'<>cs))) l + SrcSpanAnn (EpAnn anc (AnnListItem is) (EpaCommentsBalanced ls ts)) l + -> SrcSpanAnn (EpAnn anc (AnnListItem (as<>is)) (EpaCommentsBalanced (cs'<>ls) ts)) l + + r = (L l' (ValD xv (FunBind x n (MG mx (L lm (map tweakListComments' matches')) o) t))) +tweakListCommentsFB x = error $ "tweakListCommentsFB for " ++ showAst x + +-- --------------------------------------------------------------------- + balanceSameLineComments :: (Monad m) => LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs)) balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do @@ -638,7 +849,7 @@ gac = addCommentOrigDeltas $ epAnnComments ga gfc = getFollowingComments gac - gac' = setFollowingComments gac (sort $ gfc ++ move) + gac' = setFollowingComments gac (sortEpaComments $ gfc ++ move) ga' = (EpAnn anc an gac') an1' = setCommentsSrcAnn la cs1 @@ -653,6 +864,22 @@ -- --------------------------------------------------------------------- +commentsOrigDeltasDecl :: LHsDecl GhcPs -> LHsDecl GhcPs +commentsOrigDeltasDecl (L (SrcSpanAnn an l) d) = L (SrcSpanAnn an' l) d + where + an' = addCommentOrigDeltasAnn an + +-- --------------------------------------------------------------------- + +-- | Take an anchor and a preceding location, and generate an +-- equivalent one with a 'MovedAnchor' delta. +deltaAnchor :: Anchor -> RealSrcSpan -> Anchor +deltaAnchor (Anchor anc _) ss = Anchor anc (MovedAnchor dp) + where + dp = pos2delta (ss2pos ss) (ss2pos anc) + +-- --------------------------------------------------------------------- + -- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the -- given @DeltaPos@. noAnnSrcSpanDP :: (Monoid ann) => SrcSpan -> DeltaPos -> SrcSpanAnn' (EpAnn ann) @@ -669,13 +896,13 @@ noAnnSrcSpanDPn l s = noAnnSrcSpanDP l (SameLine s) d0 :: EpaLocation -d0 = EpaDelta $ SameLine 0 +d0 = EpaDelta (SameLine 0) [] d1 :: EpaLocation -d1 = EpaDelta $ SameLine 1 +d1 = EpaDelta (SameLine 1) [] dn :: Int -> EpaLocation -dn n = EpaDelta $ SameLine n +dn n = EpaDelta (SameLine n) [] m0 :: AnchorOperation m0 = MovedAnchor $ SameLine 0 @@ -705,7 +932,9 @@ -> Transform ast insertAt f t decl = do oldDecls <- hsDecls t - replaceDecls t (f decl oldDecls) + oldDeclsb <- balanceCommentsList oldDecls + let oldDecls' = map commentsOrigDeltasDecl oldDeclsb + replaceDecls t (f decl oldDecls') -- |Insert a declaration at the beginning or end of the subdecls of the given -- AST item @@ -836,8 +1065,8 @@ let off = case l of (EpaSpan r) -> LayoutStartCol $ snd $ ss2pos r - (EpaDelta (SameLine _)) -> LayoutStartCol 0 - (EpaDelta (DifferentLine _ c)) -> LayoutStartCol c + (EpaDelta (SameLine _) _) -> LayoutStartCol 0 + (EpaDelta (DifferentLine _ c) _) -> LayoutStartCol c ex'' = setEntryDPFromAnchor off i ex newDecls'' = case newDecls of [] -> newDecls @@ -1003,7 +1232,7 @@ oldWhereAnnotation EpAnnNotUsed ww _oldSpan = do newSpan <- uniqueSrcSpanT let w = case ww of - WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0))] + WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] WithoutWhere -> [] let anc2' = Anchor (rs newSpan) (MovedAnchor (SameLine 1)) (anc, anc2) <- do @@ -1018,7 +1247,7 @@ -- TODO: when we set DP (0,0) for the HsValBinds EpEpaLocation, change the AnnList anchor to have the correct DP too let (AnnList ancl o c _r t) = an let w = case ww of - WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0))] + WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] WithoutWhere -> [] (anc', ancl') <- do case ww of @@ -1035,7 +1264,7 @@ let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3)) let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5)) let w = case ww of - WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0))] + WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] WithoutWhere -> [] let an = EpAnn anc (AnnList (Just anc2) Nothing Nothing w []) @@ -1098,5 +1327,79 @@ decls <- liftT $ hsDecls t decls' <- action decls liftT $ replaceDecls t decls' + +-- --------------------------------------------------------------------- + +-- type RWS r w s = RWST r w s Identity +-- runRWS :: Monoid w => RWS r w s a -> r -> s -> (a, s, w) +-- rws :: Monoid w => (r -> s -> (a, s, w)) -> RWS r w s a + +-- -- | Evaluate a computation with the given initial state and environment, +-- -- returning the final value and output, discarding the final state. +-- evalRWS :: (Monoid w) +-- => RWS r w s a -- ^RWS computation to execute +-- -> r -- ^initial environment +-- -> s -- ^initial value +-- -> (a, w) -- ^final value and output + +-- mkM :: (Monad m, Typeable a, Typeable b) => (b -> m b) -> a -> m a + +type Delta a = RWS () [String] (Maybe Anchor) a + + +-- | Generic top-down traversal through the given AST fragment, +-- converting all ExactPrint Anchor's into ones with an equivalent +-- MovedAnchor operation. Initially ignores comments +makeDeltaAst' :: forall a. (Data a) => a -> a +makeDeltaAst' a = fst $ evalRWS (go a) () Nothing + where + go :: a -> Delta a + go = everywhereM' (mkM (locatedAnnImpl @AnnListItem) -- LocatedA + `extM` (locatedAnnImpl @NameAnn) -- LocatedN + `extM` (locatedAnnImpl @AnnList) -- LocatedL + `extM` (locatedAnnImpl @AnnPragma) -- LocatedP + `extM` (locatedAnnImpl @AnnContext) -- LocatedC + ) + + locatedAnnImpl :: forall an. (Monoid an) + => SrcAnn an -> Delta (SrcAnn an) + locatedAnnImpl (SrcSpanAnn (EpAnn anc@(Anchor loc _op) an cs) l) = do + -- error "locatedAnnImpl:EpAnn" + ma <- get + put (Just anc) + let anchor' = case ma of + Nothing -> (Anchor loc (MovedAnchor (SameLine 0))) + Just (Anchor rl _op) -> deltaAnchor anc rl + let cs' = case ma of + Nothing -> cs <> mkComments ("from anc:Nothing") (Anchor loc UnchangedAnchor) + Just anc' -> cs <> mkComments ("from anc:" ++ showGhc anc') anc' + return (SrcSpanAnn (EpAnn anchor' an cs') l) + + locatedAnnImpl (SrcSpanAnn EpAnnNotUsed l) = do + -- error $ "EpAnnNotUsed: " ++ showGhc l + ma <- get + let anc = spanAsAnchor l + put (Just anc) + let anchor' = case ma of + Nothing -> Anchor (realSrcSpan l) (MovedAnchor (SameLine 0)) + Just (Anchor rl _op) -> deltaAnchor anc rl + let cs' = case ma of + Nothing -> mkComments ("EpAnnNotUsed:from anc:Nothing") (spanAsAnchor l) + Just anc' -> mkComments ("EpAnnNotUsed:from anc:" ++ showGhc anc') anc' + return (SrcSpanAnn (EpAnn anchor' mempty cs') l) + +-- | Monadic variation on everywhere', so Apply a monadic +-- transformation everywhere in top-down manner +everywhereM' :: Monad m => GenericM m -> GenericM m +everywhereM' f x + = do x' <- f x + gmapM (everywhereM' f) x' + + +mkComments :: String -> Anchor -> EpAnnComments +mkComments str anc = EpaComments [mkCommentAnc str anc] + +mkCommentAnc :: String -> Anchor -> LEpaComment +mkCommentAnc str anc = L anc (EpaComment (EpaLineComment str) (anchor anc) ) -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs --- a/src/Language/Haskell/GHC/ExactPrint/Types.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs @@ -11,6 +11,7 @@ module Language.Haskell.GHC.ExactPrint.Types where +import Data.Data hiding (Fixity) import GHC hiding (EpaComment) import GHC.Utils.Outputable hiding ( (<>) ) @@ -30,47 +31,26 @@ data Comment = Comment { commentContents :: !String -- ^ The contents of the comment including separators - - -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is - -- the thing we use to decide where in the output stream the comment should - -- go. , commentAnchor :: !Anchor + , commentPriorTok :: !RealSrcSpan , commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly. } - deriving Eq + deriving (Data, Eq) instance Show Comment where - show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showPprUnsafe ss ++ " " ++ show o ++ ")" + show (Comment cs ss r o) + = "(Comment " ++ show cs ++ " " ++ showPprUnsafe ss ++ " " ++ show r ++ " " ++ show o ++ ")" instance Ord Comment where -- When we have CPP injected comments with a fake filename, or LINE -- pragma, the file name changes, so we need to compare the -- locations only, with out the filename. - compare (Comment _ ss1 _) (Comment _ ss2 _) = compare (ss2pos $ anchor ss1) (ss2pos $ anchor ss2) + compare (Comment _ ss1 _ _) (Comment _ ss2 _ _) = compare (ss2pos $ anchor ss1) (ss2pos $ anchor ss2) where ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss) instance Outputable Comment where ppr x = text (show x) - --- | The different syntactic elements which are not represented in the --- AST. -data KeywordId = G AnnKeywordId -- ^ A normal keyword - | AnnSemiSep -- ^ A separating comma - | AnnTypeApp -- ^ Visible type application annotation - | AnnComment Comment - | AnnString String -- ^ Used to pass information from - -- Delta to Print when we have to work - -- out details from the original - -- SrcSpan. - deriving (Eq) - -instance Show KeywordId where - show (G gc) = "(G " ++ show gc ++ ")" - show AnnSemiSep = "AnnSemiSep" - show AnnTypeApp = "AnnTypeApp" - show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")" - show (AnnString s) = "(AnnString " ++ s ++ ")" -- | Marks the start column of a layout block. newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int } diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs --- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs @@ -19,12 +19,14 @@ where import Control.Monad.State import Data.Function +import Data.Maybe import Data.Ord (comparing) import Data.Generics import GHC.Hs.Dump import Language.Haskell.GHC.ExactPrint.Lookup +import Language.Haskell.GHC.ExactPrint.Orphans () import GHC hiding (EpaComment) import qualified GHC @@ -34,8 +36,6 @@ import GHC.Data.FastString import GHC.Utils.Outputable (showSDocUnsafe, showPprUnsafe) -import Control.Arrow - import Data.List (sortBy, elemIndex) import Debug.Trace @@ -80,12 +80,13 @@ -- | A good delta has no negative values. isGoodDelta :: DeltaPos -> Bool isGoodDelta (SameLine co) = co >= 0 -isGoodDelta (DifferentLine ro co) = ro > 0 && co >= 0 +-- isGoodDelta (DifferentLine ro co) = ro > 0 && co >= 0 +isGoodDelta (DifferentLine ro co) = ro > 0 -- Note: DifferentLine invariant is ro is nonzero and positive -- | Create a delta from the current position to the start of the given --- @SrcSpan@. +-- @RealSrcSpan@. ss2delta :: Pos -> RealSrcSpan -> DeltaPos ss2delta ref ss = pos2delta ref (ss2pos ss) @@ -134,15 +135,15 @@ undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp) where (l,c) = undelta (ss2pos anchor) dp (LayoutStartCol 0) - len = length (keywordToString (G kw)) + len = length (keywordToString kw) sp = range2rs ((l,c),(l,c+len)) -- --------------------------------------------------------------------- -adjustDeltaForOffset :: Int -> LayoutStartCol -> DeltaPos -> DeltaPos -adjustDeltaForOffset _ _colOffset dp@(SameLine _) = dp -adjustDeltaForOffset d (LayoutStartCol colOffset) (DifferentLine l c) - = DifferentLine l (c - colOffset - d) +adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos +adjustDeltaForOffset _colOffset dp@(SameLine _) = dp +adjustDeltaForOffset (LayoutStartCol colOffset) (DifferentLine l c) + = DifferentLine l (c - colOffset) -- --------------------------------------------------------------------- @@ -224,31 +225,58 @@ ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _)) = "" tokComment :: LEpaComment -> Comment -tokComment t@(L lt _) = mkComment (normaliseCommentText $ ghcCommentText t) lt +tokComment t@(L lt c) = mkComment (normaliseCommentText $ ghcCommentText t) lt (ac_prior_tok c) -mkLEpaComment :: String -> Anchor -> LEpaComment --- Note: fudging the ac_prior_tok value, hope it does not cause a problem -mkLEpaComment s anc = (L anc (GHC.EpaComment (EpaLineComment s) (anchor anc))) +mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments +mkEpaComments priorCs [] + = EpaComments (map comment2LEpaComment priorCs) +mkEpaComments priorCs postCs + = EpaCommentsBalanced (map comment2LEpaComment priorCs) (map comment2LEpaComment postCs) -mkComment :: String -> Anchor -> Comment -mkComment c anc = Comment c anc Nothing +comment2LEpaComment :: Comment -> LEpaComment +comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r + +mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment +mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r)) + +mkComment :: String -> Anchor -> RealSrcSpan -> Comment +mkComment c anc r = Comment c anc r Nothing + -- Windows comments include \r in them from the lexer. normaliseCommentText :: String -> String normaliseCommentText [] = [] normaliseCommentText ('\r':xs) = normaliseCommentText xs normaliseCommentText (x:xs) = x:normaliseCommentText xs +-- |Must compare without span filenames, for CPP injected comments with fake filename +cmpComments :: Comment -> Comment -> Ordering +cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) + +-- |Sort, comparing without span filenames, for CPP injected comments with fake filename +sortComments :: [Comment] -> [Comment] +sortComments cs = sortBy cmpComments cs + +-- |Sort, comparing without span filenames, for CPP injected comments with fake filename +sortEpaComments :: [LEpaComment] -> [LEpaComment] +sortEpaComments cs = sortBy cmp cs + where + cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) + -- | Makes a comment which originates from a specific keyword. mkKWComment :: AnnKeywordId -> EpaLocation -> Comment mkKWComment kw (EpaSpan ss) - = Comment (keywordToString $ G kw) (Anchor ss UnchangedAnchor) (Just kw) -mkKWComment kw (EpaDelta dp) - = Comment (keywordToString $ G kw) (Anchor placeholderRealSpan (MovedAnchor dp)) (Just kw) + = Comment (keywordToString kw) (Anchor ss UnchangedAnchor) ss (Just kw) +mkKWComment kw (EpaDelta dp _) + = Comment (keywordToString kw) (Anchor placeholderRealSpan (MovedAnchor dp)) placeholderRealSpan (Just kw) -comment2dp :: (Comment, DeltaPos) -> (KeywordId, DeltaPos) -comment2dp = first AnnComment +-- | Detects a comment which originates from a specific keyword. +isKWComment :: Comment -> Bool +isKWComment c = isJust (commentOrigin c) +noKWComments :: [Comment] -> [Comment] +noKWComments = filter (\c -> not (isKWComment c)) + sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a] sortAnchorLocated = sortBy (compare `on` (anchor . getLoc)) @@ -287,9 +315,119 @@ locatedAnAnchor (L (SrcSpanAnn EpAnnNotUsed l) _) = realSrcSpan l locatedAnAnchor (L (SrcSpanAnn (EpAnn a _ _) _) _) = anchor a - -- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- showAst :: (Data a) => a -> String showAst ast = showSDocUnsafe $ showAstData NoBlankSrcSpan NoBlankEpAnnotations ast + +-- --------------------------------------------------------------------- + +setAnchorAn :: (Monoid an) => LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a +setAnchorAn (L (SrcSpanAnn EpAnnNotUsed l) a) anc cs + = (L (SrcSpanAnn (EpAnn anc mempty cs) l) a) + `debug` ("setAnchorAn: anc=" ++ showAst anc) +setAnchorAn (L (SrcSpanAnn (EpAnn _ an _) l) a) anc cs + = (L (SrcSpanAnn (EpAnn anc an cs) l) a) + `debug` ("setAnchorAn: anc=" ++ showAst anc) + +setAnchorEpa :: (Monoid an) => EpAnn an -> Anchor -> EpAnnComments -> EpAnn an +setAnchorEpa EpAnnNotUsed anc cs = EpAnn anc mempty cs +setAnchorEpa (EpAnn _ an _) anc cs = EpAnn anc an cs + +setAnchorEpaL :: EpAnn AnnList -> Anchor -> EpAnnComments -> EpAnn AnnList +setAnchorEpaL EpAnnNotUsed anc cs = EpAnn anc mempty cs +setAnchorEpaL (EpAnn _ an _) anc cs = EpAnn anc (an {al_anchor = Nothing}) cs + +setAnchorHsModule :: HsModule -> Anchor -> EpAnnComments -> HsModule +setAnchorHsModule hsmod anc cs = hsmod { hsmodAnn = an' } + where + -- anc' = anc { anchor_op = MovedAnchor (SameLine 0)} + anc' = anc { anchor_op = UnchangedAnchor } + an' = setAnchorEpa (hsmodAnn hsmod) anc' cs + +-- |Version of l2l that preserves the anchor, immportant if it has an +-- updated AnchorOperation +moveAnchor :: Monoid b => SrcAnn a -> SrcAnn b +moveAnchor (SrcSpanAnn EpAnnNotUsed l) = noAnnSrcSpan l +moveAnchor (SrcSpanAnn (EpAnn anc _ cs) l) = SrcSpanAnn (EpAnn anc mempty cs) l + +-- --------------------------------------------------------------------- +trailingAnnToAddEpAnn :: TrailingAnn -> AddEpAnn +trailingAnnToAddEpAnn (AddSemiAnn ss) = AddEpAnn AnnSemi ss +trailingAnnToAddEpAnn (AddCommaAnn ss) = AddEpAnn AnnComma ss +trailingAnnToAddEpAnn (AddVbarAnn ss) = AddEpAnn AnnVbar ss +trailingAnnToAddEpAnn (AddRarrowAnn ss) = AddEpAnn AnnRarrow ss +trailingAnnToAddEpAnn (AddRarrowAnnU ss) = AddEpAnn AnnRarrowU ss +trailingAnnToAddEpAnn (AddLollyAnnU ss) = AddEpAnn AnnLollyU ss + +trailingAnnLoc :: TrailingAnn -> EpaLocation +trailingAnnLoc (AddSemiAnn ss) = ss +trailingAnnLoc (AddCommaAnn ss) = ss +trailingAnnLoc (AddVbarAnn ss) = ss +trailingAnnLoc (AddRarrowAnn ss) = ss +trailingAnnLoc (AddRarrowAnnU ss) = ss +trailingAnnLoc (AddLollyAnnU ss) = ss + +setTrailingAnnLoc :: TrailingAnn -> EpaLocation -> TrailingAnn +setTrailingAnnLoc (AddSemiAnn _) ss = (AddSemiAnn ss) +setTrailingAnnLoc (AddCommaAnn _) ss = (AddCommaAnn ss) +setTrailingAnnLoc (AddVbarAnn _) ss = (AddVbarAnn ss) +setTrailingAnnLoc (AddRarrowAnn _) ss = (AddRarrowAnn ss) +setTrailingAnnLoc (AddRarrowAnnU _) ss = (AddRarrowAnnU ss) +setTrailingAnnLoc (AddLollyAnnU _) ss = (AddLollyAnnU ss) + + +addEpAnnLoc :: AddEpAnn -> EpaLocation +addEpAnnLoc (AddEpAnn _ l) = l + +-- --------------------------------------------------------------------- + +-- TODO: move this to GHC +anchorToEpaLocation :: Anchor -> EpaLocation +anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r +anchorToEpaLocation (Anchor _ (MovedAnchor dp)) = EpaDelta dp [] + +-- --------------------------------------------------------------------- +-- Horrible hack for dealing with some things still having a SrcSpan, +-- not an Anchor. + +{- +A SrcSpan is defined as + +data SrcSpan = + RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos] + | UnhelpfulSpan !UnhelpfulSpanReason + +data BufSpan = + BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } + deriving (Eq, Ord, Show) + +newtype BufPos = BufPos { bufPos :: Int } + + +We use the BufPos to encode a delta, using bufSpanStart for the line, +and bufSpanEnd for the col. + +To be absolutely sure, we make the delta versions use -ve values. + +-} + +hackSrcSpanToAnchor :: SrcSpan -> Anchor +hackSrcSpanToAnchor (UnhelpfulSpan s) = error $ "hackSrcSpanToAnchor : UnhelpfulSpan:" ++ show s +hackSrcSpanToAnchor (RealSrcSpan r Nothing) = Anchor r UnchangedAnchor +hackSrcSpanToAnchor (RealSrcSpan r (Just (BufSpan (BufPos s) (BufPos e)))) + = if s <= 0 && e <= 0 + then Anchor r (MovedAnchor (deltaPos (-s) (-e))) + else Anchor r UnchangedAnchor + +hackAnchorToSrcSpan :: Anchor -> SrcSpan +hackAnchorToSrcSpan (Anchor r UnchangedAnchor) = RealSrcSpan r Nothing +hackAnchorToSrcSpan (Anchor r (MovedAnchor dp)) + = RealSrcSpan r (Just (BufSpan (BufPos s) (BufPos e))) + where + s = - (getDeltaLine dp) + e = - (deltaColumn dp) + +-- --------------------------------------------------------------------- diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -27,7 +27,7 @@ -- --------------------------------------------------------------------- -data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88 | GHC810 | GHC90 | GHC92 +data GHCVersion = GHC92 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion @@ -37,7 +37,6 @@ testDirs :: [FilePath] testDirs = case ghcVersion of - GHC90 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90"] GHC92 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92"] -- GHC92 -> ["ghc92-copied"] @@ -70,6 +69,30 @@ findTests libdir = testList "Round-trip tests" <$> mapM (findTestsDir id (mkParserTest libdir)) testDirs +findTestsBC :: LibDir -> IO Test +findTestsBC libdir + = testList "Balance comments tests" <$> mapM (findTestsDir filterBC (mkParserTestBC libdir)) testDirs + +-- | Filter out tests that are known to fail, for particular compilers +filterBC :: [FilePath] -> [FilePath] +filterBC fps = sort $ Set.toList $ Set.difference (Set.fromList fps) skipped +-- filterBC fps = error $ "filterBC:fps=" ++ show fps + where + skipped = Set.fromList + [ + "Control.hs", + "Internals.hs", + "LinePragma.hs", + "QuasiQuote.hs", + "RandomPGC.hs", + "HashTab.hs", + "LinePragmas.hs" + ] + +findTestsMD :: LibDir -> IO Test +findTestsMD libdir + = testList "Make Delta tests" <$> mapM (findTestsDir id (mkParserTestMD libdir)) testDirs + findPrettyTests :: LibDir -> IO Test findPrettyTests libdir = testList "Default Annotations round-trip tests" @@ -105,38 +128,46 @@ -- listTests let libdir = GHC.Paths.libdir roundTripTests <- findTests libdir - prettyRoundTripTests <- findPrettyTests libdir + roundTripBalanceCommentsTests <- findTestsBC libdir + roundTripMakeDeltaTests <- findTestsMD libdir + -- prettyRoundTripTests <- findPrettyTests libdir return $ TestList [ - internalTests, - roundTripTests - , + -- internalTests, + -- roundTripTests + -- , (transformTests libdir) , (failingTests libdir) + -- , + -- roundTripBalanceCommentsTests + -- , + -- roundTripMakeDeltaTests + ] + +-- Tests that are no longer needed -- , noAnnotationTests -- , -- prettyRoundTripTests - ] + -- , failingTests :: LibDir -> Test failingTests libdir = testList "Failing tests" [ -- Tests requiring future GHC modifications - -- https://gitlab.haskell.org/ghc/ghc/-/issues/20243 - mkTestModBad libdir "n-plus-k-patterns.hs" - - -- https://gitlab.haskell.org/ghc/ghc/-/issues/20258 - , mkTestModBad libdir "TopLevelSemis.hs" - -- We do not capture EOF location very well any more - , mkTestModBad libdir "T10970a.hs" - + mkTestModBad libdir "T10970a.hs" ] mkParserTest :: LibDir -> FilePath -> FilePath -> Test mkParserTest libdir dir fp = mkParsingTest (roundTripTest libdir) dir fp +mkParserTestBC :: LibDir -> FilePath -> FilePath -> Test +mkParserTestBC libdir dir fp = mkParsingTest (roundTripTestBC libdir) dir fp + +mkParserTestMD :: LibDir -> FilePath -> FilePath -> Test +mkParserTestMD libdir dir fp = mkParsingTest (roundTripTestMD libdir) dir fp + -- --------------------------------------------------------------------- formatTT :: ([([Char], Bool)], [([Char], Bool)]) -> IO () @@ -160,134 +191,12 @@ let libdir = GHC.Paths.libdir runTestText (putTextToHandle stdout True) $ TestList [ - -- mkTestModChange libdir changeRenameCase1 "RenameCase1.hs" - - -- mkParserTest libdir "ghc710" "UnicodeSyntaxFailure.hs" - -- mkParserTest libdir "ghc80" "Class.hs" - -- mkParserTest libdir "ghc82" "Completesig03A.hs" - -- mkParserTest libdir "ghc82" "brackets.hs" - -- mkParserTest libdir "ghc84" "T13747.hs" - -- mkParserTest libdir "ghc86" "SlidingTypeSyn.hs" - - -- mkParserTest libdir "ghc86" "dynamic-paper.hs" - -- mkParserTest libdir "ghc90" "ArrowLambdaCase.hs" - -- mkParserTest libdir "ghc80" "T6018failclosed.hs" - -- mkParserTest libdir "failing" "InfixOperator.hs" - - -- mkParserTest libdir "ghc92-copied" "AddLocalDecl5.expected.hs" - -- mkParserTest libdir "ghc92" "ScopesBug.hs" - -- mkParserTest libdir "ghc92-copied" "T10279.hs" - -- mkParserTest libdir "ghc92-copied" "T10891.hs" - -- mkParserTest libdir "ghc92-copied" "T2632.hs" - -- mkParserTest libdir "ghc92-copied" "T4442.hs" - -- mkParserTest libdir "ghc92-copied" "TH_reifyExplicitForAllFams.hs" - -- mkParserTest libdir "ghc92-copied" "TH_unresolvedInfix.hs" - -- mkParserTest libdir "ghc92-copied" "regalloc_unit_tests.hs" - - -- mkParserTest libdir "ghc92" "Checkpoint.hs" - -- mkParserTest libdir "ghc710" "MultiLineCommentWithPragmas.hs" - - -- mkParserTest libdir "ghc710" "Process.hs" - -- mkParserTest libdir "ghc92" "PostgreSQL.hs" - -- mkParserTest libdir "ghc92" "Main.hs" - -- mkParserTest libdir "ghc92" "MainHareTest.hs" - -- mkParserTest libdir "ghc92" "TH.hs" - -- mkParserTest libdir "ghc92" "LeapSeconds.hs" - -- mkParserTest libdir "ghc92" "proc-lets.hs" - -- mkParserTest libdir "ghc92" "n-plus-k-patterns.hs" - -- mkParserTest libdir "ghc92" "TopLevelSemis.hs" - -- mkParserTest libdir "ghc92" "MiniBall.hs" - - mkParserTest libdir "ghc80" "T10970a.hs" - - - -- mkTestModChange libdir rmDecl1 "RmDecl1.hs" - - -- mkParserTest libdir "ghc92" "LinearArrow.hs" - -- mkParserTest libdir "transform" "AddLocalDecl5.1.hs" - -- mkTestModChange libdir addLocaLDecl5 "AddLocalDecl5.hs" - -- mkTestModChange libdir changeLocalDecls2 "LocalDecls2.hs" - -- mkTestModChange libdir addLocaLDecl1 "AddLocalDecl1.hs" - {- - ### Failure in: 1:Round-trip tests:1:ghc80:27:Decision.hs - ### Failure in: 2:transformation tests:0:Low level transformations:15 - AddLocalDecl1.hs - AddLocalDecl4.hs - AddLocalDecl5.hs - AddLocalDecl6.hs - -} - - -- mkParserTest libdir "ghc710" "EmptyMostly.hs" - - -- comment problem - -- mkParserTest libdir "ghc710" "Move1.hs" - -- mkParserTest libdir "ghc80" "Decision.hs" - -- mkParserTest libdir "ghc80" "RandomPGC.hs" - -- mkParserTest libdir "ghc92" "BlockComment.hs" - -- mkParserTest libdir "ghc92" "CommentPlacement.hs" - -- mkParserTest libdir "ghc92" "CommentPlacement2.hs" - -- mkParserTest libdir "ghc80" "Decision.hs" - - -- mkParserTest libdir "ghc92-copied" "AddLocalDecl5.expected.hs" - -- mkParserTest libdir "ghc92-copied" "AtomicPrimops.hs" - -- mkParserTest libdir "ghc92-copied" "BinaryLiterals0.hs" - -- mkParserTest libdir "ghc92-copied" "CountDeps.hs" - -- mkParserTest libdir "ghc92-copied" "regalloc_unit_tests.hs" - - - --- ### Failure in: 1:Round-trip tests:0:ghc710:20:Control.hs --- ### Failure in: 1:Round-trip tests:0:ghc710:21:CoreIr.hs --- ### Failure in: 1:Round-trip tests:0:ghc710:23:Cpp.hs --- ### Failure in: 1:Round-trip tests:0:ghc710:38:EmptyMostly.hs --- ### Failure in: 1:Round-trip tests:0:ghc710:39:EmptyMostly2.hs --- ### Failure in: 1:Round-trip tests:0:ghc710:40:EmptyMostlyInst.hs --- ### Failure in: 1:Round-trip tests:0:ghc710:41:EmptyMostlyNoSemis.hs --- ### Error in: 1:Round-trip tests:0:ghc710:50:ForeignDecl.hs - - -- mkParserTest libdir "ghc710" "BracesSemiDataDecl.hs" - -- mkParserTest libdir "ghc710" "GADTRecords.hs" - -- mkParserTest libdir "ghc710" "RdrNames.hs" - -- mkParserTest libdir "ghc710" "RdrNames1.hs" - - -- mkParserTest libdir "ghc80" "T11010.hs" - -- mkParserTest libdir "ghc80" "Test10399.hs" - -- mkParserTest libdir "ghc90" "Linear12.hs" - -- mkParserTest libdir "ghc90" "T17544_kw.hs" - - -- mkParserTest libdir "ghc90" "FromManual.hs" - -- mkPrettyRoundtrip libdir "ghc90" "FromManual.hs" - - -- mkParserTest libdir "ghc90" "Linear1Rule.hs" - -- mkPrettyRoundtrip libdir "ghc90" "Linear1Rule.hs" - - -- mkParserTest libdir "ghc80" "Test11018.hs" - -- mkPrettyRoundtrip libdir "ghc80" "Test11018.hs" - - -- mkParserTest libdir "ghc86" "UnicodeSyntax.hs" - -- mkPrettyRoundtrip libdir "ghc86" "UnicodeSyntax.hs" - - -- mkParserTest libdir "ghc86" "empty-foralls.hs" - -- mkPrettyRoundtrip libdir "ghc86" "empty-foralls.hs" - - -- mkParserTest libdir "ghc710" "PatSynBind.hs" - -- mkPrettyRoundtrip libdir "ghc710" "PatSynBind.hs" - - -- --------------------------------------------- - - -- mkParserTest libdir "ghc86" "Webhook.hs" - - -- mkParserTest libdir "ghc710" "TypeBrackets2.hs" - -- mkPrettyRoundtrip libdir "ghc710" "TypeBrackets2.hs" - - -- mkParserTest libdir "ghc710" "DataDecl.hs" - -- mkPrettyRoundtrip libdir "ghc710" "DataDecl.hs" - - -- mkParserTest libdir "ghc90" "BaseDescriptor.hs" - -- mkPrettyRoundtrip libdir "ghc90" "BaseDescriptor.hs" + mkTestModChange libdir rmDecl7 "RmDecl7.hs" - -- mkParserTest libdir "ghc90" "BaseDescriptors2.hs" - -- mkPrettyRoundtrip libdir "ghc90" "BaseDescriptors2.hs" + -- mkTestModChange libdir changeLayoutLet2 "LayoutLet2.hs" + -- mkParserTestMD libdir "transform" "LayoutLet2.hs" + -- mkParserTest libdir "ghc80" "T10970a.hs" + -- mkParserTestBC libdir "ghc710" "Control.hs" -- Needs GHC changes diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs --- a/tests/Test/Common.hs +++ b/tests/Test/Common.hs @@ -12,6 +12,8 @@ , ParseFailure(..) , ReportType(..) , roundTripTest + , roundTripTestBC + , roundTripTestMD , mkParsingTest , getModSummaryForFile @@ -20,6 +22,7 @@ , Changer , genTest , noChange + , changeMakeDelta , mkDebugOutput , showErrorMessages , LibDir @@ -31,31 +34,23 @@ import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Preprocess --- import Language.Haskell.GHC.ExactPrint.Types import qualified Control.Monad.IO.Class as GHC import qualified GHC as GHC hiding (parseModule) import qualified GHC.Data.Bag as GHC import qualified GHC.Driver.Session as GHC import qualified GHC.Utils.Error as GHC --- import qualified GHC.Utils.Outputable as GHC --- import qualified GHC.Hs.Dump as GHC import qualified GHC.LanguageExtensions as LangExt --- import qualified Data.Map as Map - import Control.Monad import Data.List hiding (find) import System.Directory --- import Test.Consistency - import Test.HUnit import System.FilePath --- import Debug.Trace testPrefix :: FilePath testPrefix = "." "tests" "examples" @@ -81,29 +76,16 @@ Success | RoundTripFailure deriving (Eq, Show) -{- -runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a -runParser parser flags filename str = GHC.unP parser parseState - where - location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1 - buffer = GHC.stringToStringBuffer str - parseState = GHC.mkPState flags buffer location -parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GhcPs)) -parseFile = runParser GHC.parseModule - -mkApiAnns :: GHC.PState -> GHC.ApiAnns -mkApiAnns pstate = (Map.fromListWith (++) . GHC.annotations $ pstate - , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : (GHC.annotations_comments pstate))) - -removeSpaces :: String -> String -removeSpaces = map (\case {'\160' -> ' '; s -> s}) --} - roundTripTest :: LibDir -> FilePath -> IO Report roundTripTest libdir f = genTest libdir noChange f f +roundTripTestBC :: LibDir -> FilePath -> IO Report +roundTripTestBC libdir f = genTest libdir changeBalanceComments f f +roundTripTestMD :: LibDir -> FilePath -> IO Report +roundTripTestMD libdir f = genTest libdir changeMakeDelta f f + mkParsingTest :: (FilePath -> IO Report) -> FilePath -> FilePath -> Test mkParsingTest tester dir fp = let basename = testPrefix dir fp @@ -118,14 +100,23 @@ forM_ (cppStatus r) writeHsPP assertBool fp (status r == Success)) - --- type Changer = (Anns -> GHC.ParsedSource -> IO (Anns,GHC.ParsedSource)) --- First param is libdir type Changer = LibDir -> (GHC.ParsedSource -> IO GHC.ParsedSource) noChange :: Changer noChange _libdir parsed = return parsed +changeBalanceComments :: Changer +changeBalanceComments _libdir (GHC.L l p) = do + let decls0 = GHC.hsmodDecls p + (decls,_,w) = runTransform (balanceCommentsList decls0) + let p2 = p { GHC.hsmodDecls = decls} + debugM $ "changeBalanceComments:\n" ++ unlines w + return (GHC.L l p2) + +changeMakeDelta :: Changer +changeMakeDelta _libdir m = do + return (makeDeltaAst m) + genTest :: LibDir -> Changer -> FilePath -> FilePath -> IO Report genTest libdir f origFile expectedFile = do res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions origFile @@ -212,14 +203,5 @@ showErrorMessages :: GHC.ErrorMessages -> String showErrorMessages m = show $ GHC.bagToList m - --- --------------------------------------------------------------------- - --- instance GHC.Outputable GHC.ApiAnns where --- ppr (GHC.ApiAnns items eof comments rogueComments) --- = GHC.text "ApiAnns" GHC.<+> GHC.ppr items --- GHC.<+> GHC.ppr eof --- GHC.<+> GHC.ppr comments --- GHC.<+> GHC.ppr rogueComments -- --------------------------------------------------------------------- diff --git a/tests/Test/NoAnnotations.hs b/tests/Test/NoAnnotations.hs --- a/tests/Test/NoAnnotations.hs +++ b/tests/Test/NoAnnotations.hs @@ -90,7 +90,7 @@ let priorComments = GHC.priorComments $ GHC.epAnnComments $ GHC.hsmodAnn $ GHC.unLoc parsedOrig -- let comments = map tokComment $ GHC.sortRealLocated priorComments let comments = map tokComment priorComments - let pragmas = filter (\(Comment c _ _) -> isPrefixOf "{-#" c ) comments + let pragmas = filter (\(Comment c _ _ _) -> isPrefixOf "{-#" c ) comments let pragmaStr = intercalate "\n" $ map commentContents pragmas let !printed = pragmaStr ++ "\n" ++ exactPrint parsedOrig diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -1,6 +1,9 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} + + -- Many of the tests match on a specific expected value,the other patterns should trigger a fail +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Test.Transform where import Language.Haskell.GHC.ExactPrint @@ -68,6 +71,9 @@ mkTestModBad libdir file = mkTestMod libdir "bad" "failing" noChange file +mkTestModBadMD :: LibDir -> FilePath -> Test +mkTestModBadMD libdir file + = mkTestMod libdir "bad" "failing" changeMakeDelta file mkTestMod :: LibDir -> String -> FilePath -> Changer -> FilePath -> Test mkTestMod libdir suffix dir f fp = @@ -169,13 +175,13 @@ -- | Add a local declaration with signature to LocalDecl, where there was no -- prior local decl. So it adds a "where" annotation. changeLocalDecls2 :: Changer -changeLocalDecls2 libdir (L l p) = do +changeLocalDecls2 libdir top = do Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") - let decl' = setEntryDP (L ld decl) (DifferentLine 1 0) - let sig' = setEntryDP (L ls sig) (SameLine 2) - let (p',_,_w) = runTransform doAddLocal - doAddLocal = everywhereM (mkM replaceLocalBinds) p + let decl' = setEntryDP (makeDeltaAst (L ld decl)) (DifferentLine 1 0) + let sig' = setEntryDP (makeDeltaAst (L ls sig)) (SameLine 2) + let (top',_,_w) = runTransform doAddLocal + doAddLocal = everywhereM (mkM replaceLocalBinds) (makeDeltaAst top) replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do @@ -184,15 +190,16 @@ let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5))) let an = EpAnn anc (AnnList (Just anc2) Nothing Nothing - [(undeltaSpan (rs newSpan) AnnWhere (SameLine 0))] []) + [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] []) emptyComments let decls = [s,d] let sortKey = captureOrder decls let binds = (HsValBinds an (ValBinds sortKey (listToBag $ [decl']) [sig'])) - return (L lm (Match ma mln pats (GRHSs noExtField rhs binds))) + return (L lm (Match ma mln pats (GRHSs emptyComments rhs binds))) replaceLocalBinds x = return x - return (L l p') + -- return (L l p') + return top' -- --------------------------------------------------------------------- @@ -233,13 +240,14 @@ -- | Add a local declaration with signature to LocalDecl changeLocalDecls :: Changer -changeLocalDecls libdir (L l p) = do +changeLocalDecls libdir top = do Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - let decl' = setEntryDP (L ld decl) (DifferentLine 1 0) - let sig' = setEntryDP (L ls sig) (SameLine 0) - let (p',_,_w) = runTransform doAddLocal - doAddLocal = everywhereM (mkM replaceLocalBinds) p + let decl' = setEntryDP (makeDeltaAst (L ld decl)) (DifferentLine 1 0) + let sig' = setEntryDP (makeDeltaAst (L ls sig)) (SameLine 0) + -- let (p',_,_w) = runTransform doAddLocal + let (top',_,_w) = runTransform doAddLocal + doAddLocal = everywhereM (mkM replaceLocalBinds) (makeDeltaAst top) replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ binds sigs))))) = do @@ -250,15 +258,18 @@ (os:oldSigs) = concatMap decl2Sig oldDecls' os' = setEntryDP os (DifferentLine 2 0) let sortKey = captureOrder decls - let (EpAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van - let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 5)))) a b c dd) cs) + -- let (EpAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van + -- let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 5)))) a b c dd) cs) + let (EpAnn anc (AnnList _ a b c dd) cs) = van + let van' = (EpAnn anc (AnnList (Just (Anchor (anchor anc) (MovedAnchor (DifferentLine 1 5)))) a b c dd) cs) let binds' = (HsValBinds van' (ValBinds sortKey (listToBag $ decl':oldBinds) (sig':os':oldSigs))) - return (L lm (Match an mln pats (GRHSs noExtField rhs binds'))) + return (L lm (Match an mln pats (GRHSs emptyComments rhs binds'))) replaceLocalBinds x = return x - return (L l p') + -- return (L l p') + return top' -- --------------------------------------------------------------------- @@ -280,9 +291,11 @@ changeAddDecl :: Changer changeAddDecl libdir top = do Right decl <- withDynFlags libdir (\df -> parseDecl df "" "nn = n2") - let decl' = setEntryDP decl (DifferentLine 2 0) + -- let decl' = setEntryDP decl (DifferentLine 2 0) + let decl' = setEntryDP (makeDeltaAst decl) (DifferentLine 2 0) let (p',_,_) = runTransform doAddDecl + -- doAddDecl = everywhereM (mkM replaceTopLevelDecls) (makeDeltaAst top) doAddDecl = everywhereM (mkM replaceTopLevelDecls) top replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource replaceTopLevelDecls m = insertAtStart m decl' @@ -342,9 +355,9 @@ changeLayoutLet5 _libdir parsed = return (rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed) -rename :: (Data a) => String -> [(Pos, Pos)] -> a -> a +rename :: (ExactPrint a, Data a) => String -> [(Pos, Pos)] -> a -> a rename newNameStr spans' a - = everywhere (mkT replaceRdr) a + = everywhere (mkT replaceRdr) (makeDeltaAst a) where newName = mkRdrUnqual (mkVarOcc newNameStr) @@ -370,7 +383,7 @@ changeWhereIn4 :: Changer changeWhereIn4 _libdir parsed - = return (everywhere (mkT replace) parsed) + = return (everywhere (mkT replace) (makeDeltaAst parsed)) where replace :: LocatedN RdrName -> LocatedN RdrName replace (L ln _n) @@ -393,7 +406,7 @@ changeLetIn1 :: Changer changeLetIn1 _libdir parsed - = return (everywhere (mkT replace) parsed) + = return (everywhere (mkT replace) (makeDeltaAst parsed)) where replace :: HsExpr GhcPs -> HsExpr GhcPs replace (HsLet (EpAnn anc (AnnsLet l _i) cs) localDecls expr) @@ -404,7 +417,7 @@ (L (SrcSpanAnn _ le) e) = expr a = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan le) (MovedAnchor (SameLine 1))) mempty emptyComments) le) expr' = L a e - in (HsLet (EpAnn anc (AnnsLet l (EpaDelta (DifferentLine 1 0))) cs) + in (HsLet (EpAnn anc (AnnsLet l (EpaDelta (DifferentLine 1 0) [])) cs) (HsValBinds x (ValBinds xv bagDecls' sigs)) expr') replace x = x @@ -427,8 +440,10 @@ , mkTestModChange libdir rmDecl4 "RmDecl4.hs" , mkTestModChange libdir rmDecl5 "RmDecl5.hs" , mkTestModChange libdir rmDecl6 "RmDecl6.hs" - , mkTestModChange libdir rmDecl7 "RmDecl7.hs" + -- Currently failing, arguable output + -- , mkTestModChange libdir rmDecl7 "RmDecl7.hs" + , mkTestModChange libdir rmTypeSig1 "RmTypeSig1.hs" , mkTestModChange libdir rmTypeSig2 "RmTypeSig2.hs" @@ -458,9 +473,9 @@ addLocaLDecl1 :: Changer addLocaLDecl1 libdir lp = do Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - let decl' = setEntryDP (L ld decl) (DifferentLine 1 5) + let decl' = setEntryDP (makeDeltaAst (L ld decl)) (DifferentLine 1 5) doAddLocal = do - (de1:d2:d3:_) <- hsDecls lp + (de1:d2:d3:_) <- hsDecls (makeDeltaAst lp) (de1'',d2') <- balanceComments de1 d2 (de1',_) <- modifyValD (getLocA de1'') de1'' $ \_m d -> do return ((wrapDecl decl' : d),Nothing) @@ -496,11 +511,12 @@ Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let doAddLocal = do + -- (de1:d2:_) <- hsDecls (makeDeltaAst lp) (de1:d2:_) <- hsDecls lp (de1'',d2') <- balanceComments de1 d2 (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do - newDecl' <- transferEntryDP' d newDecl + newDecl' <- transferEntryDP' d (makeDeltaAst newDecl) let d' = setEntryDP d (DifferentLine 1 0) return ((newDecl':d':ds),Nothing) @@ -539,11 +555,11 @@ Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let doAddLocal = do - (de1:d2:_) <- hsDecls lp + (de1:d2:_) <- hsDecls (makeDeltaAst lp) (de1'',d2') <- balanceComments de1 d2 (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do - let newDecl' = setEntryDP newDecl (DifferentLine 1 0) + let newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 0) return (((d:ds) ++ [newDecl']),Nothing) replaceDecls (anchorEof lp) [parent',d2'] @@ -583,10 +599,10 @@ Right newSig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let doAddLocal = do - (parent:ds) <- hsDecls lp + (parent:ds) <- hsDecls (makeDeltaAst lp) - let newDecl' = setEntryDP newDecl (DifferentLine 1 0) - let newSig' = setEntryDP newSig (DifferentLine 1 5) + let newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 0) + let newSig' = setEntryDP (makeDeltaAst newSig) (DifferentLine 1 5) (parent',_) <- modifyValD (getLocA parent) parent $ \_m decls -> do return ((decls++[newSig',newDecl']),Nothing) @@ -619,7 +635,7 @@ addLocaLDecl5 _libdir lp = do let doAddLocal = do - decls <- hsDecls lp + decls <- hsDecls (makeDeltaAst lp) [s1,de1,d2,d3] <- balanceCommentsList decls let d3' = setEntryDP d3 (DifferentLine 2 0) @@ -659,8 +675,9 @@ addLocaLDecl6 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3") let - newDecl' = setEntryDP newDecl (DifferentLine 1 5) + newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 5) doAddLocal = do + -- decls0 <- hsDecls (makeDeltaAst lp) decls0 <- hsDecls lp [de1'',d2] <- balanceCommentsList decls0 @@ -675,40 +692,18 @@ (lp',_,_w) <- runTransformT doAddLocal debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" return lp' --- --------------------------------------------------------------------- --- rmDecl1 :: Changer --- rmDecl1 ans lp = do --- let doRmDecl = do --- tlDecs <- hsDecls lp --- let (d1:s1:d2:ds) = tlDecs - --- -- First delete the decl (d2) only --- balanceComments s1 d2 -- ++AZ++ --- balanceComments d2 (head ds) --- lp1 <- replaceDecls lp (d1:s1:ds) --- -- return lp1 - --- -- Then delete the sig separately --- tlDecs1 <- hsDecls lp1 --- let (d1':s1':ds') = tlDecs1 --- -- transferEntryDPT s1' (head ds') -- required in HaRe. --- balanceComments d1' s1' --- balanceComments s1' (head ds') --- transferEntryDPT s1' (head ds') -- required in HaRe. --- replaceDecls lp (d1':ds') - --- (lp',(ans',_),_w) <- runTransformT ans doRmDecl --- return (ans',lp') +-- --------------------------------------------------------------------- rmDecl1 :: Changer rmDecl1 _libdir lp = do let doRmDecl = do tlDecs0 <- hsDecls lp - tlDecs <- balanceCommentsList $ captureLineSpacing tlDecs0 - let (de1:_s1:_d2:ds) = tlDecs + tlDecs <- balanceCommentsList tlDecs0 + let (de1:_s1:_d2:d3:ds) = tlDecs + let d3' = setEntryDP d3 (DifferentLine 2 0) - replaceDecls lp (de1:ds) + replaceDecls lp (de1:d3':ds) (lp',_,_w) <- runTransformT doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" @@ -747,7 +742,7 @@ return e' go x = return x - everywhereM (mkM go) lp + everywhereM (mkM go) (makeDeltaAst lp) let (lp',_,_w) = runTransform doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" @@ -774,6 +769,7 @@ rmDecl3 _libdir lp = do let doRmDecl = do + -- [de1,d2] <- hsDecls (makeDeltaAst lp) [de1,d2] <- hsDecls lp (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1] -> do @@ -810,7 +806,8 @@ rmDecl4 _libdir lp = do let doRmDecl = do - [de1] <- hsDecls lp + let lpd = (makeDeltaAst lp) + [de1] <- hsDecls lpd (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1,sd2] -> do sd2' <- transferEntryDP' sd1 sd2 @@ -818,11 +815,12 @@ let sd1' = setEntryDP sd1 (DifferentLine 2 0) return ([sd2'],Just sd1') - replaceDecls (anchorEof lp) [de1',sd1] + replaceDecls (anchorEof lpd) [de1',sd1] (lp',_,_w) <- runTransformT doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" return lp' + -- --------------------------------------------------------------------- -- rmDecl5 :: Changer @@ -859,6 +857,7 @@ return (HsLet a lb' expr) go x = return x + -- everywhereM (mkM go) (makeDeltaAst lp) everywhereM (mkM go) lp let (lp',_,_w) = runTransform doRmDecl @@ -889,7 +888,7 @@ rmDecl6 _libdir lp = do let doRmDecl = do - [de1] <- hsDecls lp + [de1] <- hsDecls (makeDeltaAst lp) (de1',_) <- modifyValD (getLocA de1) de1 $ \_m subDecs -> do let (ss1:_sd1:sd2:sds) = subDecs @@ -926,6 +925,7 @@ rmDecl7 _libdir lp = do let doRmDecl = do + -- tlDecs <- hsDecls (makeDeltaAst lp) tlDecs <- hsDecls lp [s1,de1,d2,d3] <- balanceCommentsList tlDecs @@ -952,6 +952,7 @@ rmTypeSig1 :: Changer rmTypeSig1 _libdir lp = do let doRmDecl = do + -- tlDecs <- hsDecls (makeDeltaAst lp) tlDecs <- hsDecls lp let (s0:de1:d2) = tlDecs s1 = captureTypeSigSpacing s0 @@ -984,10 +985,11 @@ rmTypeSig2 :: Changer rmTypeSig2 _libdir lp = do let doRmDecl = do + -- tlDecs <- hsDecls (makeDeltaAst lp) tlDecs <- hsDecls lp let [de1] = tlDecs - (de1',_) <- modifyValD (getLocA de1) de1 $ \_m [s,d] -> do + (de1',_) <- modifyValD (getLocA de1) de1 $ \_m [_s,d] -> do return ([d],Nothing) replaceDecls lp [de1'] @@ -1080,11 +1082,11 @@ let [L li imp1] = hsmodImports p Just (_,L lh ns) = ideclHiding imp1 - lh' = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan (locA lh)) m0) + lh' = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan (locA lh)) m1) (AnnList Nothing (Just (AddEpAnn AnnOpenP d1)) (Just (AddEpAnn AnnCloseP d0)) - [(AddEpAnn AnnHiding d1)] + [(AddEpAnn AnnHiding d0)] []) emptyComments) (locA lh)) n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1")) @@ -1105,7 +1107,7 @@ cloneDecl1 :: Changer cloneDecl1 _libdir lp = do let doChange = do - tlDecs <- hsDecls lp + tlDecs <- hsDecls (makeDeltaAst lp) let (d1':d2:ds) = tlDecs -- d2' <- fst <$> cloneT d2 let d2' = d2 diff --git a/tests/examples/failing/TopLevelSemis.hs b/tests/examples/failing/TopLevelSemis.hs deleted file mode 100644 --- a/tests/examples/failing/TopLevelSemis.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -module Network.MoHWS.HTTP.Header where - -x = 1 - --- Comment -; - -data Foo = Foo - --- After TyClD -; - -instance Monoid CIRB where - mempty = CIRB mempty mempty mempty mempty - --- After InstD -; - -deriving instance Eq (GenTickish 'TickishPassCore) - --- After DerivD -; - -transferCodingStr DeflateTransferCoding = "deflate" - --- After ValD -; - -getContentType :: Int - --- After SigD -; - -type MyMaybe :: Type -> Type - --- After KindSigD -; - -default (Integer) - --- After DefD -; - -foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int - --- After ForD -; - -{-# DEPRECATED foo2 [] #-} - --- After WarningD -; - -{-# ANN module FromA #-} - --- After AnnD -; - -{-# RULES "myrule2" id f = f #-} - --- After RuleD -; - -$foo - --- After SpliceD -; - -type role Representational representational - --- After RoleAnnotD -; - -getContentType = 1 - --- Note: skipping DocD, only generated in haddock mode - diff --git a/tests/examples/failing/TopLevelSemis.hs.bad b/tests/examples/failing/TopLevelSemis.hs.bad deleted file mode 100644 --- a/tests/examples/failing/TopLevelSemis.hs.bad +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -module Network.MoHWS.HTTP.Header where - -x = 1 - - -; - - -data Foo = Foo - - -; - - -instance Monoid CIRB where - mempty = CIRB mempty mempty mempty mempty - - -; - - -deriving instance Eq (GenTickish 'TickishPassCore) - - -; - - -transferCodingStr DeflateTransferCoding = "deflate" - - -; - - -getContentType :: Int - - -; - - -type MyMaybe :: Type -> Type - - -; - - -default (Integer) - - -; - - -foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int - - -; - - -{-# DEPRECATED foo2 [] #-} - - -; - - -{-# ANN module FromA #-} - - -; - - -{-# RULES "myrule2" id f = f #-} - - -; - - -$foo - - -; - - -type role Representational representational - - -; - - -getContentType = 1 - --- Note: skipping DocD, only generated in haddock mode - diff --git a/tests/examples/failing/n-plus-k-patterns.hs b/tests/examples/failing/n-plus-k-patterns.hs deleted file mode 100644 --- a/tests/examples/failing/n-plus-k-patterns.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE NPlusKPatterns #-} -singleline :: Int -singleline (n + 1) = n - -multiline :: Int -multiline(n - + 1) = n - -n :: Int -(n + 1) = 3 - diff --git a/tests/examples/failing/n-plus-k-patterns.hs.bad b/tests/examples/failing/n-plus-k-patterns.hs.bad deleted file mode 100644 --- a/tests/examples/failing/n-plus-k-patterns.hs.bad +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE NPlusKPatterns #-} -singleline :: Int -singleline (n 1) = n - -multiline :: Int -multiline(n - 1) = n - -n :: Int -(n 1) = 3 - diff --git a/tests/examples/ghc710/Stmts.hs b/tests/examples/ghc710/Stmts.hs --- a/tests/examples/ghc710/Stmts.hs +++ b/tests/examples/ghc710/Stmts.hs @@ -1,22 +1,26 @@ module Stmts where -- Make sure we get all the semicolons in statements - +;;;; ;; +import Data.List +; ; ; +import Data.Maybe + ; ;; foo :: IO () foo = do do { ;;;; a } a - +; ;; bar :: IO () bar = do - { ; + { ; ; a ;; b } - + ; ;; ; baz :: IO () baz = do { ;; s ; s ; ; s ;; } - +; a = undefined b = undefined s = undefined diff --git a/tests/examples/ghc92/AdhocRule.hs b/tests/examples/ghc92/AdhocRule.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/AdhocRule.hs @@ -0,0 +1,3 @@ +{-# RULES "adhoc1" forall r i. r { rOne = i } = r { rOne = i + 12 } #-} +{-# RULES "adhoc2" forall s. Record { rTwo = s } = Record { rTwo = s ++ s } #-} + diff --git a/tests/examples/ghc92/BalanceComments1.hs b/tests/examples/ghc92/BalanceComments1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/BalanceComments1.hs @@ -0,0 +1,11 @@ +module BalanceComments1 where + +-- Captured in https://gitlab.haskell.org/ghc/ghc/-/issues/20297 +-- The '-- do stuff' comment is attached to the wrong annotation + +-- Chris done comment attachment problem +foo = x + where -- do stuff + doStuff = do stuff +x = 1 +stuff = 4 diff --git a/tests/examples/ghc92/CommentOrder.hs b/tests/examples/ghc92/CommentOrder.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/CommentOrder.hs @@ -0,0 +1,7 @@ +module CommentOrder where + +x = 1 + +-- First +-- Second +-- Third diff --git a/tests/examples/ghc92/CommentPlacement3.hs b/tests/examples/ghc92/CommentPlacement3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/CommentPlacement3.hs @@ -0,0 +1,7 @@ +module CommentPlacement where + +--a comment +x = y1 +--b comment +y = x1 +--c comment diff --git a/tests/examples/ghc92/ConPat.hs b/tests/examples/ghc92/ConPat.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/ConPat.hs @@ -0,0 +1,5 @@ +module ConPat where + +{-# RULES +"infix" forall a. let x1:x2:xs = flipFirst a in f x2 x1 = let x1:x2:xs = a in f x1 x2 + #-} diff --git a/tests/examples/ghc92/ConstructorComment.hs b/tests/examples/ghc92/ConstructorComment.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/ConstructorComment.hs @@ -0,0 +1,7 @@ +module ConstructorComment where + + +data instance Method PGMigration = MigrationQuery Query + -- ^ Run a query against the database + | MigrationCode (Connection -> IO (Either String ())) + -- ^ Run any arbitrary IO code diff --git a/tests/examples/ghc92/DataDecl.hs b/tests/examples/ghc92/DataDecl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/DataDecl.hs @@ -0,0 +1,9 @@ +module DataDecl where + +data FileGlob + -- | No glob at all, just an ordinary file + = NoGlob FilePath + + -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to + -- @FileGlob \"foo\/bar\" \".baz\"@ + | FileGlob FilePath String diff --git a/tests/examples/ghc92/DependentStmt.hs b/tests/examples/ghc92/DependentStmt.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/DependentStmt.hs @@ -0,0 +1,10 @@ +module DependentStmt where + +-- This test rewrites foo to baz, but only in scope of 'y'. + +main :: IO () +main = do + x <- bar 7 + foo x + y <- bar 54 + baz y diff --git a/tests/examples/ghc92/Import.hs b/tests/examples/ghc92/Import.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/Import.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ImportQualifiedPost #-} +module Import where + +import safe A +import qualified B as B +import B qualified as B +import C hiding (a,b) +import D (x,y) +import Data.List as L ( intersperse ) +import "base" Prelude hiding (String) diff --git a/tests/examples/ghc92/IndentedComments.hs b/tests/examples/ghc92/IndentedComments.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/IndentedComments.hs @@ -0,0 +1,12 @@ +module IndentedComments where + +-- | 'ls_get strsMany n' ls_get strs 'n' elements in order, without blowing the stack. +ls_getMany strs n = go [] n + where + go xs 0 = return $! reverse xs + go xs i = do x <- ls_get strs + -- indented comment + x `seq` go (x:xs) (i-1) + +-- compat newtype for deserialization of v2-v4 CaptureData +newtype IntLen a = IntLen { fromIntLen :: a } diff --git a/tests/examples/ghc92/LinePragmas.hs b/tests/examples/ghc92/LinePragmas.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/LinePragmas.hs @@ -0,0 +1,7 @@ +module LinePragmas where + +x = 1 +-- Comment 1 +{-# LINE 93 "Foo.chs" #-} +-- Comment 2 +y = 2 diff --git a/tests/examples/ghc92/ListComments.hs b/tests/examples/ghc92/ListComments.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/ListComments.hs @@ -0,0 +1,5 @@ +module ListComments where + +foo :: Int -- nonterm + -> IO Int +foo = undefined diff --git a/tests/examples/ghc92/Observer1.hs b/tests/examples/ghc92/Observer1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/Observer1.hs @@ -0,0 +1,10 @@ +module Observer1 where + +instance HasPdu (ObserverRegistry event) where + data Pdu (ObserverRegistry event) r where + --a comment + RegisterObserver :: Int + --b comment + ForgetObserver :: Int + --c comment + deriving (Typeable) diff --git a/tests/examples/ghc92/ParensGADT.hs b/tests/examples/ghc92/ParensGADT.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/ParensGADT.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +module ParensGADT where + +-- | Base Descriptor Class Tags TODO rename to xxxTag +data ClassTag (tag :: Nat) where + M4MuxChannelDescr ::ClassTag 0x69 + ExtDescrTag :: ( forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n) + OCIDescrTag :: ((forall (n :: Nat) . (0x40 <= n, n <= 0x5F) => ClassTag n)) + +-- End of file comment diff --git a/tests/examples/ghc92/PragmaSpans.hs b/tests/examples/ghc92/PragmaSpans.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/PragmaSpans.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE GADTs #-} +module PragmaSpans where + +-- The following pragma gets the wrong previous span. +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/20720 +{-# LANGUAGE TypeFamilies #-} diff --git a/tests/examples/ghc92/Records.hs b/tests/examples/ghc92/Records.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/Records.hs @@ -0,0 +1,14 @@ +module Records where + +data Record = Record + { rOne :: Int + , rTwo :: String + } + +defR :: Record +defR = Record 1 "record" + +main :: IO () +main = do + print $ defR { rOne = 42 } + print $ Record { rTwo = "foo" } diff --git a/tests/examples/ghc92/Records2.hs b/tests/examples/ghc92/Records2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/Records2.hs @@ -0,0 +1,14 @@ +module Records where + +data Record = Record + { rOne :: Int + , rTwo :: String + } + +defR :: Record +defR = Record 1 "record" + +main :: IO () +main = do + print $ defR { rOne = 42 + 12 } + print $ Record { rTwo = "foo" ++ "foo" } diff --git a/tests/examples/ghc92/Retrie.hs b/tests/examples/ghc92/Retrie.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/Retrie.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedSums #-} +module Types4a where + +import Data.Maybe hiding (f1,f2,n1,n2) + +type Foo5 = forall r (a :: Type) (b :: TYPE r). (a -> b) -> a -> b + +foo5 :: forall s (c :: Type) (d :: TYPE s). (c -> d) -> c -> d +foo5 = ($) diff --git a/tests/examples/ghc92/RmDecl4.hs b/tests/examples/ghc92/RmDecl4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/RmDecl4.hs @@ -0,0 +1,9 @@ +module RmDecl4 where + +-- Remove first declaration from a where clause, last should still be indented +ff y = y + zz + xx + where + zz = 1 -- comment + xx = 2 + +-- EOF diff --git a/tests/examples/ghc92/TH2.hs b/tests/examples/ghc92/TH2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/TH2.hs @@ -0,0 +1,8 @@ +{- Bloc comment +-} + +{-# LANGUAGE PolyKinds #-} + +module Language.Grammars.AspectAG.TH where + +import Data.GenRec diff --git a/tests/examples/ghc92/TH_reifyDecl1a.hs b/tests/examples/ghc92/TH_reifyDecl1a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/TH_reifyDecl1a.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeFamilies, TypeApplications, PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TH_reifyDecl1 where + +test :: () +test = $(let + display :: Name -> Q () + display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) } + in do { display ''T + ; display ''DF3 + ; [| () |] }) + diff --git a/tests/examples/ghc92/TopLevelSemis.hs b/tests/examples/ghc92/TopLevelSemis.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/TopLevelSemis.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +module Network.MoHWS.HTTP.Header where + +x = 1 + +-- Comment +; + +data Foo = Foo + +-- After TyClD +; + +instance Monoid CIRB where + mempty = CIRB mempty mempty mempty mempty + +-- After InstD +; + +deriving instance Eq (GenTickish 'TickishPassCore) + +-- After DerivD +; + +transferCodingStr DeflateTransferCoding = "deflate" + +-- After ValD +; + +getContentType :: Int + +-- After SigD +; + +type MyMaybe :: Type -> Type + +-- After KindSigD +; + +default (Integer) + +-- After DefD +; + +foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int + +-- After ForD +; + +{-# DEPRECATED foo2 [] #-} + +-- After WarningD +; + +{-# ANN module FromA #-} + +-- After AnnD +; + +{-# RULES "myrule2" id f = f #-} + +-- After RuleD +; + +$foo + +-- After SpliceD +; + +type role Representational representational + +-- After RoleAnnotD +; + +getContentType = 1 + +-- Note: skipping DocD, only generated in haddock mode + diff --git a/tests/examples/ghc92/TopLevelSemis1.hs b/tests/examples/ghc92/TopLevelSemis1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/TopLevelSemis1.hs @@ -0,0 +1,14 @@ +module TopLevelSemis1 where + +x = 1 + +-- C1 +-- C2 +; +-- C3 +; +-- C4 + +data Foo = Foo + +-- After TyClD diff --git a/tests/examples/ghc92/TopLevelSemis2.hs b/tests/examples/ghc92/TopLevelSemis2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/TopLevelSemis2.hs @@ -0,0 +1,25 @@ +module TopLevelSemis2 where + +x = 1 +; + +-- foo: two matches, with params +foo [] = [] +-- After foo1 +; + +foo x = x +-- After foo2 +; + +-- bar: one match, with params +bar a = a +-- after bar +; + +-- baz: one match, no params +baz = 2 +-- after baz +; + +y = 3 diff --git a/tests/examples/ghc92/TopLevelSemis3.hs b/tests/examples/ghc92/TopLevelSemis3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/TopLevelSemis3.hs @@ -0,0 +1,7 @@ +module TopLevelSemis3 where + { + x = 1; + -- Comment + class Foo a where { + }; +} diff --git a/tests/examples/ghc92/TypeFamilies.hs b/tests/examples/ghc92/TypeFamilies.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/TypeFamilies.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds, UndecidableInstances #-} + +module TypeFamilies where + +type family F a b = r | r -> a b where + F a IO = IO a -- (1) + F Char b = b Int -- (2) diff --git a/tests/examples/ghc92/n-plus-k-patterns.hs b/tests/examples/ghc92/n-plus-k-patterns.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/n-plus-k-patterns.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE NPlusKPatterns #-} +singleline :: Int +singleline (n + 1) = n + +multiline :: Int +multiline(n + + 1) = n + +n :: Int +(n + 1) = 3 + diff --git a/tests/examples/transform/LocalDecls2.hs.expected b/tests/examples/transform/LocalDecls2.hs.expected --- a/tests/examples/transform/LocalDecls2.hs.expected +++ b/tests/examples/transform/LocalDecls2.hs.expected @@ -4,5 +4,3 @@ where nn :: Int nn = 2 - - diff --git a/tests/examples/transform/RmDecl4.hs.expected b/tests/examples/transform/RmDecl4.hs.expected --- a/tests/examples/transform/RmDecl4.hs.expected +++ b/tests/examples/transform/RmDecl4.hs.expected