%
+% (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}
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,
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 Type
+import TcType
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 TcMType
+import TysPrim
+import TysWiredIn
+import TyCon
+import {- Kind parts of -} Type
+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}
%* *
%************************************************************************
-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
+ = 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 (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 (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)
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.
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
abs_exports = new_exports, abs_binds = new_val_bind })
where
zonkExport env (tyvars, global, local, prags)
+ -- The tyvars are already zonked
= zonkIdBndr env global `thenM` \ new_global ->
mapM zonk_prag prags `thenM` \ new_prags ->
returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
= 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
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)
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 (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' <- zonkIdBndr 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') }
-------------------------------------------------------------------------
= 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 (HsIsString s e)
+ = do { e' <- zonkExpr env e; return (HsIsString s e') }
-------------------------------------------------------------------------
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
-------------------------------------------------------------------------
zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
-zonkRbinds env rbinds
- = mappM zonk_rbind rbinds
+zonkRbinds env (HsRecordBinds rbinds)
+ = mappM zonk_rbind rbinds >>= return . HsRecordBinds
where
zonk_rbind (field, expr)
= zonkLExpr env expr `thenM` \ new_expr ->
-------------------------------------------------------------------------
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}
; (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
; 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)
; 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)
= do { (env', pats') <- zonkPats env pats
; 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
+ = 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) }
---------------------------
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}
%************************************************************************
zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
-zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
- returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
+zonkForeignExport env (ForeignExport i hs_ty spec) =
+ returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
zonkForeignExport env for_imp
= returnM for_imp -- Foreign imports don't need zonking
\end{code}
-- 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
+ | liftedTypeKind `isSubKind` kind = anyPrimTy -- The vastly common case
| otherwise = mkTyConApp tycon []
where
kind = tyVarKind tv
(args,res) = splitKindFunTys kind
- tycon | kind == tyConKind listTyCon -- *->*
- = listTyCon -- No tuples this size
+ tycon | eqKind kind (tyConKind anyPrimTyCon1) -- *->*
+ = anyPrimTyCon1 -- No tuples this size
| all isLiftedTypeKind args && isLiftedTypeKind res
= tupleTyCon Boxed (length args) -- *-> ... ->*->*
+ -- Horrible hack to make less use of mkAnyPrimTyCon
| otherwise
- = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
- mkPrimTyCon tc_name kind 0 [] VoidRep
+ = 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
\end{code}
projects / ghc-hetmet.git / blobdiff