X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsBinds.lhs;h=5871914ad864a4ec6152b8e8b8f89a35f0fecb1c;hp=f8afd262fe5b4a5585b5d262e5428ec3fd09c7da;hb=2d4d636af091b8da27466b5cf90011395a9c2f66;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index f8afd26..5871914 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -69,23 +69,23 @@ data HsLocalBindsLR idL idR -- Bindings in a 'let' expression type HsValBinds id = HsValBindsLR id id data HsValBindsLR idL idR -- Value bindings (not implicit parameters) - = ValBindsIn -- Before renaming + = ValBindsIn -- Before renaming RHS; idR is always RdrName (LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed -- Recursive by default - | ValBindsOut -- After renaming + | ValBindsOut -- After renaming RHS; idR can be Name or Id [(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings -- in the list may depend on earlier -- ones. [LSig Name] deriving (Data, Typeable) -type LHsBinds id = Bag (LHsBind id) -type LHsBind id = Located (HsBind id) -type HsBind id = HsBindLR id id +type LHsBind id = LHsBindLR id id +type LHsBinds id = LHsBindsLR id id +type HsBind id = HsBindLR id id -type LHsBindLR idL idR = Located (HsBindLR idL idR) type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) +type LHsBindLR idL idR = Located (HsBindLR idL idR) data HsBindLR idL idR = -- | FunBind is used for both functions @f x = e@ @@ -155,6 +155,7 @@ data HsBindLR idL idR abs_ev_binds :: TcEvBinds, -- Evidence bindings abs_binds :: LHsBinds idL -- Typechecked user bindings } + deriving (Data, Typeable) -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- @@ -245,6 +246,13 @@ plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2) = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2) plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2) = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2) + +getTypeSigNames :: HsValBinds a -> NameSet +-- Get the names that have a user type sig +getTypeSigNames (ValBindsIn {}) + = panic "getTypeSigNames" +getTypeSigNames (ValBindsOut _ sigs) + = mkNameSet [unLoc n | L _ (TypeSig n _) <- sigs] \end{code} What AbsBinds means @@ -277,18 +285,24 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL id ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc -ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss -ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = pprBndr CaseBind var <+> equals <+> pprExpr (unLoc rhs) +ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) + = pprPatBind pat grhss +ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) + = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] ppr_monobind (FunBind { fun_id = fun, fun_infix = inf, + fun_co_fn = wrap, fun_matches = matches, fun_tick = tick }) = pprTicks empty (case tick of Nothing -> empty Just t -> text "-- tick id = " <> ppr t) + $$ ifPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind (unLoc fun) inf matches + $$ ifPprDebug (ppr wrap) -ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars, - abs_exports = exports, abs_binds = val_binds }) +ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars + , abs_exports = exports, abs_binds = val_binds + , abs_ev_binds = ev_binds }) = sep [ptext (sLit "AbsBinds"), brackets (interpp'SP tyvars), brackets (interpp'SP dictvars), @@ -297,10 +311,12 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars, nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports] -- Print type signatures $$ pprLHsBinds val_binds ) + $$ + ifPprDebug (ppr ev_binds) where ppr_exp (tvs, gbl, lcl, prags) = vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl, - nest 2 (pprTcSpecPrags gbl prags)] + nest 2 (pprTcSpecPrags prags)] \end{code} @@ -341,7 +357,7 @@ data IPBind id instance (OutputableBndr id) => Outputable (HsIPBinds id) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) - $$ ppr ds + $$ ifPprDebug (ppr ds) instance (OutputableBndr id) => Outputable (IPBind id) where ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs) @@ -432,7 +448,7 @@ data EvTerm | EvCast EvVar Coercion -- d |> co | EvDFunApp DFunId -- Dictionary instance application - [Type] [EvVar] + [Type] [EvVar] | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and -- dictionaries, even though the former have no @@ -441,7 +457,7 @@ data EvTerm deriving( Data, Typeable) evVarTerm :: EvVar -> EvTerm -evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v) +evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v) | otherwise = EvId v \end{code} @@ -521,17 +537,28 @@ instance Outputable HsWrapper where pprHsWrapper :: SDoc -> HsWrapper -> SDoc -- In debug mode, print the wrapper -- otherwise just print what's inside -pprHsWrapper it wrap - = getPprStyle (\ s -> if debugStyle s then (help it wrap) else it) +pprHsWrapper doc wrap + = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc) where - help it WpHole = it - help it (WpCompose f1 f2) = help (help it f2) f1 - help it (WpCast co) = sep [it, nest 2 (ptext (sLit "`cast`") <+> pprParendType co)] - help it (WpEvApp id) = sep [it, nest 2 (ppr id)] - help it (WpTyApp ty) = sep [it, ptext (sLit "@") <+> pprParendType ty] - help it (WpEvLam id) = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it] - help it (WpTyLam tv) = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it] - help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it] + help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc + -- True <=> appears in function application position + -- False <=> appears as body of let or lambda + help it WpHole = it + help it (WpCompose f1 f2) = help (help it f2) f1 + help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") + <+> pprParendCo co)] + help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] + help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty] + help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False] + help it (WpTyLam tv) = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False] + help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False] + + pp_bndr v = pprBndr LambdaBind v <> dot + + add_parens, no_parens :: SDoc -> Bool -> SDoc + add_parens d True = parens d + add_parens d False = d + no_parens d _ = d instance Outputable TcEvBinds where ppr (TcEvBinds v) = ppr v @@ -545,11 +572,10 @@ instance Outputable EvBind where instance Outputable EvTerm where ppr (EvId v) = ppr v - ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co - ppr (EvCoercion co) = ppr co + ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co + ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) - ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys - , ppr ts ] + ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] \end{code} %************************************************************************ @@ -571,6 +597,10 @@ data Sig name -- Signatures and pragmas -- f :: Num a => a -> a TypeSig (Located name) (LHsType name) + -- A type signature for a default method inside a class + -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool + | GenericSig (Located name) (LHsType name) + -- A type signature in generated code, notably the code -- generated for record selectors. We simply record -- the desired Id itself, replete with its name, type @@ -595,10 +625,10 @@ data Sig name -- Signatures and pragmas -- If it's just defaultInlinePragma, then we said -- SPECIALISE, not SPECIALISE_INLINE - -- 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 + -- 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 deriving (Data, Typeable) @@ -610,11 +640,14 @@ data FixitySig name = FixitySig (Located name) Fixity data TcSpecPrags = IsDefaultMethod -- Super-specialised: a default method should -- be macro-expanded at every call site - | SpecPrags [Located TcSpecPrag] + | SpecPrags [LTcSpecPrag] deriving (Data, Typeable) +type LTcSpecPrag = Located TcSpecPrag + data TcSpecPrag = SpecPrag + Id -- The Id to be specialised HsWrapper -- An wrapper, that specialises the polymorphic function InlinePragma -- Inlining spec for the specialised function deriving (Data, Typeable) @@ -637,29 +670,27 @@ okBindSig :: Sig a -> Bool okBindSig _ = True okHsBootSig :: Sig a -> Bool -okHsBootSig (TypeSig _ _) = True -okHsBootSig (FixSig _) = True -okHsBootSig _ = False +okHsBootSig (TypeSig _ _) = True +okHsBootSig (GenericSig _ _) = False +okHsBootSig (FixSig _) = True +okHsBootSig _ = False okClsDclSig :: Sig a -> Bool okClsDclSig (SpecInstSig _) = False okClsDclSig _ = True -- All others OK okInstDclSig :: Sig a -> Bool -okInstDclSig (TypeSig _ _) = False -okInstDclSig (FixSig _) = False -okInstDclSig _ = True - -sigForThisGroup :: NameSet -> LSig Name -> Bool -sigForThisGroup ns sig - = case sigName sig of - Nothing -> False - Just n -> n `elemNameSet` ns +okInstDclSig (TypeSig _ _) = False +okInstDclSig (GenericSig _ _) = False +okInstDclSig (FixSig _) = False +okInstDclSig _ = True sigName :: LSig name -> Maybe name +-- Used only in Haddock sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> Maybe name +-- Used only in Haddock sigNameNoLoc (TypeSig n _) = Just (unLoc n) sigNameNoLoc (SpecSig n _ _) = Just (unLoc n) sigNameNoLoc (InlineSig n _) = Just (unLoc n) @@ -677,9 +708,10 @@ isVanillaLSig (L _(TypeSig {})) = True isVanillaLSig _ = False isTypeLSig :: LSig name -> Bool -- Type signatures -isTypeLSig (L _(TypeSig {})) = True -isTypeLSig (L _(IdSig {})) = True -isTypeLSig _ = False +isTypeLSig (L _(TypeSig {})) = True +isTypeLSig (L _(GenericSig {})) = True +isTypeLSig (L _(IdSig {})) = True +isTypeLSig _ = False isSpecLSig :: LSig name -> Bool isSpecLSig (L _(SpecSig {})) = True @@ -702,6 +734,7 @@ isInlineLSig _ = False hsSigDoc :: Sig name -> SDoc hsSigDoc (TypeSig {}) = ptext (sLit "type signature") +hsSigDoc (GenericSig {}) = ptext (sLit "default type signature") hsSigDoc (IdSig {}) = ptext (sLit "id signature") hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma") hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma") @@ -716,6 +749,7 @@ eqHsSig :: Eq a => LSig a -> LSig a -> Bool eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2 eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2 +eqHsSig (L _ (GenericSig n1 _)) (L _ (GenericSig n2 _)) = unLoc n1 == unLoc n2 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2 -- For specialisations, we don't have equality over -- HsType, so it's not convenient to spot duplicate @@ -729,6 +763,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where ppr_sig :: OutputableBndr name => Sig name -> SDoc ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty) +ppr_sig (GenericSig var ty) = ptext (sLit "default") <+> pprVarSig (unLoc var) (ppr ty) ppr_sig (IdSig id) = pprVarSig id (ppr (varType id)) ppr_sig (FixSig fix_sig) = ppr fix_sig ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl) @@ -750,14 +785,11 @@ pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var p pp_inl | isDefaultInlinePragma inl = empty | otherwise = ppr inl -pprTcSpecPrags :: Outputable id => id -> TcSpecPrags -> SDoc -pprTcSpecPrags _ IsDefaultMethod = ptext (sLit "") -pprTcSpecPrags gbl (SpecPrags ps) = vcat (map (pprSpecPrag gbl) ps) - -pprSpecPrag :: Outputable id => id -> Located TcSpecPrag -> SDoc -pprSpecPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "")) inl +pprTcSpecPrags :: TcSpecPrags -> SDoc +pprTcSpecPrags IsDefaultMethod = ptext (sLit "") +pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) instance Outputable TcSpecPrag where - ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p + ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "")) inl \end{code}