; [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
%* *
%************************************************************************
+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
-- 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
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
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])
checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
topIdLvl,
- -- Arrow stuff
- checkProcLevel,
-
-- New Ids
newLocalName, newDFunName
) where
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)
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)
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
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)
%************************************************************************
%* *
- 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
%* *
%************************************************************************
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 )
-- 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"))
}
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
%************************************************************************
%* *
- 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
%* *
%************************************************************************
ThStage(..), topStage, topSpliceStage,
ThLevel, impLevel, topLevel,
- -- Arrows
- ArrowCtxt(..), topArrowCtxt, ProcLevel, topProcLevel,
-
-- Insts
Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc,
instLocSrcLoc, instLocSrcSpan,
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
---------------------------
--- 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
---------------------------
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,
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}
; 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
projects / ghc-hetmet.git / commitdiff