X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsArrows.lhs;h=111e0bccd04882dfddf0e3a054d2cd851d8b4213;hb=2c6f7109e521e906fda9e3ed7c78b85b7bffcea1;hp=b1714b81bb9b4d0d9d2f31b103c2bab88ded6362;hpb=71d25e0ac3a401cf7d21822ecaa0eee84d5a0417;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsArrows.lhs b/ghc/compiler/deSugar/DsArrows.lhs index b1714b8..111e0bc 100644 --- a/ghc/compiler/deSugar/DsArrows.lhs +++ b/ghc/compiler/deSugar/DsArrows.lhs @@ -10,41 +10,30 @@ module DsArrows ( dsProcExpr ) where import Match ( matchSimply ) import DsUtils ( mkErrorAppDs, - mkCoreTupTy, mkCoreTup, selectMatchVar, + mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL, mkTupleCase, mkBigCoreTup, mkTupleType, mkTupleExpr, mkTupleSelector, - dsReboundNames, lookupReboundName ) + dsSyntaxTable, lookupEvidence ) import DsMonad -import HsSyn ( HsExpr(..), - Stmt(..), HsMatchContext(..), HsStmtContext(..), - Match(..), GRHSs(..), GRHS(..), - HsCmdTop(..), HsArrAppType(..), - ReboundNames, - collectHsBinders, - collectStmtBinders, collectStmtsBinders, - matchContextErrString - ) -import TcHsSyn ( TypecheckedHsCmd, TypecheckedHsCmdTop, - TypecheckedHsExpr, TypecheckedPat, - TypecheckedMatch, TypecheckedGRHS, - TypecheckedStmt, hsPatType, - TypecheckedMatchContext ) +import HsSyn +import TcHsSyn ( hsPatType ) -- 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 {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds ) -import TcType ( Type, tcSplitAppTy ) -import Type ( mkTyConApp ) +import TcType ( Type, tcSplitAppTy, mkFunTy ) +import Type ( mkTyConApp, funArgTy ) import CoreSyn import CoreFVs ( exprFreeVars ) import CoreUtils ( mkIfThenElse, bindNonRec, exprType ) import Id ( Id, idType ) +import Name ( Name ) import PrelInfo ( pAT_ERROR_ID ) import DataCon ( dataConWrapId ) import TysWiredIn ( tupleCon ) @@ -55,11 +44,11 @@ import PrelNames ( eitherTyConName, leftDataConName, rightDataConName, import Util ( mapAccumL ) import Outputable -import HsPat ( collectPatBinders, collectPatsBinders ) +import HsUtils ( collectPatBinders, collectPatsBinders ) import VarSet ( IdSet, mkVarSet, varSetElems, - intersectVarSet, minusVarSet, + intersectVarSet, minusVarSet, extendVarSetList, unionVarSet, unionVarSets, elemVarSet ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( Located(..), unLoc, noLoc ) \end{code} \begin{code} @@ -68,17 +57,17 @@ data DsCmdEnv = DsCmdEnv { arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr } -mkCmdEnv :: ReboundNames Id -> DsM DsCmdEnv +mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv mkCmdEnv ids - = dsReboundNames ids `thenDs` \ (meth_binds, ds_meths) -> + = dsSyntaxTable 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 + arr_id = Var (lookupEvidence ds_meths arrAName), + compose_id = Var (lookupEvidence ds_meths composeAName), + first_id = Var (lookupEvidence ds_meths firstAName), + app_id = Var (lookupEvidence ds_meths appAName), + choice_id = Var (lookupEvidence ds_meths choiceAName), + loop_id = Var (lookupEvidence ds_meths loopAName) } bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr @@ -122,7 +111,7 @@ do_map_arrow :: DsCmdEnv -> Type -> Type -> Type -> 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 :: HsMatchContext Id -> Type -> DsM CoreExpr mkFailExpr ctxt ty = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) @@ -150,7 +139,7 @@ coreCaseTuple uniqs scrut_var vars body coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body - = Case (Var scrut_var) scrut_var + = Case (Var scrut_var) scrut_var (exprType body) [(DataAlt (tupleCon Boxed 2), [var1, var2], body)] \end{code} @@ -201,7 +190,7 @@ matchEnvStack :: [Id] -- x1..xn -> CoreExpr -- e -> DsM CoreExpr matchEnvStack env_ids stack_ids body - = getUniqSupplyDs `thenDs` \ uniqs -> + = newUniqueSupply `thenDs` \ uniqs -> newSysLocalDs (mkTupleType env_ids) `thenDs` \ tup_var -> matchVarStack tup_var stack_ids (coreCaseTuple uniqs tup_var env_ids body) @@ -232,14 +221,14 @@ matchVarStack env_id (stack_id:stack_ids) body \end{code} \begin{code} -mkHsTupleExpr :: [TypecheckedHsExpr] -> TypecheckedHsExpr +mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id mkHsTupleExpr [e] = e -mkHsTupleExpr es = ExplicitTuple es Boxed +mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed -mkHsPairExpr :: TypecheckedHsExpr -> TypecheckedHsExpr -> TypecheckedHsExpr +mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2] -mkHsEnvStackExpr :: [Id] -> [Id] -> TypecheckedHsExpr +mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id mkHsEnvStackExpr env_ids stack_ids = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids) \end{code} @@ -255,13 +244,11 @@ Translation of arrow abstraction -- where (xs) is the tuple of variables bound by p dsProcExpr - :: TypecheckedPat - -> TypecheckedHsCmdTop - -> SrcLoc + :: LPat Id + -> LHsCmdTop Id -> DsM CoreExpr -dsProcExpr pat (HsCmdTop cmd [] cmd_ty ids) locn - = putSrcLocDs locn $ - mkCmdEnv ids `thenDs` \ meth_ids -> +dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) + = mkCmdEnv ids `thenDs` \ meth_ids -> let locals = mkVarSet (collectPatBinders pat) in @@ -271,7 +258,7 @@ dsProcExpr pat (HsCmdTop cmd [] cmd_ty ids) locn env_ty = mkTupleType env_ids in mkFailExpr ProcExpr env_ty `thenDs` \ fail_expr -> - selectMatchVar pat `thenDs` \ var -> + selectSimpleMatchVarL pat `thenDs` \ var -> matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr `thenDs` \ match_code -> let @@ -281,7 +268,6 @@ dsProcExpr pat (HsCmdTop cmd [] cmd_ty ids) locn core_cmd in returnDs (bindCmdEnv meth_ids proc_code) - \end{code} Translation of command judgements of the form @@ -289,55 +275,73 @@ Translation of command judgements of the form A | xs |- c :: [ts] t \begin{code} +dsLCmd ids local_vars env_ids stack res_ty cmd + = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd) -dsCmd :: DsCmdEnv -- arrow combinators +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 + -> HsCmd Id -- command to desugar -> DsM (CoreExpr, -- desugared expression IdSet) -- set of local vars that occur free --- A |- f :: a t t' +-- A |- f :: a (t*ts) t' -- A, xs |- arg :: t --- --------------------------- --- A | xs |- f -< arg :: [] t' ---> arr (\ (xs) -> arg) >>> f +-- ----------------------------- +-- A | xs |- f -< arg :: [ts] t' +-- +-- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f -dsCmd ids local_vars env_ids [] res_ty - (HsArrApp arrow arg arrow_ty HsFirstOrderApp _ _) +dsCmd ids local_vars env_ids stack 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 = mkTupleType 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 + dsLExpr arrow `thenDs` \ core_arrow -> + dsLExpr arg `thenDs` \ core_arg -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> + matchEnvStack env_ids stack_ids + (foldl mkCorePairExpr core_arg (map Var stack_ids)) + `thenDs` \ core_make_arg -> + returnDs (do_map_arrow ids + (envStackType env_ids stack) + arg_ty + res_ty core_make_arg core_arrow, exprFreeVars core_arg `intersectVarSet` local_vars) --- A, xs |- f :: a t t' +-- A, xs |- f :: a (t*ts) t' -- A, xs |- arg :: t --- --------------------------- --- A | xs |- f -<< arg :: [] t' ---> arr (\ (xs) -> (f,arg)) >>> app +-- ------------------------------ +-- A | xs |- f -<< arg :: [ts] t' +-- +-- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app -dsCmd ids local_vars env_ids [] res_ty - (HsArrApp arrow arg arrow_ty HsHigherOrderApp _ _) +dsCmd ids local_vars env_ids stack 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 = mkTupleType env_ids in - dsExpr arrow `thenDs` \ core_arrow -> - dsExpr arg `thenDs` \ core_arg -> - matchEnvStack env_ids [] (mkCorePairExpr core_arrow core_arg) + dsLExpr arrow `thenDs` \ core_arrow -> + dsLExpr arg `thenDs` \ core_arg -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> + matchEnvStack env_ids stack_ids + (mkCorePairExpr core_arrow + (foldl mkCorePairExpr core_arg (map Var stack_ids))) `thenDs` \ core_make_pair -> - returnDs (do_map_arrow ids env_ty (mkCorePairTy arrow_ty arg_ty) res_ty + returnDs (do_map_arrow ids + (envStackType env_ids stack) + (mkCorePairTy arrow_ty arg_ty) + res_ty core_make_pair (do_app ids arg_ty res_ty), (exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg) @@ -351,14 +355,14 @@ dsCmd ids local_vars env_ids [] res_ty -- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) - = dsExpr arg `thenDs` \ core_arg -> + = dsLExpr arg `thenDs` \ core_arg -> let arg_ty = exprType core_arg stack' = arg_ty:stack in dsfixCmd ids local_vars stack' res_ty cmd `thenDs` \ (core_cmd, free_vars, env_ids') -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> newSysLocalDs arg_ty `thenDs` \ arg_id -> -- push the argument expression onto the stack let @@ -384,7 +388,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) -- ---> 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))) + (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) = let pat_vars = mkVarSet (collectPatsBinders pats) local_vars' = local_vars `unionVarSet` pat_vars @@ -392,7 +396,7 @@ dsCmd ids local_vars env_ids stack res_ty in dsfixCmd ids local_vars' stack' res_ty body `thenDs` \ (core_body, free_vars, env_ids') -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> -- the expression is built from the inside out, so the actions -- are presented in reverse order @@ -415,7 +419,7 @@ dsCmd ids local_vars env_ids stack res_ty 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 + = dsLCmd ids local_vars env_ids stack res_ty cmd -- A, xs |- e :: Bool -- A | xs1 |- c1 :: [ts] t @@ -427,13 +431,13 @@ dsCmd ids local_vars env_ids stack res_ty (HsPar cmd) -- 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 _loc) - = dsExpr cond `thenDs` \ core_cond -> +dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd) + = dsLExpr 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 -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> dsLookupTyCon eitherTyConName `thenDs` \ either_con -> dsLookupDataCon leftDataConName `thenDs` \ left_con -> dsLookupDataCon rightDataConName `thenDs` \ right_con -> @@ -485,9 +489,9 @@ case bodies, containing the following fields: bodies with |||. \begin{code} -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 -> +dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty)) + = dsLExpr exp `thenDs` \ core_exp -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> -- Extract and desugar the leaf commands in the case, building tuple -- expressions that will (after tagging) replace these leaves @@ -496,21 +500,21 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) 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) -> + `thenDs` \ (core_leaf, fvs, leaf_ids) -> returnDs (fvs `minusVarSet` bound_vars, - [mkHsEnvStackExpr leaf_ids stack_ids], + [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids], envStackType leaf_ids stack, core_leaf) in - mapDs make_branch leaves `thenDs` \ branches -> + mappM 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 + left_id = nlHsVar (dataConWrapId left_con) + right_id = nlHsVar (dataConWrapId right_con) + left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp left_id [ty1, ty2]) e + right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ 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. @@ -526,17 +530,22 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) = foldb merge_branches branches -- Replace the commands in the case with these tagged tuples, - -- yielding a TypecheckedHsExpr we can feed to dsExpr. + -- yielding a HsExpr Id we can feed to dsExpr. (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches in_ty = envStackType env_ids stack fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars + + pat_ty = funArgTy match_ty + match_ty' = mkFunTy pat_ty sum_ty + -- Note that we replace the HsCase result type by sum_ty, + -- which is the type of matches' in - dsExpr (HsCase exp matches' src_loc) `thenDs` \ core_body -> + dsExpr (HsCase exp (MatchGroup matches' match_ty')) `thenDs` \ core_body -> matchEnvStack env_ids stack_ids core_body `thenDs` \ core_matches -> returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices, - fvs_exp `unionVarSet` fvs_alts) + fvs_exp `unionVarSet` fvs_alts) -- A | ys |- c :: [ts] t -- ---------------------------------- @@ -546,14 +555,14 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = let - defined_vars = mkVarSet (collectHsBinders binds) + defined_vars = mkVarSet (map unLoc (collectLocalBinders 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 -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> -- build a new environment, plus the stack, using the let bindings - dsLet binds (buildEnvStack env_ids' stack_ids) + dsLocalBinds 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 @@ -566,19 +575,19 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) core_body, exprFreeVars core_binds `intersectVarSet` local_vars) -dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _ _loc) - = dsCmdDo ids local_vars env_ids res_ty stmts +dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _) + = dsCmdDo ids local_vars env_ids res_ty stmts body -- 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 _) +dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args) = let env_ty = mkTupleType env_ids in - dsExpr op `thenDs` \ core_op -> + dsLExpr 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, @@ -591,14 +600,14 @@ dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args _) 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 + -> LHsCmdTop Id -- 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) +dsTrimCmdArg local_vars env_ids (L _ (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 -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids) `thenDs` \ trim_code -> let @@ -617,13 +626,13 @@ dsfixCmd -> IdSet -- set of local vars available to this command -> [Type] -- type of the stack -> Type -- return type of the command - -> TypecheckedHsCmd -- command to desugar + -> LHsCmd Id -- 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 + dsLCmd ids local_vars env_ids' stack cmd_ty cmd `thenDs` \ (core_cmd, free_vars) -> returnDs (core_cmd, free_vars, varSetElems free_vars)) @@ -641,7 +650,8 @@ dsCmdDo :: DsCmdEnv -- arrow combinators -- This is typically fed back, -- so don't pull on it too early -> Type -- return type of the statement - -> [TypecheckedStmt] -- statements to desugar + -> [LStmt Id] -- statements to desugar + -> LHsExpr Id -- body -> DsM (CoreExpr, -- desugared expression IdSet) -- set of local vars that occur free @@ -649,20 +659,20 @@ dsCmdDo :: DsCmdEnv -- arrow combinators -- -------------------------- -- 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 [] body + = dsLCmd ids local_vars env_ids [] res_ty body -dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) +dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = let - bound_vars = mkVarSet (collectStmtBinders stmt) + bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt)) local_vars' = local_vars `unionVarSet` bound_vars in fixDs (\ ~(_,_,env_ids') -> - dsCmdDo ids local_vars' env_ids' res_ty stmts + dsCmdDo ids local_vars' env_ids' res_ty stmts body `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 + dsCmdLStmt ids local_vars env_ids env_ids' stmt `thenDs` \ (core_stmt, fv_stmt) -> returnDs (do_compose ids (mkTupleType env_ids) @@ -677,6 +687,8 @@ A statement maps one local environment to another, and is represented as an arrow from one tuple type to another. A statement sequence is translated to a composition of such arrows. \begin{code} +dsCmdLStmt ids local_vars env_ids out_ids cmd + = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd) dsCmdStmt :: DsCmdEnv -- arrow combinators @@ -685,7 +697,7 @@ dsCmdStmt -- 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 + -> Stmt Id -- statement to desugar -> DsM (CoreExpr, -- desugared expression IdSet) -- set of local vars that occur free @@ -697,7 +709,7 @@ dsCmdStmt -- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>> -- arr snd >>> ss -dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty _loc) +dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty) = dsfixCmd ids local_vars [] c_ty cmd `thenDs` \ (core_cmd, fv_cmd, env_ids1) -> matchEnvStack env_ids [] @@ -715,7 +727,7 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty _loc) 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) + extendVarSetList fv_cmd out_ids) where -- A | xs1 |- c :: [] t @@ -729,7 +741,7 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty _loc) -- 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 _loc) +dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) = dsfixCmd ids local_vars [] (hsPatType pat) cmd `thenDs` \ (core_cmd, fv_cmd, env_ids1) -> let @@ -749,15 +761,15 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _loc) -- projection function -- \ (p, (xs2)) -> (zs) - selectMatchVar pat `thenDs` \ pat_id -> newSysLocalDs env_ty2 `thenDs` \ env_id -> - getUniqSupplyDs `thenDs` \ uniqs -> + newUniqueSupply `thenDs` \ uniqs -> let after_c_ty = mkCorePairTy pat_ty env_ty2 out_ty = mkTupleType out_ids body_expr = coreCaseTuple uniqs env_id env_ids2 (mkTupleExpr out_ids) in mkFailExpr (StmtCtxt DoExpr) out_ty `thenDs` \ fail_expr -> + selectSimpleMatchVarL pat `thenDs` \ pat_id -> matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr `thenDs` \ match_code -> newSysLocalDs after_c_ty `thenDs` \ pair_id -> @@ -786,7 +798,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _loc) 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 -> + = dsLocalBinds 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 @@ -809,8 +821,8 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) -- 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 +dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss binds) + = let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ******** env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids env2_ids = varSetElems env2_id_set env2_ty = mkTupleType env2_ids @@ -818,7 +830,7 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss) -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) - getUniqSupplyDs `thenDs` \ uniqs -> + newUniqueSupply `thenDs` \ uniqs -> newSysLocalDs env2_ty `thenDs` \ env2_id -> let later_ty = mkTupleType later_ids @@ -874,7 +886,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss -- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss)) - mapDs dsExpr rhss `thenDs` \ core_rhss -> + mappM dsExpr rhss `thenDs` \ core_rhss -> let later_tuple = mkTupleExpr later_ids later_ty = mkTupleType later_ids @@ -931,7 +943,7 @@ dsfixCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- output vars of these statements - -> [TypecheckedStmt] -- statements to desugar + -> [LStmt Id] -- statements to desugar -> DsM (CoreExpr, -- desugared expression IdSet, -- set of local vars that occur free [Id]) -- input vars @@ -947,21 +959,21 @@ dsCmdStmts -> 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 + -> [LStmt Id] -- 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 + = dsCmdLStmt ids local_vars env_ids out_ids stmt dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = let - bound_vars = mkVarSet (collectStmtBinders stmt) + bound_vars = mkVarSet (map unLoc (collectLStmtBinders 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 + dsCmdLStmt ids local_vars env_ids env_ids' stmt `thenDs` \ (core_stmt, fv_stmt) -> returnDs (do_compose ids (mkTupleType env_ids) @@ -976,11 +988,11 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) 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 +matchSimplys :: [CoreExpr] -- Scrutinees + -> HsMatchContext Name -- Match kind + -> [LPat Id] -- 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 @@ -992,15 +1004,17 @@ matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr List of leaf expressions, with set of variables bound in each \begin{code} -leavesMatch :: TypecheckedMatch -> [(TypecheckedHsExpr, IdSet)] -leavesMatch (Match pats _ (GRHSs grhss binds _ty)) +leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)] +leavesMatch (L _ (Match pats _ (GRHSs grhss binds))) = let - defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` - mkVarSet (collectHsBinders binds) + defined_vars = mkVarSet (collectPatsBinders pats) + `unionVarSet` + mkVarSet (map unLoc (collectLocalBinders binds)) in - [(expr, mkVarSet (collectStmtsBinders stmts) `unionVarSet` defined_vars) | - GRHS stmts _locn <- grhss, - let ResultStmt expr _ = last stmts] + [(expr, + mkVarSet (map unLoc (collectLStmtsBinders stmts)) + `unionVarSet` defined_vars) + | L _ (GRHS stmts expr) <- grhss] \end{code} Replace the leaf commands in a match @@ -1008,23 +1022,23 @@ Replace the leaf commands in a match \begin{code} 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)) + -> [LHsExpr Id] -- replacement leaf expressions of that type + -> LMatch Id -- the matches of a case command + -> ([LHsExpr Id],-- remaining leaf expressions + LMatch Id) -- updated match +replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds))) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in - (leaves', Match pat mt (GRHSs grhss' binds res_ty)) + (leaves', L loc (Match pat mt (GRHSs grhss' binds))) replaceLeavesGRHS - :: [TypecheckedHsExpr] -- replacement leaf expressions of that type - -> TypecheckedGRHS -- rhss of a case command - -> ([TypecheckedHsExpr],-- remaining leaf expressions - TypecheckedGRHS) -- updated GRHS -replaceLeavesGRHS (leaf:leaves) (GRHS stmts srcloc) - = (leaves, GRHS (init stmts ++ [ResultStmt leaf srcloc]) srcloc) + :: [LHsExpr Id] -- replacement leaf expressions of that type + -> LGRHS Id -- rhss of a case command + -> ([LHsExpr Id],-- remaining leaf expressions + LGRHS Id) -- updated GRHS +replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts rhs)) + = (leaves, L loc (GRHS stmts leaf)) \end{code} Balanced fold of a non-empty list.