Commit a13cb279 authored by Alan Zimmerman's avatar Alan Zimmerman

Merge MatchFixity and HsMatchContext

Summary:
MatchFixity was introduced to facilitate use of API Annotations.

HsMatchContext does the same thing with more detail, but is chased
through all over the place to provide context when processing a Match.

Since we already have MatchFixity in the Match, it may as well provide
the full context.

updates submodule haddock

Test Plan: ./validate

Reviewers: austin, goldfire, bgamari

Subscribers: thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2271

GHC Trac Issues: #12105

(cherry picked from commit 306ecad5)
parent 1937ef1c
......@@ -1328,8 +1328,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
(ppr_match, pref)
= case kind of
FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp)
FunRhs (L _ fun) _ -> (pprMatchContext kind,
\ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp)
ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
ppr_pats kind pats
......
......@@ -124,7 +124,9 @@ dsHsBind dflags
dsHsBind dflags
(FunBind { fun_id = L _ fun, fun_matches = matches
, fun_co_fn = co_fn, fun_tick = tick })
= do { (args, body) <- matchWrapper (FunRhs (idName fun)) Nothing matches
= do { (args, body) <- matchWrapper
(FunRhs (noLoc $ idName fun) Prefix)
Nothing matches
; let body' = mkOptTickBox tick body
; rhs <- dsHsWrapper co_fn (mkLams args body')
; let core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
......@@ -313,7 +315,9 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
= putSrcSpanDs bind_loc $
addDictsDs (toTcTypeBag (listToBag dicts)) $
-- addDictsDs: push type constraints deeper for pattern match check
do { (args, body) <- matchWrapper (FunRhs (idName global)) Nothing matches
do { (args, body) <- matchWrapper
(FunRhs (noLoc $ idName global) Prefix)
Nothing matches
; let body' = mkOptTickBox tick body
; fun_rhs <- dsHsWrapper co_fn $
mkLams args body'
......
......@@ -149,13 +149,14 @@ dsUnliftedBind (AbsBindsSig { abs_tvs = []
; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body
; return (mkCoreLets ds_binds body') }
dsUnliftedBind (FunBind { fun_id = L _ fun
dsUnliftedBind (FunBind { fun_id = L l fun
, fun_matches = matches
, fun_co_fn = co_fn
, fun_tick = tick }) body
-- Can't be a bang pattern (that looks like a PatBind)
-- so must be simply unboxed
= do { (args, rhs) <- matchWrapper (FunRhs (idName fun)) Nothing matches
= do { (args, rhs) <- matchWrapper (FunRhs (L l $ idName fun) Prefix)
Nothing matches
; MASSERT( null args ) -- Functions aren't lifted
; MASSERT( isIdHsWrapper co_fn )
; let rhs' = mkOptTickBox tick rhs
......@@ -685,7 +686,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
, pat_args = PrefixCon $ map nlVarPat arg_ids
, pat_arg_tys = in_inst_tys
, pat_wrap = req_wrap }
; return (mkSimpleMatch [pat] wrapped_rhs) }
; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
-- Here is where we desugar the Template Haskell brackets and escapes
......@@ -909,7 +910,8 @@ dsDo stmts
; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty
; let fun = L noSrcSpan $ HsLam $
MG { mg_alts = noLoc [mkSimpleMatch pats body']
MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
body']
, mg_arg_tys = arg_tys
, mg_res_ty = body_ty
, mg_origin = Generated }
......@@ -940,7 +942,9 @@ dsDo stmts
rets = map noLoc rec_rets
mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
mfix_arg = noLoc $ HsLam
(MG { mg_alts = noLoc [mkSimpleMatch [mfix_pat] body]
(MG { mg_alts = noLoc [mkSimpleMatch
LambdaExpr
[mfix_pat] body]
, mg_arg_tys = [tup_ty], mg_res_ty = body_ty
, mg_origin = Generated })
mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
......
......@@ -1553,7 +1553,7 @@ repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds))))
do { xs <- repLPs ps; body <- repLE e; repLam xs body })
; wrapGenSyms ss lam }
repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m)
-----------------------------------------------------------------------------
......
......@@ -142,7 +142,7 @@ cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName))
cvtDec (TH.ValD pat body ds)
| TH.VarP s <- pat
= do { s' <- vNameL s
; cl' <- cvtClause (Clause [] body ds)
; cl' <- cvtClause (FunRhs s' Prefix) (Clause [] body ds)
; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
| otherwise
......@@ -161,7 +161,7 @@ cvtDec (TH.FunD nm cls)
<+> text "has no equations")
| otherwise
= do { nm' <- vNameL nm
; cls' <- mapM cvtClause cls
; cls' <- mapM (cvtClause (FunRhs nm' Prefix)) cls
; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
cvtDec (TH.SigD nm typ)
......@@ -354,7 +354,7 @@ cvtDec (TH.DefaultSigD nm typ)
cvtDec (TH.PatSynD nm args dir pat)
= do { nm' <- cNameL nm
; args' <- cvtArgs args
; dir' <- cvtDir dir
; dir' <- cvtDir nm' dir
; pat' <- cvtPat pat
; returnJustL $ Hs.ValD $ PatSynBind $
PSB nm' placeHolderType args' pat' dir' }
......@@ -366,10 +366,10 @@ cvtDec (TH.PatSynD nm args dir pat)
; vars' <- mapM (vNameL . mkNameS . nameBase) sels
; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' }
cvtDir Unidir = return Unidirectional
cvtDir ImplBidir = return ImplicitBidirectional
cvtDir (ExplBidir cls) =
do { ms <- mapM cvtClause cls
cvtDir _ Unidir = return Unidirectional
cvtDir _ ImplBidir = return ImplicitBidirectional
cvtDir n (ExplBidir cls) =
do { ms <- mapM (cvtClause (FunRhs n Prefix)) cls
; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
cvtDec (TH.PatSynSigD nm ty)
......@@ -730,12 +730,13 @@ cvtLocalDecs doc ds
; unless (null bads) (failWith (mkBadDecMsg doc bads))
; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtClause (Clause ps body wheres)
cvtClause :: HsMatchContext RdrName
-> TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtClause ctxt (Clause ps body wheres)
= do { ps' <- cvtPats ps
; g' <- cvtGuard body
; ds' <- cvtLocalDecs (text "a where clause") wheres
; returnL $ Hs.Match NonFunBindMatch ps' Nothing
; returnL $ Hs.Match ctxt ps' Nothing
(GRHSs g' (noLoc ds')) }
......@@ -756,8 +757,9 @@ cvtl e = wrapL (cvt e)
cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y
; return $ HsApp x' y' }
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms
; return $ HsLam (mkMatchGroup FromSource
[mkSimpleMatch LambdaExpr ps' e'])}
cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms
; return $ HsLamCase (mkMatchGroup FromSource ms')
}
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
......@@ -777,7 +779,7 @@ cvtl e = wrapL (cvt e)
; return $ HsMultiIf placeHolderType alts' }
cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds
; e' <- cvtl e; return $ HsLet (noLoc ds') e' }
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
; return $ HsCase e' (mkMatchGroup FromSource ms') }
cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss
......@@ -950,12 +952,13 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' n
where
cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtMatch (TH.Match p body decs)
cvtMatch :: HsMatchContext RdrName
-> TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtMatch ctxt (TH.Match p body decs)
= do { p' <- cvtPat p
; g' <- cvtGuard body
; decs' <- cvtLocalDecs (text "a where clause") decs
; returnL $ Hs.Match NonFunBindMatch [p'] Nothing
; returnL $ Hs.Match ctxt [p'] Nothing
(GRHSs g' (noLoc decs')) }
cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
......
......@@ -22,7 +22,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
GRHSs, pprPatBind )
import {-# SOURCE #-} HsPat ( LPat )
import PlaceHolder ( PostTc,PostRn,DataId )
import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId )
import HsTypes
import PprCore ()
import CoreSyn
......@@ -405,12 +405,14 @@ Specifically,
it's just an error thunk
-}
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
instance (OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsLocalBindsLR idL idR) where
ppr (HsValBinds bs) = ppr bs
ppr (HsIPBinds bs) = ppr bs
ppr EmptyLocalBinds = empty
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
instance (OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsValBindsLR idL idR) where
ppr (ValBindsIn binds sigs)
= pprDeclList (pprLHsBindsForUser binds sigs)
......@@ -425,12 +427,14 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR id
pp_rec Recursive = text "rec"
pp_rec NonRecursive = text "nonrec"
pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR)
=> LHsBindsLR idL idR -> SDoc
pprLHsBinds binds
| isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map ppr (bagToList binds))
pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR,
OutputableBndrId id2)
=> LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
-- pprLHsBindsForUser is different to pprLHsBinds because
-- a) No braces: 'let' and 'where' include a list of HsBindGroups
......@@ -491,7 +495,6 @@ plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds"
{-
What AbsBinds means
~~~~~~~~~~~~~~~~~~~
......@@ -518,10 +521,12 @@ So the desugarer tries to do a better job:
in (fm,gm)
-}
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
instance (OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsBindLR idL idR) where
ppr mbind = ppr_monobind mbind
ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR)
=> HsBindLR idL idR -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
= pprPatBind pat grhss
......@@ -534,7 +539,7 @@ ppr_monobind (FunBind { fun_id = fun,
= pprTicks empty (if null ticks then empty
else text "-- ticks = " <> ppr ticks)
$$ ifPprDebug (pprBndr LetBind (unLoc fun))
$$ pprFunBind (unLoc fun) matches
$$ pprFunBind matches
$$ ifPprDebug (ppr wrap)
ppr_monobind (PatSynBind psb) = ppr psb
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
......@@ -574,8 +579,10 @@ instance (OutputableBndr id) => Outputable (ABExport id) where
, nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)]
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir })
instance (OutputableBndr idL, OutputableBndrId 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
......@@ -592,7 +599,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL
Unidirectional -> ppr_simple (text "<-")
ImplicitBidirectional -> ppr_simple equals
ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$
(nest 2 $ pprFunBind psyn mg)
(nest 2 $ pprFunBind mg)
pprTicks :: SDoc -> SDoc -> SDoc
-- Print stuff about ticks only when -dppr-debug is on, to avoid
......@@ -642,11 +649,11 @@ data IPBind id
= IPBind (Either (Located HsIPName) id) (LHsExpr id)
deriving instance (DataId name) => Data (IPBind name)
instance (OutputableBndr id) => Outputable (HsIPBinds id) where
instance (OutputableBndrId id) => Outputable (HsIPBinds id) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
$$ ifPprDebug (ppr ds)
instance (OutputableBndr id) => Outputable (IPBind id) where
instance (OutputableBndrId id) => Outputable (IPBind id) where
ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of
Left (L _ ip) -> pprBndr LetBind ip
......@@ -878,10 +885,10 @@ 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 (OutputableBndr name) => Outputable (Sig name) where
instance (OutputableBndrId name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig :: (OutputableBndrId name) => Sig name -> 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)
......
This diff is collapsed.
This diff is collapsed.
......@@ -8,9 +8,9 @@
module HsExpr where
import SrcLoc ( Located )
import Outputable ( SDoc, OutputableBndr, Outputable )
import Outputable ( SDoc, Outputable )
import {-# SOURCE #-} HsPat ( LPat )
import PlaceHolder ( DataId )
import PlaceHolder ( DataId, OutputableBndrId )
import Data.Data hiding ( Fixity )
type role HsExpr nominal
......@@ -33,21 +33,20 @@ instance (Data body,DataId id) => Data (MatchGroup id body)
instance (Data body,DataId id) => Data (GRHSs id body)
instance (DataId id) => Data (SyntaxExpr id)
instance OutputableBndr id => Outputable (HsExpr id)
instance OutputableBndr id => Outputable (HsCmd id)
instance (OutputableBndrId id) => Outputable (HsExpr id)
instance (OutputableBndrId id) => Outputable (HsCmd id)
type LHsExpr a = Located (HsExpr a)
pprLExpr :: (OutputableBndr i) =>
LHsExpr i -> SDoc
pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc
pprExpr :: (OutputableBndr i) =>
HsExpr i -> SDoc
pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc
pprSplice :: (OutputableBndr i) => HsSplice i -> SDoc
pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc
pprPatBind :: (OutputableBndr bndr, OutputableBndr id, Outputable body)
pprPatBind :: (OutputableBndrId bndr,
OutputableBndrId id, Outputable body)
=> LPat bndr -> GRHSs id body -> SDoc
pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> idL -> MatchGroup idR body -> SDoc
pprFunBind :: (OutputableBndrId idR, Outputable body)
=> MatchGroup idR body -> SDoc
......@@ -23,7 +23,7 @@ import BasicTypes ( FractionalLit(..),SourceText )
import Type ( Type )
import Outputable
import FastString
import PlaceHolder ( PostTc,PostRn,DataId )
import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId )
import Data.ByteString (ByteString)
import Data.Data hiding ( Fixity )
......@@ -165,7 +165,7 @@ instance Outputable HsLit where
ppr (HsWord64Prim _ w) = pprPrimWord64 w
-- in debug mode, print the expression that it's resolved to, too
instance OutputableBndr id => Outputable (HsOverLit id) where
instance (OutputableBndrId id) => Outputable (HsOverLit id) where
ppr (OverLit {ol_val=val, ol_witness=witness})
= ppr val <+> (ifPprDebug (parens (pprExpr witness)))
......
......@@ -43,7 +43,7 @@ import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr
-- friends:
import HsBinds
import HsLit
import PlaceHolder -- ( PostRn,PostTc,DataId )
import PlaceHolder
import HsTypes
import TcEvidence
import BasicTypes
......@@ -365,7 +365,7 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
************************************************************************
-}
instance (OutputableBndr name) => Outputable (Pat name) where
instance (OutputableBndrId name) => Outputable (Pat name) where
ppr = pprPat
pprPatBndr :: OutputableBndr name => name -> SDoc
......@@ -377,10 +377,10 @@ pprPatBndr var -- Print with type info if -dppr-debug is on
else
pprPrefixOcc var
pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
pprParendLPat :: (OutputableBndrId name) => LPat name -> SDoc
pprParendLPat (L _ p) = pprParendPat p
pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
pprParendPat :: (OutputableBndrId name) => Pat name -> SDoc
pprParendPat p = sdocWithDynFlags $ \ dflags ->
if need_parens dflags p
then parens (pprPat p)
......@@ -394,7 +394,7 @@ pprParendPat p = sdocWithDynFlags $ \ dflags ->
-- But otherwise the CoPat is discarded, so it
-- is the pattern inside that matters. Sigh.
pprPat :: (OutputableBndr name) => Pat name -> SDoc
pprPat :: (OutputableBndrId name) => Pat name -> SDoc
pprPat (VarPat (L _ var)) = pprPatBndr var
pprPat (WildPat _) = char '_'
pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
......@@ -430,11 +430,12 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
else pprUserCon (unLoc con) details
pprUserCon :: (OutputableBndr con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc
pprUserCon :: (OutputableBndr con, OutputableBndrId id)
=> con -> HsConPatDetails id -> SDoc
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
pprConArgs :: OutputableBndr id => HsConPatDetails id -> SDoc
pprConArgs :: (OutputableBndrId id) => HsConPatDetails id -> SDoc
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
pprConArgs (RecCon rpats) = ppr rpats
......@@ -546,7 +547,7 @@ looksLazyLPat (L _ (VarPat {})) = False
looksLazyLPat (L _ (WildPat {})) = False
looksLazyLPat _ = True
isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
isIrrefutableHsPat :: (OutputableBndrId id) => LPat id -> Bool
-- (isIrrefutableHsPat p) is true if matching against p cannot fail,
-- in the sense of falling through to the next pattern.
-- (NB: this is not quite the same as the (silly) defn
......
......@@ -10,11 +10,11 @@ import SrcLoc( Located )
import Data.Data hiding (Fixity)
import Outputable
import PlaceHolder ( DataId )
import PlaceHolder ( DataId, OutputableBndrId )
type role Pat nominal
data Pat (i :: *)
type LPat i = Located (Pat i)
instance (DataId id) => Data (Pat id)
instance (OutputableBndr name) => Outputable (Pat name)
instance (OutputableBndrId name) => Outputable (Pat name)
......@@ -107,7 +107,7 @@ data HsModule name
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId name) => Data (HsModule name)
instance (OutputableBndr name, HasOccName name)
instance (OutputableBndrId name, HasOccName name)
=> Outputable (HsModule name) where
ppr (HsModule Nothing _ imports decls _ mbDoc)
......
......@@ -69,7 +69,8 @@ module HsTypes (
import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..),
OutputableBndrId )
import Id ( Id )
import Name( Name )
......@@ -584,7 +585,7 @@ data HsAppType name
| HsAppPrefix (LHsType name) -- anything else, including things like (+)
deriving instance (DataId name) => Data (HsAppType name)
instance OutputableBndr name => Outputable (HsAppType name) where
instance (OutputableBndrId name) => Outputable (HsAppType name) where
ppr = ppr_app_ty TopPrec
{-
......@@ -715,7 +716,7 @@ data ConDeclField name -- Record fields have Haddoc docs on them
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId name) => Data (ConDeclField name)
instance (OutputableBndr name) => Outputable (ConDeclField name) where
instance (OutputableBndrId name) => Outputable (ConDeclField name) where
ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
-- HsConDetails is used for patterns/expressions *and* for data type
......@@ -1104,16 +1105,16 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
************************************************************************
-}
instance (OutputableBndr name) => Outputable (HsType name) where
instance (OutputableBndrId name) => Outputable (HsType name) where
ppr ty = pprHsType ty
instance Outputable HsTyLit where
ppr = ppr_tylit
instance (OutputableBndr name) => Outputable (LHsQTyVars name) where
instance (OutputableBndrId name) => Outputable (LHsQTyVars name) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
instance (OutputableBndrId name) => Outputable (HsTyVarBndr name) where
ppr (UserTyVar n) = ppr n
ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
......@@ -1126,7 +1127,8 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs name thing) where
instance Outputable (HsWildCardInfo name) where
ppr (AnonWildCard _) = char '_'
pprHsForAll :: OutputableBndr name => [LHsTyVarBndr name] -> LHsContext name -> SDoc
pprHsForAll :: (OutputableBndrId name)
=> [LHsTyVarBndr name] -> LHsContext name -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
-- | Version of 'pprHsForAll' that can also print an extra-constraints
......@@ -1136,32 +1138,34 @@ pprHsForAll = pprHsForAllExtra Nothing
-- function for this is needed, as the extra-constraints wildcard is removed
-- from the actual context and type, and stored in a separate field, thus just
-- printing the type will not print the extra-constraints wildcard.
pprHsForAllExtra :: OutputableBndr name => Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name -> SDoc
pprHsForAllExtra :: (OutputableBndrId name)
=> Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name
-> SDoc
pprHsForAllExtra extra qtvs cxt
= pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt)
where
show_extra = isJust extra
pprHsForAllTvs :: OutputableBndr name => [LHsTyVarBndr name] -> SDoc
pprHsForAllTvs :: (OutputableBndrId name) => [LHsTyVarBndr name] -> SDoc
pprHsForAllTvs qtvs
| show_forall = forAllLit <+> interppSP qtvs <> dot
| otherwise = empty
where
show_forall = opt_PprStyle_Debug || not (null qtvs)
pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
pprHsContext :: (OutputableBndrId name) => HsContext name -> SDoc
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
pprHsContextNoArrow :: (OutputableBndr name) => HsContext name -> SDoc
pprHsContextNoArrow :: (OutputableBndrId name) => HsContext name -> SDoc
pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
pprHsContextMaybe :: (OutputableBndr name) => HsContext name -> Maybe SDoc
pprHsContextMaybe :: (OutputableBndrId name) => HsContext name -> Maybe SDoc
pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
pprHsContextExtra :: (OutputableBndr name) => Bool -> HsContext name -> SDoc
pprHsContextExtra :: (OutputableBndrId name) => Bool -> HsContext name -> SDoc
pprHsContextExtra show_extra ctxt
| not show_extra
= pprHsContext ctxt
......@@ -1172,7 +1176,7 @@ pprHsContextExtra show_extra ctxt
where
ctxt' = map ppr ctxt ++ [char '_']
pprConDeclFields :: OutputableBndr name => [LConDeclField name] -> SDoc
pprConDeclFields :: (OutputableBndrId name) => [LConDeclField name] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
......@@ -1196,7 +1200,7 @@ seems like the Right Thing anyway.)
-- Printing works more-or-less as for Types
pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc
pprHsType, pprParendHsType :: (OutputableBndrId name) => HsType name -> SDoc
pprHsType ty = ppr_mono_ty TopPrec (prepare ty)
pprParendHsType ty = ppr_mono_ty TyConPrec ty
......@@ -1207,10 +1211,10 @@ prepare (HsParTy ty) = prepare (unLoc ty)
prepare (HsAppsTy [L _ (HsAppPrefix (L _ ty))]) = prepare ty
prepare ty = ty
ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc
ppr_mono_lty :: (OutputableBndrId name) => TyPrec -> LHsType name -> SDoc
ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
ppr_mono_ty :: (OutputableBndr name) => TyPrec -> HsType name -> SDoc
ppr_mono_ty :: (OutputableBndrId name) => TyPrec -> HsType name -> SDoc
ppr_mono_ty ctxt_prec (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
= maybeParen ctxt_prec FunPrec $
sep [pprHsForAllTvs tvs, ppr_mono_lty TopPrec ty]
......@@ -1268,7 +1272,8 @@ ppr_mono_ty ctxt_prec (HsDocTy ty doc)
-- postfix operators
--------------------------
ppr_fun_ty :: (OutputableBndr name) => TyPrec -> LHsType name -> LHsType name -> SDoc
ppr_fun_ty :: (OutputableBndrId name)
=> TyPrec -> LHsType name -> LHsType name -> SDoc
ppr_fun_ty ctxt_prec ty1 ty2
= let p1 = ppr_mono_lty FunPrec ty1
p2 = ppr_mono_lty TopPrec ty2
......@@ -1277,7 +1282,7 @@ ppr_fun_ty ctxt_prec ty1 ty2
sep [p1, text "->" <+> p2]
--------------------------
ppr_app_ty :: OutputableBndr name => TyPrec -> HsAppType name -> SDoc
ppr_app_ty :: (OutputableBndrId name) => TyPrec -> HsAppType name -> SDoc
ppr_app_ty _ (HsAppInfix (L _ n)) = pprInfixOcc n
ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar (L _ n)))) = pprPrefixOcc n
ppr_app_ty ctxt (HsAppPrefix ty) = ppr_mono_lty ctxt ty
......
......@@ -20,7 +20,7 @@ which deal with the instantiated versions are located elsewhere:
module HsUtils(
-- Terms
mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsConApp, mkSimpleHsAlt,
mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsConApp, mkHsCaseAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
......@@ -133,10 +133,12 @@ just attach noSrcSpan to everything.
mkHsPar :: LHsExpr id -> LHsExpr id
mkHsPar e = L (getLoc e) (HsPar e)
mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
mkSimpleMatch pats rhs
mkSimpleMatch :: HsMatchContext (NameOrRdrName id)
-> [LPat id] -> Located (body id)
-> LMatch id (Located (body id))
mkSimpleMatch ctxt pats rhs
= L loc $
Match NonFunBindMatch pats Nothing (unguardedGRHSs rhs)
Match ctxt pats Nothing (unguardedGRHSs rhs)
where
loc = case pats of
[] -> getLoc rhs
......@@ -178,8 +180,9 @@ mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)
mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where
matches = mkMatchGroup Generated [mkSimpleMatch pats body]
where
matches = mkMatchGroup Generated
[mkSimpleMatch LambdaExpr pats body]
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
......@@ -192,10 +195,11 @@ mkHsConApp data_con tys args
where
mk_app f a = noLoc (HsApp f (noLoc a))
mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
mkSimpleHsAlt pat expr
= mkSimpleMatch [pat] expr
-- |A simple case alternative with a single pattern, no binds, no guards;
-- pre-typechecking
mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
mkHsCaseAlt pat expr
= mkSimpleMatch CaseAlt [pat] expr
nlHsTyApp :: name -> [Type] -> LHsExpr name
nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
......@@ -709,13 +713,15 @@ isInfixFunBind _ = False
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-> LHsExpr RdrName -> LHsBind RdrName
mk_easy_FunBind loc fun pats expr
= L loc $ mkFunBind (L loc fun) [mkMatch pats expr (noLoc emptyLocalBinds)]
= L loc $ mkFunBind (L loc fun)
[mkMatch (FunRhs (L loc fun) Prefix) pats expr
(noLoc emptyLocalBinds)]
------------
mkMatch :: [LPat id] -> LHsExpr id -> Located (HsLocalBinds id)
-> LMatch id (LHsExpr id)
mkMatch pats expr lbinds
= noLoc (Match NonFunBindMatch (map paren pats) Nothing
mkMatch :: HsMatchContext (NameOrRdrName id) -> [LPat id] -> LHsExpr id
-> Located (HsLocalBinds id) -> LMatch id (LHsExpr id)
mkMatch ctxt pats expr lbinds
= noLoc (Match ctxt (map paren pats) Nothing
(GRHSs (unguardedRHS noSrcSpan expr) lbinds))
where
paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
......
......@@ -17,6 +17,7 @@ import ConLike (ConLike)
import FieldLabel