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}
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
-------------------------------------------------------------------------
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
-zonkCoFn env WpHole = return (env, WpHole)
+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, WpCompose c1' c2') }
zonkCoFn env (WpCo co) = do { co' <- zonkTcTypeToType env co
; return (env, WpCo co') }
-zonkCoFn env (WpLam id) = do { id' <- zonkIdBndr env id
+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 )
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)
; 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)
+
-------------------------------------------------------------------------
zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
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_args) <- zonkConStuff env2 args
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
-- 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 = anyPrimTy -- 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)
+
+
+{- Note [Strangely-kinded void TyCons]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ See Trac #959 for more examples
- tycon | eqKind kind (tyConKind anyPrimTyCon1) -- *->*
- = anyPrimTyCon1 -- No tuples this size
+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.
- | all isLiftedTypeKind args && isLiftedTypeKind res
- = tupleTyCon Boxed (length args) -- *-> ... ->*->*
- -- Horrible hack to make less use of mkAnyPrimTyCon
+ length []
+===>
+ length Void (Nil Void)
- | otherwise
- = mkAnyPrimTyCon (getUnique tv) kind
+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.
+ 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}
projects / ghc-hetmet.git / blobdiff