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
import SrcLoc (Located)
import TcEvidence ( HsWrapper )
import Outputable ( OutputableBndr )
import Data.Data hiding ( Fixity )
import BasicTypes (Fixity)
......@@ -97,9 +98,18 @@ In terms of actual usage, we have the following
PostRn id NameSet
TcId and Var are synonyms for Id
Unfortunately the type checker termination checking conditions fail for the
DataId constraint type based on this, so even though it is safe the
UndecidableInstances pragma is required where this is used.
-}