Updates to reflect changes in HsDecls to support closed type families.

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)