X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsBinds.lhs;h=c0f01a86108040e9cb4ad85e200d54a17474e8b3;hp=78a22343bb9fe87b67750e1f21d3018a04c91bb1;hb=a8427a4125e9b78e88a487eeabf018f1c6e8bc08;hpb=0d7cc019c65244968f8bc9cbeb5501a3bb832776 diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 78a2234..c0f01a8 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,16 +16,18 @@ import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) -import HsTypes ( LHsType, PostTcType ) -import Type ( Type ) -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 ) -import Bag ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags ) +import SrcLoc +import Util +import Var +import Bag \end{code} %************************************************************************ @@ -49,7 +52,9 @@ data HsValBinds id -- Value bindings (not implicit parameters) -- Recursive by default | ValBindsOut -- After renaming - [(RecFlag, LHsBinds id)] -- Dependency analysed + [(RecFlag, LHsBinds id)] -- Dependency analysed, later bindings + -- in the list may depend on earlier + -- ones. [LSig Name] type LHsBinds id = Bag (LHsBind id) @@ -59,21 +64,22 @@ type LHsBind id = Located (HsBind id) data HsBind id = FunBind { -- FunBind is used for both functions f x = e -- and variables f = \x -> e --- Reason 1: the Match stuff lets us have an optional --- result type sig f :: a->a = ...mentions a... +-- Reason 1: Special case for type inference: see TcBinds.tcMonoBinds -- --- Reason 2: Special case for type inference: see TcBinds.tcMonoBinds --- --- Reason 3: instance decls can only have FunBinds, which is convenient +-- Reason 2: instance decls can only have FunBinds, which is convenient -- If you change this, you'll need tochange e.g. rnMethodBinds +-- But note that the form f :: a->a = ... +-- parses as a pattern binding, just like +-- (f :: a -> a) = ... + fun_id :: Located id, fun_infix :: Bool, -- True => infix declaration 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 @@ -81,15 +87,15 @@ 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 + bind_fvs :: NameSet, -- After the renamer, this contains a superset of the -- Names of the other binders in this binding group that -- are free in the RHS of the defn -- Before renaming, and after typechecking, -- the field is unused; it's just an error thunk + + fun_tick :: Maybe (Int,[id]) -- This is the (optional) module-local tick number. } | PatBind { -- The pattern is never a simple variable; @@ -108,7 +114,7 @@ data HsBind id | AbsBinds { -- Binds abstraction; TRANSLATION abs_tvs :: [TyVar], abs_dicts :: [DictId], - abs_exports :: [([TyVar], id, id, [Prag])], -- (tvs, poly_id, mono_id, prags) + abs_exports :: [([TyVar], id, id, [LPrag])], -- (tvs, poly_id, mono_id, prags) abs_binds :: LHsBinds id -- The dictionary bindings and typechecked user bindings -- mixed up together; you can tell the dict bindings because -- they are all VarBinds @@ -159,7 +165,7 @@ instance OutputableBndr id => Outputable (HsValBinds id) where pprValBindsForUser :: (OutputableBndr id1, OutputableBndr id2) => LHsBinds id1 -> [LSig id2] -> SDoc pprValBindsForUser binds sigs - = vcat (map snd (sort_by_loc decls)) + = pprDeeperList vcat (map snd (sort_by_loc decls)) where decls :: [(SrcSpan, SDoc)] @@ -171,7 +177,7 @@ pprValBindsForUser binds sigs pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty - | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace + | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace ------------ emptyLocalBinds :: HsLocalBinds a @@ -236,8 +242,13 @@ ppr_monobind :: OutputableBndr id => HsBind id -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = ppr var <+> equals <+> pprExpr (unLoc rhs) -ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches - -- ToDo: print infix if appropriate +ppr_monobind (FunBind { fun_id = fun, fun_infix = inf, + fun_matches = matches, + fun_tick = tick }) = + (case tick of + Nothing -> empty + Just t -> text "-- tick id = " <> ppr t + ) $$ pprFunBind (unLoc fun) inf matches ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars, abs_exports = exports, abs_binds = val_binds }) @@ -280,7 +291,7 @@ data IPBind id (LHsExpr id) instance (OutputableBndr id) => Outputable (HsIPBinds id) where - ppr (IPBinds bs ds) = vcat (map ppr bs) + ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) $$ pprLHsBinds ds instance (OutputableBndr id) => Outputable (IPBind id) where @@ -295,27 +306,67 @@ instance (OutputableBndr id) => Outputable (IPBind id) where %************************************************************************ \begin{code} --- A Coercion 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 - | CoCompose ExprCoFn ExprCoFn - | CoApps ExprCoFn [Id] -- Non-empty list - | CoTyApps ExprCoFn [Type] -- in all of these - | CoLams [Id] ExprCoFn -- so that the identity coercion - | CoTyLams [TyVar] ExprCoFn -- is just Hole - | CoLet (LHsBinds Id) ExprCoFn -- Would be nicer to be core bindings +data HsWrapper + = WpHole -- The identity coercion + + | WpCompose HsWrapper HsWrapper -- (\a1..an. []) `WpCompose` (\x1..xn. []) + -- = (\a1..an \x1..xn. []) + + | WpCo Coercion -- A cast: [] `cast` co + -- Guaranteedn not the identity coercion + + | WpApp Var -- [] d the 'd' is a type-class dictionary + | WpTyApp Type -- [] t the 't' is a type or corecion + | WpLam Id -- \d. [] the 'd' is a type-class dictionary + | WpTyLam TyVar -- \a. [] the 'a' is a type or coercion variable + + -- Non-empty bindings, so that the identity coercion + -- is always exactly WpHole + | WpLet (LHsBinds Id) -- let binds in [] + -- (would be nicer to be core bindings) + +instance Outputable HsWrapper where + ppr co_fn = pprHsWrapper (ptext SLIT("<>")) co_fn + +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] + +(<.>) :: HsWrapper -> HsWrapper -> HsWrapper +WpHole <.> c = c +c <.> WpHole = c +c1 <.> c2 = c1 `WpCompose` c2 + +mkWpTyApps :: [Type] -> HsWrapper +mkWpTyApps tys = mk_co_fn WpTyApp (reverse tys) + +mkWpApps :: [Id] -> HsWrapper +mkWpApps ids = mk_co_fn WpApp (reverse ids) + +mkWpTyLams :: [TyVar] -> HsWrapper +mkWpTyLams ids = mk_co_fn WpTyLam ids -(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn -(<.>) = CoCompose +mkWpLams :: [Id] -> HsWrapper +mkWpLams ids = mk_co_fn WpLam ids -idCoercion :: ExprCoFn -idCoercion = CoHole +mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +mk_co_fn f as = foldr (WpCompose . f) WpHole as -isIdCoercion :: ExprCoFn -> Bool -isIdCoercion CoHole = True -isIdCoercion other = False +idHsWrapper :: HsWrapper +idHsWrapper = WpHole + +isIdHsWrapper :: HsWrapper -> Bool +isIdHsWrapper WpHole = True +isIdHsWrapper other = False \end{code} @@ -333,26 +384,38 @@ serves for both. \begin{code} type LSig name = Located (Sig name) -data Sig name - = TypeSig (Located name) -- A bog-std type signature +data Sig name -- Signatures and pragmas + = -- An ordinary type signature + -- f :: Num a => a -> a + TypeSig (Located name) -- A bog-std type signature (LHsType name) - | SpecSig (Located name) -- Specialise a function or datatype ... - (LHsType name) -- ... to these types - InlineSpec + -- An ordinary fixity declaration + -- infixl *** 8 + | FixSig (FixitySig name) -- Fixity declaration + -- An inline pragma + -- {#- INLINE f #-} | InlineSig (Located name) -- Function name InlineSpec + -- A specialisation pragma + -- {-# SPECIALISE f :: Int -> Int #-} + | SpecSig (Located name) -- Specialise a function or datatype ... + (LHsType name) -- ... to these types + InlineSpec + + -- A specialisation pragma for instance declarations only + -- {-# SPECIALISE instance Eq [Int] #-} | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the -- current instance decl - | FixSig (FixitySig name) -- Fixity declaration type LFixitySig name = Located (FixitySig name) data FixitySig name = FixitySig (Located name) Fixity -- A Prag conveys pragmas from the type checker to the desugarer +type LPrag = Located Prag data Prag = InlinePrag InlineSpec @@ -361,13 +424,15 @@ data Prag (HsExpr Id) -- An expression, of the given specialised type, which PostTcType -- specialises the polymorphic function [Id] -- Dicts mentioned free in the expression + -- Apr07: I think this is pretty useless + -- see Note [Const rule dicts] in DsBinds InlineSpec -- Inlining spec for the specialised function isInlinePrag (InlinePrag _) = True isInlinePrag prag = False -isSpecPrag (SpecPrag _ _ _ _) = True -isSpecPrag prag = False +isSpecPrag (SpecPrag {}) = True +isSpecPrag prag = False \end{code} \begin{code} @@ -398,13 +463,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 @@ -475,7 +541,8 @@ pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)] pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty] -pprPrag :: Outputable id => id -> Prag -> SDoc -pprPrag var (InlinePrag inl) = ppr inl <+> ppr var -pprPrag var (SpecPrag expr ty _ inl) = pprSpec var ty inl +pprPrag :: Outputable id => id -> LPrag -> SDoc +pprPrag var (L _ (InlinePrag inl)) = ppr inl <+> ppr var +pprPrag var (L _ (SpecPrag expr ty _ inl)) = pprSpec var ty inl \end{code} +