From 888dd5e3ea383c00d44e92e736acccdf340301ab Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 23 Oct 2022 22:07:54 +0100 Subject: [PATCH] Match GHc wip/az/locatedn-epa-improve branch --- haddock-api/src/Haddock/Backends/Hoogle.hs | 7 +++++-- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 2 +- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 12 ++++++------ haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 2 +- haddock-api/src/Haddock/Convert.hs | 2 +- haddock-api/src/Haddock/GhcUtils.hs | 2 +- haddock-api/src/Haddock/Interface.hs | 2 +- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++-- haddock-api/src/Haddock/Types.hs | 13 +++++-------- 10 files changed, 24 insertions(+), 24 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index e0bc9380c8..c074c38678 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -1,6 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +-- AZ temporary +{-# LANGUAGE RankNTypes #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle @@ -346,9 +349,9 @@ docWith dflags header d maybe [] (showTags . markup (markupTag dflags)) d mkSubdocN :: DynFlags -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String] -mkSubdocN dflags n subdocs s = mkSubdoc dflags (n2l n) subdocs s +mkSubdocN dflags n subdocs s = mkSubdoc dflags n subdocs s -mkSubdoc :: DynFlags -> LocatedA Name -> [(Name, DocForDecl Name)] -> [String] -> [String] +mkSubdoc :: DynFlags -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String] mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s where getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 282756ac65..c7920727eb 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -96,7 +96,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do path = srcdir hypSrcModuleFile (ifaceMod iface) emptyHieAst fileFs = Node - { nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) Strict.Nothing + { nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) , nodeChildren = [] , sourcedNodeInfo = SourcedNodeInfo mempty } diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 83097fbed7..db4203eb36 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -79,11 +79,11 @@ parse dflags fpath bs = case unP (go False []) initState of -- | Like 'Lexer.lexer', but slower, with a better API, and filtering out empty tokens wrappedLexer :: P (RealLocated Lexer.Token) wrappedLexer = Lexer.lexer False andThen - where andThen (L (RealSrcSpan s) t) + where andThen (L (RealSrcSpan s _) t) | srcSpanStartLine s /= srcSpanEndLine s || srcSpanStartCol s /= srcSpanEndCol s = pure (L s t) - andThen (L (RealSrcSpan s) ITeof) = pure (L s ITeof) + andThen (L (RealSrcSpan s _) ITeof) = pure (L s ITeof) andThen _ = wrappedLexer -- | Try to parse a CPP line (can fail) @@ -94,7 +94,7 @@ parse dflags fpath bs = case unP (go False []) initState of Just (cppBStr, l', b') -> let cppTok = T.Token { tkType = TkCpp , tkValue = cppBStr - , tkSpan = mkRealSrcSpan l l' Strict.Nothing } + , tkSpan = mkRealSrcSpan l l' } in setInput (b', l') *> pure (Just ([cppTok], False)) _ -> return Nothing @@ -106,7 +106,7 @@ parse dflags fpath bs = case unP (go False []) initState of (bEnd, _) <- lift getInput case sp of UnhelpfulSpan _ -> pure ([], False) -- pretend the token never existed - RealSrcSpan rsp -> do + RealSrcSpan rsp _ -> do let typ = if inPrag then TkPragma else classify tok RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real (spaceBStr, bStart) = spanPosition lInit lStart bInit @@ -145,7 +145,7 @@ parse dflags fpath bs = case unP (go False []) initState of , tkSpan = rsp } spaceTok = T.Token { tkType = TkSpace , tkValue = spaceBStr - , tkSpan = mkRealSrcSpan lInit lStart Strict.Nothing} + , tkSpan = mkRealSrcSpan lInit lStart } pure (plainTok : [ spaceTok | not (BS.null spaceBStr) ], inPrag') @@ -156,7 +156,7 @@ parse dflags fpath bs = case unP (go False []) initState of let (unkBStr, l', b') = spanLine l b unkTok = T.Token { tkType = TkUnknown , tkValue = unkBStr - , tkSpan = mkRealSrcSpan l l' Strict.Nothing } + , tkSpan = mkRealSrcSpan l l' } setInput (b', l') pure ([unkTok], False) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index c61282a0a8..41afe5a0d4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -168,7 +168,7 @@ subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRo : map (cell . (td <<)) subs linkHtml :: SrcSpan -> Maybe Module -> DocName -> Html - linkHtml loc@(RealSrcSpan _) mdl dn = links lnks loc splice mdl dn + linkHtml loc@(RealSrcSpan _ _) mdl dn = links lnks loc splice mdl dn linkHtml _ _ _ = noHtml subBlock :: [Html] -> Maybe Html diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index 94865eda16..7f8be25a6a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -73,7 +73,7 @@ spliceURL' maybe_mod maybe_name maybe_loc = run Nothing -> "" Just span_ -> case span_ of - RealSrcSpan span__ -> + RealSrcSpan span__ _ -> show $ srcSpanStartLine span__ UnhelpfulSpan _ -> "" diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 436504a823..08c07ae3fe 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -104,7 +104,7 @@ tyThingToLHsDecl prr t = case t of -- Without this signature, we trigger GHC#18932 cvt (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noAnn - (L (na2la name_loc) (HsTyVar noAnn NotPromoted (L name_loc n))) kind + (L (l2l name_loc) (HsTyVar noAnn NotPromoted (L name_loc n))) kind -- | Convert a LHsTyVarBndr to an equivalent LHsType. hsLTyVarBndrToType :: LHsTyVarBndr flag GhcRn -> LHsType GhcRn diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 3fab1a1355..ec8991140d 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -460,7 +460,7 @@ unL (L _ x) = x reL :: a -> GenLocated l a reL = L undefined -mapMA :: Monad m => (a -> m b) -> LocatedAn an a -> m (Located b) +mapMA :: Monad m => (a -> m b) -> LocatedAnS an a -> m (Located b) mapMA f (L al a) = L (locA al) <$> f a ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index b1360cb5b2..cd94add63c 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -290,7 +290,7 @@ processModule verbosity modSummary flags ifaceMap instIfaceMap = do where formatName :: SrcSpan -> HsDecl GhcRn -> String formatName loc n = p (getMainDeclBinder emptyOccEnv n) ++ case loc of - RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ + RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" _ -> "" diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index c23c689129..e2157a246b 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -500,7 +500,7 @@ renameDecl decl = case decl of return (DerivD noExtField d') _ -> error "renameDecl" -renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> LocatedAn an (a GhcRn) -> RnM (Located (a DocNameI)) +renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> LocatedAnS an (a GhcRn) -> RnM (Located (a DocNameI)) renameLThing fn (L loc x) = return . L (locA loc) =<< fn x renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI) @@ -658,7 +658,7 @@ renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do sel' <- renameName sel - return $ L l (FieldOcc sel' lbl) + return $ L (l2l l) (FieldOcc sel' lbl) renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 273e08ae7c..c140f617a1 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -817,7 +817,7 @@ type instance Anno [LocatedA (HsType DocNameI)] = SrcSpanAnnC type instance Anno (HsType DocNameI) = SrcSpanAnnA type instance Anno (DataFamInstDecl DocNameI) = SrcSpanAnnA type instance Anno (DerivStrategy DocNameI) = SrcAnn NoEpAnns -type instance Anno (FieldOcc DocNameI) = SrcAnn NoEpAnns +type instance Anno (FieldOcc DocNameI) = SrcSpanAnnA type instance Anno (ConDeclField DocNameI) = SrcSpan type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan @@ -979,6 +979,9 @@ instance NFData Fixity where instance NFData ann => NFData (SrcSpanAnn' ann) where rnf (SrcSpanAnn a ss) = a `deepseq` ss `deepseq` () +instance NFData ann => NFData (EpAnnS ann) where + rnf (EpAnnS anc anns cs) = anc`deepseq` anns `deepseq` cs `deepseq` () + instance NFData (EpAnn NameAnn) where rnf EpAnnNotUsed = () rnf (EpAnn en ann cs) = en `deepseq` ann `deepseq` cs `deepseq` () @@ -1034,7 +1037,7 @@ instance NFData NameAdornment where rnf NameSquare = () instance NFData EpaLocation where - rnf (EpaSpan ss bs) = ss `seq` bs `deepseq` () + rnf (EpaSpan ss) = ss `deepseq` () rnf (EpaDelta dp lc) = dp `seq` lc `deepseq` () instance NFData EpAnnComments where @@ -1049,8 +1052,6 @@ instance NFData EpaCommentTok where rnf (EpaDocOptions s) = rnf s rnf (EpaLineComment s) = rnf s rnf (EpaBlockComment s) = rnf s - rnf EpaEofComment = () - instance NFData a => NFData (Strict.Maybe a) where rnf Strict.Nothing = () @@ -1062,9 +1063,6 @@ instance NFData BufSpan where instance NFData BufPos where rnf (BufPos n) = rnf n -instance NFData Anchor where - rnf (Anchor ss op) = ss `seq` op `deepseq` () - instance NFData AnchorOperation where rnf UnchangedAnchor = () rnf (MovedAnchor dp) = rnf dp @@ -1072,4 +1070,3 @@ instance NFData AnchorOperation where instance NFData DeltaPos where rnf (SameLine n) = rnf n rnf (DifferentLine n m) = n `deepseq` m `deepseq` () -