X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=b80145a6232bb761b0f52eb95c57c00143f7345f;hp=d9c45e6529c177edea88066958f869a35576627a;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index d9c45e6..b80145a 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -1,5 +1,5 @@ % -% (c) The University of Glasgow, 1992-2003 +% (c) The University of Glasgow, 1992-2006 % Here we collect a variety of helper functions that construct or @@ -22,18 +22,18 @@ import HsExpr import HsPat import HsTypes import HsLit - -import RdrName ( RdrName, getRdrName, mkRdrUnqual ) -import Var ( Id ) -import Type ( Type ) -import DataCon ( DataCon, dataConWrapId, dataConSourceArity ) -import OccName ( mkVarOccFS ) -import Name ( Name ) -import BasicTypes ( RecFlag(..) ) +import HsDecls + +import RdrName +import Var +import Type +import DataCon +import Name +import BasicTypes import SrcLoc -import FastString ( mkFastString ) +import FastString import Outputable -import Util ( nOfThem ) +import Util import Bag \end{code} @@ -52,16 +52,18 @@ just attach noSrcSpan to everything. mkHsPar :: LHsExpr id -> LHsExpr id mkHsPar e = L (getLoc e) (HsPar e) --- gaw 2004 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id mkSimpleMatch pats rhs = L loc $ - Match pats Nothing (GRHSs (unguardedRHS rhs) emptyLocalBinds) + Match pats Nothing (unguardedGRHSs rhs) where loc = case pats of [] -> getLoc rhs (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) +unguardedGRHSs :: LHsExpr id -> GRHSs id +unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds + unguardedRHS :: LHsExpr id -> [LGRHS id] unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)] @@ -71,17 +73,15 @@ mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) -mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name -mkHsTyApp expr [] = expr -mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys) +nlHsTyApp :: name -> [Type] -> LHsExpr name +nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id)) -mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name -mkHsDictApp expr [] = expr -mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars) +mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id +mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) -mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id -mkHsCoerce co_fn e | isIdCoercion co_fn = e - | otherwise = HsCoerce co_fn e +mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id +mkHsWrap co_fn e | isIdHsWrapper co_fn = e + | otherwise = HsWrap co_fn e mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) @@ -91,12 +91,6 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) mkMatchGroup :: [LMatch id] -> MatchGroup id mkMatchGroup matches = MatchGroup matches placeHolderType -mkHsTyLam [] expr = expr -mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr) - -mkHsDictLam [] expr = expr -mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr) - mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id -- Used for the dictionary bindings gotten from TcSimplify -- We make them recursive to be on the safe side @@ -109,7 +103,7 @@ mkHsDictLet binds expr mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id -- Used for constructing dictinoary terms etc, so no locations mkHsConApp data_con tys args - = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args + = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args where mk_app f a = noLoc (HsApp f (noLoc a)) @@ -218,6 +212,8 @@ nlList exprs = noLoc (ExplicitList placeHolderType exprs) nlHsAppTy f t = noLoc (HsAppTy f t) nlHsTyVar x = noLoc (HsTyVar x) nlHsFunTy a b = noLoc (HsFunTy a b) + +nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys \end{code} @@ -232,7 +228,8 @@ nlHsFunTy a b = noLoc (HsFunTy a b) mkFunBind :: Located id -> [LMatch id] -> HsBind id -- Not infix, with place holders for coercion and free vars mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms, - fun_co_fn = idCoercion, bind_fvs = placeHolderNames } + fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, + fun_tick = Nothing } mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName @@ -385,20 +382,30 @@ collectl (L l pat) bndrs go (TuplePat pats _ _) = foldr collectl bndrs pats go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps) - go (ConPatOut c _ ds bs ps _) = map noLoc ds - ++ collectHsBindLocatedBinders bs - ++ foldr collectl bndrs (hsConArgs ps) + go (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConArgs ps) + -- See Note [Dictionary binders in ConPatOut] 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 (DictPat ids1 ids2) = map noLoc ids1 ++ map noLoc ids2 ++ bndrs + go (CoPat _ pat ty) = collectl (noLoc pat) bndrs \end{code} +Note [Dictionary binders in ConPatOut] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* gather (a) dictionary and (b) dictionary bindings as binders +of a ConPatOut pattern. For most calls it doesn't matter, because +it's pre-typechecker and there are no ConPatOuts. But it does matter +more in the desugarer; for example, DsUtils.mkSelectorBinds uses +collectPatBinders. In a lazy pattern, for example f ~(C x y) = ..., +we want to generate bindings for x,y but not for dictionaries bound by +C. (The type checker ensures they would not be used.) + \begin{code} collectSigTysFromPats :: [InPat name] -> [LHsType name] collectSigTysFromPats pats = foldr collect_lpat [] pats @@ -421,3 +428,24 @@ collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps) collect_pat other acc = acc -- Literals, vars, wildcard \end{code} + +%************************************************************************ +%* * +%* Getting the main binder name of a top declaration +%* * +%************************************************************************ + +\begin{code} + +getMainDeclBinder :: HsDecl name -> Maybe name +getMainDeclBinder (TyClD d) = Just (tcdName d) +getMainDeclBinder (ValD d) + = case collectAcc d [] of + [] -> Nothing -- see rn003 + (name:_) -> Just (unLoc name) +getMainDeclBinder (SigD d) = sigNameNoLoc d +getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) +getMainDeclBinder (ForD (ForeignExport name _ _)) = Just (unLoc name) +getMainDeclBinder _ = Nothing + +\end{code}