Commit 7255501a authored by Alan Zimmerman's avatar Alan Zimmerman
Browse files

Working on check-exact. Making progress

Working on the ghc-exact bit
parent 0138c4b4
......@@ -1313,8 +1313,8 @@ type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)
-- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'.
lhsTypeArgSrcSpan :: LHsTypeArg pass -> SrcSpan
lhsTypeArgSrcSpan arg = case arg of
HsValArg tm -> getLoc tm
HsTypeArg at ty -> at `combineSrcSpans` getLoc ty
HsValArg tm -> getLocA tm
HsTypeArg at ty -> at `combineSrcSpans` getLocA ty
HsArgPar sp -> sp
instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where
......
......@@ -712,9 +712,9 @@ typeToLHsType ty
, hst_body = go tau })
go ty@(ForAllTy (Bndr _ argf) _)
= noLoc (HsForAllTy { hst_tele = tele
, hst_xforall = noAnn
, hst_body = go tau })
= noLocA (HsForAllTy { hst_tele = tele
, hst_xforall = noAnn
, hst_body = go tau })
where
(tele, tau)
| isVisibleArgFlag argf
......@@ -770,7 +770,7 @@ typeToLHsType ty
go_tv :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
go_tv (Bndr tv flag) = noLoc $ KindedTyVar noAnn
flag
(noLoc (getRdrName tv))
(noLocA (getRdrName tv))
(go (tyVarKind tv))
{-
......
......@@ -1666,9 +1666,9 @@ instance ToHie (LHsType GhcRn) where
toHie x = toHie $ TS (ResolvedScopes []) x
instance ToHie (TScoped (LHsType GhcRn)) where
toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
toHie (TS tsc (L span t)) = concatM $ makeNodeA t span : case t of
HsForAllTy _ tele body ->
let scope = mkScope $ getLoc body in
let scope = mkScope $ getLocA body in
[ case tele of
HsForAllVis { hsf_vis_bndrs = bndrs } ->
toHie $ tvScopes tsc scope bndrs
......
......@@ -1930,7 +1930,7 @@ unpackedness :: { Located ([AddApiAnn], SourceText, SrcUnpackedness) }
| '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) }
-- AZ: this is new, will need work
forall_telescope :: { Located ([AddAnn], HsForAllTelescope GhcPs) }
forall_telescope :: { Located ([AddApiAnn], HsForAllTelescope GhcPs) }
: 'forall' tv_bndrs '.' {% do { hintExplicitForall $1
; pure $ sLL $1 $>
( [mu AnnForall $1, mu AnnDot $3]
......@@ -1952,15 +1952,12 @@ ktypedoc :: { LHsType GhcPs }
-- A ctype is a for-all type
ctype :: { LHsType GhcPs }
-- AZ: next two productions are new, will need work
: forall_telescope ctype {% let (forall_anns, forall_tele) = unLoc $1 in
ams (sLL $1 $> $
acsA (\cs -> sLL $1 (reLoc $>) $
HsForAllTy { hst_tele = forall_tele
, hst_xforall = noExtField
, hst_body = $2 })
forall_anns }
| context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> return (sLL $1 $> $
, hst_xforall = ApiAnn (glR $1) forall_anns cs
, hst_body = $2 }) }
| context '=>' ctype {% acsA (\cs -> (sLL (reLoc $1) (reLoc $>) $
HsQualTy { hst_ctxt = $1
, hst_xqual = ApiAnn (glAR $1) [mu AnnDarrow $2] cs
, hst_body = $3 })) }
......@@ -1982,16 +1979,14 @@ ctype :: { LHsType GhcPs }
ctypedoc :: { LHsType GhcPs }
-- AZ: next two productions are new, will need work
: forall_telescope ctypedoc {% let (forall_anns, forall_tele) = unLoc $1 in
ams (sLL $1 $> $
acsA (\cs -> (sLL $1 (reLoc $>) $
HsForAllTy { hst_tele = forall_tele
, hst_xforall = noExtField
, hst_body = $2 })
forall_anns }
| context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> return (sLL $1 $> $
, hst_xforall = ApiAnn (glR $1) forall_anns cs
, hst_body = $2 })) }
| context '=>' ctypedoc {% acsA (\cs -> (sLL (reLoc $1) (reLoc $>) $
HsQualTy { hst_ctxt = $1
, hst_xqual = ApiAnn (glAR $1) [mu AnnDarrow $2] cs
, hst_body = $3 }) )}
, hst_body = $3 })) }
| ipvar '::' type {% acsA (\cs -> sLL $1 (reLoc $>) (HsIParamTy (ApiAnn (glR $1) [mu AnnDcolon $2] cs) $1 $3)) }
| typedoc { $1 }
......
......@@ -267,6 +267,9 @@ lookupTopBndrRn rdr_name =
lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn
lookupLocatedTopBndrRnN :: LocatedN RdrName -> RnM (LocatedN Name)
lookupLocatedTopBndrRnN = wrapLocMN lookupTopBndrRn
-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].
-- This never adds an error, but it may return one, see
-- Note [Errors in lookup functions]
......
......@@ -385,7 +385,8 @@ rnImplicitBndrs mb_assoc implicit_vs_with_dups thing_inside
-- Use the currently set SrcSpan as the new source location for each Name.
-- See Note [Source locations for implicitly bound type variables].
; loc <- getSrcSpanM
; vars <- mapM (newTyVarNameRn mb_assoc . L loc . unLoc) implicit_vs
; let loc' = noAnnSrcSpan loc
; vars <- mapM (newTyVarNameRn mb_assoc . L loc' . unLoc) implicit_vs
; bindLocalNamesFV vars $
thing_inside vars }
......@@ -563,7 +564,7 @@ rnHsTyKi env ty@(HsForAllTy { hst_tele = tele, hst_body = tau })
= do { checkPolyKinds env ty
; bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' ->
do { (tau', fvs) <- rnLHsTyKi env tau
; return ( HsForAllTy { hst_xforall = noExtField
; return ( HsForAllTy { hst_xforall = noAnn
, hst_tele = tele' , hst_body = tau' }
, fvs) } }
......@@ -885,13 +886,8 @@ bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside
bndrs = map hsLTyVarLocName hs_tv_bndrs
implicit_kvs = filterFreeVarsToBind bndrs $
bndr_kv_occs ++ body_kv_occs
<<<<<<< variant A
body_remaining = filterFreeVarsToBind bndr_kv_occs $
filterFreeVarsToBind bndrs body_kv_occs
>>>>>>> variant B
del = deleteBys eqLocated
body_remaining = (body_kv_occs `del` bndrs) `del` bndr_kv_occs
======= end
all_bound_on_lhs = null body_remaining
; traceRn "checkMixedVars3" $
......@@ -927,7 +923,7 @@ bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside
--
-- class C (a :: j) (b :: k) where
-- ^^^^^^^^^^^^^^^
bndrs_loc = case map getLoc hs_tv_bndrs ++ map getLoc body_kv_occs of
bndrs_loc = case map getLoc hs_tv_bndrs ++ map getLocA body_kv_occs of
[] -> panic "bindHsQTyVars.bndrs_loc"
[loc] -> loc
(loc:locs) -> loc `combineSrcSpans` last locs
......@@ -1128,24 +1124,15 @@ bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x fl lrdr@(L lv _) kind))
$ thing_inside (L loc (KindedTyVar x fl (L lv tv_nm) kind'))
; return (b, fvs1 `plusFV` fvs2) }
<<<<<<< variant A
newTyVarNameRn :: Maybe a -- associated class
-> Located RdrName -> RnM Name
-> LocatedN RdrName -> RnM Name
newTyVarNameRn mb_assoc lrdr@(L _ rdr)
>>>>>>> variant B
newTyVarNameRn :: Maybe a -> LocatedN RdrName -> RnM Name
newTyVarNameRn mb_assoc (L loc rdr)
======= end
= do { rdr_env <- getLocalRdrEnv
; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
(Just _, Just n) -> return n
-- Use the same Name as the parent class decl
<<<<<<< variant A
_ -> newLocalBndrRn lrdr }
>>>>>>> variant B
_ -> newLocalBndrRn (L loc rdr) }
======= end
{-
*********************************************************
* *
......@@ -1792,11 +1779,7 @@ extractHsTyVarBndrsKVs tv_bndrs = extract_hs_tv_bndrs_kvs tv_bndrs
-- Returns the free kind variables in a type family result signature, returning
-- variable occurrences in left-to-right order.
-- See Note [Ordering of implicit variables].
<<<<<<< variant A
extractRdrKindSigVars :: LFamilyResultSig GhcPs -> FreeKiTyVars
>>>>>>> variant B
extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [LocatedN RdrName]
======= end
extractRdrKindSigVars (L _ resultSig) = case resultSig of
KindSig _ k -> extractHsTyRdrTyVars k
TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k
......@@ -1905,12 +1888,7 @@ extract_hs_tv_bndrs_kvs tv_bndrs =
foldr extract_lty []
[k | L _ (KindedTyVar _ _ _ k) <- tv_bndrs]
<<<<<<< variant A
extract_tv :: Located RdrName -> FreeKiTyVars -> FreeKiTyVars
>>>>>>> variant B
extract_tv :: LocatedN RdrName
-> [LocatedN RdrName] -> [LocatedN RdrName]
======= end
extract_tv :: LocatedN RdrName -> FreeKiTyVars -> FreeKiTyVars
extract_tv tv acc =
if isRdrTyVar (unLoc tv) then tv:acc else acc
......
......@@ -730,7 +730,7 @@ rnFamInstEqn doc atfi rhs_kvars
-- is what lhs_loc corresponds to.
all_imp_var_names = map (`setNameLoc` lhs_loc) all_imp_var_names'
groups :: [NonEmpty (Located RdrName)]
groups :: [NonEmpty (LocatedN RdrName)]
groups = equivClasses cmpLocated $
pat_kity_vars_with_dups
; nms_dups <- mapM (lookupOccRn . unLoc) $
......@@ -783,7 +783,7 @@ rnFamInstEqn doc atfi rhs_kvars
--
-- type instance F a b c = Either a b
-- ^^^^^
lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLoc rhs_kvars of
lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLocA rhs_kvars of
[] -> panic "rnFamInstEqn.lhs_loc"
[loc] -> loc
(loc:locs) -> loc `combineSrcSpans` last locs
......@@ -2188,12 +2188,12 @@ rnConDecl (XConDecl (ConDeclGADTPrefixPs { con_gp_names = names, con_gp_ty = ty
; case res_ty of
L l (HsForAllTy { hst_tele = tele })
| HsForAllVis{} <- tele
-> setSrcSpan l $ addErr $ withHsDocContext ctxt $ vcat
-> setSrcSpanA l $ addErr $ withHsDocContext ctxt $ vcat
[ text "Illegal visible, dependent quantification" <+>
text "in the type of a term"
, text "(GHC does not yet support this)" ]
| HsForAllInvis{} <- tele
-> nested_foralls_contexts_err l ctxt
-> nested_foralls_contexts_err (locA l) ctxt
L l (HsQualTy {})
-> nested_foralls_contexts_err (locA l) ctxt
_ -> pure ()
......
......@@ -136,7 +136,7 @@ checkShadowedRdrNames loc_rdr_names
where
filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names
-- See Note [Binders in Template Haskell] in "GHC.ThToHs"
get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr)
get_loc_occ (L loc rdr) = (locA loc,rdrNameOcc rdr)
checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
checkDupAndShadowedNames envs names
......
......@@ -2445,10 +2445,10 @@ getGhciStepIO = do
let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
step_ty = noLoc $ HsForAllTy
step_ty = noLocA $ HsForAllTy
{ hst_tele = mkHsForAllInvisTele
[noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)]
, hst_xforall = noExtField
[noLoc $ UserTyVar noAnn SpecifiedSpec (noLocA a_tv)]
, hst_xforall = noAnn
, hst_body = nlHsFunTy ghciM ioM }
stepTy :: LHsSigWcType GhcRn
......
......@@ -1518,9 +1518,10 @@ cvtTypeKind ty_str ty
; cxt' <- cvtContext funPrec cxt
; ty' <- cvtType ty
; loc <- getL
; let loc' = noAnnSrcSpan loc
; let tele = mkHsForAllInvisTele tvs'
hs_ty = mkHsForAllTy loc tele rho_ty
rho_ty = mkHsQualTy cxt loc cxt' ty'
hs_ty = mkHsForAllTy loc' tele rho_ty
rho_ty = mkHsQualTy cxt loc' cxt' ty'
; return hs_ty }
......@@ -1529,8 +1530,9 @@ cvtTypeKind ty_str ty
-> do { tvs' <- cvtTvs tvs
; ty' <- cvtType ty
; loc <- getL
; let loc' = noAnnSrcSpan loc
; let tele = mkHsForAllVisTele tvs'
; pure $ mkHsForAllTy loc tele ty' }
; pure $ mkHsForAllTy loc' tele ty' }
SigT ty ki
-> do { ty' <- cvtType ty
......@@ -1765,13 +1767,14 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
, hst_xqual = noAnn
, hst_body = ty' }) }
| null reqs = do { l' <- getL
; let l = noAnnSrcSpan l'
; let l = noAnnSrcSpan l'
; let l'' = noAnnSrcSpan l'
; univs' <- cvtTvs univs
; ty' <- cvtType (ForallT exis provs ty)
; let forTy = HsForAllTy
{ hst_tele = mkHsForAllInvisTele univs'
, hst_xforall = noExtField
, hst_body = L l cxtTy }
, hst_xforall = noAnn
, hst_body = L l'' cxtTy }
cxtTy = HsQualTy { hst_ctxt = L l []
, hst_xqual = noAnn
, hst_body = ty' }
......@@ -1830,7 +1833,7 @@ mkHsForAllTy :: SrcSpanAnn
mkHsForAllTy loc tele rho_ty
| no_tvs = rho_ty
| otherwise = L loc $ HsForAllTy { hst_tele = tele
, hst_xforall = noExtField
, hst_xforall = noAnn
, hst_body = rho_ty }
where
no_tvs = case tele of
......
......@@ -17,7 +17,7 @@ showGhc = undefined
-- ---------------------------------------------------------------------
tt :: IO ()
tt = testOneFile "/home/alanz/mysrc/git.haskell.org/ghc/_build/bindist/ghc-8.11.0.20200524-x86_64-unknown-linux/lib"
tt = testOneFile "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
"Test.hs"
-- exact = ppr
......@@ -49,7 +49,7 @@ testOneFile libdir fileName = do
anns' = pm_annotations p
-- pped = pragmas ++ "\n" ++ (exactPrint $ pm_parsed_source p)
pped = exactPrint (pm_parsed_source p) anns'
pragmas = getPragmas anns'
-- pragmas = getPragmas anns'
newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName
astFile = fileName <.> "ast"
......@@ -58,6 +58,9 @@ testOneFile libdir fileName = do
writeFile astFile origAst
writeFile newFile pped
-- putStrLn $ "anns':" ++ showGhc (apiAnnComments anns')
-- putStrLn $ "anns':" ++ showGhc (apiAnnRogueComments anns')
p' <- parseOneFile libdir newFile
let newAstStr :: String
......@@ -66,8 +69,6 @@ testOneFile libdir fileName = do
(pm_parsed_source p')
writeFile newAstFile newAstStr
putStrLn $ "anns':" ++ showGhc (apiAnnComments anns')
putStrLn $ "anns':" ++ showGhc (apiAnnRogueComments anns')
if origAst == newAstStr
then do
......@@ -115,8 +116,8 @@ getPragmas anns' = pragmaStr
pragmas = filter (\c -> isPrefixOf "{-#" c ) comments'
pragmaStr = intercalate "\n" pragmas
pp :: (Outputable a) => a -> String
pp a = showPpr unsafeGlobalDynFlags a
-- pp :: (Outputable a) => a -> String
-- pp a = showPpr unsafeGlobalDynFlags a
-- ---------------------------------------------------------------------
......
......@@ -30,7 +30,7 @@ import Control.Monad.Identity
import Control.Monad.RWS
import Data.Data (Data, Typeable, toConstr,cast)
import Data.Foldable
import Data.List (sortBy, elemIndex)
import Data.List (sortBy, elemIndex, partition, intercalate)
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
......@@ -93,8 +93,10 @@ defaultEPState as = EPState
, epLHS = 0
, epMarkLayout = False
, priorEndPosition = (1,1)
, epComments = rogueComments as
}
-- ---------------------------------------------------------------------
------------------------------------------------------
-- The EP monad and basic combinators
......@@ -151,12 +153,19 @@ data EPState = EPState
, epLHS :: LayoutStartCol
, priorEndPosition :: !Pos -- ^ Position reached when
-- processing the last element
, epComments :: ![Comment]
}
-- ---------------------------------------------------------------------
class Data ast => Annotate ast where
markAST :: SrcSpan -> ast -> Annotated ()
-- class Data ast => Annotate ast where
-- markAST :: SrcSpan -> ast -> Annotated ()
-- ---------------------------------------------------------------------
-- AZ:TODO: this can just be a function :: (ApiAnn' a) -> Entry
class HasEntry ast where
fromAnn :: ast -> Entry
-- ---------------------------------------------------------------------
......@@ -171,8 +180,8 @@ type Annotated a = EP String Identity a
-- annotate :: (Data ast, Annotate ast) => Located ast -> Annotated ()
-- annotate = markLocated
instance (Annotate ast) => Annotate (Located ast) where
markAST l (L _ ast) = markAST l ast
-- instance (Annotate ast) => Annotate (Located ast) where
-- markAST l (L _ ast) = markAST l ast
-- ---------------------------------------------------------------------
......@@ -182,14 +191,19 @@ markAnnotated a = enterAnn (getApiAnnotation a) a
data Entry = Entry RealSrcSpan [RealLocated AnnotationComment]
| NoEntryVal
fromAnn :: ApiAnn -> Entry
fromAnn (ApiAnn anchor _ cs) = Entry anchor cs
fromAnn ApiAnnNotUsed = NoEntryVal
instance HasEntry (ApiAnn' a) where
-- fromAnn :: ApiAnn -> Entry
fromAnn (ApiAnn anchor _ cs) = Entry anchor cs
fromAnn ApiAnnNotUsed = NoEntryVal
-- instance HasEntry ApiAnnCO where
-- fromAnn :: ApiAnnCO -> Entry
-- fromAnn (ApiAnn anchor _ cs) = Entry anchor cs
-- fromAnn ApiAnnNotUsed = NoEntryVal
fromAnnCo :: ApiAnnCO -> Entry
fromAnnCo (ApiAnn anchor _ cs) = Entry anchor cs
fromAnnCo ApiAnnNotUsed = NoEntryVal
-- | "Enter" an annotation, by using the associated 'anchor' field as
-- the new reference point for calculating all DeltaPos positions.
enterAnn :: (ExactPrint a) => Entry -> a -> Annotated ()
enterAnn NoEntryVal a = do
p <- getPos
......@@ -205,8 +219,7 @@ enterAnn (Entry anchor cs) a = do
-- the current position, and the anchor.
-- off <- gets apLayoutStart
off <- gets epLHS
-- priorEndAfterComments <- getPriorEnd
priorEndAfterComments <- getPos
priorEndAfterComments <- getPriorEnd
let ss = anchor
let edp = adjustDeltaForOffset
-- Use the propagated offset if one is set
......@@ -215,7 +228,6 @@ enterAnn (Entry anchor cs) a = do
off (ss2delta priorEndAfterComments ss)
let
-- edp = DP (1,0)
st = annNone { annEntryDelta = edp }
withOffset st (advance edp >> exact a)
......@@ -246,11 +258,32 @@ enterAnn (Entry anchor cs) a = do
-- -- exactPC :: Located a -> Annotated () -> EPP ()
-- exactPC = undefined
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
-- |In order to interleave annotations into the stream, we turn them into
-- comments.
-- annotationsToCommentsDelta :: [AnnKeywordId] -> Delta ()
-- annotationsToCommentsDelta kws = do
-- ss <- getSrcSpan
-- cs <- gets apComments
-- let
-- doOne :: AnnKeywordId -> Delta [Comment]
-- doOne kw = do
-- (spans,_) <- getAndRemoveAnnotationDelta ss kw
-- return $ map (mkKWComment kw) spans
-- -- TODO:AZ make sure these are sorted/merged properly when the invariant for
-- -- allocateComments is re-established.
-- newComments <- mapM doOne kws
-- putUnallocatedComments (cs ++ concat newComments)
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
instance Annotate HsModule where
markAST l hsmod = undefined
-- instance Annotate HsModule where
-- markAST l hsmod = undefined
withPpr :: (Outputable a) => a -> Annotated ()
withPpr a = printString False (showGhc a)
......@@ -288,10 +321,13 @@ instance ExactPrint HsModule where
-- exact = withPpr
exact (HsModule anns@(ApiAnn ss as cs) mmn mexports imports decls mdeprec mbDoc) = do
as <- gets epApiAnns
debugM $ "rogue comments:\n" ++ (intercalate "\n" (map show $ rogueComments as))
case mmn of
Nothing -> return ()
Just (L ln mn) -> do
mark anns AnnModule
markApiAnn anns AnnModule
-- markExternal ln AnnVal (moduleNameString mn)
debugM $ "HsModule name: (ss,ln)=" ++ show (ss2pos ss,ss2pos (realSrcSpan ln))
printStringAtSs ss ln (moduleNameString mn)
......@@ -302,7 +338,7 @@ instance ExactPrint HsModule where
-- forM_ mexports markLocated
forM_ mexports markAnnotated
mark anns AnnWhere
markApiAnn anns AnnWhere
-- markOptional GHC.AnnOpenC -- Possible '{'
-- markManyOptional GHC.AnnSemi -- possible leading semis
......@@ -326,29 +362,82 @@ printStringAtSs anchor (RealSrcSpan ss _) str = do
-- ---------------------------------------------------------------------
printStringAtKw :: ApiAnn -> 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) -> do
dp <- nextDP ss
p <- getPos
debugM $ "printStringAtKw: (dp,p) = " ++ show (dp,p)
printStringAtLsDelta [] dp 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
printStringAtKw' :: RealSrcSpan -> String -> EPP ()
printStringAtKw' ss str = do
dp <- nextDP ss
p <- getPos
debugM $ "printStringAtKw': (dp,p) = " ++ show (dp,p)
printStringAtLsDelta [] dp str
-- ---------------------------------------------------------------------
mark :: ApiAnn -> AnnKeywordId -> EPP ()
mark ApiAnnNotUsed _ = return ()
mark (ApiAnn anchor anns _cs) kw = do
markALocatedA :: ApiAnn' AnnListItem -> AnnKeywordId -> EPP ()
markALocatedA ApiAnnNotUsed _ = return ()
markALocatedA (ApiAnn _ a _) kw = mark (lann_trailing a) kw
markALocatedN :: ApiAnn' NameAnn -> AnnKeywordId -> EPP ()
markALocatedN ApiAnnNotUsed _ = return ()
markALocatedN (ApiAnn _ a _) kw = mark (nann_trailing a) kw
markApiAnn :: ApiAnn -> AnnKeywordId -> EPP ()
markApiAnn ApiAnnNotUsed _ = return ()
markApiAnn (ApiAnn _ a _) kw = mark a kw
mark :: [AddApiAnn] -> AnnKeywordId -> EPP ()
mark anns kw = do
case find (\(AddApiAnn k _) -> k == kw) anns of
Nothing -> return ()
Just (AddApiAnn _ ss) -> do
dp <- nextDP ss
p <- getPos
debugM $ "mark: (dp,p) = " ++ show (dp,p)
printStringAtLsDelta [] dp (keywordToString (G kw))
Just aa -> markKw aa
-- | This should be the main driver of the process, managing comments
markKw :: AddApiAnn -> EPP ()
markKw (AddApiAnn kw ss) = do
p' <- getPos
cs <- commentAllocation ss
debugM $ "markKw: (ss,comment locations): " ++ showGhc (ss,map (commentIdentifier . fst) cs)
mapM_ (uncurry printQueuedComment) cs
dp <- nextDP ss
p <- getPos
debugM $ "markKw: (dp,p,p') = " ++ show (dp,p,p')
printStringAtLsDelta [] dp (keywordToString (G kw))
-- ---------------------------------------------------------------------
commentAllocation :: RealSrcSpan -> EPP [(Comment, DeltaPos)]
commentAllocation ss = do
p <- getPos
cs <- getUnallocatedComments
let (earlier,later) = partition (\(Comment _str loc _mo) -> loc <= ss) cs
putUnallocatedComments later
return $ map (\c@(Comment _str loc _mo) -> (c, ss2delta p loc)) earlier
-- ---------------------------------------------------------------------
-- commentAllocation :: (Comment -> Bool)
-- -> EPP a
-- commentAllocation p = do
-- cs <- getUnallocatedComments
-- let (allocated,cs') = allocateComments p cs
-- putUnallocatedComments cs'
-- mapM makeDeltaComment (sortBy (comparing commentIdentifier) allocated)
-- makeDeltaComment :: Comment -> EPP (Comment, DeltaPos)
-- makeDeltaComment c = do
-- let pa = commentIdentifier c
-- pe <- getPriorEnd
-- let p = ss2delta pe pa
-- p' <- adjustDeltaForOffsetM p
-- setPriorEnd (ss2posEnd pa)
-- return (c, p')
-- ---------------------------------------------------------------------
......@@ -360,7 +449,7 @@ markLocatedA (L (SrcSpanAnn ann l) a) = do
-- ---------------------------------------------------------------------