[commit: haddock] overlapping-tyfams: Fixed merging errors (c45f106)

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 <[email protected]>
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)