Commit 872f7e82 authored by ross's avatar ross

[project @ 2005-04-16 16:05:52 by ross]

Rejig handling of environments in arrow notation: instead of the
proc_level stuff, we just record the environment of the proc, and
use that on the left side of -< and the head of (|...|).

This also makes the arrow1 test yield a compile error, as it should,
but the error message is uninformative.
parent 7ffe2d88
......@@ -54,9 +54,9 @@ tcProc pat cmd exp_ty
; [arg_ty, res_ty] <- newTyFlexiVarTys 2 liftedTypeKind
; zapExpectedTo exp_ty (mkAppTys arr_ty [arg_ty,res_ty])
; let cmd_env = CmdEnv { cmd_arr = arr_ty }
; ([pat'], cmd') <- incProcLevel $
tcMatchPats [pat] [Check arg_ty] (Check res_ty) $
; proc_env <- getEnv
; let cmd_env = CmdEnv { cmd_arr = arr_ty, cmd_proc_env = proc_env }
; ([pat'], cmd') <- tcMatchPats [pat] [Check arg_ty] (Check res_ty) $
tcCmdTop cmd_env cmd ([], res_ty)
-- The False says don't do GADT type refinement
-- This is a conservative choice, but I'm not sure of the consequences
......@@ -72,13 +72,36 @@ tcProc pat cmd exp_ty
%* *
%************************************************************************
In arrow notation, a variable bound by a proc (or enclosed let/kappa)
is not in scope to the left of an arrow tail (-<) or the head of (|..|).
For example
proc x -> (e1 -< e2)
Here, x is not in scope in e1, but it is in scope in e2. This can get
a bit complicated:
let x = 3 in
proc y -> (proc z -> e1) -< e2
Here, x and z are in scope in e1, but y is not. We implement this by
recording the environment when passing a proc, and returning to that
(using popArrowBinders) on the left of -< and the head of (|..|).
\begin{code}
type CmdStack = [TcTauType]
data CmdEnv = CmdEnv { cmd_arr :: TcType } -- The arrow type constructor, of kind *->*->*
data CmdEnv
= CmdEnv {
cmd_arr :: TcType, -- arrow type constructor, of kind *->*->*
cmd_proc_env :: Env TcGblEnv TcLclEnv -- environment of the proc
}
mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
popArrowBinders :: CmdEnv -> TcM a -> TcM a
popArrowBinders env tc = setEnv (cmd_proc_env env) tc
---------------------------------------
tcCmdTop :: CmdEnv
-> LHsCmdTop Name
......@@ -154,7 +177,7 @@ tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
-- inside f. In the higher-order case (-<<), they are.
pop_arrow_binders tc = case ho_app of
HsHigherOrderApp -> tc
HsFirstOrderApp -> popArrowBinders tc
HsFirstOrderApp -> popArrowBinders env tc
-------------------------------------------
-- Command application
......@@ -250,7 +273,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
e_res_ty
-- Check expr
; (expr', lie) <- popArrowBinders (getLIE (tcCheckRho expr e_ty))
; (expr', lie) <- popArrowBinders env (getLIE (tcCheckRho expr e_ty))
; inst_binds <- tcSimplifyCheck sig_msg [w_tv] [] lie
-- Check that the polymorphic variable hasn't been unified with anything
......@@ -289,7 +312,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
(badFormFun i tup_ty')
; tcCmdTop (CmdEnv { cmd_arr = b }) cmd (arg_tys, s) }
; tcCmdTop (env { cmd_arr = b }) cmd (arg_tys, s) }
unscramble :: TcType -> (TcType, [TcType])
-- unscramble ((w,s1) .. sn) = (w, [s1..sn])
......
......@@ -36,9 +36,6 @@ module TcEnv(
checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
topIdLvl,
-- Arrow stuff
checkProcLevel,
-- New Ids
newLocalName, newDFunName
) where
......@@ -210,7 +207,7 @@ tcLookupId :: Name -> TcM Id
tcLookupId name
= tcLookup name `thenM` \ thing ->
case thing of
ATcId tc_id _ _ -> returnM tc_id
ATcId tc_id _ -> returnM tc_id
AGlobal (AnId id) -> returnM id
other -> pprPanic "tcLookupId" (ppr name)
......@@ -223,8 +220,8 @@ tcLookupLocalIds ns
where
lookup lenv lvl name
= case lookupNameEnv lenv name of
Just (ATcId id lvl1 _) -> ASSERT( lvl == lvl1 ) id
other -> pprPanic "tcLookupLocalIds" (ppr name)
Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
other -> pprPanic "tcLookupLocalIds" (ppr name)
lclEnvElts :: TcLclEnv -> [TcTyThing]
lclEnvElts env = nameEnvElts (tcl_env env)
......@@ -291,8 +288,7 @@ tcExtendIdEnv2 names_w_ids thing_inside
let
extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
th_lvl = thLevel (tcl_th_ctxt env)
proc_lvl = proc_level (tcl_arrow_ctxt env)
extra_env = [(name, ATcId id th_lvl proc_lvl) | (name,id) <- names_w_ids]
extra_env = [(name, ATcId id th_lvl) | (name,id) <- names_w_ids]
le' = extendNameEnvList (tcl_env env) extra_env
rdr_env' = extendLocalRdrEnv (tcl_rdr env) (map fst names_w_ids)
in
......@@ -326,7 +322,7 @@ findGlobals tvs tidy_env
ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
-----------------------
find_thing ignore_it tidy_env (ATcId id _ _)
find_thing ignore_it tidy_env (ATcId id _)
= zonkTcType (idType id) `thenM` \ id_ty ->
if ignore_it id_ty then
returnM (tidy_env, Nothing)
......@@ -404,25 +400,6 @@ tcExtendRules lcl_rules thing_inside
\end{code}
%************************************************************************
%* *
Arrow notation proc levels
%* *
%************************************************************************
\begin{code}
checkProcLevel :: TcId -> ProcLevel -> TcM ()
checkProcLevel id id_lvl
= do { banned <- getBannedProcLevels
; checkTc (not (id_lvl `elem` banned))
(procLevelErr id id_lvl) }
procLevelErr id id_lvl
= hang (ptext SLIT("Command-bound variable") <+> quotes (ppr id) <+> ptext SLIT("is not in scope here"))
4 (ptext SLIT("Reason: it is used in the left argument of (-<)"))
\end{code}
%************************************************************************
%* *
Meta level
......
......@@ -32,7 +32,7 @@ import BasicTypes ( isMarkedStrict )
import Inst ( tcOverloadedLit, newMethodFromName, newIPDict,
newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookup, tcLookupId, checkProcLevel,
import TcEnv ( tcLookup, tcLookupId,
tcLookupDataCon, tcLookupGlobalId
)
import TcArrows ( tcProc )
......@@ -787,9 +787,7 @@ tcId orig id_name -- Look up the Id and instantiate its type
-- A global cannot possibly be ill-staged
-- nor does it need the 'lifting' treatment
; ATcId id th_level proc_level
-> do { checkProcLevel id proc_level
; tc_local_id id th_level }
; ATcId id th_level -> tc_local_id id th_level
; other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
}
......
......@@ -106,7 +106,6 @@ initTc hsc_env hsc_src mod do_this
tcl_ctxt = [],
tcl_rdr = emptyLocalRdrEnv,
tcl_th_ctxt = topStage,
tcl_arrow_ctxt = topArrowCtxt,
tcl_env = emptyNameEnv,
tcl_tyvars = tvs_var,
tcl_lie = panic "initTc:LIE", -- LIE only valid inside a getLIE
......@@ -782,33 +781,6 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
\end{code}
%************************************************************************
%* *
Arrow context
%* *
%************************************************************************
\begin{code}
popArrowBinders :: TcM a -> TcM a -- Move to the left of a (-<); see comments in TcRnTypes
popArrowBinders
= updLclEnv (\ env -> env { tcl_arrow_ctxt = pop (tcl_arrow_ctxt env) })
where
pop (ArrCtxt {proc_level = curr_lvl, proc_banned = banned})
= ASSERT( not (curr_lvl `elem` banned) )
ArrCtxt {proc_level = curr_lvl + 1, proc_banned = curr_lvl : banned}
getBannedProcLevels :: TcM [ProcLevel]
getBannedProcLevels
= do { env <- getLclEnv; return (proc_banned (tcl_arrow_ctxt env)) }
incProcLevel :: TcM a -> TcM a
incProcLevel
= updLclEnv (\ env -> env { tcl_arrow_ctxt = inc (tcl_arrow_ctxt env) })
where
inc ctxt = ctxt { proc_level = proc_level ctxt + 1 }
\end{code}
%************************************************************************
%* *
Stuff for the renamer's local env
......
......@@ -26,9 +26,6 @@ module TcRnTypes(
ThStage(..), topStage, topSpliceStage,
ThLevel, impLevel, topLevel,
-- Arrows
ArrowCtxt(..), topArrowCtxt, ProcLevel, topProcLevel,
-- Insts
Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc,
instLocSrcLoc, instLocSrcSpan,
......@@ -278,7 +275,6 @@ data TcLclEnv -- Changes as we move inside an expression
tcl_errs :: TcRef Messages, -- Place to accumulate errors
tcl_th_ctxt :: ThStage, -- Template Haskell context
tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context
tcl_rdr :: LocalRdrEnv, -- Local name envt
-- Maintained during renaming, of course, but also during
......@@ -356,42 +352,6 @@ topStage = Comp
topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level splice
---------------------------
-- Arrow-notation stages
---------------------------
-- In arrow notation, a variable bound by a proc (or enclosed let/kappa)
-- is not in scope to the left of an arrow tail (-<) or the head of (|..|).
-- For example
--
-- proc x -> (e1 -< e2)
--
-- Here, x is not in scope in e1, but it is in scope in e2. This can get
-- a bit complicated:
--
-- let x = 3 in
-- proc y -> (proc z -> e1) -< e2
--
-- Here, x and z are in scope in e1, but y is not. Here's how we track this:
-- a) Assign an "proc level" to each proc, being the number of
-- lexically-enclosing procs + 1.
-- b) Assign to each local variable the proc-level of its lexically
-- enclosing proc.
-- c) Keep a list of out-of-scope procs. When moving to the left of
-- an arrow-tail, add the proc-level of the immediately enclosing
-- proc to the list, and increment the proc-level so that variables
-- bound inside the expression are in scope.
-- d) When looking up a variable, complain if its proc-level is in
-- the banned list
type ProcLevel = Int -- Always >= 0
topProcLevel = 0 -- Not inside any proc
data ArrowCtxt = ArrCtxt { proc_level :: ProcLevel, -- Current level
proc_banned :: [ProcLevel] } -- Out of scope proc-levels
topArrowCtxt = ArrCtxt { proc_level = topProcLevel, proc_banned = [] }
---------------------------
-- TcTyThing
---------------------------
......@@ -399,7 +359,7 @@ topArrowCtxt = ArrCtxt { proc_level = topProcLevel, proc_banned = [] }
data TcTyThing
= AGlobal TyThing -- Used only in the return type of a lookup
| ATcId TcId ThLevel ProcLevel -- Ids defined in this module; may not be fully zonked
| ATcId TcId ThLevel -- Ids defined in this module; may not be fully zonked
| ATyVar Name TcType -- Type variables; tv -> type. It can't just be a TyVar
-- that is mutated to point to the type it is bound to,
......@@ -412,15 +372,15 @@ data TcTyThing
instance Outputable TcTyThing where -- Debugging only
ppr (AGlobal g) = ppr g
ppr (ATcId g tl pl) = text "Identifier" <>
ifPprDebug (brackets (ppr g <> comma <> ppr tl <> comma <> ppr pl))
ppr (ATcId g tl) = text "Identifier" <>
ifPprDebug (brackets (ppr g <> comma <> ppr tl))
ppr (ATyVar tv ty) = text "Type variable" <+> quotes (ppr tv) <+> pprParendType ty
ppr (AThing k) = text "AThing" <+> ppr k
pprTcTyThingCategory :: TcTyThing -> SDoc
pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing
pprTcTyThingCategory (ATyVar _ _) = ptext SLIT("Type variable")
pprTcTyThingCategory (ATcId _ _ _) = ptext SLIT("Local identifier")
pprTcTyThingCategory (ATcId _ _) = ptext SLIT("Local identifier")
pprTcTyThingCategory (AThing _) = ptext SLIT("Kinded thing")
\end{code}
......
......@@ -544,7 +544,7 @@ reifyThing (AGlobal (ADataCon dc))
; fix <- reifyFixity name
; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
reifyThing (ATcId id _ _)
reifyThing (ATcId id _)
= do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
-- though it may be incomplete
; ty2 <- reifyType ty1
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment