aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2017-05-23 23:16:32 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2017-06-05 22:26:55 +0200
commit1e1f85d6513b84bac3ae13470900ac7c23e8640e (patch)
tree8a8de8b9a2507ce126aa8b9e4d7939e43e264bcc /haddock-api/src/Haddock/Interface
parenta1b57146c5678b32eb5ac37021e93a81a4b73007 (diff)
Match new AST as per GHC wip/new-tree-one-param
See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs7
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs67
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs86
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs54
4 files changed, 108 insertions, 106 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index d5d74819..b89a14f4 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, MagicHash #-}
+{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.AttachInstances
@@ -66,7 +67,7 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces
, ifaceOrphanInstances = orphanInstances
}
-attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name]
+attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GHCR]
attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
[ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n))
| let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]
@@ -76,8 +77,8 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap
- -> ExportItem Name
- -> Ghc (ExportItem Name)
+ -> ExportItem GHCR
+ -> Ghc (ExportItem GHCR)
attachToExportItem expInfo iface ifaceMap instIfaceMap export =
case attachFixities export of
e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index e594feae..800c58ef 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
@@ -288,7 +289,7 @@ type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap)
mkMaps :: DynFlags
-> GlobalRdrEnv
-> [Name]
- -> [(LHsDecl Name, [HsDocString])]
+ -> [(LHsDecl GHCR, [HsDocString])]
-> Maps
mkMaps dflags gre instances decls =
let (a, b, c, d) = unzip4 $ map mappings decls
@@ -300,11 +301,11 @@ mkMaps dflags gre instances decls =
f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name)
f' = M.fromListWith metaDocAppend . concat
- mappings :: (LHsDecl Name, [HsDocString])
+ mappings :: (LHsDecl GHCR, [HsDocString])
-> ( [(Name, MDoc Name)]
, [(Name, Map Int (MDoc Name))]
, [(Name, [Name])]
- , [(Name, [LHsDecl Name])]
+ , [(Name, [LHsDecl GHCR])]
)
mappings (ldecl, docStrs) =
let L l decl = ldecl
@@ -334,7 +335,7 @@ mkMaps dflags gre instances decls =
instanceMap :: Map SrcSpan Name
instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
- names :: SrcSpan -> HsDecl Name -> [Name]
+ names :: SrcSpan -> HsDecl GHCR -> [Name]
names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
where loc = case d of
TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
@@ -358,12 +359,12 @@ mkMaps dflags gre instances decls =
-- | 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 Name -> [(Name, [HsDocString], Map Int HsDocString)]
+subordinates :: InstMap -> HsDecl GHCR -> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
InstD (ClsInstD d) -> do
DataFamInstDecl { dfid_tycon = L l _
- , dfid_defn = def } <- unLoc <$> cid_datafam_insts d
- [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def
+ , dfid_defn = defn } <- unLoc <$> cid_datafam_insts d
+ [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
InstD (DataFamInstD d) -> dataSubs (dfid_defn d)
TyClD d | isClassDecl d -> classSubs d
@@ -373,7 +374,7 @@ subordinates instMap decl = case decl of
classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
, name <- getMainDeclBinder d, not (isValD d)
]
- dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)]
+ dataSubs :: HsDataDefn GHCR -> [(Name, [HsDocString], Map Int HsDocString)]
dataSubs dd = constrs ++ fields ++ derivs
where
cons = map unL $ (dd_cons dd)
@@ -390,7 +391,7 @@ subordinates instMap decl = case decl of
, Just instName <- [M.lookup l instMap] ]
-- | Extract function argument docs from inside types.
-typeDocs :: HsDecl Name -> Map Int HsDocString
+typeDocs :: HsDecl GHCR -> Map Int HsDocString
typeDocs d =
let docs = go 0 in
case d of
@@ -410,7 +411,7 @@ typeDocs d =
-- | All the sub declarations of a class (that we handle), ordered by
-- source location, with documentation attached if it exists.
-classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]
+classDecls :: TyClDecl GHCR -> [(LHsDecl GHCR, [HsDocString])]
classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
where
decls = docs ++ defs ++ sigs ++ ats
@@ -422,18 +423,18 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
-- | The top-level declarations of a module that we care about,
-- ordered by source location, with documentation attached if it exists.
-topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])]
+topDecls :: HsGroup GHCR -> [(LHsDecl GHCR, [HsDocString])]
topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
-- | Extract a map of fixity declarations only
-mkFixMap :: HsGroup Name -> FixMap
+mkFixMap :: HsGroup GHCR -> 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 Name -> [LHsDecl Name]
+ungroup :: HsGroup GHCR -> [LHsDecl GHCR]
ungroup group_ =
mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++
mkDecls hs_derivds DerivD group_ ++
@@ -533,14 +534,14 @@ mkExportItems
-> WarningMap
-> GlobalRdrEnv
-> [Name] -- exported names (orig)
- -> [LHsDecl Name] -- renamed source declarations
+ -> [LHsDecl GHCR] -- renamed source declarations
-> Maps
-> FixMap
-> [SrcSpan] -- splice locations
- -> Maybe [IE Name]
+ -> Maybe [IE GHCR]
-> InstIfaceMap
-> DynFlags
- -> ErrMsgGhc [ExportItem Name]
+ -> ErrMsgGhc [ExportItem GHCR]
mkExportItems
is_sig modMap thisMod semMod warnings gre exportedNames decls
maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
@@ -570,7 +571,7 @@ mkExportItems
Nothing -> []
Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
- declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
+ declWith :: Name -> ErrMsgGhc [ ExportItem GHCR ]
declWith t = do
r <- findDecl t
case r of
@@ -640,7 +641,7 @@ mkExportItems
_ -> return []
- mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
+ mkExportDecl :: Name -> LHsDecl GHCR -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem GHCR
mkExportDecl name decl (doc, subs) = decl'
where
decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False
@@ -652,7 +653,7 @@ mkExportItems
isExported = (`elem` exportedNames)
- findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
+ findDecl :: Name -> ErrMsgGhc ([LHsDecl GHCR], (DocForDecl Name, [(Name, DocForDecl Name)]))
findDecl n
| m == semMod =
case M.lookup n declMap of
@@ -688,7 +689,7 @@ semToIdMod this_uid m
| Module.isHoleModule m = mkModule this_uid (moduleName m)
| otherwise = m
-hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
+hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GHCR))
hiDecl dflags t = do
mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
case mayTyThing of
@@ -710,7 +711,7 @@ hiDecl dflags t = do
-- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the
-- declaration and use it instead - 'nLoc' here.
hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
- -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
+ -> Maybe Fixity -> ErrMsgGhc (ExportItem GHCR)
hiValExportItem dflags name nLoc doc splice fixity = do
mayDecl <- hiDecl dflags name
case mayDecl of
@@ -755,13 +756,13 @@ moduleExports :: Module -- ^ Module A (identity, NOT semantic)
-> WarningMap
-> GlobalRdrEnv -- ^ The renaming environment used for A
-> [Name] -- ^ All the exports of A
- -> [LHsDecl Name] -- ^ All the renamed declarations in A
+ -> [LHsDecl GHCR] -- ^ All the renamed declarations in A
-> IfaceMap -- ^ Already created interfaces
-> InstIfaceMap -- ^ Interfaces in other packages
-> Maps
-> FixMap
-> [SrcSpan] -- ^ Locations of all TH splices
- -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
+ -> ErrMsgGhc [ExportItem GHCR] -- ^ Resulting export items
moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices
| expMod == moduleName thisMod
= fullModuleContents dflags warnings gre maps fixMap splices decls
@@ -813,8 +814,8 @@ fullModuleContents :: DynFlags
-> Maps
-> FixMap
-> [SrcSpan] -- ^ Locations of all TH splices
- -> [LHsDecl Name] -- ^ All the renamed declarations
- -> ErrMsgGhc [ExportItem Name]
+ -> [LHsDecl GHCR] -- ^ All the renamed declarations
+ -> ErrMsgGhc [ExportItem GHCR]
fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
liftM catMaybes $ mapM mkExportItem (expandSig decls)
where
@@ -831,7 +832,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names
f x xs = x : xs
- mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
+ mkExportItem :: LHsDecl GHCR -> ErrMsgGhc (Maybe (ExportItem GHCR))
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
return . Just . ExportGroup lev "" $ processDocString dflags gre docStr
mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
@@ -871,7 +872,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
-- it might be an individual record selector or a class method. In these
-- cases we have to extract the required declaration (and somehow cobble
-- together a type signature for it...).
-extractDecl :: Name -> LHsDecl Name -> LHsDecl Name
+extractDecl :: Name -> LHsDecl GHCR -> LHsDecl GHCR
extractDecl name decl
| name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
@@ -912,8 +913,8 @@ extractDecl name decl
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
-extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name]
- -> LSig Name
+extractRecSel :: Name -> Name -> [LHsType GHCR] -> [LConDecl GHCR]
+ -> LSig GHCR
extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
@@ -922,7 +923,7 @@ extractRecSel nm t tvs (L _ con : rest) =
L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
_ -> extractRecSel nm t tvs rest
where
- matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
+ matching_fields :: [LConDeclField GHCR] -> [(SrcSpan, LConDeclField GHCR)]
matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
, L l n <- ns, selectorFieldOcc n == nm ]
data_ty
@@ -931,14 +932,14 @@ extractRecSel nm t tvs (L _ con : rest) =
| otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
-- | Keep export items with docs.
-pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
+pruneExportItems :: [ExportItem GHCR] -> [ExportItem GHCR]
pruneExportItems = filter hasDoc
where
hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
hasDoc _ = True
-mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name]
+mkVisibleNames :: Maps -> [ExportItem GHCR] -> [DocOption] -> [Name]
mkVisibleNames (_, _, _, _, instMap) exports opts
| OptHide `elem` opts = []
| otherwise = let ns = concatMap exportName exports
@@ -982,7 +983,7 @@ mkTokenizedSrc ms src =
rawSrc = readFile $ msHsFilePath ms
-- | Find a stand-alone documentation comment by its name.
-findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
+findNamedDoc :: String -> [HsDecl GHCR] -> ErrMsgM (Maybe HsDocString)
findNamedDoc name = search
where
search [] = do
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index b43860fb..2c51cf40 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -147,7 +147,7 @@ renameL :: Located Name -> RnM (Located DocName)
renameL = mapM rename
-renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
+renameExportItems :: [ExportItem GHCR] -> RnM [ExportItem DocNameI]
renameExportItems = mapM renameExportItem
@@ -172,22 +172,22 @@ renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
renameFnArgsDoc = mapM renameDoc
-renameLType :: LHsType Name -> RnM (LHsType DocName)
+renameLType :: LHsType GHCR -> RnM (LHsType DocNameI)
renameLType = mapM renameType
-renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName)
+renameLSigType :: LHsSigType GHCR -> RnM (LHsSigType DocNameI)
renameLSigType = renameImplicit renameLType
-renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName)
+renameLSigWcType :: LHsSigWcType GHCR -> RnM (LHsSigWcType DocNameI)
renameLSigWcType = renameWc (renameImplicit renameLType)
-renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
+renameLKind :: LHsKind GHCR -> RnM (LHsKind DocNameI)
renameLKind = renameLType
-renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
+renameMaybeLKind :: Maybe (LHsKind GHCR) -> RnM (Maybe (LHsKind DocNameI))
renameMaybeLKind = traverse renameLKind
-renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName)
+renameFamilyResultSig :: LFamilyResultSig GHCR -> RnM (LFamilyResultSig DocNameI)
renameFamilyResultSig (L loc NoSig)
= return (L loc NoSig)
renameFamilyResultSig (L loc (KindSig ki))
@@ -197,17 +197,17 @@ renameFamilyResultSig (L loc (TyVarSig bndr))
= do { bndr' <- renameLTyVarBndr bndr
; return (L loc (TyVarSig bndr')) }
-renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName)
+renameInjectivityAnn :: LInjectivityAnn GHCR -> RnM (LInjectivityAnn DocNameI)
renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))
= do { lhs' <- renameL lhs
; rhs' <- mapM renameL rhs
; return (L loc (InjectivityAnn lhs' rhs')) }
-renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name)
- -> RnM (Maybe (LInjectivityAnn DocName))
+renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GHCR)
+ -> RnM (Maybe (LInjectivityAnn DocNameI))
renameMaybeInjectivityAnn = traverse renameInjectivityAnn
-renameType :: HsType Name -> RnM (HsType DocName)
+renameType :: HsType GHCR -> RnM (HsType DocNameI)
renameType t = case t of
HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
tyvars' <- mapM renameLTyVarBndr tyvars
@@ -268,13 +268,13 @@ renameType t = case t of
HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
HsAppsTy _ -> error "renameType: HsAppsTy"
-renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
+renameLHsQTyVars :: LHsQTyVars GHCR -> RnM (LHsQTyVars DocNameI)
renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
= do { tvs' <- mapM renameLTyVarBndr tvs
; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) }
-- This is rather bogus, but I'm not sure what else to do
-renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
+renameLTyVarBndr :: LHsTyVarBndr GHCR -> RnM (LHsTyVarBndr DocNameI)
renameLTyVarBndr (L loc (UserTyVar (L l n)))
= do { n' <- rename n
; return (L loc (UserTyVar (L l n'))) }
@@ -283,15 +283,15 @@ renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind))
; kind' <- renameLKind kind
; return (L loc (KindedTyVar (L lv n') kind')) }
-renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
+renameLContext :: Located [LHsType GHCR] -> RnM (Located [LHsType DocNameI])
renameLContext (L loc context) = do
context' <- mapM renameLType context
return (L loc context')
-renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName)
+renameWildCardInfo :: HsWildCardInfo GHCR -> RnM (HsWildCardInfo DocNameI)
renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name
-renameInstHead :: InstHead Name -> RnM (InstHead DocName)
+renameInstHead :: InstHead GHCR -> RnM (InstHead DocNameI)
renameInstHead InstHead {..} = do
cname <- rename ihdClsName
kinds <- mapM renameType ihdKinds
@@ -311,11 +311,11 @@ renameInstHead InstHead {..} = do
, ihdInstType = itype
}
-renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
+renameLDecl :: LHsDecl GHCR -> RnM (LHsDecl DocNameI)
renameLDecl (L loc d) = return . L loc =<< renameDecl d
-renameDecl :: HsDecl Name -> RnM (HsDecl DocName)
+renameDecl :: HsDecl GHCR -> RnM (HsDecl DocNameI)
renameDecl decl = case decl of
TyClD d -> do
d' <- renameTyClD d
@@ -334,10 +334,10 @@ renameDecl decl = case decl of
return (DerivD d')
_ -> error "renameDecl"
-renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))
+renameLThing :: (a GHCR -> RnM (a DocNameI)) -> Located (a GHCR) -> RnM (Located (a DocNameI))
renameLThing fn (L loc x) = return . L loc =<< fn x
-renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName)
+renameTyClD :: TyClDecl GHCR -> RnM (TyClDecl DocNameI)
renameTyClD d = case d of
-- TyFamily flav lname ltyvars kind tckind -> do
FamDecl { tcdFam = decl } -> do
@@ -379,7 +379,7 @@ renameTyClD d = case d of
renameLSig (L loc sig) = return . L loc =<< renameSig sig
-renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
+renameFamilyDecl :: FamilyDecl GHCR -> RnM (FamilyDecl DocNameI)
renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
, fdTyVars = ltyvars
, fdFixity = fixity
@@ -397,8 +397,8 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
, fdInjectivityAnn = injectivity' })
-renamePseudoFamilyDecl :: PseudoFamilyDecl Name
- -> RnM (PseudoFamilyDecl DocName)
+renamePseudoFamilyDecl :: PseudoFamilyDecl GHCR
+ -> RnM (PseudoFamilyDecl DocNameI)
renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl
<$> renameFamilyInfo pfdInfo
<*> renameL pfdLName
@@ -406,14 +406,14 @@ renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl
<*> renameFamilyResultSig pfdKindSig
-renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
+renameFamilyInfo :: FamilyInfo GHCR -> RnM (FamilyInfo DocNameI)
renameFamilyInfo DataFamily = return DataFamily
renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
renameFamilyInfo (ClosedTypeFamily eqns)
= do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns
; return $ ClosedTypeFamily eqns' }
-renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)
+renameDataDefn :: HsDataDefn GHCR -> RnM (HsDataDefn DocNameI)
renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
, dd_kindSig = k, dd_cons = cons }) = do
lcontext' <- renameLContext lcontext
@@ -424,7 +424,7 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
, dd_kindSig = k', dd_cons = cons'
, dd_derivs = noLoc [] })
-renameCon :: ConDecl Name -> RnM (ConDecl DocName)
+renameCon :: ConDecl GHCR -> RnM (ConDecl DocNameI)
renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars
, con_cxt = lcontext, con_details = details
, con_doc = mbldoc }) = do
@@ -455,19 +455,19 @@ renameCon decl@(ConDeclGADT { con_names = lnames
return (decl { con_names = lnames'
, con_type = lty', con_doc = mbldoc' })
-renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)
+renameConDeclFieldField :: LConDeclField GHCR -> RnM (LConDeclField DocNameI)
renameConDeclFieldField (L l (ConDeclField names t doc)) = do
names' <- mapM renameLFieldOcc names
t' <- renameLType t
doc' <- mapM renameLDocHsSyn doc
return $ L l (ConDeclField names' t' doc')
-renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName)
+renameLFieldOcc :: LFieldOcc GHCR -> RnM (LFieldOcc DocNameI)
renameLFieldOcc (L l (FieldOcc lbl sel)) = do
sel' <- rename sel
return $ L l (FieldOcc lbl sel')
-renameSig :: Sig Name -> RnM (Sig DocName)
+renameSig :: Sig GHCR -> RnM (Sig DocNameI)
renameSig sig = case sig of
TypeSig lnames ltype -> do
lnames' <- mapM renameL lnames
@@ -491,7 +491,7 @@ renameSig sig = case sig of
_ -> error "expected TypeSig"
-renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)
+renameForD :: ForeignDecl GHCR -> RnM (ForeignDecl DocNameI)
renameForD (ForeignImport lname ltype co x) = do
lname' <- renameL lname
ltype' <- renameLSigType ltype
@@ -502,7 +502,7 @@ renameForD (ForeignExport lname ltype co x) = do
return (ForeignExport lname' ltype' co x)
-renameInstD :: InstDecl Name -> RnM (InstDecl DocName)
+renameInstD :: InstDecl GHCR -> RnM (InstDecl DocNameI)
renameInstD (ClsInstD { cid_inst = d }) = do
d' <- renameClsInstD d
return (ClsInstD { cid_inst = d' })
@@ -513,7 +513,7 @@ renameInstD (DataFamInstD { dfid_inst = d }) = do
d' <- renameDataFamInstD d
return (DataFamInstD { dfid_inst = d' })
-renameDerivD :: DerivDecl Name -> RnM (DerivDecl DocName)
+renameDerivD :: DerivDecl GHCR -> RnM (DerivDecl DocNameI)
renameDerivD (DerivDecl { deriv_type = ty
, deriv_strategy = strat
, deriv_overlap_mode = omode }) = do
@@ -522,7 +522,7 @@ renameDerivD (DerivDecl { deriv_type = ty
, deriv_strategy = strat
, deriv_overlap_mode = omode })
-renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
+renameClsInstD :: ClsInstDecl GHCR -> RnM (ClsInstDecl DocNameI)
renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
, cid_poly_ty =ltype, cid_tyfam_insts = lATs
, cid_datafam_insts = lADTs }) = do
@@ -535,13 +535,13 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
, cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })
-renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName)
+renameTyFamInstD :: TyFamInstDecl GHCR -> RnM (TyFamInstDecl DocNameI)
renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
= do { eqn' <- renameLTyFamInstEqn eqn
; return (TyFamInstDecl { tfid_eqn = eqn'
, tfid_fvs = placeHolderNames }) }
-renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)
+renameLTyFamInstEqn :: LTyFamInstEqn GHCR -> RnM (LTyFamInstEqn DocNameI)
renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity, tfe_rhs = rhs }))
= do { tc' <- renameL tc
; pats' <- renameImplicit (mapM renameLType) pats
@@ -551,7 +551,7 @@ renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixi
, tfe_fixity = fixity
, tfe_rhs = rhs' })) }
-renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)
+renameLTyFamDefltEqn :: LTyFamDefltEqn GHCR -> RnM (LTyFamDefltEqn DocNameI)
renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs }))
= do { tc' <- renameL tc
; tvs' <- renameLHsQTyVars tvs
@@ -561,7 +561,7 @@ renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixi
, tfe_fixity = fixity
, tfe_rhs = rhs' })) }
-renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
+renameDataFamInstD :: DataFamInstDecl GHCR -> RnM (DataFamInstDecl DocNameI)
renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn })
= do { tc' <- renameL tc
; pats' <- renameImplicit (mapM renameLType) pats
@@ -572,8 +572,8 @@ renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fi
, dfid_defn = defn', dfid_fvs = placeHolderNames }) }
renameImplicit :: (in_thing -> RnM out_thing)
- -> HsImplicitBndrs Name in_thing
- -> RnM (HsImplicitBndrs DocName out_thing)
+ -> HsImplicitBndrs GHCR in_thing
+ -> RnM (HsImplicitBndrs DocNameI out_thing)
renameImplicit rn_thing (HsIB { hsib_body = thing })
= do { thing' <- rn_thing thing
; return (HsIB { hsib_body = thing'
@@ -581,21 +581,21 @@ renameImplicit rn_thing (HsIB { hsib_body = thing })
, hsib_closed = PlaceHolder }) }
renameWc :: (in_thing -> RnM out_thing)
- -> HsWildCardBndrs Name in_thing
- -> RnM (HsWildCardBndrs DocName out_thing)
+ -> HsWildCardBndrs GHCR in_thing
+ -> RnM (HsWildCardBndrs DocNameI out_thing)
renameWc rn_thing (HsWC { hswc_body = thing })
= do { thing' <- rn_thing thing
; return (HsWC { hswc_body = thing'
, hswc_wcs = PlaceHolder }) }
-renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName)
+renameDocInstance :: DocInstance GHCR -> RnM (DocInstance DocNameI)
renameDocInstance (inst, idoc, L l n) = do
inst' <- renameInstHead inst
n' <- rename n
idoc' <- mapM renameDoc idoc
return (inst', idoc',L l n')
-renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
+renameExportItem :: ExportItem GHCR -> RnM (ExportItem DocNameI)
renameExportItem item = case item of
ExportModule mdl -> return (ExportModule mdl)
ExportGroup lev id_ doc -> do
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 28bbf305..d8bdecec 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -30,9 +30,9 @@ import qualified Data.Set as Set
-- | Instantiate all occurrences of given name with particular type.
-specialize :: (Eq name, Typeable name)
+specialize :: (Eq (IdP name), Typeable name)
=> Data a
- => name -> HsType name -> a -> a
+ => IdP name -> HsType name -> a -> a
specialize name details =
everywhere $ mkT step
where
@@ -44,9 +44,9 @@ specialize name details =
--
-- It is just a convenience function wrapping 'specialize' that supports more
-- that one specialization.
-specialize' :: (Eq name, Typeable name)
+specialize' :: (Eq (IdP name), Typeable name)
=> Data a
- => [(name, HsType name)] -> a -> a
+ => [(IdP name, HsType name)] -> a -> a
specialize' = flip $ foldr (uncurry specialize)
@@ -54,7 +54,7 @@ specialize' = flip $ foldr (uncurry specialize)
--
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: (Eq name, DataId name)
+specializeTyVarBndrs :: (Eq (IdP name), DataId name)
=> Data a
=> LHsQTyVars name -> [HsType name]
-> a -> a
@@ -66,7 +66,7 @@ specializeTyVarBndrs bndrs typs =
bname (KindedTyVar (L _ name) _) = name
-specializePseudoFamilyDecl :: (Eq name, DataId name)
+specializePseudoFamilyDecl :: (Eq (IdP name), DataId name)
=> LHsQTyVars name -> [HsType name]
-> PseudoFamilyDecl name
-> PseudoFamilyDecl name
@@ -76,7 +76,7 @@ specializePseudoFamilyDecl bndrs typs decl =
specializeTyVars = specializeTyVarBndrs bndrs typs
-specializeSig :: forall name . (Eq name, DataId name, SetName name)
+specializeSig :: forall name . (Eq (IdP name), DataId name, SetName (IdP name))
=> LHsQTyVars name -> [HsType name]
-> Sig name
-> Sig name
@@ -93,7 +93,7 @@ specializeSig _ _ sig = sig
-- | Make all details of instance head (signatures, associated types)
-- specialized to that particular instance type.
-specializeInstHead :: (Eq name, DataId name, SetName name)
+specializeInstHead :: (Eq (IdP name), DataId name, SetName (IdP name))
=> InstHead name -> InstHead name
specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
ihd { ihdInstType = instType' }
@@ -113,7 +113,7 @@ specializeInstHead ihd = ihd
-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
-- can be fixed using 'sugar' function, that will turn such types into @[a]@
-- and @(a, b, c)@.
-sugar :: forall name. (NamedThing name, DataId name)
+sugar :: forall name. (NamedThing (IdP name), DataId name)
=> HsType name -> HsType name
sugar =
everywhere $ mkT step
@@ -122,7 +122,7 @@ sugar =
step = sugarOperators . sugarTuples . sugarLists
-sugarLists :: NamedThing name => HsType name -> HsType name
+sugarLists :: NamedThing (IdP name) => HsType name -> HsType name
sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
| isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
where
@@ -131,7 +131,7 @@ sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
sugarLists typ = typ
-sugarTuples :: NamedThing name => HsType name -> HsType name
+sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name
sugarTuples typ =
aux [] typ
where
@@ -148,7 +148,7 @@ sugarTuples typ =
aux _ _ = typ
-sugarOperators :: NamedThing name => HsType name -> HsType name
+sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name
sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb)
| isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
| isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
@@ -216,7 +216,7 @@ setInternalOccName occ name =
-- | Compute set of free variables of given type.
-freeVariables :: forall name. (NamedThing name, DataId name)
+freeVariables :: forall name. (NamedThing (IdP name), DataId name)
=> HsType name -> Set NameRep
freeVariables =
everythingWithState Set.empty Set.union query
@@ -239,7 +239,7 @@ freeVariables =
-- different type variable than latter one. Applying 'rename' function
-- will fix that type to be visually unambiguous again (making it something
-- like @(a -> c) -> b@).
-rename :: SetName name => Set NameRep -> HsType name -> HsType name
+rename :: SetName (IdP name) => Set NameRep -> HsType name -> HsType name
rename fv typ = runReader (renameType typ) $ RenameEnv
{ rneFV = fv
, rneCtx = Map.empty
@@ -258,7 +258,7 @@ data RenameEnv name = RenameEnv
}
-renameType :: SetName name => HsType name -> Rename name (HsType name)
+renameType :: SetName (IdP name) => HsType name -> Rename (IdP name) (HsType name)
renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' ->
HsForAllTy
<$> pure bndrs'
@@ -294,19 +294,19 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"
-renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
+renameLType :: SetName (IdP name) => LHsType name -> Rename (IdP name) (LHsType name)
renameLType = located renameType
-renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name]
+renameLTypes :: SetName (IdP name) => [LHsType name] -> Rename (IdP name) [LHsType name]
renameLTypes = mapM renameLType
-renameContext :: SetName name => HsContext name -> Rename name (HsContext name)
+renameContext :: SetName (IdP name) => HsContext name -> Rename (IdP name) (HsContext name)
renameContext = renameLTypes
{-
-renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)
+renameLTyOp :: SetName (IdP name) => LHsTyOp name -> Rename name (LHsTyOp name)
renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
-}
@@ -317,21 +317,21 @@ renameName name = do
pure $ fromMaybe name (Map.lookup (getName name) ctx)
-rebind :: SetName name
- => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a)
- -> Rename name a
+rebind :: SetName (IdP name)
+ => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename (IdP name) a)
+ -> Rename (IdP name) a
rebind lbndrs action = do
(lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask
local (const env') (action lbndrs')
-rebindLTyVarBndrs :: SetName name
- => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name]
+rebindLTyVarBndrs :: SetName (IdP name)
+ => [LHsTyVarBndr name] -> Rebind (IdP name) [LHsTyVarBndr name]
rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs
-rebindTyVarBndr :: SetName name
- => HsTyVarBndr name -> Rebind name (HsTyVarBndr name)
+rebindTyVarBndr :: SetName (IdP name)
+ => HsTyVarBndr name -> Rebind (IdP name) (HsTyVarBndr name)
rebindTyVarBndr (UserTyVar (L l name)) =
UserTyVar . L l <$> rebindName name
rebindTyVarBndr (KindedTyVar name kinds) =
@@ -402,6 +402,6 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located f (L loc e) = L loc <$> f e
-tyVarName :: HsTyVarBndr name -> name
+tyVarName :: HsTyVarBndr name -> IdP name
tyVarName (UserTyVar name) = unLoc name
tyVarName (KindedTyVar (L _ name) _) = name