diff options
Diffstat (limited to 'compiler/GHC/Hs/Binds.hs')
| -rw-r--r-- | compiler/GHC/Hs/Binds.hs | 1310 |
1 files changed, 1310 insertions, 0 deletions
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs new file mode 100644 index 0000000000..01c10b1ea1 --- /dev/null +++ b/compiler/GHC/Hs/Binds.hs @@ -0,0 +1,1310 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[HsBinds]{Abstract syntax: top-level bindings and signatures} + +Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Hs.Binds where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, LHsExpr, + MatchGroup, pprFunBind, + GRHSs, pprPatBind ) +import {-# SOURCE #-} GHC.Hs.Pat ( LPat ) + +import GHC.Hs.Extension +import GHC.Hs.Types +import CoreSyn +import TcEvidence +import Type +import NameSet +import BasicTypes +import Outputable +import SrcLoc +import Var +import Bag +import FastString +import BooleanFormula (LBooleanFormula) +import DynFlags + +import Data.Data hiding ( Fixity ) +import Data.List hiding ( foldr ) +import Data.Ord + +{- +************************************************************************ +* * +\subsection{Bindings: @BindGroup@} +* * +************************************************************************ + +Global bindings (where clauses) +-} + +-- During renaming, we need bindings where the left-hand sides +-- have been renamed but the right-hand sides have not. +-- the ...LR datatypes are parametrized by two id types, +-- one for the left and one for the right. +-- Other than during renaming, these will be the same. + +-- | Haskell Local Bindings +type HsLocalBinds id = HsLocalBindsLR id id + +-- | Located Haskell local bindings +type LHsLocalBinds id = Located (HsLocalBinds id) + +-- | Haskell Local Bindings with separate Left and Right identifier types +-- +-- Bindings in a 'let' expression +-- or a 'where' clause +data HsLocalBindsLR idL idR + = HsValBinds + (XHsValBinds idL idR) + (HsValBindsLR idL idR) + -- ^ Haskell Value Bindings + + -- There should be no pattern synonyms in the HsValBindsLR + -- These are *local* (not top level) bindings + -- The parser accepts them, however, leaving the + -- renamer to report them + + | HsIPBinds + (XHsIPBinds idL idR) + (HsIPBinds idR) + -- ^ Haskell Implicit Parameter Bindings + + | EmptyLocalBinds (XEmptyLocalBinds idL idR) + -- ^ Empty Local Bindings + + | XHsLocalBindsLR + (XXHsLocalBindsLR idL idR) + +type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon + +type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) + + +-- | Haskell Value Bindings +type HsValBinds id = HsValBindsLR id id + +-- | Haskell Value bindings with separate Left and Right identifier types +-- (not implicit parameters) +-- Used for both top level and nested bindings +-- May contain pattern synonym bindings +data HsValBindsLR idL idR + = -- | Value Bindings In + -- + -- Before renaming RHS; idR is always RdrName + -- Not dependency analysed + -- Recursive by default + ValBinds + (XValBinds idL idR) + (LHsBindsLR idL idR) [LSig idR] + + -- | Value Bindings Out + -- + -- After renaming RHS; idR can be Name or Id Dependency analysed, + -- later bindings in the list may depend on earlier ones. + | XValBindsLR + (XXValBindsLR idL idR) + +-- --------------------------------------------------------------------- +-- Deal with ValBindsOut + +-- TODO: make this the only type for ValBinds +data NHsValBindsLR idL + = NValBinds + [(RecFlag, LHsBinds idL)] + [LSig GhcRn] + +type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXValBindsLR (GhcPass pL) (GhcPass pR) + = NHsValBindsLR (GhcPass pL) + +-- --------------------------------------------------------------------- + +-- | Located Haskell Binding +type LHsBind id = LHsBindLR id id + +-- | Located Haskell Bindings +type LHsBinds id = LHsBindsLR id id + +-- | Haskell Binding +type HsBind id = HsBindLR id id + +-- | Located Haskell Bindings with separate Left and Right identifier types +type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) + +-- | Located Haskell Binding with separate Left and Right identifier types +type LHsBindLR idL idR = Located (HsBindLR idL idR) + +{- Note [FunBind vs PatBind] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +The distinction between FunBind and PatBind is a bit subtle. FunBind covers +patterns which resemble function bindings and simple variable bindings. + + f x = e + f !x = e + f = e + !x = e -- FunRhs has SrcStrict + x `f` y = e -- FunRhs has Infix + +The actual patterns and RHSs of a FunBind are encoding in fun_matches. +The m_ctxt field of each Match in fun_matches will be FunRhs and carries +two bits of information about the match, + + * The mc_fixity field on each Match describes the fixity of the + function binder in that match. E.g. this is legal: + f True False = e1 + True `f` True = e2 + + * The mc_strictness field is used /only/ for nullary FunBinds: ones + with one Match, which has no pats. For these, it describes whether + the match is decorated with a bang (e.g. `!x = e`). + +By contrast, PatBind represents data constructor patterns, as well as a few +other interesting cases. Namely, + + Just x = e + (x) = e + x :: Ty = e +-} + +-- | Haskell Binding with separate Left and Right id's +data HsBindLR idL idR + = -- | Function-like Binding + -- + -- FunBind is used for both functions @f x = e@ + -- and variables @f = \x -> e@ + -- and strict variables @!x = x + 1@ + -- + -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'. + -- + -- Reason 2: Instance decls can only have FunBinds, which is convenient. + -- If you change this, you'll need to change e.g. rnMethodBinds + -- + -- But note that the form @f :: a->a = ...@ + -- parses as a pattern binding, just like + -- @(f :: a -> a) = ... @ + -- + -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their + -- 'MatchContext'. See Note [FunBind vs PatBind] for + -- details about the relationship between FunBind and PatBind. + -- + -- 'ApiAnnotation.AnnKeywordId's + -- + -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches + -- + -- - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + FunBind { + + fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains + -- the locally-bound + -- free variables of this defn. + -- See Note [Bind free vars] + + fun_id :: Located (IdP idL), -- Note [fun_id in Match] in GHC.Hs.Expr + + fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload + + 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 + -- @ + -- + -- Then the MatchGroup will have type (Int -> a' -> a') + -- (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'. + + fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any + } + + -- | Pattern Binding + -- + -- The pattern is never a simple variable; + -- That case is done by FunBind. + -- See Note [FunBind vs PatBind] for details about the + -- relationship between FunBind and PatBind. + + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang', + -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + | PatBind { + pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars] + pat_lhs :: LPat idL, + pat_rhs :: GRHSs idR (LHsExpr idR), + pat_ticks :: ([Tickish Id], [[Tickish Id]]) + -- ^ Ticks to put on the rhs, if any, and ticks to put on + -- the bound variables. + } + + -- | Variable Binding + -- + -- Dictionary binding and suchlike. + -- All VarBinds are introduced by the type checker + | VarBind { + var_ext :: XVarBind idL idR, + var_id :: IdP idL, + var_rhs :: LHsExpr idR, -- ^ Located only for consistency + var_inline :: Bool -- ^ True <=> inline this binding regardless + -- (used for implication constraints only) + } + + -- | Abstraction Bindings + | AbsBinds { -- Binds abstraction; TRANSLATION + abs_ext :: XAbsBinds idL idR, + abs_tvs :: [TyVar], + abs_ev_vars :: [EvVar], -- ^ Includes equality constraints + + -- | AbsBinds only gets used when idL = idR after renaming, + -- but these need to be idL's for the collect... code in HsUtil + -- to have the right type + abs_exports :: [ABExport idL], + + -- | Evidence bindings + -- Why a list? See TcInstDcls + -- Note [Typechecking plan for instance declarations] + abs_ev_binds :: [TcEvBinds], + + -- | Typechecked user bindings + abs_binds :: LHsBinds idL, + + abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds] + } + + -- | Patterns Synonym Binding + | PatSynBind + (XPatSynBind idL idR) + (PatSynBind idL idR) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', + -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual', + -- 'ApiAnnotation.AnnWhere' + -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | XHsBindsLR (XXHsBindsLR idL idR) + +data NPatBindTc = NPatBindTc { + pat_fvs :: NameSet, -- ^ Free variables + pat_rhs_ty :: Type -- ^ Type of the GRHSs + } deriving Data + +type instance XFunBind (GhcPass pL) GhcPs = NoExtField +type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables +type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables + +type instance XPatBind GhcPs (GhcPass pR) = NoExtField +type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables +type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc + +type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExtField +type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon + + + -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] + -- + -- Creates bindings for (polymorphic, overloaded) poly_f + -- in terms of monomorphic, non-overloaded mono_f + -- + -- Invariants: + -- 1. 'binds' binds mono_f + -- 2. ftvs is a subset of tvs + -- 3. ftvs includes all tyvars free in ds + -- + -- See Note [AbsBinds] + +-- | Abtraction Bindings Export +data ABExport p + = ABE { abe_ext :: XABE p + , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id + , abe_mono :: IdP p + , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] + -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly + , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas + } + | XABExport (XXABExport p) + +type instance XABE (GhcPass p) = NoExtField +type instance XXABExport (GhcPass p) = NoExtCon + + +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', +-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' +-- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@, +-- 'ApiAnnotation.AnnClose' @'}'@, + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | Pattern Synonym binding +data PatSynBind idL idR + = PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs. + -- See Note [Bind free vars] + psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym + psb_args :: HsPatSynDetails (Located (IdP idR)), + -- ^ Formal parameter names + psb_def :: LPat idR, -- ^ Right-hand side + psb_dir :: HsPatSynDir idR -- ^ Directionality + } + | XPatSynBind (XXPatSynBind idL idR) + +type instance XPSB (GhcPass idL) GhcPs = NoExtField +type instance XPSB (GhcPass idL) GhcRn = NameSet +type instance XPSB (GhcPass idL) GhcTc = NameSet + +type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExtCon + +{- +Note [AbsBinds] +~~~~~~~~~~~~~~~ +The AbsBinds constructor is used in the output of the type checker, to +record *typechecked* and *generalised* bindings. Specifically + + AbsBinds { abs_tvs = tvs + , abs_ev_vars = [d1,d2] + , abs_exports = [ABE { abe_poly = fp, abe_mono = fm + , abe_wrap = fwrap } + ABE { slly for g } ] + , abs_ev_binds = DBINDS + , abs_binds = BIND[fm,gm] } + +where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means + + fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ] + [ ; BIND[fm,gm] } ] + [ in fm ] + + gp = ...same again, with gm instead of fm + +The 'fwrap' is an impedence-matcher that typically does nothing; see +Note [ABExport wrapper]. + +This is a pretty bad translation, because it duplicates all the bindings. +So the desugarer tries to do a better job: + + fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of + (fm,gm) -> fm + ..ditto for gp.. + + tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND } + in (fm,gm) + +In general: + + * abs_tvs are the type variables over which the binding group is + generalised + * abs_ev_var are the evidence variables (usually dictionaries) + over which the binding group is generalised + * abs_binds are the monomorphic bindings + * abs_ex_binds are the evidence bindings that wrap the abs_binds + * abs_exports connects the monomorphic Ids bound by abs_binds + with the polymorphic Ids bound by the AbsBinds itself. + +For example, consider a module M, with this top-level binding, where +there is no type signature for M.reverse, + M.reverse [] = [] + M.reverse (x:xs) = M.reverse xs ++ [x] + +In Hindley-Milner, a recursive binding is typechecked with the +*recursive* uses being *monomorphic*. So after typechecking *and* +desugaring we will get something like this + + M.reverse :: forall a. [a] -> [a] + = /\a. letrec + reverse :: [a] -> [a] = \xs -> case xs of + [] -> [] + (x:xs) -> reverse xs ++ [x] + in reverse + +Notice that 'M.reverse' is polymorphic as expected, but there is a local +definition for plain 'reverse' which is *monomorphic*. The type variable +'a' scopes over the entire letrec. + +That's after desugaring. What about after type checking but before +desugaring? That's where AbsBinds comes in. It looks like this: + + AbsBinds { abs_tvs = [a] + , abs_ev_vars = [] + , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a], + , abe_mono = reverse :: [a] -> [a]}] + , abs_ev_binds = {} + , abs_binds = { reverse :: [a] -> [a] + = \xs -> case xs of + [] -> [] + (x:xs) -> reverse xs ++ [x] } } + +Here, + + * abs_tvs says what type variables are abstracted over the binding + group, just 'a' in this case. + * abs_binds is the *monomorphic* bindings of the group + * abs_exports describes how to get the polymorphic Id 'M.reverse' + from the monomorphic one 'reverse' + +Notice that the *original* function (the polymorphic one you thought +you were defining) appears in the abe_poly field of the +abs_exports. The bindings in abs_binds are for fresh, local, Ids with +a *monomorphic* Id. + +If there is a group of mutually recursive (see Note [Polymorphic +recursion]) functions without type signatures, we get one AbsBinds +with the monomorphic versions of the bindings in abs_binds, and one +element of abe_exports for each variable bound in the mutually +recursive group. This is true even for pattern bindings. Example: + (f,g) = (\x -> x, f) +After type checking we get + AbsBinds { abs_tvs = [a] + , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a + , abe_mono = f :: a -> a } + , ABE { abe_poly = M.g :: forall a. a -> a + , abe_mono = g :: a -> a }] + , abs_binds = { (f,g) = (\x -> x, f) } + +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + Rec { f x = ...(g ef)... + + ; g :: forall a. [a] -> [a] + ; g y = ...(f eg)... } + +These bindings /are/ mutually recursive (f calls g, and g calls f). +But we can use the type signature for g to break the recursion, +like this: + + 1. Add g :: forall a. [a] -> [a] to the type environment + + 2. Typecheck the definition of f, all by itself, + including generalising it to find its most general + type, say f :: forall b. b -> b -> [b] + + 3. Extend the type environment with that type for f + + 4. Typecheck the definition of g, all by itself, + checking that it has the type claimed by its signature + +Steps 2 and 4 each generate a separate AbsBinds, so we end +up with + Rec { AbsBinds { ...for f ... } + ; AbsBinds { ...for g ... } } + +This approach allows both f and to call each other +polymorphically, even though only g has a signature. + +We get an AbsBinds that encompasses multiple source-program +bindings only when + * Each binding in the group has at least one binder that + lacks a user type signature + * The group forms a strongly connected component + + +Note [The abs_sig field of AbsBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The abs_sig field supports a couple of special cases for bindings. +Consider + + x :: Num a => (# a, a #) + x = (# 3, 4 #) + +The general desugaring for AbsBinds would give + + x = /\a. \ ($dNum :: Num a) -> + letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in + xm + +But that has an illegal let-binding for an unboxed tuple. In this +case we'd prefer to generate the (more direct) + + x = /\ a. \ ($dNum :: Num a) -> + (# fromInteger $dNum 3, fromInteger $dNum 4 #) + +A similar thing happens with representation-polymorphic defns +(#11405): + + undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a + undef = error "undef" + +Again, the vanilla desugaring gives a local let-binding for a +representation-polymorphic (undefm :: a), which is illegal. But +again we can desugar without a let: + + undef = /\ a. \ (d:HasCallStack) -> error a d "undef" + +The abs_sig field supports this direct desugaring, with no local +let-bining. When abs_sig = True + + * the abs_binds is single FunBind + + * the abs_exports is a singleton + + * we have a complete type sig for binder + and hence the abs_binds is non-recursive + (it binds the mono_id but refers to the poly_id + +These properties are exploited in DsBinds.dsAbsBinds to +generate code without a let-binding. + +Note [ABExport wrapper] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (f,g) = (\x.x, \y.y) +This ultimately desugars to something like this: + tup :: forall a b. (a->a, b->b) + tup = /\a b. (\x:a.x, \y:b.y) + f :: forall a. a -> a + f = /\a. case tup a Any of + (fm::a->a,gm:Any->Any) -> fm + ...similarly for g... + +The abe_wrap field deals with impedance-matching between + (/\a b. case tup a b of { (f,g) -> f }) +and the thing we really want, which may have fewer type +variables. The action happens in TcBinds.mkExport. + +Note [Bind free vars] +~~~~~~~~~~~~~~~~~~~~~ +The bind_fvs field of FunBind and PatBind records the free variables +of the definition. It is used for the following purposes + +a) Dependency analysis prior to type checking + (see TcBinds.tc_group) + +b) Deciding whether we can do generalisation of the binding + (see TcBinds.decideGeneralisationPlan) + +c) Deciding whether the binding can be used in static forms + (see TcExpr.checkClosedInStaticForm for the HsStatic case and + TcBinds.isClosedBndrGroup). + +Specifically, + + * bind_fvs includes all free vars that are defined in this module + (including top-level things and lexically scoped type variables) + + * bind_fvs excludes imported vars; this is just to keep the set smaller + + * Before renaming, and after typechecking, the field is unused; + it's just an error thunk +-} + +instance (idL ~ GhcPass pl, idR ~ GhcPass pr, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsLocalBindsLR idL idR) where + ppr (HsValBinds _ bs) = ppr bs + ppr (HsIPBinds _ bs) = ppr bs + ppr (EmptyLocalBinds _) = empty + ppr (XHsLocalBindsLR x) = ppr x + +instance (idL ~ GhcPass pl, idR ~ GhcPass pr, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsValBindsLR idL idR) where + ppr (ValBinds _ binds sigs) + = pprDeclList (pprLHsBindsForUser binds sigs) + + ppr (XValBindsLR (NValBinds sccs sigs)) + = getPprStyle $ \ sty -> + if debugStyle sty then -- Print with sccs showing + vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) + else + pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) + where + ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds + pp_rec Recursive = text "rec" + pp_rec NonRecursive = text "nonrec" + +pprLHsBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprLHsBinds binds + | isEmptyLHsBinds binds = empty + | otherwise = pprDeclList (map ppr (bagToList binds)) + +pprLHsBindsForUser :: (OutputableBndrId (GhcPass idL), + OutputableBndrId (GhcPass idR), + OutputableBndrId (GhcPass id2)) + => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc] +-- pprLHsBindsForUser is different to pprLHsBinds because +-- a) No braces: 'let' and 'where' include a list of HsBindGroups +-- and we don't want several groups of bindings each +-- with braces around +-- b) Sort by location before printing +-- c) Include signatures +pprLHsBindsForUser binds sigs + = map snd (sort_by_loc decls) + where + + decls :: [(SrcSpan, SDoc)] + decls = [(loc, ppr sig) | L loc sig <- sigs] ++ + [(loc, ppr bind) | L loc bind <- bagToList binds] + + sort_by_loc decls = sortBy (comparing fst) decls + +pprDeclList :: [SDoc] -> SDoc -- Braces with a space +-- Print a bunch of declarations +-- One could choose { d1; d2; ... }, using 'sep' +-- or d1 +-- d2 +-- .. +-- using vcat +-- At the moment we chose the latter +-- Also we do the 'pprDeeperList' thing. +pprDeclList ds = pprDeeperList vcat ds + +------------ +emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) +emptyLocalBinds = EmptyLocalBinds noExtField + +-- AZ:These functions do not seem to be used at all? +isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool +isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds +isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds +isEmptyLocalBindsTc (EmptyLocalBinds _) = True +isEmptyLocalBindsTc (XHsLocalBindsLR _) = True + +isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool +isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds +isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds +isEmptyLocalBindsPR (EmptyLocalBinds _) = True +isEmptyLocalBindsPR (XHsLocalBindsLR _) = True + +eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool +eqEmptyLocalBinds (EmptyLocalBinds _) = True +eqEmptyLocalBinds _ = False + +isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool +isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs + +emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b) +emptyValBindsIn = ValBinds noExtField emptyBag [] +emptyValBindsOut = XValBindsLR (NValBinds [] []) + +emptyLHsBinds :: LHsBindsLR idL idR +emptyLHsBinds = emptyBag + +isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool +isEmptyLHsBinds = isEmptyBag + +------------ +plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) + -> HsValBinds(GhcPass a) +plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) + = ValBinds noExtField (ds1 `unionBags` ds2) (sigs1 ++ sigs2) +plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) + (XValBindsLR (NValBinds ds2 sigs2)) + = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2)) +plusHsValBinds _ _ + = panic "HsBinds.plusHsValBinds" + +instance (idL ~ GhcPass pl, idR ~ GhcPass pr, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsBindLR idL idR) where + ppr mbind = ppr_monobind mbind + +ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc + +ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) + = pprPatBind pat grhss +ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) + = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] +ppr_monobind (FunBind { fun_id = fun, + fun_co_fn = wrap, + fun_matches = matches, + fun_tick = ticks }) + = pprTicks empty (if null ticks then empty + else text "-- ticks = " <> ppr ticks) + $$ whenPprDebug (pprBndr LetBind (unLoc fun)) + $$ pprFunBind matches + $$ whenPprDebug (ppr wrap) +ppr_monobind (PatSynBind _ psb) = ppr psb +ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars + , abs_exports = exports, abs_binds = val_binds + , abs_ev_binds = ev_binds }) + = sdocWithDynFlags $ \ dflags -> + if gopt Opt_PrintTypecheckerElaboration dflags then + -- Show extra information (bug number: #10662) + hang (text "AbsBinds" <+> brackets (interpp'SP tyvars) + <+> brackets (interpp'SP dictvars)) + 2 $ braces $ vcat + [ text "Exports:" <+> + brackets (sep (punctuate comma (map ppr exports))) + , text "Exported types:" <+> + vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] + , text "Binds:" <+> pprLHsBinds val_binds + , text "Evidence:" <+> ppr ev_binds ] + else + pprLHsBinds val_binds +ppr_monobind (XHsBindsLR x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport p) where + ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) + = vcat [ ppr gbl <+> text "<=" <+> ppr lcl + , nest 2 (pprTcSpecPrags prags) + , nest 2 (text "wrap:" <+> ppr wrap)] + ppr (XABExport x) = ppr x + +instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR, + Outputable (XXPatSynBind idL idR)) + => Outputable (PatSynBind idL idR) where + ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, + psb_dir = dir }) + = ppr_lhs <+> ppr_rhs + where + ppr_lhs = text "pattern" <+> ppr_details + ppr_simple syntax = syntax <+> ppr pat + + ppr_details = case details of + InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2] + PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr vs) + RecCon vs -> pprPrefixOcc psyn + <> braces (sep (punctuate comma (map ppr vs))) + + ppr_rhs = case dir of + Unidirectional -> ppr_simple (text "<-") + ImplicitBidirectional -> ppr_simple equals + ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$ + (nest 2 $ pprFunBind mg) + ppr (XPatSynBind x) = ppr x + +pprTicks :: SDoc -> SDoc -> SDoc +-- Print stuff about ticks only when -dppr-debug is on, to avoid +-- them appearing in error messages (from the desugarer); see # 3263 +-- Also print ticks in dumpStyle, so that -ddump-hpc actually does +-- something useful. +pprTicks pp_no_debug pp_when_debug + = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty + then pp_when_debug + else pp_no_debug) + +{- +************************************************************************ +* * + Implicit parameter bindings +* * +************************************************************************ +-} + +-- | Haskell Implicit Parameter Bindings +data HsIPBinds id + = IPBinds + (XIPBinds id) + [LIPBind id] + -- TcEvBinds -- Only in typechecker output; binds + -- -- uses of the implicit parameters + | XHsIPBinds (XXHsIPBinds id) + +type instance XIPBinds GhcPs = NoExtField +type instance XIPBinds GhcRn = NoExtField +type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the + -- implicit parameters + + +type instance XXHsIPBinds (GhcPass p) = NoExtCon + +isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool +isEmptyIPBindsPR (IPBinds _ is) = null is +isEmptyIPBindsPR (XHsIPBinds _) = True + +isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool +isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds +isEmptyIPBindsTc (XHsIPBinds _) = True + +-- | Located Implicit Parameter Binding +type LIPBind id = Located (IPBind id) +-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a +-- list + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | Implicit parameter bindings. +-- +-- These bindings start off as (Left "x") in the parser and stay +-- that way until after type-checking when they are replaced with +-- (Right d), where "d" is the name of the dictionary holding the +-- evidence for the implicit parameter. +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' + +-- For details on above see note [Api annotations] in ApiAnnotation +data IPBind id + = IPBind + (XCIPBind id) + (Either (Located HsIPName) (IdP id)) + (LHsExpr id) + | XIPBind (XXIPBind id) + +type instance XCIPBind (GhcPass p) = NoExtField +type instance XXIPBind (GhcPass p) = NoExtCon + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsIPBinds p) where + ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs) + $$ whenPprDebug (ppr ds) + ppr (XHsIPBinds x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where + ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) + where name = case lr of + Left (L _ ip) -> pprBndr LetBind ip + Right id -> pprBndr LetBind id + ppr (XIPBind x) = ppr x + +{- +************************************************************************ +* * +\subsection{@Sig@: type signatures and value-modifying user pragmas} +* * +************************************************************************ + +It is convenient to lump ``value-modifying'' user-pragmas (e.g., +``specialise this function to these four types...'') in with type +signatures. Then all the machinery to move them into place, etc., +serves for both. +-} + +-- | Located Signature +type LSig pass = Located (Sig pass) + +-- | Signatures and pragmas +data Sig pass + = -- | An ordinary type signature + -- + -- > f :: Num a => a -> a + -- + -- After renaming, this list of Names contains the named + -- wildcards brought into scope by this signature. For a signature + -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@ + -- untouched, and the named wildcard @_a@ is then replaced with + -- fresh meta vars in the type. Their names are stored in the type + -- signature that brought them into scope, in this third field to be + -- more specific. + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnComma' + + -- For details on above see note [Api annotations] in ApiAnnotation + TypeSig + (XTypeSig pass) + [Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah + (LHsSigWcType pass) -- RHS of the signature; can have wildcards + + -- | A pattern synonym type signature + -- + -- > pattern Single :: () => (Show a) => a -> [a] + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall' + -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass) + -- P :: forall a b. Req => Prov => ty + + -- | A signature for a class method + -- False: ordinary class-method signature + -- True: generic-default class method signature + -- e.g. class C a where + -- op :: a -> a -- Ordinary + -- default op :: Eq a => a -> a -- Generic default + -- No wildcards allowed here + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', + -- 'ApiAnnotation.AnnDcolon' + | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass) + + -- | 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 + -- and IdDetails. Otherwise it's just like a type + -- signature: there should be an accompanying binding + | IdSig (XIdSig pass) Id + + -- | An ordinary fixity declaration + -- + -- > infixl 8 *** + -- + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix', + -- 'ApiAnnotation.AnnVal' + + -- For details on above see note [Api annotations] in ApiAnnotation + | FixSig (XFixSig pass) (FixitySig pass) + + -- | An inline pragma + -- + -- > {#- INLINE f #-} + -- + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@, + -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | InlineSig (XInlineSig pass) + (Located (IdP pass)) -- Function name + InlinePragma -- Never defaultInlinePragma + + -- | A specialisation pragma + -- + -- > {-# SPECIALISE f :: Int -> Int #-} + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@, + -- 'ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@, + -- 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | SpecSig (XSpecSig pass) + (Located (IdP pass)) -- Specialise a function or datatype ... + [LHsSigType pass] -- ... to these types + InlinePragma -- The pragma on SPECIALISE_INLINE form. + -- If it's just defaultInlinePragma, then we said + -- SPECIALISE, not SPECIALISE_INLINE + + -- | A specialisation pragma for instance declarations only + -- + -- > {-# SPECIALISE instance Eq [Int] #-} + -- + -- (Class tys); should be a specialisation of the + -- current instance declaration + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) + -- Note [Pragma source text] in BasicTypes + + -- | A minimal complete definition pragma + -- + -- > {-# MINIMAL a | (b, c | (d | e)) #-} + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | MinimalSig (XMinimalSig pass) + SourceText (LBooleanFormula (Located (IdP pass))) + -- Note [Pragma source text] in BasicTypes + + -- | A "set cost centre" pragma for declarations + -- + -- > {-# SCC funName #-} + -- + -- or + -- + -- > {-# SCC funName "cost_centre_name" #-} + + | SCCFunSig (XSCCFunSig pass) + SourceText -- Note [Pragma source text] in BasicTypes + (Located (IdP pass)) -- Function name + (Maybe (Located StringLiteral)) + -- | A complete match pragma + -- + -- > {-# COMPLETE C, D [:: T] #-} + -- + -- Used to inform the pattern match checker about additional + -- complete matchings which, for example, arise from pattern + -- synonym definitions. + | CompleteMatchSig (XCompleteMatchSig pass) + SourceText + (Located [Located (IdP pass)]) + (Maybe (Located (IdP pass))) + | XSig (XXSig pass) + +type instance XTypeSig (GhcPass p) = NoExtField +type instance XPatSynSig (GhcPass p) = NoExtField +type instance XClassOpSig (GhcPass p) = NoExtField +type instance XIdSig (GhcPass p) = NoExtField +type instance XFixSig (GhcPass p) = NoExtField +type instance XInlineSig (GhcPass p) = NoExtField +type instance XSpecSig (GhcPass p) = NoExtField +type instance XSpecInstSig (GhcPass p) = NoExtField +type instance XMinimalSig (GhcPass p) = NoExtField +type instance XSCCFunSig (GhcPass p) = NoExtField +type instance XCompleteMatchSig (GhcPass p) = NoExtField +type instance XXSig (GhcPass p) = NoExtCon + +-- | Located Fixity Signature +type LFixitySig pass = Located (FixitySig pass) + +-- | Fixity Signature +data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity + | XFixitySig (XXFixitySig pass) + +type instance XFixitySig (GhcPass p) = NoExtField +type instance XXFixitySig (GhcPass p) = NoExtCon + +-- | Type checker Specialisation Pragmas +-- +-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer +data TcSpecPrags + = IsDefaultMethod -- ^ Super-specialised: a default method should + -- be macro-expanded at every call site + | SpecPrags [LTcSpecPrag] + deriving Data + +-- | Located Type checker Specification Pragmas +type LTcSpecPrag = Located TcSpecPrag + +-- | Type checker Specification Pragma +data TcSpecPrag + = SpecPrag + Id + HsWrapper + InlinePragma + -- ^ The Id to be specialised, a wrapper that specialises the + -- polymorphic function, and inlining spec for the specialised function + deriving Data + +noSpecPrags :: TcSpecPrags +noSpecPrags = SpecPrags [] + +hasSpecPrags :: TcSpecPrags -> Bool +hasSpecPrags (SpecPrags ps) = not (null ps) +hasSpecPrags IsDefaultMethod = False + +isDefaultMethod :: TcSpecPrags -> Bool +isDefaultMethod IsDefaultMethod = True +isDefaultMethod (SpecPrags {}) = False + + +isFixityLSig :: LSig name -> Bool +isFixityLSig (L _ (FixSig {})) = True +isFixityLSig _ = False + +isTypeLSig :: LSig name -> Bool -- Type signatures +isTypeLSig (L _(TypeSig {})) = True +isTypeLSig (L _(ClassOpSig {})) = True +isTypeLSig (L _(IdSig {})) = True +isTypeLSig _ = False + +isSpecLSig :: LSig name -> Bool +isSpecLSig (L _(SpecSig {})) = True +isSpecLSig _ = False + +isSpecInstLSig :: LSig name -> Bool +isSpecInstLSig (L _ (SpecInstSig {})) = True +isSpecInstLSig _ = False + +isPragLSig :: LSig name -> Bool +-- Identifies pragmas +isPragLSig (L _ (SpecSig {})) = True +isPragLSig (L _ (InlineSig {})) = True +isPragLSig (L _ (SCCFunSig {})) = True +isPragLSig (L _ (CompleteMatchSig {})) = True +isPragLSig _ = False + +isInlineLSig :: LSig name -> Bool +-- Identifies inline pragmas +isInlineLSig (L _ (InlineSig {})) = True +isInlineLSig _ = False + +isMinimalLSig :: LSig name -> Bool +isMinimalLSig (L _ (MinimalSig {})) = True +isMinimalLSig _ = False + +isSCCFunSig :: LSig name -> Bool +isSCCFunSig (L _ (SCCFunSig {})) = True +isSCCFunSig _ = False + +isCompleteMatchSig :: LSig name -> Bool +isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True +isCompleteMatchSig _ = False + +hsSigDoc :: Sig name -> SDoc +hsSigDoc (TypeSig {}) = text "type signature" +hsSigDoc (PatSynSig {}) = text "pattern synonym signature" +hsSigDoc (ClassOpSig _ is_deflt _ _) + | is_deflt = text "default type signature" + | otherwise = text "class method signature" +hsSigDoc (IdSig {}) = text "id signature" +hsSigDoc (SpecSig {}) = text "SPECIALISE pragma" +hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" +hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma" +hsSigDoc (FixSig {}) = text "fixity declaration" +hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" +hsSigDoc (SCCFunSig {}) = text "SCC pragma" +hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" +hsSigDoc (XSig {}) = text "XSIG TTG extension" + +{- +Check if signatures overlap; this is used when checking for duplicate +signatures. Since some of the signatures contain a list of names, testing for +equality is not enough -- we have to check if they overlap. +-} + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where + ppr sig = ppr_sig sig + +ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc +ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (ClassOpSig _ is_deflt vars ty) + | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) + | otherwise = pprVarSig (map unLoc vars) (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@(InlinePragma { inl_inline = spec })) + = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) + (interpp'SP ty) inl) + where + pragmaSrc = case spec of + NoUserInline -> "{-# SPECIALISE" + _ -> "{-# SPECIALISE_INLINE" +ppr_sig (InlineSig _ var inl) + = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl + <+> pprPrefixOcc (unLoc var)) +ppr_sig (SpecInstSig _ src ty) + = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty) +ppr_sig (MinimalSig _ src bf) + = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) +ppr_sig (PatSynSig _ names sig_ty) + = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) +ppr_sig (SCCFunSig _ src fn mlabel) + = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel ) +ppr_sig (CompleteMatchSig _ src cs mty) + = pragSrcBrackets src "{-# COMPLETE" + ((hsep (punctuate comma (map ppr (unLoc cs)))) + <+> opt_sig) + where + opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty +ppr_sig (XSig x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (FixitySig p) where + ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops] + where + pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) + ppr (XFixitySig x) = ppr x + +pragBrackets :: SDoc -> SDoc +pragBrackets doc = text "{-#" <+> doc <+> text "#-}" + +-- | Using SourceText in case the pragma was spelled differently or used mixed +-- case +pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc +pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}" +pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}" + +pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc +pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] + where + pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) + +pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc +pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty + where + pp_inl | isDefaultInlinePragma inl = empty + | otherwise = pprInline inl + +pprTcSpecPrags :: TcSpecPrags -> SDoc +pprTcSpecPrags IsDefaultMethod = text "<default method>" +pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) + +instance Outputable TcSpecPrag where + ppr (SpecPrag var _ inl) + = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl + +pprMinimalSig :: (OutputableBndr name) + => LBooleanFormula (Located name) -> SDoc +pprMinimalSig (L _ bf) = ppr (fmap unLoc bf) + +{- +************************************************************************ +* * +\subsection[PatSynBind]{A pattern synonym definition} +* * +************************************************************************ +-} + +-- | Haskell Pattern Synonym Details +type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg] + +-- See Note [Record PatSyn Fields] +-- | Record Pattern Synonym Field +data RecordPatSynField a + = RecordPatSynField { + recordPatSynSelectorId :: a -- Selector name visible in rest of the file + , recordPatSynPatVar :: a + -- Filled in by renamer, the name used internally + -- by the pattern + } deriving (Data, Functor) + + + +{- +Note [Record PatSyn Fields] + +Consider the following two pattern synonyms. + +pattern P x y = ([x,True], [y,'v']) +pattern Q{ x, y } =([x,True], [y,'v']) + +In P, we just have two local binders, x and y. + +In Q, we have local binders but also top-level record selectors +x :: ([Bool], [Char]) -> Bool and similarly for y. + +It would make sense to support record-like syntax + +pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) + +when we have a different name for the local and top-level binder +the distinction between the two names clear + +-} +instance Outputable a => Outputable (RecordPatSynField a) where + ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v + +instance Foldable RecordPatSynField where + foldMap f (RecordPatSynField { recordPatSynSelectorId = visible + , recordPatSynPatVar = hidden }) + = f visible `mappend` f hidden + +instance Traversable RecordPatSynField where + traverse f (RecordPatSynField { recordPatSynSelectorId =visible + , recordPatSynPatVar = hidden }) + = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id + , recordPatSynPatVar = pat_var }) + <$> f visible <*> f hidden + + +-- | Haskell Pattern Synonym Direction +data HsPatSynDir id + = Unidirectional + | ImplicitBidirectional + | ExplicitBidirectional (MatchGroup id (LHsExpr id)) |