fixing more ghcutils

1 files changed, 63 insertions, 106 deletions

diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs
index 4256641..16e9e00 100644
--- a/src/HaskellCodeExplorer/GhcUtils.hs
+++ b/src/HaskellCodeExplorer/GhcUtils.hs
@@ -1,4 +1,7 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -61,6 +64,7 @@ module HaskellCodeExplorer.GhcUtils
 import GHC.Data.Bag (bagToList)
 -- import ConLike (ConLike(..))
 import GHC.Core.ConLike (ConLike(..))
+import GHC.HsToCore.Docs (collectDocs)
 import qualified Data.ByteString as BS
 import Data.Hashable (Hashable,hash)
 import qualified Data.ByteString.Internal as BSI
@@ -87,6 +91,9 @@ import GHC.Data.FastString (mkFastString, unpackFS)
 import GHC
   ( DynFlags
   , unXRec
+  , UnXRec
+  , XRec
+  , LConDeclField
   , recordPatSynField
 #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
   , HsDocString
@@ -98,6 +105,8 @@ import GHC
   , Name
   , SrcSpan(..)
   , RealSrcSpan(..)
+  , SrcSpanAnnA
+  , Anno
   , ClsInstDecl(..)
   , TyClDecl(..)
   , HsDataDefn(..)
@@ -134,6 +143,7 @@ import GHC
   , NHsValBindsLR(..)
 --  , getConArgs
   , unpackHDS
+  , NoExtField(..)
 --  , NoExt(..)
   , extFieldOcc
 #else
@@ -230,6 +240,8 @@ import Distribution.Package (packageVersion)
 import GHC.Unit.State
   ( LookupResult(..)
   , lookupModuleWithSuggestions
+  , lookupUnit
+  , lookupUnitId
 --  , lookupPackage
 --  , packageNameString
   )
@@ -599,22 +611,22 @@ lookupIdInTypeEnv typeEnv name = do
     _ -> Nothing
 
 lookupNameModuleAndPackage ::
-     DynFlags
+     UnitState
   -> HCE.PackageId
   -> Name
   -> Either T.Text (HCE.HaskellModuleName, HCE.PackageId)
-lookupNameModuleAndPackage flags currentPackageId name =
+lookupNameModuleAndPackage state currentPackageId name =
   case nameModule_maybe name of
     Just Module {..} ->
-      case lookupPackage flags moduleUnitId of
-        Just packageConfig ->
+      case lookupUnit state moduleUnit of
+        Just unitInfo ->
           let packageId =
-                if (T.pack . packageNameString $ packageConfig) ==
+                if (T.pack . unitPackageNameString $ unitInfo) ==
                    HCE.name (currentPackageId :: HCE.PackageId)
                   then currentPackageId
                   else HCE.PackageId
-                         (T.pack $ packageNameString packageConfig)
-                         (packageVersion packageConfig)
+                         (T.pack $ unitPackageNameString unitInfo)
+                         (packageVersion unitInfo)
            in Right
                 ( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName
                 , packageId)
@@ -634,12 +646,13 @@ isHsBoot = T.isSuffixOf "-boot" . HCE.getHaskellModulePath
 
 moduleLocationInfo ::
      DynFlags
+  -> UnitState
   -> HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath)
   -> HCE.PackageId
   -> HCE.ComponentId
   -> ModuleName
   -> HCE.LocationInfo
-moduleLocationInfo flags moduleNameMap currentPackageId compId moduleName =
+moduleLocationInfo flags unitState moduleNameMap currentPackageId compId moduleName =
   let moduleNameText = T.pack . moduleNameString $ moduleName
       currentPackageLocation =
         HCE.ApproximateLocation
@@ -663,12 +676,12 @@ moduleLocationInfo flags moduleNameMap currentPackageId compId moduleName =
         _ ->
           case lookupModuleWithSuggestions flags moduleName Nothing of
             LookupFound Module {moduleUnit = unitId} _ ->
-              case lookupPackage flags unitId of
-                Just packInfo ->
+              case lookupUnitId unitState unitId of
+                Just unitInfo ->
                   let packageId =
                         HCE.PackageId
-                          (T.pack $ packageNameString packInfo)
-                          (packageVersion packInfo)
+                          (T.pack $ unitPackageNameString unitInfo)
+                          (packageVersion unitInfo)
                    in HCE.ApproximateLocation
                         packageId
                         (HCE.HaskellModuleName . T.pack . moduleNameString $
@@ -1077,28 +1090,10 @@ tyVarsOfType = varSetElems . everything unionVarSet (emptyVarSet `mkQ` tyVar)
 -- Some functions are copied from haddock-api package
 --------------------------------------------------------------------------------
 
-collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])]
-collectDocs = go Nothing []
-  where
-    go Nothing _ [] = []
-    go (Just prev) docs [] = finished prev docs []
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-    go prev docs (L _ (DocD _ (DocCommentNext str)):ds)
-#else
-    go prev docs (L _ (DocD (DocCommentNext str)):ds)
-#endif
-
-      | Nothing <- prev = go Nothing (str : docs) ds
-      | Just decl <- prev = finished decl docs (go Nothing [str] ds)
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-    go prev docs (L _ (DocD _ (DocCommentPrev str)):ds) = go prev (str : docs) ds
-#else
-    go prev docs (L _ (DocD (DocCommentPrev str)):ds) = go prev (str : docs) ds
-#endif
-    go Nothing docs (d:ds) = go (Just d) docs ds
-    go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
-    finished decl docs rest = (decl, reverse docs) : rest
+-- collectDocs is available in GHC.HsToCore.Docs
+-- collectDocs :: [LHsDecl p] -> [(LHsDecl p, [HsDocString])]
 
+-- also available in GHC.HsToCore.Docs
 #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
 ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
 #else
@@ -1106,7 +1101,7 @@ ungroup :: HsGroup Name -> [LHsDecl Name]
 #endif
 ungroup group_ =
 #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD NoExt) group_ ++
+  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD NoExtField) group_ ++
 #elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
   mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++
 #else
@@ -1114,10 +1109,10 @@ ungroup group_ =
 #endif
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-  mkDecls hs_derivds (DerivD NoExt) group_ ++
-  mkDecls hs_defds (DefD NoExt) group_ ++
-  mkDecls hs_fords (ForD NoExt) group_ ++
-  mkDecls hs_docs (DocD NoExt) group_ ++
+  mkDecls hs_derivds (DerivD NoExtField) group_ ++
+  mkDecls hs_defds (DefD NoExtField) group_ ++
+  mkDecls hs_fords (ForD NoExtField) group_ ++
+  mkDecls hs_docs (DocD NoExtField) group_ ++
 #else
   mkDecls hs_derivds DerivD group_ ++
   mkDecls hs_defds DefD group_ ++
@@ -1126,7 +1121,7 @@ ungroup group_ =
 #endif
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-  mkDecls hsGroupInstDecls (InstD NoExt) group_ ++
+  mkDecls hsGroupInstDecls (InstD NoExtField) group_ ++
 #elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
   mkDecls hsGroupInstDecls InstD group_ ++
 #else
@@ -1134,8 +1129,8 @@ ungroup group_ =
 #endif
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-  mkDecls (typesigs . hs_valds) (SigD NoExt) group_ ++
-  mkDecls (valbinds . hs_valds) (ValD NoExt) group_
+  mkDecls (typesigs . hs_valds) (SigD NoExtField) group_ ++
+  mkDecls (valbinds . hs_valds) (ValD NoExtField) group_
 #else
   mkDecls (typesigs . hs_valds) SigD group_ ++
   mkDecls (valbinds . hs_valds) ValD group_
@@ -1156,6 +1151,7 @@ ungroup group_ =
 #endif
     valbinds _ = []
 
+-- also available in GHC.HsToCore.Docs
 mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
 mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct]
 
@@ -1171,10 +1167,10 @@ classDeclDocs class_ = collectDocs . sortByLoc $ decls
   where
     decls = docs ++ defs ++ sigs ++ ats
 #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-    docs = mkDecls tcdDocs (DocD NoExt) class_
-    defs = mkDecls (bagToList . tcdMeths) (ValD NoExt) class_
-    sigs = mkDecls tcdSigs (SigD NoExt) class_
-    ats = mkDecls tcdATs ((TyClD NoExt) . (FamDecl NoExt)) class_
+    docs = mkDecls tcdDocs (DocD NoExtField) class_
+    defs = mkDecls (bagToList . tcdMeths) (ValD NoExtField) class_
+    sigs = mkDecls tcdSigs (SigD NoExtField) class_
+    ats = mkDecls tcdATs ((TyClD NoExtField) . (FamDecl NoExtField)) class_
 #else
     docs = mkDecls tcdDocs DocD class_
     defs = mkDecls (bagToList . tcdMeths) ValD class_
@@ -1193,37 +1189,24 @@ conDeclDocs conDecl =
   getConNames $
   conDecl
 
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+extractRecCon :: ConDecl p -> Maybe (XRec p [LConDeclField p])
+extractRecCon = undefined
+
 selectorDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)]
-#else
-selectorDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)]
-#endif
 selectorDocs con =
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-  case getConArgs con of
-#else
-  case getConDetails con of
-#endif
-    RecCon (L _ flds) ->
+  case extractRecCon con of
+    Just (L _ flds) ->
       concatMap
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
         (\(L _ (ConDeclField _ fieldOccs _ mbDoc)) ->
-#else
-        (\(L _ (ConDeclField fieldOccs _ mbDoc)) ->
-#endif
            map
              (\(L span f) ->
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
                 (extFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span))
-#else
-                (selectorFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span))
-#endif
              fieldOccs)
         flds
     _ -> []
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-subordinateNamesWithDocs :: [GenLocated SrcSpan (HsDecl GhcRn)] -> [(Name, [HsDocString], SrcSpan)]
+subordinateNamesWithDocs :: [LHsDecl GhcRn] -> [(Name, [HsDocString], SrcSpan)]
 #else
 subordinateNamesWithDocs :: [GenLocated SrcSpan (HsDecl Name)] -> [(Name, [HsDocString], SrcSpan)]
 #endif
@@ -1253,17 +1236,21 @@ subordinateNamesWithDocs =
 #endif
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-           concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs  . hsib_body $ dfid_eqn
+           concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs $ dfid_eqn
 #else
            concatMap (conDeclDocs . unLoc) . dd_cons $ dfid_defn
 #endif
          _ -> [])
 
 
-isUserLSig :: LSig name -> Bool
-isUserLSig (L _ TypeSig {})    = True
-isUserLSig (L _ ClassOpSig {}) = True
-isUserLSig _ = False
+isUserLSig :: forall p. UnXRec p => LSig p -> Bool
+isUserLSig sig = case unXRec @p sig of
+  TypeSig {} -> True
+  ClassOpSig {} -> True
+  otherwise -> False
+-- isUserLSig (L _ TypeSig {})    = True
+-- isUserLSig (L _ ClassOpSig {}) = True
+-- isUserLSig _ = False
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
 getMainDeclBinder :: HsDecl GhcRn -> [IdP GhcRn]
@@ -1301,43 +1288,13 @@ getMainDeclBinder (ForD ForeignExport {}) = []
 #endif
 getMainDeclBinder _ = []
 
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-sigNameNoLoc :: Sig pass -> [IdP pass]
-#else
-sigNameNoLoc :: Sig name -> [name]
-#endif
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-sigNameNoLoc (TypeSig _ ns _) = map unLoc ns
-#else
-sigNameNoLoc (TypeSig ns _) = map unLoc ns
-#endif
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns
-#else
-sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns
-#endif
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns
-#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
-sigNameNoLoc (PatSynSig ns _) = map unLoc ns
-#else
-sigNameNoLoc (PatSynSig n _) = [unLoc n]
-#endif
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-sigNameNoLoc (SpecSig _ n _ _) = [unLoc n]
-#else
-sigNameNoLoc (SpecSig n _ _) = [unLoc n]
-#endif
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-sigNameNoLoc (InlineSig _ n _) = [unLoc n]
-#else
-sigNameNoLoc (InlineSig n _) = [unLoc n]
-#endif
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
-#else
-sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
-#endif
+sigNameNoLoc :: forall p. UnXRec p => Sig p -> [IdP p]
+sigNameNoLoc (TypeSig _ ns _) = map (unXRec @p) ns
+sigNameNoLoc (ClassOpSig _ _ ns _) = map (unXRec @p) ns
+sigNameNoLoc (PatSynSig _ ns _) = map (unXRec @p) ns
+sigNameNoLoc (SpecSig _ n _ _) = [unXRec @p n]
+sigNameNoLoc (InlineSig _ n _) = [unXRec @p n]
+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @p) ns
 sigNameNoLoc _                         = []
 
 clsInstDeclSrcSpan :: ClsInstDecl a -> SrcSpan