1 files changed, 49 insertions, 237 deletions

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index d554eeb3..7fb71d4b 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -33,31 +33,30 @@ import Data.Bitraversable
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Map (Map)
-import Data.List (find, foldl', sortBy)
+import Data.List (find, foldl')
 import Data.Maybe
-import Data.Ord
-import Control.Applicative
 import Control.Monad
 import Data.Traversable
 import GHC.Stack (HasCallStack)
 
-import Avail hiding (avail)
-import qualified Avail
-import qualified Module
-import qualified SrcLoc
-import ConLike (ConLike(..))
+import GHC.Types.Avail hiding (avail)
+import qualified GHC.Types.Avail  as Avail
+import qualified GHC.Unit.Module as Module
+import qualified GHC.Types.SrcLoc as SrcLoc
+import GHC.Core.ConLike (ConLike(..))
 import GHC
-import HscTypes
-import Name
-import NameSet
-import NameEnv
-import Packages   ( lookupModuleInAllPackages, PackageName(..) )
-import Bag
-import RdrName
-import TcRnTypes
-import FastString ( unpackFS, bytesFS )
-import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
-import qualified Outputable as O
+import GHC.Driver.Types
+import GHC.Types.Name
+import GHC.Types.Name.Set
+import GHC.Types.Name.Env
+import GHC.Unit.State
+import GHC.Types.Name.Reader
+import GHC.Tc.Types
+import GHC.Data.FastString ( unpackFS, bytesFS )
+import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
+import qualified GHC.Utils.Outputable as O
+import GHC.HsToCore.Docs hiding (mkMaps)
+import GHC.Parser.Annotation (IsUnicodeSyntax(..))
 
 mkExceptionContext :: TypecheckedModule -> String
 mkExceptionContext =
@@ -168,7 +167,7 @@ createInterface tm flags modMap instIfaceMap =
       !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
 
   let !aliases =
-        mkAliasMap dflags $ tm_renamed_source tm
+        mkAliasMap (unitState dflags) $ tm_renamed_source tm
 
   modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
 
@@ -213,12 +212,13 @@ createInterface tm flags modMap instIfaceMap =
   , ifaceDynFlags          = dflags
   }
 
+
 -- | Given all of the @import M as N@ declarations in a package,
 -- create a mapping from the module identity of M, to an alias N
 -- (if there are multiple aliases, we pick the last one.)  This
 -- will go in 'ifaceModuleAliases'.
-mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
-mkAliasMap dflags mRenamedSource =
+mkAliasMap :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName
+mkAliasMap state mRenamedSource =
   case mRenamedSource of
     Nothing -> M.empty
     Just (_,impDecls,_,_) ->
@@ -226,7 +226,7 @@ mkAliasMap dflags mRenamedSource =
       mapMaybe (\(SrcLoc.L _ impDecl) -> do
         SrcLoc.L _ alias <- ideclAs impDecl
         return $
-          (lookupModuleDyn dflags
+          (lookupModuleDyn state
              -- TODO: This is supremely dodgy, because in general the
              -- UnitId isn't going to look anything like the package
              -- qualifier (even with old versions of GHC, the
@@ -241,7 +241,7 @@ mkAliasMap dflags mRenamedSource =
              -- them to the user.  We should reuse that information;
              -- or at least reuse the renamed imports, which know what
              -- they import!
-             (fmap Module.fsToUnitId $
+             (fmap Module.fsToUnit $
               fmap sl_fs $ ideclPkgQual impDecl)
              (case ideclName impDecl of SrcLoc.L _ name -> name),
            alias))
@@ -285,13 +285,13 @@ unrestrictedModuleImports idecls =
 -- Similar to GHC.lookupModule
 -- ezyang: Not really...
 lookupModuleDyn ::
-  DynFlags -> Maybe UnitId -> ModuleName -> Module
+  UnitState -> Maybe Unit -> ModuleName -> Module
 lookupModuleDyn _ (Just pkgId) mdlName =
   Module.mkModule pkgId mdlName
-lookupModuleDyn dflags Nothing mdlName =
-  case lookupModuleInAllPackages dflags mdlName of
+lookupModuleDyn state Nothing mdlName =
+  case lookupModuleInAllUnits state mdlName of
     (m,_):_ -> m
-    [] -> Module.mkModule Module.mainUnitId mdlName
+    [] -> Module.mkModule Module.mainUnit mdlName
 
 
 -------------------------------------------------------------------------------
@@ -396,9 +396,8 @@ mkMaps dflags pkgName gre instances decls = do
                         , [(Name, Map Int (MDoc Name))]
                         , [(Name,  [LHsDecl GhcRn])]
                         )
-    mappings (ldecl, docStrs) = do
-      let L l decl = ldecl
-          declDoc :: [HsDocString] -> Map Int HsDocString
+    mappings (ldecl@(L (RealSrcSpan l _) decl), docStrs) = do
+      let declDoc :: [HsDocString] -> Map Int HsDocString
                   -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name))
           declDoc strs m = do
             doc' <- processDocStrings dflags pkgName gre strs
@@ -426,12 +425,13 @@ mkMaps dflags pkgName gre instances decls = do
         seqList subDocs `seq`
         seqList subArgs `seq`
         pure (dm, am, cm)
+    mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], [])
 
-    instanceMap :: Map SrcSpan Name
-    instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
+    instanceMap :: Map RealSrcSpan Name
+    instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]
 
-    names :: SrcSpan -> HsDecl GhcRn -> [Name]
-    names _ (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
+    names :: RealSrcSpan -> HsDecl GhcRn -> [Name]
+    names _ (InstD _ d) = maybeToList (SrcLoc.lookupSrcSpan loc instanceMap) -- See note [2].
       where loc = case d of
               -- The CoAx's loc is the whole line, but only for TFs. The
               -- workaround is to dig into the family instance declaration and
@@ -454,200 +454,13 @@ mkMaps dflags pkgName gre instances decls = do
 --------------------------------------------------------------------------------
 
 
--- | Get all subordinate declarations inside a declaration, and their docs.
--- A subordinate declaration is something like the associate type or data
--- family of a type class.
-subordinates :: InstMap
-             -> HsDecl GhcRn
-             -> [(Name, [HsDocString], Map Int HsDocString)]
-subordinates instMap decl = case decl of
-  InstD _ (ClsInstD _ d) -> do
-    DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
-      FamEqn { feqn_tycon = L l _
-             , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d
-    [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
-
-  InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
-    -> dataSubs (feqn_rhs d)
-  TyClD _ d | isClassDecl d -> classSubs d
-            | isDataDecl  d -> dataSubs (tcdDataDefn d)
-  _ -> []
-  where
-    classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd
-                   , name <- getMainDeclBinder d, not (isValD d)
-                   ]
-    dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]
-    dataSubs dd = constrs ++ fields ++ derivs
-      where
-        cons = map unLoc $ (dd_cons dd)
-        constrs = [ (unLoc cname, maybeToList $ fmap unLoc $ con_doc c, conArgDocs c)
-                  | c <- cons, cname <- getConNames c ]
-        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
-                  | RecCon flds <- map getConArgs cons
-                  , L _ (ConDeclField _ ns _ doc) <- (unLoc flds)
-                  , L _ n <- ns ]
-        derivs  = [ (instName, [unLoc doc], M.empty)
-                  | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
-                                concatMap (unLoc . deriv_clause_tys . unLoc) $
-                                unLoc $ dd_derivs dd
-                  , Just instName <- [M.lookup l instMap] ]
-
-        extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
-        extract_deriv_ty ty =
-          case dL ty of
-            -- deriving (forall a. C a {- ^ Doc comment -})
-            L l (HsForAllTy{ hst_fvf = ForallInvis
-                           , hst_body = dL->L _ (HsDocTy _ _ doc) })
-                                  -> Just (l, doc)
-            -- deriving (C a {- ^ Doc comment -})
-            L l (HsDocTy _ _ doc) -> Just (l, doc)
-            _                     -> Nothing
-
--- | Extract constructor argument docs from inside constructor decls.
-conArgDocs :: ConDecl GhcRn -> Map Int HsDocString
-conArgDocs con = case getConArgs con of
-                   PrefixCon args -> go 0 (map unLoc args ++ ret)
-                   InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
-                   RecCon _ -> go 1 ret
-  where
-    go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys
-    go n (HsBangTy _ _ (L _ (HsDocTy _ _ (L _ ds))) : tys) = M.insert n ds $ go (n+1) tys
-    go n (_ : tys) = go (n+1) tys
-    go _ [] = M.empty
-
-    ret = case con of
-            ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
-            _ -> []
-
--- | Extract function argument docs from inside top-level decls.
-declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString
-declTypeDocs (SigD  _ (TypeSig _ _ ty))          = typeDocs (unLoc (hsSigWcType ty))
-declTypeDocs (SigD  _ (ClassOpSig _ _ _ ty))     = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (SigD  _ (PatSynSig _ _ ty))        = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (ForD  _ (ForeignImport _ _ ty _))  = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)
-declTypeDocs _ = M.empty
-
--- | Extract function argument docs from inside types.
-typeDocs :: HsType GhcRn -> Map Int HsDocString
-typeDocs = go 0
-  where
-    go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
-    go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)
-    go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
-    go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)
-    go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc
-    go _ _ = M.empty
-
--- | All the sub declarations of a class (that we handle), ordered by
--- source location, with documentation attached if it exists.
-classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
-classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
-  where
-    decls = docs ++ defs ++ sigs ++ ats
-    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_
-
-
--- | The top-level declarations of a module that we care about,
--- ordered by source location, with documentation attached if it exists.
-topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
-topDecls =
-  filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
 
 -- | Extract a map of fixity declarations only
 mkFixMap :: HsGroup GhcRn -> FixMap
-mkFixMap group_ = M.fromList [ (n,f)
-                             | L _ (FixitySig _ ns f) <- hs_fixds group_,
-                               L _ n <- ns ]
-
-
--- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
-ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
-ungroup group_ =
-  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField)  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_ ++
-  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField)  group_ ++
-  mkDecls (typesigs . hs_valds)  (SigD noExtField)   group_ ++
-  mkDecls (valbinds . hs_valds)  (ValD noExtField)   group_
-  where
-    typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs
-    typesigs _ = error "expected ValBindsOut"
-
-    valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds
-    valbinds _ = error "expected ValBindsOut"
-
-
--- | Take a field of declarations from a data structure and create HsDecls
--- using the given constructor
-mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
-mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]
-
-
--- | Sort by source location
-sortByLoc :: [Located a] -> [Located a]
-sortByLoc = sortBy (comparing getLoc)
-
-
---------------------------------------------------------------------------------
--- Filtering of declarations
---
--- We filter out declarations that we don't intend to handle later.
---------------------------------------------------------------------------------
-
-
--- | Filter out declarations that we don't handle in Haddock
-filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterDecls = filter (isHandled . unLoc . fst)
-  where
-    isHandled (ForD _ (ForeignImport {})) = True
-    isHandled (TyClD {})  = True
-    isHandled (InstD {})  = True
-    isHandled (DerivD {}) = True
-    isHandled (SigD _ d)  = isUserLSig (noLoc d)
-    isHandled (ValD {})   = True
-    -- we keep doc declarations to be able to get at named docs
-    isHandled (DocD {})   = True
-    isHandled _ = False
-
--- | Go through all class declarations and filter their sub-declarations
-filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
-                      | x@(L loc d, doc) <- decls ]
-  where
-    filterClass (TyClD x c) =
-      TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
-    filterClass _ = error "expected TyClD"
-
-
---------------------------------------------------------------------------------
--- Collect docs
---
--- To be able to attach the right Haddock comment to the right declaration,
--- we sort the declarations by their SrcLoc and "collect" the docs for each
--- declaration.
---------------------------------------------------------------------------------
-
-
--- | Collect docs and attach them to the right declarations.
-collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])]
-collectDocs = go Nothing []
-  where
-    go Nothing _ [] = []
-    go (Just prev) docs [] = finished prev docs []
-    go prev docs (L _ (DocD _ (DocCommentNext str)) : ds)
-      | Nothing <- prev = go Nothing (str:docs) ds
-      | Just decl <- prev = finished decl docs (go Nothing [str] ds)
-    go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds
-    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
+mkFixMap group_ =
+  M.fromList [ (n,f)
+             | L _ (FixitySig _ ns f) <- hsGroupTopLevelFixitySigs group_,
+               L _ n <- ns ]
 
 
 -- | Build the list of items that will become the documentation, from the
@@ -874,11 +687,11 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
                     Nothing -> return ([], (noDocForDecl, availNoDocs avail))
                     -- TODO: If we try harder, we might be able to find
                     -- a Haddock!  Look in the Haddocks for each thing in
-                    -- requirementContext (pkgState)
+                    -- requirementContext (unitState)
                     Just decl -> return ([decl], (noDocForDecl, availNoDocs avail))
               | otherwise ->
                 return ([], (noDocForDecl, availNoDocs avail))
-      | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap
+      | Just iface <- M.lookup (semToIdMod (moduleUnit thisMod) m) modMap
       , Just ds <- M.lookup n (ifaceDeclMap iface) =
           return (ds, lookupDocs avail warnings
                             (ifaceDocMap iface)
@@ -924,10 +737,10 @@ availNoDocs avail =
 
 -- | Given a 'Module' from a 'Name', convert it into a 'Module' that
 -- we can actually find in the 'IfaceMap'.
-semToIdMod :: UnitId -> Module -> Module
+semToIdMod :: Unit -> Module -> Module
 semToIdMod this_uid m
     | Module.isHoleModule m = mkModule this_uid (moduleName m)
-    | otherwise      = m
+    | otherwise             = m
 
 -- | Reify a declaration from the GHC internal 'TyThing' representation.
 hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn))
@@ -1006,8 +819,7 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
                     "documentation for exported module: " ++ pretty dflags expMod]
             return []
   where
-    m = mkModule unitId expMod -- Identity module!
-    unitId = moduleUnitId thisMod
+    m = mkModule (moduleUnit thisMod) expMod -- Identity module!
 
 -- Note [1]:
 ------------
@@ -1180,9 +992,9 @@ extractPatternSyn nm t tvs cons =
   extract con =
     let args =
           case getConArgs con of
-            PrefixCon args' -> args'
+            PrefixCon args' -> (map hsScaledThing args')
             RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
-            InfixCon arg1 arg2 -> [arg1, arg2]
+            InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
         typ = longArrow args (data_ty con)
         typ' =
           case con of
@@ -1192,7 +1004,7 @@ extractPatternSyn nm t tvs cons =
     in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'')
 
   longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
-  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField x y)) output inputs
+  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
 
   data_ty con
     | ConDeclGADT{} <- con = con_res_ty con
@@ -1209,7 +1021,7 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
 extractRecSel nm t tvs (L _ con : rest) =
   case getConArgs con of
     RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
-      pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty))))))
+      pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
     _ -> extractRecSel nm t tvs rest
  where
   matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
@@ -1242,7 +1054,7 @@ mkVisibleNames (_, _, _, instMap) exports opts
       where subs    = map fst (expItemSubDocs e)
             patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
             name = case unLoc $ expItemDecl e of
-              InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap
+              InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap
               decl      -> getMainDeclBinder decl
     exportName ExportNoDecl {} = [] -- we don't count these as visible, since
                                     -- we don't want links to go to them.