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 (
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
import TcRnMonad
import Type
import TcType
-import qualified Type
import TcMType
import TysPrim
import TysWiredIn
import TyCon
-import {- Kind parts of -} Type
import Name
import Var
import VarSet
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}
+
%************************************************************************
%* *
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 _ _ ty) = ty
+hsPatType (NPat lit _ _) = overLitType lit
hsPatType (NPlusKPat id _ _ _) = idType (unLoc id)
hsPatType (CoPat _ _ ty) = ty
-hsPatType (DictPat ds ms) = case (ds ++ ms) of
- [] -> unitTy
- [d] -> idType d
- ds -> mkTupleTy Boxed (length ds) (map idType ds)
-
hsLitType :: HsLit -> TcType
hsLitType (HsChar c) = charTy
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
= 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}
%************************************************************************
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
= 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 ->
-------------------------------------------------------------------------
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 )
-------------------------------------------------------------------------
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)
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)
--------------------------------------------------------------------------
-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)
; (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
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
; (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
; 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)
; (env', p2') <- zonkPat env1 p2
; return (env', InfixCon p1' p2') }
-zonkConStuff env (RecCon rpats)
- = do { let (fields, pats) = unzip [ (f, p) | HsRecField f p _ <- rpats ]
- ; (env', pats') <- zonkPats env pats
- ; let recCon = RecCon [ mkRecField f p | (f, p) <- zip fields pats' ]
- ; returnM (env', recCon) }
+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, [])
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
+
+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}
projects / ghc-hetmet.git / blobdiff