even more ghcutils fixes

1 files changed, 74 insertions, 128 deletions

diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs
index b408570..65244e9 100644
--- a/src/HaskellCodeExplorer/GhcUtils.hs
+++ b/src/HaskellCodeExplorer/GhcUtils.hs
@@ -64,7 +64,11 @@ module HaskellCodeExplorer.GhcUtils
 import GHC.Data.Bag (bagToList)
 -- import ConLike (ConLike(..))
 import GHC.Core.ConLike (ConLike(..))
-import GHC.HsToCore.Docs (collectDocs)
+import GHC.HsToCore.Docs
+  ( collectDocs
+  , ungroup
+  , mkDecls
+  )
 import qualified Data.ByteString as BS
 import Data.Hashable (Hashable,hash)
 import qualified Data.ByteString.Internal as BSI
@@ -80,9 +84,11 @@ import qualified Data.Text as T
 -- import DataCon (dataConWorkId, flSelector)
 import GHC.Core.DataCon (dataConWorkId, flSelector)
 import Documentation.Haddock.Parser (overIdentifier, parseParas)
-import Documentation.Haddock.Types (DocH(..),
-                                    Header(..),
-                                    _doc
+import Documentation.Haddock.Types
+  ( DocH(..)
+  , Header(..)
+  , _doc
+  , Namespace
  )
 -- import DynFlags ()
 import GHC.Driver.Session (DynFlags)
@@ -90,6 +96,8 @@ import GHC.Driver.Session (DynFlags)
 import GHC.Data.FastString (mkFastString, unpackFS)
 import GHC
   ( DynFlags
+  , CollectFlag(..)
+  , reLocN
   , unXRec
   , UnXRec
   , GhcPass
@@ -257,7 +265,11 @@ import GHC.Parser (parseIdentifier)
 import GHC.Core.PatSyn (PatSyn, patSynMatcher, patSynSig)
 import Prelude hiding (id, span)
 -- import RdrName (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName)
-import GHC.Types.Name.Reader (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName)
+import GHC.Types.Name.Reader
+  ( GlobalRdrEnv
+  , RdrName(..)
+  , grePrintableName
+  , lookupGRE_RdrName)
 -- import RnEnv (dataTcOccs)
 import GHC.Rename.Env (dataTcOccs)
 -- import SrcLoc (GenLocated(..), mkRealSrcLoc, unLoc)
@@ -269,13 +281,14 @@ import System.FilePath (normalise)
 import GHC.Tc.Types.Evidence (HsWrapper(..), tcCoercionKind)
 -- import TcType (evVarPred)
 import GHC.Tc.Utils.TcType (evVarPred)
-import GHC.Core.TyCo.Rep (Type(..),
-
-  ArgFlag(..), mkVisFunTysMany
-
-
-
- )
+import GHC.Core.TyCo.Rep
+  ( Type(..)
+  , ArgFlag(..)
+  , mkVisFunTyMany
+  , mkVisFunTys
+  , mkVisFunTysMany
+  , scaledThing
+  )
 -- import TyCon (tyConName)
 import GHC.Core.TyCon (tyConName)
 -- import Type
@@ -284,11 +297,9 @@ import GHC.Core.Type
   , expandTypeSynonyms
   , mkForAllTy
   , mkFunTy
+  , mkTyCoInvForAllTys
 --  , mkFunTys
 --  , mkInvForAllTys
-
-
-
   , piResultTy
   , splitFunTy_maybe
   , tidyOpenType, mkVisForAllTys
@@ -316,6 +327,7 @@ import GHC.Types.Var
   ( idDetails
   , isId
   , mkTyVar
+  , mkCoVar
   , setVarType
   , varName
   , varType
@@ -360,18 +372,18 @@ instanceDeclToText flags decl =
       T.append "instance " (toText flags cid_poly_ty)
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-    DataFamInstD _ di -> ""
-    --   let args =
-    --         T.intercalate " " . map (toText flags) .  feqn_pats  . hsib_body . dfid_eqn $ di
-    --    in T.concat
-    --         ["data instance ", toText flags (unLoc $ feqn_tycon . hsib_body . dfid_eqn $ di), " ", args]
-    -- TyFamInstD _ ti ->
-    --   let args =
-    --         T.intercalate " " .
-    --         map (toText flags) . feqn_pats . hsib_body . tfid_eqn $
-    --         ti
-    --    in T.concat
-    --         ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args]
+    DataFamInstD _ di ->
+      let args =
+            T.intercalate " " . map (toText flags) .  feqn_pats  . dfid_eqn $ di
+       in T.concat
+            ["data instance ", toText flags (unLoc $ feqn_tycon . dfid_eqn $ di), " ", args]
+    TyFamInstD _ ti ->
+      let args =
+            T.intercalate " " .
+            map (toText flags) . feqn_pats . tfid_eqn $
+            ti
+       in T.concat
+            ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args]
 #elif MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
     DataFamInstD di ->
       let args =
@@ -542,7 +554,7 @@ hsPatSynDetails patDetails =
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
 unwrapName :: LIEWrappedName a -> Located a
-unwrapName = undefined
+unwrapName = reLocN . ieLWrappedName
 #elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
 unwrapName :: LIEWrappedName Name -> Located Name
 unwrapName = ieLWrappedName
@@ -559,10 +571,11 @@ ieLocNames :: IE Name -> [Located Name]
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
 ieLocNames (XIE _) = []
-ieLocNames (IEVar _ n) = []
+ieLocNames (IEVar _ n) =
 #else
-ieLocNames (IEVar n) =  [unwrapName n]
+ieLocNames (IEVar n) =
 #endif
+  [unwrapName n]
 #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
 ieLocNames (IEThingAbs _ n) =
 #else
@@ -901,6 +914,7 @@ srcSpanToLineAndColNumbers ::
      HCE.SourceCodeTransformation
   -> SrcSpan
   -> Maybe (HCE.HaskellFilePath, (Int, Int), (Int, Int))
+-- do we need to do anything with the BufSpan?
 srcSpanToLineAndColNumbers transformation (RealSrcSpan s _) =
   let filePath =
         HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ s
@@ -945,11 +959,11 @@ patSynId patSyn =
         | otherwise = reqTheta
       --  required => provided => arg_1 -> ... -> arg_n -> res
       patSynTy =
-        mkVisForAllTys univTvs $
+        mkTyCoInvForAllTys univTvs $
         mkVisFunTysMany reqTheta' $
-        mkVisForAllTys exTvs $ mkVisFunTysMany provTheta $
-        mkVisFunTysMany argTys resTy
-   in flip setVarType patSynTy . fst . patSynMatcher $ patSyn
+        mkTyCoInvForAllTys exTvs $ mkVisFunTysMany provTheta $ mkVisFunTys argTys resTy
+      (name, _, _) = patSynMatcher patSyn
+   in mkCoVar name patSynTy
 
 applyWrapper :: HsWrapper -> Type -> Type
 applyWrapper wp ty
@@ -957,14 +971,16 @@ applyWrapper wp ty
 applyWrapper WpHole t = t
 applyWrapper (WpCompose w1 w2) t = applyWrapper w1 . applyWrapper w2 $ t
 #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
-applyWrapper (WpFun w1 w2 t1 _doc) t = mkFunTy t1 (applyWrapper w2 $ piResultTy t (applyWrapper w1 t1))
+applyWrapper (WpFun w1 w2 t1 _doc) t =
+  mkVisFunTys [t1] (applyWrapper w2 $ piResultTy t
+              (applyWrapper w1 $ scaledThing t1))
 #else
 applyWrapper (WpFun w1 w2 t1) t = mkFunTy t1 (applyWrapper w2 $ piResultTy t (applyWrapper w1 t1))
 #endif
 applyWrapper (WpCast coercion) _t = pSnd $ tcCoercionKind coercion
-applyWrapper (WpEvLam v) t = mkFunTy (evVarPred v) t
+applyWrapper (WpEvLam v) t = mkVisFunTyMany (evVarPred v) t
 applyWrapper (WpEvApp _ev) t = case splitFunTy_maybe t of
-  Just (_arg,res) -> res
+  Just (_, _arg,res) -> res
   Nothing -> t
 #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
 applyWrapper (WpTyLam v) t = mkForAllTy v Required t
@@ -1089,69 +1105,19 @@ tyVarsOfType = varSetElems . everything unionVarSet (emptyVarSet `mkQ` tyVar)
 -- 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
-ungroup :: HsGroup Name -> [LHsDecl Name]
-#endif
-ungroup group_ =
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD NoExtField) group_ ++
-#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
-  mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++
-#else
-  mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++
-#endif
-
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-  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_ ++
-  mkDecls hs_fords ForD group_ ++
-  mkDecls hs_docs DocD group_ ++
-#endif
-
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-  mkDecls hsGroupInstDecls (InstD NoExtField) group_ ++
-#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
-  mkDecls hsGroupInstDecls InstD group_ ++
-#else
-  mkDecls hs_instds InstD group_ ++
-#endif
-
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-  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_
-#endif
-
-
-  where
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-    typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs
-#else
-    typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs
-#endif
-    typesigs _ = []
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-    valbinds (XValBindsLR (NValBinds binds _)) = concatMap (bagToList . snd) binds
-#else
-    valbinds (ValBindsOut binds _) = concatMap (bagToList . snd) binds
-#endif
-    valbinds _ = []
+-- available in GHC.HsToCore.Docs
+-- #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+-- ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
+-- #else
+-- ungroup :: HsGroup Name -> [LHsDecl Name]
+-- #endif
 
 -- 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]
+-- mkDecls :: (struct -> [GenLocated l decl]) -> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
+-- mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
+-- mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct]
 
-sortByLoc :: [Located a] -> [Located a]
+sortByLoc :: [GenLocated l a] -> [GenLocated l a]
 sortByLoc = L.sortOn getLoc
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
@@ -1181,7 +1147,7 @@ conDeclDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)]
 conDeclDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)]
 #endif
 conDeclDocs conDecl =
-  map (\(L span n) -> (n, maybe [] ((: []) . unLoc) $ con_doc conDecl, span)) .
+  map (\con -> (unLoc con, maybe [] ((: []) . unLoc) $ con_doc conDecl, getLocA con)) .
   getConNames $
   conDecl
 
@@ -1201,41 +1167,20 @@ selectorDocs con =
         flds
     _ -> []
 
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
 subordinateNamesWithDocs :: [LHsDecl GhcRn] -> [(Name, [HsDocString], SrcSpan)]
-#else
-subordinateNamesWithDocs :: [GenLocated SrcSpan (HsDecl Name)] -> [(Name, [HsDocString], SrcSpan)]
-#endif
 subordinateNamesWithDocs =
     concatMap
-    (\(L span tyClDecl) ->
-       case tyClDecl of
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+    (\lhd ->
+       case unLoc lhd of
          TyClD _ classDecl@ClassDecl {..} ->
-#else
-         TyClD classDecl@ClassDecl {..} ->
-#endif
            concatMap
-             (\(L _ decl, docs) -> map (, docs, span) $ getMainDeclBinder decl) $
+             (\(L _ decl, docs) -> map (, docs, getLocA lhd) $ getMainDeclBinder decl) $
            classDeclDocs classDecl
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
          TyClD _ DataDecl {..} ->
-#else
-         TyClD DataDecl {..} ->
-#endif
            concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) $
            dd_cons tcdDataDefn
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
          InstD _ (DataFamInstD _ DataFamInstDecl {..}) ->
-#else
-         InstD (DataFamInstD DataFamInstDecl {..}) ->
-#endif
-
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
            concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs $ dfid_eqn
-#else
-           concatMap (conDeclDocs . unLoc) . dd_cons $ dfid_defn
-#endif
          _ -> [])
 
 
@@ -1264,7 +1209,7 @@ getMainDeclBinder (ValD _ d) =
 #else
 getMainDeclBinder (ValD d) =
 #endif
-  case collectHsBindBinders d of
+  case collectHsBindBinders CollNoDictBinders d of
     [] -> []
     (name:_) -> [name]
 #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
@@ -1315,8 +1260,8 @@ hsDocsToDocH flags rdrEnv =
     . concatMap (unpackFS . (\(HsDocString s) -> s))
 #endif
 
-parseIdent :: DynFlags -> String -> Maybe RdrName
-parseIdent dflags str0 =
+parseIdent :: DynFlags -> Namespace -> String -> Maybe RdrName
+parseIdent dflags _ str0 =
   let buffer = stringToStringBuffer str0
       realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0
       pstate = initParserState (initParserOpts dflags) buffer realSrcLc
@@ -1329,6 +1274,7 @@ type Doc id = DocH (ModuleName, OccName) id
 rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
 rename dflags gre = rn
   where
+    rn :: Doc RdrName -> Doc Name
     rn d = case d of
       DocAppend a b -> DocAppend (rn a) (rn b)
       DocParagraph doc -> DocParagraph (rn doc)
@@ -1338,7 +1284,7 @@ rename dflags gre = rn
         let choices = dataTcOccs x
         -- Try to look up all the names in the GlobalRdrEnv that match
         -- the names.
-        let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
+        let names = concatMap (\c -> map grePrintableName (lookupGRE_RdrName c gre)) choices
 
         case names of
           -- We found no names in the env so we start guessing.
@@ -1373,8 +1319,8 @@ rename dflags gre = rn
       DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
       DocCodeBlock doc -> DocCodeBlock (rn doc)
       DocIdentifierUnchecked x -> DocIdentifierUnchecked x
-      DocModule str -> DocModule str
-      DocHyperlink l -> DocHyperlink l
+      DocModule modLink -> DocModule (rn <$> modLink)
+      DocHyperlink hyperLink -> DocHyperlink (rn <$> hyperLink)
       DocPic str -> DocPic str
       DocMathInline str -> DocMathInline str
       DocMathDisplay str -> DocMathDisplay str