Repository : ssh://darcs.haskell.org//srv/darcs/haddock On branch : overlapping-tyfams
http://hackage.haskell.org/trac/ghc/changeset/c45f1068b6d9a09020f0d5ffa9451f894692e9a7 >--------------------------------------------------------------- commit c45f1068b6d9a09020f0d5ffa9451f894692e9a7 Author: Richard Eisenberg <e...@cis.upenn.edu> Date: Wed Nov 21 15:53:21 2012 -0500 Fixed merging errors >--------------------------------------------------------------- src/Haddock/Convert.hs | 54 +++++++++++++++++++------------------- src/Haddock/Interface/Rename.hs | 6 +++- src/Main.hs | 6 ++-- 3 files changed, 34 insertions(+), 32 deletions(-) diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 6ae5cbb..5f166da 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -18,7 +18,7 @@ module Haddock.Convert where import HsSyn -import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy ) +import TcType ( tcSplitSigmaTy ) import TypeRep import Type(isStrLitTy) import Kind ( splitKindFunTys, synTyConResKind ) @@ -90,22 +90,23 @@ synifyATDefault :: TyCon -> LTyFamInstDecl Name synifyATDefault tc = noLoc (synifyAxiom ax) where Just ax = tyConFamilyCoercion_maybe tc --- TODO (RAE): make convert axioms into instance groups as necessary +synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name +synifyAxBranch tc (CoAxBranch { cab_tvs = tvs, cab_lhs = args, cab_rhs = rhs }) + = let name = synifyName tc + typats = map (synifyType WithinType) args + hs_rhs = synifyType WithinType rhs + in TyFamInstEqn { tfie_tycon = name + , tfie_pats = HsWB { hswb_cts = typats + , hswb_kvs = [] + , hswb_tvs = map tyVarName tvs } + , tfie_rhs = hs_rhs } + synifyAxiom :: CoAxiom -> TyFamInstDecl Name -synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) - | Just (tc, args) <- tcSplitTyConApp_maybe lhs - = let name = synifyName tc - typats = map (synifyType WithinType) args - hs_rhs_ty = synifyType WithinType rhs - in TyFamInstDecl { tfid_eqns = [noLoc $ TyFamInstEqn { tfie_tycon = name - , tfie_pats = - HsWB { hswb_cts = typats - , hswb_kvs = [] - , hswb_tvs = map tyVarName tvs } - , tfie_rhs = hs_rhs_ty }] - , tfid_fvs = placeHolderNames } - | otherwise - = error "synifyAxiom" +synifyAxiom (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) + = let eqns = map (noLoc . synifyAxBranch tc) branches + in TyFamInstDecl { tfid_eqns = eqns + , tfid_group = (length branches /= 1) + , tfid_fvs = placeHolderNames } synifyTyCon :: TyCon -> TyClDecl Name synifyTyCon tc @@ -130,8 +131,8 @@ synifyTyCon tc , dd_derivs = Nothing } , tcdFVs = placeHolderNames } | isSynFamilyTyCon tc - = case synTyConRhs tc of - SynFamilyTyCon -> + = 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?" @@ -143,11 +144,13 @@ synifyTyCon tc Nothing) --always kind '*' _ -> error "synifyTyCon: impossible open data type?" | isSynTyCon tc - = SynDecl { tcdLName = synifyName tc - , tcdTyVars = synifyTyVars (tyConTyVars tc) - , tcdRhs = synifyType WithinType (synTyConType tc) - , tcdFVs = placeHolderNames } - + = case synTyConRhs_maybe tc of + Just (SynonymTyCon ty) -> + SynDecl { tcdLName = synifyName tc + , tcdTyVars = synifyTyVars (tyConTyVars tc) + , tcdRhs = synifyType WithinType ty + , tcdFVs = placeHolderNames } + _ -> error "synifyTyCon: impossible synTyCon" | otherwise = -- (closed) newtype and data let @@ -176,10 +179,7 @@ synifyTyCon tc cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = Nothing - defn | Just (_, syn_rhs) <- synTyConDefn_maybe tc - = TySynonym (synifyType WithinType syn_rhs) - | otherwise - = HsDataDefn { dd_ND = alg_nd + defn = HsDataDefn { dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing , dd_kindSig = fmap synifyKindSig kindSig diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 7a796d6..b384886 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -460,9 +460,11 @@ renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_da renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName) -renameTyFamInstD (TyFamInstDecl { tfid_eqns = eqns }) +renameTyFamInstD (TyFamInstDecl { tfid_eqns = eqns , tfid_group = eqn_group }) = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns - ; return (TyFamInstDecl { tfid_eqns = eqns', tfid_fvs = placeHolderNames }) } + ; return (TyFamInstDecl { tfid_eqns = eqns' + , tfid_group = eqn_group + , tfid_fvs = placeHolderNames }) } renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName) renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs }) diff --git a/src/Main.hs b/src/Main.hs index 88c89a1..dc5a49d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -54,11 +54,11 @@ import qualified GHC.Paths as GhcPaths import Paths_haddock #endif -import GHC hiding (flags, verbosity) +import GHC hiding (verbosity) import Config -import DynFlags hiding (flags, verbosity) +import DynFlags hiding (verbosity) import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) -import Panic (panic, handleGhcException) +import Panic (handleGhcException) import Module import Control.Monad.Fix (MonadFix) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
