X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=7bb1d5e38da7d342a68659e4212fd8d0949a9405;hp=322a5fd69d98b57b1bc9822fbf4f08e847826c6d;hb=6c7b41cc2b24f533697a62bf1843507ae043fc97;hpb=40f5a0759bd07308009c3ae8956dfa061c684ebd diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 322a5fd..7bb1d5e 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1,18 +1,28 @@ % +% (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1996-1998 % -\section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker} + +TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker This module is an extension of @HsSyn@ syntax, for use in the type checker. \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcHsSyn ( - mkHsTyApp, mkHsDictApp, mkHsConApp, - mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp, - hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt, + mkHsConApp, mkHsDictLet, mkHsApp, + hsLitType, hsLPatType, hsPatType, + mkHsAppTy, mkSimpleHsAlt, nlHsIntLit, mkVanillaTuplePat, + mkArbitraryType, -- Put this elsewhere? -- re-exported from TcMonad TcId, TcIdSet, TcDictBinds, @@ -27,35 +37,43 @@ module TcHsSyn ( import HsSyn -- oodles of it -- others: -import Id ( idType, setIdType, Id ) +import Id import TcRnMonad -import Type ( Type ) -import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar ) -import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind ) -import qualified Type -import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, writeMetaTyVar ) -import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, - doublePrimTy, addrPrimTy - ) -import TysWiredIn ( charTy, stringTy, intTy, - mkListTy, mkPArrTy, mkTupleTy, unitTy, - voidTy, listTyCon, tupleTyCon ) -import TyCon ( mkPrimTyCon, tyConKind, PrimRep(..) ) -import Kind ( splitKindFunTys ) -import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc ) -import Var ( Var, isId, isLocalVar, tyVarKind ) +import Type +import TcType +import TcMType +import TysPrim +import TysWiredIn +import TyCon +import Name +import Var import VarSet import VarEnv -import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName ) -import Maybes ( orElse ) -import Unique ( Uniquable(..) ) -import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc ) -import Util ( mapSnd ) +import BasicTypes +import Maybes +import Unique +import SrcLoc +import Util import Bag import Outputable \end{code} +\begin{code} +-- XXX +thenM :: Monad a => a b -> (b -> a c) -> a c +thenM = (>>=) + +thenM_ :: Monad a => a b -> a c -> a c +thenM_ = (>>) + +returnM :: Monad m => a -> m a +returnM = return + +mappM :: (Monad m) => (a -> m b) -> [a] -> m [b] +mappM = mapM +\end{code} + %************************************************************************ %* * @@ -63,37 +81,34 @@ import Outputable %* * %************************************************************************ -Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@, +Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@, then something is wrong. \begin{code} mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id -- A vanilla tuple pattern simply gets its type from its sub-patterns mkVanillaTuplePat pats box - = TuplePat pats box (mkTupleTy box (length pats) (map hsPatType pats)) - -hsPatType :: OutPat Id -> Type -hsPatType (L _ pat) = pat_type pat - -pat_type (ParPat pat) = hsPatType pat -pat_type (WildPat ty) = ty -pat_type (VarPat var) = idType var -pat_type (VarPatOut var _) = idType var -pat_type (BangPat pat) = hsPatType pat -pat_type (LazyPat pat) = hsPatType pat -pat_type (LitPat lit) = hsLitType lit -pat_type (AsPat var pat) = idType (unLoc var) -pat_type (ListPat _ ty) = mkListTy ty -pat_type (PArrPat _ ty) = mkPArrTy ty -pat_type (TuplePat pats box ty) = ty -pat_type (ConPatOut _ _ _ _ _ ty) = ty -pat_type (SigPatOut pat ty) = ty -pat_type (NPat lit _ _ ty) = ty -pat_type (NPlusKPat id _ _ _) = idType (unLoc id) -pat_type (DictPat ds ms) = case (ds ++ ms) of - [] -> unitTy - [d] -> idType d - ds -> mkTupleTy Boxed (length ds) (map idType ds) - + = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats)) + +hsLPatType :: OutPat Id -> Type +hsLPatType (L _ pat) = hsPatType pat + +hsPatType (ParPat pat) = hsLPatType pat +hsPatType (WildPat ty) = ty +hsPatType (VarPat var) = idType var +hsPatType (VarPatOut var _) = idType var +hsPatType (BangPat pat) = hsLPatType pat +hsPatType (LazyPat pat) = hsLPatType pat +hsPatType (LitPat lit) = hsLitType lit +hsPatType (AsPat var pat) = idType (unLoc var) +hsPatType (ViewPat expr pat ty) = ty +hsPatType (ListPat _ ty) = mkListTy ty +hsPatType (PArrPat _ ty) = mkPArrTy ty +hsPatType (TuplePat pats box ty) = ty +hsPatType (ConPatOut{ pat_ty = ty })= ty +hsPatType (SigPatOut pat ty) = ty +hsPatType (NPat lit _ _) = overLitType lit +hsPatType (NPlusKPat id _ _ _) = idType (unLoc id) +hsPatType (CoPat _ _ ty) = ty hsLitType :: HsLit -> TcType hsLitType (HsChar c) = charTy @@ -120,7 +135,7 @@ hsLitType (HsDoublePrim d) = doublePrimTy zonkId :: TcId -> TcM TcId zonkId id = zonkTcType (idType id) `thenM` \ ty' -> - returnM (setIdType id ty') + returnM (Id.setIdType id ty') \end{code} The rest of the zonking is done *after* typechecking. @@ -189,11 +204,18 @@ zonkIdOccs env ids = map (zonkIdOcc env) ids zonkIdBndr :: ZonkEnv -> TcId -> TcM Id zonkIdBndr env id = zonkTcTypeToType env (idType id) `thenM` \ ty' -> - returnM (setIdType id ty') + returnM (Id.setIdType id ty') zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] zonkIdBndrs env ids = mappM (zonkIdBndr env) ids +zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var] +-- "Dictionary" binders can be coercion variables or dictionary variables +zonkDictBndrs env ids = mappM (zonkDictBndr env) ids + +zonkDictBndr env var | isTyVar var = return var + | otherwise = zonkIdBndr env var + zonkTopBndrs :: [TcId] -> TcM [Id] zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids \end{code} @@ -287,7 +309,7 @@ zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, abs_exports = exports, abs_binds = val_binds }) = ASSERT( all isImmutableTyVar tyvars ) - zonkIdBndrs env dicts `thenM` \ new_dicts -> + zonkDictBndrs env dicts `thenM` \ new_dicts -> fixM (\ ~(new_val_binds, _) -> let env1 = extendZonkEnv env new_dicts @@ -305,11 +327,11 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, = zonkIdBndr env global `thenM` \ new_global -> mapM zonk_prag prags `thenM` \ new_prags -> returnM (tyvars, new_global, zonkIdOcc env local, new_prags) - zonk_prag prag@(InlinePrag {}) = return prag - zonk_prag (SpecPrag expr ty ds inl) = do { expr' <- zonkExpr env expr - ; ty' <- zonkTcTypeToType env ty - ; let ds' = zonkIdOccs env ds - ; return (SpecPrag expr' ty' ds' inl) } + zonk_prag prag@(L _ (InlinePrag {})) = return prag + zonk_prag (L loc (SpecPrag expr ty inl)) + = do { expr' <- zonkExpr env expr + ; ty' <- zonkTcTypeToType env ty + ; return (L loc (SpecPrag expr' ty' inl)) } \end{code} %************************************************************************ @@ -459,16 +481,16 @@ zonkExpr env (ExplicitTuple exprs boxed) returnM (ExplicitTuple new_exprs boxed) zonkExpr env (RecordCon data_con con_expr rbinds) - = zonkExpr env con_expr `thenM` \ new_con_expr -> - zonkRbinds env rbinds `thenM` \ new_rbinds -> - returnM (RecordCon data_con new_con_expr new_rbinds) + = do { new_con_expr <- zonkExpr env con_expr + ; new_rbinds <- zonkRecFields env rbinds + ; return (RecordCon data_con new_con_expr new_rbinds) } -zonkExpr env (RecordUpd expr rbinds in_ty out_ty) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkTcTypeToType env in_ty `thenM` \ new_in_ty -> - zonkTcTypeToType env out_ty `thenM` \ new_out_ty -> - zonkRbinds env rbinds `thenM` \ new_rbinds -> - returnM (RecordUpd new_expr new_rbinds new_in_ty new_out_ty) +zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys) + = do { new_expr <- zonkLExpr env expr + ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys + ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys + ; new_rbinds <- zonkRecFields env rbinds + ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) } zonkExpr env (ExprWithTySigOut e ty) = do { e' <- zonkLExpr env e @@ -490,33 +512,15 @@ zonkExpr env (HsSCC lbl expr) = zonkLExpr env expr `thenM` \ new_expr -> returnM (HsSCC lbl new_expr) +zonkExpr env (HsTickPragma info expr) + = zonkLExpr env expr `thenM` \ new_expr -> + returnM (HsTickPragma info new_expr) + -- hdaume: core annotations zonkExpr env (HsCoreAnn lbl expr) = zonkLExpr env expr `thenM` \ new_expr -> returnM (HsCoreAnn lbl new_expr) -zonkExpr env (TyLam tyvars expr) - = ASSERT( all isImmutableTyVar tyvars ) - zonkLExpr env expr `thenM` \ new_expr -> - returnM (TyLam tyvars new_expr) - -zonkExpr env (TyApp expr tys) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkTcTypeToTypes env tys `thenM` \ new_tys -> - returnM (TyApp new_expr new_tys) - -zonkExpr env (DictLam dicts expr) - = zonkIdBndrs env dicts `thenM` \ new_dicts -> - let - env1 = extendZonkEnv env new_dicts - in - zonkLExpr env1 expr `thenM` \ new_expr -> - returnM (DictLam new_dicts new_expr) - -zonkExpr env (DictApp expr dicts) - = zonkLExpr env expr `thenM` \ new_expr -> - returnM (DictApp new_expr (zonkIdOccs env dicts)) - -- arrow notation extensions zonkExpr env (HsProc pat body) = do { (env1, new_pat) <- zonkPat env pat @@ -534,10 +538,10 @@ zonkExpr env (HsArrForm op fixity args) mappM (zonkCmdTop env) args `thenM` \ new_args -> returnM (HsArrForm new_op fixity new_args) -zonkExpr env (HsCoerce co_fn expr) +zonkExpr env (HsWrap co_fn expr) = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) -> zonkExpr env1 expr `thenM` \ new_expr -> - return (HsCoerce new_co_fn new_expr) + return (HsWrap new_co_fn new_expr) zonkExpr env other = pprPanic "zonkExpr" (ppr other) @@ -552,26 +556,24 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids) ------------------------------------------------------------------------- -zonkCoFn :: ZonkEnv -> ExprCoFn -> TcM (ZonkEnv, ExprCoFn) -zonkCoFn env CoHole = return (env, CoHole) -zonkCoFn env (CoCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 +zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) +zonkCoFn env WpHole = return (env, WpHole) +zonkCoFn env WpInline = return (env, WpInline) +zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 - ; return (env2, CoCompose c1' c2') } -zonkCoFn env (CoLams ids c) = do { ids' <- zonkIdBndrs env ids - ; let env1 = extendZonkEnv env ids' - ; (env2, c') <- zonkCoFn env1 c - ; return (env2, CoLams ids' c') } -zonkCoFn env (CoTyLams tvs c) = ASSERT( all isImmutableTyVar tvs ) - do { (env1, c') <- zonkCoFn env c - ; return (env1, CoTyLams tvs c') } -zonkCoFn env (CoApps c ids) = do { (env1, c') <- zonkCoFn env c - ; return (env1, CoApps c' (zonkIdOccs env ids)) } -zonkCoFn env (CoTyApps c tys) = do { tys' <- zonkTcTypeToTypes env tys - ; (env1, c') <- zonkCoFn env c - ; return (env1, CoTyApps c' tys') } -zonkCoFn env (CoLet bs c) = do { (env1, bs') <- zonkRecMonoBinds env bs - ; (env2, c') <- zonkCoFn env1 c - ; return (env2, CoLet bs' c') } + ; return (env2, WpCompose c1' c2') } +zonkCoFn env (WpCo co) = do { co' <- zonkTcTypeToType env co + ; return (env, WpCo co') } +zonkCoFn env (WpLam id) = do { id' <- zonkDictBndr env id + ; let env1 = extendZonkEnv1 env id' + ; return (env1, WpLam id') } +zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) + do { return (env, WpTyLam tv) } +zonkCoFn env (WpApp id) = do { return (env, WpApp (zonkIdOcc env id)) } +zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty + ; return (env, WpTyApp ty') } +zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs + ; return (env1, WpLet bs') } ------------------------------------------------------------------------- @@ -582,10 +584,17 @@ zonkDo env do_or_lc = do_or_lc ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) -zonkOverLit env (HsIntegral i e) - = do { e' <- zonkExpr env e; return (HsIntegral i e') } -zonkOverLit env (HsFractional r e) - = do { e' <- zonkExpr env e; return (HsFractional r e') } +zonkOverLit env ol = + let + zonkedStuff = do ty' <- zonkTcTypeToType env (overLitType ol) + e' <- zonkExpr env (overLitExpr ol) + return (e', ty') + ru f (x, y) = return (f x y) + in + case ol of + (HsIntegral i _ _) -> ru (HsIntegral i) =<< zonkedStuff + (HsFractional r _ _) -> ru (HsFractional r) =<< zonkedStuff + (HsIsString s _ _) -> ru (HsIsString s) =<< zonkedStuff ------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) @@ -652,6 +661,37 @@ zonkStmt env (ExprStmt expr then_op ty) zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (env, ExprStmt new_expr new_then new_ty) +zonkStmt env (TransformStmt (stmts, binders) usingExpr maybeByExpr) + = do { (env', stmts') <- zonkStmts env stmts + ; let binders' = zonkIdOccs env' binders + ; usingExpr' <- zonkLExpr env' usingExpr + ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr + ; return (env', TransformStmt (stmts', binders') usingExpr' maybeByExpr') } + +zonkStmt env (GroupStmt (stmts, binderMap) groupByClause) + = do { (env', stmts') <- zonkStmts env stmts + ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap + ; groupByClause' <- + case groupByClause of + GroupByNothing usingExpr -> (zonkLExpr env' usingExpr) >>= (return . GroupByNothing) + GroupBySomething eitherUsingExpr byExpr -> do + eitherUsingExpr' <- mapEitherM (zonkLExpr env') (zonkExpr env') eitherUsingExpr + byExpr' <- zonkLExpr env' byExpr + return $ GroupBySomething eitherUsingExpr' byExpr' + + ; let env'' = extendZonkEnv env' (map snd binderMap') + ; return (env'', GroupStmt (stmts', binderMap') groupByClause') } + where + mapEitherM f g x = do + case x of + Left a -> f a >>= (return . Left) + Right b -> g b >>= (return . Right) + + zonkBinderMapEntry env (oldBinder, newBinder) = do + let oldBinder' = zonkIdOcc env oldBinder + newBinder' <- zonkIdBndr env newBinder + return (oldBinder', newBinder') + zonkStmt env (LetStmt binds) = zonkLocalBinds env binds `thenM` \ (env1, new_binds) -> returnM (env1, LetStmt new_binds) @@ -663,21 +703,24 @@ zonkStmt env (BindStmt pat expr bind_op fail_op) ; new_fail <- zonkExpr env fail_op ; return (env1, BindStmt new_pat new_expr new_bind new_fail) } +zonkMaybeLExpr env Nothing = return Nothing +zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just) -------------------------------------------------------------------------- -zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id) -zonkRbinds env rbinds - = mappM zonk_rbind rbinds +------------------------------------------------------------------------- +zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) +zonkRecFields env (HsRecFields flds dd) + = do { flds' <- mappM zonk_rbind flds + ; return (HsRecFields flds' dd) } where - zonk_rbind (field, expr) - = zonkLExpr env expr `thenM` \ new_expr -> - returnM (fmap (zonkIdOcc env) field, new_expr) + zonk_rbind fld + = do { new_expr <- zonkLExpr env (hsRecFieldArg fld) + ; return (fld { hsRecFieldArg = new_expr }) } + -- Field selectors have declared types; hence no zonking ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b) -mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r) -mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r) +mapIPNameTc f (IPName n) = f n `thenM` \ r -> returnM (IPName r) \end{code} @@ -724,6 +767,11 @@ zonk_pat env (AsPat (L loc v) pat) ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat ; return (env', AsPat (L loc v') pat') } +zonk_pat env (ViewPat expr pat ty) + = do { expr' <- zonkLExpr env expr + ; (env', pat') <- zonkPat env pat + ; return (env', ViewPat expr' pat' ty) } + zonk_pat env (ListPat pats ty) = do { ty' <- zonkTcTypeToType env ty ; (env', pats') <- zonkPats env pats @@ -739,14 +787,15 @@ zonk_pat env (TuplePat pats boxed ty) ; (env', pats') <- zonkPats env pats ; return (env', TuplePat pats' boxed ty') } -zonk_pat env (ConPatOut n tvs dicts binds stuff ty) - = ASSERT( all isImmutableTyVar tvs ) +zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args }) + = ASSERT( all isImmutableTyVar (pat_tvs p) ) do { new_ty <- zonkTcTypeToType env ty - ; new_dicts <- zonkIdBndrs env dicts + ; new_dicts <- zonkDictBndrs env dicts ; let env1 = extendZonkEnv env new_dicts ; (env2, new_binds) <- zonkRecMonoBinds env1 binds - ; (env', new_stuff) <- zonkConStuff env2 stuff - ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) } + ; (env', new_args) <- zonkConStuff env2 args + ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_dicts, + pat_binds = new_binds, pat_args = new_args }) } zonk_pat env (LitPat lit) = return (env, LitPat lit) @@ -755,15 +804,14 @@ zonk_pat env (SigPatOut pat ty) ; (env', pat') <- zonkPat env pat ; return (env', SigPatOut pat' ty') } -zonk_pat env (NPat lit mb_neg eq_expr ty) +zonk_pat env (NPat lit mb_neg eq_expr) = do { lit' <- zonkOverLit env lit ; mb_neg' <- case mb_neg of Nothing -> return Nothing Just neg -> do { neg' <- zonkExpr env neg ; return (Just neg') } ; eq_expr' <- zonkExpr env eq_expr - ; ty' <- zonkTcTypeToType env ty - ; return (env, NPat lit' mb_neg' eq_expr' ty') } + ; return (env, NPat lit' mb_neg' eq_expr') } zonk_pat env (NPlusKPat (L loc n) lit e1 e2) = do { n' <- zonkIdBndr env n @@ -772,10 +820,13 @@ zonk_pat env (NPlusKPat (L loc n) lit e1 e2) ; e2' <- zonkExpr env e2 ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') } -zonk_pat env (DictPat ds ms) - = do { ds' <- zonkIdBndrs env ds - ; ms' <- zonkIdBndrs env ms - ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') } +zonk_pat env (CoPat co_fn pat ty) + = do { (env', co_fn') <- zonkCoFn env co_fn + ; (env'', pat') <- zonkPat env' (noLoc pat) + ; ty' <- zonkTcTypeToType env'' ty + ; return (env'', CoPat co_fn' (unLoc pat') ty') } + +zonk_pat env pat = pprPanic "zonk_pat" (ppr pat) --------------------------- zonkConStuff env (PrefixCon pats) @@ -787,17 +838,17 @@ zonkConStuff env (InfixCon p1 p2) ; (env', p2') <- zonkPat env1 p2 ; return (env', InfixCon p1' p2') } -zonkConStuff env (RecCon rpats) - = do { (env', pats') <- zonkPats env pats - ; returnM (env', RecCon (fields `zip` pats')) } - where - (fields, pats) = unzip rpats +zonkConStuff env (RecCon (HsRecFields rpats dd)) + = do { (env', pats') <- zonkPats env (map hsRecFieldArg rpats) + ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats' + ; returnM (env', RecCon (HsRecFields rpats' dd)) } + -- Field selectors have declared types; hence no zonking --------------------------- zonkPats env [] = return (env, []) zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat - ; (env', pats') <- zonkPats env1 pats - ; return (env', pat':pats') } + ; (env', pats') <- zonkPats env1 pats + ; return (env', pat':pats') } \end{code} %************************************************************************ @@ -823,7 +874,7 @@ zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id] zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id) -zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs fv_lhs rhs fv_rhs) +zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) = mappM zonk_bndr vars `thenM` \ new_bndrs -> newMutVar emptyVarSet `thenM` \ unbound_tv_set -> let @@ -905,58 +956,76 @@ zonkTypeZapping ty -- mutable tyvar to a fresh immutable one. So the mutable store -- plays the role of an environment. If we come across a mutable -- type variable that isn't so bound, it must be completely free. - zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty } - where - ty = mkArbitraryType tv - - --- When the type checker finds a type variable with no binding, --- which means it can be instantiated with an arbitrary type, it --- usually instantiates it to Void. Eg. --- --- length [] --- ===> --- length Void (Nil Void) --- --- But in really obscure programs, the type variable might have --- a kind other than *, so we need to invent a suitably-kinded type. --- --- This commit uses --- Void for kind * --- List for kind *->* --- Tuple for kind *->...*->* --- --- which deals with most cases. (Previously, it only dealt with --- kind *.) --- --- In the other cases, it just makes up a TyCon with a suitable --- kind. If this gets into an interface file, anyone reading that --- file won't understand it. This is fixable (by making the client --- of the interface file make up a TyCon too) but it is tiresome and --- never happens, so I am leaving it - -mkArbitraryType :: TcTyVar -> Type --- Make up an arbitrary type whose kind is the same as the tyvar. --- We'll use this to instantiate the (unbound) tyvar. -mkArbitraryType tv - | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case - | otherwise = mkTyConApp tycon [] - where - kind = tyVarKind tv - (args,res) = splitKindFunTys kind + zonk_unbound_tyvar tv = do { ty <- mkArbitraryType warn tv + ; writeMetaTyVar tv ty + ; return ty } + where + warn span msg = setSrcSpan span (addWarnTc msg) + - tycon | kind == tyConKind listTyCon -- *->* - = listTyCon -- No tuples this size +{- Note [Strangely-kinded void TyCons] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + See Trac #959 for more examples - | all isLiftedTypeKind args && isLiftedTypeKind res - = tupleTyCon Boxed (length args) -- *-> ... ->*->* +When the type checker finds a type variable with no binding, which +means it can be instantiated with an arbitrary type, it usually +instantiates it to Void. Eg. - | otherwise - = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $ - mkPrimTyCon tc_name kind 0 [] VoidRep + length [] +===> + length Void (Nil Void) + +But in really obscure programs, the type variable might have a kind +other than *, so we need to invent a suitably-kinded type. + +This commit uses + Void for kind * + List for kind *->* + Tuple for kind *->...*->* + +which deals with most cases. (Previously, it only dealt with +kind *.) + +In the other cases, it just makes up a TyCon with a suitable kind. If +this gets into an interface file, anyone reading that file won't +understand it. This is fixable (by making the client of the interface +file make up a TyCon too) but it is tiresome and never happens, so I +am leaving it. + +Meanwhile I have now fixed GHC to emit a civilized warning. + -} + +mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a) -- How to complain + -> TcTyVar + -> TcRnIf g l Type -- Used by desugarer too +-- Make up an arbitrary type whose kind is the same as the tyvar. +-- We'll use this to instantiate the (unbound) tyvar. +-- +-- Also used by the desugarer; hence the (tiresome) parameter +-- to use when generating a warning +mkArbitraryType warn tv + | liftedTypeKind `isSubKind` kind -- The vastly common case + = return anyPrimTy + | eqKind kind (tyConKind anyPrimTyCon1) -- *->* + = return (mkTyConApp anyPrimTyCon1 []) -- No tuples this size + | all isLiftedTypeKind args -- *-> ... ->*->* + , isLiftedTypeKind res -- Horrible hack to make less use + = return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon + | otherwise + = do { warn (getSrcSpan tv) msg + ; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) } -- Same name as the tyvar, apart from making it start with a colon (sigh) -- I dread to think what will happen if this gets out into an -- interface file. Catastrophe likely. Major sigh. - - tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc + where + kind = tyVarKind tv + (args,res) = splitKindFunTys kind + tup_tc = tupleTyCon Boxed (length args) + + msg = vcat [ hang (ptext SLIT("Inventing strangely-kinded Any TyCon")) + 2 (ptext SLIT("of kind") <+> quotes (ppr kind)) + , nest 2 (ptext SLIT("from an instantiation of type variable") <+> quotes (ppr tv)) + , ptext SLIT("This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv) + , nest 2 (ptext SLIT("but is harmless without -O (and usually harmless anyway).")) + , ptext SLIT("See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ] \end{code}