aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock')
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs20
-rw-r--r--src/Haddock/Convert.hs43
-rw-r--r--src/Haddock/Interface/AttachInstances.hs2
-rw-r--r--src/Haddock/Interface/Create.hs13
-rw-r--r--src/Haddock/Interface/Rename.hs19
5 files changed, 64 insertions, 33 deletions
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index db39ccca..2ecc6464 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -145,23 +145,25 @@ ppTyName name
ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Bool -> Qualification -> Html
-ppTyFamHeader summary associated d@(FamilyDecl { fdFlavour = flav
+ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
, fdKindSig = mkind }) unicode qual =
- (case flav of
- TypeFamily
+ (case info of
+ OpenTypeFamily
| associated -> keyword "type"
| otherwise -> keyword "type family"
DataFamily
| associated -> keyword "data"
| otherwise -> keyword "data family"
+ ClosedTypeFamily _
+ -> keyword "type family"
) <+>
ppFamDeclBinderWithVars summary d <+>
- case mkind of
+ (case mkind of
Just kind -> dcolon unicode <+> ppLKind unicode qual kind
Nothing -> noHtml
-
+ )
ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
FamilyDecl DocName -> Bool -> Qualification -> Html
@@ -175,7 +177,13 @@ ppTyFam summary associated links loc doc decl unicode qual
header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual)
- instancesBit = ppInstances instances docname unicode qual
+ instancesBit
+ | FamilyDecl { fdInfo = ClosedTypeFamily _eqns } <- decl
+ , not summary
+ = noHtml -- TODO: print eqns
+
+ | otherwise
+ = ppInstances instances docname unicode qual
-- TODO: get the instances
instances = []
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 56a5c772..d3bda268 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -33,6 +33,7 @@ import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName, eqTyCon )
import PrelNames (ipClassName)
import Bag ( emptyBag )
+import Unique ( getUnique )
import SrcLoc ( Located, noLoc, unLoc )
import Data.List( partition )
@@ -81,16 +82,12 @@ tyThingToLHsDecl t = noLoc $ case t of
-- type-constructors (e.g. Maybe) are complicated, put the definition
-- later in the file (also it's used for class associated-types too.)
- ACoAxiom ax -> InstD (TyFamInstD { tfid_inst = synifyAxiom ax })
+ ACoAxiom ax -> synifyAxiom ax
-- a data-constructor alone just gets rendered as a function:
ADataCon dc -> SigD (TypeSig [synifyName dc]
(synifyType ImplicitizeForAll (dataConUserType dc)))
-synifyATDefault :: TyCon -> LTyFamInstDecl Name
-synifyATDefault tc = noLoc (synifyAxiom ax)
- where Just ax = tyConFamilyCoercion_maybe tc
-
synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name
synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
= let name = synifyName tc
@@ -103,12 +100,19 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
, hswb_tvs = map tyVarName tvs }
, tfie_rhs = hs_rhs }
-synifyAxiom :: CoAxiom br -> TyFamInstDecl Name
-synifyAxiom (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
- = let eqns = brListMap (noLoc . synifyAxBranch tc) branches
- in TyFamInstDecl { tfid_eqns = eqns
- , tfid_group = (brListLength branches /= 1)
- , tfid_fvs = placeHolderNames }
+synifyAxiom :: CoAxiom br -> HsDecl Name
+synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
+ | isOpenSynFamilyTyCon tc
+ , Just branch <- coAxiomSingleBranch_maybe ax
+ = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch
+ , tfid_fvs = placeHolderNames }))
+
+ | Just ax' <- isClosedSynFamilyTyCon_maybe tc
+ , getUnique ax' == getUnique ax -- without the getUniques, type error
+ = TyClD (synifyTyCon tc)
+
+ | otherwise
+ = error "synifyAxiom: closed/open family confusion"
synifyTyCon :: TyCon -> TyClDecl Name
synifyTyCon tc
@@ -132,12 +136,21 @@ synifyTyCon tc
, dd_cons = [] -- No constructors
, dd_derivs = Nothing }
, tcdFVs = placeHolderNames }
+
| isSynFamilyTyCon tc
= case synTyConRhs_maybe tc of
- Just (SynFamilyTyCon {}) ->
- FamDecl (FamilyDecl TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
- (Just (synifyKindSig (synTyConResKind tc))))
- _ -> error "synifyTyCon: impossible open type synonym?"
+ Just rhs ->
+ let info = case rhs of
+ OpenSynFamilyTyCon -> OpenTypeFamily
+ ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->
+ ClosedTypeFamily (brListMap (noLoc . synifyAxBranch tc) branches)
+ _ -> error "synifyTyCon: type/data family confusion"
+ in FamDecl (FamilyDecl { fdInfo = info
+ , fdLName = synifyName tc
+ , fdTyVars = synifyTyVars (tyConTyVars tc)
+ , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) })
+ Nothing -> error "synifyTyCon: impossible open type synonym?"
+
| isDataFamilyTyCon tc
= --(why no "isOpenAlgTyCon"?)
case algTyConRhs tc of
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 62d08021..03d463cb 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -116,7 +116,7 @@ dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta
-- | 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,[ClsInst],[FamInst Branched]))
+getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))
getAllInfo name = withSession $ \hsc_env -> do
(_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name
return r
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 40016a0b..d4adbe1c 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -385,16 +385,19 @@ warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM ()
warnAboutFilteredDecls dflags mdl decls = do
let modStr = moduleString mdl
let typeInstances =
- nub (concat [[ unLoc (tfie_tycon eqn)
- | L _ (InstD (TyFamInstD (TyFamInstDecl { tfid_eqns = eqns }))) <- decls
- , L _ eqn <- eqns ],
+ nub (concat [[ unLoc (tfie_tycon (unLoc eqn))
+ | L _ (InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn }))) <- decls ],
[ unLoc (dfid_tycon d)
- | L _ (InstD (DataFamInstD { dfid_inst = d })) <- decls ]])
+ | L _ (InstD (DataFamInstD { dfid_inst = d })) <- decls ],
+ [ unLoc tc
+ | L _ (TyClD (FamDecl (FamilyDecl { fdInfo = ClosedTypeFamily _
+ , fdLName = tc }))) <- decls ]])
unless (null typeInstances) $
tell [
"Warning: " ++ modStr ++ ": Instances of type and data "
- ++ "families are not yet supported. Instances of the following families "
+ ++ "families and equations of closed type families are not yet supported."
+ ++ "Instances of the following families "
++ "will be filtered out:\n " ++ (intercalate ", "
$ map (occNameString . nameOccName) typeInstances) ]
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index a2499726..f21088d8 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -379,14 +379,22 @@ renameTyClD d = case d of
renameLSig (L loc sig) = return . L loc =<< renameSig sig
renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
-renameFamilyDecl (FamilyDecl { fdFlavour = flav, fdLName = lname
+renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
, fdTyVars = ltyvars, fdKindSig = tckind }) = do
+ info' <- renameFamilyInfo info
lname' <- renameL lname
ltyvars' <- renameLTyVarBndrs ltyvars
tckind' <- renameMaybeLKind tckind
- return (FamilyDecl { fdFlavour = flav, fdLName = lname'
+ return (FamilyDecl { fdInfo = info', fdLName = lname'
, fdTyVars = ltyvars', fdKindSig = tckind' })
+renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
+renameFamilyInfo DataFamily = return DataFamily
+renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
+renameFamilyInfo (ClosedTypeFamily eqns)
+ = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns
+ ; return $ ClosedTypeFamily eqns' }
+
renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)
renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
, dd_kindSig = k, dd_cons = cons }) = do
@@ -471,10 +479,9 @@ renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_da
renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName)
-renameTyFamInstD (TyFamInstDecl { tfid_eqns = eqns , tfid_group = eqn_group })
- = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns
- ; return (TyFamInstDecl { tfid_eqns = eqns'
- , tfid_group = eqn_group
+renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
+ = do { eqn' <- renameLThing renameTyFamInstEqn eqn
+ ; return (TyFamInstDecl { tfid_eqn = eqn'
, tfid_fvs = placeHolderNames }) }
renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName)
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 21:00:11 +0000