Commit fed25228 authored by dreixel's avatar dreixel

Remove HsNumTy and TypePati.

They belonged to the old generic deriving mechanism, so they can go. Adapted a lot of code as a consequence.
parent 91a75b9a
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 []
......
......@@ -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 $
......
......@@ -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)) $
......
......@@ -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"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment