diff options
Diffstat (limited to 'haddock-api/src/Haddock')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 4 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 30 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 30 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 64 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 17 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 18 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 26 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Utils.hs | 28 |
8 files changed, 124 insertions, 93 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index c9aad6ed..8939664d 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -236,9 +236,9 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of _ -> [] ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] -ppCtor dflags dat subdocs con@ConDeclH98 {} +ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } -- AZ:TODO get rid of the concatMap - = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con) + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args' where f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index a90d9a6e..d0528322 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -796,20 +796,22 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = , ppLType unicode (getGADTConType con) ] - fieldPart = case (con, getConArgsI con) of - -- Record style GADTs - (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs [] - - -- Regular record declarations - (_, RecCon (L _ fields)) -> doRecordFields fields - - -- Any GADT or a regular H98 prefix data constructor - (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) - - -- An infix H98 data constructor - (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) - - _ -> empty + fieldPart = case con of + ConDeclGADT{con_g_args = con_args'} -> case con_args' of + -- GADT record declarations + RecConGADT _ -> doConstrArgsWithDocs [] + -- GADT prefix data constructors + PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) + _ -> empty + + ConDeclH98{con_args = con_args'} -> case con_args' of + -- H98 record declarations + RecCon (L _ fields) -> doRecordFields fields + -- H98 prefix data constructors + PrefixCon args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) + -- H98 infix data constructor + InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) + _ -> empty doRecordFields fields = vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 20e099ee..d80f8e95 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -937,20 +937,22 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) , fixity ] - fieldPart = case (con, getConArgsI con) of - -- Record style GADTs - (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ] - - -- Regular record declarations - (_, RecCon (L _ fields)) -> [ doRecordFields fields ] - - -- Any GADT or a regular H98 prefix data constructor - (_, PrefixCon args) | hasArgDocs -> [ doConstrArgsWithDocs args ] - - -- An infix H98 data constructor - (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] - - _ -> [] + fieldPart = case con of + ConDeclGADT{con_g_args = con_args'} -> case con_args' of + -- GADT record declarations + RecConGADT _ -> [ doConstrArgsWithDocs [] ] + -- GADT prefix data constructors + PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ] + _ -> [] + + ConDeclH98{con_args = con_args'} -> case con_args' of + -- H98 record declarations + RecCon (L _ fields) -> [ doRecordFields fields ] + -- H98 prefix data constructors + PrefixCon args | hasArgDocs -> [ doConstrArgsWithDocs args ] + -- H98 infix data constructor + InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] + _ -> [] doRecordFields fields = subFields pkg qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index b7faf6cd..c0347e56 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -387,34 +387,44 @@ synifyDataCon use_gadt_syntax dc = con_decl_field fl synTy = noLoc $ ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy Nothing - hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of - (True,True) -> Left "synifyDataCon: contradiction!" - (True,False) -> return $ RecCon (noLoc field_tys) - (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys) - (False,True) -> case linear_tys of - [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) - _ -> Left "synifyDataCon: infix with non-2 args?" + + mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn) + mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of + (True,True) -> Left "synifyDataCon: contradiction!" + (True,False) -> return $ RecCon (noLoc field_tys) + (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys) + (False,True) -> case linear_tys of + [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) + _ -> Left "synifyDataCon: infix with non-2 args?" + + mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn + mk_gadt_arg_tys + | use_named_field_syntax = RecConGADT (noLoc field_tys) + | otherwise = PrefixConGADT (map hsUnrestricted linear_tys) + -- finally we get synifyDataCon's result! - in hs_arg_tys >>= - \hat -> - if use_gadt_syntax - then return $ noLoc $ - ConDeclGADT { con_g_ext = [] - , con_names = [name] - , con_forall = noLoc $ not $ null user_tvbndrs - , con_qvars = map synifyTyVarBndr user_tvbndrs - , con_mb_cxt = ctx - , con_args = hat - , con_res_ty = synifyType WithinType [] res_ty - , con_doc = Nothing } - else return $ noLoc $ - ConDeclH98 { con_ext = noExtField - , con_name = name - , con_forall = noLoc False - , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs - , con_mb_cxt = ctx - , con_args = hat - , con_doc = Nothing } + in if use_gadt_syntax + then do + let hat = mk_gadt_arg_tys + return $ noLoc $ ConDeclGADT + { con_g_ext = [] + , con_names = [name] + , con_forall = noLoc $ not $ null user_tvbndrs + , con_qvars = map synifyTyVarBndr user_tvbndrs + , con_mb_cxt = ctx + , con_g_args = hat + , con_res_ty = synifyType WithinType [] res_ty + , con_doc = Nothing } + else do + hat <- mk_h98_arg_tys + return $ noLoc $ ConDeclH98 + { con_ext = noExtField + , con_name = name + , con_forall = noLoc False + , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs + , con_mb_cxt = ctx + , con_args = hat + , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 8d0b382b..d6d12e4e 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -134,9 +134,6 @@ mkHsForAllInvisTeleI :: mkHsForAllInvisTeleI invis_bndrs = HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs } -getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI -getConArgsI d = con_args d - getGADTConType :: ConDecl DocNameI -> LHsType DocNameI -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So @@ -144,7 +141,7 @@ getGADTConType :: ConDecl DocNameI -> LHsType DocNameI -- 'undefined's getGADTConType (ConDeclGADT { con_forall = L _ has_forall , con_qvars = qtvs - , con_mb_cxt = mcxt, con_args = args + , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty }) | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField , hst_tele = mkHsForAllInvisTeleI qtvs @@ -158,9 +155,8 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall -- tau_ty :: LHsType DocNameI tau_ty = case args of - RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty - PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) - InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) + RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty + PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) @@ -199,7 +195,7 @@ getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn -- 'undefined's getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall , con_qvars = qtvs - , con_mb_cxt = mcxt, con_args = args + , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty }) | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField , hst_tele = mkHsForAllInvisTele qtvs @@ -213,9 +209,8 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall -- tau_ty :: LHsType DocNameI tau_ty = case args of - RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty - PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) - InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) + RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty + PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 59809e89..ecaf1a5d 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -926,7 +926,7 @@ extractDecl declMap name decl let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) - , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d)) + , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , extFieldOcc n == name @@ -949,10 +949,14 @@ extractPatternSyn nm t tvs cons = extract :: ConDecl GhcRn -> Sig GhcRn extract con = let args = - case getConArgs con of - PrefixCon args' -> (map hsScaledThing args') - RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields - InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] + case con of + ConDeclH98 { con_args = con_args' } -> case con_args' of + PrefixCon args' -> map hsScaledThing args' + RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields + InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] + ConDeclGADT { con_g_args = con_args' } -> case con_args' of + PrefixConGADT args' -> map hsScaledThing args' + RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields typ = longArrow args (data_ty con) typ' = case con of @@ -977,8 +981,8 @@ extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] extractRecSel _ _ _ [] = error "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 -> + case getRecConArgs_maybe con of + Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 67439383..e7d19dfe 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -479,7 +479,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext - details' <- renameDetails details + details' <- renameH98Details details mbldoc' <- mapM renameLDocHsSyn mbldoc return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' @@ -487,18 +487,18 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars , con_args = details', con_doc = mbldoc' }) renameCon ConDeclGADT { con_names = lnames, con_qvars = ltyvars - , con_mb_cxt = lcontext, con_args = details + , con_mb_cxt = lcontext, con_g_args = details , con_res_ty = res_ty, con_forall = forall , con_doc = mbldoc } = do lnames' <- mapM renameL lnames ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext - details' <- renameDetails details + details' <- renameGADTDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc return (ConDeclGADT { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' - , con_mb_cxt = lcontext', con_args = details' + , con_mb_cxt = lcontext', con_g_args = details' , con_res_ty = res_ty', con_doc = mbldoc' , con_forall = forall}) -- Remove when #18311 is fixed @@ -506,18 +506,24 @@ renameHsScaled :: HsScaled GhcRn (LHsType GhcRn) -> RnM (HsScaled DocNameI (LHsType DocNameI)) renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty -renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) -renameDetails (RecCon (L l fields)) = do +renameH98Details :: HsConDeclH98Details GhcRn + -> RnM (HsConDeclH98Details DocNameI) +renameH98Details (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields return (RecCon (L l fields')) - -- This causes an assertion failure ---renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps -renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps -renameDetails (InfixCon a b) = do +renameH98Details (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps +renameH98Details (InfixCon a b) = do a' <- renameHsScaled a b' <- renameHsScaled b return (InfixCon a' b') +renameGADTDetails :: HsConDeclGADTDetails GhcRn + -> RnM (HsConDeclGADTDetails DocNameI) +renameGADTDetails (RecConGADT (L l fields)) = do + fields' <- mapM renameConDeclFieldField fields + return (RecConGADT (L l fields')) +renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps + renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 33fbd000..1177fb18 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -187,21 +187,33 @@ restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = - case con_args d of - PrefixCon _ -> Just d - RecCon fields - | all field_avail (unL fields) -> Just d - | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) + case d of + ConDeclH98 { con_args = args } -> restrict_h98_args args + ConDeclGADT { con_g_args = args } -> restrict_gadt_args args + where + restrict_h98_args :: HsConDeclH98Details GhcRn -> Maybe (ConDecl GhcRn) + restrict_h98_args (PrefixCon _) = Just d + restrict_h98_args (RecCon (L _ fields)) + | all field_avail fields = Just d + | otherwise = Just (d { con_args = PrefixCon (field_types fields) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but -- it's the best we can do. - InfixCon _ _ -> Just d - where + + restrict_h98_args (InfixCon _ _) = Just d + + restrict_gadt_args :: HsConDeclGADTDetails GhcRn -> Maybe (ConDecl GhcRn) + restrict_gadt_args (PrefixConGADT _) = Just d + restrict_gadt_args (RecConGADT (L _ fields)) + | all field_avail fields = Just d + | otherwise = Just (d { con_g_args = PrefixConGADT (field_types fields) }) + -- see the comments for the RecCon case of `restrict_h98_args` above + field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _)) = all (\f -> extFieldOcc (unLoc f) `elem` names) fs - field_types flds = [ hsUnrestricted t | ConDeclField _ _ t _ <- flds ] + field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ] keep _ = Nothing |