aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r--src/Haddock/Interface/AttachInstances.hs7
-rw-r--r--src/Haddock/Interface/Create.hs58
-rw-r--r--src/Haddock/Interface/LexParseRn.hs26
-rw-r--r--src/Haddock/Interface/Rename.hs130
4 files changed, 127 insertions, 94 deletions
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index c012f2e0..a4d4764e 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -91,7 +91,7 @@ lookupInstDoc name iface ifaceMap instIfaceMap =
-- | Like GHC's getInfo but doesn't cut things out depending on the
-- interative context, which we don't set sufficiently anyway.
-getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
+getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst]))
getAllInfo name = withSession $ \hsc_env -> do
(_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name
return r
@@ -106,7 +106,9 @@ getAllInfo name = withSession $ \hsc_env -> do
-- in Haddock output) and unifying special tycons with normal ones.
-- For the benefit of the user (looks nice and predictable) and the
-- tests (which prefer output to be deterministic).
-data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
+data SimpleType = SimpleType Name [SimpleType]
+ | SimpleTyLit TyLit
+ deriving (Eq,Ord)
instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
@@ -126,6 +128,7 @@ instHead (_, _, cls, args)
where (SimpleType s ts) = simplify t1
simplify (TyVarTy v) = SimpleType (tyVarName v) []
simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
+ simplify (LitTy l) = SimpleTyLit l
-- sortImage f = sortBy (\x y -> compare (f x) (f y))
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 50f468db..4bb46cba 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -86,7 +86,7 @@ createInterface tm flags modMap instIfaceMap = do
| OptIgnoreExports `elem` opts = Nothing
| otherwise = exports0
- liftErrMsg $ warnAboutFilteredDecls mdl decls
+ liftErrMsg $ warnAboutFilteredDecls dflags mdl decls
let warningMap = mkWarningMap warnings gre exportedNames
exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports
@@ -224,13 +224,12 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap)
-
-- | Create 'Maps' by looping through the declarations. For each declaration,
-- find its names, its subordinates, and its doc strings. Process doc strings
-- into 'Doc's.
mkMaps :: DynFlags
-> GlobalRdrEnv
- -> [Instance]
+ -> [ClsInst]
-> [(LHsDecl Name, [HsDocString])]
-> ErrMsgM Maps
mkMaps dflags gre instances decls = do
@@ -261,16 +260,15 @@ mkMaps dflags gre instances decls = do
instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
names :: HsDecl Name -> [Name]
- names (InstD (InstDecl (L l _) _ _ _)) = maybeToList (M.lookup l instanceMap) -- See note [2].
+ names (InstD (ClsInstD { cid_poly_ty = L l _ })) = maybeToList (M.lookup l instanceMap) -- See note [2].
names decl = getMainDeclBinder decl
-
-- Note [2]:
------------
--- We relate Instances to InstDecls using the SrcSpans buried inside them.
+-- We relate ClsInsts to InstDecls using the SrcSpans buried inside them.
-- That should work for normal user-written instances (from looking at GHC
-- sources). We can assume that commented instances are user-written.
--- This lets us relate Names (from Instances) to comments (associated
+-- This lets us relate Names (from ClsInsts) to comments (associated
-- with InstDecls).
@@ -290,7 +288,7 @@ subordinates (TyClD decl)
]
dataSubs = constrs ++ fields
where
- cons = map unL $ tcdCons decl
+ cons = map unL $ (td_cons (tcdTyDefn decl))
constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)
| c <- cons ]
fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)
@@ -306,7 +304,7 @@ typeDocs d =
case d of
SigD (TypeSig _ ty) -> docs (unLoc ty)
ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
- TyClD (TySynonym {tcdSynRhs = ty}) -> docs (unLoc ty)
+ TyClD (TyDecl { tcdTyDefn = TySynonym {td_synRhs = ty}}) -> docs (unLoc ty)
_ -> M.empty
where
go n (HsForAllTy _ _ _ ty) = go n (unLoc ty)
@@ -364,11 +362,11 @@ sortByLoc :: [Located a] -> [Located a]
sortByLoc = sortBy (comparing getLoc)
-warnAboutFilteredDecls :: Module -> [LHsDecl Name] -> ErrMsgM ()
-warnAboutFilteredDecls mdl decls = do
+warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM ()
+warnAboutFilteredDecls dflags mdl decls = do
let modStr = moduleString mdl
let typeInstances =
- nub [ tcdName d | L _ (TyClD d) <- decls, isFamInstDecl d ]
+ nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD { lid_inst = d })) <- decls ]
unless (null typeInstances) $
tell [
@@ -377,7 +375,7 @@ warnAboutFilteredDecls mdl decls = do
++ "will be filtered out:\n " ++ (intercalate ", "
$ map (occNameString . nameOccName) typeInstances) ]
- let instances = nub [ pretty i | L _ (InstD (InstDecl i _ _ ats)) <- decls
+ let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD { cid_poly_ty = i, cid_fam_insts = ats })) <- decls
, not (null ats) ]
unless (null instances) $
@@ -457,7 +455,7 @@ mkExportItems
-> [LHsDecl Name]
-> Maps
-> Maybe [IE Name]
- -> [Instance]
+ -> [ClsInst]
-> InstIfaceMap
-> DynFlags
-> ErrMsgGhc [ExportItem Name]
@@ -501,7 +499,7 @@ mkExportItems
case findDecl t of
([L _ (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
- export <- hiValExportItem t doc
+ export <- hiValExportItem dflags t doc
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
let declNames = getMainDeclBinder (unL decl)
@@ -518,8 +516,8 @@ mkExportItems
Just p <- find isExported (parents t $ unL decl) ->
do liftErrMsg $ tell [
"Warning: " ++ moduleString thisMod ++ ": " ++
- pretty (nameOccName t) ++ " is exported separately but " ++
- "will be documented under " ++ pretty (nameOccName p) ++
+ pretty dflags (nameOccName t) ++ " is exported separately but " ++
+ "will be documented under " ++ pretty dflags (nameOccName p) ++
". Consider exporting it together with its parent(s)" ++
" for code clarity." ]
return []
@@ -539,7 +537,7 @@ mkExportItems
-- Declaration from another package
([], _) -> do
- mayDecl <- hiDecl t
+ mayDecl <- hiDecl dflags t
case mayDecl of
Nothing -> return [ ExportNoDecl t [] ]
Just decl ->
@@ -548,7 +546,7 @@ mkExportItems
case M.lookup (nameModule t) instIfaceMap of
Nothing -> do
liftErrMsg $ tell
- ["Warning: Couldn't find .haddock for export " ++ pretty t]
+ ["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
return [ mkExportDecl t decl (noDocForDecl, subs_) ]
Just iface ->
@@ -580,19 +578,19 @@ mkExportItems
m = nameModule n
-hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name))
-hiDecl t = do
+hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
+hiDecl dflags t = do
mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
case mayTyThing of
Nothing -> do
- liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty t]
+ liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
return Nothing
Just x -> return (Just (tyThingToLHsDecl x))
-hiValExportItem :: Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name)
-hiValExportItem name doc = do
- mayDecl <- hiDecl name
+hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name)
+hiValExportItem dflags name doc = do
+ mayDecl <- hiDecl dflags name
case mayDecl of
Nothing -> return (ExportNoDecl name [])
Just decl -> return (ExportDecl decl doc [] [])
@@ -648,8 +646,8 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
Just iface -> return [ ExportModule (instMod iface) ]
Nothing -> do
liftErrMsg $
- tell ["Warning: " ++ pretty thisMod ++ ": Could not find " ++
- "documentation for exported module: " ++ pretty expMod]
+ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
+ "documentation for exported module: " ++ pretty dflags expMod]
return []
where
m = mkModule packageId expMod
@@ -700,7 +698,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
| name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
-- Top-level binding without type signature.
let (doc, _) = lookupDocs name warnings docMap argMap subMap in
- fmap Just (hiValExportItem name doc)
+ fmap Just (hiValExportItem dflags name doc)
| otherwise = return Nothing
mkExportItem decl
| name:_ <- getMainDeclBinder (unLoc decl) =
@@ -728,7 +726,7 @@ extractDecl name mdl decl
_ -> error "internal: extractDecl"
TyClD d | isDataDecl d ->
let (n, tyvar_names) = name_and_tyvars d
- L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d)
+ L pos sig = extractRecSel name mdl n tyvar_names (td_cons (tcdTyDefn d))
in L pos (SigD sig)
_ -> error "internal: extractDecl"
where
@@ -743,7 +741,7 @@ extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name
extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of
L _ (HsForAllTy expl tvs (L _ preds) ty) ->
L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty)))
- _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype)))
+ _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype)))
where
lctxt = noLoc . ctxt
ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index 56ed1b42..d68f78f8 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -61,7 +61,7 @@ process parse dflags gre (HsDocString fs) = do
Nothing -> do
tell [ "doc comment parse failed: " ++ str ]
return Nothing
- Just doc -> return (Just (rename gre doc))
+ Just doc -> return (Just (rename dflags gre doc))
processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
@@ -69,6 +69,7 @@ processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsD
processModuleHeader dflags gre safety mayStr = do
(hmi, doc) <-
case mayStr of
+
Nothing -> return failure
Just (L _ (HsDocString fs)) -> do
let str = unpackFS fs
@@ -77,16 +78,16 @@ processModuleHeader dflags gre safety mayStr = do
tell ["haddock module header parse failed: " ++ msg]
return failure
Right (hmi, doc) -> do
- let hmi' = hmi { hmi_description = rename gre <$> hmi_description hmi }
- doc' = rename gre doc
+ let hmi' = hmi { hmi_description = rename dflags gre <$> hmi_description hmi }
+ doc' = rename dflags gre doc
return (hmi', Just doc')
- return (hmi { hmi_safety = Just $ showPpr safety }, doc)
+ return (hmi { hmi_safety = Just $ showPpr dflags safety }, doc)
where
failure = (emptyHaddockModInfo, Nothing)
-rename :: GlobalRdrEnv -> Doc RdrName -> Doc Name
-rename gre = rn
+rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
+rename dflags gre = rn
where
rn d = case d of
DocAppend a b -> DocAppend (rn a) (rn b)
@@ -97,9 +98,10 @@ rename gre = rn
case names of
[] ->
case choices of
- [] -> DocMonospaced (DocString (showSDoc $ ppr x))
- [a] -> outOfScope a
- a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope b
+ [] -> DocMonospaced (DocString (showPpr dflags x))
+ [a] -> outOfScope dflags a
+ a:b:_ | isRdrTc a -> outOfScope dflags a
+ | otherwise -> outOfScope dflags b
[a] -> DocIdentifier a
a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
-- If an id can refer to multiple things, we give precedence to type
@@ -121,12 +123,12 @@ rename gre = rn
DocString str -> DocString str
-outOfScope :: RdrName -> Doc a
-outOfScope x =
+outOfScope :: DynFlags -> RdrName -> Doc a
+outOfScope dflags x =
case x of
Unqual occ -> monospaced occ
Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)
Orig _ occ -> monospaced occ
Exact name -> monospaced name -- Shouldn't happen since x is out of scope
where
- monospaced a = DocMonospaced (DocString (showSDoc $ ppr a))
+ monospaced a = DocMonospaced (DocString (showPpr dflags a))
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index b703da0f..6109c341 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -16,7 +16,6 @@ import Haddock.GhcUtils
import Haddock.Types
import Bag (emptyBag)
-import BasicTypes ( IPName(..), ipNameName )
import GHC hiding (NoLink)
import Name
@@ -28,8 +27,8 @@ import Data.Traversable (mapM)
import Prelude hiding (mapM)
-renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface
-renameInterface renamingEnv warnings iface =
+renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
+renameInterface dflags renamingEnv warnings iface =
-- first create the local env, where every name exported by this module
-- is mapped to itself, and everything else comes from the global renaming
@@ -58,7 +57,7 @@ renameInterface renamingEnv warnings iface =
-- representation. TODO: use the Name constants from the GHC API.
-- strings = filter (`notElem` ["()", "[]", "(->)"])
-- (map pretty missingNames)
- strings = map pretty . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames
+ strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames
in do
-- report things that we couldn't link to. Only do this for non-hidden
@@ -216,14 +215,17 @@ renameLType = mapM renameType
renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
renameLKind = renameLType
-renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
+renameMaybeLKind :: Maybe (LHsKind Name)
+ -> RnM (Maybe (LHsKind DocName))
renameMaybeLKind Nothing = return Nothing
-renameMaybeLKind (Just ki) = Just <$> renameLKind ki
+renameMaybeLKind (Just ki)
+ = do { ki' <- renameLKind ki
+ ; return (Just ki') }
renameType :: HsType Name -> RnM (HsType DocName)
renameType t = case t of
HsForAllTy expl tyvars lcontext ltype -> do
- tyvars' <- mapM renameLTyVarBndr tyvars
+ tyvars' <- renameLTyVarBndrs tyvars
lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
return (HsForAllTy expl tyvars' lcontext' ltype')
@@ -243,7 +245,7 @@ renameType t = case t of
HsListTy ty -> return . HsListTy =<< renameLType ty
HsPArrTy ty -> return . HsPArrTy =<< renameLType ty
- HsIParamTy n ty -> liftM2 HsIParamTy (liftM IPName (rename (ipNameName n))) (renameLType ty)
+ HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty)
HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
@@ -266,15 +268,25 @@ renameType t = case t of
doc' <- renameLDocHsSyn doc
return (HsDocTy ty' doc')
+ HsTyLit x -> return (HsTyLit x)
+
_ -> error "renameType"
-renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
-renameLTyVarBndr (L loc tv) = do
- name' <- rename (hsTyVarName tv)
- tyvar' <- replaceTyVarName tv name' renameLKind
- return $ L loc tyvar'
+renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
+renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
+ = do { tvs' <- mapM renameLTyVarBndr tvs
+ ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }
+ -- This is rather bogus, but I'm not sure what else to do
+renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
+renameLTyVarBndr (L loc (UserTyVar n))
+ = do { n' <- rename n
+ ; return (L loc (UserTyVar n')) }
+renameLTyVarBndr (L loc (KindedTyVar n k))
+ = do { n' <- rename n
+ ; k' <- renameLKind k
+ ; return (L loc (KindedTyVar n' k')) }
renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
renameLContext (L loc context) = do
@@ -324,54 +336,67 @@ renameTyClD d = case d of
-- TyFamily flav lname ltyvars kind tckind -> do
TyFamily flav lname ltyvars tckind -> do
lname' <- renameL lname
- ltyvars' <- mapM renameLTyVarBndr ltyvars
+ ltyvars' <- renameLTyVarBndrs ltyvars
-- kind' <- renameMaybeLKind kind
tckind' <- renameMaybeLKind tckind
-- return (TyFamily flav lname' ltyvars' kind' tckind)
return (TyFamily flav lname' ltyvars' tckind')
- TyData x lcontext lname ltyvars typats k cons _ -> do
- lcontext' <- renameLContext lcontext
+ TyDecl { tcdLName = lname, tcdTyVars = tyvars, tcdTyDefn = defn, tcdFVs = fvs } -> do
lname' <- renameL lname
- ltyvars' <- mapM renameLTyVarBndr ltyvars
- typats' <- mapM (mapM renameLType) typats
- k' <- renameMaybeLKind k
- cons' <- mapM renameLCon cons
- -- I don't think we need the derivings, so we return Nothing
- return (TyData x lcontext' lname' ltyvars' typats' k' cons' Nothing)
-
- TySynonym lname ltyvars typats ltype -> do
- lname' <- renameL lname
- ltyvars' <- mapM renameLTyVarBndr ltyvars
- ltype' <- renameLType ltype
- typats' <- mapM (mapM renameLType) typats
- return (TySynonym lname' ltyvars' typats' ltype')
+ tyvars' <- renameLTyVarBndrs tyvars
+ defn' <- renameTyDefn defn
+ return (TyDecl { tcdLName = lname', tcdTyVars = tyvars', tcdTyDefn = defn', tcdFVs = fvs })
- ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats at_defs _ -> do
+ ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars
+ , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
lcontext' <- renameLContext lcontext
lname' <- renameL lname
- ltyvars' <- mapM renameLTyVarBndr ltyvars
+ ltyvars' <- renameLTyVarBndrs ltyvars
lfundeps' <- mapM renameLFunDep lfundeps
lsigs' <- mapM renameLSig lsigs
ats' <- mapM renameLTyClD ats
- at_defs' <- mapM renameLTyClD at_defs
+ at_defs' <- mapM (mapM renameFamInstD) at_defs
-- we don't need the default methods or the already collected doc entities
- return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' at_defs' [])
+ return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
+ , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
+ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })
where
- renameLCon (L loc con) = return . L loc =<< renameCon con
- renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
- , con_cxt = lcontext, con_details = details
- , con_res = restype, con_doc = mbldoc }) = do
+ renameLFunDep (L loc (xs, ys)) = do
+ xs' <- mapM rename xs
+ ys' <- mapM rename ys
+ return (L loc (xs', ys'))
+
+ renameLSig (L loc sig) = return . L loc =<< renameSig sig
+
+renameTyDefn :: HsTyDefn Name -> RnM (HsTyDefn DocName)
+renameTyDefn (TyData { td_ND = nd, td_ctxt = lcontext, td_cType = cType
+ , td_kindSig = k, td_cons = cons }) = do
+ lcontext' <- renameLContext lcontext
+ k' <- renameMaybeLKind k
+ cons' <- mapM (mapM renameCon) cons
+ -- I don't think we need the derivings, so we return Nothing
+ return (TyData { td_ND = nd, td_ctxt = lcontext', td_cType = cType
+ , td_kindSig = k', td_cons = cons', td_derivs = Nothing })
+
+renameTyDefn (TySynonym { td_synRhs = ltype }) = do
+ ltype' <- renameLType ltype
+ return (TySynonym { td_synRhs = ltype' })
+
+renameCon :: ConDecl Name -> RnM (ConDecl DocName)
+renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
+ , con_cxt = lcontext, con_details = details
+ , con_res = restype, con_doc = mbldoc }) = do
lname' <- renameL lname
- ltyvars' <- mapM renameLTyVarBndr ltyvars
+ ltyvars' <- renameLTyVarBndrs ltyvars
lcontext' <- renameLContext lcontext
details' <- renameDetails details
restype' <- renameResType restype
mbldoc' <- mapM renameLDocHsSyn mbldoc
return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
, con_details = details', con_res = restype', con_doc = mbldoc' })
-
+ where
renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields
renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
renameDetails (InfixCon a b) = do
@@ -388,14 +413,6 @@ renameTyClD d = case d of
renameResType (ResTyH98) = return ResTyH98
renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
- renameLFunDep (L loc (xs, ys)) = do
- xs' <- mapM rename xs
- ys' <- mapM rename ys
- return (L loc (xs', ys'))
-
- renameLSig (L loc sig) = return . L loc =<< renameSig sig
-
-
renameSig :: Sig Name -> RnM (Sig DocName)
renameSig sig = case sig of
TypeSig lnames ltype -> do
@@ -418,10 +435,23 @@ renameForD (ForeignExport lname ltype co x) = do
renameInstD :: InstDecl Name -> RnM (InstDecl DocName)
-renameInstD (InstDecl ltype _ _ lATs) = do
+renameInstD (ClsInstD { cid_poly_ty =ltype, cid_fam_insts = lATs }) = do
ltype' <- renameLType ltype
- lATs' <- mapM renameLTyClD lATs
- return (InstDecl ltype' emptyBag [] lATs')
+ lATs' <- mapM (mapM renameFamInstD) lATs
+ return (ClsInstD { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []
+ , cid_fam_insts = lATs' })
+
+renameInstD (FamInstD { lid_inst = d }) = do
+ d' <- renameFamInstD d
+ return (FamInstD { lid_inst = d' })
+
+renameFamInstD :: FamInstDecl Name -> RnM (FamInstDecl DocName)
+renameFamInstD (FamInstDecl { fid_tycon = tc, fid_pats = pats_w_bndrs, fid_defn = defn })
+ = do { tc' <- renameL tc
+ ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+ ; defn' <- renameTyDefn defn
+ ; return (FamInstDecl { fid_tycon = tc', fid_pats = pats_w_bndrs { hswb_cts = pats' }
+ , fid_defn = defn', fid_fvs = placeHolderNames }) }
renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)