From ce3ff856c9412d5392fb7a5c37445f60f84cb2d2 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Fri, 21 Jun 2013 14:08:25 +0100 Subject: Updates to reflect changes in HsDecls to support closed type families. --- src/Haddock/Backends/Xhtml/Decl.hs | 20 ++++++++++----- src/Haddock/Convert.hs | 43 +++++++++++++++++++++----------- src/Haddock/Interface/AttachInstances.hs | 2 +- src/Haddock/Interface/Create.hs | 13 ++++++---- src/Haddock/Interface/Rename.hs | 19 +++++++++----- 5 files changed, 64 insertions(+), 33 deletions(-) (limited to 'src') 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) -- cgit v1.2.3