X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsArrows.lhs;h=0ef7fa5f8c84e1ee663658207976448e739c427c;hp=111e0bccd04882dfddf0e3a054d2cd851d8b4213;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 111e0bc..0ef7fa5 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -1,23 +1,29 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[DsArrows]{Desugaring arrow commands} + +Desugaring arrow commands \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module DsArrows ( dsProcExpr ) where #include "HsVersions.h" -import Match ( matchSimply ) -import DsUtils ( mkErrorAppDs, - mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL, - mkTupleCase, mkBigCoreTup, mkTupleType, - mkTupleExpr, mkTupleSelector, - dsSyntaxTable, lookupEvidence ) +import Match +import DsUtils import DsMonad -import HsSyn -import TcHsSyn ( hsPatType ) +import HsSyn hiding (collectPatBinders, collectLocatedPatBinders, collectl, + collectPatsBinders, collectLocatedPatsBinders) +import TcHsSyn -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types (newtypes etc), and sometimes not @@ -26,29 +32,25 @@ import TcHsSyn ( hsPatType ) import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds ) -import TcType ( Type, tcSplitAppTy, mkFunTy ) -import Type ( mkTyConApp, funArgTy ) +import TcType +import Type 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 ) -import BasicTypes ( Boxity(..) ) -import PrelNames ( eitherTyConName, leftDataConName, rightDataConName, - arrAName, composeAName, firstAName, - appAName, choiceAName, loopAName ) -import Util ( mapAccumL ) -import Outputable - -import HsUtils ( collectPatBinders, collectPatsBinders ) -import VarSet ( IdSet, mkVarSet, varSetElems, - intersectVarSet, minusVarSet, extendVarSetList, - unionVarSet, unionVarSets, elemVarSet ) -import SrcLoc ( Located(..), unLoc, noLoc ) +import CoreFVs +import CoreUtils + +import Id +import Name +import PrelInfo +import DataCon +import TysWiredIn +import BasicTypes +import PrelNames +import Util + +import VarSet +import SrcLoc + +import Data.List \end{code} \begin{code} @@ -262,7 +264,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr `thenDs` \ match_code -> let - pat_ty = hsPatType pat + pat_ty = hsLPatType pat proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty (Lam var match_code) core_cmd @@ -511,10 +513,10 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ dsLookupDataCon leftDataConName `thenDs` \ left_con -> dsLookupDataCon rightDataConName `thenDs` \ right_con -> let - 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 + left_id = HsVar (dataConWrapId left_con) + right_id = HsVar (dataConWrapId right_con) + left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e + right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e -- Prefix each tuple with a distinct series of Left's and Right's, -- in a balanced way, keeping track of the types. @@ -593,6 +595,12 @@ dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args) returnDs (mkApps (App core_op (Type env_ty)) core_args, unionVarSets fv_sets) + +dsCmd ids local_vars env_ids stack res_ty (HsTick ix vars expr) + = dsLCmd ids local_vars env_ids stack res_ty expr `thenDs` \ (expr1,id_set) -> + mkTickBox ix vars expr1 `thenDs` \ expr2 -> + return (expr2,id_set) + -- A | ys |- c :: [ts] t (ys <= xs) -- --------------------- -- A | xs |- c :: [ts] t ---> arr_ts (\ (xs) -> (ys)) >>> c @@ -742,10 +750,10 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty) -- but that's likely to be defined in terms of first. dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) - = dsfixCmd ids local_vars [] (hsPatType pat) cmd + = dsfixCmd ids local_vars [] (hsLPatType pat) cmd `thenDs` \ (core_cmd, fv_cmd, env_ids1) -> let - pat_ty = hsPatType pat + pat_ty = hsLPatType pat pat_vars = mkVarSet (collectPatBinders pat) env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars) env_ty2 = mkTupleType env_ids2 @@ -1053,3 +1061,65 @@ foldb f xs = foldb f (fold_pairs xs) fold_pairs [x] = [x] fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs \end{code} + +The following functions to collect value variables from patterns are +copied from HsUtils, with one change: we also collect the dictionary +bindings (pat_binds) from ConPatOut. We need them for cases like + +h :: Arrow a => Int -> a (Int,Int) Int +h x = proc (y,z) -> case compare x y of + GT -> returnA -< z+x + +The type checker turns the case into + + case compare x y of + GT { p77 = plusInt } -> returnA -< p77 z x + +Here p77 is a local binding for the (+) operation. + +See comments in HsUtils for why the other version does not include +these bindings. + +\begin{code} +collectPatBinders :: LPat a -> [a] +collectPatBinders pat = map unLoc (collectLocatedPatBinders pat) + +collectLocatedPatBinders :: LPat a -> [Located a] +collectLocatedPatBinders pat = collectl pat [] + +collectPatsBinders :: [LPat a] -> [a] +collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats) + +collectLocatedPatsBinders :: [LPat a] -> [Located a] +collectLocatedPatsBinders pats = foldr collectl [] pats + +--------------------- +collectl (L l pat) bndrs + = go pat + where + go (VarPat var) = L l var : bndrs + go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs + ++ bndrs + go (WildPat _) = bndrs + go (LazyPat pat) = collectl pat bndrs + go (BangPat pat) = collectl pat bndrs + go (AsPat a pat) = a : collectl pat bndrs + go (ParPat pat) = collectl pat bndrs + + go (ListPat pats _) = foldr collectl bndrs pats + go (PArrPat pats _) = foldr collectl bndrs pats + go (TuplePat pats _ _) = foldr collectl bndrs pats + + go (ConPatIn c ps) = foldr collectl bndrs (hsConPatArgs ps) + go (ConPatOut {pat_args=ps, pat_binds=ds}) = + collectHsBindLocatedBinders ds + ++ foldr collectl bndrs (hsConPatArgs ps) + go (LitPat _) = bndrs + go (NPat _ _ _ _) = bndrs + go (NPlusKPat n _ _ _) = n : bndrs + + go (SigPatIn pat _) = collectl pat bndrs + go (SigPatOut pat _) = collectl pat bndrs + go (TypePat ty) = bndrs + go (CoPat _ pat ty) = collectl (noLoc pat) bndrs +\end{code}