summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Core/Coercion.hs45
-rw-r--r--compiler/GHC/Core/TyCo/Rep.hs15
-rw-r--r--compiler/GHC/Hs/Expr.hs63
-rw-r--r--compiler/GHC/Hs/Pat.hs11
-rw-r--r--compiler/GHC/HsToCore/PmCheck.hs6
5 files changed, 95 insertions, 45 deletions
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs
index 626b1bbc78..317ca00906 100644
--- a/compiler/GHC/Core/Coercion.hs
+++ b/compiler/GHC/Core/Coercion.hs
@@ -12,7 +12,8 @@
module GHC.Core.Coercion (
-- * Main data type
Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR,
- UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar,
+ UnivCoProvenance, CoercionHole(..), BlockSubstFlag(..),
+ coHoleCoVar, setCoHoleCoVar,
LeftOrRight(..),
Var, CoVar, TyCoVar,
Role(..), ltRole,
@@ -111,7 +112,9 @@ module GHC.Core.Coercion (
-- * Other
promoteCoercion, buildCoercion,
- simplifyArgsWorker
+ simplifyArgsWorker,
+
+ badCoercionHole, badCoercionHoleCo
) where
#include "HsVersions.h"
@@ -148,6 +151,7 @@ import UniqFM
import Control.Monad (foldM, zipWithM)
import Data.Function ( on )
import Data.Char( isDigit )
+import qualified Data.Monoid as Monoid
{-
%************************************************************************
@@ -2904,3 +2908,40 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
ppr (take 10 orig_roles), -- often infinite!
ppr orig_tys])
-}
+
+{-
+%************************************************************************
+%* *
+ Coercion holes
+%* *
+%************************************************************************
+-}
+
+bad_co_hole_ty :: Type -> Monoid.Any
+bad_co_hole_co :: Coercion -> Monoid.Any
+(bad_co_hole_ty, _, bad_co_hole_co, _)
+ = foldTyCo folder ()
+ where
+ folder = TyCoFolder { tcf_view = const Nothing
+ , tcf_tyvar = const2 (Monoid.Any False)
+ , tcf_covar = const2 (Monoid.Any False)
+ , tcf_hole = const hole
+ , tcf_tycobinder = const2
+ }
+
+ const2 :: a -> b -> c -> a
+ const2 x _ _ = x
+
+ hole :: CoercionHole -> Monoid.Any
+ hole (CoercionHole { ch_blocker = YesBlockSubst }) = Monoid.Any True
+ hole _ = Monoid.Any False
+
+-- | Is there a blocking coercion hole in this type? See
+-- TcCanonical Note [Equalities with incompatible kinds]
+badCoercionHole :: Type -> Bool
+badCoercionHole = Monoid.getAny . bad_co_hole_ty
+
+-- | Is there a blocking coercion hole in this coercion? See
+-- TcCanonical Note [Equalities with incompatible kinds]
+badCoercionHoleCo :: Coercion -> Bool
+badCoercionHoleCo = Monoid.getAny . bad_co_hole_co
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index 26c01ebcb8..c1ca32fc3c 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -39,7 +39,7 @@ module GHC.Core.TyCo.Rep (
-- * Coercions
Coercion(..),
UnivCoProvenance(..),
- CoercionHole(..), coHoleCoVar, setCoHoleCoVar,
+ CoercionHole(..), BlockSubstFlag(..), coHoleCoVar, setCoHoleCoVar,
CoercionN, CoercionR, CoercionP, KindCoercion,
MCoercion(..), MCoercionR, MCoercionN,
@@ -1487,12 +1487,18 @@ instance Outputable UnivCoProvenance where
-- | A coercion to be filled in by the type-checker. See Note [Coercion holes]
data CoercionHole
- = CoercionHole { ch_co_var :: CoVar
+ = CoercionHole { ch_co_var :: CoVar
-- See Note [CoercionHoles and coercion free variables]
- , ch_ref :: IORef (Maybe Coercion)
+ , ch_blocker :: BlockSubstFlag -- should this hole block substitution?
+ -- See (2a) in TcCanonical
+ -- Note [Equalities with incompatible kinds]
+ , ch_ref :: IORef (Maybe Coercion)
}
+data BlockSubstFlag = YesBlockSubst
+ | NoBlockSubst
+
coHoleCoVar :: CoercionHole -> CoVar
coHoleCoVar = ch_co_var
@@ -1508,6 +1514,9 @@ instance Data.Data CoercionHole where
instance Outputable CoercionHole where
ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv)
+instance Outputable BlockSubstFlag where
+ ppr YesBlockSubst = text "YesBlockSubst"
+ ppr NoBlockSubst = text "NoBlockSubst"
{- Note [Phantom coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 551401be6c..2e05270065 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1089,10 +1089,9 @@ ppr_expr (XExpr x) = case ghcPass @p of
GhcPs -> ppr x
GhcRn -> ppr x
GhcTc -> case x of
- HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e
+ HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e
else pprExpr e)
-
ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc
ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v)
ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c))
@@ -1118,7 +1117,7 @@ ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))
-- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
-- = char '@' <> pprHsType arg
pp (Right arg)
- = char '@' <> ppr arg
+ = text "@" <> ppr arg
pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
@@ -1712,41 +1711,39 @@ pprPatBind pat (grhss)
pprMatch :: (OutputableBndrId idR, Outputable body)
=> Match (GhcPass idR) body -> SDoc
-pprMatch match
+pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
= sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)
- , nest 2 (pprGRHSs ctxt (m_grhss match)) ]
+ , nest 2 (pprGRHSs ctxt grhss) ]
where
- ctxt = m_ctxt match
(herald, other_pats)
= case ctxt of
FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}
- | strictness == SrcStrict -> ASSERT(null $ m_pats match)
- (char '!'<>pprPrefixOcc fun, m_pats match)
- -- a strict variable binding
- | fixity == Prefix -> (pprPrefixOcc fun, m_pats match)
- -- f x y z = e
- -- Not pprBndr; the AbsBinds will
- -- have printed the signature
-
- | null pats2 -> (pp_infix, [])
- -- x &&& y = e
-
- | otherwise -> (parens pp_infix, pats2)
- -- (x &&& y) z = e
- where
- pp_infix = pprParendLPat opPrec pat1
- <+> pprInfixOcc fun
- <+> pprParendLPat opPrec pat2
-
- LambdaExpr -> (char '\\', m_pats match)
-
- _ -> if null (m_pats match)
- then (empty, [])
- else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
- (ppr pat1, []) -- No parens around the single pat
-
- (pat1:pats1) = m_pats match
- (pat2:pats2) = pats1
+ | SrcStrict <- strictness
+ -> ASSERT(null pats) -- A strict variable binding
+ (char '!'<>pprPrefixOcc fun, pats)
+
+ | Prefix <- fixity
+ -> (pprPrefixOcc fun, pats) -- f x y z = e
+ -- Not pprBndr; the AbsBinds will
+ -- have printed the signature
+ | otherwise
+ -> case pats of
+ (p1:p2:rest)
+ | null rest -> (pp_infix, []) -- x &&& y = e
+ | otherwise -> (parens pp_infix, rest) -- (x &&& y) z = e
+ where
+ pp_infix = pprParendLPat opPrec p1
+ <+> pprInfixOcc fun
+ <+> pprParendLPat opPrec p2
+ _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
+
+ LambdaExpr -> (char '\\', pats)
+
+ _ -> case pats of
+ [] -> (empty, [])
+ [pat] -> (ppr pat, []) -- No parens around the single pat in a case
+ _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
+pprMatch (XMatch nec) = noExtCon nec
pprGRHSs :: (OutputableBndrId idR, Outputable body)
=> HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index c427d977ed..1bddfa2c71 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -1,3 +1,4 @@
+
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -58,6 +59,7 @@ import TcEvidence
import BasicTypes
-- others:
import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )
+import GHC.Driver.Session ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) )
import TysWiredIn
import Var
import RdrName ( RdrName )
@@ -526,10 +528,11 @@ pprPat (NPat _ l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k]
pprPat (SplicePat _ splice) = pprSplice splice
pprPat (CoPat _ co pat _) = pprIfTc @p $
- pprHsWrapper co $ \parens
- -> if parens
- then pprParendPat appPrec pat
- else pprPat pat
+ sdocWithDynFlags $ \ dflags ->
+ if gopt Opt_PrintTypecheckerElaboration dflags
+ then hang (text "CoPat" <+> parens (ppr co))
+ 2 (pprParendPat appPrec pat)
+ else pprPat pat
pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr_ty
where ppr_ty = case ghcPass @p of
GhcPs -> ppr ty
diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs
index 3891be649d..61278391d0 100644
--- a/compiler/GHC/HsToCore/PmCheck.hs
+++ b/compiler/GHC/HsToCore/PmCheck.hs
@@ -32,7 +32,7 @@ import GHC.Core (CoreExpr, Expr(Var,App))
import FastString (unpackFS, lengthFS)
import GHC.Driver.Session
import GHC.Hs
-import TcHsSyn
+import TcHsSyn ( shortCutLit )
import Id
import GHC.Core.ConLike
import Name
@@ -45,7 +45,7 @@ import GHC.Core.DataCon
import GHC.Core.TyCon
import Var (EvVar)
import GHC.Core.Coercion
-import TcEvidence
+import TcEvidence ( HsWrapper(..), isIdHsWrapper )
import TcType (evVarPred)
import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr)
import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)
@@ -999,7 +999,7 @@ checkGrdTree guards deltas = do
tracePm "checkGrdTree {" $ vcat [ ppr guards
, ppr deltas ]
res <- checkGrdTree' guards deltas
- tracePm "}:" (ppr res) -- braces are easier to match by tooling
+ tracePm "checkGrdTree }:" (ppr res) -- braces are easier to match by tooling
return res
-- ----------------------------------------------------------------------------
View Lorry Controller Status