Commit ec0d62c5 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc

Conflicts:
	compiler/coreSyn/CoreLint.lhs
parents 3406c060 66ec09b7
......@@ -45,8 +45,8 @@ module DataCon (
deepSplitProductType_maybe,
-- ** Promotion related functions
promoteType, isPromotableType, isPromotableTyCon,
buildPromotedTyCon, buildPromotedDataCon,
isPromotableTyCon, promoteTyCon,
promoteDataCon, promoteDataCon_maybe
) where
#include "HsVersions.h"
......@@ -386,9 +386,11 @@ data DataCon
-- An entirely separate wrapper function is built in TcTyDecls
dcIds :: DataConIds,
dcInfix :: Bool -- True <=> declared infix
dcInfix :: Bool, -- True <=> declared infix
-- Used for Template Haskell and 'deriving' only
-- The actual fixity is stored elsewhere
dcPromoted :: Maybe TyCon -- The promoted TyCon if this DataCon is promotable
}
deriving Data.Typeable.Typeable
......@@ -519,10 +521,7 @@ mkDataCon name declared_infix
-- so the error is detected properly... it's just that asaertions here
-- are a little dodgy.
= -- ASSERT( not (any isEqPred theta) )
-- We don't currently allow any equality predicates on
-- a data constructor (apart from the GADT ones in eq_spec)
con
= con
where
is_vanilla = null ex_tvs && null eq_spec && null theta
con = MkData {dcName = name, dcUnique = nameUnique name,
......@@ -537,7 +536,8 @@ mkDataCon name declared_infix
dcStrictMarks = arg_stricts,
dcRepStrictness = rep_arg_stricts,
dcFields = fields, dcTag = tag, dcRepType = ty,
dcIds = ids }
dcIds = ids,
dcPromoted = mb_promoted }
-- Strictness marks for source-args
-- *after unboxing choices*,
......@@ -559,6 +559,16 @@ mkDataCon name declared_infix
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
mb_promoted
| is_vanilla -- No existentials or context
, all (isLiftedTypeKind . tyVarKind) univ_tvs
, all isPromotableType orig_arg_tys
= Just (mkPromotedDataCon con name (getUnique name) prom_kind arity)
| otherwise
= Nothing
prom_kind = promoteType (dataConUserType con)
arity = dataConSourceArity con
eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
......@@ -978,24 +988,22 @@ computeRep stricts tys
%* *
%************************************************************************
These two 'buildPromoted..' functions are here because
These two 'promoted..' functions are here because
* They belong together
* 'buildPromotedTyCon' is used by promoteType
* 'buildPromotedTyCon' depends on DataCon stuff
* 'promoteTyCon' is used by promoteType
* 'prmoteDataCon' depends on DataCon stuff
\begin{code}
buildPromotedTyCon :: TyCon -> TyCon
buildPromotedTyCon tc
= mkPromotedTyCon tc (promoteKind (tyConKind tc))
promoteDataCon :: DataCon -> TyCon
promoteDataCon (MkData { dcPromoted = Just tc }) = tc
promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc)
promoteDataCon_maybe :: DataCon -> Maybe TyCon
promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc
buildPromotedDataCon :: DataCon -> TyCon
buildPromotedDataCon dc
= ASSERT ( isPromotableType ty )
mkPromotedDataCon dc (getName dc) (getUnique dc) kind arity
where
ty = dataConUserType dc
kind = promoteType ty
arity = dataConSourceArity dc
promoteTyCon :: TyCon -> TyCon
promoteTyCon tc
= mkPromotedTyCon tc (promoteKind (tyConKind tc))
\end{code}
Note [Promoting a Type to a Kind]
......@@ -1017,16 +1025,11 @@ The transformation from type to kind is done by promoteType
\begin{code}
isPromotableType :: Type -> Bool
isPromotableType ty
= all (isLiftedTypeKind . tyVarKind) tvs
&& go rho
where
(tvs, rho) = splitForAllTys ty
go (TyConApp tc tys) | Just n <- isPromotableTyCon tc
= tys `lengthIs` n && all go tys
go (FunTy arg res) = go arg && go res
go (TyVarTy tvar) = tvar `elem` tvs
go _ = False
isPromotableType (TyConApp tc tys)
| Just n <- isPromotableTyCon tc = tys `lengthIs` n && all isPromotableType tys
isPromotableType (FunTy arg res) = isPromotableType arg && isPromotableType res
isPromotableType (TyVarTy {}) = True
isPromotableType _ = False
-- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ]
isPromotableTyCon :: TyCon -> Maybe Int
......@@ -1048,7 +1051,7 @@ promoteType ty
kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
env = zipVarEnv tvs kvs
go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys)
go (TyConApp tc tys) = mkTyConApp (promoteTyCon tc) (map go tys)
go (FunTy arg res) = mkArrowKind (go arg) (go res)
go (TyVarTy tv) | Just kv <- lookupVarEnv env tv
= TyVarTy kv
......
......@@ -758,29 +758,54 @@ There's a wrinkle for operators. Consider '>>='. We can't use '>>=1'
because that isn't a single lexeme. So we encode it to 'lle' and *then*
tack on the '1', if necessary.
Note [TidyOccEnv]
~~~~~~~~~~~~~~~~~
type TidyOccEnv = UniqFM Int
* Domain = The OccName's FastString. These FastStrings are "taken";
make sure that we don't re-use
* Int, n = A plausible starting point for new guesses
There is no guarantee that "FSn" is available;
you must look that up in the TidyOccEnv. But
it's a good place to start looking.
* When looking for a renaming for "foo2" we strip off the "2" and start
with "foo". Otherwise if we tidy twice we get silly names like foo23.
\begin{code}
type TidyOccEnv = OccEnv Int -- The in-scope OccNames
-- Range gives a plausible starting point for new guesses
type TidyOccEnv = UniqFM Int -- The in-scope OccNames
-- See Note [TidyOccEnv]
emptyTidyOccEnv :: TidyOccEnv
emptyTidyOccEnv = emptyOccEnv
emptyTidyOccEnv = emptyUFM
initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid!
initTidyOccEnv = foldl (\env occ -> extendOccEnv env occ 1) emptyTidyOccEnv
initTidyOccEnv = foldl add emptyUFM
where
add env (OccName _ fs) = addToUFM env fs 1
tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
tidyOccName in_scope occ@(OccName occ_sp fs)
= case lookupOccEnv in_scope occ of
Nothing -> -- Not already used: make it used
(extendOccEnv in_scope occ 1, occ)
Just n -> -- Already used: make a new guess,
-- change the guess base, and try again
tidyOccName (extendOccEnv in_scope occ (n+1))
(mkOccName occ_sp (base_occ ++ show n))
tidyOccName env occ@(OccName occ_sp fs)
= case lookupUFM env fs of
Just n -> find n
Nothing -> (addToUFM env fs 1, occ)
where
base_occ = reverse (dropWhile isDigit (reverse (unpackFS fs)))
base :: String -- Drop trailing digits (see Note [TidyOccEnv])
base = reverse (dropWhile isDigit (reverse (unpackFS fs)))
find n
= case lookupUFM env new_fs of
Just n' -> find (n1 `max` n')
-- The max ensures that n increases, avoiding loops
Nothing -> (addToUFM (addToUFM env fs n1) new_fs n1,
OccName occ_sp new_fs)
-- We update only the beginning and end of the
-- chain that find explores; it's a little harder to
-- update the middle and there's no real need.
where
n1 = n+1
new_fs = mkFastString (base ++ show n)
\end{code}
%************************************************************************
......
......@@ -886,7 +886,8 @@ lintCoercion co@(AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
; let ktv_kind = Type.substTy subst_l (tyVarKind ktv)
-- Using subst_l is ok, because subst_l and subst_r
-- must agree on kind equalities
; unless (k `isSubKind` ktv_kind) (bad_ax (ptext (sLit "check_ki2") $$ ppr k $$ ppr ktv_kind $$ ppr ktv $$ ppr co))
; unless (k `isSubKind` ktv_kind)
(bad_ax (ptext (sLit "check_ki2") <+> vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] ))
; return (Type.extendTvSubst subst_l ktv t1,
Type.extendTvSubst subst_r ktv t2) }
\end{code}
......
......@@ -675,7 +675,7 @@ exprIsWorkFree e = go 0 e
[ go n rhs | (_,_,rhs) <- alts ]
-- See Note [Case expressions are work-free]
go _ (Let {}) = False
go n (Var v) = n==0 || n < idArity v
go n (Var v) = isCheapApp v n
go n (Tick t e) | tickishCounts t = False
| otherwise = go n e
go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e
......@@ -740,7 +740,6 @@ exprIsCheap = exprIsCheap' isCheapApp
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes
type CheapAppFun = Id -> Int -> Bool
exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
exprIsCheap' _ (Lit _) = True
exprIsCheap' _ (Type _) = True
......@@ -779,16 +778,26 @@ exprIsCheap' good_app other_expr -- Applications and variables
go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
| otherwise = go f val_args
go (Var _) [] = True -- Just a type application of a variable
-- (f t1 t2 t3) counts as WHNF
go (Var _) [] = True
-- Just a type application of a variable
-- (f t1 t2 t3) counts as WHNF
-- This case is probably handeld by the good_app case
-- below, which should have a case for n=0, but putting
-- it here too is belt and braces; and it's such a common
-- case that checking for null directly seems like a
-- good plan
go (Var f) args
| good_app f (length args)
= go_pap args
| otherwise
= case idDetails f of
RecSelId {} -> go_sel args
ClassOpId {} -> go_sel args
PrimOpId op -> go_primop op args
_ | good_app f (length args) -> go_pap args
| isBottomingId f -> True
| otherwise -> False
RecSelId {} -> go_sel args
ClassOpId {} -> go_sel args
PrimOpId op -> go_primop op args
_ | isBottomingId f -> True
| otherwise -> False
-- Application of a function which
-- always gives bottom; we treat this as cheap
-- because it certainly doesn't need to be shared!
......@@ -820,9 +829,17 @@ exprIsCheap' good_app other_expr -- Applications and variables
-- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
-- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
-------------------------------------
type CheapAppFun = Id -> Int -> Bool
-- Is an application of this function to n *value* args
-- always cheap, assuming the arguments are cheap?
-- Mainly true of partial applications, data constructors,
-- and of course true if the number of args is zero
isCheapApp :: CheapAppFun
isCheapApp fn n_val_args
= isDataConWorkId fn
= isDataConWorkId fn
|| n_val_args == 0
|| n_val_args < idArity fn
isExpandableApp :: CheapAppFun
......@@ -833,6 +850,7 @@ isExpandableApp fn n_val_args
where
-- See if all the arguments are PredTys (implicit params or classes)
-- If so we'll regard it as expandable; see Note [Expandable overloadings]
-- This incidentally picks up the (n_val_args = 0) case
go 0 _ = True
go n_val_args ty
| Just (_, ty) <- splitForAllTy_maybe ty = go n_val_args ty
......
......@@ -265,9 +265,8 @@ repTyDefn tc bndrs opt_tys tv_names
; case new_or_data of
NewType -> do { con1 <- repC tv_names (head cons)
; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 }
DataType -> do { cons1 <- mapM (repC tv_names) cons
; cons2 <- coreList conQTyConName cons1
; repData cxt1 tc bndrs opt_tys cons2 derivs1 } }
DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons
; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty })
= do { ty1 <- repLTy ty
......@@ -305,16 +304,12 @@ mk_extra_tvs tc tvs defn
-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
repLFunDeps fds = do fds' <- mapM repLFunDep fds
fdList <- coreList funDepTyConName fds'
return fdList
repLFunDeps fds = repList funDepTyConName repLFunDep fds
repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
ys' <- mapM lookupBinder ys
xs_list <- coreList nameTyConName xs'
ys_list <- coreList nameTyConName ys'
repFunDep xs_list ys_list
repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
ys' <- repList nameTyConName lookupBinder ys
repFunDep xs' ys'
-- represent family declaration flavours
--
......@@ -364,9 +359,8 @@ repFamInstD (FamInstDecl { fid_tycon = tc_name
; let loc = getLoc tc_name
hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk
; addTyClTyVarBinds hs_tvs $ \ bndrs ->
do { tys1 <- repLTys tys
; tys2 <- coreList typeQTyConName tys1
; repTyDefn tc bndrs (Just tys2) tv_names defn } }
do { tys1 <- repList typeQTyConName repLTy tys
; repTyDefn tc bndrs (Just tys1) tv_names defn } }
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
......@@ -415,20 +409,29 @@ repFixD (L loc (FixitySig name (Fixity prec dir)))
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
= do { n' <- coreStringLit $ unpackFS n
; phases <- repPhases act
; bndrs' <- mapM repRuleBndr bndrs >>= coreList ruleBndrQTyConName
; lhs' <- repLE lhs
; rhs' <- repLE rhs
; pragma <- repPragRule n' bndrs' lhs' rhs' phases
; return (loc, pragma) }
= do { let bndr_names = concatMap ruleBndrNames bndrs
; ss <- mkGenSyms bndr_names
; rule1 <- addBinds ss $
do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
; n' <- coreStringLit $ unpackFS n
; act' <- repPhases act
; lhs' <- repLE lhs
; rhs' <- repLE rhs
; repPragRule n' bndrs' lhs' rhs' act' }
; rule2 <- wrapGenSyms ss rule1
; return (loc, rule2) }
ruleBndrNames :: RuleBndr Name -> [Name]
ruleBndrNames (RuleBndr n) = [unLoc n]
ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))
= unLoc n : kvs ++ tvs
repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (RuleBndr n)
= do { MkC n' <- lookupLOcc n
= do { MkC n' <- lookupLBinder n
; rep2 ruleVarName [n'] }
repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
= do { MkC n' <- lookupLOcc n
= do { MkC n' <- lookupLBinder n
; MkC ty' <- repLTy ty
; rep2 typedRuleVarName [n', ty'] }
......@@ -527,8 +530,7 @@ repBangTy ty= do
repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
repDerivs Nothing = coreList nameTyConName []
repDerivs (Just ctxt)
= do { strs <- mapM rep_deriv ctxt ;
coreList nameTyConName strs }
= repList nameTyConName rep_deriv ctxt
where
rep_deriv :: LHsType Name -> DsM (Core TH.Name)
-- Deriving clauses must have the simple H98 form
......@@ -578,11 +580,10 @@ rep_ty_sig loc (L _ ty) nm
rep_ty (HsForAllTy Explicit tvs ctxt ty)
= do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
; repTyVarBndrWithKind tv name }
; bndrs1 <- mapM rep_in_scope_tv (hsQTvBndrs tvs)
; bndrs2 <- coreList tyVarBndrTyConName bndrs1
; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
; ctxt1 <- repLContext ctxt
; ty1 <- repLTy ty
; repTForall bndrs2 ctxt1 ty1 }
; repTForall bndrs1 ctxt1 ty1 }
rep_ty ty = repTy ty
......@@ -653,9 +654,8 @@ addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be
addTyVarBinds tvs m
= do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs)
; term <- addBinds freshNames $
do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
; kbs2 <- coreList tyVarBndrTyConName kbs1
; m kbs2 }
do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
; m kbs }
; wrapGenSyms freshNames term }
where
mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
......@@ -677,13 +677,12 @@ addTyClTyVarBinds tvs m
-- This makes things work for family declarations
; term <- addBinds freshNames $
do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs)
; kbs2 <- coreList tyVarBndrTyConName kbs1
; m kbs2 }
do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
; m kbs }
; wrapGenSyms freshNames term }
where
mk_tv_bndr tv = do { v <- lookupOcc (hsLTyVarName tv)
mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
; repTyVarBndrWithKind tv v }
-- Produce kinded binder constructors from the Haskell tyvar binders
......@@ -701,10 +700,8 @@ repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt
repContext :: HsContext Name -> DsM (Core TH.CxtQ)
repContext ctxt = do
preds <- mapM repLPred ctxt
predList <- coreList predQTyConName preds
repCtxt predList
repContext ctxt = do preds <- repList predQTyConName repLPred ctxt
repCtxt preds
-- represent a type predicate
--
......@@ -716,9 +713,8 @@ repPred ty
| Just (cls, tys) <- splitHsClassTy_maybe ty
= do
cls1 <- lookupOcc cls
tys1 <- repLTys tys
tys2 <- coreList typeQTyConName tys1
repClassP cls1 tys2
tys1 <- repList typeQTyConName repLTy tys
repClassP cls1 tys1
repPred (HsEqTy tyleft tyright)
= do
tyleft1 <- repLTy tyleft
......@@ -860,8 +856,7 @@ repSplice (HsSplice n _)
-----------------------------------------------------------------------------
repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
repLEs es = do { es' <- mapM repLE es ;
coreList expQTyConName es' }
repLEs es = repList expQTyConName repLE es
-- FIXME: some of these panics should be converted into proper error messages
-- unless we can make sure that constructs, which are plainly not
......@@ -1024,10 +1019,11 @@ repLGRHS (L _ (GRHS ss rhs))
repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
repFields (HsRecFields { rec_flds = flds })
= do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
; es <- mapM repLE (map hsRecFieldArg flds)
; fs <- zipWithM repFieldExp fnames es
; coreList fieldExpQTyConName fs }
= repList fieldExpQTyConName rep_fld flds
where
rep_fld fld = do { fn <- lookupLOcc (hsRecFieldId fld)
; e <- repLE (hsRecFieldArg fld)
; repFieldExp fn e }
-----------------------------------------------------------------------------
......@@ -1210,8 +1206,7 @@ repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatc
-- Process a list of patterns
repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
repLPs ps = do { ps' <- mapM repLP ps ;
coreList patQTyConName ps' }
repLPs ps = repList patQTyConName repLP ps
repLP :: LPat Name -> DsM (Core TH.PatQ)
repLP (L _ p) = repP p
......@@ -1232,16 +1227,17 @@ repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
RecCon rec -> do { let flds = rec_flds rec
; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
; ps <- sequence $ map repLP (map hsRecFieldArg flds)
; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
; fps' <- coreList fieldPatQTyConName fps
; repPrec con_str fps' }
RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
; repPrec con_str fps }
InfixCon p1 p2 -> do { p1' <- repLP p1;
p2' <- repLP p2;
repPinfix p1' con_str p2' }
}
where
rep_fld fld = do { MkC v <- lookupLOcc (hsRecFieldId fld)
; MkC p <- repLP (hsRecFieldArg fld)
; rep2 fieldPatName [v,p] }
repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
......@@ -1679,16 +1675,16 @@ repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
repConstr :: Core TH.Name -> HsConDeclDetails Name
-> DsM (Core TH.ConQ)
repConstr con (PrefixCon ps)
= do arg_tys <- mapM repBangTy ps
arg_tys1 <- coreList strictTypeQTyConName arg_tys
rep2 normalCName [unC con, unC arg_tys1]
= do arg_tys <- repList strictTypeQTyConName repBangTy ps
rep2 normalCName [unC con, unC arg_tys]
repConstr con (RecCon ips)
= do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
arg_tys <- mapM repBangTy (map cd_fld_type ips)
arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
arg_vs arg_tys
arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
rep2 recCName [unC con, unC arg_vtys']
= do { arg_vtys <- repList varStrictTypeQTyConName rep_ip ips
; rep2 recCName [unC con, unC arg_vtys] }
where
rep_ip ip = do { MkC v <- lookupLOcc (cd_fld_name ip)
; MkC ty <- repBangTy (cd_fld_type ip)
; rep2 varStrictTypeName [v,ty] }
repConstr con (InfixCon st1 st2)
= do arg1 <- repBangTy st1
arg2 <- repBangTy st2
......@@ -1863,6 +1859,12 @@ repSequenceQ ty_a (MkC list)
------------ Lists and Tuples -------------------
-- turn a list of patterns into a single pattern matching a list
repList :: Name -> (a -> DsM (Core b))
-> [a] -> DsM (Core [b])
repList tc_name f args
= do { args1 <- mapM f args
; coreList tc_name args1 }
coreList :: Name -- Of the TyCon of the element type
-> [Core a] -> DsM (Core [a])
coreList tc_name es
......
......@@ -573,22 +573,6 @@ Check if signatures overlap; this is used when checking for duplicate
signatures. Since some of the signatures contain a list of names, testing for
equality is not enough -- we have to check if they overlap.
\begin{code}
overlapHsSig :: Eq a => LSig a -> LSig a -> Bool
overlapHsSig sig1 sig2 = case (unLoc sig1, unLoc sig2) of
(FixSig (FixitySig n1 _), FixSig (FixitySig n2 _)) -> unLoc n1 == unLoc n2
(IdSig n1, IdSig n2) -> n1 == n2
(TypeSig ns1 _, TypeSig ns2 _) -> ns1 `overlaps_with` ns2
(GenericSig ns1 _, GenericSig ns2 _) -> ns1 `overlaps_with` ns2
(InlineSig n1 _, InlineSig n2 _) -> unLoc n1 == unLoc n2
-- For specialisations, we don't have equality over HsType, so it's not
-- convenient to spot duplicate specialisations here. Check for this later,
-- when we're in Type land
(_other1, _other2) -> False
where
ns1 `overlaps_with` ns2 = not (null (intersect (map unLoc ns1) (map unLoc ns2)))
\end{code}
\begin{code}
instance (OutputableBndr name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
......
......@@ -1364,7 +1364,7 @@ tcIfaceTyCon (IfaceTc name)
; case thing of -- A "type constructor" can be a promoted data constructor
-- c.f. Trac #5881
ATyCon tc -> return tc
ADataCon dc -> return (buildPromotedDataCon dc)
ADataCon dc -> return (promoteDataCon dc)
_ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) }
tcIfaceKindCon :: IfaceTyCon -> IfL TyCon
......@@ -1374,7 +1374,7 @@ tcIfaceKindCon (IfaceTc name)
-- c.f. Trac #5881
ATyCon tc
| isSuperKind (tyConKind tc) -> return tc -- Mainly just '*' or 'AnyK'
| otherwise -> return (buildPromotedTyCon tc)
| otherwise -> return (promoteTyCon tc)
_ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr thing) }
......
......@@ -495,7 +495,6 @@ data ExtensionFlag
| Opt_MultiParamTypeClasses
| Opt_FunctionalDependencies
| Opt_UnicodeSyntax
| Opt_PolymorphicComponents
| Opt_ExistentialQuantification
| Opt_MagicHash
| Opt_EmptyDataDecls
......@@ -509,7 +508,6 @@ data ExtensionFlag
| Opt_TupleSections
| Opt_PatternGuards
| Opt_LiberalTypeSynonyms
| Opt_Rank2Types
| Opt_RankNTypes
| Opt_ImpredicativeTypes
| Opt_TypeOperators
......@@ -2447,7 +2445,6 @@ xFlags = [
( "PatternGuards", Opt_PatternGuards, nop ),
( "UnicodeSyntax", Opt_UnicodeSyntax, nop ),
( "MagicHash", Opt_MagicHash, nop ),
( "PolymorphicComponents", Opt_PolymorphicComponents, nop ),
( "ExistentialQuantification", Opt_ExistentialQuantification, nop ),
( "KindSignatures", Opt_KindSignatures, nop ),
( "EmptyDataDecls", Opt_EmptyDataDecls, nop ),
......@@ -2460,7 +2457,10 @@ xFlags = [
( "CApiFFI", Opt_CApiFFI, nop ),
( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ),
( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms, nop ),
( "Rank2Types", Opt_Rank2Types, nop ),
( "PolymorphicComponents", Opt_RankNTypes,
deprecatedForExtension "RankNTypes" ),
( "Rank2Types", Opt_RankNTypes,