Match GHc wip/az/locatedn-epa-improve branch

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)

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
       }

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)
 

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

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 _ -> ""
 

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

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
 
 -------------------------------------------------------------------------------

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) ++ ")"
             _ -> ""
 

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

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,14 +1063,10 @@ 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
 
 instance NFData DeltaPos where
   rnf (SameLine n)        = rnf n
   rnf (DifferentLine n m) = n `deepseq` m `deepseq` ()
-