Remove HsNumTy and TypePati.

They belonged to the old generic deriving mechanism, so they can go. Adapted a lot of code as a consequence.

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 2432051..ade1830 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"