From 7c1d533fc596acd5a6a4f197f9f3f3313dd82def Mon Sep 17 00:00:00 2001
From: Yuchen Pei <hi@ypei.me>
Date: Thu, 21 Jul 2022 13:23:51 +1000
Subject: fixing org backend for ghc-head (9.5)

---
 haddock-api/src/Haddock.hs              |  2 +-
 haddock-api/src/Haddock/Backends/Org.hs | 46 +++++++++++++++++----------------
 2 files changed, 25 insertions(+), 23 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 40cf8414..d011078a 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -472,7 +472,7 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc
                    libDir
       return ()
   when (Flag_Org `elem` flags) $ do
-    withTiming logger dflags' "ppOrg" (const ()) $ do
+    withTiming logger "ppOrg" (const ()) $ do
       let org = {-# SCC ppOrg #-} ppOrg title (_doc <$> prologue) (fromJust pkgStr) visibleIfaces
       writeUtf8File (fromMaybe "haddock" (cleanPkgStr <$> pkgStr) <.> "org") org 
 
diff --git a/haddock-api/src/Haddock/Backends/Org.hs b/haddock-api/src/Haddock/Backends/Org.hs
index 9d02d0db..d651551d 100644
--- a/haddock-api/src/Haddock/Backends/Org.hs
+++ b/haddock-api/src/Haddock/Backends/Org.hs
@@ -245,8 +245,10 @@ processExport _ (ExportModule mdl ) = do
 ppFnArgsDoc :: FnArgsDoc DocName -> [OrgBlock]
 ppFnArgsDoc aDoc = if M.null aDoc
   then []
-  else ((`ppDoc` Nothing) . DocParagraph . DocString) "Arguments (in order):"
-    ++ ((`ppDoc` Nothing) . DocOrderedList . toList . M.map _doc) aDoc
+  else
+    ((`ppDoc` Nothing) . DocParagraph . DocString) "Arguments (in order):"
+      ++ ((`ppDoc` Nothing) . DocOrderedList . map snd . toList . M.map _doc)
+           aDoc
 
 ppDocumentation :: Documentation DocName -> Maybe Int -> [OrgBlock]
 ppDocumentation (Documentation (Just mdoc) _) minLevel = ppMDoc mdoc minLevel
@@ -266,7 +268,7 @@ ppDocBlock (DocParagraph x) _    = [Paragraph (ppDocInline x)]
 ppDocBlock (DocUnorderedList docs) _ =
   [PlainList Unordered $ (`ppDocBlock` Nothing) <$> docs]
 ppDocBlock (DocOrderedList items) _ =
-  [PlainList Ordered (map ((`ppDocBlock` Nothing) . snd) items)]
+  [PlainList Ordered (map (`ppDocBlock` Nothing) items)]
 ppDocBlock (DocDefList pairs) _ =
   [ DefList
       $   (\(term, def) -> (ppDocInline term, ppDocBlock def Nothing))
@@ -653,19 +655,19 @@ ppConDecl (ConDeclH98 _ (L _ docName) _forall exTvs mbCtxt args _) subdocs path
         ]
       _ -> ppFnArgsDoc aDoc
 -- TODO: handle con_bndrs and con_mb_cxt
-ppConDecl (ConDeclGADT _ names _ _ args resTy _) subdocs path level =
-  [ Heading
-      level
-      (  interNotNull
-          [Whitespace]
-          [ intersperse (Plain $ text ", ")
-                        (map (Plain . docNameToDoc . unLoc) names)
-          , [plaintext "::"]
-          ]
-      ++ [Whitespace]
-      ++ ppConDeclGADTDetailsPrefix args resTy
-      )
-      (concatMap (cIdPaths path . unLoc) names)
+ppConDecl (ConDeclGADT { con_names = names, con_g_args = args, con_res_ty = resTy }) subdocs path level
+  = [ Heading
+        level
+        (  interNotNull
+            [Whitespace]
+            [ intersperse (Plain $ text ", ")
+                          (map (Plain . docNameToDoc . unLoc) names)
+            , [plaintext "::"]
+            ]
+        ++ [Whitespace]
+        ++ ppConDeclGADTDetailsPrefix args resTy
+        )
+        (concatMap (cIdPaths path . unLoc) names)
     ]
     ++ maybe []
              (`ppDocForDecl` (Just level))
@@ -692,7 +694,7 @@ ppConDeclGADTDetailsRec
   -> ModPath
   -> Int
   -> [OrgBlock]
-ppConDeclGADTDetailsRec (RecConGADT (L _ args)) resTy subdocs path level =
+ppConDeclGADTDetailsRec (RecConGADT (L _ args) _) resTy subdocs path level =
   concatMap (\arg -> ppConDeclField (unLoc arg) subdocs path level) args
     ++ [Heading level (plaintext "} -> " : ppLHsType resTy) []]
 ppConDeclGADTDetailsRec _ _ _ _ _ = []
@@ -810,8 +812,8 @@ ppHsSigTypeDoc (HsSig _ bndrs (L _ ty)) adoc =
   ppHsTypeDoc :: HsType DocNameI -> Int -> [DefListItem]
   ppHsTypeDoc (HsFunTy _ _ (L _ lTy) (L _ rTy)) i =
     ppHsTypeDoc lTy i ++ ppHsTypeDoc rTy (i + 1)
-  ppHsTypeDoc (HsQualTy _ mbCtxt (L _ body)) i =
-    (ppMbLHsContext mbCtxt, []) : ppHsTypeDoc body i
+  ppHsTypeDoc (HsQualTy _ ctxt (L _ body)) i =
+    (ppMbLHsContext (Just ctxt), []) : ppHsTypeDoc body i
   ppHsTypeDoc (HsForAllTy _ tele (L _ body)) i =
     (ppHsForAllTelescope tele ++ [plaintext "."], []) : ppHsTypeDoc body i
   ppHsTypeDoc typ i = [(ppHsType typ, ppADoc adoc i)]
@@ -832,8 +834,8 @@ ppHsType :: HsType DocNameI -> [OrgInline]
 ppHsType (HsForAllTy _ tele (L _ body)) =
   ppHsForAllTelescope tele ++ [plaintext ".", Whitespace] ++ ppHsType body
 -- e.g. forall a. Ord a => a
-ppHsType (HsQualTy _ mbCtxt (L _ body)) =
-  interNotNull [Whitespace] [ppMbLHsContext mbCtxt, ppHsType body]
+ppHsType (HsQualTy _ ctxt (L _ body)) =
+  interNotNull [Whitespace] [ppMbLHsContext (Just ctxt), ppHsType body]
 -- e.g. Bool
 ppHsType (HsTyVar _ promo (L _ docName)) =
   ppPromoted promo ++ ppDocName docName
@@ -857,7 +859,7 @@ ppHsType (HsTupleTy _ sort tys) = orgParens $ maybeUnbox $ intercalate
 -- e.g. (# a | b #)    
 ppHsType (HsSumTy _ tys) =
   orgParens . orgUnbox $ intercalate [plaintext " | "] (map ppLHsType tys)
-ppHsType (HsOpTy _ (L _ lTy) (L _ docName) (L _ rTy)) =
+ppHsType (HsOpTy _ _promo (L _ lTy) (L _ docName) (L _ rTy)) =
   intercalate [Whitespace] [ppHsType lTy, ppDocName docName, ppHsType rTy]
 -- e.g. (a -> a)
 ppHsType (HsParTy _ (L _ t)) = orgParens $ ppHsType t
-- 
cgit v1.2.3