[Git][ghc/ghc][wip/az/exactprint] WIP on delta printing.
Alan Zimmerman
gitlab at gitlab.haskell.org
Thu Nov 19 23:30:34 UTC 2020
Alan Zimmerman pushed to branch wip/az/exactprint at Glasgow Haskell Compiler / GHC
Commits:
b5fe6860 by Alan Zimmerman at 2020-11-19T23:30:04+00:00
WIP on delta printing.
Making progress
- - - - -
15 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/ThToHs.hs
- utils/check-exact/Main.hs
- utils/check-exact/Test.hs
- + utils/check-exact/cases/RenameCase1.hs
- utils/check-exact/check-exact.cabal
- utils/check-exact/src/ExactPrint.hs
- utils/check-exact/src/Utils.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1925,8 +1925,7 @@ data GRHSs p body
}
| XGRHSs !(XXGRHSs p body)
- -- MatchContext dependent, as per 'matchSeparator'
-type instance XCGRHSs (GhcPass _) b = ApiAnn' AddApiAnn
+type instance XCGRHSs (GhcPass _) b = NoExtField
type instance XXGRHSs (GhcPass _) b = NoExtCon
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -1120,7 +1120,7 @@ data HsType pass
-- For adding new constructors via Trees that Grow
| XHsType
- (XXType pass)
+ !(XXType pass)
data NewHsTypeX
= NHsCoreTy Type -- An escape hatch for tunnelling a *closed*
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -185,10 +185,10 @@ mkSimpleMatch ctxt pats rhs
unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpan
- => LocatedA (body (GhcPass p)) -> ApiAnn' AddApiAnn
+ => LocatedA (body (GhcPass p)) -> ApiAnn' GrhsAnn
-> GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))
unguardedGRHSs rhs@(L loc _) ann
- = GRHSs ann (unguardedRHS noAnn (locA loc) rhs) emptyLocalBinds
+ = GRHSs noExtField (unguardedRHS ann (locA loc) rhs) emptyLocalBinds
unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpan
@@ -907,7 +907,7 @@ mkMatch ctxt pats expr binds
= noLocA (Match { m_ext = noAnn
, m_ctxt = ctxt
, m_pats = map paren pats
- , m_grhss = GRHSs noAnn (unguardedRHS noAnn noSrcSpan expr) binds })
+ , m_grhss = GRHSs noExtField (unguardedRHS noAnn noSrcSpan expr) binds })
where
paren :: LPat (GhcPass p) -> LPat (GhcPass p)
paren lp@(L l p)
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -504,7 +504,7 @@ dsExpr (HsMultiIf res_ty alts)
= mkErrorExpr
| otherwise
- = do { let grhss = GRHSs noAnn alts emptyLocalBinds
+ = do { let grhss = GRHSs noExtField alts emptyLocalBinds
; rhss_nablas <- pmcGRHSs IfAlt grhss
; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas
; error_expr <- mkErrorExpr
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2486,10 +2486,10 @@ rhs :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) }
: '=' exp wherebinds {% runPV (unECP $2) >>= \ $2 ->
do { let loc = (comb3 $1 (reLoc $2) (adaptWhereBinds $3))
; acs (\cs ->
- sL loc (GRHSs (ApiAnn (rs loc) (mj AnnEqual $1) cs) (unguardedRHS (ApiAnn (rs loc) (GrhsAnn Nothing (mj AnnEqual $1)) []) loc $2)
+ sL loc (GRHSs NoExtField (unguardedRHS (ApiAnn (rs loc) (GrhsAnn Nothing (mj AnnEqual $1)) cs) loc $2)
(unLoc $ (adaptWhereBinds $3)))) } }
| gdrhs wherebinds { sL (comb2 $1 (adaptWhereBinds $>))
- (GRHSs noAnn (reverse (unLoc $1)) (unLoc $ (adaptWhereBinds $2))) }
+ (GRHSs noExtField (reverse (unLoc $1)) (unLoc $ (adaptWhereBinds $2))) }
gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
: gdrhs gdrh { sLL $1 $> ($2 : unLoc $1) }
@@ -2755,7 +2755,7 @@ aexp :: { ECP }
$ Match { m_ext = ApiAnn (glR $1) [mj AnnLam $1] cs
, m_ctxt = LambdaExpr
, m_pats = $2:$3
- , m_grhss = unguardedGRHSs $5 (ApiAnn (glR $4) (mu AnnRarrow $4) []) }])) }
+ , m_grhss = unguardedGRHSs $5 (ApiAnn (glR $4) (GrhsAnn Nothing (mu AnnRarrow $4)) []) }])) }
| 'let' binds 'in' exp { ECP $
unECP $4 >>= \ $4 ->
mkHsLetPV (comb2A $1 $>) (unLoc $2) $4
@@ -3181,7 +3181,7 @@ alt :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }
alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }
: ralt wherebinds { $1 >>= \alt ->
- return $ sLL alt (adaptWhereBinds $>) (GRHSs noAnn (unLoc alt) (unLoc $ adaptWhereBinds $2)) }
+ return $ sLL alt (adaptWhereBinds $>) (GRHSs noExtField (unLoc alt) (unLoc $ adaptWhereBinds $2)) }
ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }
: '->' exp { unECP $2 >>= \ $2 ->
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -498,6 +498,13 @@ defined.
-- AnnKeywordId elements. Note: we may reduce the usage of
-- AnnKeywordId, and use locations only, as captured in that
-- structure.
+--
+-- The spacing between the items under the scope of a given ApiAnn' is
+-- derived from the original 'anchor'. But there is no requirement
+-- that the items included in the sub-element have a "matching"
+-- location in their relative anchors. This allows us to freely move
+-- elements around, and stitch together new AST fragments out of old
+-- ones, and have them still printed out in a reasonable way.
data ApiAnn' ann
= ApiAnn { anchor :: RealSrcSpan -- ^ Base location for the start of
-- the syntactic element holding the
@@ -514,6 +521,9 @@ data ApiAnn' ann
type ApiAnn = ApiAnn' [AddApiAnn]
type ApiAnnComments = [RealLocated AnnotationComment]
+-- +| Relative positions, row then column
+-- newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data)
+
data NoApiAnns = NoApiAnns
deriving (Data,Eq,Ord)
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -1232,7 +1232,7 @@ rnGRHSs :: AnnoBody body
rnGRHSs ctxt rnBody (GRHSs _ grhss binds)
= rnLocalBindsAndThen binds $ \ binds' _ -> do
(grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
- return (GRHSs noAnn grhss' binds', fvGRHSs)
+ return (GRHSs noExtField grhss' binds', fvGRHSs)
rnGRHS :: AnnoBody body
=> HsMatchContext GhcRn
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -276,7 +276,7 @@ tcGRHSs ctxt (GRHSs _ grhss binds) res_ty
mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss
; let (usages, grhss') = unzip ugrhss
; tcEmitBindingUsage $ supUEs usages
- ; return (GRHSs noAnn grhss' binds') }
+ ; return (GRHSs noExtField grhss' binds') }
-------------
tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn))
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -190,7 +190,7 @@ cvtDec (TH.ValD pat body ds)
; ds' <- cvtLocalDecs (text "a where clause") ds
; returnJustLA $ Hs.ValD noExtField $
PatBind { pat_lhs = pat'
- , pat_rhs = GRHSs noAnn body' ds'
+ , pat_rhs = GRHSs noExtField body' ds'
, pat_ext = noAnn
, pat_ticks = ([],[]) } }
@@ -904,7 +904,7 @@ cvtClause ctxt (Clause ps body wheres)
; let pps = map (parenthesizePat appPrec) ps'
; g' <- cvtGuard body
; ds' <- cvtLocalDecs (text "a where clause") wheres
- ; returnLA $ Hs.Match noAnn ctxt pps (GRHSs noAnn g' ds') }
+ ; returnLA $ Hs.Match noAnn ctxt pps (GRHSs noExtField g' ds') }
cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind n e = do
@@ -1213,7 +1213,7 @@ cvtMatch ctxt (TH.Match p body decs)
_ -> p'
; g' <- cvtGuard body
; decs' <- cvtLocalDecs (text "a where clause") decs
- ; returnLA $ Hs.Match noAnn ctxt [lp] (GRHSs noAnn g' decs') }
+ ; returnLA $ Hs.Match noAnn ctxt [lp] (GRHSs noExtField g' decs') }
cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard (GuardedB pairs) = mapM cvtpair pairs
=====================================
utils/check-exact/Main.hs
=====================================
@@ -6,9 +6,9 @@ import GHC hiding (moduleName)
import GHC.Driver.Ppr
import GHC.Driver.Session
import GHC.Hs.Dump
-import GHC.Types.SourceText
+-- import GHC.Types.SourceText
-- import GHC.Hs.Exact hiding (ExactPrint())
-import GHC.Utils.Outputable hiding (space)
+-- import GHC.Utils.Outputable hiding (space)
import System.Environment( getArgs )
import System.Exit
import System.FilePath
@@ -21,7 +21,6 @@ import ExactPrint
tt :: IO ()
-- tt = testOneFile "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
- -- "Test.hs"
-- "../../testsuite/tests/printer/Ppr001.hs"
-- "../../testsuite/tests/printer/Ppr002.hs"
-- "../../testsuite/tests/printer/Ppr003.hs"
=====================================
utils/check-exact/Test.hs
=====================================
@@ -1,34 +1,184 @@
-{-# LANGUAGE ParallelListComp #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples #-}
-module
- Main
- (
- main
- ,
- foo
- )
- where
-
-import {-# SOURCE #-} qualified Data.List as L
-import Data.Map hiding ( Map(..) )
-
-main =
- putStrLn "hello"
-
-foo = 1
-
-
--- | '(' qconsym ')' {% amsr (sLL $1 $> (unLoc $2))
--- [mop $1,mjA AnnVal $2,mcp $3] }
-f1 = ( Main.::: ) 0 1
-
--- | '(' consym ')' {% amsr (sLL $1 $> (unLoc $2))
--- [mop $1,mjA AnnVal $2,mcp $3] }
-f2 = ( ::: ) 0 1
-
--- | '`' conid '`' {% amsr (sLL $1 $> (unLoc $2))
--- [mj AnnBackquote $1,mjA AnnVal $2
--- ,mj AnnBackquote $3] }
--- data GG = GG Int Int
--- gg = 0 ` GG ` 1
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- import Data.List
+import Data.Data
+import Data.Typeable
+-- import GHC.Types.SrcLoc
+import GHC.Types.Name.Occurrence
+import GHC.Types.Name.Reader
+import GHC hiding (moduleName)
+import GHC.Driver.Ppr
+import GHC.Driver.Session
+import GHC.Hs.Dump
+-- import GHC.Types.SourceText
+-- import GHC.Hs.Exact hiding (ExactPrint())
+-- import GHC.Utils.Outputable hiding (space)
+import System.Environment( getArgs )
+import System.Exit
+import System.FilePath
+
+import Types
+import Utils
+import ExactPrint
+-- exactPrint = undefined
+-- showPprUnsafe = undefined
+
+-- ---------------------------------------------------------------------
+
+tt :: IO ()
+-- tt = testOneFile "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
+tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
+ "cases/RenameCase1.hs"
+
+-- exact = ppr
+
+-- ---------------------------------------------------------------------
+
+usage :: String
+usage = unlines
+ [ "usage: check-ppr (libdir) (file)"
+ , ""
+ , "where libdir is the GHC library directory (e.g. the output of"
+ , "ghc --print-libdir) and file is the file to parse."
+ ]
+
+main :: IO()
+main = do
+ args <- getArgs
+ case args of
+ [libdir,fileName] -> testOneFile libdir fileName
+ _ -> putStrLn usage
+
+testOneFile :: FilePath -> String -> IO ()
+testOneFile libdir fileName = do
+ p <- parseOneFile libdir fileName
+ -- putStrLn $ "\n\ngot p"
+ let
+ origAst = showSDocUnsafe
+ $ showAstData BlankSrcSpanFile NoBlankApiAnnotations
+ (pm_parsed_source p)
+ anns' = pm_annotations p
+ -- pped = pragmas ++ "\n" ++ (exactPrint $ pm_parsed_source p)
+ pped = exactPrint (pm_parsed_source p) anns'
+ -- pragmas = getPragmas anns'
+
+ newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName
+ newFileChanged = dropExtension fileName <.> "changed" <.> takeExtension fileName
+ astFile = fileName <.> "ast"
+ newAstFile = fileName <.> "ast.new"
+
+ pped' <- exactprintWithChange changeRenameCase1 (pm_parsed_source p) anns'
+ -- putStrLn $ "\n\nabout to writeFile"
+ writeFile astFile origAst
+ -- putStrLn $ "\n\nabout to pp"
+ writeFile newFile pped
+ writeFile newFileChanged pped'
+
+ -- putStrLn $ "anns':" ++ showPprUnsafe (apiAnnRogueComments anns')
+
+ p' <- parseOneFile libdir newFile
+
+ let newAstStr :: String
+ newAstStr = showSDocUnsafe
+ $ showAstData BlankSrcSpanFile NoBlankApiAnnotations
+ (pm_parsed_source p')
+ writeFile newAstFile newAstStr
+
+ -- putStrLn $ "\n\nanns':" ++ showPprUnsafe (apiAnnRogueComments anns')
+
+ if origAst == newAstStr
+ then do
+ -- putStrLn "ASTs matched"
+ exitSuccess
+ else do
+ putStrLn "AST Match Failed"
+ -- putStrLn "\n===================================\nOrig\n\n"
+ -- putStrLn origAst
+ putStrLn "\n===================================\nNew\n\n"
+ putStrLn newAstStr
+ exitFailure
+
+
+parseOneFile :: FilePath -> FilePath -> IO ParsedModule
+parseOneFile libdir fileName = do
+ let modByFile m =
+ case ml_hs_file $ ms_location m of
+ Nothing -> False
+ Just fn -> fn == fileName
+ runGhc (Just libdir) $ do
+ dflags <- getSessionDynFlags
+ let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream
+ _ <- setSessionDynFlags dflags2
+ addTarget Target { targetId = TargetFile fileName Nothing
+ , targetAllowObjCode = True
+ , targetContents = Nothing }
+ _ <- load LoadAllTargets
+ graph <- getModuleGraph
+ let
+ modSum = case filter modByFile (mgModSummaries graph) of
+ [x] -> x
+ xs -> error $ "Can't find module, got:"
+ ++ show (map (ml_hs_file . ms_location) xs)
+ parseModule modSum
+
+-- getPragmas :: ApiAnns -> String
+-- getPragmas anns' = pragmaStr
+-- where
+-- tokComment (L _ (AnnBlockComment s)) = s
+-- tokComment (L _ (AnnLineComment s)) = s
+-- tokComment _ = ""
+
+-- comments' = map tokComment $ sortRealLocated $ apiAnnRogueComments anns'
+-- pragmas = filter (\c -> isPrefixOf "{-#" c ) comments'
+-- pragmaStr = intercalate "\n" pragmas
+
+-- pp :: (Outputable a) => a -> String
+-- pp a = showPpr unsafeGlobalDynFlags a
+
+-- ---------------------------------------------------------------------
+
+exactprintWithChange :: Changer -> ParsedSource -> ApiAnns -> IO String
+exactprintWithChange f p anns = do
+ (anns',p') <- f anns p
+ return $ exactPrint p' anns'
+
+
+type Changer = (ApiAnns -> ParsedSource -> IO (ApiAnns,ParsedSource))
+
+noChange :: Changer
+noChange ans parsed = return (ans,parsed)
+
+changeRenameCase1 :: Changer
+changeRenameCase1 ans parsed = return (ans,rename "bazLonger" [((3,15),(3,18))] parsed)
+
+rename :: (Data a) => String -> [(Pos, Pos)] -> a -> a
+rename newNameStr spans' a
+ = everywhere (mkT replaceRdr) a
+ where
+ newName = mkRdrUnqual (mkVarOcc newNameStr)
+
+ cond :: SrcSpan -> Bool
+ cond ln = ss2range ln `elem` spans'
+
+ replaceRdr :: LocatedN RdrName -> LocatedN RdrName
+ replaceRdr (L ln _)
+ | cond (locA ln) = L ln newName
+ replaceRdr x = x
+
+-- ---------------------------------------------------------------------
+-- From SYB
+
+-- | Apply transformation on each level of a tree.
+--
+-- Just like 'everything', this is stolen from SYB package.
+everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)
+everywhere f = f . gmapT (everywhere f)
+
+-- | Create generic transformation.
+--
+-- Another function stolen from SYB package.
+mkT :: (Typeable a, Typeable b) => (b -> b) -> (a -> a)
+mkT f = case cast f of
+ Just f' -> f'
+ Nothing -> id
=====================================
utils/check-exact/cases/RenameCase1.hs
=====================================
@@ -0,0 +1,5 @@
+module RenameCase1 where
+
+foo x = case (baz x) of
+ 1 -> "a"
+ _ -> "b"
=====================================
utils/check-exact/check-exact.cabal
=====================================
@@ -26,7 +26,7 @@ Executable check-exact
Build-Depends: base >= 4 && < 5,
bytestring,
containers,
- Cabal >= 3.0 && < 3.4,
+ Cabal >= 3.0 && < 3.6,
directory,
filepath,
ghc
=====================================
utils/check-exact/src/ExactPrint.hs
=====================================
@@ -83,6 +83,10 @@ defaultEPState as = EPState
, epLHS = 0
, epMarkLayout = False
, priorEndPosition = (1,1)
+ , priorEndPositionE = (1,1)
+ , priorEndPositionU = (1,1)
+ , anchorSpan = badRealSrcSpan
+ , origPos = (1,1)
, epComments = rogueComments as
}
@@ -142,6 +146,12 @@ data EPState = EPState
, epLHS :: LayoutStartCol
, priorEndPosition :: !Pos -- ^ Position reached when
-- processing the last element
+ , priorEndPositionE :: !Pos -- ^ End of Position reached when
+ , priorEndPositionU :: !Pos -- ^ last priorEndPositionE used when calculating EDP
+ , anchorSpan :: !RealSrcSpan -- ^ in pre-changed AST reference frame, from Annotation
+ , origPos :: !Pos -- ^ Current output position in
+ -- original annotation, used to
+ -- calculate DPs
, epComments :: ![Comment]
}
@@ -181,11 +191,26 @@ enterAnn NoEntryVal a = do
p <- getPos
debugM $ "enterAnn:NO ANN:p =" ++ show p
exact a
-enterAnn (Entry anchor cs) a = do
+enterAnn (Entry anchor' cs) a = do
+ -- NOTE: in time anchor will note if it has moved, for now we assume
+ -- both values are the same
+ let topAnchor = anchor' -- To control spacing to get into this AST element
+ let curAnchor = anchor' -- As a base for the current AST element
+ -- -- -----------------------------------------------
+ -- -- Advance by any discrepance between origPos and topAnchor
+ -- op <- getOrigPos
+ -- p <- getPos
+ -- let dp = pos2delta op (ss2pos topAnchor)
+ -- debugM $ "enterAnn:(op,p,topAnchor,dp)=" ++ show (op,p,rs2range topAnchor,dp)
+ -- advance dp
+ -- -- We are now cleanly in the current context
+ -- -- -------------------------------------------
+ setAnchor curAnchor
+ setOrigPos (ss2pos curAnchor) -- We assume we are now aligned with the anchor
+ p' <- getPos
addCommentsA cs
- printComments anchor
+ printComments curAnchor
p <- getPos
- debugM $ "enterAnn:(anchor(pos),p)=" ++ show (ss2pos(anchor),p)
-- do all the machinery of advancing to the anchor, with a local etc
-- modelled on exactpc (which is normally called via withast
@@ -193,16 +218,35 @@ enterAnn (Entry anchor cs) a = do
-- the current position, and the anchor.
-- off <- gets apLayoutStart
off <- gets epLHS
- priorEndAfterComments <- getPos
- let ss = anchor
- let edp = adjustDeltaForOffset
+ -- priorEndAfterComments <- getPos
+ let ss = curAnchor
+---------------------------
+ priorEndAfterComments <- getPriorEnd
+ priorEndAfterCommentsE <- getPriorEndE
+ peu <- getPriorEndU
+ debugM $ "enterAnn:(curAnchor,pe,pec,p,p')=" ++ show (ss2pos curAnchor,priorEndAfterComments,priorEndAfterCommentsE,p,p')
+----------------------------
+ -- NOTE: edp only uses the *original* ast spacing, i.e. the gap
+ -- between the end of the previous leaf span, and the start of the
+ -- next leaf span
+ 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 ss)
+ -- off (ss2delta priorEndAfterComments ss)
+ off (ss2delta priorEndAfterCommentsE curAnchor)
+ edp = if peu /= priorEndAfterCommentsE -- new leaf node
+ then edp' else DP (0,0)
+ debugM $ "enterAnn:(p,ss,edp,pec)=" ++ show (p,ss2pos ss,edp,priorEndAfterCommentsE)
+ -- when (priorEndAfterComments < ss2pos ss) (do
+ -- modify (\s -> s { priorEndPosition = ss2pos ss
+ -- , priorEndPositionU = priorEndAfterCommentsE } ))
+ modify (\s -> s { priorEndPosition = ss2pos ss
+ , priorEndPositionU = priorEndAfterCommentsE } )
let
st = annNone { annEntryDelta = edp }
+
withOffset st (advance edp >> exact a)
-- ---------------------------------------------------------------------
@@ -248,7 +292,7 @@ sr s = RealSrcSpan s Nothing
-- Temporary function to simply reproduce the "normal" pretty printer output
withPpr :: (Outputable a) => a -> Annotated ()
-withPpr a = printString False (showPprUnsafe a)
+withPpr a = printStringAdvance (showPprUnsafe a)
-- ---------------------------------------------------------------------
-- Modeled on Outputable
@@ -273,6 +317,7 @@ instance (ExactPrint a) => ExactPrint (Located a) where
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)
@@ -301,13 +346,15 @@ instance ExactPrint HsModule where
Just (L ln mn) -> do
markApiAnn' an am_main AnnModule
-- debugM $ "HsModule name: (ss,ln)=" ++ show (ss2pos ss,ss2pos (realSrcSpan ln))
- printStringAtSs ln (moduleNameString mn)
+ -- printStringAtSs ln (moduleNameString mn)
+ markAnnotated (L ln mn)
-- forM_ mdeprec markLocated
markAnnotated mdeprec
markAnnotated mexports
+ debugM $ "HsModule.AnnWhere coming"
markApiAnn' an am_main AnnWhere
-- markApiAnn (am_main anns) AnnWhere
@@ -334,23 +381,19 @@ instance ExactPrint HsModule where
-- ---------------------------------------------------------------------
printSourceText :: SourceText -> String -> EPP ()
-printSourceText NoSourceText txt = printString False txt
-printSourceText (SourceText txt) _ = printString False txt
+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
-- ---------------------------------------------------------------------
--- printStringAtKw :: ApiAnn' ann -> AnnKeywordId -> String -> EPP ()
--- printStringAtKw ApiAnnNotUsed _ str = printString True str
--- printStringAtKw (ApiAnn anchor anns _cs) kw str = do
--- case find (\(AddApiAnn k _) -> k == kw) anns of
--- Nothing -> printString True str
--- Just (AddApiAnn _ ss) -> printStringAtKw' ss str
-
-- AZ:TODO get rid of this
printStringAtMkw :: Maybe RealSrcSpan -> String -> EPP ()
printStringAtMkw (Just r) s = printStringAtKw' r s
@@ -359,11 +402,35 @@ printStringAtMkw Nothing s = printStringAtLsDelta [] (DP (0,1)) s
printStringAtKw' :: RealSrcSpan -> String -> EPP ()
printStringAtKw' ss str = do
printComments ss
- dp <- nextDP ss
+ -- dp <- nextDP ss
+ anchor <- getAnchor
+ op <- getOrigPos
+ dp <- nextDPAnchor ss
p <- getPos
- debugM $ "printStringAtKw': (dp,p) = " ++ show (dp,p)
+ debugM $ "printStringAtKw': (dp,p,pe,a,op) = " ++ show (dp,p,ss2posEnd ss,rs2range anchor,op)
+ setPriorEndE (ss2posEnd ss)
+ setOrigPos (ss2posEnd ss)
printStringAtLsDelta [] dp str
+-- | Print a string, advancing origPos by the same amount as the pos
+-- advances. Complicated because the string may have newlines in it
+printStringAdvance :: String -> EPP ()
+printStringAdvance str = do
+ op <- getOrigPos
+ p1 <- getPos
+ printString False str
+ p2 <- getPos
+ let dp = pos2delta p1 p2
+ colOffset <- getLayoutOffset
+ let op2 = undelta op dp colOffset
+ setOrigPos op2
+
+adaptPos dp = do
+ op <- getOrigPos
+ colOffset <- getLayoutOffset
+ let op2 = undelta op dp colOffset
+ setOrigPos op2
+
-- ---------------------------------------------------------------------
markExternalSourceText :: SrcSpan -> SourceText -> String -> EPP ()
@@ -418,13 +485,6 @@ markLocatedAALS (ApiAnn _ a _) f kw (Just str) = go (f a)
markArrow :: ApiAnn' TrailingAnn -> (HsArrow GhcPs) -> EPP ()
markArrow ApiAnnNotUsed _ = pure ()
markArrow an mult = markKwT (anns an)
- -- = case mult of
- -- HsLinearArrow -> markApiAnn an AnnLolly
- -- HsUnrestrictedArrow -> markApiAnn an AnnRarrow
- -- HsExplicitMult p -> do
- -- printString False "#"
- -- markAnnotated p
- -- markApiAnn an AnnRarrow
-- ---------------------------------------------------------------------
@@ -517,9 +577,14 @@ markKw' :: AnnKeywordId -> RealSrcSpan -> EPP ()
markKw' kw ss = do
p' <- getPos
printComments ss
- dp <- nextDP ss
+ -- AZ:TODO instead of using nextDP, we need to use the original DP. how?
+ -- dp <- nextDP ss
+ dp <- nextDPAnchor ss
p <- getPos
- debugM $ "markKw: (dp,p,p') = " ++ show (dp,p,p')
+ anchor <- getAnchor
+ setPriorEndE (ss2posEnd ss)
+ setOrigPos (ss2posEnd ss)
+ debugM $ "markKw: (dp,p,p',pe,anchor) = " ++ show (dp,p,p',rs2range ss,rs2range anchor)
printStringAtLsDelta [] dp (keywordToString (G kw))
-- ---------------------------------------------------------------------
@@ -594,6 +659,15 @@ nextDP ss = do
p <- getPos
return $ pos2delta p (ss2pos ss)
+nextDPAnchor :: RealSrcSpan -> EPP DeltaPos
+nextDPAnchor ss = do
+ anchor <- getAnchor
+ op <- getOrigPos
+ let dp = pos2delta op (ss2pos ss)
+ -- return $ pos2delta (ss2pos anchor) (ss2pos ss)
+ debugM $ "nextDPAnchor:(dp,op,ss,anchor)=" ++ show (dp,op,rs2range ss,rs2range anchor)
+ return dp
+
-- ---------------------------------------------------------------------
markListWithLayout :: ExactPrint (LocatedA ast) => [LocatedA ast] -> EPP ()
@@ -948,7 +1022,7 @@ instance ExactPrint FastString where
getAnnotationEntry = const NoEntryVal
-- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies.
- exact fs = printString False (show (unpackFS fs))
+ exact fs = printStringAdvance (show (unpackFS fs))
-- ---------------------------------------------------------------------
@@ -1048,7 +1122,7 @@ instance ExactPrint DocDecl where
(DocCommentNamed _s ds) -> unpackHDS ds
(DocGroup _i ds) -> unpackHDS ds
in
- printString False str
+ printStringAdvance str
-- ---------------------------------------------------------------------
@@ -1426,7 +1500,7 @@ exactMatch (Match an mctxt pats grhss) = do
markApiAnn an AnnLam
mapM_ markAnnotated pats
GHC.CaseAlt -> do
- mapM_ markAnnotated pats
+ markAnnotated pats
_ -> withPpr mctxt
markAnnotated grhss
@@ -1434,21 +1508,21 @@ exactMatch (Match an mctxt pats grhss) = do
-- ---------------------------------------------------------------------
instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where
- getAnnotationEntry (GRHSs an _ _) = fromAnn an
+ getAnnotationEntry (GRHSs _ _ _) = NoEntryVal
exact (GRHSs an grhss binds) = do
debugM $ "GRHSs: before matchSeparator"
- markLocatedAA an id -- Mark the matchSeparator for these GRHSs
+ -- markLocatedAA an id -- Mark the matchSeparator for these GRHSs
debugM $ "GRHSs: after matchSeparator"
markAnnotated grhss
markAnnotated binds
instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where
- getAnnotationEntry (GRHSs an _ _) = fromAnn an
+ getAnnotationEntry (GRHSs _ _ _) = NoEntryVal
exact (GRHSs an grhss binds) = do
debugM $ "GRHSs: before matchSeparator"
- markLocatedAA an id -- Mark the matchSeparator for these GRHSs
+ -- markLocatedAA an id -- Mark the matchSeparator for these GRHSs
debugM $ "GRHSs: after matchSeparator"
markAnnotated grhss
markAnnotated binds
@@ -1499,7 +1573,7 @@ instance ExactPrint (IPBind GhcPs) where
instance ExactPrint HsIPName where
getAnnotationEntry = const NoEntryVal
- exact (HsIPName fs) = printString False ("?" ++ (unpackFS fs))
+ exact (HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs))
-- ---------------------------------------------------------------------
@@ -1507,7 +1581,7 @@ instance ExactPrint (HsValBindsLR GhcPs GhcPs) where
getAnnotationEntry _ = NoEntryVal
exact (ValBinds sortkey binds sigs) = do
- -- printString False "ValBinds"
+ -- printStringAdvance "ValBinds"
applyListAnnotations
(prepareListAnnotationA (bagToList binds)
++ prepareListAnnotationA sigs
@@ -1848,7 +1922,7 @@ instance ExactPrint (HsExpr GhcPs) where
-- exact x@(HsRecFld{}) = withPpr x
-- exact x@(HsOverLabel ann _ _) = withPpr x
exact (HsIPVar _ (HsIPName n))
- = printString False ("?" ++ unpackFS n)
+ = printStringAdvance ("?" ++ unpackFS n)
exact x@(HsOverLit ann ol) = do
let str = case ol_val ol of
@@ -1857,7 +1931,7 @@ instance ExactPrint (HsExpr GhcPs) where
HsIsString src _ -> src
-- markExternalSourceText l str ""
case str of
- SourceText s -> printString False s
+ SourceText s -> printStringAdvance s
NoSourceText -> withPpr x
exact (HsLit ann lit) = withPpr lit
@@ -1897,9 +1971,9 @@ instance ExactPrint (HsExpr GhcPs) where
exact x@(HsPar an e) = do
markOpeningParen an
markAnnotated e
- -- debugM $ "HsPar closing paren"
+ debugM $ "HsPar closing paren"
markClosingParen an
- -- debugM $ "HsPar done"
+ debugM $ "HsPar done"
-- exact (SectionL an expr op) = do
exact (SectionR an op expr) = do
@@ -2142,7 +2216,7 @@ instance ExactPrint (HsSplice GhcPs) where
-- = ppr_splice empty n e empty
exact (HsQuasiQuote _ _ q _ss fs) = do
- printString False
+ printStringAdvance
-- Note: Lexer.x does not provide unicode alternative. 2017-02-26
("[" ++ (showPprUnsafe q) ++ "|" ++ (unpackFS fs) ++ "|]")
@@ -2222,7 +2296,7 @@ instance ExactPrint (HsTupArg GhcPs) where
exact (Present _ e) = markAnnotated e
exact (Missing ApiAnnNotUsed) = return ()
- exact (Missing _) = printString False ","
+ exact (Missing _) = printStringAdvance ","
-- ---------------------------------------------------------------------
@@ -2402,12 +2476,12 @@ instance ExactPrint (HsCmd GhcPs) where
instance (ExactPrint (LocatedA body))
=> ExactPrint (StmtLR GhcPs GhcPs (LocatedA body)) where
-- instance ExactPrint (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs))) where
- getAnnotationEntry (LastStmt _ _ _ _) = NoEntryVal
+ getAnnotationEntry (LastStmt _ _ _ _) = NoEntryVal
getAnnotationEntry (BindStmt an _ _) = fromAnn an
- getAnnotationEntry (ApplicativeStmt an _ _) = NoEntryVal
- getAnnotationEntry (BodyStmt an _ _ _) = NoEntryVal
+ getAnnotationEntry (ApplicativeStmt _ _ _) = NoEntryVal
+ getAnnotationEntry (BodyStmt _ _ _ _) = NoEntryVal
getAnnotationEntry (LetStmt an _) = fromAnn an
- getAnnotationEntry (ParStmt an _ _ _) = NoEntryVal
+ getAnnotationEntry (ParStmt _ _ _ _) = NoEntryVal
getAnnotationEntry (TransStmt an _ _ _ _ _ _ _ _) = fromAnn an
getAnnotationEntry (RecStmt an _ _ _ _ _ _) = fromAnn an
@@ -2515,7 +2589,7 @@ instance (ExactPrint (LocatedA body))
-- markTrailingSemi
-- exact x = error $ "exact CmdLStmt for:" ++ showAst x
- exact x = error $ "exact CmdLStmt for:"
+ -- exact x = error $ "exact CmdLStmt for:"
-- ---------------------------------------------------------------------
@@ -2690,7 +2764,7 @@ instance ExactPrint (TyClDecl GhcPs) where
-- = error "extension hit for TyClDecl"
-- markAST _ (GHC.XTyClDecl _)
-- = error "extension hit for TyClDecl"
- exact x = error $ "exact TyClDecl for:" ++ showAst x
+ -- exact x = error $ "exact TyClDecl for:" ++ showAst x
-- ---------------------------------------------------------------------
@@ -2719,7 +2793,7 @@ instance ExactPrint (FamilyDecl GhcPs) where
markApiAnn an AnnWhere
markApiAnn an AnnOpenC
case mb_eqns of
- Nothing -> printString False ".."
+ Nothing -> printStringAdvance ".."
Just eqns -> markAnnotated eqns
markApiAnn an AnnCloseC
_ -> return ()
@@ -2887,7 +2961,7 @@ instance ExactPrint (HsType GhcPs) where
getAnnotationEntry (HsWildCardTy _) = NoEntryVal
- exact (HsForAllTy { hst_xforall = an
+ exact (HsForAllTy { hst_xforall = _an
, hst_tele = tele, hst_body = ty }) = do
markAnnotated tele
markAnnotated ty
@@ -2900,9 +2974,9 @@ instance ExactPrint (HsType GhcPs) where
when (promoted == IsPromoted) $ markApiAnn an AnnSimpleQuote
markAnnotated name
- exact x@(HsAppTy _ t1 t2) = markAnnotated t1 >> markAnnotated t2
- exact x@(HsAppKindTy an _ _) = withPpr x
- exact x@(HsFunTy an mult ty1 ty2) = do
+ exact (HsAppTy _ t1 t2) = markAnnotated t1 >> markAnnotated t2
+ exact x@(HsAppKindTy _an _ _) = withPpr x
+ exact (HsFunTy an mult ty1 ty2) = do
markAnnotated ty1
markArrow an mult
markAnnotated ty2
@@ -2918,7 +2992,7 @@ instance ExactPrint (HsType GhcPs) where
markOpeningParen an
markAnnotated tys
markClosingParen an
- exact (HsOpTy an t1 lo t2) = do
+ exact (HsOpTy _an t1 lo t2) = do
markAnnotated t1
markAnnotated lo
markAnnotated t2
@@ -2926,14 +3000,14 @@ instance ExactPrint (HsType GhcPs) where
markOpeningParen an
markAnnotated ty
markClosingParen an
- exact x@(HsIParamTy an n t) = do
+ exact (HsIParamTy an n t) = do
markAnnotated n
markApiAnn an AnnDcolon
markAnnotated t
- exact (HsStarTy an isUnicode)
+ exact (HsStarTy _an isUnicode)
= if isUnicode
- then printString False "\x2605" -- Unicode star
- else printString False "*"
+ then printStringAdvance "\x2605" -- Unicode star
+ else printStringAdvance "*"
exact (HsKindSig an ty k) = do
exact ty
markApiAnn an AnnDcolon
@@ -2969,7 +3043,7 @@ instance ExactPrint (HsType GhcPs) where
case lit of
(HsNumTy src v) -> printSourceText src (show v)
(HsStrTy src v) -> printSourceText src (show v)
- exact (HsWildCardTy _) = printString False "_"
+ exact (HsWildCardTy _) = printStringAdvance "_"
exact x = error $ "missing match for HsType:" ++ showAst x
-- ---------------------------------------------------------------------
@@ -3076,8 +3150,10 @@ instance ExactPrint (HsSigType GhcPs) where
instance ExactPrint (LocatedN RdrName) where
getAnnotationEntry (L sann _) = fromAnn sann
- exact (L (SrcSpanAnn ApiAnnNotUsed _) n) = do
- printString False (showPprUnsafe n)
+ exact (L (SrcSpanAnn ApiAnnNotUsed l) n) = do
+ p <- getPos
+ debugM $ "LocatedN RdrName:NOANN: (p,l,str)=" ++ show (p,ss2range l, showPprUnsafe n)
+ printStringAtSs l (showPprUnsafe n)
exact (L (SrcSpanAnn (ApiAnn _anchor ann _cs) ll) n) = do
case ann of
NameAnn a o l c t -> do
@@ -3100,7 +3176,7 @@ instance ExactPrint (LocatedN RdrName) where
markAnnotated (L (SrcSpanAnn name ll) n)
markTrailing t
NameAnnTrailing t -> do
- printString False (showPprUnsafe n)
+ printStringAdvance (showPprUnsafe n)
markTrailing t
markName :: NameAdornment
@@ -3133,12 +3209,12 @@ exact_condecls an cs
| gadt_syntax -- In GADT syntax
-- = hang (text "where") 2 (vcat (map ppr cs))
= do
- -- printString False "exact_condecls:gadt"
+ -- printStringAdvance "exact_condecls:gadt"
mapM_ markAnnotated cs
| otherwise -- In H98 syntax
-- = equals <+> sep (punctuate (text " |") (map ppr cs))
= do
- -- printString False "exact_condecls:not gadt"
+ -- printStringAdvance "exact_condecls:not gadt"
markApiAnn an AnnEqual
mapM_ markAnnotated cs
where
@@ -3210,8 +3286,8 @@ instance ExactPrint (ConDecl GhcPs) where
when (isJust mcxt) $ markApiAnn an AnnDarrow
-- mapM_ markAnnotated args
case args of
- (PrefixConGADT args) -> mapM_ markAnnotated args
- (RecConGADT fields) -> markAnnotated fields
+ (PrefixConGADT args') -> mapM_ markAnnotated args'
+ (RecConGADT fields) -> markAnnotated fields
-- mapM_ markAnnotated (unLoc fields)
markAnnotated res_ty
-- markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) qvars mbCxt args typ _) = do
@@ -3315,7 +3391,7 @@ instance ExactPrint (LocatedP CType) where
getAnnotationEntry = entryFromLocatedA
exact (L (SrcSpanAnn ApiAnnNotUsed _) ct) = withPpr ct
- exact (L (SrcSpanAnn an ll)
+ exact (L (SrcSpanAnn an _ll)
(CType stp mh (stct,ct))) = do
markAnnOpenP an stp "{-# CTYPE"
case mh of
@@ -3345,7 +3421,7 @@ instance ExactPrint (SourceText, RuleName) where
getAnnotationEntry = const NoEntryVal
exact (st, rn)
- = printString False (toSourceTextWithSuffix st (unpackFS rn) "")
+ = printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "")
-- =====================================================================
@@ -3408,7 +3484,7 @@ instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr Gh
markAnnList an $ do
-- markLocatedMAA an al_open
case snocView stmts of
- Just (initStmts, ls@(L _ (LastStmt _ body _ _))) -> do
+ Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do
debugM $ "LocatedL [ExprLStmt: snocView"
markAnnotated ls
markAnnotated initStmts
@@ -3459,7 +3535,7 @@ instance ExactPrint (IE GhcPs) where
markApiAnn an AnnDotdot
markApiAnn an AnnCloseP
- exact (IEThingWith an thing wc withs flds) = do
+ exact (IEThingWith an thing wc withs _flds) = do
markAnnotated thing
markApiAnn an AnnOpenP
case wc of
@@ -3529,8 +3605,10 @@ instance ExactPrint (Pat GhcPs) where
getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an
getAnnotationEntry (SigPat an _ _) = fromAnn an
-
- exact (WildPat _) = printString False "_"
+ exact (WildPat _) = do
+ anchor <- getAnchor
+ 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.
@@ -3558,7 +3636,7 @@ instance ExactPrint (Pat GhcPs) where
Boxed -> markApiAnn an AnnCloseP
Unboxed -> markApiAnn an AnnClosePH
- exact (SumPat an pat alt arity) = do
+ exact (SumPat an pat _alt _arity) = do
markLocatedAAL an sumPatParens AnnOpenPH
markAnnKwAll an sumPatVbarsBefore AnnVbar
markAnnotated pat
@@ -3578,7 +3656,7 @@ instance ExactPrint (Pat GhcPs) where
markApiAnn an AnnRarrow
markAnnotated pat
exact (SplicePat _ splice) = markAnnotated splice
- exact (LitPat _ lit) = printString False (hsLit2String lit)
+ exact (LitPat _ lit) = printStringAdvance (hsLit2String lit)
exact (NPat an ol mn _) = do
when (isJust mn) $ markApiAnn an AnnMinus
markAnnotated ol
@@ -3699,7 +3777,7 @@ instance ExactPrint (HsOverLit GhcPs) where
HsIsString src _ -> src
in
case str of
- SourceText s -> printString False s
+ SourceText s -> printStringAdvance s
NoSourceText -> return ()
-- ---------------------------------------------------------------------
@@ -3961,6 +4039,43 @@ getPos = gets epPos
setPos :: (Monad m, Monoid w) => Pos -> EP w m ()
setPos l = modify (\s -> s {epPos = l})
+getPriorEnd :: (Monad m, Monoid w) => EP w m Pos
+getPriorEnd = gets priorEndPosition
+
+getPriorEndE :: (Monad m, Monoid w) => EP w m Pos
+getPriorEndE = gets priorEndPositionE
+
+getPriorEndU :: (Monad m, Monoid w) => EP w m Pos
+getPriorEndU = gets priorEndPositionU
+
+getAnchor :: (Monad m, Monoid w) => EP w m RealSrcSpan
+getAnchor = gets anchorSpan
+
+getOrigPos :: (Monad m, Monoid w) => EP w m Pos
+getOrigPos = gets origPos
+
+setPriorEnd :: (Monad m, Monoid w) => Pos -> EP w m ()
+setPriorEnd pe =
+ modify (\s -> s { priorEndPosition = pe })
+
+setPriorEndE :: (Monad m, Monoid w) => Pos -> EP w m ()
+setPriorEndE pe =
+ modify (\s -> s { priorEndPositionE = pe })
+
+setPriorEndU :: (Monad m, Monoid w) => Pos -> EP w m ()
+setPriorEndU pe =
+ modify (\s -> s { priorEndPositionU = pe })
+
+setAnchor :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()
+setAnchor rss = do
+ debugM $ "setAnchor:" ++ show (rs2range rss)
+ modify (\s -> s { anchorSpan = rss })
+
+setOrigPos :: (Monad m, Monoid w) => Pos -> EP w m ()
+setOrigPos p = do
+ debugM $ "setOrigPos:" ++ show p
+ modify (\s -> s { origPos = p })
+
getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment]
getUnallocatedComments = gets epComments
@@ -4014,7 +4129,7 @@ advance :: (Monad m, Monoid w) => DeltaPos -> EP w m ()
advance cl = do
p <- getPos
colOffset <- getLayoutOffset
- debugM $ "advance:(p,colOffset,ws)=" ++ show (p,colOffset,undelta p cl colOffset)
+ debugM $ "advance:(p,cl,colOffset,ws)=" ++ show (p,cl,colOffset,undelta p cl colOffset)
printWhitespace (undelta p cl colOffset)
-- getAndRemoveAnnotation :: (Monad m, Monoid w, Data a) => GHC.Located a -> EP w m (Maybe Annotation)
@@ -4034,9 +4149,6 @@ adjustDeltaForOffset (LayoutStartCol colOffset) (DP (l,c)) = DP (l,c - colOffset
-- ---------------------------------------------------------------------
-- Printing functions
-
-
-
printString :: (Monad m, Monoid w) => Bool -> String -> EP w m ()
printString layout str = do
EPState{epPos = (_,c), epMarkLayout} <- get
=====================================
utils/check-exact/src/Utils.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Driver.Ppr
+import GHC.Data.FastString
-- import GHC.Types.Var
-- import GHC.Types.Name.Occurrence
@@ -164,6 +165,22 @@ ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss)
ss2posEnd :: RealSrcSpan -> Pos
ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndCol ss)
+ss2range :: SrcSpan -> (Pos,Pos)
+ss2range ss = (ss2pos $ rs ss, ss2posEnd $ rs ss)
+
+rs2range :: RealSrcSpan -> (Pos,Pos)
+rs2range ss = (ss2pos ss, ss2posEnd ss)
+
+rs :: SrcSpan -> RealSrcSpan
+rs (RealSrcSpan s _) = s
+rs _ = badRealSrcSpan
+
+badRealSrcSpan :: RealSrcSpan
+badRealSrcSpan = mkRealSrcSpan bad bad
+ where
+ bad = mkRealSrcLoc (fsLit "ghc-exactprint-nospan") 0 0
+
+
-- srcSpanEndColumn :: SrcSpan -> Int
-- srcSpanEndColumn (RealSrcSpan s) = srcSpanEndCol s
-- srcSpanEndColumn _ = 0
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b5fe6860a300604a43059d372ac56b504a9d704e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b5fe6860a300604a43059d372ac56b504a9d704e
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201119/46ab50b3/attachment-0001.html>
More information about the ghc-commits
mailing list