Commit 5819ae21 authored by Alan Zimmerman's avatar Alan Zimmerman

Remove HasSourceText and SourceTextX classes

Updates haddock submodule to match.

Test Plan : Validate

Differential Revision: https://phabricator.haskell.org/D4199
parent 718a0181
......@@ -754,8 +754,8 @@ addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprRHS e
addTickApplicativeArg
:: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
-> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
:: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
addTickApplicativeArg isGuard (op, arg) =
liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
where
......
......@@ -2390,16 +2390,16 @@ repLiteral lit
mk_integer :: Integer -> DsM (HsLit GhcRn)
mk_integer i = do integer_ty <- lookupType integerTyConName
return $ HsInteger noSourceText i integer_ty
return $ HsInteger NoSourceText i integer_ty
mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat def r rat_ty
mk_string :: FastString -> DsM (HsLit GhcRn)
mk_string s = return $ HsString noSourceText s
mk_string s = return $ HsString NoSourceText s
mk_char :: Char -> DsM (HsLit GhcRn)
mk_char c = return $ HsChar noSourceText c
mk_char c = return $ HsChar NoSourceText c
repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit)
repOverloadedLiteral (OverLit { ol_val = val})
......
......@@ -14,6 +14,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
module HsBinds where
......@@ -560,14 +561,14 @@ Specifically,
it's just an error thunk
-}
instance (SourceTextX idL, SourceTextX idR,
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
instance (SourceTextX idL, SourceTextX idR,
instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsValBindsLR idL idR) where
ppr (ValBindsIn binds sigs)
......@@ -584,17 +585,16 @@ instance (SourceTextX idL, SourceTextX idR,
pp_rec Recursive = text "rec"
pp_rec NonRecursive = text "nonrec"
pprLHsBinds :: (SourceTextX idL, SourceTextX idR,
OutputableBndrId idL, OutputableBndrId idR)
=> LHsBindsLR idL idR -> SDoc
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 :: (SourceTextX idL, SourceTextX idR,
OutputableBndrId idL, OutputableBndrId idR,
SourceTextX id2, OutputableBndrId id2)
=> LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
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
......@@ -658,14 +658,13 @@ plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds"
instance (SourceTextX idL, SourceTextX idR,
instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsBindLR idL idR) where
ppr mbind = ppr_monobind mbind
ppr_monobind :: (SourceTextX idL, SourceTextX idR,
OutputableBndrId idL, OutputableBndrId idR)
=> HsBindLR idL idR -> SDoc
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
......@@ -705,8 +704,7 @@ instance (OutputableBndrId p) => Outputable (ABExport p) where
, nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)]
instance (SourceTextX idR,
OutputableBndrId idL, OutputableBndrId idR)
instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
psb_dir = dir })
......@@ -777,11 +775,12 @@ data IPBind id
= IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id)
deriving instance (DataId name) => Data (IPBind name)
instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsIPBinds p) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
$$ whenPprDebug (ppr ds)
instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where
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
......@@ -1054,11 +1053,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 (SourceTextX pass, OutputableBndrId pass)
=> Outputable (Sig pass) where
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where
ppr sig = ppr_sig sig
ppr_sig :: (SourceTextX pass, OutputableBndrId pass ) => Sig pass -> SDoc
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)
......
This diff is collapsed.
This diff is collapsed.
......@@ -5,6 +5,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TypeFamilies #-}
module HsExpr where
......@@ -12,7 +13,7 @@ import SrcLoc ( Located )
import Outputable ( SDoc, Outputable )
import {-# SOURCE #-} HsPat ( LPat )
import BasicTypes ( SpliceExplicitFlag(..))
import HsExtension ( OutputableBndrId, DataId, SourceTextX )
import HsExtension ( OutputableBndrId, DataId, GhcPass )
import Data.Data hiding ( Fixity )
type role HsExpr nominal
......@@ -35,25 +36,24 @@ instance (Data body,DataId p) => Data (MatchGroup p body)
instance (Data body,DataId p) => Data (GRHSs p body)
instance (DataId p) => Data (SyntaxExpr p)
instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p)
instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p)
type LHsExpr a = Located (HsExpr a)
pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc
pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc
pprSpliceDecl :: (SourceTextX p, OutputableBndrId p)
=> HsSplice p -> SpliceExplicitFlag -> SDoc
pprSpliceDecl :: (OutputableBndrId (GhcPass p))
=> HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr,
OutputableBndrId bndr,
OutputableBndrId p,
pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr),
OutputableBndrId (GhcPass p),
Outputable body)
=> LPat bndr -> GRHSs p body -> SDoc
=> LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
=> MatchGroup idR body -> SDoc
pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body)
=> MatchGroup (GhcPass idR) body -> SDoc
......@@ -124,91 +124,20 @@ type ForallX (c :: * -> Constraint) (x :: *) =
)
-- Provide the specific extension types for the parser phase.
type instance XHsChar GhcPs = SourceText
type instance XHsCharPrim GhcPs = SourceText
type instance XHsString GhcPs = SourceText
type instance XHsStringPrim GhcPs = SourceText
type instance XHsInt GhcPs = ()
type instance XHsIntPrim GhcPs = SourceText
type instance XHsWordPrim GhcPs = SourceText
type instance XHsInt64Prim GhcPs = SourceText
type instance XHsWord64Prim GhcPs = SourceText
type instance XHsInteger GhcPs = SourceText
type instance XHsRat GhcPs = ()
type instance XHsFloatPrim GhcPs = ()
type instance XHsDoublePrim GhcPs = ()
-- Provide the specific extension types for the renamer phase.
type instance XHsChar GhcRn = SourceText
type instance XHsCharPrim GhcRn = SourceText
type instance XHsString GhcRn = SourceText
type instance XHsStringPrim GhcRn = SourceText
type instance XHsInt GhcRn = ()
type instance XHsIntPrim GhcRn = SourceText
type instance XHsWordPrim GhcRn = SourceText
type instance XHsInt64Prim GhcRn = SourceText
type instance XHsWord64Prim GhcRn = SourceText
type instance XHsInteger GhcRn = SourceText
type instance XHsRat GhcRn = ()
type instance XHsFloatPrim GhcRn = ()
type instance XHsDoublePrim GhcRn = ()
-- Provide the specific extension types for the typechecker phase.
type instance XHsChar GhcTc = SourceText
type instance XHsCharPrim GhcTc = SourceText
type instance XHsString GhcTc = SourceText
type instance XHsStringPrim GhcTc = SourceText
type instance XHsInt GhcTc = ()
type instance XHsIntPrim GhcTc = SourceText
type instance XHsWordPrim GhcTc = SourceText
type instance XHsInt64Prim GhcTc = SourceText
type instance XHsWord64Prim GhcTc = SourceText
type instance XHsInteger GhcTc = SourceText
type instance XHsRat GhcTc = ()
type instance XHsFloatPrim GhcTc = ()
type instance XHsDoublePrim GhcTc = ()
-- ---------------------------------------------------------------------
-- | The 'SourceText' fields have been moved into the extension fields, thus
-- placing a requirement in the extension field to contain a 'SourceText' so
-- that the pretty printing and round tripping of source can continue to
-- operate.
--
-- The 'HasSourceText' class captures this requirement for the relevant fields.
class HasSourceText a where
-- Provide setters to mimic existing constructors
noSourceText :: a
sourceText :: String -> a
setSourceText :: SourceText -> a
getSourceText :: a -> SourceText
-- | Provide a summary constraint that lists all the extension points requiring
-- the 'HasSourceText' class, so that it can be changed in one place as the
-- named extensions change throughout the AST.
type SourceTextX x =
( HasSourceText (XHsChar x)
, HasSourceText (XHsCharPrim x)
, HasSourceText (XHsString x)
, HasSourceText (XHsStringPrim x)
, HasSourceText (XHsIntPrim x)
, HasSourceText (XHsWordPrim x)
, HasSourceText (XHsInt64Prim x)
, HasSourceText (XHsWord64Prim x)
, HasSourceText (XHsInteger x)
)
-- | 'SourceText' trivially implements 'HasSourceText'
instance HasSourceText SourceText where
noSourceText = NoSourceText
sourceText s = SourceText s
type instance XHsChar (GhcPass _) = SourceText
type instance XHsCharPrim (GhcPass _) = SourceText
type instance XHsString (GhcPass _) = SourceText
type instance XHsStringPrim (GhcPass _) = SourceText
type instance XHsInt (GhcPass _) = ()
type instance XHsIntPrim (GhcPass _) = SourceText
type instance XHsWordPrim (GhcPass _) = SourceText
type instance XHsInt64Prim (GhcPass _) = SourceText
type instance XHsWord64Prim (GhcPass _) = SourceText
type instance XHsInteger (GhcPass _) = SourceText
type instance XHsRat (GhcPass _) = ()
type instance XHsFloatPrim (GhcPass _) = ()
type instance XHsDoublePrim (GhcPass _) = ()
setSourceText s = s
getSourceText a = a
-- ----------------------------------------------------------------------
......
......@@ -8,7 +8,6 @@
{-# LANGUAGE CPP, DeriveDataTypeable #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
......@@ -195,35 +194,28 @@ instance Ord OverLitVal where
compare (HsIsString _ _) (HsFractional _) = GT
-- Instance specific to GhcPs, need the SourceText
instance (SourceTextX x) => Outputable (HsLit x) where
ppr (HsChar st c) = pprWithSourceText (getSourceText st) (pprHsChar c)
ppr (HsCharPrim st c)
= pp_st_suffix (getSourceText st) primCharSuffix (pprPrimChar c)
ppr (HsString st s)
= pprWithSourceText (getSourceText st) (pprHsString s)
ppr (HsStringPrim st s)
= pprWithSourceText (getSourceText st) (pprHsBytes s)
instance p ~ GhcPass pass => Outputable (HsLit p) where
ppr (HsChar st c) = pprWithSourceText st (pprHsChar c)
ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c)
ppr (HsString st s) = pprWithSourceText st (pprHsString s)
ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)
ppr (HsInt _ i)
= pprWithSourceText (il_text i) (integer (il_value i))
ppr (HsInteger st i _) = pprWithSourceText (getSourceText st) (integer i)
ppr (HsInteger st i _) = pprWithSourceText st (integer i)
ppr (HsRat _ f _) = ppr f
ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix
ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix
ppr (HsIntPrim st i)
= pprWithSourceText (getSourceText st) (pprPrimInt i)
ppr (HsWordPrim st w)
= pprWithSourceText (getSourceText st) (pprPrimWord w)
ppr (HsInt64Prim st i)
= pp_st_suffix (getSourceText st) primInt64Suffix (pprPrimInt64 i)
ppr (HsWord64Prim st w)
= pp_st_suffix (getSourceText st) primWord64Suffix (pprPrimWord64 w)
ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i)
ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w)
ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i)
ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w)
pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix NoSourceText _ doc = doc
pp_st_suffix (SourceText st) suffix _ = text st <> suffix
-- in debug mode, print the expression that it's resolved to, too
instance (SourceTextX p, OutputableBndrId p)
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsOverLit p) where
ppr (OverLit {ol_val=val, ol_witness=witness})
= ppr val <+> (whenPprDebug (parens (pprExpr witness)))
......@@ -239,11 +231,10 @@ instance Outputable OverLitVal where
-- mainly for too reasons:
-- * We do not want to expose their internal representation
-- * The warnings become too messy
pmPprHsLit :: (SourceTextX x) => HsLit x -> SDoc
pmPprHsLit :: HsLit (GhcPass x) -> SDoc
pmPprHsLit (HsChar _ c) = pprHsChar c
pmPprHsLit (HsCharPrim _ c) = pprHsChar c
pmPprHsLit (HsString st s) = pprWithSourceText (getSourceText st)
(pprHsString s)
pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s)
pmPprHsLit (HsStringPrim _ s) = pprHsBytes s
pmPprHsLit (HsInt _ i) = integer (il_value i)
pmPprHsLit (HsIntPrim _ i) = integer i
......
......@@ -414,8 +414,7 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
************************************************************************
-}
instance (SourceTextX pass, OutputableBndrId pass)
=> Outputable (Pat pass) where
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where
ppr = pprPat
pprPatBndr :: OutputableBndr name => name -> SDoc
......@@ -427,10 +426,10 @@ pprPatBndr var -- Print with type info if -dppr-debug is on
else
pprPrefixOcc var
pprParendLPat :: (SourceTextX pass, OutputableBndrId pass) => LPat pass -> SDoc
pprParendLPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> SDoc
pprParendLPat (L _ p) = pprParendPat p
pprParendPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
pprParendPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
pprParendPat p = sdocWithDynFlags $ \ dflags ->
if need_parens dflags p
then parens (pprPat p)
......@@ -444,7 +443,7 @@ pprParendPat p = sdocWithDynFlags $ \ dflags ->
-- But otherwise the CoPat is discarded, so it
-- is the pattern inside that matters. Sigh.
pprPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
pprPat (VarPat (L _ var)) = pprPatBndr var
pprPat (WildPat _) = char '_'
pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
......@@ -481,12 +480,13 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
else pprUserCon (unLoc con) details
pprUserCon :: (SourceTextX p, OutputableBndr con, OutputableBndrId p)
=> con -> HsConPatDetails p -> SDoc
pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p))
=> con -> HsConPatDetails (GhcPass p) -> SDoc
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
pprConArgs :: (SourceTextX p, OutputableBndrId p) => HsConPatDetails p -> SDoc
pprConArgs :: (OutputableBndrId (GhcPass p))
=> HsConPatDetails (GhcPass p) -> SDoc
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
pprConArgs (RecCon rpats) = ppr rpats
......@@ -525,9 +525,9 @@ mkPrefixConPat dc pats tys
mkNilPat :: Type -> OutPat p
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
mkCharLitPat :: (SourceTextX p) => SourceText -> Char -> OutPat p
mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
mkCharLitPat src c = mkPrefixConPat charDataCon
[noLoc $ LitPat (HsCharPrim (setSourceText src) c)] []
[noLoc $ LitPat (HsCharPrim src c)] []
{-
************************************************************************
......@@ -587,7 +587,7 @@ looksLazyLPat (L _ (VarPat {})) = False
looksLazyLPat (L _ (WildPat {})) = False
looksLazyLPat _ = True
isIrrefutableHsPat :: (SourceTextX p, OutputableBndrId p) => LPat p -> Bool
isIrrefutableHsPat :: (OutputableBndrId p) => LPat p -> 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
......
......@@ -4,17 +4,18 @@
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE TypeFamilies #-}
module HsPat where
import SrcLoc( Located )
import Data.Data hiding (Fixity)
import Outputable
import HsExtension ( SourceTextX, DataId, OutputableBndrId )
import HsExtension ( DataId, OutputableBndrId, GhcPass )
type role Pat nominal
data Pat (i :: *)
type LPat i = Located (Pat i)
instance (DataId p) => Data (Pat p)
instance (SourceTextX pass, OutputableBndrId pass) => Outputable (Pat pass)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
......@@ -15,6 +15,7 @@ therefore, is almost nothing but re-exporting.
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
module HsSyn (
module HsBinds,
......@@ -112,8 +113,7 @@ data HsModule name
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId name) => Data (HsModule name)
instance (SourceTextX pass, OutputableBndrId pass)
=> Outputable (HsModule pass) where
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where
ppr (HsModule Nothing _ imports decls _ mbDoc)
= pp_mb mbDoc $$ pp_nonnull imports
......
......@@ -8,13 +8,13 @@ HsTypes: Abstract syntax: user-defined types
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
module HsTypes (
HsType(..), LHsType, HsKind, LHsKind,
......@@ -620,8 +620,8 @@ data HsAppType pass
| HsAppPrefix (LHsType pass) -- anything else, including things like (+)
deriving instance (DataId pass) => Data (HsAppType pass)
instance (SourceTextX pass, OutputableBndrId pass)
=> Outputable (HsAppType pass) where
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsAppType p) where
ppr = ppr_app_ty
{-
......@@ -765,8 +765,8 @@ data ConDeclField pass -- Record fields have Haddoc docs on them
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId pass) => Data (ConDeclField pass)
instance (SourceTextX pass, OutputableBndrId pass)
=> Outputable (ConDeclField pass) where
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (ConDeclField p) where
ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
-- HsConDetails is used for patterns/expressions *and* for data type
......@@ -1148,19 +1148,18 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
************************************************************************
-}
instance (SourceTextX pass, OutputableBndrId pass)
=> Outputable (HsType pass) where
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsType p) where
ppr ty = pprHsType ty
instance Outputable HsTyLit where
ppr = ppr_tylit
instance (SourceTextX pass, OutputableBndrId pass)
=> Outputable (LHsQTyVars pass) where
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (LHsQTyVars p) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
instance (SourceTextX pass, OutputableBndrId pass)
=> Outputable (HsTyVarBndr pass) where
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsTyVarBndr p) where
ppr (UserTyVar n) = ppr n
ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
......@@ -1173,8 +1172,8 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs pass thing) where
instance Outputable (HsWildCardInfo pass) where
ppr (AnonWildCard _) = char '_'
pprHsForAll :: (SourceTextX pass, OutputableBndrId pass)
=> [LHsTyVarBndr pass] -> LHsContext pass -> SDoc
pprHsForAll :: (OutputableBndrId (GhcPass p))
=> [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
-- | Version of 'pprHsForAll' that can also print an extra-constraints
......@@ -1184,44 +1183,43 @@ 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 :: (SourceTextX pass, OutputableBndrId pass)
=> Maybe SrcSpan -> [LHsTyVarBndr pass] -> LHsContext pass
-> SDoc
pprHsForAllExtra :: (OutputableBndrId (GhcPass p))
=> Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)]
-> LHsContext (GhcPass p) -> SDoc
pprHsForAllExtra extra qtvs cxt
= pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt)
where
show_extra = isJust extra
pprHsForAllTvs :: (SourceTextX pass, OutputableBndrId pass)
=> [LHsTyVarBndr pass] -> SDoc
pprHsForAllTvs :: (OutputableBndrId (GhcPass p))
=> [LHsTyVarBndr (GhcPass p)] -> SDoc
pprHsForAllTvs qtvs
| null qtvs = whenPprDebug (forAllLit <+> dot)
| otherwise = forAllLit <+> interppSP qtvs <> dot
pprHsContext :: (SourceTextX pass, OutputableBndrId pass)
=> HsContext pass -> SDoc
pprHsContext :: (OutputableBndrId (GhcPass p)) => HsContext (GhcPass p) -> SDoc
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
pprHsContextNoArrow :: (SourceTextX pass, OutputableBndrId pass)
=> HsContext pass -> SDoc
pprHsContextNoArrow :: (OutputableBndrId (GhcPass p))
=> HsContext (GhcPass p) -> SDoc
pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
pprHsContextMaybe :: (SourceTextX pass, OutputableBndrId pass)
=> HsContext pass -> Maybe SDoc
pprHsContextMaybe :: (OutputableBndrId (GhcPass p))
=> HsContext (GhcPass p) -> Maybe SDoc
pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
-- For use in a HsQualTy, which always gets printed if it exists.
pprHsContextAlways :: (SourceTextX pass, OutputableBndrId pass)
=> HsContext pass -> SDoc
pprHsContextAlways :: (OutputableBndrId (GhcPass p))
=> HsContext (GhcPass p) -> SDoc
pprHsContextAlways [] = parens empty <+> darrow
pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow
pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow
-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
pprHsContextExtra :: (SourceTextX pass, OutputableBndrId pass)
=> Bool -> HsContext pass -> SDoc
pprHsContextExtra :: (OutputableBndrId (GhcPass p))
=> Bool -> HsContext (GhcPass p) -> SDoc
pprHsContextExtra show_extra ctxt
| not show_extra
= pprHsContext ctxt
......@@ -1232,8 +1230,8 @@ pprHsContextExtra show_extra ctxt
where
ctxt' = map ppr ctxt ++ [char '_']
pprConDeclFields :: (SourceTextX pass, OutputableBndrId pass)
=> [LConDeclField pass] -> SDoc
pprConDeclFields :: (OutputableBndrId (GhcPass p))
=> [LConDeclField (GhcPass p)] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
......@@ -1257,15 +1255,13 @@ seems like the Right Thing anyway.)
-- Printing works more-or-less as for Types
pprHsType :: (SourceTextX pass, OutputableBndrId pass) => HsType pass -> SDoc
pprHsType :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
pprHsType ty = ppr_mono_ty ty
ppr_mono_lty :: (SourceTextX pass, OutputableBndrId pass)
=> LHsType pass -> SDoc
ppr_mono_lty :: (OutputableBndrId (GhcPass p)) => LHsType (GhcPass p) -> SDoc
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_ty :: (SourceTextX pass, OutputableBndrId pass)
=> HsType pass -> SDoc
ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
= sep [pprHsForAllTvs tvs, ppr_mono_lty ty]
......@@ -1325,8 +1321,8 @@ ppr_mono_ty (HsDocTy ty doc)
-- postfix operators
--------------------------
ppr_fun_ty :: (SourceTextX pass, OutputableBndrId pass)
=> LHsType pass -> LHsType pass -> SDoc
ppr_fun_ty :: (OutputableBndrId (GhcPass p))
=> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
ppr_fun_ty ty1 ty2
= let p1 = ppr_mono_lty ty1
p2 = ppr_mono_lty ty2
......@@ -1334,8 +1330,7 @@ ppr_fun_ty ty1 ty2
sep [p1, text "->" <+> p2]
--------------------------
ppr_app_ty :: (SourceTextX pass, OutputableBndrId pass)
=> HsAppType pass -> SDoc
ppr_app_ty :: (OutputableBndrId (GhcPass p)) => HsAppType (GhcPass p) -> SDoc
ppr_app_ty (HsAppInfix (L _ n)) = pprInfixOcc n
ppr_app_ty (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n))))
= pprPrefixOcc n
......
......@@ -240,17 +240,17 @@ mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)
-> Pat GhcPs
mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs
mkLastStmt :: SourceTextX idR
=> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
mkLastStmt :: Located (bodyR (GhcPass idR))
-> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkBodyStmt :: Located (bodyR GhcPs)
-> StmtLR idL GhcPs (Located (bodyR GhcPs))
mkBindStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
=> LPat idL -&g