From fed25228aec3f3bd2f91c50d67043d83efb1af18 Mon Sep 17 00:00:00 2001 From: Jose Pedro Magalhaes Date: Wed, 4 May 2011 17:27:49 +0200 Subject: [PATCH] Remove HsNumTy and TypePati. They belonged to the old generic deriving mechanism, so they can go. Adapted a lot of code as a consequence. --- compiler/deSugar/Check.lhs | 2 +- compiler/deSugar/DsArrows.lhs | 1 - compiler/deSugar/DsMeta.hs | 6 ++++-- compiler/hsSyn/HsBinds.lhs | 2 +- compiler/hsSyn/HsPat.lhs | 9 --------- compiler/hsSyn/HsTypes.lhs | 3 --- compiler/hsSyn/HsUtils.lhs | 2 -- compiler/parser/Parser.y.pp | 2 -- compiler/parser/RdrHsSyn.lhs | 6 +----- compiler/rename/RnBinds.lhs | 30 ++++++++---------------------- compiler/rename/RnHsSyn.lhs | 26 +------------------------- compiler/rename/RnPat.lhs | 4 ---- compiler/rename/RnSource.lhs | 14 +++++--------- compiler/rename/RnTypes.lhs | 7 ------- compiler/typecheck/TcDeriv.lhs | 2 +- compiler/typecheck/TcHsType.lhs | 9 --------- compiler/typecheck/TcPat.lhs | 6 ------ compiler/typecheck/TcTyClsDecls.lhs | 15 --------------- utils/ghctags/Main.hs | 1 - 19 files changed, 22 insertions(+), 125 deletions(-) diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 2432051..ade1830 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -643,7 +643,7 @@ might_fail_pat (ConPatOut { pat_args = ps }) = any might_fail_lpat (hsConPatArgs -- Finally the ones that are sure to succeed, or which are covered by the checking algorithm might_fail_pat (LazyPat _) = False -- Always succeeds -might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat, TypePat +might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat -------------- might_fail_lpat :: LPat Id -> Bool diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 58bf6b8..4f553e5 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -1061,7 +1061,6 @@ collectl (L _ pat) bndrs go (SigPatIn pat _) = collectl pat bndrs go (SigPatOut pat _) = collectl pat bndrs - go (TypePat _) = bndrs go (CoPat _ pat _) = collectl (noLoc pat) bndrs go (ViewPat _ pat _) = collectl pat bndrs go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 611a231..ce0f231 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -420,7 +420,10 @@ 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 (GenericSig nm ty)) = rep_proto nm ty loc -- JPM: ? +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") ] + 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 [] @@ -632,7 +635,6 @@ repTy (HsKindSig t k) = do k1 <- repKind k repTSig t1 k1 repTy (HsSpliceTy splice _ _) = repSplice splice -repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) repTy ty = notHandled "Exotic form of type" (ppr ty) -- represent a kind diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index e6cad1a..dab2860 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -671,7 +671,7 @@ okBindSig _ = True okHsBootSig :: Sig a -> Bool okHsBootSig (TypeSig _ _) = True -okHsBootSig (GenericSig _ _) = True -- JPM: Is this true? +okHsBootSig (GenericSig _ _) = False okHsBootSig (FixSig _) = True okHsBootSig _ = False diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 78b5887..6341a66 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -132,12 +132,6 @@ data Pat id (SyntaxExpr id) -- (>=) function, of type t->t->Bool (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName) - ------------ Generics --------------- - | TypePat (LHsType id) -- Type pattern for generic definitions - -- e.g f{| a+b |} = ... - -- These show up only in class declarations, - -- and should be a top-level pattern - ------------ Pattern type signatures --------------- | SigPatIn (LPat id) -- Pattern with a type signature (LHsType id) @@ -281,7 +275,6 @@ pprPat (NPat l Nothing _) = ppr l pprPat (NPat l (Just _) _) = char '-' <> ppr l pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] pprPat (QuasiQuotePat qq) = ppr qq -pprPat (TypePat ty) = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}") pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty @@ -439,7 +432,6 @@ isIrrefutableHsPat pat go1 (QuasiQuotePat {}) = urk pat -- Gotten rid of by renamer, before -- isIrrefutablePat is called - go1 (TypePat {}) = urk pat urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat) @@ -463,7 +455,6 @@ hsPatNeedsParens (LitPat {}) = False hsPatNeedsParens (NPat {}) = False hsPatNeedsParens (NPlusKPat {}) = True hsPatNeedsParens (QuasiQuotePat {}) = True -hsPatNeedsParens (TypePat {}) = False conPatNeedsParens :: HsConDetails a b -> Bool conPatNeedsParens (PrefixCon args) = not (null args) diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 38608a4..7dbb16d 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -168,8 +168,6 @@ data HsType name -- interface files smaller), so when printing a HsType we may need to -- add parens. - | HsNumTy Integer -- Generics only - | HsPredTy (HsPred name) -- Only used in the type of an instance -- declaration, eg. Eq [a] -> Eq a -- ^^^^ @@ -440,7 +438,6 @@ ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcol ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsPredTy pred) = ppr pred -ppr_mono_ty _ (HsNumTy n) = integer n -- generics only ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index ad0f30f..916d2e4 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -538,7 +538,6 @@ collect_lpat (L _ pat) bndrs go (SigPatIn pat _) = collect_lpat pat bndrs go (SigPatOut pat _) = collect_lpat pat bndrs go (QuasiQuotePat _) = bndrs - go (TypePat _) = bndrs go (CoPat _ pat _) = go pat \end{code} @@ -714,7 +713,6 @@ collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name] collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc) -collect_sig_pat (TypePat ty) acc = ty:acc collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index e009071..1f459e5 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1027,8 +1027,6 @@ atype :: { LHsType RdrName } | '$(' exp ')' { LL $ mkHsSpliceTy $2 } | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ mkUnqual varName (getTH_ID_SPLICE $1) } --- Generics - | INTEGER { L1 (HsNumTy (getINTEGER $1)) } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 21fbb5a..1d96bf8 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -127,7 +127,6 @@ extract_lty (L loc ty) acc HsPredTy p -> extract_pred p acc HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) HsParTy ty -> extract_lty ty acc - HsNumTy {} -> acc HsCoreTy {} -> acc -- The type is closed HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables HsSpliceTy {} -> acc -- Type splices mention no type variables @@ -152,8 +151,7 @@ extractGenericPatTyVars binds get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms get _ acc = acc - get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc - get_m _ acc = acc + get_m _ acc = acc \end{code} @@ -732,8 +730,6 @@ checkAPat dynflags loc e0 = case e0 of -> do fs <- mapM checkPatField fs return (ConPatIn c (RecCon (HsRecFields fs dd))) HsQuasiQuoteE q -> return (QuasiQuotePat q) --- Generics - HsType ty -> return (TypePat ty) _ -> patFail loc e0 placeHolderPunRhs :: LHsExpr RdrName diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 4371a2c..8f8d7cb 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -26,7 +26,6 @@ module RnBinds ( import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn -import RdrHsSyn import RnHsSyn import TcRnMonad import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch) @@ -586,11 +585,10 @@ a binder. \begin{code} rnMethodBinds :: Name -- Class name -> (Name -> [Name]) -- Signature tyvar function - -> [Name] -- Names for generic type variables -> LHsBinds RdrName -> RnM (LHsBinds Name, FreeVars) -rnMethodBinds cls sig_fn gen_tyvars binds +rnMethodBinds cls sig_fn binds = do { checkDupRdrNames meth_names -- Check that the same method is not given twice in the -- same instance decl instance C T where @@ -606,15 +604,14 @@ rnMethodBinds cls sig_fn gen_tyvars binds where meth_names = collectMethodBinders binds do_one (binds,fvs) bind - = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind + = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) } rnMethodBind :: Name -> (Name -> [Name]) - -> [Name] -> LHsBindLR RdrName RdrName -> RnM (Bag (LHsBindLR Name Name), FreeVars) -rnMethodBind cls sig_fn gen_tyvars +rnMethodBind cls sig_fn (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix , fun_matches = MatchGroup matches _ })) = setSrcSpan loc $ do @@ -623,7 +620,7 @@ rnMethodBind cls sig_fn gen_tyvars -- We use the selector name as the binder (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ - mapFvRn (rn_match (FunRhs plain_name is_infix)) matches + mapFvRn (rnMatch (FunRhs plain_name is_infix)) matches let new_group = MatchGroup new_matches placeHolderType when is_infix $ checkPrecMatch plain_name new_group @@ -632,24 +629,13 @@ rnMethodBind cls sig_fn gen_tyvars , bind_fvs = fvs })), fvs `addOneFV` plain_name) -- The 'fvs' field isn't used for method binds - where - -- Truly gruesome; bring into scope the correct members of the generic - -- type variables. See comments in RnSource.rnSourceDecl(ClassDecl) - rn_match info match@(L _ (Match (L _ (TypePat ty) : _) _ _)) - = extendTyVarEnvFVRn gen_tvs $ - rnMatch info match - where - tvs = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty) - gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] - - rn_match info match = rnMatch info match -- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do +rnMethodBind _ _ (L loc bind@(PatBind {})) = do addErrAt loc (methodBindErr bind) return (emptyBag, emptyFVs) -rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b) +rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b) \end{code} @@ -684,7 +670,7 @@ renameSigs mb_names ok_sig sigs -- equal to an ordinary sig, so we allow, say -- class C a where -- op :: a -> a - -- generic op :: Eq a => a -> a + -- default op :: Eq a => a -> a ; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs @@ -717,7 +703,7 @@ renameSig mb_names sig@(GenericSig v ty) ; unless defaultSigs_on (addErr (defaultSigErr sig)) ; new_v <- lookupSigOccRn mb_names sig v ; new_ty <- rnHsSigType (quotes (ppr v)) ty - ; return (GenericSig new_v new_ty) } -- JPM: ? + ; return (GenericSig new_v new_ty) } renameSig _ (SpecInstSig ty) = do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index 44aa700..478ba32 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -11,9 +11,7 @@ module RnHsSyn( extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames, -- Free variables - hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs, - - maybeGenericMatch + hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs ) where #include "HsVersions.h" @@ -66,7 +64,6 @@ extractHsTyNames ty get (HsParTy ty) = getl ty get (HsBangTy _ ty) = getl ty get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds) - get (HsNumTy _) = emptyNameSet get (HsTyVar tv) = unitNameSet tv get (HsSpliceTy _ fvs _) = fvs get (HsQuasiQuoteTy {}) = emptyNameSet @@ -145,24 +142,3 @@ conDetailsFVs details = plusFVs (map bangTyFVs (hsConDeclArgTys details)) bangTyFVs :: LHsType Name -> FreeVars bangTyFVs bty = extractHsTyNames (getBangType bty) \end{code} - - -%************************************************************************ -%* * -\subsection{A few functions on generic defintions -%* * -%************************************************************************ - -These functions on generics are defined over Matches Name, which is -why they are here and not in HsMatches. - -\begin{code} -maybeGenericMatch :: LMatch Name -> Maybe (HsType Name, LMatch Name) - -- Tells whether a Match is for a generic definition - -- and extract the type from a generic match and put it at the front - -maybeGenericMatch (L loc (Match (L _ (TypePat (L _ ty)) : pats) sig_ty grhss)) - = Just (ty, L loc (Match pats sig_ty grhss)) - -maybeGenericMatch _ = Nothing -\end{code} diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 76be451..844a1f9 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -367,10 +367,6 @@ rnPatAndThen mk (TuplePat pats boxed _) ; pats' <- rnLPatsAndThen mk pats ; return (TuplePat pats' boxed placeHolderType) } -rnPatAndThen _ (TypePat ty) - = do { ty' <- liftCpsFV $ rnHsTypeFVs (text "In a type pattern") ty - ; return (TypePat ty') } - #ifndef GHCI rnPatAndThen _ p@(QuasiQuotePat {}) = pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index e08f65e..54dc378 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -17,14 +17,14 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) import HsSyn import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc ) -import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) +import RdrHsSyn ( extractHsRhoRdrTyVars ) import RnHsSyn import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields ) import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn, makeMiniFixityEnv) import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, lookupTopBndrRn, lookupLocatedTopBndrRn, - lookupOccRn, newLocalBndrsRn, bindLocalNamesFV, + lookupOccRn, bindLocalNamesFV, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn, bindLocalNames, checkDupRdrNames, mapFvRn @@ -449,7 +449,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too rnMethodBinds cls (\_ -> []) -- No scoped tyvars - [] mbinds + mbinds ) `thenM` \ (mbinds', meth_fvs) -> -- Rename the associated types -- The typechecker (not the renamer) checks that all @@ -815,15 +815,11 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. ; (mbinds', meth_fvs) - <- extendTyVarEnvForMethodBinds tyvars' $ do - { name_env <- getLocalRdrEnv - ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds, - not (unLoc tv `elemLocalRdrEnv` name_env) ] + <- extendTyVarEnvForMethodBinds tyvars' $ -- No need to check for duplicate method signatures -- since that is done by RnNames.extendGlobalRdrEnvRn -- and the methods are already in scope - ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs - ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds } + rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds -- Haddock docs ; docs' <- mapM (wrapLocM rnDocDecl) docs diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 138ffa2..ea87745 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -139,13 +139,6 @@ rnHsType doc (HsRecTy flds) = do { flds' <- rnConDeclFields doc flds ; return (HsRecTy flds') } -rnHsType _ (HsNumTy i) - | i == 1 = return (HsNumTy i) - | otherwise = addErr err_msg >> return (HsNumTy i) - where - err_msg = ptext (sLit "Only unit numeric type pattern is valid") - - rnHsType doc (HsFunTy ty1 ty2) = do ty1' <- rnLHsType doc ty1 -- Might find a for-all as the arg of a function type diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index a681543..3bb46ed 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -407,7 +407,7 @@ renameDeriv is_boot gen_binds insts -- scope (yuk), and rename the method binds ASSERT( null sigs ) bindLocalNames (map Var.varName tyvars) $ - do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds + do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) binds ; let binds' = VanillaInst rn_binds [] standalone_deriv ; return (inst_info { iBinds = binds' }, fvs) } where diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 71eb55e..182d1fc 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -44,7 +44,6 @@ import TyCon import Class import Name import NameSet -import PrelNames import TysWiredIn import BasicTypes import SrcLoc @@ -365,9 +364,6 @@ kc_hs_type (HsPArrTy ty) = do ty' <- kcLiftedType ty return (HsPArrTy ty', liftedTypeKind) -kc_hs_type (HsNumTy n) - = return (HsNumTy n, liftedTypeKind) - kc_hs_type (HsKindSig ty k) = do ty' <- kc_check_lhs_type ty (EK k EkKindSig) return (HsKindSig ty' k, k) @@ -606,11 +602,6 @@ ds_type (HsOpTy ty1 (L span op) ty2) = do tau_ty2 <- dsHsType ty2 setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2]) -ds_type (HsNumTy n) - = ASSERT(n==1) do - tc <- tcLookupTyCon genUnitTyConName - return (mkTyConApp tc []) - ds_type ty@(HsAppTy _ _) = ds_app ty [] diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index d28e901..79603ea 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -459,9 +459,6 @@ tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) } -tc_pat _ pat@(TypePat _) _ _ - = failWithTc (badTypePat pat) - ------------------------ -- Lists, tuples, arrays tc_pat penv (ListPat pats _) pat_ty thing_inside @@ -1047,9 +1044,6 @@ polyPatSig sig_ty = hang (ptext (sLit "Illegal polymorphic type signature in pattern:")) 2 (ppr sig_ty) -badTypePat :: Pat Name -> SDoc -badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat - lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM () lazyUnliftedPatErr pat = failWithTc $ diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 284972e..cb16097 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1157,13 +1157,6 @@ checkValidClass cls ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars) ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars) (noClassTyVarErr cls sel_id) - - -- Check that for a generic method, the type of - -- the method is sufficiently simple -{- -- JPM TODO (when reinstating, remove commenting-out of badGenericMethodType - ; checkTc (dm /= GenDefMeth || validGenericMethodType tau) - (badGenericMethodType op_name op_ty) --} } where op_name = idName sel_id @@ -1429,14 +1422,6 @@ genericMultiParamErr clas = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+> ptext (sLit "cannot have generic methods") -{- Commented out until the call is reinstated -badGenericMethodType :: Name -> Kind -> SDoc -badGenericMethodType op op_ty - = hang (ptext (sLit "Generic method type is too complex")) - 2 (vcat [ppr op <+> dcolon <+> ppr op_ty, - ptext (sLit "You can only use type variables, arrows, lists, and tuples")]) --} - recSynErr :: [LTyClDecl Name] -> TcRn () recSynErr syn_decls = setSrcSpan (getLoc (head sorted_decls)) $ diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index b3ed58f..c86a92a 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -293,7 +293,6 @@ boundThings modname lbinding = LitPat _ -> tl NPat _ _ _ -> tl -- form of literal pattern? NPlusKPat id _ _ _ -> thing id : tl - TypePat _ -> tl -- XXX need help here SigPatIn p _ -> patThings p tl SigPatOut p _ -> patThings p tl _ -> error "boundThings" -- 1.7.10.4