X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=8b907d212c8f00a37641deffea2345fd30c53b07;hp=22367404071302cb552290c41cb5c0c225882ee7;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=fdf8656855d26105ff36bdd24d41827b05037b91 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 2236740..8b907d2 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -42,9 +42,11 @@ import DataCon import Name import TyCon import Type +import TypeRep import Coercion import Var import VarSet +import VarEnv import TysWiredIn import TysPrim( intPrimTy ) import PrimOp( tagToEnumKey ) @@ -55,6 +57,7 @@ import SrcLoc import Util import ListSetOps import Maybes +import ErrUtils import Outputable import FastString import Control.Monad @@ -137,17 +140,68 @@ tcInfExpr e = tcInfer (tcExpr e) %************************************************************************ \begin{code} + +updHetMetLevel :: ([TyVar] -> [TyVar]) -> TcM a -> TcM a +updHetMetLevel f comp = + updEnv + (\oldenv -> let oldlev = (case oldenv of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x) + in (oldenv { env_lcl = (env_lcl oldenv) { tcl_hetMetLevel = f oldlev } })) + + comp + +addEscapes :: [TyVar] -> HsExpr Name -> HsExpr Name +addEscapes [] e = e +addEscapes (t:ts) e = HsHetMetEsc (TyVarTy t) placeHolderType (noLoc (addEscapes ts e)) + +getIdLevel :: Name -> TcM [TyVar] +getIdLevel name + = do { thing <- tcLookup name + ; case thing of + ATcId { tct_hetMetLevel = variable_hetMetLevel } -> return $ variable_hetMetLevel + _ -> return [] + } + tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId) tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e) tcExpr (HsVar name) res_ty = tcCheckId name res_ty -tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty +tcExpr (HsHetMetBrak _ e) res_ty = + do { (coi, [inferred_name,elt_ty]) <- matchExpectedTyConApp hetMetCodeTypeTyCon res_ty + ; fresh_ec_name <- newFlexiTyVar ecKind + ; expr' <- updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev)) + $ tcPolyExpr e elt_ty + ; unifyType (TyVarTy fresh_ec_name) inferred_name + ; return $ mkHsWrapCoI coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') } +tcExpr (HsHetMetEsc _ _ e) res_ty = + do { cur_level <- getHetMetLevel + ; expr' <- updHetMetLevel (\old_lev -> tail old_lev) + $ tcExpr (unLoc e) (mkTyConApp hetMetCodeTypeTyCon [(TyVarTy $ head cur_level),res_ty]) + ; ty' <- zonkTcType res_ty + ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr')) } +tcExpr (HsHetMetCSP _ e) res_ty = + do { cur_level <- getHetMetLevel + ; expr' <- updHetMetLevel (\old_lev -> tail old_lev) + $ tcExpr (unLoc e) res_ty + ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr')) } -tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit - ; tcWrapResult (HsLit lit) lit_ty res_ty } +tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty +tcExpr (HsLit lit) res_ty = + getHetMetLevel >>= \lev -> + case lev of + [] -> do { let lit_ty = hsLitType lit + ; tcWrapResult (HsLit lit) lit_ty res_ty } + (ec:rest) -> let n = case lit of + (HsChar c) -> hetmet_guest_char_literal_name + (HsString str) -> hetmet_guest_string_literal_name + (HsInteger i _) -> hetmet_guest_integer_literal_name + (HsInt i) -> hetmet_guest_integer_literal_name + _ -> error "literals of this sort are not allowed at depth >0" + in tcExpr (HsHetMetEsc (TyVarTy ec) placeHolderType $ noLoc $ + (HsApp (noLoc $ HsVar n) (noLoc $ HsLit lit))) res_ty + tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty ; return (HsPar expr') } @@ -163,9 +217,18 @@ tcExpr (HsCoreAnn lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty ; return (HsCoreAnn lbl expr') } -tcExpr (HsOverLit lit) res_ty - = do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty - ; return (HsOverLit lit') } +tcExpr (HsOverLit lit) res_ty = + getHetMetLevel >>= \lev -> + case lev of + [] -> do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty + ; return (HsOverLit lit') } + (ec:rest) -> let n = case lit of + (OverLit { ol_val = HsIntegral i }) -> hetmet_guest_integer_literal_name + (OverLit { ol_val = HsIsString fs }) -> hetmet_guest_string_literal_name + (OverLit { ol_val = HsFractional f }) -> error "fractional literals not allowed at depth >0" + in tcExpr (HsHetMetEsc (TyVarTy ec) placeHolderType $ noLoc $ + (HsApp (noLoc $ HsVar n) (noLoc $ HsOverLit lit))) res_ty + tcExpr (NegApp expr neg_expr) res_ty = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr @@ -415,8 +478,8 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if] -- and it maintains uniformity with other rebindable syntax ; return (HsIf (Just fun') pred' b1' b2') } -tcExpr (HsDo do_or_lc stmts body _) res_ty - = tcDoStmts do_or_lc stmts body res_ty +tcExpr (HsDo do_or_lc stmts _) res_ty + = tcDoStmts do_or_lc stmts res_ty tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty @@ -820,7 +883,7 @@ tcApp fun args res_ty -- Typecheck the result, thereby propagating -- info (if any) from result into the argument types -- Both actual_res_ty and res_ty are deeply skolemised - ; co_res <- addErrCtxt (funResCtxt fun) $ + ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $ unifyType actual_res_ty res_ty -- Typecheck the arguments @@ -961,24 +1024,40 @@ tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType) -- Look up an occurrence of an Id, and instantiate it (deeply) -tcInferIdWithOrig orig id_name - = do { id <- lookup_id - ; (id_expr, id_rho) <- instantiateOuter orig id - ; (wrap, rho) <- deeplyInstantiate orig id_rho - ; return (mkHsWrap wrap id_expr, rho) } +tcInferIdWithOrig orig id_name = + do { id_level <- getIdLevel id_name + ; cur_level <- getHetMetLevel + ; if (length id_level < length cur_level) + then do { (lhexp, tcrho) <- + tcInferRho (noLoc $ addEscapes (take ((length cur_level) - (length id_level)) cur_level) (HsVar id_name)) + ; return (unLoc lhexp, tcrho) + } + else tcInferIdWithOrig' orig id_name + } + +tcInferIdWithOrig' orig id_name = + do { id <- lookup_id + ; (id_expr, id_rho) <- instantiateOuter orig id + ; (wrap, rho) <- deeplyInstantiate orig id_rho + ; return (mkHsWrap wrap id_expr, rho) } where lookup_id :: TcM TcId lookup_id = do { thing <- tcLookup id_name ; case thing of - ATcId { tct_id = id, tct_level = lvl } + ATcId { tct_id = id, tct_level = lvl, tct_hetMetLevel = variable_hetMetLevel } -> do { check_naughty id -- Note [Local record selectors] ; checkThLocalId id lvl + ; current_hetMetLevel <- getHetMetLevel + ; mapM + (\(name1,name2) -> unifyType (TyVarTy name1) (TyVarTy name2)) + (zip variable_hetMetLevel current_hetMetLevel) ; return id } AGlobal (AnId id) - -> do { check_naughty id; return id } - -- A global cannot possibly be ill-staged + -> do { check_naughty id + ; return id } + -- A global cannot possibly be ill-staged in Template Haskell -- nor does it need the 'lifting' treatment -- hence no checkTh stuff here @@ -1386,9 +1465,23 @@ funAppCtxt fun arg arg_no quotes (ppr fun) <> text ", namely"]) 2 (quotes (ppr arg)) -funResCtxt :: LHsExpr Name -> SDoc -funResCtxt fun - = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun) +funResCtxt :: LHsExpr Name -> TcType -> TcType + -> TidyEnv -> TcM (TidyEnv, Message) +-- When we have a mis-match in the return type of a function +-- try to give a helpful message about too many/few arguments +funResCtxt fun fun_res_ty res_ty env0 + = do { fun_res' <- zonkTcType fun_res_ty + ; res' <- zonkTcType res_ty + ; let n_fun = length (fst (tcSplitFunTys fun_res')) + n_res = length (fst (tcSplitFunTys res')) + what | n_fun > n_res = ptext (sLit "few") + | otherwise = ptext (sLit "many") + extra | n_fun == n_res = empty + | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun) + <+> ptext (sLit "is applied to too") <+> what + <+> ptext (sLit "arguments") + msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun) + ; return (env0, msg $$ extra) } badFieldTypes :: [(Name,TcType)] -> SDoc badFieldTypes prs