Merge branch 'master' of http://darcs.haskell.org/ghc
authorDavid Waern <david.waern@gmail.com>
Fri, 10 Jun 2011 23:56:19 +0000 (23:56 +0000)
committerDavid Waern <david.waern@gmail.com>
Fri, 10 Jun 2011 23:56:19 +0000 (23:56 +0000)
12 files changed:
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsUtils.lhs
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnBinds.lhs
compiler/rename/RnNames.lhs
compiler/rename/RnSource.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcGenDeriv.lhs

index a4b47ee..ab1c1e3 100644 (file)
@@ -419,7 +419,7 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
        -- Singleton => Ok
        -- Empty     => Too hard, signature ignored
-rep_sig (L loc (TypeSig nm ty))       = rep_proto nm ty loc
+rep_sig (L loc (TypeSig nms ty))      = rep_proto nms ty loc
 rep_sig (L _   (GenericSig nm _))     = failWithDs msg
   where msg = vcat  [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm)
                     , ptext (sLit "Default signatures are not supported by Template Haskell") ]
@@ -428,14 +428,16 @@ rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
 rep_sig _                             = return []
 
-rep_proto :: Located Name -> LHsType Name -> SrcSpan 
+rep_proto :: [Located Name] -> LHsType Name -> SrcSpan
           -> DsM [(SrcSpan, Core TH.DecQ)]
-rep_proto nm ty loc 
-  = do { nm1 <- lookupLOcc nm
-       ; ty1 <- repLTy ty
-       ; sig <- repProto nm1 ty1
-       ; return [(loc, sig)]
-       }
+rep_proto nms ty loc
+  = mapM f nms
+  where
+    f nm = do { nm1 <- lookupLOcc nm
+              ; ty1 <- repLTy ty
+              ; sig <- repProto nm1 ty1
+              ; return (loc, sig)
+              }
 
 rep_inline :: Located Name 
            -> InlinePragma     -- Never defaultInlinePragma
index 492f255..8d79afe 100644 (file)
@@ -143,7 +143,7 @@ cvtDec (TH.FunD nm cls)
 cvtDec (TH.SigD nm typ)  
   = do  { nm' <- vNameL nm
        ; ty' <- cvtType typ
-       ; returnL $ Hs.SigD (TypeSig nm' ty') }
+       ; returnL $ Hs.SigD (TypeSig [nm'] ty') }
 
 cvtDec (PragmaD prag)
   = do { prag' <- cvtPragmaD prag
index 5871914..52ed14b 100644 (file)
@@ -252,7 +252,7 @@ getTypeSigNames :: HsValBinds a -> NameSet
 getTypeSigNames (ValBindsIn {}) 
   = panic "getTypeSigNames"
 getTypeSigNames (ValBindsOut _ sigs) 
-  = mkNameSet [unLoc n | L _ (TypeSig n _) <- sigs]
+  = mkNameSet [unLoc n | L _ (TypeSig names _) <- sigs, n <- names]
 \end{code}
 
 What AbsBinds means
@@ -595,11 +595,11 @@ type LSig name = Located (Sig name)
 data Sig name  -- Signatures and pragmas
   =    -- An ordinary type signature
        -- f :: Num a => a -> a
-    TypeSig (Located name) (LHsType name)
+    TypeSig [Located name] (LHsType name)
 
         -- A type signature for a default method inside a class
         -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
-  | GenericSig (Located name) (LHsType name)
+  | GenericSig [Located name] (LHsType name)
 
        -- A type signature in generated code, notably the code
        -- generated for record selectors.  We simply record
@@ -685,18 +685,6 @@ okInstDclSig (GenericSig _ _) = False
 okInstDclSig (FixSig _)       = False
 okInstDclSig _                       = True
 
-sigName :: LSig name -> Maybe name
--- Used only in Haddock
-sigName (L _ sig) = sigNameNoLoc sig
-
-sigNameNoLoc :: Sig name -> Maybe name    
--- Used only in Haddock
-sigNameNoLoc (TypeSig   n _)          = Just (unLoc n)
-sigNameNoLoc (SpecSig   n _ _)        = Just (unLoc n)
-sigNameNoLoc (InlineSig n _)          = Just (unLoc n)
-sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
-sigNameNoLoc _                        = Nothing
-
 isFixityLSig :: LSig name -> Bool
 isFixityLSig (L _ (FixSig {})) = True
 isFixityLSig _                = False
@@ -748,8 +736,8 @@ Signature equality is used when checking for duplicate signatures
 eqHsSig :: Eq a => LSig a -> LSig a -> Bool
 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
 eqHsSig (L _ (IdSig n1))               (L _ (IdSig n2))                = n1 == n2
-eqHsSig (L _ (TypeSig n1 _))           (L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
-eqHsSig (L _ (GenericSig n1 _))                (L _ (GenericSig n2 _))         = unLoc n1 == unLoc n2
+eqHsSig (L _ (TypeSig ns1 _))          (L _ (TypeSig ns2 _))           = map unLoc ns1 == map unLoc ns2
+eqHsSig (L _ (GenericSig ns1 _))        (L _ (GenericSig ns2 _))        = map unLoc ns1 == map unLoc ns2
 eqHsSig (L _ (InlineSig n1 _))          (L _ (InlineSig n2 _))          = unLoc n1 == unLoc n2
        -- For specialisations, we don't have equality over
        -- HsType, so it's not convenient to spot duplicate 
@@ -762,9 +750,9 @@ instance (OutputableBndr name) => Outputable (Sig name) where
     ppr sig = ppr_sig sig
 
 ppr_sig :: OutputableBndr name => Sig name -> SDoc
-ppr_sig (TypeSig var ty)         = pprVarSig (unLoc var) (ppr ty)
-ppr_sig (GenericSig var ty)      = ptext (sLit "default") <+> pprVarSig (unLoc var) (ppr ty)
-ppr_sig (IdSig id)               = pprVarSig id (ppr (varType id))
+ppr_sig (TypeSig vars ty)        = pprVarSig (map unLoc vars) (ppr ty)
+ppr_sig (GenericSig vars ty)     = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
+ppr_sig (IdSig id)               = pprVarSig [id] (ppr (varType id))
 ppr_sig (FixSig fix_sig)         = ppr fix_sig
 ppr_sig (SpecSig var ty inl)     = pragBrackets (pprSpec var (ppr ty) inl)
 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
@@ -776,11 +764,13 @@ instance Outputable name => Outputable (FixitySig name) where
 pragBrackets :: SDoc -> SDoc
 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") 
 
-pprVarSig :: (Outputable id) => id -> SDoc -> SDoc
-pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty]
+pprVarSig :: (Outputable id) => [id] -> SDoc -> SDoc
+pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
+  where
+    pprvars = hsep $ punctuate comma (map ppr vars)
 
 pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc
-pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty
+pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty
   where
     pp_inl | isDefaultInlinePragma inl = empty
            | otherwise = ppr inl
index cc57e05..6ddbd99 100644 (file)
@@ -606,7 +606,7 @@ hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name]
 
 hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}))
   = cls_name : 
-    concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig n _) <- sigs]
+    concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns]
 
 hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons}))
   = tc_name : hsConDeclsBinders cons
index 01d768a..3651405 100644 (file)
@@ -1239,7 +1239,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
                         {% do s <- checkValSig $1 $3 
                         ; return (LL $ unitOL (LL $ SigD s)) }
        | var ',' sig_vars '::' sigtypedoc
-                               { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
+                               { LL $ toOL [ LL $ SigD (TypeSig ($1 : unLoc $3) $5) ] }
        | infix prec ops        { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
                                             | n <- unLoc $3 ] }
        | '{-# INLINE'   activation qvar '#-}'        
index a943344..10274e1 100644 (file)
@@ -774,7 +774,7 @@ checkValSig
        -> P (Sig RdrName)
 checkValSig (L l (HsVar v)) ty 
   | isUnqual v && not (isDataOcc (rdrNameOcc v))
-  = return (TypeSig (L l v) ty)
+  = return (TypeSig [L l v] ty)
 checkValSig lhs@(L l _) ty
   = parseErrorSDoc l ((text "Invalid type signature:" <+>
                        ppr lhs <+> text "::" <+> ppr ty)
index 80a47a4..3052a31 100644 (file)
@@ -560,8 +560,9 @@ mkSigTvFn sigs
   where
     env :: NameEnv [Name]
     env = mkNameEnv [ (name, map hsLTyVarName ltvs)
-                   | L _ (TypeSig (L _ name) 
-                                  (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs]
+                   | L _ (TypeSig names
+                                  (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs
+                    , (L _ name) <- names]
        -- Note the pattern-match on "Explicit"; we only bind
        -- type variables from signatures with an explicit top-level for-all
 \end{code}
@@ -693,16 +694,16 @@ renameSig :: Maybe NameSet -> Sig RdrName -> RnM (Sig Name)
 -- FixitySig is renamed elsewhere.
 renameSig _ (IdSig x)
   = return (IdSig x)     -- Actually this never occurs
-renameSig mb_names sig@(TypeSig v ty)
-  = do { new_v <- lookupSigOccRn mb_names sig v
-       ; new_ty <- rnHsSigType (quotes (ppr v)) ty
-       ; return (TypeSig new_v new_ty) }
+renameSig mb_names sig@(TypeSig vs ty)
+  = do { new_vs <- mapM (lookupSigOccRn mb_names sig) vs
+       ; new_ty <- rnHsSigType (quotes (ppr vs)) ty
+       ; return (TypeSig new_vs new_ty) }
 
-renameSig mb_names sig@(GenericSig v ty)
+renameSig mb_names sig@(GenericSig vs ty)
   = do { defaultSigs_on <- xoptM Opt_DefaultSignatures
         ; unless defaultSigs_on (addErr (defaultSigErr sig))
-        ; new_v <- lookupSigOccRn mb_names sig v
-       ; new_ty <- rnHsSigType (quotes (ppr v)) ty
+        ; new_v <- mapM (lookupSigOccRn mb_names sig) vs
+       ; new_ty <- rnHsSigType (quotes (ppr vs)) ty
        ; return (GenericSig new_v new_ty) }
 
 renameSig _ (SpecInstSig ty)
index 3867e17..ee14ad9 100644 (file)
@@ -472,7 +472,7 @@ get_local_binders gbl_env (HsGroup {hs_valds  = ValBindsIn _ val_sigs,
     -- In a hs-boot file, the value binders come from the
     --  *signatures*, and there should be no foreign binders
     val_bndrs :: [Located RdrName]
-    val_bndrs | is_hs_boot = [nm | L _ (TypeSig nm _) <- val_sigs]
+    val_bndrs | is_hs_boot = [n | L _ (TypeSig ns _) <- val_sigs, n <- ns]
               | otherwise  = for_hs_bndrs
 
     new_simple :: Located RdrName -> RnM (GenAvailInfo Name)
index 54dc378..73da1f1 100644 (file)
@@ -799,7 +799,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 
        -- Check the signatures
        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
-       ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
+       ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops]
        ; checkDupRdrNames sig_rdr_names_w_locs
                -- Typechecker is responsible for checking that we only
                -- give default-method bindings for things in this class.
index 2eefb8c..78fc9bc 100644 (file)
@@ -102,11 +102,12 @@ tcHsBootSigs :: HsValBinds Name -> TcM [Id]
 -- signatures in it.  The renamer checked all this
 tcHsBootSigs (ValBindsOut binds sigs)
   = do  { checkTc (null binds) badBootDeclErr
-        ; mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
+        ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
   where
-    tc_boot_sig (TypeSig (L _ name) ty)
-      = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
-           ; return (mkVanillaGlobal name sigma_ty) }
+    tc_boot_sig (TypeSig lnames ty) = mapM f lnames
+      where
+        f (L _ name) = do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+                           ; return (mkVanillaGlobal name sigma_ty) }
         -- Notice that we make GlobalIds, not LocalIds
     tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
 tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
@@ -177,7 +178,7 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
               ; ty_sigs = filter isTypeLSig sigs
               ; sig_fn  = mkSigFun ty_sigs }
 
-        ; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
+        ; poly_ids <- concat <$> checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
                 -- No recovery from bad signatures, because the type sigs
                 -- may bind type variables, so proceeding without them
                 -- can lead to a cascade of errors
@@ -1055,10 +1056,12 @@ mkSigFun :: [LSig Name] -> SigFun
 -- Precondition: no duplicates
 mkSigFun sigs = lookupNameEnv env
   where
-    env = mkNameEnv (mapCatMaybes mk_pair sigs)
-    mk_pair (L loc (TypeSig (L _ name) lhs_ty)) = Just (name, (hsExplicitTvs lhs_ty, loc))
-    mk_pair (L loc (IdSig id))                  = Just (idName id, ([], loc))
-    mk_pair _                                   = Nothing    
+    env = mkNameEnv (concatMap mk_pair sigs)
+    mk_pair (L loc (IdSig id))              = [(idName id, ([], loc))]
+    mk_pair (L loc (TypeSig lnames lhs_ty)) = map f lnames
+      where
+        f (L _ name) = (name, (hsExplicitTvs lhs_ty, loc))
+    mk_pair _                               = []
         -- The scoped names are the ones explicitly mentioned
         -- in the HsForAll.  (There may be more in sigma_ty, because
         -- of nested type synonyms.  See Note [More instantiated than scoped].)
@@ -1066,13 +1069,14 @@ mkSigFun sigs = lookupNameEnv env
 \end{code}
 
 \begin{code}
-tcTySig :: LSig Name -> TcM TcId
-tcTySig (L span (TypeSig (L _ name) ty))
-  = setSrcSpan span             $
-    do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
-        ; return (mkLocalId name sigma_ty) }
+tcTySig :: LSig Name -> TcM [TcId]
+tcTySig (L span (TypeSig names ty))
+  = setSrcSpan span $ mapM f names
+  where
+    f (L _ name) = do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+                       ; return (mkLocalId name sigma_ty) }
 tcTySig (L _ (IdSig id))
-  = return id
+  = return [id]
 tcTySig s = pprPanic "tcTySig" (ppr s)
 
 -------------------
index 8fc8a24..2663895 100644 (file)
@@ -89,10 +89,10 @@ tcClassSigs :: Name              -- Name of the class
            -> TcM ([TcMethInfo],    -- Exactly one for each method
                     NameEnv Type)    -- Types of the generic-default methods
 tcClassSigs clas sigs def_methods
-  = do { gen_dm_prs <- mapM (addLocM tc_gen_sig) gen_sigs
+  = do { gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
        ; let gen_dm_env = mkNameEnv gen_dm_prs
 
-       ; op_info <- mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
+       ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
 
        ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
        ; sequence_ [ failWithTc (badMethodErr clas n)
@@ -110,16 +110,17 @@ tcClassSigs clas sigs def_methods
     dm_bind_names :: [Name]    -- These ones have a value binding in the class decl
     dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
 
-    tc_sig genop_env (L _ op_name, op_hs_ty)
+    tc_sig genop_env (op_names, op_hs_ty)
       = do { op_ty <- tcHsKindedType op_hs_ty  -- Class tyvars already in scope
-           ; let dm | op_name `elemNameEnv` genop_env = GenericDM
-                    | op_name `elem` dm_bind_names    = VanillaDM
-                    | otherwise                       = NoDM
-           ; return (op_name, dm, op_ty) }
+           ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] }
+           where
+             f nm | nm `elemNameEnv` genop_env = GenericDM
+                  | nm `elem` dm_bind_names    = VanillaDM
+                  | otherwise                  = NoDM
 
-    tc_gen_sig (L _ op_name, gen_hs_ty)
+    tc_gen_sig (op_names, gen_hs_ty)
       = do { gen_op_ty <- tcHsKindedType gen_hs_ty
-           ; return (op_name, gen_op_ty) }
+           ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
 \end{code}
 
 
index ad640ef..e412910 100644 (file)
@@ -1670,7 +1670,7 @@ fiddling around.
 genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
 genAuxBind loc (GenCon2Tag tycon)
   = (mk_FunBind loc rdr_name eqns, 
-     L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
+     L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
   where
     rdr_name = con2tag_RDR tycon
 
@@ -1695,7 +1695,7 @@ genAuxBind loc (GenTag2Con tycon)
   = (mk_FunBind loc rdr_name 
        [([nlConVarPat intDataCon_RDR [a_RDR]], 
           nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
-     L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
+     L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
   where
     sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
              intTy `mkFunTy` mkParentType tycon
@@ -1704,7 +1704,7 @@ genAuxBind loc (GenTag2Con tycon)
 
 genAuxBind loc (GenMaxTag tycon)
   = (mkHsVarBind loc rdr_name rhs,
-     L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
+     L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
   where
     rdr_name = maxtag_RDR tycon
     sig_ty = HsCoreTy intTy
@@ -1714,7 +1714,7 @@ genAuxBind loc (GenMaxTag tycon)
 
 genAuxBind loc (MkTyCon tycon) --  $dT
   = (mkHsVarBind loc rdr_name rhs,
-     L loc (TypeSig (L loc rdr_name) sig_ty))
+     L loc (TypeSig [L loc rdr_name] sig_ty))
   where
     rdr_name = mk_data_type_name tycon
     sig_ty   = nlHsTyVar dataType_RDR
@@ -1725,7 +1725,7 @@ genAuxBind loc (MkTyCon tycon)    --  $dT
 
 genAuxBind loc (MkDataCon dc)  --  $cT1 etc
   = (mkHsVarBind loc rdr_name rhs,
-     L loc (TypeSig (L loc rdr_name) sig_ty))
+     L loc (TypeSig [L loc rdr_name] sig_ty))
   where
     rdr_name = mk_constr_name dc
     sig_ty   = nlHsTyVar constr_RDR