X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=5ce40fc0cd06fd9ccdbcc3437543a31e55cad34e;hp=5341a4f2ec4dde6c3117859d2676876bb67c326f;hb=HEAD;hpb=92267aa26adb1ab5a6d8004a80fdf6aa06ea4e44 diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 5341a4f..5ce40fc 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -35,6 +35,7 @@ import TcRnMonad import PrelNames import TcType import TcMType +import Coercion import TysPrim import TysWiredIn import DataCon @@ -43,14 +44,15 @@ import NameSet import Var import VarSet import VarEnv +import DynFlags( DynFlag(..) ) import Literal import BasicTypes import Maybes import SrcLoc -import DynFlags( DynFlag(..) ) import Bag import FastString import Outputable +-- import Data.Traversable( traverse ) \end{code} \begin{code} @@ -82,7 +84,6 @@ hsPatType :: Pat Id -> Type 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 @@ -120,7 +121,7 @@ shortCutLit (HsIntegral i) ty | isIntTy ty && inIntRange i = Just (HsLit (HsInt i)) | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i)) | isIntegerTy ty = Just (HsLit (HsInteger i ty)) - | otherwise = shortCutLit (HsFractional (fromInteger i)) ty + | otherwise = shortCutLit (HsFractional (integralFractionalLit i)) ty -- The 'otherwise' case is important -- Consider (3 :: Float). Syntactically it looks like an IntLit, -- so we'll call shortCutIntLit, but of course it's a float @@ -270,15 +271,16 @@ zonkTopLExpr e = zonkLExpr emptyZonkEnv e zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> NameSet - -> [LRuleDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] - -> TcM ([Id], - Bag EvBind, - Bag (LHsBind Id), - [LForeignDecl Id], - [LTcSpecPrag], - [LRuleDecl Id]) -zonkTopDecls ev_binds binds sig_ns rules imp_specs fords - = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds + -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] + -> TcM ([Id], + Bag EvBind, + Bag (LHsBind Id), + [LForeignDecl Id], + [LTcSpecPrag], + [LRuleDecl Id], + [LVectDecl Id]) +zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords + = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds -- Warn about missing signatures -- Do this only when we we have a type to offer @@ -287,11 +289,12 @@ zonkTopDecls ev_binds binds sig_ns rules imp_specs fords | otherwise = noSigWarn ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds - -- Top level is implicitly recursive - ; rules' <- zonkRules env2 rules + -- Top level is implicitly recursive + ; rules' <- zonkRules env2 rules + ; vects' <- zonkVects env2 vects ; specs' <- zonkLTcSpecPrags env2 imp_specs - ; fords' <- zonkForeignExports env2 fords - ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } + ; fords' <- zonkForeignExports env2 fords + ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') } --------------------------------------------- zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) @@ -543,6 +546,33 @@ zonkExpr env (HsPar e) = zonkLExpr env e `thenM` \new_e -> returnM (HsPar new_e) +zonkExpr env (HsHetMetBrak c e) + = do c' <- zonkTcTypeToType env c + e' <- zonkLExpr env e + return (HsHetMetBrak c' e') + +zonkExpr env (HsHetMetEsc c t e) + = do c' <- zonkTcTypeToType env c + t' <- zonkTcTypeToType env t + e' <- zonkLExpr env e + return (HsHetMetEsc c' t' e') + +zonkExpr env (HsHetMetCSP c e) + = do c' <- zonkTcTypeToType env c + e' <- zonkLExpr env e + return (HsHetMetCSP c' e') + +zonkExpr env (HsKappa matches) + = do { matches' <- zonkMatchGroup env matches + ; returnM (HsKappa matches') + } + +zonkExpr env (HsKappaApp e1 e2) + = do { e1' <- zonkLExpr env e1 + ; e2' <- zonkLExpr env e2 + ; returnM (HsKappaApp e1' e2') + } + zonkExpr env (SectionL expr op) = zonkLExpr env expr `thenM` \ new_expr -> zonkLExpr env op `thenM` \ new_op -> @@ -565,23 +595,22 @@ zonkExpr env (HsCase expr ms) zonkMatchGroup env ms `thenM` \ new_ms -> returnM (HsCase new_expr new_ms) -zonkExpr env (HsIf e1 e2 e3) - = zonkLExpr env e1 `thenM` \ new_e1 -> - zonkLExpr env e2 `thenM` \ new_e2 -> - zonkLExpr env e3 `thenM` \ new_e3 -> - returnM (HsIf new_e1 new_e2 new_e3) +zonkExpr env (HsIf e0 e1 e2 e3) + = do { new_e0 <- fmapMaybeM (zonkExpr env) e0 + ; new_e1 <- zonkLExpr env e1 + ; new_e2 <- zonkLExpr env e2 + ; new_e3 <- zonkLExpr env e3 + ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) } zonkExpr env (HsLet binds expr) = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> zonkLExpr new_env expr `thenM` \ new_expr -> returnM (HsLet new_binds new_expr) -zonkExpr env (HsDo do_or_lc stmts body ty) - = zonkStmts env stmts `thenM` \ (new_env, new_stmts) -> - zonkLExpr new_env body `thenM` \ new_body -> +zonkExpr env (HsDo do_or_lc stmts ty) + = zonkStmts env stmts `thenM` \ (_, new_stmts) -> zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkDo env do_or_lc `thenM` \ new_do_or_lc -> - returnM (HsDo new_do_or_lc new_stmts new_body new_ty) + returnM (HsDo do_or_lc new_stmts new_ty) zonkExpr env (ExplicitList ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> @@ -675,7 +704,7 @@ zonkCoFn env WpHole = return (env, WpHole) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co +zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co ; return (env, WpCast co') } zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev ; return (env', WpEvLam ev') } @@ -689,13 +718,6 @@ zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs ; return (env1, WpLet bs') } ------------------------------------------------------------------------- -zonkDo :: ZonkEnv -> HsStmtContext Name -> TcM (HsStmtContext Name) --- Only used for 'do', so the only Ids are in a MDoExpr table -zonkDo env (MDoExpr tbl) = do { tbl' <- mapSndM (zonkExpr env) tbl - ; return (MDoExpr tbl') } -zonkDo _ do_or_lc = return do_or_lc - -------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty }) = do { ty' <- zonkTcTypeToType env ty @@ -734,22 +756,26 @@ zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s ; return (env2, s' : ss') } zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id) -zonkStmt env (ParStmt stmts_w_bndrs) +zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op) = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs -> let new_binders = concat (map snd new_stmts_w_bndrs) env1 = extendZonkEnv env new_binders in - return (env1, ParStmt new_stmts_w_bndrs) + zonkExpr env1 mzip_op `thenM` \ new_mzip -> + zonkExpr env1 bind_op `thenM` \ new_bind -> + zonkExpr env1 return_op `thenM` \ new_return -> + return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind new_return) where zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) -> returnM (new_stmts, zonkIdOccs env1 bndrs) zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id - , recS_rec_rets = rets, recS_dicts = binds }) + , recS_rec_rets = rets, recS_ret_ty = ret_ty }) = do { new_rvs <- zonkIdBndrs env rvs ; new_lvs <- zonkIdBndrs env lvs + ; new_ret_ty <- zonkTcTypeToType env ret_ty ; new_ret_id <- zonkExpr env ret_id ; new_mfix_id <- zonkExpr env mfix_id ; new_bind_id <- zonkExpr env bind_id @@ -758,34 +784,38 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt ; new_rets <- mapM (zonkExpr env2) rets - ; let env3 = extendZonkEnv env new_lvs -- Only the lvs are needed - ; (env4, new_binds) <- zonkTcEvBinds env3 binds - ; return (env4, + ; return (extendZonkEnv env new_lvs, -- Only the lvs are needed RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_rec_rets = new_rets, recS_dicts = new_binds }) } + , recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) } -zonkStmt env (ExprStmt expr then_op ty) +zonkStmt env (ExprStmt expr then_op guard_op ty) = zonkLExpr env expr `thenM` \ new_expr -> zonkExpr env then_op `thenM` \ new_then -> + zonkExpr env guard_op `thenM` \ new_guard -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (env, ExprStmt new_expr new_then new_ty) + returnM (env, ExprStmt new_expr new_then new_guard 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 by using) +zonkStmt env (LastStmt expr ret_op) + = zonkLExpr env expr `thenM` \ new_expr -> + zonkExpr env ret_op `thenM` \ new_ret -> + returnM (env, LastStmt new_expr new_ret) + +zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op }) = do { (env', stmts') <- zonkStmts env stmts ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap - ; by' <- fmapMaybeM (zonkLExpr env') by - ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using + ; by' <- fmapMaybeM (zonkLExpr env') by + ; using' <- zonkLExpr env using + ; return_op' <- zonkExpr env' return_op + ; bind_op' <- zonkExpr env' bind_op + ; liftM_op' <- zonkExpr env' liftM_op ; let env'' = extendZonkEnv env' (map snd binderMap') - ; return (env'', GroupStmt stmts' binderMap' by' using') } + ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' + , trS_by = by', trS_form = form, trS_using = using' + , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) } where zonkBinderMapEntry env (oldBinder, newBinder) = do let oldBinder' = zonkIdOcc env oldBinder @@ -803,11 +833,6 @@ zonkStmt env (BindStmt pat expr bind_op fail_op) ; new_fail <- zonkExpr env fail_op ; return (env1, BindStmt new_pat new_expr new_bind new_fail) } -zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id)) -zonkMaybeLExpr _ Nothing = return Nothing -zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just) - - ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) zonkRecFields env (HsRecFields flds dd) @@ -851,11 +876,6 @@ zonk_pat env (VarPat v) = do { v' <- zonkIdBndr env v ; return (extendZonkEnv1 env v', VarPat v') } -zonk_pat env (VarPatOut v binds) - = do { v' <- zonkIdBndr env v - ; (env', binds') <- zonkTcEvBinds (extendZonkEnv1 env v') binds - ; returnM (env', VarPatOut v' binds') } - zonk_pat env (LazyPat pat) = do { (env', pat') <- zonkPat env pat ; return (env', LazyPat pat') } @@ -908,10 +928,7 @@ zonk_pat env (SigPatOut pat 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') } + ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg ; eq_expr' <- zonkExpr env eq_expr ; return (env, NPat lit' mb_neg' eq_expr') } @@ -1020,10 +1037,28 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) zonk_it env v | isId v = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') } - | isCoVar v = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') } | otherwise = ASSERT( isImmutableTyVar v) return (env, v) \end{code} +\begin{code} +zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id] +zonkVects env = mappM (wrapLocM (zonkVect env)) + +zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id) +zonkVect env (HsVect v Nothing) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; return $ HsVect v' Nothing + } +zonkVect env (HsVect v (Just e)) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; e' <- zonkLExpr env e + ; return $ HsVect v' (Just e') + } +zonkVect env (HsNoVect v) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; return $ HsNoVect v' + } +\end{code} %************************************************************************ %* * @@ -1035,13 +1070,13 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) return (EvId (zonkIdOcc env v)) -zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcTypeToType env co +zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co ; return (EvCoercion co') } zonkEvTerm env (EvCast v co) = ASSERT( isId v) - do { co' <- zonkTcTypeToType env co + do { co' <- zonkTcCoToCo env co ; return (EvCast (zonkIdOcc env v) co') } zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) -zonkEvTerm env (EvDFunApp df tys tms) +zonkEvTerm env (EvDFunApp df tys tms) = do { tys' <- zonkTcTypeToTypes env tys ; let tms' = map (zonkEvVarOcc env) tms ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } @@ -1076,7 +1111,7 @@ zonkEvBind env (EvBind var term) %************************************************************************ %* * -\subsection[BackSubst-Foreign]{Foreign exports} + Zonking types %* * %************************************************************************ @@ -1093,7 +1128,7 @@ zonkTypeCollecting unbound_tv_set = zonkType (mkZonkTcTyVar zonk_unbound_tyvar) where zonk_unbound_tyvar tv - = do { tv' <- zonkQuantifiedTyVar tv + = do { tv' <- zonkQuantifiedTyVar tv ; tv_set <- readMutVar unbound_tv_set ; writeMutVar unbound_tv_set (extendVarSet tv_set tv') ; return (mkTyVarTy tv') } @@ -1113,4 +1148,27 @@ zonkTypeZapping ty zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } -\end{code} \ No newline at end of file + +zonkTcCoToCo :: ZonkEnv -> Coercion -> TcM Coercion +zonkTcCoToCo env co + = go co + where + go (CoVarCo cv) = return (CoVarCo (zonkEvVarOcc env cv)) + go (Refl ty) = do { ty' <- zonkTcTypeToType env ty + ; return (Refl ty') } + go (TyConAppCo tc cos) = do { cos' <- mapM go cos; return (mkTyConAppCo tc cos') } + go (AxiomInstCo ax cos) = do { cos' <- mapM go cos; return (AxiomInstCo ax cos') } + go (AppCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkAppCo co1' co2') } + go (UnsafeCo t1 t2) = do { t1' <- zonkTcTypeToType env t1 + ; t2' <- zonkTcTypeToType env t2 + ; return (mkUnsafeCo t1' t2') } + go (SymCo co) = do { co' <- go co; return (mkSymCo co') } + go (NthCo n co) = do { co' <- go co; return (mkNthCo n co') } + go (TransCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkTransCo co1' co2') } + go (InstCo co ty) = do { co' <- go co; ty' <- zonkTcTypeToType env ty + ; return (mkInstCo co' ty') } + go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv ) + do { co' <- go co; return (mkForAllCo tv co') } +\end{code}