X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsBinds.lhs;h=ebac06fa0580a3de2fb7e9133079ee651f1bcb06;hp=40b51ca440f08c4ee2520a997eed9e3424778386;hb=ab22f4e6456820c1b5169d75f5975a94e61f54ce;hpb=247fd64109002ed88c27bc5d6cfea6a71ee48cfa diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 40b51ca..ebac06f 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[HsBinds]{Abstract syntax: top-level bindings and signatures} @@ -15,18 +16,18 @@ import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) -import HsTypes ( LHsType, PostTcType ) -import PprCore ( {- instances -} ) -import Coercion ( Coercion ) -import Type ( Type, pprParendType ) -import Name ( Name ) -import NameSet ( NameSet, elemNameSet ) -import BasicTypes ( IPName, RecFlag(..), InlineSpec(..), Fixity ) +import HsTypes +import PprCore +import Coercion +import Type +import Name +import NameSet +import BasicTypes import Outputable -import SrcLoc ( Located(..), SrcSpan, unLoc ) -import Util ( sortLe ) -import Var ( TyVar, DictId, Id, Var ) -import Bag ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags ) +import SrcLoc +import Util +import Var +import Bag \end{code} %************************************************************************ @@ -76,7 +77,7 @@ data HsBind id fun_matches :: MatchGroup id, -- The payload - fun_co_fn :: ExprCoFn, -- Coercion from the type of the MatchGroup to the type of + fun_co_fn :: HsWrapper, -- Coercion from the type of the MatchGroup to the type of -- the Id. Example: -- f :: Int -> forall a. a -> a -- f x y = y @@ -84,9 +85,7 @@ data HsBind id -- (with a free type variable a'). The coercion will take -- a CoreExpr of this type and convert it to a CoreExpr of -- type Int -> forall a'. a' -> a' - -- Notice that the coercion captures the free a'. That's - -- why coercions are (CoreExpr -> CoreExpr), rather than - -- just CoreExpr (with a functional type) + -- Notice that the coercion captures the free a'. bind_fvs :: NameSet -- After the renamer, this contains a superset of the -- Names of the other binders in this binding group that @@ -298,67 +297,67 @@ instance (OutputableBndr id) => Outputable (IPBind id) where %************************************************************************ \begin{code} --- A ExprCoFn is an expression with a hole in it +-- A HsWrapper is an expression with a hole in it -- We need coercions to have concrete form so that we can zonk them -data ExprCoFn - = CoHole -- The identity coercion +data HsWrapper + = WpHole -- The identity coercion - | CoCompose ExprCoFn ExprCoFn -- (\a1..an. []) `CoCompose` (\x1..xn. []) + | WpCompose HsWrapper HsWrapper -- (\a1..an. []) `WpCompose` (\x1..xn. []) -- = (\a1..an \x1..xn. []) - | ExprCoFn Coercion -- A cast: [] `cast` co + | WpCo Coercion -- A cast: [] `cast` co -- Guaranteedn not the identity coercion - | CoApp Var -- [] x; the xi are dicts or coercions - | CoTyApp Type -- [] t - | CoLam Id -- \x. []; the xi are dicts or coercions - | CoTyLam TyVar -- \a. [] + | WpApp Var -- [] x; the xi are dicts or coercions + | WpTyApp Type -- [] t + | WpLam Id -- \x. []; the xi are dicts or coercions + | WpTyLam TyVar -- \a. [] -- Non-empty bindings, so that the identity coercion - -- is always exactly CoHole - | CoLet (LHsBinds Id) -- let binds in [] + -- is always exactly WpHole + | WpLet (LHsBinds Id) -- let binds in [] -- (would be nicer to be core bindings) -instance Outputable ExprCoFn where - ppr co_fn = pprCoFn (ptext SLIT("<>")) co_fn +instance Outputable HsWrapper where + ppr co_fn = pprHsWrapper (ptext SLIT("<>")) co_fn -pprCoFn :: SDoc -> ExprCoFn -> SDoc -pprCoFn it CoHole = it -pprCoFn it (CoCompose f1 f2) = pprCoFn (pprCoFn it f2) f1 -pprCoFn it (ExprCoFn co) = it <+> ptext SLIT("`cast`") <+> pprParendType co -pprCoFn it (CoApp id) = it <+> ppr id -pprCoFn it (CoTyApp ty) = it <+> ptext SLIT("@") <+> pprParendType ty -pprCoFn it (CoLam id) = ptext SLIT("\\") <> pprBndr LambdaBind id <> dot <+> it -pprCoFn it (CoTyLam tv) = ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot <+> it -pprCoFn it (CoLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it] +pprHsWrapper :: SDoc -> HsWrapper -> SDoc +pprHsWrapper it WpHole = it +pprHsWrapper it (WpCompose f1 f2) = pprHsWrapper (pprHsWrapper it f2) f1 +pprHsWrapper it (WpCo co) = it <+> ptext SLIT("`cast`") <+> pprParendType co +pprHsWrapper it (WpApp id) = it <+> ppr id +pprHsWrapper it (WpTyApp ty) = it <+> ptext SLIT("@") <+> pprParendType ty +pprHsWrapper it (WpLam id) = ptext SLIT("\\") <> pprBndr LambdaBind id <> dot <+> it +pprHsWrapper it (WpTyLam tv) = ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot <+> it +pprHsWrapper it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it] -(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn -CoHole <.> c = c -c <.> CoHole = c -c1 <.> c2 = c1 `CoCompose` c2 +(<.>) :: HsWrapper -> HsWrapper -> HsWrapper +WpHole <.> c = c +c <.> WpHole = c +c1 <.> c2 = c1 `WpCompose` c2 -mkCoTyApps :: [Type] -> ExprCoFn -mkCoTyApps tys = mk_co_fn CoTyApp (reverse tys) +mkWpTyApps :: [Type] -> HsWrapper +mkWpTyApps tys = mk_co_fn WpTyApp (reverse tys) -mkCoApps :: [Id] -> ExprCoFn -mkCoApps ids = mk_co_fn CoApp (reverse ids) +mkWpApps :: [Id] -> HsWrapper +mkWpApps ids = mk_co_fn WpApp (reverse ids) -mkCoTyLams :: [TyVar] -> ExprCoFn -mkCoTyLams ids = mk_co_fn CoTyLam ids +mkWpTyLams :: [TyVar] -> HsWrapper +mkWpTyLams ids = mk_co_fn WpTyLam ids -mkCoLams :: [Id] -> ExprCoFn -mkCoLams ids = mk_co_fn CoLam ids +mkWpLams :: [Id] -> HsWrapper +mkWpLams ids = mk_co_fn WpLam ids -mk_co_fn :: (a -> ExprCoFn) -> [a] -> ExprCoFn -mk_co_fn f as = foldr (CoCompose . f) CoHole as +mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +mk_co_fn f as = foldr (WpCompose . f) WpHole as -idCoercion :: ExprCoFn -idCoercion = CoHole +idHsWrapper :: HsWrapper +idHsWrapper = WpHole -isIdCoercion :: ExprCoFn -> Bool -isIdCoercion CoHole = True -isIdCoercion other = False +isIdHsWrapper :: HsWrapper -> Bool +isIdHsWrapper WpHole = True +isIdHsWrapper other = False \end{code} @@ -441,13 +440,14 @@ sigForThisGroup ns sig Just n -> n `elemNameSet` ns sigName :: LSig name -> Maybe name -sigName (L _ sig) = f sig - where - f (TypeSig n _) = Just (unLoc n) - f (SpecSig n _ _) = Just (unLoc n) - f (InlineSig n _) = Just (unLoc n) - f (FixSig (FixitySig n _)) = Just (unLoc n) - f other = Nothing +sigName (L _ sig) = sigNameNoLoc sig + +sigNameNoLoc :: Sig name -> Maybe name +sigNameNoLoc (TypeSig n _) = Just (unLoc n) +sigNameNoLoc (SpecSig n _ _) = Just (unLoc n) +sigNameNoLoc (InlineSig n _) = Just (unLoc n) +sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n) +sigNameNoLoc other = Nothing isFixityLSig :: LSig name -> Bool isFixityLSig (L _ (FixSig {})) = True