X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=c6d428b307cd0b70fe83f8f2b3a68ec1ba3a2bb4;hp=47231fb0a65d57b32b82fc6cf1e9f82f8bd82142;hb=102b73a3f2a2f63d3835726be625dca8053dd88c;hpb=5dc9a4504ea4d3df462081a7dbfde0431eac133e diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 47231fb..c6d428b 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1,18 +1,21 @@ % +% (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, @@ -27,31 +30,26 @@ 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 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} @@ -63,33 +61,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 + = 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) @@ -120,7 +119,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,7 +188,7 @@ 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 @@ -490,33 +489,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 +515,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 +533,23 @@ 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 (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') } ------------------------------------------------------------------------- @@ -586,6 +564,8 @@ 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 (HsIsString s e) + = do { e' <- zonkExpr env e; return (HsIsString s e') } ------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) @@ -667,8 +647,8 @@ zonkStmt env (BindStmt pat expr bind_op fail_op) ------------------------------------------------------------------------- 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 -> @@ -676,8 +656,7 @@ zonkRbinds env rbinds ------------------------------------------------------------------------- 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} @@ -739,14 +718,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 ; 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) @@ -796,16 +776,16 @@ zonkConStuff env (InfixCon p1 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 + = 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} %************************************************************************ @@ -947,24 +927,22 @@ 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 + | 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}