--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsArrows]{Desugaring arrow commands}
+
+\begin{code}
+module DsArrows ( dsProcExpr ) where
+
+#include "HsVersions.h"
+
+import Match ( matchSimply )
+import DsUtils ( mkErrorAppDs,
+ mkCoreTupTy, mkCoreTup, selectMatchVar,
+ mkTupleExpr, mkTupleSelector,
+ dsReboundNames, lookupReboundName )
+import DsMonad
+
+import HsSyn ( HsExpr(..), Pat(..),
+ Stmt(..), HsMatchContext(..), HsStmtContext(..),
+ Match(..), GRHSs(..), GRHS(..),
+ HsCmdTop(..), HsArrAppType(..),
+ ReboundNames,
+ collectHsBinders,
+ collectStmtBinders, collectStmtsBinders,
+ matchContextErrString
+ )
+import TcHsSyn ( TypecheckedHsCmd, TypecheckedHsCmdTop,
+ TypecheckedHsExpr, TypecheckedHsBinds,
+ TypecheckedPat,
+ TypecheckedMatch, TypecheckedGRHSs, TypecheckedGRHS,
+ TypecheckedStmt, hsPatType,
+ TypecheckedMatchContext )
+
+-- NB: The desugarer, which straddles the source and Core worlds, sometimes
+-- needs to see source types (newtypes etc), and sometimes not
+-- So WATCH OUT; check each use of split*Ty functions.
+-- Sigh. This is a pain.
+
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
+
+import TcType ( Type, tcSplitAppTy )
+import Type ( mkTyConApp )
+import CoreSyn
+import CoreFVs ( exprFreeVars )
+import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
+
+import Id ( Id, idType )
+import PrelInfo ( pAT_ERROR_ID )
+import DataCon ( DataCon, dataConWrapId )
+import TysWiredIn ( tupleCon, mkTupleTy )
+import BasicTypes ( Boxity(..) )
+import PrelNames ( eitherTyConName, leftDataConName, rightDataConName,
+ arrAName, composeAName, firstAName,
+ appAName, choiceAName, loopAName )
+import Util ( mapAccumL )
+import Outputable
+
+import HsPat ( collectPatBinders, collectPatsBinders )
+import VarSet ( IdSet, emptyVarSet, mkVarSet, varSetElems,
+ intersectVarSet, minusVarSet,
+ unionVarSet, unionVarSets, elemVarSet )
+import SrcLoc ( SrcLoc )
+\end{code}
+
+\begin{code}
+data DsCmdEnv = DsCmdEnv {
+ meth_binds :: [CoreBind],
+ arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
+ }
+
+mkCmdEnv :: ReboundNames Id -> DsM DsCmdEnv
+mkCmdEnv ids
+ = dsReboundNames ids `thenDs` \ (meth_binds, ds_meths) ->
+ return $ DsCmdEnv {
+ meth_binds = meth_binds,
+ arr_id = lookupReboundName ds_meths arrAName,
+ compose_id = lookupReboundName ds_meths composeAName,
+ first_id = lookupReboundName ds_meths firstAName,
+ app_id = lookupReboundName ds_meths appAName,
+ choice_id = lookupReboundName ds_meths choiceAName,
+ loop_id = lookupReboundName ds_meths loopAName
+ }
+
+bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
+bindCmdEnv ids body = foldr Let body (meth_binds ids)
+
+-- arr :: forall b c. (b -> c) -> a b c
+do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
+do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
+
+-- (>>>) :: forall b c d. a b c -> a c d -> a b d
+do_compose :: DsCmdEnv -> Type -> Type -> Type ->
+ CoreExpr -> CoreExpr -> CoreExpr
+do_compose ids b_ty c_ty d_ty f g
+ = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
+
+-- first :: forall b c d. a b c -> a (b,d) (c,d)
+do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
+do_first ids b_ty c_ty d_ty f
+ = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]
+
+-- app :: forall b c. a (a b c, b) c
+do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
+do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
+
+-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
+-- note the swapping of d and c
+do_choice :: DsCmdEnv -> Type -> Type -> Type ->
+ CoreExpr -> CoreExpr -> CoreExpr
+do_choice ids b_ty c_ty d_ty f g
+ = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
+
+-- loop :: forall b d c. a (b,d) (c,d) -> a b c
+-- note the swapping of d and c
+do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
+do_loop ids b_ty c_ty d_ty f
+ = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
+
+-- map_arrow (f :: b -> c) (g :: a c d) = arr f >>> g :: a b d
+do_map_arrow :: DsCmdEnv -> Type -> Type -> Type ->
+ CoreExpr -> CoreExpr -> CoreExpr
+do_map_arrow ids b_ty c_ty d_ty f c
+ = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) c
+
+mkFailExpr :: TypecheckedMatchContext -> Type -> DsM CoreExpr
+mkFailExpr ctxt ty
+ = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
+
+-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
+mkSndExpr :: Type -> Type -> DsM CoreExpr
+mkSndExpr a_ty b_ty
+ = newSysLocalDs a_ty `thenDs` \a_var ->
+ newSysLocalDs b_ty `thenDs` \b_var ->
+ newSysLocalDs (mkCorePairTy a_ty b_ty) `thenDs` \pair_var ->
+ returnDs (coreCaseSmallTuple pair_var [a_var, b_var] (Var b_var))
+\end{code}
+
+Build case analysis of a tuple. This cannot be done in the DsM monad,
+because the list of variables is typically not yet defined.
+
+\begin{code}
+-- coreCaseTuple [u1..] v [x1..xn] body
+-- = case v of v { (x1, .., xn) -> body }
+-- But the matching may be nested if the tuple is very big
+
+coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
+coreCaseTuple uniqs = coreCaseSmallTuple -- TODO: do this right
+
+-- same, but with a tuple small enough not to need nesting
+
+coreCaseSmallTuple :: Id -> [Id] -> CoreExpr -> CoreExpr
+coreCaseSmallTuple scrut_var [var] body
+ = bindNonRec var (Var scrut_var) body
+coreCaseSmallTuple scrut_var vars body
+ = Case (Var scrut_var) scrut_var
+ [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
+\end{code}
+
+\begin{code}
+-- Not right: doesn't handle nested tuples
+tupleType :: [Id] -> Type
+tupleType vars = mkCoreTupTy (map idType vars)
+
+mkCorePairTy :: Type -> Type -> Type
+mkCorePairTy t1 t2 = mkCoreTupTy [t1, t2]
+
+mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
+mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
+\end{code}
+
+The input is divided into a local environment, which is a flat tuple
+(unless it's too big), and a stack, each element of which is paired
+with the stack in turn. In general, the input has the form
+
+ (...((x1,...,xn),s1),...sk)
+
+where xi are the environment values, and si the ones on the stack,
+with s1 being the "top", the first one to be matched with a lambda.
+
+\begin{code}
+envStackType :: [Id] -> [Type] -> Type
+envStackType ids stack_tys = foldl mkCorePairTy (tupleType ids) stack_tys
+
+----------------------------------------------
+-- buildEnvStack
+--
+-- (...((x1,...,xn),s1),...sn)
+
+buildEnvStack :: [Id] -> [Id] -> CoreExpr
+buildEnvStack env_ids stack_ids
+ = envStackExpr (mkTupleExpr env_ids) (map Var stack_ids)
+
+envStackExpr :: CoreExpr -> [CoreExpr] -> CoreExpr
+envStackExpr core_ids core_exprs = foldl mkCorePairExpr core_ids core_exprs
+
+----------------------------------------------
+-- matchEnvStack
+--
+-- \ (...((x1,...,xm),s1),...sn) -> e
+-- =>
+-- \ zn ->
+-- case zn of (zn-1,sn) ->
+-- ...
+-- case z1 of (z0,s1) ->
+-- case z0 of (x1,...,xm) ->
+-- e
+
+matchEnvStack :: [Id] -- x1..xm
+ -> [Id] -- s1..sn
+ -> CoreExpr -- e
+ -> DsM CoreExpr
+matchEnvStack env_ids stack_ids body
+ = getUniqSupplyDs `thenDs` \ uniqs ->
+ newSysLocalDs (tupleType env_ids) `thenDs` \ tup_var ->
+ matchVarStack tup_var stack_ids
+ (coreCaseTuple uniqs tup_var env_ids body)
+
+
+----------------------------------------------
+-- matchVarStack
+--
+-- \ (...(z0,s1),...sn) -> e
+-- =>
+-- \ zn ->
+-- case zn of (zn-1,sn) ->
+-- ...
+-- case z1 of (z0,s1) ->
+-- e
+
+matchVarStack :: Id -- z0
+ -> [Id] -- s1..sn
+ -> CoreExpr -- e
+ -> DsM CoreExpr
+matchVarStack env_id [] body
+ = returnDs (Lam env_id body)
+matchVarStack env_id (stack_id:stack_ids) body
+ = let
+ pair_ids = [env_id, stack_id]
+ in
+ newSysLocalDs (tupleType pair_ids) `thenDs` \ pair_id ->
+ matchVarStack pair_id stack_ids
+ (coreCaseSmallTuple pair_id pair_ids body)
+\end{code}
+
+\begin{code}
+mkHsTupleExpr :: [TypecheckedHsExpr] -> TypecheckedHsExpr
+mkHsTupleExpr [e] = e
+mkHsTupleExpr es = ExplicitTuple es Unboxed
+
+mkHsPairExpr :: TypecheckedHsExpr -> TypecheckedHsExpr -> TypecheckedHsExpr
+mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2]
+
+mkHsEnvStackExpr :: [Id] -> [Id] -> TypecheckedHsExpr
+mkHsEnvStackExpr env_ids stack_ids
+ = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids)
+\end{code}
+
+Translation of arrow abstraction
+
+\begin{code}
+
+-- A | xs |- c :: [] t' ---> c'
+-- --------------------------
+-- A |- proc p -> c :: a t t' ---> arr (\ p -> (xs)) >>> c'
+--
+-- where (xs) is the tuple of variables bound by p
+
+dsProcExpr
+ :: TypecheckedPat
+ -> TypecheckedHsCmdTop
+ -> SrcLoc
+ -> DsM CoreExpr
+dsProcExpr pat (HsCmdTop cmd [] cmd_ty ids) locn
+ = putSrcLocDs locn $
+ mkCmdEnv ids `thenDs` \ meth_ids ->
+ let
+ locals = mkVarSet (collectPatBinders pat)
+ in
+ dsfixCmd meth_ids locals [] cmd_ty cmd
+ `thenDs` \ (core_cmd, free_vars, env_ids) ->
+ let
+ env_ty = tupleType env_ids
+ in
+ mkFailExpr ProcExpr env_ty `thenDs` \ fail_expr ->
+ selectMatchVar pat `thenDs` \ var ->
+ matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
+ `thenDs` \ match_code ->
+ let
+ pat_ty = hsPatType pat
+ proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
+ (Lam var match_code)
+ core_cmd
+ in
+ returnDs (bindCmdEnv meth_ids proc_code)
+
+\end{code}
+
+Translation of command judgements of the form
+
+ A | xs |- c :: [ts] t
+
+\begin{code}
+
+dsCmd :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this command
+ -> [Id] -- list of vars in the input to this command
+ -- This is typically fed back,
+ -- so don't pull on it too early
+ -> [Type] -- type of the stack
+ -> Type -- return type of the command
+ -> TypecheckedHsCmd -- command to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- set of local vars that occur free
+
+-- A |- f :: a t t'
+-- A, xs |- arg :: t
+-- ---------------------------
+-- A | xs |- f -< arg :: [] t' ---> arr (\ (xs) -> arg) >>> f
+
+dsCmd ids local_vars env_ids [] res_ty
+ (HsArrApp arrow arg arrow_ty HsFirstOrderApp _ _)
+ = let
+ (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+ (a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+ env_ty = tupleType env_ids
+ in
+ dsExpr arrow `thenDs` \ core_arrow ->
+ dsExpr arg `thenDs` \ core_arg ->
+ matchEnvStack env_ids [] core_arg `thenDs` \ core_make_arg ->
+ returnDs (do_map_arrow ids env_ty arg_ty res_ty
+ core_make_arg
+ core_arrow,
+ exprFreeVars core_arg `intersectVarSet` local_vars)
+
+-- A, xs |- f :: a t t'
+-- A, xs |- arg :: t
+-- ---------------------------
+-- A | xs |- f -<< arg :: [] t' ---> arr (\ (xs) -> (f,arg)) >>> app
+
+dsCmd ids local_vars env_ids [] res_ty
+ (HsArrApp arrow arg arrow_ty HsHigherOrderApp _ _)
+ = let
+ (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+ (a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+ env_ty = tupleType env_ids
+ in
+ dsExpr arrow `thenDs` \ core_arrow ->
+ dsExpr arg `thenDs` \ core_arg ->
+ matchEnvStack env_ids [] (mkCoreTup [core_arrow, core_arg])
+ `thenDs` \ core_make_pair ->
+ returnDs (do_map_arrow ids env_ty (mkCorePairTy arrow_ty arg_ty) res_ty
+ core_make_pair
+ (do_app ids arg_ty res_ty),
+ (exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
+ `intersectVarSet` local_vars)
+
+-- A | ys |- c :: [ts] t'
+-- -----------------------------------------------
+-- A | xs |- \ p1 ... pk -> c :: [t1:...:tk:ts] t'
+--
+-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
+
+dsCmd ids local_vars env_ids stack res_ty
+ (HsLam (Match pats _ (GRHSs [GRHS [ResultStmt body _] loc] _ _cmd_ty)))
+ = let
+ pat_vars = mkVarSet (collectPatsBinders pats)
+ local_vars' = local_vars `unionVarSet` pat_vars
+ stack' = drop (length pats) stack
+ in
+ dsfixCmd ids local_vars' stack' res_ty body
+ `thenDs` \ (core_body, free_vars, env_ids') ->
+ mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
+
+ -- the expression is built from the inside out, so the actions
+ -- are presented in reverse order
+
+ let
+ (actual_ids, stack_ids') = splitAt (length pats) stack_ids
+ -- build a new environment, plus what's left of the stack
+ core_expr = buildEnvStack env_ids' stack_ids'
+ in_ty = envStackType env_ids stack
+ in_ty' = envStackType env_ids' stack'
+ in
+ mkFailExpr LambdaExpr in_ty' `thenDs` \ fail_expr ->
+ -- match the patterns against the top of the old stack
+ matchSimplys (map Var actual_ids) LambdaExpr pats core_expr fail_expr
+ `thenDs` \ match_code ->
+ -- match the old environment and stack against the input
+ matchEnvStack env_ids stack_ids match_code
+ `thenDs` \ select_code ->
+ returnDs (do_map_arrow ids in_ty in_ty' res_ty select_code core_body,
+ free_vars `minusVarSet` pat_vars)
+
+dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
+ = dsCmd ids local_vars env_ids stack res_ty cmd
+
+dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc)
+ = dsExpr exp `thenDs` \ core_exp ->
+ mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
+
+ -- Extract and desugar the leaf commands in the case, building tuple
+ -- expressions that will (after tagging) replace these leaves
+
+ let
+ leaves = concatMap leavesMatch matches
+ make_branch (leaf, bound_vars)
+ = dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
+ `thenDs` \ (core_leaf, fvs, leaf_ids) ->
+ returnDs (fvs `minusVarSet` bound_vars,
+ [mkHsEnvStackExpr leaf_ids stack_ids],
+ envStackType leaf_ids stack,
+ core_leaf)
+ in
+ mapDs make_branch leaves `thenDs` \ branches ->
+ dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
+ dsLookupDataCon leftDataConName `thenDs` \ left_con ->
+ dsLookupDataCon rightDataConName `thenDs` \ right_con ->
+ let
+ left_id = HsVar (dataConWrapId left_con)
+ right_id = HsVar (dataConWrapId right_con)
+ left_expr ty1 ty2 e = HsApp (TyApp left_id [ty1, ty2]) e
+ right_expr ty1 ty2 e = HsApp (TyApp right_id [ty1, ty2]) e
+
+ -- Prefix each tuple with a distinct series of Left's and Right's,
+ -- in a balanced way, keeping track of the types.
+
+ merge_branches (fvs1, builds1, in_ty1, core_exp1)
+ (fvs2, builds2, in_ty2, core_exp2)
+ = (fvs1 `unionVarSet` fvs2,
+ map (left_expr in_ty1 in_ty2) builds1 ++
+ map (right_expr in_ty1 in_ty2) builds2,
+ mkTyConApp either_con [in_ty1, in_ty2],
+ do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
+ (fvs, leaves', sum_ty, core_choices) = foldb merge_branches branches
+
+ -- Replace the commands in the case with these tagged tuples,
+ -- yielding a TypecheckedHsExpr we can feed to dsExpr.
+
+ (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
+ in_ty = envStackType env_ids stack
+ in
+ dsExpr (HsCase exp matches' src_loc) `thenDs` \ core_matches ->
+ returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
+ exprFreeVars core_exp `unionVarSet` fvs)
+
+-- A, xs |- e :: Bool
+-- A | xs1 |- c1 :: [ts] t
+-- A | xs2 |- c2 :: [ts] t
+-- ----------------------------------------
+-- A | xs |- if e then c1 else c2 :: [ts] t
+--
+-- ---> arr (\ ((xs)*ts) ->
+-- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
+-- c1 ||| c2
+
+dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd src_loc)
+ = dsExpr cond `thenDs` \ core_cond ->
+ dsfixCmd ids local_vars stack res_ty then_cmd
+ `thenDs` \ (core_then, fvs_then, then_ids) ->
+ dsfixCmd ids local_vars stack res_ty else_cmd
+ `thenDs` \ (core_else, fvs_else, else_ids) ->
+ mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
+ dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
+ dsLookupDataCon leftDataConName `thenDs` \ left_con ->
+ dsLookupDataCon rightDataConName `thenDs` \ right_con ->
+ let
+ left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
+ right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
+
+ in_ty = envStackType env_ids stack
+ then_ty = envStackType then_ids stack
+ else_ty = envStackType else_ids stack
+ sum_ty = mkTyConApp either_con [then_ty, else_ty]
+ in
+ matchEnvStack env_ids stack_ids
+ (mkIfThenElse core_cond
+ (left_expr then_ty else_ty (buildEnvStack then_ids stack_ids))
+ (right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)))
+ `thenDs` \ core_if ->
+ returnDs(do_map_arrow ids in_ty sum_ty res_ty
+ core_if
+ (do_choice ids then_ty else_ty res_ty core_then core_else),
+ exprFreeVars core_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
+
+-- A | ys |- c :: [ts] t
+-- ----------------------------------
+-- A | xs |- let binds in c :: [ts] t
+--
+-- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c
+
+dsCmd ids local_vars env_ids stack res_ty (HsLet binds body)
+ = let
+ defined_vars = mkVarSet (collectHsBinders binds)
+ local_vars' = local_vars `unionVarSet` defined_vars
+ in
+ dsfixCmd ids local_vars' stack res_ty body
+ `thenDs` \ (core_body, free_vars, env_ids') ->
+ mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
+ -- build a new environment, plus the stack, using the let bindings
+ dsLet binds (buildEnvStack env_ids' stack_ids)
+ `thenDs` \ core_binds ->
+ -- match the old environment and stack against the input
+ matchEnvStack env_ids stack_ids core_binds
+ `thenDs` \ core_map ->
+ returnDs (do_map_arrow ids
+ (envStackType env_ids stack)
+ (envStackType env_ids' stack)
+ res_ty
+ core_map
+ core_body,
+ exprFreeVars core_binds `intersectVarSet` local_vars)
+
+dsCmd ids local_vars env_ids [] res_ty (HsDo ctxt stmts _ _ src_loc)
+ = dsCmdDo ids local_vars env_ids res_ty stmts
+
+-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
+-- A | xs |- ci :: [tsi] ti
+-- -----------------------------------
+-- A | xs |- (|e|) c1 ... cn :: [ts] t ---> e [t_xs] c1 ... cn
+
+dsCmd ids local_vars env_ids _stack _res_ty (HsArrForm op _ args _)
+ = let
+ env_ty = tupleType env_ids
+ in
+ dsExpr op `thenDs` \ core_op ->
+ mapAndUnzipDs (dsTrimCmdArg local_vars env_ids) args
+ `thenDs` \ (core_args, fv_sets) ->
+ returnDs (mkApps (App core_op (Type env_ty)) core_args,
+ unionVarSets fv_sets)
+
+-- A | ys |- c :: [ts] t (ys <= xs)
+-- ---------------------
+-- A | xs |- c :: [ts] t ---> arr_ts (\ (xs) -> (ys)) >>> c
+
+dsTrimCmdArg
+ :: IdSet -- set of local vars available to this command
+ -> [Id] -- list of vars in the input to this command
+ -> TypecheckedHsCmdTop -- command argument to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- set of local vars that occur free
+dsTrimCmdArg local_vars env_ids (HsCmdTop cmd stack cmd_ty ids)
+ = mkCmdEnv ids `thenDs` \ meth_ids ->
+ dsfixCmd meth_ids local_vars stack cmd_ty cmd
+ `thenDs` \ (core_cmd, free_vars, env_ids') ->
+ mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
+ matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids)
+ `thenDs` \ trim_code ->
+ let
+ in_ty = envStackType env_ids stack
+ in_ty' = envStackType env_ids' stack
+ arg_code = if env_ids' == env_ids then core_cmd else
+ do_map_arrow meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
+ in
+ returnDs (bindCmdEnv meth_ids arg_code, free_vars)
+
+-- Given A | xs |- c :: [ts] t, builds c with xs fed back.
+-- Typically needs to be prefixed with arr (\p -> ((xs)*ts))
+
+dsfixCmd
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this command
+ -> [Type] -- type of the stack
+ -> Type -- return type of the command
+ -> TypecheckedHsCmd -- command to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet, -- set of local vars that occur free
+ [Id]) -- set as a list, fed back
+dsfixCmd ids local_vars stack cmd_ty cmd
+ = fixDs (\ ~(_,_,env_ids') ->
+ dsCmd ids local_vars env_ids' stack cmd_ty cmd
+ `thenDs` \ (core_cmd, free_vars) ->
+ returnDs (core_cmd, free_vars, varSetElems free_vars))
+
+\end{code}
+
+Translation of command judgements of the form
+
+ A | xs |- do { ss } :: [] t
+
+\begin{code}
+
+dsCmdDo :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
+ -> [Id] -- list of vars in the input to this statement
+ -- This is typically fed back,
+ -- so don't pull on it too early
+ -> Type -- return type of the statement
+ -> [TypecheckedStmt] -- statements to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- set of local vars that occur free
+
+-- A | xs |- c :: [] t
+-- --------------------------
+-- A | xs |- do { c } :: [] t
+
+dsCmdDo ids local_vars env_ids res_ty [ResultStmt cmd _locn]
+ = dsCmd ids local_vars env_ids [] res_ty cmd
+
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts)
+ = let
+ bound_vars = mkVarSet (collectStmtBinders stmt)
+ local_vars' = local_vars `unionVarSet` bound_vars
+ in
+ fixDs (\ ~(_,_,env_ids') ->
+ dsCmdDo ids local_vars' env_ids' res_ty stmts
+ `thenDs` \ (core_stmts, fv_stmts) ->
+ returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
+ `thenDs` \ (core_stmts, fv_stmts, env_ids') ->
+ dsCmdStmt ids local_vars env_ids env_ids' stmt
+ `thenDs` \ (core_stmt, fv_stmt) ->
+ returnDs (do_compose ids
+ (tupleType env_ids)
+ (tupleType env_ids')
+ res_ty
+ core_stmt
+ core_stmts,
+ fv_stmt)
+
+dsCmdStmt
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
+ -> [Id] -- list of vars in the input to this statement
+ -- This is typically fed back,
+ -- so don't pull on it too early
+ -> [Id] -- list of vars in the output of this statement
+ -> TypecheckedStmt -- statement to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- set of local vars that occur free
+
+-- A | xs1 |- c :: [] t
+-- A | xs' |- do { ss } :: [] t
+-- ------------------------------
+-- A | xs |- do { c; ss } :: [] t
+--
+-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
+-- arr snd >>> ss
+
+dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty locn)
+ = dsfixCmd ids local_vars [] c_ty cmd
+ `thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
+ matchEnvStack env_ids []
+ (mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr out_ids))
+ `thenDs` \ core_mux ->
+ let
+ in_ty = tupleType env_ids
+ in_ty1 = tupleType env_ids1
+ out_ty = tupleType out_ids
+ before_c_ty = mkCorePairTy in_ty1 out_ty
+ after_c_ty = mkCorePairTy c_ty out_ty
+ in
+ mkSndExpr c_ty out_ty `thenDs` \ snd_fn ->
+ returnDs (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
+ do_compose ids before_c_ty after_c_ty out_ty
+ (do_first ids in_ty1 c_ty out_ty core_cmd) $
+ do_arr ids after_c_ty out_ty snd_fn,
+ fv_cmd `unionVarSet` mkVarSet out_ids)
+ where
+
+-- A | xs1 |- c :: [] t
+-- A | xs' |- do { ss } :: [] t xs2 = xs' - defs(p)
+-- -----------------------------------
+-- A | xs |- do { p <- c; ss } :: [] t
+--
+-- ---> arr (\ (xs) -> ((xs1),(xs2))) >>> first c >>>
+-- arr (\ (p, (xs2)) -> (xs')) >>> ss
+--
+-- It would be simpler and more consistent to do this using second,
+-- but that's likely to be defined in terms of first.
+
+dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd locn)
+ = dsfixCmd ids local_vars [] (hsPatType pat) cmd
+ `thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
+ let
+ pat_vars = mkVarSet (collectPatBinders pat)
+ env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
+ in
+
+ -- multiplexing function
+ -- \ (xs) -> ((xs1),(xs2))
+
+ matchEnvStack env_ids []
+ (mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr env_ids2))
+ `thenDs` \ core_mux ->
+
+ -- projection function
+ -- \ (p, (xs2)) -> (zs)
+
+ selectMatchVar pat `thenDs` \ pat_id ->
+ newSysLocalDs (tupleType env_ids2) `thenDs` \ env_id ->
+ getUniqSupplyDs `thenDs` \ uniqs ->
+ let
+ pair_ids = [pat_id, env_id]
+ after_c_ty = tupleType pair_ids
+ out_ty = tupleType out_ids
+ body_expr = coreCaseTuple uniqs env_id env_ids2 (mkTupleExpr out_ids)
+ in
+ mkFailExpr (StmtCtxt DoExpr) out_ty `thenDs` \ fail_expr ->
+ matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
+ `thenDs` \ match_code ->
+ newSysLocalDs after_c_ty `thenDs` \ pair_id ->
+ let
+ proj_expr = Lam pair_id (coreCaseSmallTuple pair_id pair_ids match_code)
+ in
+
+ -- put it all togther
+ let
+ pat_ty = hsPatType pat
+ in_ty = tupleType env_ids
+ in_ty1 = tupleType env_ids1
+ in_ty2 = tupleType env_ids2
+ before_c_ty = mkCorePairTy in_ty1 in_ty2
+ in
+ returnDs (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
+ do_compose ids before_c_ty after_c_ty out_ty
+ (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
+ do_arr ids after_c_ty out_ty proj_expr,
+ fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars))
+
+-- A | xs' |- do { ss } :: [] t
+-- --------------------------------------
+-- A | xs |- do { let binds; ss } :: [] t
+--
+-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
+
+dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
+ -- build a new environment using the let bindings
+ = dsLet binds (mkTupleExpr out_ids) `thenDs` \ core_binds ->
+ -- match the old environment against the input
+ matchEnvStack env_ids [] core_binds `thenDs` \ core_map ->
+ returnDs (do_arr ids
+ (tupleType env_ids)
+ (tupleType out_ids)
+ core_map,
+ exprFreeVars core_binds `intersectVarSet` local_vars)
+
+-- A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ...
+-- A | xs' |- do { ss' } :: [] t
+-- ------------------------------------
+-- A | xs |- do { rec ss; ss' } :: [] t
+--
+-- xs1 = xs' /\ defs(ss)
+-- xs2 = xs' - defs(ss)
+-- ys1 = ys - defs(ss)
+-- ys2 = ys /\ defs(ss)
+--
+-- ---> arr (\(xs) -> ((ys1),(xs2))) >>>
+-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
+-- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
+
+dsCmdStmt ids local_vars env_ids out_ids' (RecStmt stmts later_ids rec_ids rhss)
+ = let
+ rec_id_set = mkVarSet rec_ids
+ out_ids = varSetElems (mkVarSet later_ids `unionVarSet` rec_id_set)
+ out_ty = tupleType out_ids
+ local_vars' = local_vars `unionVarSet` rec_id_set
+ in
+
+ -- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss))
+
+ mapDs dsExpr rhss `thenDs` \ core_rhss ->
+ let
+ later_tuple = mkTupleExpr later_ids
+ later_ty = tupleType later_ids
+ rec_tuple = mkCoreTup core_rhss
+ rec_ty = tupleType rec_ids
+ out_pair = mkCoreTup [later_tuple, rec_tuple]
+ out_pair_ty = mkCoreTupTy [later_ty, rec_ty]
+ in
+ matchEnvStack out_ids [] out_pair
+ `thenDs` \ mk_pair_fn ->
+
+ dsfixCmdStmts ids local_vars' out_ids stmts
+ `thenDs` \ (core_stmts, fv_stmts, env_ids') ->
+
+ -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids')
+
+ newSysLocalDs rec_ty `thenDs` \ rec_id ->
+ let
+ env1_id_set = fv_stmts `minusVarSet` rec_id_set
+ env1_ids = varSetElems env1_id_set
+ env1_ty = tupleType env1_ids
+ in_pair_ty = mkCoreTupTy [env1_ty, rec_ty]
+ core_body = mkCoreTup (map selectVar env_ids')
+ where
+ selectVar v
+ | v `elemVarSet` rec_id_set
+ = mkTupleSelector rec_ids v rec_id (Var rec_id)
+ | otherwise = Var v
+ in
+ matchEnvStack env1_ids [rec_id] core_body
+ `thenDs` \ squash_pair_fn ->
+
+ -- loop (arr squash_pair_fn >>> ss >>> arr mk_pair_fn)
+
+ let
+ env_ty' = tupleType env_ids'
+ core_loop = do_loop ids env1_ty later_ty rec_ty
+ (do_map_arrow ids in_pair_ty env_ty' out_pair_ty
+ squash_pair_fn
+ (do_compose ids env_ty' out_ty out_pair_ty
+ core_stmts
+ (do_arr ids out_ty out_pair_ty mk_pair_fn)))
+ in
+
+ -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
+
+ let
+ env_ty = tupleType env_ids
+ env2_id_set = mkVarSet out_ids' `minusVarSet` mkVarSet later_ids
+ env2_ids = varSetElems env2_id_set
+ env2_ty = tupleType env2_ids
+ pre_pair_ty = mkCoreTupTy [env1_ty, env2_ty]
+ pre_loop_body = mkCoreTup [mkTupleExpr env1_ids, mkTupleExpr env2_ids]
+
+ in
+ matchEnvStack env_ids [] pre_loop_body
+ `thenDs` \ pre_loop_fn ->
+
+ -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids')
+
+ getUniqSupplyDs `thenDs` \ uniqs ->
+ newSysLocalDs env2_ty `thenDs` \ env2_id ->
+ let
+ out_ty' = tupleType out_ids'
+ post_pair_ty = mkCoreTupTy [later_ty, env2_ty]
+ post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkTupleExpr out_ids')
+ in
+ matchEnvStack later_ids [env2_id] post_loop_body
+ `thenDs` \ post_loop_fn ->
+
+ -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
+
+ let
+ core_body = do_map_arrow ids env_ty pre_pair_ty out_ty'
+ pre_loop_fn
+ (do_compose ids pre_pair_ty post_pair_ty out_ty'
+ (do_first ids env1_ty later_ty env2_ty
+ core_loop)
+ (do_arr ids post_pair_ty out_ty'
+ post_loop_fn))
+ in
+ returnDs (core_body, env1_id_set `unionVarSet` env2_id_set)
+
+\end{code}
+A sequence of statements (as is a rec) is desugared to an arrow between
+two environments
+\begin{code}
+
+dsfixCmdStmts
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
+ -> [Id] -- output vars of these statements
+ -> [TypecheckedStmt] -- statements to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet, -- set of local vars that occur free
+ [Id]) -- input vars
+
+dsfixCmdStmts ids local_vars out_ids stmts
+ = fixDs (\ ~(_,_,env_ids) ->
+ dsCmdStmts ids local_vars env_ids out_ids stmts
+ `thenDs` \ (core_stmts, fv_stmts) ->
+ returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
+
+dsCmdStmts
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
+ -> [Id] -- list of vars in the input to these statements
+ -> [Id] -- output vars of these statements
+ -> [TypecheckedStmt] -- statements to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- set of local vars that occur free
+
+dsCmdStmts ids local_vars env_ids out_ids [stmt]
+ = dsCmdStmt ids local_vars env_ids out_ids stmt
+
+dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts)
+ = let
+ bound_vars = mkVarSet (collectStmtBinders stmt)
+ local_vars' = local_vars `unionVarSet` bound_vars
+ in
+ dsfixCmdStmts ids local_vars' out_ids stmts
+ `thenDs` \ (core_stmts, fv_stmts, env_ids') ->
+ dsCmdStmt ids local_vars env_ids env_ids' stmt
+ `thenDs` \ (core_stmt, fv_stmt) ->
+ returnDs (do_compose ids
+ (tupleType env_ids)
+ (tupleType env_ids')
+ (tupleType out_ids)
+ core_stmt
+ core_stmts,
+ fv_stmt)
+
+\end{code}
+
+Match a list of expressions against a list of patterns, left-to-right.
+
+\begin{code}
+matchSimplys :: [CoreExpr] -- Scrutinees
+ -> TypecheckedMatchContext -- Match kind
+ -> [TypecheckedPat] -- Patterns they should match
+ -> CoreExpr -- Return this if they all match
+ -> CoreExpr -- Return this if they don't
+ -> DsM CoreExpr
+matchSimplys [] _ctxt [] result_expr fail_expr = returnDs result_expr
+matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr
+ = matchSimplys exps ctxt pats result_expr fail_expr
+ `thenDs` \ match_code ->
+ matchSimply exp ctxt pat match_code fail_expr
+\end{code}
+
+\begin{code}
+
+-- list of leaf expressions, with set of variables bound in each
+leavesMatch :: TypecheckedMatch -> [(TypecheckedHsExpr, IdSet)]
+leavesMatch (Match pats _ (GRHSs grhss binds _ty))
+ = let
+ defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet`
+ mkVarSet (collectHsBinders binds)
+ in
+ [(expr, mkVarSet (collectStmtsBinders stmts) `unionVarSet` defined_vars) |
+ GRHS stmts _locn <- grhss,
+ let ResultStmt expr _ = last stmts]
+
+-- Replace the leaf commands in a match
+
+replaceLeavesMatch
+ :: Type -- new result type
+ -> [TypecheckedHsExpr] -- replacement leaf expressions of that type
+ -> TypecheckedMatch -- the matches of a case command
+ -> ([TypecheckedHsExpr],-- remaining leaf expressions
+ TypecheckedMatch) -- updated match
+replaceLeavesMatch res_ty leaves (Match pat mt (GRHSs grhss binds _ty))
+ = let
+ (leaves', grhss') = mapAccumL (replaceLeavesGRHS res_ty) leaves grhss
+ in
+ (leaves', Match pat mt (GRHSs grhss' binds res_ty))
+
+replaceLeavesGRHS
+ :: Type -- new result type
+ -> [TypecheckedHsExpr] -- replacement leaf expressions of that type
+ -> TypecheckedGRHS -- rhss of a case command
+ -> ([TypecheckedHsExpr],-- remaining leaf expressions
+ TypecheckedGRHS) -- updated GRHS
+replaceLeavesGRHS res_ty (leaf:leaves) (GRHS stmts srcloc)
+ = (leaves, GRHS (init stmts ++ [ResultStmt leaf srcloc]) srcloc)
+
+\end{code}
+
+Balanced fold of a non-empty list.
+
+\begin{code}
+foldb :: (a -> a -> a) -> [a] -> a
+foldb f [] = error "foldb of empty list"
+foldb f [x] = x
+foldb f xs = foldb f (fold_pairs xs)
+ where
+ fold_pairs [] = []
+ fold_pairs [x] = [x]
+ fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
+\end{code}
import DsGRHSs ( dsGuarded )
import DsCCall ( dsCCall )
import DsListComp ( dsListComp, dsPArrComp )
-import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr, mkCoreTupTy, selectMatchVar )
+import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr,
+ mkCoreTupTy, selectMatchVar,
+ dsReboundNames, lookupReboundName )
+import DsArrows ( dsProcExpr )
import DsMonad
#ifdef GHCI
import HsSyn ( HsExpr(..), Pat(..), ArithSeqInfo(..),
Stmt(..), HsMatchContext(..), HsStmtContext(..),
Match(..), HsBinds(..), MonoBinds(..), HsConDetails(..),
+ ReboundNames,
mkSimpleMatch, isDoExpr
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, hsPatType )
import TyCon ( tyConDataCons )
import TysWiredIn ( tupleCon, mkTupleTy )
import BasicTypes ( RecFlag(..), Boxity(..), ipNameName )
-import PrelNames ( toPName )
+import PrelNames ( toPName,
+ returnMName, bindMName, thenMName, failMName,
+ mfixName )
import SrcLoc ( noSrcLoc )
import Util ( zipEqual, zipWithEqual )
import Outputable
dsExpr (HsSplice n e _) = pprPanic "dsExpr:splice" (ppr e)
#endif
+-- Arrow notation extension
+dsExpr (HsProc pat cmd src_loc) = dsProcExpr pat cmd src_loc
\end{code}
\begin{code}
dsDo :: HsStmtContext Name
-> [TypecheckedStmt]
- -> [Id] -- id for: [return,fail,>>=,>>] and possibly mfixName
- -> Type -- Element type; the whole expression has type (m t)
+ -> ReboundNames Id -- id for: [return,fail,>>=,>>] and possibly mfixName
+ -> Type -- Element type; the whole expression has type (m t)
-> DsM CoreExpr
dsDo do_or_lc stmts ids result_ty
- = let
- (return_id : fail_id : bind_id : then_id : _) = ids
+ = dsReboundNames ids `thenDs` \ (meth_binds, ds_meths) ->
+ let
+ return_id = lookupReboundName ds_meths returnMName
+ fail_id = lookupReboundName ds_meths failMName
+ bind_id = lookupReboundName ds_meths bindMName
+ then_id = lookupReboundName ds_meths thenMName
+
(m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
is_do = isDoExpr do_or_lc -- True for both MDo and Do
go [ResultStmt expr locn]
| is_do = do_expr expr locn
| otherwise = do_expr expr locn `thenDs` \ expr2 ->
- returnDs (mkApps (Var return_id) [Type b_ty, expr2])
+ returnDs (mkApps return_id [Type b_ty, expr2])
go (ExprStmt expr a_ty locn : stmts)
| is_do -- Do expression
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
- returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2, rest])
+ returnDs (mkApps then_id [Type a_ty, Type b_ty, expr2, rest])
| otherwise -- List comprehension
= do_expr expr locn `thenDs` \ expr2 ->
in
mkStringLit msg `thenDs` \ core_msg ->
returnDs (mkIfThenElse expr2 rest
- (App (App (Var fail_id) (Type b_ty)) core_msg))
+ (App (App fail_id (Type b_ty)) core_msg))
go (LetStmt binds : stmts )
= go stmts `thenDs` \ rest ->
let
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
- fail_expr = mkApps (Var fail_id) [Type b_ty, core_msg]
+ fail_expr = mkApps fail_id [Type b_ty, core_msg]
a_ty = hsPatType pat
in
selectMatchVar pat `thenDs` \ var ->
matchSimply (Var var) (StmtCtxt do_or_lc) pat
body fail_expr `thenDs` \ match_code ->
- returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, rhs, Lam var match_code])
+ returnDs (mkApps bind_id [Type a_ty, Type b_ty, rhs, Lam var match_code])
- go (RecStmt rec_vars rec_stmts rec_rets : stmts)
+ go (RecStmt rec_stmts later_vars rec_vars rec_rets : stmts)
= go (bind_stmt : stmts)
where
- bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts rec_rets
+ bind_stmt = dsRecStmt m_ty ds_meths rec_stmts later_vars rec_vars rec_rets
in
- go stmts
+ go stmts `thenDs` \ stmts_code ->
+ returnDs (foldr Let stmts_code meth_binds)
where
do_expr expr locn = putSrcLocDs locn (dsExpr expr)
\begin{code}
dsRecStmt :: Type -- Monad type constructor :: * -> *
- -> [Id] -- Ids for: [return,fail,>>=,>>,mfix]
- -> [Id] -> [TypecheckedStmt] -> [TypecheckedHsExpr] -- Guts of the RecStmt
+ -> [(Name,Id)] -- Rebound Ids
+ -> [TypecheckedStmt]
+ -> [Id] -> [Id] -> [TypecheckedHsExpr]
-> TypecheckedStmt
-dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts rets
+dsRecStmt m_ty ds_meths stmts later_vars rec_vars rec_rets
= ASSERT( length vars == length rets )
BindStmt tup_pat mfix_app noSrcLoc
where
- (var1:rest) = vars -- Always at least one
- (ret1:_) = rets
- one_var = null rest
+ vars@(var1:rest) = later_vars ++ rec_vars -- Always at least one
+ rets@(ret1:_) = map HsVar later_vars ++ rec_rets
+ one_var = null rest
mfix_app = HsApp (TyApp (HsVar mfix_id) [tup_ty]) mfix_arg
mfix_arg = HsLam (mkSimpleMatch [tup_pat] body tup_ty noSrcLoc)
| otherwise = LazyPat (TuplePat (map VarPat vars) Boxed)
body = HsDo DoExpr (stmts ++ [return_stmt])
- ids -- Don't need the mfix, but it does no harm
+ [(n, HsVar id) | (n,id) <- ds_meths] -- A bit of a hack
(mkAppTy m_ty tup_ty)
noSrcLoc
+ Var return_id = lookupReboundName ds_meths returnMName
+ Var mfix_id = lookupReboundName ds_meths mfixName
+
return_stmt = ResultStmt return_app noSrcLoc
return_app = HsApp (TyApp (HsVar return_id) [tup_ty]) tup_expr
\end{code}
returnDs (Var build_id `App` Type elt_ty
`App` mkLams [n_tyvar, c, n] result)
- where isParallelComp (ParStmtOut bndrstmtss : _) = True
- isParallelComp _ = False
+ where isParallelComp (ParStmt bndrstmtss : _) = True
+ isParallelComp _ = False
\end{code}
%************************************************************************
where (x1, .., xn) are the variables bound in p1, v1, p2
(y1, .., ym) are the variables bound in q1, v2, q2
-In the translation below, the ParStmtOut branch translates each parallel branch
+In the translation below, the ParStmt branch translates each parallel branch
into a sub-comprehension, and desugars each independently. The resulting lists
are fed to a zip function, we create a binding for all the variables bound in all
the comprehensions, and then we hand things off the the desugarer for bindings.
deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
-deListComp (ParStmtOut bndrstmtss : quals) list
- = mapDs do_list_comp bndrstmtss `thenDs` \ exps ->
+deListComp (ParStmt stmtss_w_bndrs : quals) list
+ = mapDs do_list_comp stmtss_w_bndrs `thenDs` \ exps ->
mkZipBind qual_tys `thenDs` \ (zip_fn, zip_rhs) ->
-- Deal with [e | pat <- zip l1 .. ln] in example above
deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
quals list
- where -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
- pat = TuplePat pats Boxed
- pats = map (\(bs,_) -> mk_hs_tuple_pat bs) bndrstmtss
+ where
+ bndrs_s = map snd stmtss_w_bndrs
+
+ -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
+ pat = TuplePat pats Boxed
+ pats = map mk_hs_tuple_pat bndrs_s
-- Types of (x1,..,xn), (y1,..,yn) etc
- qual_tys = [ mk_bndrs_tys bndrs | (bndrs,_) <- bndrstmtss ]
+ qual_tys = map mk_bndrs_tys bndrs_s
- do_list_comp (bndrs, stmts)
+ do_list_comp (stmts, bndrs)
= dsListComp (stmts ++ [ResultStmt (mk_hs_tuple_expr bndrs) noSrcLoc])
(mk_bndrs_tys bndrs)
-- where
-- {x_1, ..., x_n} = DV (qs)
--
-dePArrComp (ParStmtOut [] : qss2) pa cea = dePArrComp qss2 pa cea
-dePArrComp (ParStmtOut ((xs, qs):qss) : qss2) pa cea =
+dePArrComp (ParStmt [] : qss2) pa cea = dePArrComp qss2 pa cea
+dePArrComp (ParStmt ((qs, xs):qss) : qss2) pa cea =
dsLookupGlobalId zipPName `thenDs` \zipP ->
let pa' = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
ty'cea = parrElemType cea
let ty'cqs = parrElemType cqs
cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
in
- dePArrComp (ParStmtOut qss : qss2) pa' cea'
+ dePArrComp (ParStmt qss : qss2) pa' cea'
-- generate Core corresponding to `\p -> e'
--
\begin{code}
module DsMonad (
DsM,
- initDs, returnDs, thenDs, mapDs, listDs,
+ initDs, returnDs, thenDs, mapDs, listDs, fixDs,
mapAndUnzipDs, zipWithDs, foldlDs,
uniqSMtoDsM,
newTyVarsDs, cloneTyVarsDs,
getSrcLocDs, putSrcLocDs,
getModuleDs,
getUniqueDs, getUniquesDs,
+ UniqSupply, getUniqSupplyDs,
getDOptsDs,
- dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
+ dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
import HscTypes ( TyThing(..) )
import Bag ( emptyBag, snocBag, Bag )
+import DataCon ( DataCon )
import TyCon ( TyCon )
+import DataCon ( DataCon )
import Id ( mkSysLocal, setIdUnique, Id )
import Module ( Module )
import Var ( TyVar, setTyVarUnique )
import SrcLoc ( noSrcLoc, SrcLoc )
import Type ( Type )
import UniqSupply ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs,
- UniqSM, UniqSupply )
+ fixUs, UniqSM, UniqSupply, getUs )
import Unique ( Unique )
import Name ( Name, nameOccName )
import NameEnv
returnDs :: a -> DsM a
returnDs result = DsM (\ env warns -> returnUs (result, warns))
+fixDs :: (a -> DsM a) -> DsM a
+fixDs f = DsM (\env warns -> fixUs (\ ~(a, _warns') -> unDsM (f a) env warns))
+
listDs :: [DsM a] -> DsM [a]
listDs [] = returnDs []
listDs (x:xs)
getUniquesUs `thenUs` \ uniqs ->
returnUs (uniqs, warns))
+getUniqSupplyDs :: DsM UniqSupply
+getUniqSupplyDs = DsM(\ env warns ->
+ getUs `thenUs` \ uniqs ->
+ returnUs (uniqs, warns))
+
-- Make a new Id with the same print name, but different type, and new unique
newUniqueId :: Name -> Type -> DsM Id
newUniqueId id ty
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId name
= dsLookupGlobal name `thenDs` \ thing ->
- returnDs (get_id name thing)
+ returnDs $ case thing of
+ AnId id -> id
+ other -> pprPanic "dsLookupGlobalId" (ppr name)
dsLookupTyCon :: Name -> DsM TyCon
dsLookupTyCon name
= dsLookupGlobal name `thenDs` \ thing ->
- returnDs (get_tycon name thing)
+ returnDs $ case thing of
+ ATyCon tc -> tc
+ other -> pprPanic "dsLookupTyCon" (ppr name)
-get_id name (AnId id) = id
-get_id name other = pprPanic "dsLookupGlobalId" (ppr name)
-
-get_tycon name (ATyCon tc) = tc
-get_tycon name other = pprPanic "dsLookupTyCon" (ppr name)
+dsLookupDataCon :: Name -> DsM DataCon
+dsLookupDataCon name
+ = dsLookupGlobal name `thenDs` \ thing ->
+ returnDs $ case thing of
+ ADataCon dc -> dc
+ other -> pprPanic "dsLookupDataCon" (ppr name)
\end{code}
\begin{code}
mkSelectorBinds, mkTupleExpr, mkTupleSelector,
mkCoreTup, mkCoreSel, mkCoreTupTy,
+
+ dsReboundNames, lookupReboundName,
selectMatchVar
) where
#include "HsVersions.h"
-import {-# SOURCE #-} Match ( matchSimply )
+import {-# SOURCE #-} Match ( matchSimply )
+import {-# SOURCE #-} DsExpr( dsExpr )
import HsSyn
import TcHsSyn ( TypecheckedPat, hsPatType )
import CoreUtils ( exprType, mkIfThenElse, mkCoerce )
import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody )
import Id ( idType, Id, mkWildId, mkTemplateLocals )
+import Name ( Name )
import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
import TyCon ( isNewTyCon, tyConDataCons )
import DataCon ( DataCon, dataConSourceArity )
import Outputable
import UnicodeUtil ( intsToUtf8, stringToUtf8 )
import Util ( isSingleton, notNull, zipEqual )
+import ListSetOps ( assocDefault )
import FastString
\end{code}
%************************************************************************
%* *
+ Rebindable syntax
+%* *
+%************************************************************************
+
+\begin{code}
+dsReboundNames :: ReboundNames Id
+ -> DsM ([CoreBind], -- Auxiliary bindings
+ [(Name,Id)]) -- Maps the standard name to its value
+
+dsReboundNames rebound_ids
+ = mapAndUnzipDs mk_bind rebound_ids `thenDs` \ (binds_s, prs) ->
+ return (concat binds_s, prs)
+ where
+ -- The cheapo special case can happen when we
+ -- make an intermediate HsDo when desugaring a RecStmt
+ mk_bind (std_name, HsVar id) = return ([], (std_name, id))
+ mk_bind (std_name, expr) = dsExpr expr `thenDs` \ rhs ->
+ newSysLocalDs (exprType rhs) `thenDs` \ id ->
+ return ([NonRec id rhs], (std_name, id))
+
+lookupReboundName :: [(Name,Id)] -> Name -> CoreExpr
+lookupReboundName prs std_name
+ = Var (assocDefault (mk_panic std_name) prs std_name)
+ where
+ mk_panic std_name = pprPanic "dsReboundNames" (ptext SLIT("Not found:") <+> ppr std_name)
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Tidying lit pats}
%* *
%************************************************************************
cvtstmts :: [Meta.Stmt] -> [Hs.Stmt RdrName]
-cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt
-cvtstmts [NoBindS e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt
-cvtstmts (NoBindS e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss
+cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt
+cvtstmts [NoBindS e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt
+cvtstmts (NoBindS e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss
cvtstmts (Meta.BindS p e : ss) = BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss
cvtstmts (Meta.LetS ds : ss) = LetStmt (cvtdecs ds) : cvtstmts ss
-cvtstmts (Meta.ParS dss : ss) = ParStmt(map cvtstmts dss) : cvtstmts ss
-
+cvtstmts (Meta.ParS dss : ss) = ParStmt [(cvtstmts ds, undefined) | ds <- dss] : cvtstmts ss
cvtm :: Meta.Match -> Hs.Match RdrName
cvtm (Meta.Match p body wheres)
import Type ( Type )
import Var ( TyVar, Id )
import Name ( Name )
+import NameSet ( FreeVars )
import DataCon ( DataCon )
import CStrings ( CLabelString, pprCLabelString )
import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) )
| HsDo (HsStmtContext Name) -- The parameterisation is unimportant
-- because in this context we never use
-- the PatGuard or ParStmt variant
- [Stmt id] -- "do":one or more stmts
- [id] -- Ids for [return,fail,>>=,>>]
- -- Brutal but simple
- -- Before type checking, used for rebindable syntax
- PostTcType -- Type of the whole expression
+ [Stmt id] -- "do":one or more stmts
+ (ReboundNames id) -- Ids for [return,fail,>>=,>>]
+ PostTcType -- Type of the whole expression
SrcLoc
| ExplicitList -- syntactic list
| HsCoreAnn FastString -- hdaume: core annotation
(HsExpr id)
+ -----------------------------------------------------------
-- MetaHaskell Extensions
| HsBracket (HsBracket id) SrcLoc
-- identify this splice point
| HsReify (HsReify id) -- reifyType t, reifyDecl i, reifyFixity
+
+ -----------------------------------------------------------
+ -- Arrow notation extension
+
+ | HsProc (Pat id) -- arrow abstraction, proc
+ (HsCmdTop id) -- body of the abstraction
+ -- always has an empty stack
+ SrcLoc
+
+ ---------------------------------------
+ -- The following are commands, not expressions proper
+
+ | HsArrApp -- Arrow tail, or arrow application (f -< arg)
+ (HsExpr id) -- arrow expression, f
+ (HsExpr id) -- input expression, arg
+ PostTcType -- type of the arrow expressions f,
+ -- of the form a t t', where arg :: t
+ HsArrAppType -- higher-order (-<<) or first-order (-<)
+ Bool -- True => right-to-left (f -< arg)
+ -- False => left-to-right (arg >- f)
+ SrcLoc
+
+ | HsArrForm -- Command formation, (| e |) cmd1 .. cmdn
+ (HsExpr id) -- the operator
+ -- after type-checking, a type abstraction to be
+ -- applied to the type of the local environment tuple
+ (Maybe Fixity) -- fixity (filled in by the renamer), for forms that
+ -- were converted from OpApp's by the renamer
+ [HsCmdTop id] -- argument commands
+ SrcLoc
+
\end{code}
-- pasted back in by the desugarer
\end{code}
+Table of bindings of names used in rebindable syntax.
+This gets filled in by the renamer.
+
+\begin{code}
+type ReboundNames id = [(Name, HsExpr id)]
+-- * Before the renamer, this list is empty
+--
+-- * After the renamer, it takes the form [(std_name, HsVar actual_name)]
+-- For example, for the 'return' op of a monad
+-- normal case: (GHC.Base.return, HsVar GHC.Base.return)
+-- with rebindable syntax: (GHC.Base.return, return_22)
+-- where return_22 is whatever "return" is in scope
+--
+-- * After the type checker, it takes the form [(std_name, <expression>)]
+-- where <expression> is the evidence for the method
+\end{code}
A @Dictionary@, unless of length 0 or 1, becomes a tuple. A
@ClassDictLam dictvars methods expr@ is, therefore:
= hang (pprExpr op) 4 (sep [pp_e1, pp_e2])
pp_infixly v
- = sep [pp_e1, hsep [pp_v_op, pp_e2]]
- where
- ppr_v = ppr v
- pp_v_op | isOperator ppr_v = ppr_v
- | otherwise = char '`' <> ppr_v <> char '`'
- -- Put it in backquotes if it's not an operator already
+ = sep [pp_e1, hsep [pprInfix v, pp_e2]]
ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps
ppr_expr (HsReify r) = ppr r
+ppr_expr (HsProc pat (HsCmdTop cmd _ _ _) _)
+ = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), pprExpr cmd]
+
+ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True _)
+ = hsep [pprExpr arrow, ptext SLIT("-<"), pprExpr arg]
+ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False _)
+ = hsep [pprExpr arg, ptext SLIT(">-"), pprExpr arrow]
+ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True _)
+ = hsep [pprExpr arrow, ptext SLIT("-<<"), pprExpr arg]
+ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False _)
+ = hsep [pprExpr arg, ptext SLIT(">>-"), pprExpr arrow]
+
+ppr_expr (HsArrForm (HsVar v) (Just _) [arg1, arg2] _)
+ = sep [pprCmdArg arg1, hsep [pprInfix v, pprCmdArg arg2]]
+ppr_expr (HsArrForm op _ args _)
+ = hang (ptext SLIT("(|") <> pprExpr op <> ptext SLIT("|)"))
+ 4 (sep (map pprCmdArg args))
+
+pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
+pprCmdArg (HsCmdTop cmd@(HsArrForm _ Nothing [] _) _ _ _) = pprExpr cmd
+pprCmdArg (HsCmdTop cmd _ _ _) = parens (pprExpr cmd)
+
+-- Put a var in backquotes if it's not an operator already
+pprInfix :: Outputable name => name -> SDoc
+pprInfix v | isOperator ppr_v = ppr_v
+ | otherwise = char '`' <> ppr_v <> char '`'
+ where
+ ppr_v = ppr v
+
-- add parallel array brackets around a document
--
pa_brackets :: SDoc -> SDoc
%************************************************************************
%* *
+\subsection{Commands (in arrow abstractions)}
+%* *
+%************************************************************************
+
+We re-use HsExpr to represent these.
+
+\begin{code}
+type HsCmd id = HsExpr id
+
+data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
+\end{code}
+
+The legal constructors for commands are:
+
+ = HsArrApp ... -- as above
+
+ | HsArrForm ... -- as above
+
+ | HsLam (Match id) -- kappa
+
+ -- the renamer turns this one into HsArrForm
+ | OpApp (HsExpr id) -- left operand
+ (HsCmd id) -- operator
+ Fixity -- Renamer adds fixity; bottom until then
+ (HsCmd id) -- right operand
+
+ | HsPar (HsCmd id) -- parenthesised command
+
+ | HsCase (HsExpr id)
+ [Match id] -- bodies are HsCmd's
+ SrcLoc
+
+ | HsIf (HsExpr id) -- predicate
+ (HsCmd id) -- then part
+ (HsCmd id) -- else part
+ SrcLoc
+
+ | HsLet (HsBinds id) -- let(rec)
+ (HsCmd id)
+
+ | HsDo (HsStmtContext Name) -- The parameterisation is unimportant
+ -- because in this context we never use
+ -- the PatGuard or ParStmt variant
+ [Stmt id] -- HsExpr's are really HsCmd's
+ (ReboundNames id)
+ PostTcType -- Type of the whole expression
+ SrcLoc
+
+Top-level command, introducing a new arrow.
+This may occur inside a proc (where the stack is empty) or as an
+argument of a command-forming operator.
+
+\begin{code}
+data HsCmdTop id
+ = HsCmdTop (HsCmd id)
+ [PostTcType] -- types of inputs on the command's stack
+ PostTcType -- return type of the command
+ (ReboundNames id)
+ -- after type checking:
+ -- names used in the command's desugaring
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Record binds}
%* *
%************************************************************************
unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id]
unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc]
+
+glueBindsOnGRHSs :: HsBinds id -> GRHSs id -> GRHSs id
+glueBindsOnGRHSs EmptyBinds grhss = grhss
+glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty)
+ = GRHSs grhss (binds1 `ThenBinds` binds2) ty
\end{code}
@getMatchLoc@ takes a @Match@ and returns the
-- The type is the *element type* of the expression
-- ParStmts only occur in a list comprehension
- | ParStmt [[Stmt id]] -- List comp only: parallel set of quals
- | ParStmtOut [([id], [Stmt id])] -- PLC after renaming; the ids are the binders
- -- bound by the stmts
-
- -- mdo-notation (only exists after renamer)
- -- The ids are a subset of the variables bound by the stmts that
- -- either (a) are used before they are bound in the stmts
- -- or (b) are used in stmts that follow the RecStmt
- | RecStmt [id]
- [Stmt id]
- [HsExpr id] -- Post type-checking only; these expressions correspond
- -- 1-to-1 with the [id], and are the expresions that should
- -- be returned by the recursion. They may not quite be the
- -- Ids themselves, because the Id may be polymorphic, but
- -- the returned thing has to be monomorphic.
+ | ParStmt [([Stmt id], [id])] -- After remaing, the ids are the binders
+ -- bound by the stmts and used subsequently
+
+ -- Recursive statement
+ | RecStmt [Stmt id]
+ --- The next two fields are only valid after renaming
+ [id] -- The ids are a subset of the variables bound by the stmts
+ -- that are used in stmts that follow the RecStmt
+
+ [id] -- Ditto, but these variables are the "recursive" ones, that
+ -- are used before they are bound in the stmts of the RecStmt
+ -- From a type-checking point of view, these ones have to be monomorphic
+
+ --- This field is only valid after typechecking
+ [HsExpr id] -- These expressions correspond
+ -- 1-to-1 with the "recursive" [id], and are the expresions that
+ -- should be returned by the recursion. They may not quite be the
+ -- Ids themselves, because the Id may be *polymorphic*, but
+ -- the returned thing has to be *monomorphic*.
\end{code}
ExprStmts and ResultStmts are a bit tricky, because what they mean
instance OutputableBndr id => Outputable (Stmt id) where
ppr stmt = pprStmt stmt
-pprStmt (BindStmt pat expr _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
-pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds]
-pprStmt (ExprStmt expr _ _) = ppr expr
-pprStmt (ResultStmt expr _) = ppr expr
-pprStmt (ParStmt stmtss)
- = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
-pprStmt (ParStmtOut stmtss)
- = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
-pprStmt (RecStmt _ segment _) = vcat (map ppr segment)
+pprStmt (BindStmt pat expr _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
+pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds]
+pprStmt (ExprStmt expr _ _) = ppr expr
+pprStmt (ResultStmt expr _) = ppr expr
+pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
+pprStmt (RecStmt segment _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment))
pprDo :: OutputableBndr id => HsStmtContext any -> [Stmt id] -> SDoc
pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
= FunRhs id -- Function binding for f
| CaseAlt -- Guard on a case alternative
| LambdaExpr -- Pattern of a lambda
+ | ProcExpr -- Pattern of a proc
| PatBindRhs -- Pattern binding
| RecUpd -- Record update [used only in DsExpr to tell matchWrapper
-- what sort of runtime error message to generate]
matchSeparator (FunRhs _) = ptext SLIT("=")
matchSeparator CaseAlt = ptext SLIT("->")
matchSeparator LambdaExpr = ptext SLIT("->")
+matchSeparator ProcExpr = ptext SLIT("->")
matchSeparator PatBindRhs = ptext SLIT("=")
matchSeparator (StmtCtxt _) = ptext SLIT("<-")
matchSeparator RecUpd = panic "unused"
pprMatchContext RecUpd = ptext SLIT("a record-update construct")
pprMatchContext PatBindRhs = ptext SLIT("a pattern binding")
pprMatchContext LambdaExpr = ptext SLIT("a lambda abstraction")
+pprMatchContext ProcExpr = ptext SLIT("an arrow abstraction")
pprMatchContext (StmtCtxt ctxt) = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt
pprMatchRhsContext (FunRhs fun) = ptext SLIT("a right-hand side of function") <+> quotes (ppr fun)
pprMatchRhsContext CaseAlt = ptext SLIT("the body of a case alternative")
pprMatchRhsContext PatBindRhs = ptext SLIT("the right-hand side of a pattern binding")
pprMatchRhsContext LambdaExpr = ptext SLIT("the body of a lambda")
+pprMatchRhsContext ProcExpr = ptext SLIT("the body of a proc")
pprMatchRhsContext RecUpd = panic "pprMatchRhsContext"
pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c]
matchContextErrString PatBindRhs = "pattern binding"
matchContextErrString RecUpd = "record update"
matchContextErrString LambdaExpr = "lambda"
+matchContextErrString ProcExpr = "proc"
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) = "pattern guard"
matchContextErrString (StmtCtxt DoExpr) = "'do' expression"
Fixity, NewOrData,
HsModule(..),
- collectStmtsBinders,
+ collectStmtsBinders, collectStmtBinders,
collectHsBinders, collectLocatedHsBinders,
collectMonoBinders, collectLocatedMonoBinders,
collectSigTysFromHsBinds, collectSigTysFromMonoBinds
go (PatMonoBind pat _ loc) acc = collectPatBinders pat ++ acc
go (FunMonoBind f _ _ loc) acc = f : acc
go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
+ go (VarMonoBind v _) acc = v : acc
+ go (AbsBinds _ _ dbinds _ binds) acc
+ = [dp | (_,dp,_) <- dbinds] ++ go binds acc
\end{code}
collectStmtBinders (LetStmt binds) = collectHsBinders binds
collectStmtBinders (ExprStmt _ _ _) = []
collectStmtBinders (ResultStmt _ _) = []
+collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
collectStmtBinders other = panic "collectStmtBinders"
\end{code}
| Opt_FFI
| Opt_PArr -- syntactic support for parallel arrays
| Opt_With -- deprecated keyword for implicit parms
+ | Opt_Arrows -- Arrow-notation syntax
| Opt_Generics
| Opt_NoImplicitPrelude
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.116 2003/06/23 10:35:17 simonpj Exp $
+-- $Id: DriverFlags.hs,v 1.117 2003/06/24 07:58:20 simonpj Exp $
--
-- Driver flags
--
( "fi", Opt_FFI ), -- support `-ffi'...
( "ffi", Opt_FFI ), -- ...and also `-fffi'
( "with", Opt_With ), -- with keyword
+ ( "arrows", Opt_Arrows ), -- arrow syntax
( "parr", Opt_PArr ),
( "allow-overlapping-instances", Opt_AllowOverlappingInstances ),
( "allow-undecidable-instances", Opt_AllowUndecidableInstances ),
_scc_ "Parser" do
buf <- hGetStringBuffer src_filename
- let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
- ffiEF = dopt Opt_FFI dflags,
- withEF = dopt Opt_With dflags,
- parrEF = dopt Opt_PArr dflags}
+ let exts = mkExtFlags dflags
loc = mkSrcLoc (mkFastString src_filename) 1
case parseModule buf (mkPState loc exts) of {
buf <- stringToStringBuffer str
- let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
- ffiEF = dopt Opt_FFI dflags,
- withEF = dopt Opt_With dflags,
- parrEF = dopt Opt_PArr dflags}
+ let exts = mkExtFlags dflags
loc = mkSrcLoc FSLIT("<interactive>") 1
case parseStmt buf (mkPState loc exts) of {
myParseIdentifier dflags str
= do buf <- stringToStringBuffer str
- let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
- ffiEF = dopt Opt_FFI dflags,
- withEF = dopt Opt_With dflags,
- parrEF = dopt Opt_PArr dflags}
+ let exts = mkExtFlags dflags
loc = mkSrcLoc FSLIT("<interactive>") 1
case parseIdentifier buf (mkPState loc exts) of
initOrigNames :: OrigNameCache
initOrigNames = foldl extendOrigNameCache emptyModuleEnv knownKeyNames
+
+mkExtFlags dflags
+ = ExtFlags { glasgowExtsEF = dopt Opt_GlasgowExts dflags,
+ ffiEF = dopt Opt_FFI dflags,
+ withEF = dopt Opt_With dflags,
+ arrowsEF = dopt Opt_Arrows dflags,
+ parrEF = dopt Opt_PArr dflags}
\end{code}
let loc = mkSrcLoc (mkFastString conf_filename) 1
exts = ExtFlags {glasgowExtsEF = False,
ffiEF = False,
+ arrowsEF = False,
withEF = False,
parrEF = False}
case parse buf (mkPState loc exts) of
| ITreifyDecl
| ITreifyFixity
+ -- Arrow notation extension
+ | ITproc
+ | ITrec
+ | IToparenbar -- (|
+ | ITcparenbar -- |)
+ | ITlarrowtail -- -<
+ | ITrarrowtail -- >-
+ | ITLarrowtail -- -<<
+ | ITRarrowtail -- >>-
+
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
deriving Show -- debugging
ghcExtensionKeywordsFM = listToUFM $
map (\(x, y, z) -> (mkFastString x, (y, z)))
[ ( "forall", ITforall, bit glaExtsBit),
+ ( "mdo", ITmdo, bit glaExtsBit),
+ ( "reifyDecl", ITreifyDecl, bit glaExtsBit),
+ ( "reifyType", ITreifyType, bit glaExtsBit),
+ ( "reifyFixity",ITreifyFixity, bit glaExtsBit),
+
+ ( "rec", ITrec, bit glaExtsBit .|. bit arrowsBit),
+
( "foreign", ITforeign, bit ffiBit),
( "export", ITexport, bit ffiBit),
( "label", ITlabel, bit ffiBit),
( "safe", ITsafe, bit ffiBit),
( "threadsafe", ITthreadsafe, bit ffiBit),
( "unsafe", ITunsafe, bit ffiBit),
- ( "with", ITwith, bit withBit),
- ( "mdo", ITmdo, bit glaExtsBit),
( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit),
( "dotnet", ITdotnet, bit ffiBit),
- ( "reifyDecl", ITreifyDecl, bit glaExtsBit),
- ( "reifyType", ITreifyType, bit glaExtsBit),
- ( "reifyFixity",ITreifyFixity, bit glaExtsBit),
+
+ ( "with", ITwith, bit withBit),
+
+ ( "proc", ITproc, bit arrowsBit),
+
+ -- On death row
("_ccall_", ITccall (False, False, PlayRisky),
bit glaExtsBit),
("_ccall_GC_", ITccall (False, False, PlaySafe False),
]
haskellKeySymsFM = listToUFM $
- map (\ (x,y) -> (mkFastString x,y))
- [ ("..", ITdotdot)
- ,(":", ITcolon) -- (:) is a reserved op,
+ map (\ (x,y,z) -> (mkFastString x,(y,z)))
+ [ ("..", ITdotdot, Nothing)
+ ,(":", ITcolon, Nothing) -- (:) is a reserved op,
-- meaning only list cons
- ,("::", ITdcolon)
- ,("=", ITequal)
- ,("\\", ITlam)
- ,("|", ITvbar)
- ,("<-", ITlarrow)
- ,("->", ITrarrow)
- ,("@", ITat)
- ,("~", ITtilde)
- ,("=>", ITdarrow)
- ,("-", ITminus)
- ,("!", ITbang)
- ,("*", ITstar)
- ,(".", ITdot) -- sadly, for 'forall a . t'
+ ,("::", ITdcolon, Nothing)
+ ,("=", ITequal, Nothing)
+ ,("\\", ITlam, Nothing)
+ ,("|", ITvbar, Nothing)
+ ,("<-", ITlarrow, Nothing)
+ ,("->", ITrarrow, Nothing)
+ ,("@", ITat, Nothing)
+ ,("~", ITtilde, Nothing)
+ ,("=>", ITdarrow, Nothing)
+ ,("-", ITminus, Nothing)
+ ,("!", ITbang, Nothing)
+
+ ,("*", ITstar, Just (bit glaExtsBit)) -- For data T (a::*) = MkT
+ ,(".", ITdot, Just (bit glaExtsBit)) -- For 'forall a . t'
+
+ ,("-<", ITlarrowtail, Just (bit arrowsBit))
+ ,(">-", ITrarrowtail, Just (bit arrowsBit))
+ ,("-<<", ITLarrowtail, Just (bit arrowsBit))
+ ,(">>-", ITRarrowtail, Just (bit arrowsBit))
]
\end{code}
case currentChar# buf of
-- special symbols ----------------------------------------------------
- '('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'#
+ '('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'# &&
+ -- Unboxed tules: '(#' but not '(##'
+ not (lookAhead# buf 2# `eqChar#` '#'#)
-> cont IToubxparen (addToCurrentPos buf 2#)
+ -- Arrow notation extension: '(|' but not '(||'
+ | arrowsEnabled exts && lookAhead# buf 1# `eqChar#` '|'# &&
+ not (lookAhead# buf 2# `eqChar#` '|'#)
+ -> cont IToparenbar (addToCurrentPos buf 2#)
| otherwise
-> cont IToparen (incCurrentPos buf)
'}'# | glaExtsEnabled exts -> cont ITccurlybar
(addToCurrentPos buf 2#)
-- MetaHaskell extension
- ']'# | glaExtsEnabled exts -> cont ITcloseQuote (addToCurrentPos buf 2#)
- other -> lex_sym cont (incCurrentPos buf)
+ ']'# | glaExtsEnabled exts -> cont ITcloseQuote (addToCurrentPos buf 2#)
+ -- arrow notation extension
+ ')'# | arrowsEnabled exts -> cont ITcparenbar
+ (addToCurrentPos buf 2#)
+ other -> lex_sym cont exts (incCurrentPos buf)
':'# -> case lookAhead# buf 1# of
']'# | parrEnabled exts -> cont ITcpabrack
(addToCurrentPos buf 2#)
- _ -> lex_sym cont (incCurrentPos buf)
+ _ -> lex_sym cont exts (incCurrentPos buf)
'#'# -> case lookAhead# buf 1# of
-> cont ITcubxparen (addToCurrentPos buf 2#)
'-'# -> case lookAhead# buf 2# of
'}'# -> cont ITclose_prag (addToCurrentPos buf 3#)
- _ -> lex_sym cont (incCurrentPos buf)
- _ -> lex_sym cont (incCurrentPos buf)
+ _ -> lex_sym cont exts (incCurrentPos buf)
+ _ -> lex_sym cont exts (incCurrentPos buf)
'`'# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '`'#
-> lex_cstring cont (addToCurrentPos buf 2#)
((lookAhead# buf 1#) `eqChar#` '('#) -> cont ITparenEscape (addToCurrentPos buf 2#)
c | is_digit c -> lex_num cont exts 0 buf
- | is_symbol c -> lex_sym cont buf
+ | is_symbol c -> lex_sym cont exts buf
| is_upper c -> lex_con cont exts buf
| is_lower c -> lex_id cont exts buf
| otherwise -> lexError "illegal character" buf
}}}
-lex_sym cont buf =
+lex_sym cont exts buf =
-- trace "lex_sym" $
case expandWhile# is_symbol buf of
buf' -> case lookupUFM haskellKeySymsFM lexeme of {
- Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
- cont kwd_token buf' ;
- Nothing -> --trace ("sym: "++unpackFS lexeme) $
- cont (mk_var_token lexeme) buf'
+ Just (kwd_token, Nothing)
+ -> cont kwd_token buf' ;
+ Just (kwd_token, Just validExts)
+ | validExts .&. toInt32 exts /= 0
+ -> cont kwd_token buf' ;
+ other -> cont (mk_var_token lexeme) buf'
}
where lexeme = lexemeToFastString buf'
ffiBit = 1
parrBit = 2
withBit = 3
+arrowsBit = 4
glaExtsEnabled, ffiEnabled, parrEnabled :: Int# -> Bool
glaExtsEnabled flags = testBit (toInt32 flags) glaExtsBit
ffiEnabled flags = testBit (toInt32 flags) ffiBit
withEnabled flags = testBit (toInt32 flags) withBit
parrEnabled flags = testBit (toInt32 flags) parrBit
+arrowsEnabled flags = testBit (toInt32 flags) arrowsBit
toInt32 :: Int# -> Int32
toInt32 x# = fromIntegral (I# x#)
glasgowExtsEF :: Bool,
ffiEF :: Bool,
withEF :: Bool,
- parrEF :: Bool
+ parrEF :: Bool,
+ arrowsEF :: Bool
}
-- create a parse state
|| glasgowExtsEF exts)
.|. withBit `setBitIf` withEF exts
.|. parrBit `setBitIf` parrEF exts
+ .|. arrowsBit `setBitIf` arrowsEF exts
--
setBitIf :: Int -> Bool -> Int32
b `setBitIf` cond | cond = bit b
{- -*-haskell-*-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.119 2003/06/23 10:35:22 simonpj Exp $
+$Id: Parser.y,v 1.120 2003/06/24 07:58:22 simonpj Exp $
Haskell grammar.
'stdcall' { ITstdcallconv }
'ccall' { ITccallconv }
'dotnet' { ITdotnet }
+ 'proc' { ITproc } -- for arrow notation extension
+ 'rec' { ITrec } -- for arrow notation extension
'_ccall_' { ITccall (False, False, PlayRisky) }
'_ccall_GC_' { ITccall (False, False, PlaySafe False) }
'_casm_' { ITccall (False, True, PlayRisky) }
'-' { ITminus }
'!' { ITbang }
'*' { ITstar }
+ '-<' { ITlarrowtail } -- for arrow notation
+ '>-' { ITrarrowtail } -- for arrow notation
+ '-<<' { ITLarrowtail } -- for arrow notation
+ '>>-' { ITRarrowtail } -- for arrow notation
'.' { ITdot }
'{' { ITocurly } -- special symbols
')' { ITcparen }
'(#' { IToubxparen }
'#)' { ITcubxparen }
+ '(|' { IToparenbar }
+ '|)' { ITcparenbar }
';' { ITsemi }
',' { ITcomma }
'`' { ITbackquote }
exp :: { RdrNameHsExpr }
: infixexp '::' sigtype { ExprWithTySig $1 $3 }
| infixexp 'with' dbinding { HsLet (IPBinds $3 True{-not a let-}) $1 }
+ | fexp srcloc '-<' exp { HsArrApp $1 $4 placeHolderType HsFirstOrderApp True $2 }
+ | fexp srcloc '>-' exp { HsArrApp $4 $1 placeHolderType HsFirstOrderApp False $2 }
+ | fexp srcloc '-<<' exp { HsArrApp $1 $4 placeHolderType HsHigherOrderApp True $2 }
+ | fexp srcloc '>>-' exp { HsArrApp $4 $1 placeHolderType HsHigherOrderApp False $2 }
| infixexp { $1 }
infixexp :: { RdrNameHsExpr }
then HsSCC $1 $2
else HsPar $2 }
+ | 'proc' srcloc aexp '->' srcloc exp
+ {% checkPattern $2 $3 `thenP` \ p ->
+ returnP (HsProc p (HsCmdTop $6 [] placeHolderType undefined) $5) }
+
+ | srcloc operator cmdargs { HsArrForm $2 Nothing (reverse $3) $1 }
+
| '{-# CORE' STRING '#-}' exp { HsCoreAnn $2 $4 } -- hdaume: core annotation
| reifyexp { HsReify $1 }
returnP (HsBracket (PatBr p) $1) }
| srcloc '[d|' cvtopbody '|]' { HsBracket (DecBr (mkGroup $3)) $1 }
+cmdargs :: { [RdrNameHsCmdTop] }
+ : cmdargs acmd { HsCmdTop $2 [] placeHolderType undefined : $1 }
+ | {- empty -} { [] }
+
+acmd :: { RdrNameHsExpr }
+ : '(' exp ')' { HsPar $2 }
+ | srcloc operator { HsArrForm $2 Nothing [] $1 }
+
+operator :: { RdrNameHsExpr }
+ : '(|' exp '|)' { $2 }
+
cvtopbody :: { [RdrNameHsDecl] }
: '{' cvtopdecls '}' { $2 }
| layout_on cvtopdecls close { $2 }
| exp ',' exp '..' { ArithSeqIn (FromThen $1 $3) }
| exp '..' exp { ArithSeqIn (FromTo $1 $3) }
| exp ',' exp '..' exp { ArithSeqIn (FromThenTo $1 $3 $5) }
- | exp srcloc pquals {% let { body [qs] = qs;
- body qss = [ParStmt (map reverse qss)] }
- in
- returnP ( mkHsDo ListComp
- (reverse (ResultStmt $1 $2 : body $3))
- $2
- )
+ | exp srcloc pquals { mkHsDo ListComp
+ (reverse (ResultStmt $1 $2 : $3))
+ $2
}
lexps :: { [RdrNameHsExpr] }
-----------------------------------------------------------------------------
-- List Comprehensions
-pquals :: { [[RdrNameStmt]] }
- : pquals '|' quals { $3 : $1 }
+pquals :: { [RdrNameStmt] } -- Either a singleton ParStmt, or a reversed list of Stmts
+ : pquals1 { case $1 of
+ [qs] -> qs
+ qss -> [ParStmt stmtss]
+ where
+ stmtss = [ (reverse qs, undefined)
+ | qs <- qss ]
+ }
+
+pquals1 :: { [[RdrNameStmt]] }
+ : pquals1 '|' quals { $3 : $1 }
| '|' quals { [$2] }
quals :: { [RdrNameStmt] }
(reverse $1) }
| exp '..' exp { PArrSeqIn (FromTo $1 $3) }
| exp ',' exp '..' exp { PArrSeqIn (FromThenTo $1 $3 $5) }
- | exp srcloc pquals {% let {
- body [qs] = qs;
- body qss = [ParStmt
- (map reverse qss)]}
- in
- returnP $
- mkHsDo PArrComp
- (reverse (ResultStmt $1 $2
- : body $3))
- $2
+ | exp srcloc pquals { mkHsDo PArrComp
+ (reverse (ResultStmt $1 $2 : $3))
+ $2
}
-- We are reusing `lexps' and `pquals' from the list case.
returnP (BindStmt p $4 $1) }
| srcloc exp { ExprStmt $2 placeHolderType $1 }
| srcloc 'let' binds { LetStmt $3 }
+ | srcloc 'rec' stmtlist { RecStmt $3 undefined undefined undefined }
-----------------------------------------------------------------------------
-- Record Field Update/Construction
RdrNameGRHS,
RdrNameGRHSs,
RdrNameHsBinds,
+ RdrNameHsCmd,
+ RdrNameHsCmdTop,
RdrNameHsDecl,
RdrNameHsExpr,
RdrNameHsModule,
type RdrNameGRHSs = GRHSs RdrName
type RdrNameHsBinds = HsBinds RdrName
type RdrNameHsExpr = HsExpr RdrName
+type RdrNameHsCmd = HsCmd RdrName
+type RdrNameHsCmdTop = HsCmdTop RdrName
type RdrNameHsModule = HsModule RdrName
type RdrNameIE = IE RdrName
type RdrNameImportDecl = ImportDecl RdrName
-- MonadRec stuff
mfixName,
+ -- Arrow stuff
+ arrAName, composeAName, firstAName,
+ appAName, choiceAName, loopAName,
+
-- Ix stuff
ixClassName,
-- Booleans
andName, orName
+ -- The Either type
+ , eitherTyConName, leftDataConName, rightDataConName
+
-- dotnet interop
, objectTyConName, marshalObjectName, unmarshalObjectName
, marshalStringName, unmarshalStringName, checkDotnetResName
pREL_LIST_Name = mkModuleName "GHC.List"
pREL_PARR_Name = mkModuleName "GHC.PArr"
pREL_TUP_Name = mkModuleName "Data.Tuple"
+pREL_EITHER_Name = mkModuleName "Data.Either"
pREL_PACK_Name = mkModuleName "GHC.Pack"
pREL_CONC_Name = mkModuleName "GHC.Conc"
pREL_IO_BASE_Name = mkModuleName "GHC.IOBase"
pREL_INT_Name = mkModuleName "GHC.Int"
pREL_WORD_Name = mkModuleName "GHC.Word"
mONAD_FIX_Name = mkModuleName "Control.Monad.Fix"
+aRROW_Name = mkModuleName "Control.Arrow"
aDDR_Name = mkModuleName "Addr"
gLA_EXTS_Name = mkModuleName "GHC.Exts"
true_RDR = nameRdrName trueDataConName
and_RDR = nameRdrName andName
+left_RDR = nameRdrName leftDataConName
+right_RDR = nameRdrName rightDataConName
+
error_RDR = nameRdrName errorName
fromEnum_RDR = varQual_RDR pREL_ENUM_Name FSLIT("fromEnum")
eqName = varQual pREL_BASE_Name FSLIT("==") eqClassOpKey
geName = varQual pREL_BASE_Name FSLIT(">=") geClassOpKey
+eitherTyConName = tcQual pREL_EITHER_Name FSLIT("Either") eitherTyConKey
+leftDataConName = dataQual pREL_EITHER_Name FSLIT("Left") leftDataConKey
+rightDataConName = dataQual pREL_EITHER_Name FSLIT("Right") rightDataConKey
+
-- Generics
crossTyConName = tcQual pREL_BASE_Name FSLIT(":*:") crossTyConKey
crossDataConName = dataQual pREL_BASE_Name FSLIT(":*:") crossDataConKey
-- Recursive-do notation
mfixName = varQual mONAD_FIX_Name FSLIT("mfix") mfixIdKey
+-- Arrow notation
+arrAName = varQual aRROW_Name FSLIT("arr") arrAIdKey
+composeAName = varQual aRROW_Name FSLIT(">>>") composeAIdKey
+firstAName = varQual aRROW_Name FSLIT("first") firstAIdKey
+appAName = varQual aRROW_Name FSLIT("app") appAIdKey
+choiceAName = varQual aRROW_Name FSLIT("|||") choiceAIdKey
+loopAName = varQual aRROW_Name FSLIT("loop") loopAIdKey
+
-- dotnet interop
objectTyConName = wTcQual dOTNET_Name FSLIT("Object") objectTyConKey
unmarshalObjectName = varQual dOTNET_Name FSLIT("unmarshalObject") unmarshalObjectIdKey
-- dotnet interop
objectTyConKey = mkPreludeTyConUnique 83
+eitherTyConKey = mkPreludeTyConUnique 84
+
---------------- Template Haskell -------------------
-- USES TyConUniques 100-119
-----------------------------------------------------
-- Data constructor for parallel arrays
parrDataConKey = mkPreludeDataConUnique 24
+
+leftDataConKey = mkPreludeDataConUnique 25
+rightDataConKey = mkPreludeDataConUnique 26
\end{code}
%************************************************************************
-- Recursive do notation
mfixIdKey = mkPreludeMiscIdUnique 118
+-- Arrow notation
+arrAIdKey = mkPreludeMiscIdUnique 119
+composeAIdKey = mkPreludeMiscIdUnique 120 -- >>>
+firstAIdKey = mkPreludeMiscIdUnique 121
+appAIdKey = mkPreludeMiscIdUnique 122
+choiceAIdKey = mkPreludeMiscIdUnique 123 -- |||
+loopAIdKey = mkPreludeMiscIdUnique 124
+
---------------- Template Haskell -------------------
-- USES IdUniques 200-299
-----------------------------------------------------
lookupSyntaxName :: Name -- The standard name
-> RnM (Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
- = getModeRn `thenM` \ mode ->
- if isInterfaceMode mode then
- returnM (std_name, unitFV std_name)
- -- Happens for 'derived' code
- -- where we don't want to rebind
+ = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude ->
+ if not no_prelude then normal_case
else
-
- doptM Opt_NoImplicitPrelude `thenM` \ no_prelude ->
- if not no_prelude then
- returnM (std_name, unitFV std_name) -- Normal case
-
+ getModeRn `thenM` \ mode ->
+ if isInterfaceMode mode then normal_case
+ -- Happens for 'derived' code where we don't want to rebind
else
-- Get the similarly named thing from the local environment
lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
returnM (usr_name, mkFVs [usr_name, std_name])
+ where
+ normal_case = returnM (std_name, unitFV std_name)
+
+lookupSyntaxNames :: [Name] -- Standard names
+ -> RnM (ReboundNames Name, FreeVars) -- See comments with HsExpr.ReboundNames
+lookupSyntaxNames std_names
+ = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude ->
+ if not no_prelude then normal_case
+ else
+ getModeRn `thenM` \ mode ->
+ if isInterfaceMode mode then normal_case
+ else
+ -- Get the similarly named thing from the local environment
+ mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names ->
+
+ returnM (std_names `zip` map HsVar usr_names, mkFVs std_names `plusFV` mkFVs usr_names)
+ where
+ normal_case = returnM (std_names `zip` map HsVar std_names, mkFVs std_names)
\end{code}
foldrName, buildName,
cCallableClassName, cReturnableClassName,
enumClassName,
+ loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
splitName, fstName, sndName, ioDataConName,
replicatePName, mapPName, filterPName,
crossPName, zipPName, toPName,
import UnicodeUtil ( stringToUtf8 )
import UniqFM ( isNullUFM )
import UniqSet ( emptyUniqSet )
-import Util ( isSingleton )
+import Util ( isSingleton, mapAndUnzip )
import List ( intersectBy, unzip4 )
import ListSetOps ( removeDups )
import Outputable
+import SrcLoc ( noSrcLoc )
import FastString
\end{code}
} `thenM_`
-- Generate the rebindable syntax for the monad
- mapAndUnzipM lookupSyntaxName
- (syntax_names do_or_lc) `thenM` \ (monad_names', monad_fvs) ->
+ lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) ->
- returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
- fvs `plusFV` implicit_fvs do_or_lc `plusFV` plusFVs monad_fvs)
+ returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc,
+ fvs `plusFV` implicit_fvs do_or_lc `plusFV` monad_fvs)
where
implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
implicit_fvs ListComp = mkFVs [foldrName, buildName]
implicit_fvs DoExpr = emptyFVs
implicit_fvs MDoExpr = emptyFVs
- syntax_names DoExpr = monadNames
- syntax_names MDoExpr = monadNames ++ [mfixName]
- syntax_names other = []
+ syntax_names = case do_or_lc of
+ DoExpr -> monadNames
+ MDoExpr -> monadNames ++ [mfixName]
+ other -> []
rnExpr (ExplicitList _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
%************************************************************************
%* *
+ Arrow notation
+%* *
+%************************************************************************
+
+\begin{code}
+rnExpr (HsProc pat body src_loc)
+ = addSrcLoc src_loc $
+ rnPatsAndThen ProcExpr [pat] $ \ [pat'] ->
+ rnCmdTop body `thenM` \ (body',fvBody) ->
+ returnM (HsProc pat' body' src_loc, fvBody)
+
+rnExpr (HsArrApp arrow arg _ ho rtl srcloc)
+ = rnExpr arrow `thenM` \ (arrow',fvArrow) ->
+ rnExpr arg `thenM` \ (arg',fvArg) ->
+ returnM (HsArrApp arrow' arg' placeHolderType ho rtl srcloc,
+ fvArrow `plusFV` fvArg)
+
+-- infix form
+rnExpr (HsArrForm op (Just _) [arg1, arg2] srcloc)
+ = rnExpr op `thenM` \ (op'@(HsVar op_name),fv_op) ->
+ rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
+ rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
+
+ -- Deal with fixity
+
+ lookupFixityRn op_name `thenM` \ fixity ->
+ mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
+
+ returnM (final_e,
+ fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
+
+rnExpr (HsArrForm op fixity cmds srcloc)
+ = rnExpr op `thenM` \ (op',fvOp) ->
+ rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
+ returnM (HsArrForm op' fixity cmds' srcloc,
+ fvOp `plusFV` fvCmds)
+
+---------------------------
+-- Deal with fixity (cf mkOpAppRn for the method)
+
+mkOpFormRn :: RenamedHsCmdTop -- Left operand; already rearranged
+ -> RenamedHsExpr -> Fixity -- Operator and fixity
+ -> RenamedHsCmdTop -- Right operand (not an infix)
+ -> RnM RenamedHsCmd
+
+---------------------------
+-- (e11 `op1` e12) `op2` e2
+mkOpFormRn a1@(HsCmdTop (HsArrForm op1 (Just fix1) [a11,a12] loc1) _ _ _) op2 fix2 a2
+ | nofix_error
+ = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
+ returnM (HsArrForm op2 (Just fix2) [a1, a2] loc1)
+
+ | associate_right
+ = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c ->
+ returnM (HsArrForm op1 (Just fix1)
+ [a11, HsCmdTop new_c [] placeHolderType []] loc1)
+ where
+ (nofix_error, associate_right) = compareFixity fix1 fix2
+
+---------------------------
+-- Default case
+mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
+ = returnM (HsArrForm op (Just fix) [arg1, arg2] noSrcLoc)
+
+\end{code}
+
+
+%************************************************************************
+%* *
+ Arrow commands
+%* *
+%************************************************************************
+
+\begin{code}
+rnCmdArgs [] = returnM ([], emptyFVs)
+rnCmdArgs (arg:args)
+ = rnCmdTop arg `thenM` \ (arg',fvArg) ->
+ rnCmdArgs args `thenM` \ (args',fvArgs) ->
+ returnM (arg':args', fvArg `plusFV` fvArgs)
+
+rnCmdTop (HsCmdTop cmd _ _ _)
+ = rnExpr (convertOpFormsCmd cmd) `thenM` \ (cmd', fvCmd) ->
+ let
+ cmd_names = [arrAName, composeAName, firstAName] ++
+ nameSetToList (methodNamesCmd cmd')
+ in
+ -- Generate the rebindable syntax for the monad
+ lookupSyntaxNames cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
+
+ returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
+ fvCmd `plusFV` cmd_fvs)
+
+---------------------------------------------------
+-- convert OpApp's in a command context to HsArrForm's
+
+convertOpFormsCmd :: HsCmd id -> HsCmd id
+
+convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
+
+convertOpFormsCmd (OpApp c1 op fixity c2)
+ = let
+ arg1 = HsCmdTop (convertOpFormsCmd c1) [] placeHolderType []
+ arg2 = HsCmdTop (convertOpFormsCmd c2) [] placeHolderType []
+ in
+ HsArrForm op (Just fixity) [arg1, arg2] noSrcLoc
+
+convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsCmd c)
+
+convertOpFormsCmd (HsCase exp matches locn)
+ = HsCase exp (map convertOpFormsMatch matches) locn
+
+convertOpFormsCmd (HsIf exp c1 c2 locn)
+ = HsIf exp (convertOpFormsCmd c1) (convertOpFormsCmd c2) locn
+
+convertOpFormsCmd (HsLet binds cmd)
+ = HsLet binds (convertOpFormsCmd cmd)
+
+convertOpFormsCmd (HsDo ctxt stmts ids ty locn)
+ = HsDo ctxt (map convertOpFormsStmt stmts) ids ty locn
+
+-- Anything else is unchanged. This includes HsArrForm (already done),
+-- things with no sub-commands, and illegal commands (which will be
+-- caught by the type checker)
+convertOpFormsCmd c = c
+
+convertOpFormsStmt (BindStmt pat cmd locn)
+ = BindStmt pat (convertOpFormsCmd cmd) locn
+convertOpFormsStmt (ResultStmt cmd locn)
+ = ResultStmt (convertOpFormsCmd cmd) locn
+convertOpFormsStmt (ExprStmt cmd ty locn)
+ = ExprStmt (convertOpFormsCmd cmd) ty locn
+convertOpFormsStmt (RecStmt stmts lvs rvs es)
+ = RecStmt (map convertOpFormsStmt stmts) lvs rvs es
+convertOpFormsStmt stmt = stmt
+
+convertOpFormsMatch (Match pat mty grhss)
+ = Match pat mty (convertOpFormsGRHSs grhss)
+
+convertOpFormsGRHSs (GRHSs grhss binds ty)
+ = GRHSs (map convertOpFormsGRHS grhss) binds ty
+
+convertOpFormsGRHS (GRHS stmts locn)
+ = let
+ (ResultStmt cmd locn') = last stmts
+ in
+ GRHS (init stmts ++ [ResultStmt (convertOpFormsCmd cmd) locn']) locn
+
+---------------------------------------------------
+type CmdNeeds = FreeVars -- Only inhabitants are
+ -- appAName, choiceAName, loopAName
+
+-- find what methods the Cmd needs (loop, choice, apply)
+methodNamesCmd :: HsCmd Name -> CmdNeeds
+
+methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl _srcloc)
+ = emptyFVs
+methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl _srcloc)
+ = unitFV appAName
+methodNamesCmd cmd@(HsArrForm {}) = emptyFVs
+
+methodNamesCmd (HsPar c) = methodNamesCmd c
+
+methodNamesCmd (HsIf p c1 c2 loc)
+ = methodNamesCmd c1 `plusFV` methodNamesCmd c2 `addOneFV` choiceAName
+
+methodNamesCmd (HsLet b c) = methodNamesCmd c
+
+methodNamesCmd (HsDo sc stmts rbs ty loc) = methodNamesStmts stmts
+
+methodNamesCmd (HsLam match) = methodNamesMatch match
+
+methodNamesCmd (HsCase scrut matches loc)
+ = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName
+
+methodNamesCmd other = emptyFVs
+ -- Other forms can't occur in commands, but it's not convenient
+ -- to error here so we just do what's convenient.
+ -- The type checker will complain later
+
+---------------------------------------------------
+methodNamesMatch (Match pats sig_ty grhss) = methodNamesGRHSs grhss
+
+-------------------------------------------------
+methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss)
+
+-------------------------------------------------
+methodNamesGRHS (GRHS stmts loc) = methodNamesStmt (last stmts)
+
+---------------------------------------------------
+methodNamesStmts stmts = plusFVs (map methodNamesStmt stmts)
+
+---------------------------------------------------
+methodNamesStmt (ResultStmt cmd loc) = methodNamesCmd cmd
+methodNamesStmt (ExprStmt cmd ty loc) = methodNamesCmd cmd
+methodNamesStmt (BindStmt pat cmd loc) = methodNamesCmd cmd
+methodNamesStmt (RecStmt stmts lvs rvs es)
+ = methodNamesStmts stmts `addOneFV` loopAName
+methodNamesStmt (LetStmt b) = emptyFVs
+methodNamesStmt (ParStmt ss) = emptyFVs
+ -- ParStmt can't occur in commands, but it's not convenient to error
+ -- here so we just do what's convenient
+\end{code}
+
+
+%************************************************************************
+%* *
Arithmetic sequences
%* *
%************************************************************************
rnNormalStmts ctxt (ParStmt stmtss : stmts)
= doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
checkM opt_GlasgowExts parStmtErr `thenM_`
- mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss `thenM` \ (stmtss', fv_stmtss) ->
+ mapFvRn rn_branch stmtss `thenM` \ (stmtss', fv_stmtss) ->
let
- bndrss = map collectStmtsBinders stmtss'
+ bndrss :: [[Name]] -- NB: Name, not RdrName
+ bndrss = map collectStmtsBinders stmtss'
+ (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
in
- foldlM checkBndrs [] bndrss `thenM` \ new_binders ->
- bindLocalNamesFV new_binders $
+ mappM dupErr dups `thenM` \ _ ->
+ bindLocalNamesFV bndrs $
-- Note: binders are returned in scope order, so one may
-- shadow the next; e.g. x <- xs; x <- ys
rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
- returnM (ParStmtOut (bndrss `zip` stmtss') : stmts',
+
+ -- Cut down the exported binders to just the ones neede in the body
+ let
+ used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
+ in
+ returnM (ParStmt (stmtss' `zip` used_bndrs_s) : stmts',
fv_stmtss `plusFV` fvs)
where
- checkBndrs all_bndrs bndrs
- = checkErr (null common) (err (head common)) `thenM_`
- returnM (bndrs ++ all_bndrs)
- where
- common = intersectBy eqOcc all_bndrs bndrs
+ rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts
- eqOcc n1 n2 = nameOccName n1 == nameOccName n2
- err v = ptext SLIT("Duplicate binding in parallel list comprehension for:")
- <+> quotes (ppr v)
+ cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
+ dupErr (v:_) = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
+ <+> quotes (ppr v))
-rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
+rnNormalStmts ctxt (RecStmt rec_stmts _ _ _ : stmts)
+ = bindLocalsRn doc (collectStmtsBinders rec_stmts) $ \ _ ->
+ rn_rec_stmts rec_stmts `thenM` \ segs ->
+ rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
+ let
+ segs_w_fwd_refs = addFwdRefs segs
+ (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
+ later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
+ fwd_vars = nameSetToList (plusFVs fs)
+ uses = plusFVs us
+ in
+ returnM (RecStmt rec_stmts' later_vars fwd_vars [] : stmts', uses `plusFV` fvs)
+ where
+ doc = text "In a recursive do statement"
\end{code}
%************************************************************************
%* *
-\subsubsection{Precedence Parsing}
+\subsubsection{mdo expressions}
%* *
%************************************************************************
\begin{code}
type FwdRefs = NameSet
-type Segment = (Defs,
- Uses, -- May include defs
- FwdRefs, -- A subset of uses that are
+type Segment stmts = (Defs,
+ Uses, -- May include defs
+ FwdRefs, -- A subset of uses that are
-- (a) used before they are bound in this segment, or
-- (b) used here, and bound in subsequent segments
- [RenamedStmt])
+ stmts) -- Either Stmt or [Stmt]
+
----------------------------------------------------
rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
rnMDoStmts stmts
= -- Step1: bring all the binders of the mdo into scope
+ -- Remember that this also removes the binders from the
+ -- finally-returned free-vars
bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
-- Step 2: Rename each individual stmt, making a
-- singleton segment. At this stage the FwdRefs field
-- isn't finished: it's empty for all except a BindStmt
-- for which it's the fwd refs within the bind itself
- mappM rn_mdo_stmt stmts `thenM` \ segs ->
+ -- (This set may not be empty, because we're in a recursive
+ -- context.)
+ rn_rec_stmts stmts `thenM` \ segs ->
let
-- Step 3: Fill in the fwd refs.
-- The segments are all singletons, but their fwd-ref
where
doc = text "In a mdo-expression"
+
----------------------------------------------------
-rn_mdo_stmt :: RdrNameStmt -> RnM Segment
+rn_rec_stmt :: RdrNameStmt -> RnM [Segment RenamedStmt]
+ -- Rename a Stmt that is inside a RecStmt (or mdo)
-- Assumes all binders are already in scope
-- Turns each stmt into a singleton Stmt
-rn_mdo_stmt (ExprStmt expr _ src_loc)
+rn_rec_stmt (ExprStmt expr _ src_loc)
= addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
- returnM (emptyNameSet, fvs, emptyNameSet,
- [ExprStmt expr' placeHolderType src_loc])
+ returnM [(emptyNameSet, fvs, emptyNameSet,
+ ExprStmt expr' placeHolderType src_loc)]
-rn_mdo_stmt (ResultStmt expr src_loc)
+rn_rec_stmt (ResultStmt expr src_loc)
= addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
- returnM (emptyNameSet, fvs, emptyNameSet,
- [ResultStmt expr' src_loc])
+ returnM [(emptyNameSet, fvs, emptyNameSet,
+ ResultStmt expr' src_loc)]
-rn_mdo_stmt (BindStmt pat expr src_loc)
+rn_rec_stmt (BindStmt pat expr src_loc)
= addSrcLoc src_loc $
rnExpr expr `thenM` \ (expr', fv_expr) ->
rnPat pat `thenM` \ (pat', fv_pat) ->
bndrs = mkNameSet (collectPatBinders pat')
fvs = fv_expr `plusFV` fv_pat
in
- returnM (bndrs, fvs, bndrs `intersectNameSet` fvs,
- [BindStmt pat' expr' src_loc])
+ returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
+ BindStmt pat' expr' src_loc)]
-rn_mdo_stmt (LetStmt binds)
+rn_rec_stmt (LetStmt binds)
= rnBinds binds `thenM` \ (binds', du_binds) ->
- returnM (duDefs du_binds, duUses du_binds,
- emptyNameSet, [LetStmt binds'])
+ returnM [(duDefs du_binds, duUses du_binds,
+ emptyNameSet, LetStmt binds')]
+
+rn_rec_stmt (RecStmt stmts _ _ _) -- Flatten Rec inside Rec
+ = rn_rec_stmts stmts
+
+rn_rec_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo
+ = pprPanic "rn_rec_stmt" (ppr stmt)
-rn_mdo_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo
- = pprPanic "rn_mdo_stmt" (ppr stmt)
+---------------------------------------------
+rn_rec_stmts :: [RdrNameStmt] -> RnM [Segment RenamedStmt]
+rn_rec_stmts stmts = mappM rn_rec_stmt stmts `thenM` \ segs_s ->
+ returnM (concat segs_s)
-addFwdRefs :: [Segment] -> [Segment]
+---------------------------------------------
+addFwdRefs :: [Segment a] -> [Segment a]
-- So far the segments only have forward refs *within* the Stmt
-- (which happens for bind: x <- ...x...)
-- This function adds the cross-seg fwd ref info
addFwdRefs pairs
= fst (foldr mk_seg ([], emptyNameSet) pairs)
where
- mk_seg (defs, uses, fwds, stmts) (segs, seg_defs)
+ mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
= (new_seg : segs, all_defs)
where
new_seg = (defs, uses, new_fwds, stmts)
- all_defs = seg_defs `unionNameSets` defs
- new_fwds = fwds `unionNameSets` (uses `intersectNameSet` seg_defs)
+ all_defs = later_defs `unionNameSets` defs
+ new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
-- Add the downstream fwd refs here
----------------------------------------------------
-- q <- x ; z <- y } ;
-- r <- x }
-glomSegments :: [Segment] -> [Segment]
+glomSegments :: [Segment RenamedStmt] -> [Segment [RenamedStmt]]
-glomSegments [seg] = [seg]
-glomSegments ((defs,uses,fwds,stmts) : segs)
+glomSegments [] = []
+glomSegments ((defs,uses,fwds,stmt) : segs)
-- Actually stmts will always be a singleton
= (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
where
seg_defs = plusFVs ds `plusFV` defs
seg_uses = plusFVs us `plusFV` uses
seg_fwds = plusFVs fs `plusFV` fwds
- seg_stmts = stmts ++ concat ss
+ seg_stmts = stmt : concat ss
grab :: NameSet -- The client
- -> [Segment]
- -> ([Segment], -- Needed by the 'client'
- [Segment]) -- Not needed by the client
+ -> [Segment a]
+ -> ([Segment a], -- Needed by the 'client'
+ [Segment a]) -- Not needed by the client
-- The result is simply a split of the input
grab uses dus
= (reverse yeses, reverse noes)
----------------------------------------------------
-segsToStmts :: [Segment] -> ([RenamedStmt], FreeVars)
+segsToStmts :: [Segment [RenamedStmt]] -> ([RenamedStmt], FreeVars)
segsToStmts [] = ([], emptyFVs)
segsToStmts ((defs, uses, fwds, ss) : segs)
where
(later_stmts, later_uses) = segsToStmts segs
new_stmt | non_rec = head ss
- | otherwise = RecStmt rec_names ss []
+ | otherwise = RecStmt ss (nameSetToList used_later) (nameSetToList fwds) []
where
- non_rec = isSingleton ss && isEmptyNameSet fwds
- rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
- -- The names for the fixpoint are
- -- (a) the ones needed after the RecStmt
- -- (b) the forward refs within the fixpoint
+ non_rec = isSingleton ss && isEmptyNameSet fwds
+ used_later = defs `intersectNameSet` later_uses
+ -- The ones needed after the RecStmt
\end{code}
%************************************************************************
where
exts = ExtFlags {glasgowExtsEF = True,
ffiEF = True,
+ arrowsEF = True,
withEF = True,
parrEF = True}
loc = mkSrcLoc (mkFastString file_path) 1
type RenamedStmt = Stmt Name
type RenamedFixitySig = FixitySig Name
type RenamedDeprecation = DeprecDecl Name
+type RenamedHsCmd = HsCmd Name
+type RenamedHsCmdTop = HsCmdTop Name
\end{code}
%************************************************************************
| fi /= fromIntegerName -- Do not generate a LitInst for rebindable
-- syntax. Reason: tcSyntaxName does unification
-- which is very inconvenient in tcSimplify
- = tcSyntaxName orig expected_ty fromIntegerName fi `thenM` \ (expr, _) ->
+ = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
returnM (HsApp expr (HsLit (HsInteger i)))
| Just expr <- shortCutIntLit i expected_ty
newOverloadedLit orig lit@(HsFractional r fr) expected_ty
| fr /= fromRationalName -- c.f. HsIntegral case
- = tcSyntaxName orig expected_ty fromRationalName fr `thenM` \ (expr, _) ->
- mkRatLit r `thenM` \ rat_lit ->
+ = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
+ mkRatLit r `thenM` \ rat_lit ->
returnM (HsApp expr rat_lit)
| Just expr <- shortCutFracLit r expected_ty
\begin{code}
tcSyntaxName :: InstOrigin
-> TcType -- Type to instantiate it at
- -> Name -> Name -- (Standard name, user name)
- -> TcM (TcExpr, TcType) -- Suitable expression with its type
+ -> (Name, HsExpr Name) -- (Standard name, user name)
+ -> TcM (Name, TcExpr) -- (Standard name, suitable expression)
-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
-- So we do not call it from lookupInst, which is called from tcSimplify
-tcSyntaxName orig ty std_nm user_nm
+tcSyntaxName orig ty (std_nm, HsVar user_nm)
| std_nm == user_nm
= newMethodFromName orig ty std_nm `thenM` \ id ->
- returnM (HsVar id, idType id)
+ returnM (std_nm, HsVar id)
- | otherwise
+tcSyntaxName orig ty (std_nm, user_nm_expr)
= tcLookupId std_nm `thenM` \ std_id ->
let
-- C.f. newMethodAtLoc
-- Actually, the "tau-type" might be a sigma-type in the
-- case of locally-polymorphic methods.
in
- addErrCtxtM (syntaxNameCtxt user_nm orig tau1) $
- tcCheckSigma (HsVar user_nm) tau1 `thenM` \ user_fn ->
- returnM (user_fn, tau1)
+ addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
+ tcCheckSigma user_nm_expr tau1 `thenM` \ expr ->
+ returnM (std_nm, expr)
syntaxNameCtxt name orig ty tidy_env
= getInstLoc orig `thenM` \ inst_loc ->
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section{Typecheck arrow notation}
+
+\begin{code}
+module TcArrows ( tcProc ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} TcExpr( tcCheckRho )
+
+import HsSyn
+import TcHsSyn ( TcCmd, TcCmdTop, TcExpr, TcPat, mkHsLet )
+
+import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts )
+
+import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp,
+ mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType )
+import TcMType ( newTyVar, newTyVarTy, newTyVarTys, newSigTyVar, zonkTcType )
+import TcBinds ( tcBindsAndThen )
+import TcSimplify ( tcSimplifyCheck )
+import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo )
+import TcRnMonad
+import Inst ( tcSyntaxName )
+import TysWiredIn ( boolTy, pairTyCon )
+import VarSet
+import Type ( Kind,
+ mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes )
+import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedHsCmd, RenamedHsCmdTop )
+
+import Outputable
+import Util ( lengthAtLeast )
+
+\end{code}
+
+%************************************************************************
+%* *
+ Proc
+%* *
+%************************************************************************
+
+\begin{code}
+tcProc :: RenamedPat -> RenamedHsCmdTop -- proc pat -> expr
+ -> Expected TcRhoType -- Expected type of whole proc expression
+ -> TcM (TcPat, TcCmdTop)
+
+tcProc pat cmd exp_ty
+ = do { arr_ty <- newTyVarTy arrowTyConKind
+ ; [arg_ty, res_ty] <- newTyVarTys 2 liftedTypeKind
+ ; zapExpectedTo exp_ty (mkAppTys arr_ty [arg_ty,res_ty])
+
+ ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
+ ; ([pat'], cmd', ex_binds) <- incProcLevel $
+ tcMatchPats [(pat, Check arg_ty)] (Check res_ty) $
+ tcCmdTop cmd_env cmd ([], res_ty)
+
+ ; return (pat', glueBindsOnCmd ex_binds cmd') }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Commands
+%* *
+%************************************************************************
+
+\begin{code}
+type CmdStack = [TcTauType]
+data CmdEnv = CmdEnv { cmd_arr :: TcType } -- The arrow type constructor, of kind *->*->*
+
+mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
+mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
+
+---------------------------------------
+tcCmdTop :: CmdEnv
+ -> RenamedHsCmdTop
+ -> (CmdStack, TcTauType) -- Expected result type; always a monotype
+ -- We know exactly how many cmd args are expected,
+ -- albeit perhaps not their types; so we can pass
+ -- in a CmdStack
+ -> TcM TcCmdTop
+
+tcCmdTop env (HsCmdTop cmd _ _ names) (cmd_stk, res_ty)
+ = do { cmd' <- tcCmd env cmd (cmd_stk, res_ty)
+ ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
+ ; return (HsCmdTop cmd' cmd_stk res_ty names') }
+
+
+----------------------------------------
+tcCmd :: CmdEnv -> RenamedHsExpr -> (CmdStack, TcTauType) -> TcM TcExpr
+ -- The main recursive function
+
+tcCmd env (HsPar cmd) res_ty
+ = do { cmd' <- tcCmd env cmd res_ty
+ ; return (HsPar cmd') }
+
+tcCmd env (HsLet binds body) res_ty
+ = tcBindsAndThen HsLet binds $
+ tcCmd env body res_ty
+
+tcCmd env (HsIf pred b1 b2 src_loc) res_ty
+ = addSrcLoc src_loc $
+ do { pred' <- tcCheckRho pred boolTy
+ ; b1' <- tcCmd env b1 res_ty
+ ; b2' <- tcCmd env b2 res_ty
+ ; return (HsIf pred' b1' b2' src_loc)
+ }
+
+-------------------------------------------
+-- Arrow application
+-- (f -< a) or (f =< a)
+
+tcCmd env cmd@(HsArrApp fun arg _ ho_app lr src_loc) (cmd_stk, res_ty)
+ = addSrcLoc src_loc $
+ addErrCtxt (cmdCtxt cmd) $
+ do { arg_ty <- newTyVarTy openTypeKind
+ ; let fun_ty = mkCmdArrTy env arg_ty res_ty
+
+ ; checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
+
+ ; fun' <- pop_arrow_binders (tcCheckRho fun fun_ty)
+
+ ; arg' <- tcCheckRho arg arg_ty
+
+ ; return (HsArrApp fun' arg' fun_ty ho_app lr src_loc) }
+ where
+ -- Before type-checking f, remove the "arrow binders" from the
+ -- environment in the (-<) case.
+ -- Local bindings, inside the enclosing proc, are not in scope
+ -- inside f. In the higher-order case (--<), they are.
+ pop_arrow_binders tc = case ho_app of
+ HsHigherOrderApp -> tc
+ HsFirstOrderApp -> popArrowBinders tc
+
+
+-------------------------------------------
+-- Lambda
+
+tcCmd env cmd@(HsLam match@(Match pats maybe_rhs_sig grhss)) (cmd_stk, res_ty)
+ = addSrcLoc (getMatchLoc match) $
+ addErrCtxt (matchCtxt match_ctxt match) $
+
+ do { -- Check the cmd stack is big enough
+ ; checkTc (lengthAtLeast cmd_stk n_pats)
+ (kappaUnderflow cmd)
+ ; let pats_w_tys = zip pats (map Check cmd_stk)
+
+ -- Check the patterns, and the GRHSs inside
+ ; (pats', grhss', ex_binds) <- tcMatchPats pats_w_tys (Check res_ty) $
+ tc_grhss grhss
+
+ ; return (HsLam (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss')))
+ }
+
+ where
+ n_pats = length pats
+ stk' = drop n_pats cmd_stk
+ match_ctxt = LambdaExpr -- Maybe KappaExpr?
+
+ tc_grhss (GRHSs grhss binds _)
+ = tcBindsAndThen glueBindsOnGRHSs binds $
+ do { grhss' <- mappM tc_grhs grhss
+ ; return (GRHSs grhss' EmptyBinds res_ty) }
+
+ stmt_ctxt = SC { sc_what = PatGuard match_ctxt,
+ sc_rhs = tcCheckRho,
+ sc_body = \ body -> tcCmd env body (stk', res_ty),
+ sc_ty = res_ty } -- ToDo: Is this right?
+ tc_grhs (GRHS guarded locn)
+ = addSrcLoc locn $
+ do { guarded' <- tcStmts stmt_ctxt guarded
+ ; return (GRHS guarded' locn) }
+
+-------------------------------------------
+-- Do notation
+
+tcCmd env cmd@(HsDo do_or_lc stmts _ ty src_loc) (cmd_stk, res_ty)
+ = do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
+ ; stmts' <- tcStmts stmt_ctxt stmts
+ ; return (HsDo do_or_lc stmts' [] res_ty src_loc) }
+ -- The 'methods' needed for the HsDo are in the enclosing HsCmd
+ -- hence the empty list here
+ where
+ stmt_ctxt = SC { sc_what = do_or_lc,
+ sc_rhs = tc_rhs,
+ sc_body = tc_ret,
+ sc_ty = res_ty }
+
+ tc_rhs rhs ty = tcCmd env rhs ([], ty)
+ tc_ret body = tcCmd env body ([], res_ty)
+
+
+-----------------------------------------------------------------
+-- Arrow ``forms'' (| e |) c1 .. cn
+--
+-- G |-b c : [s1 .. sm] s
+-- pop(G) |- e : forall w. b ((w,s1) .. sm) s
+-- -> a ((w,t1) .. tn) t
+-- e \not\in (s, s1..sm, t, t1..tn)
+-- ----------------------------------------------
+-- G |-a (| e |) c : [t1 .. tn] t
+
+tcCmd env cmd@(HsArrForm expr fixity cmd_args src_loc) (cmd_stk, res_ty)
+ = addSrcLoc src_loc $
+ addErrCtxt (cmdCtxt cmd) $
+ do { cmds_w_tys <- mapM new_cmd_ty (cmd_args `zip` [1..])
+ ; w_tv <- newSigTyVar liftedTypeKind
+ ; let w_ty = mkTyVarTy w_tv
+
+ -- a ((w,t1) .. tn) t
+ ; let e_res_ty = mkCmdArrTy env (foldl mkPairTy w_ty cmd_stk) res_ty
+
+ -- b ((w,s1) .. sm) s
+ -- -> a ((w,t1) .. tn) t
+ ; let e_ty = mkFunTys [mkAppTys b [tup,s] | (_,_,b,tup,s) <- cmds_w_tys]
+ e_res_ty
+
+ -- Check expr
+ ; (expr', lie) <- getLIE (tcCheckRho expr e_ty)
+ ; inst_binds <- tcSimplifyCheck sig_msg [w_tv] [] lie
+
+ -- Check that the polymorphic variable hasn't been unified with anything
+ -- and is not free in res_ty or the cmd_stk (i.e. t, t1..tn)
+ ; [w_tv'] <- checkSigTyVarsWrt (tyVarsOfTypes (res_ty:cmd_stk))
+ [w_tv]
+
+ -- OK, now we are in a position to unscramble
+ -- the s1..sm and check each cmd
+ ; cmds' <- mapM (tc_cmd w_tv') cmds_w_tys
+
+ ; returnM (HsArrForm (TyLam [w_tv'] (mkHsLet inst_binds expr')) fixity cmds' src_loc)
+ }
+ where
+ -- Make the types
+ -- b, ((e,s1) .. sm), s
+ new_cmd_ty :: (RenamedHsCmdTop, Int)
+ -> TcM (RenamedHsCmdTop, Int, TcType, TcType, TcType)
+ new_cmd_ty (cmd,i)
+ = do { b_ty <- newTyVarTy arrowTyConKind
+ ; tup_ty <- newTyVarTy liftedTypeKind
+ -- We actually make a type variable for the tuple
+ -- because we don't know how deeply nested it is yet
+ ; s_ty <- newTyVarTy liftedTypeKind
+ ; return (cmd, i, b_ty, tup_ty, s_ty)
+ }
+
+ tc_cmd w_tv (cmd, i, b, tup_ty, s)
+ = do { tup_ty' <- zonkTcType tup_ty
+ ; let (corner_ty, arg_tys) = unscramble tup_ty'
+
+ -- Check that it has the right shape:
+ -- ((w,s1) .. sn)
+ -- where the si do not mention w
+ ; checkTc (corner_ty `tcEqType` mkTyVarTy w_tv &&
+ not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
+ (badFormFun i tup_ty')
+
+ ; tcCmdTop (CmdEnv { cmd_arr = b }) cmd (arg_tys, s) }
+
+ unscramble :: TcType -> (TcType, [TcType])
+ -- unscramble ((w,s1) .. sn) = (w, [s1..sn])
+ unscramble ty
+ = case tcSplitTyConApp_maybe ty of
+ Just (tc, [t,s]) | tc == pairTyCon
+ -> let
+ (w,ss) = unscramble t
+ in (w, s:ss)
+
+ other -> (ty, [])
+
+ sig_msg = ptext SLIT("expected type of a command form")
+
+-----------------------------------------------------------------
+-- Base case for illegal commands
+-- This is where expressions that aren't commands get rejected
+
+tcCmd env cmd _
+ = failWithTc (vcat [ptext SLIT("The expression"), nest 2 (ppr cmd),
+ ptext SLIT("was found where an arrow command was expected")])
+\end{code}
+
+
+%************************************************************************
+%* *
+ Helpers
+%* *
+%************************************************************************
+
+
+\begin{code}
+glueBindsOnCmd EmptyBinds cmd = cmd
+glueBindsOnCmd binds (HsCmdTop cmd stk res_ty names) = HsCmdTop (HsLet binds cmd) stk res_ty names
+ -- Existential bindings become local bindings in the command
+
+
+mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
+
+arrowTyConKind :: Kind -- *->*->*
+arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
+\end{code}
+
+
+%************************************************************************
+%* *
+ Errors
+%* *
+%************************************************************************
+
+\begin{code}
+cmdCtxt cmd = ptext SLIT("In the command:") <+> ppr cmd
+
+nonEmptyCmdStkErr cmd
+ = hang (ptext SLIT("Non-empty command stack at command:"))
+ 4 (ppr cmd)
+
+kappaUnderflow cmd
+ = hang (ptext SLIT("Command stack underflow at command:"))
+ 4 (ppr cmd)
+
+badFormFun i tup_ty'
+ = hang (ptext SLIT("The type of the") <+> speakNth i <+> ptext SLIT("argument of a command form has the wrong shape"))
+ 4 (ptext SLIT("Argument type:") <+> ppr tup_ty')
+\end{code}
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendLocalValEnv, tcExtendLocalValEnv2,
tcLookup, tcLookupLocalIds, tcLookup_maybe,
- tcLookupId, tcLookupIdLvl,
+ tcLookupId,
lclEnvElts, getInLocalScope, findGlobals,
-- Instance environment
tcGetGlobalTyVars,
-- Template Haskell stuff
- checkWellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
+ checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
topIdLvl,
+ -- Arrow stuff
+ checkProcLevel,
+
-- New Ids
newLocalName, newDFunName,
%************************************************************************
%* *
+ 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
%* *
%************************************************************************
\begin{code}
-instance Outputable Stage where
+instance Outputable ThStage where
ppr Comp = text "Comp"
ppr (Brack l _ _) = text "Brack" <+> int l
ppr (Splice l) = text "Splice" <+> int l
-metaLevel :: Stage -> Level
-metaLevel Comp = topLevel
-metaLevel (Splice l) = l
-metaLevel (Brack l _ _) = l
+thLevel :: ThStage -> ThLevel
+thLevel Comp = topLevel
+thLevel (Splice l) = l
+thLevel (Brack l _ _) = l
checkWellStaged :: SDoc -- What the stage check is for
- -> Level -- Binding level
- -> Stage -- Use stage
+ -> ThLevel -- Binding level
+ -> ThStage -- Use stage
-> TcM () -- Fail if badly staged, adding an error
checkWellStaged pp_thing bind_lvl use_stage
| bind_lvl <= use_lvl -- OK!
hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
ptext SLIT("but used at stage") <+> ppr use_lvl]
where
- use_lvl = metaLevel use_stage
+ use_lvl = thLevel use_stage
-topIdLvl :: Id -> Level
+topIdLvl :: Id -> ThLevel
-- Globals may either be imported, or may be from an earlier "chunk"
-- (separated by declaration splices) of this module. The former
-- *can* be used inside a top-level splice, but the latter cannot.
| otherwise = impLevel
-- Indicates the legal transitions on bracket( [| |] ).
-bracketOK :: Stage -> Maybe Level
+bracketOK :: ThStage -> Maybe ThLevel
bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
-bracketOK stage = (Just (metaLevel stage + 1))
+bracketOK stage = (Just (thLevel stage + 1))
-- Indicates the legal transitions on splice($).
-spliceOK :: Stage -> Maybe Level
+spliceOK :: ThStage -> Maybe ThLevel
spliceOK (Splice _) = Nothing -- Splice illegal inside splice
-spliceOK stage = Just (metaLevel stage - 1)
+spliceOK stage = Just (thLevel stage - 1)
tcMetaTy :: Name -> TcM Type
-- Given the name of a Template Haskell data type,
tcLookupId name
= tcLookup name `thenM` \ thing ->
case thing of
- ATcId tc_id lvl -> returnM tc_id
+ ATcId tc_id _ _ -> returnM tc_id
AGlobal (AnId id) -> returnM id
other -> pprPanic "tcLookupId" (ppr name)
-tcLookupIdLvl :: Name -> TcM (Id, Level)
--- DataCons dealt with separately
-tcLookupIdLvl name
- = tcLookup name `thenM` \ thing ->
- case thing of
- ATcId tc_id lvl -> returnM (tc_id, lvl)
- AGlobal (AnId id) -> returnM (id, topIdLvl id)
- other -> pprPanic "tcLookupIdLvl" (ppr name)
-
tcLookupLocalIds :: [Name] -> TcM [TcId]
-- We expect the variables to all be bound, and all at
-- the same level as the lookup. Only used in one place...
tcLookupLocalIds ns
= getLclEnv `thenM` \ env ->
- returnM (map (lookup (tcl_env env) (metaLevel (tcl_level env))) ns)
+ returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) 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)
= getLclEnv `thenM` \ env ->
let
extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids]
- lvl = metaLevel (tcl_level env)
- extra_env = [(idName id, ATcId id lvl) | id <- ids]
+ th_lvl = thLevel (tcl_th_ctxt env)
+ proc_lvl = proc_level (tcl_arrow_ctxt env)
+ extra_env = [(idName id, ATcId id th_lvl proc_lvl) | id <- ids]
le' = extendNameEnvList (tcl_env env) extra_env
in
tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
= getLclEnv `thenM` \ env ->
let
extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
- lvl = metaLevel (tcl_level env)
- extra_env = [(name, ATcId id lvl) | (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]
le' = extendNameEnvList (tcl_env env) extra_env
in
tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
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)
import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
import HsSyn ( HsReify(..), ReifyFlavour(..) )
import TcType ( isTauTy )
-import TcEnv ( bracketOK, tcMetaTy, checkWellStaged, metaLevel )
+import TcEnv ( bracketOK, tcMetaTy, checkWellStaged )
import Name ( isExternalName )
import qualified DsMeta
#endif
instToId, tcInstCall, tcInstDataCon
)
import TcBinds ( tcBindsAndThen )
-import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl,
- tcLookupTyCon, tcLookupDataCon, tcLookupId
+import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookup,
+ tcLookupTyCon, tcLookupDataCon, tcLookupId, checkProcLevel
)
+import TcArrows ( tcProc )
import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( badFieldCon )
= addSrcLoc src_loc $
zapExpectedType res_ty `thenM` \ res_ty' ->
-- All comprehensions yield a monotype
- tcDoStmts do_or_lc stmts method_names res_ty' `thenM` \ (binds, stmts', methods') ->
- returnM (mkHsLet binds (HsDo do_or_lc stmts' methods' res_ty' src_loc))
+ tcDoStmts do_or_lc stmts method_names res_ty' `thenM` \ (stmts', methods') ->
+ returnM (HsDo do_or_lc stmts' methods' res_ty' src_loc)
tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
= zapToListTy res_ty `thenM` \ elt_ty ->
= zapToTupleTy boxity (length exprs) res_ty `thenM` \ arg_tys ->
tcCheckRhos exprs arg_tys `thenM` \ exprs' ->
returnM (ExplicitTuple exprs' boxity)
+
+tcMonoExpr (HsProc pat cmd loc) res_ty
+ = addSrcLoc loc $
+ tcProc pat cmd res_ty `thenM` \ (pat', cmd') ->
+ returnM (HsProc pat' cmd' loc)
\end{code}
= -- First check whether it's a DataCon
-- Reason: we must not forget to chuck in the
-- constraints from their "silly context"
- tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
+ tcLookup name `thenM` \ maybe_thing ->
case maybe_thing of {
- Just (ADataCon data_con) -> inst_data_con data_con ;
- other ->
+ AGlobal (ADataCon data_con) -> inst_data_con data_con
+ ; AGlobal (AnId id) -> loop (HsVar id) (idType id)
+ -- A global cannot possibly be ill-staged
+ -- nor does it need the 'lifting' treatment
- -- OK, so now look for ordinary Ids
- tcLookupIdLvl name `thenM` \ (id, bind_lvl) ->
+ ; ATcId id th_level proc_level -> tc_local_id id th_level proc_level
+ ; other -> pprPanic "tcId" (ppr name)
+ }
+ where
#ifndef GHCI
- loop (HsVar id) (idType id) -- Non-TH case
+ tc_local_id id th_bind_lvl proc_lvl -- Non-TH case
+ = checkProcLevel id proc_lvl `thenM_`
+ loop (HsVar id) (idType id)
+
+#else /* GHCI and TH is on */
+ tc_local_id id th_bind_lvl proc_lvl -- TH case
+ = checkProcLevel id proc_lvl `thenM_`
-#else /* GHCI is on */
-- Check for cross-stage lifting
- getStage `thenM` \ use_stage ->
- case use_stage of
- Brack use_lvl ps_var lie_var
- | use_lvl > bind_lvl && not (isExternalName name)
- -> -- E.g. \x -> [| h x |]
+ getStage `thenM` \ use_stage ->
+ case use_stage of
+ Brack use_lvl ps_var lie_var
+ | use_lvl > th_bind_lvl
+ -> -- E.g. \x -> [| h x |]
-- We must behave as if the reference to x was
+
-- h $(lift x)
-- We use 'x' itself as the splice proxy, used by
-- the desugarer to stitch it all back together.
-- If 'x' occurs many times we may get many identical
-- bindings of the same splice proxy, but that doesn't
-- matter, although it's a mite untidy.
- --
- -- NB: During type-checking, isExernalName is true of
- -- top level things, and false of nested bindings
- -- Top-level things don't need lifting.
-
- let
- id_ty = idType id
- in
- checkTc (isTauTy id_ty) (polySpliceErr id) `thenM_`
+ let
+ id_ty = idType id
+ in
+ checkTc (isTauTy id_ty) (polySpliceErr id) `thenM_`
-- If x is polymorphic, its occurrence sites might
-- have different instantiations, so we can't use plain
-- 'x' as the splice proxy name. I don't know how to
-- solve this, and it's probably unimportant, so I'm
-- just going to flag an error for now
- setLIEVar lie_var (
- newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift ->
- -- Put the 'lift' constraint into the right LIE
+ setLIEVar lie_var (
+ newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift ->
+ -- Put the 'lift' constraint into the right LIE
- -- Update the pending splices
- readMutVar ps_var `thenM` \ ps ->
- writeMutVar ps_var ((name, HsApp (HsVar lift) (HsVar id)) : ps) `thenM_`
-
- returnM (HsVar id, id_ty))
-
- other ->
- checkWellStaged (quotes (ppr id)) bind_lvl use_stage `thenM_`
- loop (HsVar id) (idType id)
-#endif
- }
+ -- Update the pending splices
+ readMutVar ps_var `thenM` \ ps ->
+ writeMutVar ps_var ((name, HsApp (HsVar lift) (HsVar id)) : ps) `thenM_`
+
+ returnM (HsVar id, id_ty))
- where
- orig = OccurrenceOf name
+ other ->
+ checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_`
+ loop (HsVar id) (idType id)
+#endif /* GHCI */
loop (HsVar fun_id) fun_ty
| want_method_inst fun_ty
returnM (mkHsDictApp (mkHsTyApp (HsVar (dataConWrapId data_con)) ty_args)
(map instToId ex_dicts),
mkFunTys arg_tys result_ty)
+
+ orig = OccurrenceOf name
\end{code}
%************************************************************************
TcStmt, TcArithSeqInfo, TcRecordBinds,
TcHsModule, TcDictBinds,
TcForeignDecl,
+ TcCmd, TcCmdTop,
TypecheckedHsBinds, TypecheckedRuleDecl,
TypecheckedMonoBinds, TypecheckedPat,
TypecheckedGRHSs, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
TypecheckedMatchContext, TypecheckedCoreBind,
+ TypecheckedHsCmd, TypecheckedHsCmdTop,
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
type TcHsModule = HsModule TcId
type TcForeignDecl = ForeignDecl TcId
type TcRuleDecl = RuleDecl TcId
+type TcCmd = HsCmd TcId
+type TcCmdTop = HsCmdTop TcId
type TypecheckedPat = OutPat Id
type TypecheckedMonoBinds = MonoBinds Id
type TypecheckedForeignDecl = ForeignDecl Id
type TypecheckedRuleDecl = RuleDecl Id
type TypecheckedCoreBind = (Id, CoreExpr)
+type TypecheckedHsCmd = HsCmd Id
+type TypecheckedHsCmdTop = HsCmdTop Id
type TypecheckedMatchContext = HsMatchContext Name -- Keeps consistency with
-- HsDo arg StmtContext
zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
= zonkStmts env stmts `thenM` \ new_stmts ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsDo do_or_lc new_stmts
- (zonkIdOccs env ids)
- new_ty src_loc)
+ zonkReboundNames env ids `thenM` \ new_ids ->
+ returnM (HsDo do_or_lc new_stmts new_ids
+ new_ty src_loc)
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
= zonkExpr env expr `thenM` \ new_expr ->
returnM (DictApp new_expr (zonkIdOccs env dicts))
+-- arrow notation extensions
+zonkExpr env (HsProc pat body src_loc)
+ = zonkPat env pat `thenM` \ (new_pat, new_ids) ->
+ let
+ env1 = extendZonkEnv env (bagToList new_ids)
+ in
+ zonkCmdTop env1 body `thenM` \ new_body ->
+ returnM (HsProc new_pat new_body src_loc)
+
+zonkExpr env (HsArrApp e1 e2 ty ho rl src_loc)
+ = zonkExpr env e1 `thenM` \ new_e1 ->
+ zonkExpr env e2 `thenM` \ new_e2 ->
+ zonkTcTypeToType env ty `thenM` \ new_ty ->
+ returnM (HsArrApp new_e1 new_e2 new_ty ho rl src_loc)
+
+zonkExpr env (HsArrForm op fixity args src_loc)
+ = zonkExpr env op `thenM` \ new_op ->
+ mappM (zonkCmdTop env) args `thenM` \ new_args ->
+ returnM (HsArrForm new_op fixity new_args src_loc)
+
+zonkCmdTop :: ZonkEnv -> TcCmdTop -> TcM TypecheckedHsCmdTop
+zonkCmdTop env (HsCmdTop cmd stack_tys ty ids)
+ = zonkExpr env cmd `thenM` \ new_cmd ->
+ mappM (zonkTcTypeToType env) stack_tys
+ `thenM` \ new_stack_tys ->
+ zonkTcTypeToType env ty `thenM` \ new_ty ->
+ zonkReboundNames env ids `thenM` \ new_ids ->
+ returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
+
+-------------------------------------------------------------------------
+zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
+zonkReboundNames env prs
+ = mapM zonk prs
+ where
+ zonk (n, e) = zonkExpr env e `thenM` \ new_e ->
+ returnM (n, new_e)
-------------------------------------------------------------------------
zonk_stmts env [] = returnM (env, [])
-zonk_stmts env (ParStmtOut bndrstmtss : stmts)
- = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss ->
- mappM (zonkStmts env) stmtss `thenM` \ new_stmtss ->
+zonk_stmts env (ParStmt stmts_w_bndrs : stmts)
+ = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
let
- new_binders = concat new_bndrss
+ new_binders = concat (map snd new_stmts_w_bndrs)
env1 = extendZonkEnv env new_binders
in
zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
- returnM (env2, ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
+ returnM (env2, ParStmt new_stmts_w_bndrs : new_stmts)
where
- (bndrss, stmtss) = unzip bndrstmtss
+ zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
+ returnM (new_stmts, zonkIdOccs env1 bndrs)
-zonk_stmts env (RecStmt vs segStmts rets : stmts)
- = mappM zonkId vs `thenM` \ new_vs ->
+zonk_stmts env (RecStmt segStmts lvs rvs rets : stmts)
+ = zonkIdBndrs env rvs `thenM` \ new_rvs ->
let
- env1 = extendZonkEnv env new_vs
+ env1 = extendZonkEnv env new_rvs
in
zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
-- Zonk the ret-expressions in an envt that
-- has the polymorphic bindings in the envt
zonkExprs env2 rets `thenM` \ new_rets ->
- zonk_stmts env1 stmts `thenM` \ (env3, new_stmts) ->
- returnM (env3, RecStmt new_vs new_segStmts new_rets : new_stmts)
+ let
+ new_lvs = zonkIdOccs env2 lvs
+ env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
+ in
+ zonk_stmts env3 stmts `thenM` \ (env4, new_stmts) ->
+ returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets : new_stmts)
zonk_stmts env (ResultStmt expr locn : stmts)
= ASSERT( null stmts )
--------------------------------
-- Creating new mutable type variables
- newTyVar,
+ newTyVar, newSigTyVar,
newTyVarTy, -- Kind -> TcM TcType
newTyVarTys, -- Int -> Kind -> TcM [TcType]
newKindVar, newKindVars, newOpenTypeKind,
= newUnique `thenM` \ uniq ->
newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("t")) kind VanillaTv
+newSigTyVar :: Kind -> TcM TcTyVar
+newSigTyVar kind
+ = newUnique `thenM` \ uniq ->
+ newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("s")) kind SigTv
+
newTyVarTy :: Kind -> TcM TcType
newTyVarTy kind
= newTyVar kind `thenM` \ tc_tyvar ->
\section[TcMatches]{Typecheck some @Matches@}
\begin{code}
-module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda,
- tcDoStmts, tcStmtsAndThen, tcGRHSs, tcThingWithSig
+module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, matchCtxt,
+ tcDoStmts, tcStmtsAndThen, tcStmts, tcGRHSs, tcThingWithSig,
+ tcMatchPats,
+ TcStmtCtxt(..)
) where
#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..),
MonoBinds(..), Stmt(..), HsMatchContext(..), HsStmtContext(..),
+ ReboundNames,
pprMatch, getMatchLoc, isDoExpr,
pprMatchContext, pprStmtContext, pprStmtResultContext,
- mkMonoBind, collectSigTysFromPats, andMonoBindList
+ mkMonoBind, collectSigTysFromPats, andMonoBindList, glueBindsOnGRHSs
)
-import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt,
+import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedHsExpr,
RenamedPat, RenamedMatchContext )
-import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TcHsBinds,
+import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TcHsBinds, TcExpr,
TcMonoBinds, TcPat, TcStmt, ExprCoFn,
isIdCoercion, (<$>), (<.>) )
import TcPat ( tcPat, tcMonoPatBndr )
import TcMType ( newTyVarTy, newTyVarTys, zonkTcType )
import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType,
- tyVarsOfType, tidyOpenTypes, tidyOpenType, isSigmaTy,
+ tyVarsOfTypes, tidyOpenTypes, tidyOpenType, isSigmaTy,
mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind,
mkArrowKind, mkAppTy )
import TcBinds ( tcBindsAndThen )
import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedBranches, readExpectedType,
- unifyTauTy, subFunTy, unifyPArrTy, unifyListTy, unifyFunTy,
+ unifyTauTy, subFunTys, unifyPArrTy, unifyListTy, unifyFunTy,
checkSigTyVarsWrt, tcSubExp, tcGen )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import Name ( Name )
-- because inconsistency between branches
-- may show up as something wrong with the (non-existent) type signature
- -- No need to zonk expected_ty, because subFunTy does that on the fly
+ -- No need to zonk expected_ty, because subFunTys does that on the fly
tcMatches (FunRhs fun_name) matches expected_ty
\end{code}
tcMatch ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
= addSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
addErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
- tcMatchPats pats expected_ty tc_grhss `thenM` \ (pats', grhss', ex_binds) ->
- returnM (Match pats' Nothing (glue_on ex_binds grhss'))
+ subFunTys pats expected_ty $ \ pats_w_tys rhs_ty ->
+ -- This is the unique place we call subFunTys
+ -- The point is that if expected_y is a "hole", we want
+ -- to make arg_ty and rest_ty as "holes" too.
+ tcMatchPats pats_w_tys rhs_ty (tc_grhss rhs_ty) `thenM` \ (pats', grhss', ex_binds) ->
+ returnM (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss'))
where
tc_grhss rhs_ty
- = -- Deal with the result signature
- case maybe_rhs_sig of
- Nothing -> tcGRHSs ctxt grhss rhs_ty
+ = case maybe_rhs_sig of -- Deal with the result signature
+ Nothing -> tcGRHSs ctxt grhss rhs_ty
Just sig -> tcAddScopedTyVars [sig] $
-- Bring into scope the type variables in the signature
lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
lift_stmt stmt = stmt
--- glue_on just avoids stupid dross
-glue_on EmptyBinds grhss = grhss -- The common case
-glue_on binds1 (GRHSs grhss binds2 ty)
- = GRHSs grhss (binds1 `ThenBinds` binds2) ty
-
-
tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
-> Expected TcRhoType
-> TcM TcGRHSs
-- This is a consequence of the fact that tcStmts takes a TcType,
-- not a Expected TcType, a decision we could revisit if necessary
tcGRHSs ctxt (GRHSs [GRHS [ResultStmt rhs loc1] loc2] binds _) exp_ty
- = tcBindsAndThen glue_on binds $
- tcMonoExpr rhs exp_ty `thenM` \ rhs' ->
- readExpectedType exp_ty `thenM` \ exp_ty' ->
+ = tcBindsAndThen glueBindsOnGRHSs binds $
+ tcMonoExpr rhs exp_ty `thenM` \ rhs' ->
+ readExpectedType exp_ty `thenM` \ exp_ty' ->
returnM (GRHSs [GRHS [ResultStmt rhs' loc1] loc2] EmptyBinds exp_ty')
tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
- = tcBindsAndThen glue_on binds $
- zapExpectedType exp_ty `thenM` \ exp_ty' ->
+ = tcBindsAndThen glueBindsOnGRHSs binds $
+ zapExpectedType exp_ty `thenM` \ exp_ty' ->
-- Even if there is only one guard, we zap the RHS type to
-- a monotype. Reason: it makes tcStmts much easier,
-- and even a one-armed guard has a notional second arm
let
+ stmt_ctxt = SC { sc_what = PatGuard ctxt,
+ sc_rhs = tcCheckRho,
+ sc_body = \ body -> tcCheckRho body exp_ty',
+ sc_ty = exp_ty' }
+
tc_grhs (GRHS guarded locn)
- = addSrcLoc locn $
- tcStmts (PatGuard ctxt) m_ty guarded `thenM` \ guarded' ->
+ = addSrcLoc locn $
+ tcStmts stmt_ctxt guarded `thenM` \ guarded' ->
returnM (GRHS guarded' locn)
-
- m_ty = (\ty -> ty, exp_ty')
in
mappM tc_grhs grhss `thenM` \ grhss' ->
returnM (GRHSs grhss' EmptyBinds exp_ty')
\begin{code}
tcMatchPats
- :: [RenamedPat] -> Expected TcRhoType
- -> (Expected TcRhoType -> TcM a)
+ :: [(RenamedPat, Expected TcRhoType)]
+ -> Expected TcRhoType
+ -> TcM a
-> TcM ([TcPat], a, TcHsBinds)
-- Typecheck the patterns, extend the environment to bind the variables,
-- do the thing inside, use any existentially-bound dictionaries to
-- discharge parts of the returning LIE, and deal with pattern type
-- signatures
-tcMatchPats pats expected_ty thing_inside
+tcMatchPats pats_w_tys body_ty thing_inside
= -- STEP 1: Bring pattern-signature type variables into scope
- tcAddScopedTyVars (collectSigTysFromPats pats) (
+ tcAddScopedTyVars (collectSigTysFromPats (map fst pats_w_tys)) (
-- STEP 2: Typecheck the patterns themselves, gathering all the stuff
-- then do the thing inside
- getLIE (tc_match_pats pats expected_ty thing_inside)
+ getLIE (tc_match_pats pats_w_tys thing_inside)
) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
-- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
-- might need (via lie_req2) something made available from an 'outer'
-- pattern. But it's inconvenient to deal with, and I can't find an example
- readExpectedType expected_ty `thenM` \ exp_ty ->
- tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req exp_ty `thenM` \ ex_binds ->
- -- NB: we *must* pass "exp_ty" not "result_ty" to tcCheckExistentialPat
+ tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req
+ pats_w_tys body_ty `thenM` \ ex_binds ->
+ -- NB: we *must* pass "pats_w_tys" not just "body_ty" to tcCheckExistentialPat
-- For example, we must reject this program:
-- data C = forall a. C (a -> Int)
-- f (C g) x = g x
- -- Here, result_ty will be simply Int, but expected_ty is (a -> Int).
+ -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
returnM (pats', result, mkMonoBind Recursive ex_binds)
-tc_match_pats [] expected_ty thing_inside
- = thing_inside expected_ty `thenM` \ answer ->
+tc_match_pats [] thing_inside
+ = thing_inside `thenM` \ answer ->
returnM ([], emptyBag, [], [], answer)
-tc_match_pats (pat:pats) expected_ty thing_inside
- = subFunTy expected_ty $ \ arg_ty rest_ty ->
- -- This is the unique place we call subFunTy
- -- The point is that if expected_y is a "hole", we want
- -- to make arg_ty and rest_ty as "holes" too.
- tcPat tcMonoPatBndr pat arg_ty `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
+tc_match_pats ((pat,pat_ty):pats) thing_inside
+ = tcPat tcMonoPatBndr pat pat_ty `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
let
xve = bagToList pat_bndrs
ex_ids = [id | (_, id) <- xve]
-- of the existential Ids used in checkExistentialPat
in
tcExtendLocalValEnv2 xve $
- tc_match_pats pats rest_ty thing_inside `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
+ tc_match_pats pats thing_inside `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
returnM ( pat':pats',
ex_tvs `unionBags` exs_tvs,
ex_ids ++ exs_ids,
-- (b) to generate helpful error messages
-> [Inst] -- and context
-> [Inst] -- Required context
- -> TcType -- and type of the Match; vars in here must not escape
+ -> [(pat,Expected TcRhoType)] -- Types of the patterns
+ -> Expected TcRhoType -- Type of the body of the match
+ -- Tyvars in either of these must not escape
-> TcM TcDictBinds -- LIE to float out and dict bindings
-tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_ty
+tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req pats_w_tys body_ty
| isEmptyBag ex_tvs && all not_overloaded ex_ids
-- Short cut for case when there are no existentials
-- and no polymorphic overloaded variables
returnM EmptyMonoBinds
| otherwise
- = addErrCtxtM (sigPatCtxt tv_list ex_ids match_ty) $
+ = -- Read the by-now-filled-in expected types
+ mapM readExpectedType (body_ty : map snd pats_w_tys) `thenM` \ tys ->
+ addErrCtxtM (sigPatCtxt tv_list ex_ids tys) $
-- In case there are any polymorpic, overloaded binders in the pattern
-- (which can happen in the case of rank-2 type signatures, or data constructors
-- Deal with overloaded functions bound by the pattern
tcSimplifyCheck doc tv_list ex_lie lie `thenM` \ dict_binds ->
- checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenM_`
+
+ -- Check for type variable escape
+ checkSigTyVarsWrt (tyVarsOfTypes tys) tv_list `thenM_`
returnM (dict_binds `AndMonoBinds` inst_binds)
where
%************************************************************************
\begin{code}
-tcDoStmts :: HsStmtContext Name -> [RenamedStmt] -> [Name]
+tcDoStmts :: HsStmtContext Name
+ -> [RenamedStmt] -> ReboundNames Name
-> TcRhoType -- To keep it simple, we don't have an "expected" type here
- -> TcM (TcMonoBinds, [TcStmt], [Id])
+ -> TcM ([TcStmt], ReboundNames TcId)
tcDoStmts PArrComp stmts method_names res_ty
- = unifyPArrTy res_ty `thenM` \elt_ty ->
- tcStmts PArrComp (mkPArrTy, elt_ty) stmts `thenM` \ stmts' ->
- returnM (EmptyMonoBinds, stmts', [{- unused -}])
+ = unifyPArrTy res_ty `thenM` \elt_ty ->
+ tcComprehension PArrComp mkPArrTy elt_ty stmts `thenM` \ stmts' ->
+ returnM (stmts', [{- unused -}])
tcDoStmts ListComp stmts method_names res_ty
- = unifyListTy res_ty `thenM` \ elt_ty ->
- tcStmts ListComp (mkListTy, elt_ty) stmts `thenM` \ stmts' ->
- returnM (EmptyMonoBinds, stmts', [{- unused -}])
+ = unifyListTy res_ty ` thenM` \ elt_ty ->
+ tcComprehension ListComp mkListTy elt_ty stmts `thenM` \ stmts' ->
+ returnM (stmts', [{- unused -}])
-tcDoStmts do_or_mdo_expr stmts method_names res_ty
+tcDoStmts do_or_mdo stmts method_names res_ty
= newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
-
- tcStmts do_or_mdo_expr (mkAppTy m_ty, elt_ty) stmts `thenM` \ stmts' ->
+ let
+ ctxt = SC { sc_what = do_or_mdo,
+ sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mkAppTy m_ty rhs_elt_ty),
+ sc_body = \ body -> tcCheckRho body res_ty,
+ sc_ty = res_ty }
+ in
+ tcStmts ctxt stmts `thenM` \ stmts' ->
-- Build the then and zero methods in case we need them
-- It's important that "then" and "return" appear just once in the final LIE,
-- then = case d of (t,r) -> t
-- then = then
-- where the second "then" sees that it already exists in the "available" stuff.
- --
- mapAndUnzipM (tc_syn_name m_ty)
- (zipEqual "tcDoStmts" currentMonadNames method_names) `thenM` \ (binds, ids) ->
- returnM (andMonoBindList binds, stmts', ids)
+ mapM (tcSyntaxName DoOrigin m_ty) method_names `thenM` \ methods ->
+
+ returnM (stmts', methods)
+
+tcComprehension do_or_lc mk_mty elt_ty stmts
+ = tcStmts ctxt stmts
where
- currentMonadNames = case do_or_mdo_expr of
- DoExpr -> monadNames
- MDoExpr -> monadNames ++ [mfixName]
- tc_syn_name :: TcType -> (Name,Name) -> TcM (TcMonoBinds, Id)
- tc_syn_name m_ty (std_nm, usr_nm)
- = tcSyntaxName DoOrigin m_ty std_nm usr_nm `thenM` \ (expr, expr_ty) ->
- case expr of
- HsVar v -> returnM (EmptyMonoBinds, v)
- other -> newUnique `thenM` \ uniq ->
- let
- id = mkSysLocal FSLIT("syn") uniq expr_ty
- in
- returnM (VarMonoBind id expr, id)
+ ctxt = SC { sc_what = do_or_lc,
+ sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mk_mty rhs_elt_ty),
+ sc_body = \ body -> tcCheckRho body elt_ty, -- Note: no mk_mty!
+ sc_ty = mk_mty elt_ty }
\end{code}
group. But that's fine; there's no shadowing to worry about.
\begin{code}
-tcStmts do_or_lc m_ty stmts
+tcStmts ctxt stmts
= ASSERT( notNull stmts )
- tcStmtsAndThen (:) do_or_lc m_ty stmts (returnM [])
-
+ tcStmtsAndThen (:) ctxt stmts (returnM [])
+
+data TcStmtCtxt
+ = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is
+ sc_rhs :: RenamedHsExpr -> TcType -> TcM TcExpr, -- Type checker for RHS computations
+ sc_body :: RenamedHsExpr -> TcM TcExpr, -- Type checker for return computation
+ sc_ty :: TcType } -- Return type; used *only* to check
+ -- for escape in existential patterns
tcStmtsAndThen
:: (TcStmt -> thing -> thing) -- Combiner
- -> HsStmtContext Name
- -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
- -- res_ty, the type of the entire comprehension
- -- used at the end for the type of (return x)
- -- or the final expression in do-notation
+ -> TcStmtCtxt
-> [RenamedStmt]
-> TcM thing
-> TcM thing
-- Base case
-tcStmtsAndThen combine do_or_lc m_ty [] do_next
- = do_next
+tcStmtsAndThen combine ctxt [] thing_inside
+ = thing_inside
-tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
- = tcStmtAndThen combine do_or_lc m_ty stmt
- (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
+tcStmtsAndThen combine ctxt (stmt:stmts) thing_inside
+ = tcStmtAndThen combine ctxt stmt $
+ tcStmtsAndThen combine ctxt stmts $
+ thing_inside
-- LetStmt
-tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
+tcStmtAndThen combine ctxt (LetStmt binds) thing_inside
= tcBindsAndThen -- No error context, but a binding group is
(glue_binds combine) -- rather a large thing for an error context anyway
binds
thing_inside
-tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
- = addSrcLoc src_loc $
- addErrCtxt (stmtCtxt do_or_lc stmt) $
- newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
- tcCheckRho exp (m pat_ty) `thenM` \ exp' ->
- tcMatchPats [pat] (Check (mkFunTy pat_ty (m elt_ty))) (\ _ ->
+ -- BindStmt
+tcStmtAndThen combine ctxt stmt@(BindStmt pat exp src_loc) thing_inside
+ = addSrcLoc src_loc $
+ addErrCtxt (stmtCtxt ctxt stmt) $
+ newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
+ sc_rhs ctxt exp pat_ty `thenM` \ exp' ->
+ tcMatchPats [(pat, Check pat_ty)] (Check (sc_ty ctxt)) (
popErrCtxt thing_inside
) `thenM` \ ([pat'], thing, dict_binds) ->
returnM (combine (BindStmt pat' exp' src_loc)
(glue_binds combine dict_binds thing))
+ -- ExprStmt
+tcStmtAndThen combine ctxt stmt@(ExprStmt exp _ src_loc) thing_inside
+ = addSrcLoc src_loc (
+ addErrCtxt (stmtCtxt ctxt stmt) $
+ if isDoExpr (sc_what ctxt)
+ then -- do or mdo; the expression is a computation
+ newTyVarTy openTypeKind `thenM` \ any_ty ->
+ sc_rhs ctxt exp any_ty `thenM` \ exp' ->
+ returnM (ExprStmt exp' any_ty src_loc)
+ else -- List comprehensions, pattern guards; expression is a boolean
+ tcCheckRho exp boolTy `thenM` \ exp' ->
+ returnM (ExprStmt exp' boolTy src_loc)
+ ) `thenM` \ stmt' ->
+
+ thing_inside `thenM` \ thing ->
+ returnM (combine stmt' thing)
+
+
-- ParStmt
-tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
+tcStmtAndThen combine ctxt (ParStmt bndr_stmts_s) thing_inside
= loop bndr_stmts_s `thenM` \ (pairs', thing) ->
- returnM (combine (ParStmtOut pairs') thing)
+ returnM (combine (ParStmt pairs') thing)
where
- loop []
- = thing_inside `thenM` \ thing ->
- returnM ([], thing)
-
- loop ((bndrs,stmts) : pairs)
- = tcStmtsAndThen
- combine_par ListComp m_ty stmts
- -- Notice we pass on m_ty; the result type is used only
- -- to get escaping type variables for checkExistentialPat
- (tcLookupLocalIds bndrs `thenM` \ bndrs' ->
- loop pairs `thenM` \ (pairs', thing) ->
- returnM ([], (bndrs', pairs', thing))) `thenM` \ (stmts', (bndrs', pairs', thing)) ->
+ loop [] = thing_inside `thenM` \ thing ->
+ returnM ([], thing)
- returnM ((bndrs',stmts') : pairs', thing)
+ loop ((stmts, bndrs) : pairs)
+ = tcStmtsAndThen combine_par ctxt stmts $
+ -- Notice we pass on ctxt; the result type is used only
+ -- to get escaping type variables for checkExistentialPat
+ tcLookupLocalIds bndrs `thenM` \ bndrs' ->
+ loop pairs `thenM` \ (pairs', thing) ->
+ returnM (([], bndrs') : pairs', thing)
- combine_par stmt (stmts, thing) = (stmt:stmts, thing)
+ combine_par stmt ((stmts, bndrs) : pairs , thing) = ((stmt:stmts, bndrs) : pairs, thing)
-- RecStmt
-tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts _) thing_inside
+tcStmtAndThen combine ctxt (RecStmt stmts laterNames recNames _) thing_inside
= newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
let
- mono_ids = zipWith mkLocalId recNames recTys
+ rec_ids = zipWith mkLocalId recNames recTys
in
- tcExtendLocalValEnv mono_ids $
- tcStmtsAndThen combine_rec do_or_lc m_ty stmts (
- mappM tc_ret (recNames `zip` recTys) `thenM` \ rets ->
- returnM ([], rets)
- ) `thenM` \ (stmts', rets) ->
-
- -- NB: it's the mono_ids that scope over this part
+ tcExtendLocalValEnv rec_ids $
+ tcStmtsAndThen combine_rec ctxt stmts (
+ mappM tc_ret (recNames `zip` recTys) `thenM` \ rec_rets ->
+ tcLookupLocalIds laterNames `thenM` \ later_ids ->
+ returnM ([], (later_ids, rec_rets))
+ ) `thenM` \ (stmts', (later_ids, rec_rets)) ->
+
+ tcExtendLocalValEnv later_ids $
+ -- NB: The rec_ids for the recursive things
+ -- already scope over this part
thing_inside `thenM` \ thing ->
- returnM (combine (RecStmt mono_ids stmts' rets) thing)
+ returnM (combine (RecStmt stmts' later_ids rec_ids rec_rets) thing)
where
combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
tcSubExp (Check mono_ty) (idType poly_id) `thenM` \ co_fn ->
returnM (co_fn <$> HsVar poly_id)
- -- ExprStmt
-tcStmtAndThen combine do_or_lc m_ty@(m, _) stmt@(ExprStmt exp _ locn) thing_inside
- = addErrCtxt (stmtCtxt do_or_lc stmt) (
- if isDoExpr do_or_lc then
- newTyVarTy openTypeKind `thenM` \ any_ty ->
- tcCheckRho exp (m any_ty) `thenM` \ exp' ->
- returnM (ExprStmt exp' any_ty locn)
- else
- tcCheckRho exp boolTy `thenM` \ exp' ->
- returnM (ExprStmt exp' boolTy locn)
- ) `thenM` \ stmt' ->
-
- thing_inside `thenM` \ thing ->
- returnM (combine stmt' thing)
-
-
-- Result statements
-tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
- = addErrCtxt (resCtxt do_or_lc stmt) (
- if isDoExpr do_or_lc then
- tcCheckRho exp (m res_elt_ty)
- else
- tcCheckRho exp res_elt_ty
- ) `thenM` \ exp' ->
-
- thing_inside `thenM` \ thing ->
-
+tcStmtAndThen combine ctxt stmt@(ResultStmt exp locn) thing_inside
+ = addErrCtxt (stmtCtxt ctxt stmt) (sc_body ctxt exp) `thenM` \ exp' ->
+ thing_inside `thenM` \ thing ->
returnM (combine (ResultStmt exp' locn) thing)
varyingArgsErr name matches
= sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
-matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
-stmtCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtContext do_or_lc <> colon) 4 (ppr stmt)
-resCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtResultContext do_or_lc <> colon) 4 (ppr stmt)
-
-sigPatCtxt bound_tvs bound_ids match_ty tidy_env
- = zonkTcType match_ty `thenM` \ match_ty' ->
+matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
+ 4 (pprMatch ctxt match)
+
+stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pp_ctxt (sc_what ctxt) <> colon) 4 (ppr stmt)
+ where
+ pp_ctxt = case stmt of
+ ResultStmt _ _ -> pprStmtResultContext
+ other -> pprStmtContext
+
+sigPatCtxt bound_tvs bound_ids tys tidy_env
+ = -- tys is (body_ty : pat_tys)
+ mapM zonkTcType tys `thenM` \ tys' ->
let
(env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
- (env2, tidy_mty) = tidyOpenType env1 match_ty'
+ (env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
in
returnM (env1,
sep [ptext SLIT("When checking an existential match that binds"),
nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
- ptext SLIT("and whose type is") <+> ppr tidy_mty])
+ ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
+ ptext SLIT("The body has type:") <+> ppr tidy_body_ty
+ ])
where
show_ids = filter is_interesting bound_ids
is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
- ppr_id id ty = ppr id <+> dcolon <+> ppr ty
+ ppr_id id ty = ppr id <+> dcolon <+> ppr ty
-- Don't zonk the types so we get the separate, un-unified versions
\end{code}
pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier")
pp_thing (AGlobal (ADataCon _)) = ptext SLIT("Data constructor")
pp_thing (ATyVar _) = ptext SLIT("Type variable")
- pp_thing (ATcId _ _) = ptext SLIT("Local identifier")
+ pp_thing (ATcId _ _ _) = ptext SLIT("Local identifier")
pp_thing (AThing _) = ptext SLIT("Utterly bogus")
\end{code}
Nothing -> returnM pos_lit_expr -- Positive literal
Just neg -> -- Negative literal
-- The 'negate' is re-mappable syntax
- tcSyntaxName origin pat_ty' negateName neg `thenM` \ (neg_expr, _) ->
- returnM (HsApp neg_expr pos_lit_expr)
+ tcSyntaxName origin pat_ty' (negateName, HsVar neg) `thenM` \ (_, neg_expr) ->
+ returnM (HsApp neg_expr pos_lit_expr)
) `thenM` \ lit_expr ->
let
newMethodFromName origin pat_ty' geName `thenM` \ ge ->
-- The '-' part is re-mappable syntax
- tcSyntaxName origin pat_ty' minusName minus_name `thenM` \ (minus_expr, _) ->
+ tcSyntaxName origin pat_ty' (minusName, HsVar minus_name) `thenM` \ (_, minus_expr) ->
-- The Report says that n+k patterns must be in Integral
-- We may not want this when using re-mappable syntax, though (ToDo?)
\begin{code}
module TcRnDriver (
#ifdef GHCI
- mkGlobalContext, getModuleContents,
+ mkGlobalContext, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr,
#endif
tcRnModule, checkOldIface,
importSupportingDecls, tcTopSrcDecls,
- tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing
+ tcRnIface, tcRnExtCore
) where
#include "HsVersions.h"
import PrelNames ( iNTERACTIVE, ioTyConName, printName,
returnIOName, bindIOName, failIOName, thenIOName, runIOName,
- dollarMainName, itName, mAIN_Name
+ dollarMainName, itName, mAIN_Name, unsafeCoerceName
)
import MkId ( unsafeCoerceId )
import RdrName ( RdrName, getRdrName, mkRdrUnqual,
zonkTopExpr, zonkTopBndrs
)
-import TcExpr ( tcInferRho )
+import TcExpr ( tcInferRho, tcCheckRho )
import TcRnMonad
import TcMType ( newTyVarTy, zonkTcType )
import TcType ( Type, liftedTypeKind,
tyVarsOfType, tcFunResultTy, tidyTopType,
mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
)
-import TcMatches ( tcStmtsAndThen )
+import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
import Inst ( showLIE )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
%************************************************************************
\begin{code}
+#ifdef GHCI
tcRnStmt :: HscEnv -> PersistentCompilerState
-> InteractiveContext
-> RdrNameStmt
---------------------------
tc_stmts stmts
- = do { io_ids <- mappM tcLookupId
- [returnIOName, failIOName, bindIOName, thenIOName] ;
- ioTyCon <- tcLookupTyCon ioTyConName ;
- res_ty <- newTyVarTy liftedTypeKind ;
+ = do { ioTyCon <- tcLookupTyCon ioTyConName ;
let {
- names = collectStmtsBinders stmts ;
- return_id = head io_ids ; -- Rather gruesome
+ ret_ty = mkListTy unitTy ;
+ names = collectStmtsBinders stmts ;
+
+ stmt_ctxt = SC { sc_what = DoExpr,
+ sc_rhs = check_rhs,
+ sc_body = check_body,
+ sc_ty = ret_ty } ;
- io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
+ check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
+ check_body body = tcCheckRho body (mkTyConApp ioTyCon [ret_ty]) ;
- -- mk_return builds the expression
- -- returnIO @ [()] [coerce () x, .., coerce () z]
- mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
- (ExplicitList unitTy (map mk_item ids)) ;
+ -- ret_expr is the expression
+ -- returnIO [coerce () x, .., coerce () z]
+ ret_stmt = ResultStmt ret_expr noSrcLoc ;
+ ret_expr = HsApp (HsVar returnIOName)
+ (ExplicitList placeHolderType (map mk_item names)) ;
+ mk_item name = HsApp (HsVar unsafeCoerceName) (HsVar name) ;
- mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
- (HsVar id) } ;
+ all_stmts = stmts ++ [ret_stmt]
+ } ;
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
((ids, tc_stmts), lie) <-
- getLIE $ tcStmtsAndThen combine DoExpr io_ty stmts $
+ getLIE $
+ tcStmtsAndThen combine stmt_ctxt stmts $
do {
-- Look up the names right in the middle,
-- where they will all be in scope
ids <- mappM tcLookupId names ;
- return (ids, [ResultStmt (mk_return ids) noSrcLoc])
+ return (ids, [])
} ;
-- Simplify the context right here, so that we fail
const_binds <- tcSimplifyTop lie ;
-- Build result expression and zonk it
+ io_ids <- mappM mk_rebound
+ [returnIOName, failIOName, bindIOName, thenIOName] ;
let { expr = mkHsLet const_binds $
HsDo DoExpr tc_stmts io_ids
- (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
+ (mkTyConApp ioTyCon [ret_ty]) noSrcLoc } ;
zonked_expr <- zonkTopExpr expr ;
zonked_ids <- zonkTopBndrs ids ;
}
where
combine stmt (ids, stmts) = (ids, stmt:stmts)
+ mk_rebound n = do { id <- tcLookupId n; return (n, HsVar id) }
+ -- A bit hackoid
\end{code}
= initRn CmdLineMode $
setLocalRdrEnv (ic_rn_local_env ictxt) $
rn_thing
+#endif
\end{code}
%************************************************************************
tcg_fords = [] } ;
lcl_env = TcLclEnv {
- tcl_ctxt = [],
- tcl_level = topStage,
- tcl_env = emptyNameEnv,
- tcl_tyvars = tvs_var,
- tcl_lie = panic "initTc:LIE" } ;
+ tcl_ctxt = [],
+ 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
} ;
setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
\end{code}
+
Command-line flags
\begin{code}
%************************************************************************
%* *
- Other stuff specific to type checker
+ Type constraints (the so-called LIE)
%* *
%************************************************************************
writeMutVar lie_var (mkLIE insts `plusLIE` lie) }
\end{code}
-
\begin{code}
-getStage :: TcM Stage
-getStage = do { env <- getLclEnv; return (tcl_level env) }
-
-setStage :: Stage -> TcM a -> TcM a
-setStage s = updLclEnv (\ env -> env { tcl_level = s })
-
setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
-- Set the local type envt, but do *not* disturb other fields,
-- notably the lie_var
%************************************************************************
%* *
+ Template Haskell context
+%* *
+%************************************************************************
+
+\begin{code}
+getStage :: TcM ThStage
+getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
+
+setStage :: ThStage -> TcM a -> TcM a
+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, proc_banned = curr_lvl : banned}
+
+getBannedProcLevels :: TcM [ProcLevel]
+ = 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
%* *
%************************************************************************
TcTyThing(..),
-- Template Haskell
- Stage(..), topStage, topSpliceStage,
- Level, impLevel, topLevel,
+ ThStage(..), topStage, topSpliceStage,
+ ThLevel, impLevel, topLevel,
+
+ -- Arrows
+ ArrowCtxt(..), topArrowCtxt, ProcLevel, topProcLevel,
-- Insts
Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, instLocSrcLoc,
= TcLclEnv {
tcl_ctxt :: ErrCtxt, -- Error context
- tcl_level :: Stage, -- Template Haskell context
+ tcl_th_ctxt :: ThStage, -- Template Haskell context
+ tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context
tcl_env :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
-- defined in this module
tcl_lie :: TcRef LIE -- Place to accumulate type constraints
}
-type Level = Int
+---------------------------
+-- Template Haskell levels
+---------------------------
+
+type ThLevel = Int -- Always >= 0
-data Stage
+data ThStage
= Comp -- Ordinary compiling, at level topLevel
- | Splice Level -- Inside a splice
- | Brack Level -- Inside brackets;
+ | Splice ThLevel -- Inside a splice
+ | Brack ThLevel -- Inside brackets;
(TcRef [PendingSplice]) -- accumulate pending splices here
(TcRef LIE) -- and type constraints here
-topStage, topSpliceStage :: Stage
+topStage, topSpliceStage :: ThStage
topStage = Comp
topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level splice
-impLevel, topLevel :: Level
+impLevel, topLevel :: ThLevel
topLevel = 1 -- Things defined at top level of this module
impLevel = 0 -- Imported things; they can be used inside a top level splice
--
-- g1 = $(map ...) is OK
-- g2 = $(f ...) is not OK; because we havn't compiled f yet
+
+---------------------------
+-- 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 (-<). 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
+-- prox 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.
+-- 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 Level -- Ids defined in this module; may not be fully zonked
- | ATyVar TyVar -- Type variables
- | AThing TcKind -- Used temporarily, during kind checking
+ = 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
+ | ATyVar TyVar -- Type variables
+ | AThing TcKind -- Used temporarily, during kind checking
-- Here's an example of how the AThing guy is used
-- Suppose we are checking (forall a. T a Int):
-- 1. We first bind (a -> AThink kv), where kv is a kind variable.
-- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
instance Outputable TcTyThing where -- Debugging only
- ppr (AGlobal g) = text "AGlobal" <+> ppr g
- ppr (ATcId g l) = text "ATcId" <+> ppr g <+> ppr l
- ppr (ATyVar t) = text "ATyVar" <+> ppr t
- ppr (AThing k) = text "AThing" <+> ppr k
+ ppr (AGlobal g) = text "AGlobal" <+> ppr g
+ ppr (ATcId g tl pl) = text "ATcId" <+> ppr g <+> ppr tl <+> ppr pl
+ ppr (ATyVar t) = text "ATyVar" <+> ppr t
+ ppr (AThing k) = text "AThing" <+> ppr k
\end{code}
\begin{code}
-- of a rank-2 typed function
| DoOrigin -- The monad for a do expression
+ | ProcOrigin -- A proc expression
| ClassDeclOrigin -- Manufactured during a class decl
= ptext SLIT("a function with an overloaded argument type")
pp_orig (DoOrigin)
= ptext SLIT("a do statement")
+ pp_orig (ProcOrigin)
+ = ptext SLIT("a proc expression")
pp_orig (ClassDeclOrigin)
= ptext SLIT("a class declaration")
pp_orig (InstanceSpecOrigin clas ty)
-- Holes
Expected(..), newHole, readExpectedType,
zapExpectedType, zapExpectedTo, zapExpectedBranches,
- subFunTy, unifyFunTy,
+ subFunTys, unifyFunTy,
zapToListTy, unifyListTy,
zapToPArrTy, unifyPArrTy,
zapToTupleTy, unifyTupleTy
import TcRnMonad -- TcType, amongst others
import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
TcTyVarSet, TcThetaType, TyVarDetails(SigTv),
- isTauTy, isSigmaTy,
+ isTauTy, isSigmaTy, mkFunTys,
tcSplitAppTy_maybe, tcSplitTyConApp_maybe,
tcGetTyVar_maybe, tcGetTyVar,
mkFunTy, tyVarsOfType, mkPhiTy,
type variables, so we should create new ordinary type variables
\begin{code}
-subFunTy :: Expected TcRhoType -- Fail if ty isn't a function type
- -- If it's a hole, make two holes, feed them to...
- -> (Expected TcRhoType -> Expected TcRhoType -> TcM a) -- the thing inside
- -> TcM a -- and bind the function type to the hole
+subFunTys :: [pat]
+ -> Expected TcRhoType -- Fail if ty isn't a function type
+ -> ([(pat, Expected TcRhoType)] -> Expected TcRhoType -> TcM a)
+ -> TcM a
-subFunTy (Infer hole) thing_inside
+subFunTys pats (Infer hole) thing_inside
= -- This is the interesting case
- newHole `thenM` \ arg_hole ->
+ mapM new_pat_hole pats `thenM` \ pats_w_holes ->
newHole `thenM` \ res_hole ->
-- Do the business
- thing_inside (Infer arg_hole) (Infer res_hole) `thenM` \ answer ->
+ thing_inside pats_w_holes (Infer res_hole) `thenM` \ answer ->
-- Extract the answers
- readMutVar arg_hole `thenM` \ arg_ty ->
- readMutVar res_hole `thenM` \ res_ty ->
+ mapM read_pat_hole pats_w_holes `thenM` \ arg_tys ->
+ readMutVar res_hole `thenM` \ res_ty ->
-- Write the answer into the incoming hole
- writeMutVar hole (mkFunTy arg_ty res_ty) `thenM_`
+ writeMutVar hole (mkFunTys arg_tys res_ty) `thenM_`
-- And return the answer
returnM answer
+ where
+ new_pat_hole pat = newHole `thenM` \ hole -> return (pat, Infer hole)
+ read_pat_hole (pat, Infer hole) = readMutVar hole
-subFunTy (Check ty) thing_inside
- = unifyFunTy ty `thenM` \ (arg,res) ->
- thing_inside (Check arg) (Check res)
-
+subFunTys pats (Check ty) thing_inside
+ = go pats ty `thenM` \ (pats_w_tys, res_ty) ->
+ thing_inside pats_w_tys res_ty
+ where
+ go [] ty = return ([], Check ty)
+ go (pat:pats) ty = unifyFunTy ty `thenM` \ (arg,res) ->
+ go pats res `thenM` \ (pats_w_tys, final_res) ->
+ return ((pat, Check arg) : pats_w_tys, final_res)
unifyFunTy :: TcRhoType -- Fail if ty isn't a function type
-> TcM (TcType, TcType) -- otherwise return arg and result types
projects / ghc-hetmet.git / commitdiff