diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 13 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 28 |
2 files changed, 24 insertions, 17 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index da59c5fa..30b32963 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -47,6 +47,7 @@ import TcRnTypes import FastString (concatFS) import BasicTypes ( StringLiteral(..) ) import qualified Outputable as O +import HsDecls ( gadtDeclDetails,getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological @@ -334,9 +335,9 @@ subordinates instMap decl = case decl of where cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) - | c <- cons, cname <- con_names c ] + | c <- cons, cname <- getConNames c ] fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) - | RecCon flds <- map con_details cons + | RecCon flds <- map getConDetails cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ] @@ -785,7 +786,8 @@ extractDecl name mdl decl SigD <$> extractRecSel name mdl n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts - , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) + -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) + , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , selectorFieldOcc n == name @@ -800,7 +802,7 @@ extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = - case con_details con of + case getConDetails con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm mdl t tvs rest @@ -809,7 +811,8 @@ extractRecSel nm mdl t tvs (L _ con : rest) = matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds , L l n <- ns, selectorFieldOcc n == nm ] data_ty - | ResTyGADT _ ty <- con_res con = ty + -- | ResTyGADT _ ty <- con_res con = ty + | ConDeclGADT{} <- con = hsib_body $ con_type con | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs -- | Keep export items with docs. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index f2f93966..0b975687 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -393,17 +393,16 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) renameCon :: ConDecl Name -> RnM (ConDecl DocName) -renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details - , con_res = restype, con_doc = mbldoc }) = do - lnames' <- mapM renameL lnames - ltyvars' <- renameLHsQTyVars ltyvars - lcontext' <- renameLContext lcontext +renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_doc = mbldoc }) = do + lname' <- renameL lname + ltyvars' <- traverse renameLHsQTyVars ltyvars + lcontext' <- traverse renameLContext lcontext details' <- renameDetails details - restype' <- renameResType restype mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext' - , con_details = details', con_res = restype', con_doc = mbldoc' }) + return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' + , con_details = details', con_doc = mbldoc' }) where renameDetails (RecCon (L l fields)) = do @@ -415,9 +414,14 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars b' <- renameLType b return (InfixCon a' b') - renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t - +renameCon decl@(ConDeclGADT { con_names = lnames + , con_type = lty + , con_doc = mbldoc }) = do + lnames' <- mapM renameL lnames + lty' <- renameLSigType lty + mbldoc' <- mapM renameLDocHsSyn mbldoc + return (decl { con_names = lnames' + , con_type = lty', con_doc = mbldoc' }) renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) renameConDeclFieldField (L l (ConDeclField names t doc)) = do |