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)
-- 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
+
+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.
- tycon | eqKind kind (tyConKind anyPrimTyCon1) -- *->*
- = anyPrimTyCon1 -- No tuples this size
+ length []
+===>
+ length Void (Nil Void)
- | all isLiftedTypeKind args && isLiftedTypeKind res
- = tupleTyCon Boxed (length args) -- *-> ... ->*->*
- -- Horrible hack to make less use of mkAnyPrimTyCon
+But in really obscure programs, the type variable might have a kind
+other than *, so we need to invent a suitably-kinded type.
- | otherwise
- = mkAnyPrimTyCon (getUnique tv) kind
+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}