Ticket #5910: patch.diff

File patch.diff, 45.6 KB (added by xnyhps, 4 years ago)

Patch with my current changes.

  • compiler/basicTypes/BasicTypes.lhs

    diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
    index c6226ca..50434c6 100644
    a b module BasicTypes( 
    4040        compareFixity,
    4141
    4242        IPName(..), ipNameName, mapIPName,
     43  HoleName(..), holeNameName, mapHoleName,
    4344
    4445        RecFlag(..), isRec, isNonRec, boolToRecFlag,
    4546
    mapIPName f (IPName n) = IPName (f n) 
    189190
    190191instance Outputable name => Outputable (IPName name) where
    191192    ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters
     193
     194
     195newtype HoleName name = HoleName name -- _x
     196  deriving( Eq, Data, Typeable )
     197
     198instance Ord a => Ord (HoleName a) where
     199  compare (HoleName a) (HoleName b) = compare a b
     200
     201instance Functor HoleName where
     202    fmap = mapHoleName
     203
     204holeNameName :: HoleName name -> name
     205holeNameName (HoleName n) = n
     206
     207mapHoleName :: (a->b) -> HoleName a -> HoleName b
     208mapHoleName f (HoleName n) = HoleName (f n)
     209
     210instance Outputable name => Outputable (HoleName name) where
     211    ppr (HoleName n) = char '_' <> ppr n -- Ordinary holes
     212
    192213\end{code}
    193214
    194215%************************************************************************
  • compiler/basicTypes/Unique.lhs

    diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs
    index f99a50c..b81a5ad 100644
    a b instance Uniquable Int where 
    181181
    182182instance Uniquable n => Uniquable (IPName n) where
    183183  getUnique (IPName n) = getUnique n
     184
     185instance Uniquable n => Uniquable (HoleName n) where
     186  getUnique (HoleName n) = getUnique n
    184187\end{code}
    185188
    186189
  • compiler/deSugar/Coverage.lhs

    diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
    index 2d0ad23..9f4ee73 100644
    a b addTickHsExpr (HsWrap w e) = 
    540540                (addTickHsExpr e)       -- explicitly no tick on inside
    541541
    542542addTickHsExpr e@(HsType _) = return e
     543addTickHsExpr e@(HsHole _) = return e
    543544
    544545-- Others dhould never happen in expression content.
    545546addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
  • compiler/deSugar/DsExpr.lhs

    diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
    index b34640a..eba835a 100644
    a b dsExpr (HsLam a_Match) 
    229229
    230230dsExpr (HsApp fun arg)
    231231  = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
     232
     233dsExpr (HsHole nm)
     234  = return (Var $ holeNameName nm)
    232235\end{code}
    233236
    234237Note [Desugaring vars]
  • compiler/hsSyn/HsExpr.lhs

    diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
    index 08d1281..90b9f59 100644
    a b data HsExpr id 
    290290
    291291  |  HsWrap     HsWrapper    -- TRANSLATION
    292292                (HsExpr id)
     293  |  HsHole     (HoleName id)
    293294  deriving (Data, Typeable)
    294295
    295296-- HsTupArg is used for tuple sections
    ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) 
    545546ppr_expr (HsArrForm op _ args)
    546547  = hang (ptext (sLit "(|") <> ppr_lexpr op)
    547548         4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
     549ppr_expr (HsHole name)
     550  = ppr name
    548551
    549552pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
    550553pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
  • compiler/iface/IfaceEnv.lhs

    diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs
    index 4c66a98..de43a89 100644
    a b module IfaceEnv ( 
    1212        newGlobalBinder, newImplicitBinder,
    1313        lookupIfaceTop,
    1414        lookupOrig, lookupOrigNameCache, extendNameCache,
    15         newIPName, newIfaceName, newIfaceNames,
     15        newIPName, newHoleName, newIfaceName, newIfaceNames,
    1616        extendIfaceIdEnv, extendIfaceTyVarEnv,
    1717        tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar,
    1818
    import UniqSupply 
    4242import SrcLoc
    4343import BasicTypes
    4444
     45import TysPrim
     46import TysWiredIn
     47import Coercion
     48
    4549import Outputable
    4650import Exception     ( evaluate )
    4751
    newIPName :: FastString -> TcRnIf m n (IPName Name) 
    181185newIPName ip = updNameCache $ flip allocateIPName ip
    182186\end{code}
    183187
     188\begin{code}
     189newHoleName :: FastString -> TcRnIf m n (HoleName Name)
     190newHoleName name = updNameCache $ \name_cache -> case Map.lookup name $ nsHoles name_cache of
     191    Just name_hole -> (name_cache, name_hole)
     192    Nothing        -> (new_ns, name_hole)
     193      where
     194        (us_here, us') = splitUniqSupply (nsUniqs name_cache)
     195        new_holecache = Map.insert name name_hole $ nsHoles name_cache
     196        tycon_u:datacon_u:dc_wrk_u:co_ax_u:_ = uniqsFromSupply us_here
     197        name_hole  = mkHoleName name tycon_u datacon_u dc_wrk_u co_ax_u
     198        new_ns     = name_cache { nsUniqs = us', nsHoles = new_holecache }
     199
     200\end{code}
     201
    184202%************************************************************************
    185203%*                                                                      *
    186204                Name cache access
    initNameCache :: UniqSupply -> [Name] -> NameCache 
    249267initNameCache us names
    250268  = NameCache { nsUniqs = us,
    251269                nsNames = initOrigNames names,
    252                 nsIPs   = Map.empty }
     270                nsIPs   = Map.empty,
     271                nsHoles = Map.empty }
    253272
    254273initOrigNames :: [Name] -> OrigNameCache
    255274initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
  • compiler/main/HscTypes.lhs

    diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
    index e0eea7d..4382532 100644
    a b data NameCache 
    17621762                -- ^ Supply of uniques
    17631763                nsNames :: OrigNameCache,
    17641764                -- ^ Ensures that one original name gets one unique
    1765                 nsIPs   :: OrigIParamCache
     1765                nsIPs   :: OrigIParamCache,
    17661766                -- ^ Ensures that one implicit parameter name gets one unique
     1767                nsHoles :: OrigHoleCache
    17671768   }
    17681769
    17691770-- | Per-module cache of original 'OccName's given 'Name's
    type OrigNameCache = ModuleEnv (OccEnv Name) 
    17711772
    17721773-- | Module-local cache of implicit parameter 'OccName's given 'Name's
    17731774type OrigIParamCache = Map FastString (IPName Name)
     1775
     1776type OrigHoleCache = Map FastString (HoleName Name)
    17741777\end{code}
    17751778
    17761779
  • compiler/main/InteractiveEval.hs

    diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
    index b62ec40..c466c72 100644
    a b parseName str = withSession $ \hsc_env -> do 
    932932exprType :: GhcMonad m => String -> m Type
    933933exprType expr = withSession $ \hsc_env -> do
    934934   ty <- liftIO $ hscTcExpr hsc_env expr
    935    return $ tidyType emptyTidyEnv ty
     935   return {-$ tidyType emptyTidyEnv-} ty
    936936
    937937-- -----------------------------------------------------------------------------
    938938-- Getting the kind of a type
  • compiler/parser/Lexer.x

    diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
    index 74da99a..d1139a2 100644
    a b $large = [$asclarge $unilarge] 
    105105
    106106$unismall  = \x02 -- Trick Alex into handling Unicode. See alexGetChar.
    107107$ascsmall  = [a-z]
    108 $small     = [$ascsmall $unismall \_]
     108$small     = [$ascsmall $unismall]
    109109
    110110$unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar.
    111111$graphic   = [$small $large $symbol $digit $special $unigraphic \:\"\']
    $tab+ { warn Opt_WarnTabs (text "Tab character") } 
    338338         { token ITcubxparen }
    339339}
    340340
     341<0> {
     342  \_ @varid { skip_one_varid IThole }
     343}
     344
    341345<0,option_prags> {
    342346  \(                                    { special IToparen }
    343347  \)                                    { special ITcparen }
    data Token 
    538542  | ITprefixqconsym (FastString,FastString)
    539543
    540544  | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
     545  | IThole         FastString
    541546
    542547  | ITchar       Char
    543548  | ITstring     FastString
  • compiler/parser/Parser.y.pp

    diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
    index ff98b74..cfd964a 100644
    a b incorrect. 
    322322 PREFIXQCONSYM  { L _ (ITprefixqconsym  _) }
    323323
    324324 IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension
     325 HOLEVARID      { L _ (IThole     _) }
    325326
    326327 CHAR           { L _ (ITchar     _) }
    327328 STRING         { L _ (ITstring   _) }
    aexp1 :: { LHsExpr RdrName } 
    14361437
    14371438aexp2   :: { LHsExpr RdrName }
    14381439        : ipvar                         { L1 (HsIPVar $! unLoc $1) }
     1440        | hole                          { L1 (HsHole  $! unLoc $1) }
    14391441        | qcname                        { L1 (HsVar   $! unLoc $1) }
    14401442        | literal                       { L1 (HsLit   $! unLoc $1) }
    14411443-- This will enable overloaded strings permanently.  Normally the renamer turns HsString
    dbind : ipvar '=' exp { LL (IPBind (unLoc $1) $3) } 
    17501752ipvar   :: { Located (IPName RdrName) }
    17511753        : IPDUPVARID            { L1 (IPName (mkUnqual varName (getIPDUPVARID $1))) }
    17521754
     1755hole    :: { Located (HoleName RdrName) }
     1756        : HOLEVARID             { L1 (HoleName (mkUnqual varName $ getHOLEVARID $1)) }
     1757
    17531758-----------------------------------------------------------------------------
    17541759-- Warnings and deprecations
    17551760
    getQCONSYM (L _ (ITqconsym x)) = x 
    20692074getPREFIXQVARSYM (L _ (ITprefixqvarsym  x)) = x
    20702075getPREFIXQCONSYM (L _ (ITprefixqconsym  x)) = x
    20712076getIPDUPVARID   (L _ (ITdupipvarid   x)) = x
     2077getHOLEVARID    (L _ (IThole     x)) = x
    20722078getCHAR         (L _ (ITchar     x)) = x
    20732079getSTRING       (L _ (ITstring   x)) = x
    20742080getINTEGER      (L _ (ITinteger  x)) = x
  • compiler/prelude/TysWiredIn.lhs

    diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
    index 7d4edfd..15e4f26 100644
    a b module TysWiredIn ( 
    7373        eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon,
    7474
    7575        -- * Implicit parameter predicates
    76         mkIPName
     76        mkIPName,
     77
     78        mkHoleName
    7779    ) where
    7880
    7981#include "HsVersions.h"
    import TyCon 
    9496import TypeRep
    9597import RdrName
    9698import Name
    97 import BasicTypes       ( TupleSort(..), tupleSortBoxity, IPName(..),
     99import BasicTypes       ( TupleSort(..), tupleSortBoxity, IPName(..), HoleName(..),
    98100                          Arity, RecFlag(..), Boxity(..), HsBang(..) )
    99101import ForeignCall
    100102import Unique           ( incrUnique, mkTupleTyConUnique,
    mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_ip 
    424426    co_ax_name = mkPrimTyConName ip co_ax_u tycon
    425427\end{code}
    426428
     429\begin{code}
     430mkHoleName :: FastString
     431         -> Unique -> Unique -> Unique -> Unique
     432         -> HoleName Name
     433mkHoleName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_hole
     434  where
     435    name_hole = HoleName tycon_name
     436
     437    tycon_name = mkPrimTyConName ip tycon_u tycon
     438    tycon      = mkAlgTyCon tycon_name
     439                   (liftedTypeKind `mkArrowKind` constraintKind)
     440                   [alphaTyVar]
     441                   Nothing
     442                   []      -- No stupid theta
     443                   (NewTyCon { data_con    = datacon,
     444                               nt_rhs      = mkTyVarTy alphaTyVar,
     445                               nt_etad_rhs = ([alphaTyVar], mkTyVarTy alphaTyVar),
     446                               nt_co       = mkNewTypeCo co_ax_name tycon [alphaTyVar] (mkTyVarTy alphaTyVar) })
     447                   (HoleTyCon name_hole)
     448                   NonRecursive
     449                   False
     450
     451    datacon_name = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "IPBox") datacon_u datacon
     452    datacon      = pcDataCon' datacon_name dc_wrk_u [alphaTyVar] [mkTyVarTy alphaTyVar] tycon
     453
     454    co_ax_name = mkPrimTyConName ip co_ax_u tycon
     455\end{code}
     456
    427457%************************************************************************
    428458%*                                                                      *
    429459\subsection[TysWiredIn-boxed-prim]{The ``boxed primitive'' types (@Char@, @Int@, etc)}
  • compiler/rename/RnExpr.lhs

    diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
    index 7caae61..d5ddff9 100644
    a b import HsSyn 
    3434import TcRnMonad
    3535import TcEnv            ( thRnBrack )
    3636import RnEnv
    37 import RnTypes          ( rnHsTypeFVs, rnSplice, rnIPName, checkTH,
     37import RnTypes          ( rnHsTypeFVs, rnSplice, rnIPName, rnHoleName, checkTH,
    3838                          mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
    3939import RnPat
    4040import DynFlags
    rnExpr (ArithSeq _ seq) 
    293293rnExpr (PArrSeq _ seq)
    294294  = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
    295295    return (PArrSeq noPostTcExpr new_seq, fvs)
     296
     297rnExpr (HsHole name)
     298  = do { name' <- rnHoleName name
     299       ; return (HsHole name', emptyFVs)
     300       }
    296301\end{code}
    297302
    298303These three are pattern syntax appearing in expressions.
  • compiler/rename/RnTypes.lhs

    diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
    index 3b86d0b..78c0bb7 100644
    a b module RnTypes ( 
    1616        rnHsType, rnLHsType, rnLHsTypes, rnContext,
    1717        rnHsKind, rnLHsKind, rnLHsMaybeKind,
    1818        rnHsSigType, rnLHsInstType, rnHsTypeFVs, rnConDeclFields,
    19         rnIPName,
     19        rnIPName, rnHoleName,
    2020
    2121        -- Precence related stuff
    2222        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
    import RnHsSyn ( extractHsTyNames, extractHsTyVarBndrNames_s ) 
    4141import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
    4242import RnEnv
    4343import TcRnMonad
    44 import IfaceEnv         ( newIPName )
     44import IfaceEnv         ( newIPName, newHoleName )
    4545import RdrName
    4646import PrelNames
    4747import TysPrim          ( funTyConName )
    import NameSet 
    5151
    5252import Util             ( filterOut )
    5353import BasicTypes       ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFixity,
    54                           Fixity(..), FixityDirection(..) )
     54                          Fixity(..), FixityDirection(..), HoleName(..), holeNameName )
    5555import Outputable
    5656import FastString
    5757import Control.Monad    ( unless, zipWithM )
    rnIPName :: IPName RdrName -> RnM (IPName Name) 
    344344rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n)))
    345345\end{code}
    346346
     347\begin{code}
     348rnHoleName :: HoleName RdrName -> RnM (HoleName Name)
     349rnHoleName n = newHoleName (occNameFS (rdrNameOcc (holeNameName n)))
     350\end{code}
     351
    347352
    348353%************************************************************************
    349354%*                                                                      *
  • compiler/typecheck/Inst.lhs

    diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
    index a194d74..437b50e 100644
    a b hasEqualities givens = any (has_eq . evVarPred) givens 
    519519    has_eq' (ClassPred cls _tys) = any has_eq (classSCTheta cls)
    520520    has_eq' (TuplePred ts)       = any has_eq ts
    521521    has_eq' (IrredPred _)        = True -- Might have equalities in it after reduction?
     522    has_eq' (HolePred {})        = False
    522523
    523524---------------- Getting free tyvars -------------------------
    524525
    tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys 
    529530tyVarsOfCt (CIPCan { cc_ip_ty = ty })                   = tyVarsOfType ty
    530531tyVarsOfCt (CIrredEvCan { cc_ty = ty })                 = tyVarsOfType ty
    531532tyVarsOfCt (CNonCanonical { cc_id = ev })               = tyVarsOfEvVar ev
     533tyVarsOfCt (CHoleCan { cc_hole_ty = ty })               = tyVarsOfType ty
    532534
    533535tyVarsOfCDict :: Ct -> TcTyVarSet
    534536tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
  • compiler/typecheck/TcCanonical.lhs

    diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
    index c765dde..28e86a3 100644
    a b module TcCanonical( 
    1313
    1414#include "HsVersions.h"
    1515
    16 import BasicTypes ( IPName )
     16import BasicTypes ( IPName, HoleName )
    1717import TcErrors
    1818import TcRnTypes
    1919import TcType
    import VarSet 
    3737import TcSMonad
    3838import FastString
    3939
     40import qualified TcMType
     41
    4042import Data.Maybe ( isNothing )
    4143import Data.List  ( zip4 )
    4244\end{code}
    canonicalize (CIrredEvCan { cc_id = ev, cc_flavor = fl 
    204206                          , cc_depth = d
    205207                          , cc_ty = xi })
    206208  = canIrred d fl ev xi
     209canonicalize (CHoleCan { cc_id = ev, cc_depth = d
     210                       , cc_flavor = fl
     211                       , cc_hole_nm = nm
     212                       , cc_hole_ty = xi })
     213  = canHole d fl ev nm xi
    207214
    208215
    209216canEvVar :: EvVar -> PredTree
    canEvVar ev pred_classifier d fl 
    216223      IPPred nm ty      -> canIP      d fl ev nm ty
    217224      IrredPred ev_ty   -> canIrred   d fl ev ev_ty
    218225      TuplePred tys     -> canTuple   d fl ev tys
     226      HolePred name ty  -> canHole  d fl ev name ty
    219227\end{code}
    220228
    221229
    canIP d fl v nm ty 
    263271  =    -- Note [Canonical implicit parameter constraints] explains why it's
    264272       -- possible in principle to not flatten, but since flattening applies
    265273       -- the inert substitution we choose to flatten anyway.
    266     do { (xi,co) <- flatten d fl (mkIPPred nm ty)
     274    do { (xi,co) <- trace "canIP" $ flatten d fl (mkIPPred nm ty)
    267275       ; let no_flattening = isTcReflCo co
    268276       ; if no_flattening then
    269277            let IPPred _ xi_in = classifyPredType xi
    constraint between the types. (On the other hand, the types in two 
    296304class constraints for the same class MAY be equal, so they need to be
    297305flattened in the first place to facilitate comparing them.)
    298306
     307\begin{code}
     308canHole :: SubGoalDepth -- Depth
     309      -> CtFlavor -> EvVar
     310      -> HoleName Name -> Type -> TcS StopOrContinue
     311canHole d fl v nm ty
     312  = do { (xi,co) <- flatten d fl (mkHolePred nm ty)
     313       ; let no_flattening = isTcReflCo co
     314       ; if no_flattening then
     315            let HolePred _ xi_in = classifyPredType xi
     316            in continueWith $ CHoleCan { cc_id = v, cc_flavor = fl
     317                                       , cc_hole_nm = nm, cc_hole_ty = xi_in
     318                                       , cc_depth = d
     319                                       }
     320         else
     321            error "false"
     322       }
     323\end{code}
     324
    299325%************************************************************************
    300326%*                                                                      *
    301327%*                      Class Canonicalization
  • compiler/typecheck/TcErrors.lhs

    diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
    index cb388ff..2831218 100644
    a b reportFlatErrs ctxt cts 
    294294          ClassPred {}  -> go cts (ct:dicts) ips irreds
    295295          IPPred {}     -> go cts dicts (ct:ips) irreds
    296296          IrredPred {}  -> go cts dicts ips (ct:irreds)
     297          HolePred {}   -> go cts dicts ips irreds
    297298          _             -> panic "mkFlat"
    298299    -- TuplePreds should have been expanded away by the constraint
    299300    -- simplifier, so they shouldn't show up at this point
  • compiler/typecheck/TcExpr.lhs

    diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
    index 488e654..67a10ae 100644
    a b import ErrUtils 
    6363import Outputable
    6464import FastString
    6565import Control.Monad
     66
     67import TypeRep
     68import qualified Data.Map as Map
    6669\end{code}
    6770
    6871%************************************************************************
    tcPolyExprNC expr res_ty 
    9093  = do { traceTc "tcPolyExprNC" (ppr res_ty)
    9194       ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho ->
    9295                            tcMonoExprNC expr rho
     96       ; sk <- deeplySkolemise res_ty
    9397       ; return (mkLHsWrap gen_fn expr') }
    9498
    9599---------------
    tcExpr (HsType ty) _ 
    214218        -- so it's not enabled yet.
    215219        -- Can't eliminate it altogether from the parser, because the
    216220        -- same parser parses *patterns*.
     221tcExpr (HsHole name) res_ty
     222  = do { traceTc "tcExpr.HsHole" (ppr $ res_ty)
     223       ; let origin = OccurrenceOf $ holeNameName name
     224       -- Update the local environment with our ty
     225       ; (g, l) <- getEnvs
     226       ; holes <- readTcRef $ tcl_holes l
     227       ; ty <- newFlexiTyVarTy liftedTypeKind
     228       
     229       -- Emit the constraint
     230       ; var <- emitWanted origin (mkHolePred name ty)
     231       ; traceTc "tcExpr.HsHole: Creating new ty for hole" (ppr ty)
     232       ; writeTcRef (tcl_holes l) (Map.insert name (ty, tcl_lie l) holes)
     233
     234       ; tcWrapResult (HsHole $ HoleName var) ty res_ty }
    217235\end{code}
    218236
    219237
  • compiler/typecheck/TcHsSyn.lhs

    diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
    index d99bd81..1232a0f 100644
    a b zonkExpr env (HsWrap co_fn expr) 
    703703    zonkExpr env1 expr  `thenM` \ new_expr ->
    704704    return (HsWrap new_co_fn new_expr)
    705705
     706zonkExpr env h@(HsHole nm)
     707  = do {
     708    traceTc "zonkExpr.HsHole" (ppr h);
     709    return (HsHole nm)
     710    }
     711
    706712zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
    707713
    708714zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
  • compiler/typecheck/TcInteract.lhs

    diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
    index 3e58013..3dc1744 100644
    a b import Pair ( pSnd ) 
    5656import UniqFM
    5757import FastString ( sLit )
    5858import DynFlags
     59
     60import Control.Monad
     61import Type
    5962\end{code}
    6063**********************************************************************
    6164*                                                                    *
    kick_out_rewritable ct (IS { inert_eqs = eqmap 
    415418                           , inert_funeqs = funeqmap
    416419                           , inert_irreds = irreds
    417420                           , inert_frozen = frozen
     421                           , inert_holes  = holemap
    418422                           } )
    419423  = ((kicked_out, eqmap), remaining)
    420424  where
    421425    kicked_out = WorkList { wl_eqs    = []
    422426                          , wl_funeqs = bagToList feqs_out
    423427                          , wl_rest   = bagToList (fro_out `andCts` dicts_out
    424                                           `andCts` ips_out `andCts` irs_out) }
     428                                          `andCts` ips_out `andCts` irs_out `andCts` holes_out) }
    425429 
    426430    remaining = IS { inert_eqs = emptyVarEnv
    427431                   , inert_eq_tvs = inscope -- keep the same, safe and cheap
    kick_out_rewritable ct (IS { inert_eqs = eqmap 
    430434                   , inert_funeqs = feqs_in
    431435                   , inert_irreds = irs_in
    432436                   , inert_frozen = fro_in
     437                   , inert_holes = holes_in
    433438                   }
    434439
    435440    fl = cc_flavor ct
    436441    tv = cc_tyvar ct
    437442                               
    438443    (ips_out,   ips_in)     = partitionCCanMap rewritable ipmap
     444    (holes_out, holes_in)   = partitionCCanMap rewritable holemap
    439445
    440446    (feqs_out,  feqs_in)    = partitionCtTypeMap rewritable funeqmap
    441447    (dicts_out, dicts_in)   = partitionCCanMap rewritable dictmap
    data InteractResult 
    686692    | IRInertConsumed    { ir_fire :: String }
    687693    | IRKeepGoing        { ir_fire :: String }
    688694
     695
     696instance Outputable InteractResult where
     697  ppr (IRWorkItemConsumed str) = ptext (sLit "IRWorkItemConsumed ") <+> text str
     698  ppr (IRInertConsumed str) = ptext (sLit "IRInertConsumed ") <+> text str
     699  ppr (IRKeepGoing str) = ptext (sLit "IRKeepGoing ") <+> text str
     700
    689701irWorkItemConsumed :: String -> TcS InteractResult
    690702irWorkItemConsumed str = return (IRWorkItemConsumed str)
    691703
    interactWithInertsStage :: WorkItem -> TcS StopOrContinue 
    703715-- react with anything at this stage.
    704716interactWithInertsStage wi
    705717  = do { ctxt <- getTcSContext
     718       ; traceTcS "interactWithInertsStage" (ppr $ simplEqsOnly ctxt)
    706719       ; if simplEqsOnly ctxt then
    707720             return (ContinueWith wi)
    708721         else
    709              extractRelevantInerts wi >>=
    710                foldlBagM interact_next (ContinueWith wi) }
     722             do { relevant <- extractRelevantInerts wi
     723                ; traceTcS "interactWithInertsStage: Relevant" (ppr relevant)
     724                ; foldlBagM interact_next (ContinueWith wi) relevant
     725                }
     726       }
    711727
    712728  where interact_next Stop atomic_inert
    713           = updInertSetTcS atomic_inert >> return Stop
     729          = trace "interact_next Stop" $ updInertSetTcS atomic_inert >> return Stop
    714730        interact_next (ContinueWith wi) atomic_inert
    715731          = do { ir <- doInteractWithInert atomic_inert wi
    716732               ; let mk_msg rule keep_doc
    717733                       = text rule <+> keep_doc
    718734                         <+> vcat [ ptext (sLit "Inert =") <+> ppr atomic_inert
    719735                                  , ptext (sLit "Work =")  <+> ppr wi ]
     736               ; traceTcS "interact_next ContinueWith" (ppr ir)
    720737               ; case ir of
    721738                   IRWorkItemConsumed { ir_fire = rule }
    722739                       -> do { bumpStepCountTcS
    doInteractWithInert (CFunEqCan { cc_id = eqv1, cc_flavor = fl1, cc_fun = tc1 
    851868  where
    852869    lhss_match = tc1 == tc2 && eqTypes args1 args2
    853870
     871doInteractWithInert (CHoleCan id1 fl1 nm1 ty1 d1) workitem@(CHoleCan id2 fl2 nm2 ty2 d2)
     872  | nm1 == nm2 && isGivenOrSolved fl2 && isGivenOrSolved fl1
     873  = irInertConsumed "Hole/Hole (override inert)"
     874  | nm1 == nm2 && ty1 `eqType` ty2
     875  = solveOneFromTheOther "Hole/Hole" (EvId id1,fl1) workitem
    854876
     877  | nm1 == nm2
     878  = do { let flav = Wanted (combineCtLoc fl1 fl2)
     879       ; eqv <- newEqVar flav ty2 ty1
     880       ; when (isNewEvVar eqv) $
     881              (let ct = CNonCanonical { cc_id     = evc_the_evvar eqv
     882                                      , cc_flavor = flav
     883                                      , cc_depth  = d2 }
     884              in updWorkListTcS (extendWorkListEq ct))
     885       ; case fl2 of
     886          Given {} -> pprPanic "Unexpected given Hole" (ppr workitem)
     887          Derived {} -> pprPanic "Unexpected derived Hole" (ppr workitem)
     888          Wanted {} ->
     889              do { _ <- setEvBind id2
     890                        (mkEvCast id1 (mkTcSymCo (mkTcTyConAppCo (holeTyCon nm1) [mkTcCoVarCo (evc_the_evvar eqv)]))) fl2
     891                 ; irWorkItemConsumed "Hole/Hole (solved by rewriting)" }
     892       }
    855893doInteractWithInert _ _ = irKeepGoing "NOP"
    856894
    857895
  • compiler/typecheck/TcMType.lhs

    diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
    index 518a403..b9b6c50 100644
    a b predTypeOccName :: PredType -> OccName 
    167167predTypeOccName ty = case classifyPredType ty of
    168168    ClassPred cls _ -> mkDictOcc (getOccName cls)
    169169    IPPred ip _     -> mkVarOccFS (ipFastString ip)
     170    HolePred name _ -> mkVarOccFS (occNameFS $ nameOccName $ holeNameName name)
    170171    EqPred _ _      -> mkVarOccFS (fsLit "cobox")
    171172    TuplePred _     -> mkVarOccFS (fsLit "tup")
    172173    IrredPred _     -> mkVarOccFS (fsLit "irred")
    growPredTyVars pred tvs = go (classifyPredType pred) 
    13861387    go (EqPred ty1 ty2)  = grow (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2)
    13871388    go (TuplePred ts)    = unionVarSets (map (go . classifyPredType) ts)
    13881389    go (IrredPred ty)    = grow (tyVarsOfType ty)
     1390    go (HolePred _ ty)   = tyVarsOfType ty
    13891391\end{code}
    13901392   
    13911393Note [Implicit parameters and ambiguity]
  • compiler/typecheck/TcRnDriver.lhs

    diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
    index 8a5aab5..97975de 100644
    a b import FamInstEnv 
    4040import TcAnnotations
    4141import TcBinds
    4242import HeaderInfo       ( mkPrelImports )
    43 import TcType   ( tidyTopType )
     43import TcType   ( tidyTopType, tidyType )
    4444import TcDefaults
    4545import TcEnv
    4646import TcRules
    import Bag 
    100100
    101101import Control.Monad
    102102
     103import System.IO
     104import TypeRep
     105import qualified Data.Map as Map
     106import TcType
     107
    103108#include "HsVersions.h"
    104109\end{code}
    105110
    tcRnSrcDecls boot_iface decls 
    429434                        simplifyTop lie ;
    430435        traceTc "Tc9" empty ;
    431436
     437        traceRn (text "tcRnSrcDecls:" <+> (ppr lie)) ;
     438
    432439        failIfErrsM ;   -- Don't zonk if there have been errors
    433440                        -- It's a waste of time; and we may get debug warnings
    434441                        -- about strangely-typed TyCons!
    tcRnSrcDecls boot_iface decls 
    461468        setGlobalTypeEnv tcg_env' final_type_env
    462469   } }
    463470
     471-- where
     472
    464473tc_rn_src_decls :: ModDetails
    465474                    -> [LHsDecl RdrName]
    466475                    -> TcM (TcGblEnv, TcLclEnv)
    tcRnExpr hsc_env ictxt rdr_expr 
    14231432        -- it might have a rank-2 type (e.g. :t runST)
    14241433    uniq <- newUnique ;
    14251434    let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
    1426     ((_tc_expr, res_ty), lie)   <- captureConstraints (tcInferRho rn_expr) ;
    1427     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
     1435    ((_tc_expr, res_ty), lie)   <- captureConstraints (tcInferRho rn_expr) ;
     1436
     1437
     1438    (g, l) <- getEnvs ;
     1439    holes <- readTcRef $ tcl_holes l ;
     1440
     1441    ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
    14281442                                      {-# SCC "simplifyInfer" #-}
    14291443                                      simplifyInfer True {- Free vars are closed -}
    14301444                                                    False {- No MR for now -}
    1431                                                     [(fresh_it, res_ty)]
     1445                                                    ([(fresh_it, res_ty)]) -- ++ (map (\(nm,(ty,_)) -> (holeNameName nm, ty)) $ Map.toList holes))
    14321446                                                    lie  ;
     1447        let { (holes, dicts') = splitEvs dicts [] [] } ;
     1448   
     1449    traceRn (text "tcRnExpr1:" <+> (ppr holes <+> ppr dicts')) ;
     1450
    14331451    _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
     1452   
     1453    traceRn (text "tcRnExpr2:" <+> (ppr lie_top)) ;
     1454
     1455    let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts' res_ty) } ;
     1456    result <- zonkTcType all_expr_ty ;
     1457
    14341458
    1435     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
    1436     zonkTcType all_expr_ty
     1459    zonked_holes <- zonkHoles $ map (apsnd (mkForAllTys qtvs) . apsnd (mkPiTypes dicts') . unwrapHole . varType) $ holes ;
     1460
     1461    let { (env, tidied_holes) = apsnd (map (apsnd split)) $ foldr tidy (emptyTidyEnv, []) zonked_holes } ;
     1462
     1463    liftIO $ putStrLn $ showSDoc ((ptext $ sLit "Found the following holes: ")
     1464                                $+$ (vcat $ map (\(nm, ty) -> text "_" <> ppr nm <+> colon <> colon <+> ppr ty) tidied_holes));
     1465
     1466    return $ snd $ tidyOpenType env result
    14371467    }
     1468    where tidy (nm, ty) (env, tys) = let (env', ty') = tidyOpenType env ty
     1469                                     in (env', (nm, ty') : tys)
     1470
     1471          split t = let (_, ctxt, ty') = tcSplitSigmaTy $ tidyTopType t
     1472                    in mkPhiTy ctxt ty'
     1473
     1474          splitEvs [] hls dcts = (hls, dcts)
     1475          splitEvs (evvar:xs) hls dcts = case classifyPredType $ varType evvar of
     1476                                                                                HolePred {} -> splitEvs xs (evvar:hls) dcts
     1477                                                                                _ -> splitEvs xs hls (evvar:dcts)
     1478          -- unwrap what was wrapped in mkHolePred
     1479          unwrapHole (TyConApp nm [ty]) = (nm, ty)
     1480
     1481          -- zonk the holes, but keep the name
     1482          zonkHoles = mapM (\(nm, ty) -> liftM (\t -> (nm, t)) $ zonkTcType ty)
     1483
     1484          apsnd f (a, b) = (a, f b)
     1485
     1486          f (_, b) = let (Just (ATyCon tc)) = wiredInNameTyThing_maybe b
     1487                         (Just (_, ty, _)) = trace ("unwrapNewTyCon_maybe" ++ (showSDoc $ ppr tc)) $ unwrapNewTyCon_maybe tc
     1488                                 in (b, ty)
    14381489
    14391490--------------------------
    14401491tcRnImportDecls :: HscEnv
  • compiler/typecheck/TcRnMonad.lhs

    diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
    index 77a1230..37f1d5a 100644
    a b import System.IO 
    5353import Data.IORef
    5454import qualified Data.Set as Set
    5555import Control.Monad
     56
     57import qualified Data.Map as Map
    5658\end{code}
    5759
    5860
    initTc hsc_env hsc_src keep_rn_syntax mod do_this 
    8688        infer_var    <- newIORef True ;
    8789        lie_var      <- newIORef emptyWC ;
    8890        dfun_n_var   <- newIORef emptyOccSet ;
     91        holes_var    <- newIORef Map.empty ;
    8992        type_env_var <- case hsc_type_env_var hsc_env of {
    9093                           Just (_mod, te_var) -> return te_var ;
    9194                           Nothing             -> newIORef emptyNameEnv } ;
    initTc hsc_env hsc_src keep_rn_syntax mod do_this 
    151154                tcl_tyvars     = tvs_var,
    152155                tcl_lie        = lie_var,
    153156                tcl_meta       = meta_var,
    154                 tcl_untch      = initTyVarUnique
     157                tcl_untch      = initTyVarUnique,
     158                tcl_holes      = holes_var
    155159             } ;
    156160        } ;
    157161
  • compiler/typecheck/TcRnTypes.lhs

    diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
    index b353943..36c7ae0 100644
    a b module TcRnTypes( 
    5454        Xi, Ct(..), Cts, emptyCts, andCts, andManyCts,
    5555        singleCt, extendCts, isEmptyCts, isCTyEqCan,
    5656        isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe,
     57        isCHoleCan_Maybe, isCHoleCan,
    5758        isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
    5859        isGivenCt_maybe, isGivenOrSolvedCt,
    5960        ctWantedLoc,
    6061        SubGoalDepth, mkNonCanonical, ctPred,
    6162
    6263        WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
    63         andWC, addFlats, addImplics, mkFlatWC,
     64        andWC, unionsWC, addFlats, addImplics, mkFlatWC,
    6465
    6566        Implication(..),
    6667        CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
    import FastString 
    123124
    124125import Data.Set (Set)
    125126
     127import UniqSet
     128import qualified Data.Map as Map
    126129\end{code}
    127130
    128131
    data TcLclEnv -- Changes as we move inside an expression 
    444447        -- TcMetaTyVars have
    445448        tcl_meta  :: TcRef Unique,  -- The next free unique for TcMetaTyVars
    446449                                    -- Guaranteed to be allocated linearly
    447         tcl_untch :: Unique         -- Any TcMetaTyVar with
     450        tcl_untch :: Unique,        -- Any TcMetaTyVar with
    448451                                    --     unique >= tcl_untch is touchable
    449452                                    --     unique <  tcl_untch is untouchable
     453        tcl_holes :: TcRef (Map.Map (HoleName Name) (Type, TcRef WantedConstraints))
    450454    }
    451455
    452456type TcTypeEnv = NameEnv TcTyThing
    data Ct 
    908912      cc_depth  :: SubGoalDepth
    909913    }
    910914
     915  | CHoleCan {
     916      cc_id       :: EvVar,
     917      cc_flavor   :: CtFlavor,
     918      cc_hole_nm  :: HoleName Name,
     919      cc_hole_ty  :: TcTauType, -- Not a Xi! See same not as above
     920      cc_depth    :: SubGoalDepth        -- See Note [WorkList]
     921    }
     922
    911923\end{code}
    912924
    913925\begin{code}
    ctPred (CFunEqCan { cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 }) 
    925937ctPred (CIPCan { cc_ip_nm = nm, cc_ip_ty = xi })
    926938  = mkIPPred nm xi
    927939ctPred (CIrredEvCan { cc_ty = xi }) = xi
     940ctPred (CHoleCan { cc_hole_nm = nm, cc_hole_ty = xi})
     941  = mkHolePred nm xi
    928942\end{code}
    929943
    930944
    isCFunEqCan_Maybe _ = Nothing 
    977991isCNonCanonical :: Ct -> Bool
    978992isCNonCanonical (CNonCanonical {}) = True
    979993isCNonCanonical _ = False
     994
     995isCHoleCan :: Ct -> Bool
     996isCHoleCan (CHoleCan {}) = True
     997isCHoleCan _ = False
     998
     999isCHoleCan_Maybe :: Ct -> Maybe (HoleName Name)
     1000isCHoleCan_Maybe (CHoleCan { cc_hole_nm = nm }) = Just nm
     1001isCHoleCan_Maybe _ = Nothing
    9801002\end{code}
    9811003
    9821004\begin{code}
    instance Outputable Ct where 
    9921014                           CDictCan {}      -> "CDictCan"
    9931015                           CIPCan {}        -> "CIPCan"
    9941016                           CIrredEvCan {}   -> "CIrredEvCan"
     1017                           CHoleCan {}          -> "CHoleCan"
    9951018\end{code}
    9961019
    9971020\begin{code}
    andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 }) 
    10581081       , wc_impl  = i1 `unionBags` i2
    10591082       , wc_insol = n1 `unionBags` n2 }
    10601083
     1084unionsWC :: [WantedConstraints] -> WantedConstraints
     1085unionsWC = foldr andWC emptyWC
     1086
    10611087addFlats :: WantedConstraints -> Bag Ct -> WantedConstraints
    10621088addFlats wc cts
    10631089  = wc { wc_flat = wc_flat wc `unionBags` cts }
  • compiler/typecheck/TcSMonad.lhs

    diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
    index 77c81e7..5d2fa67 100644
    a b data CCanMap a = CCanMap { cts_given :: UniqFM Cts 
    329329                         , cts_wanted  :: UniqFM Cts }
    330330                                          -- Invariant: all Wanted
    331331
     332instance Outputable (CCanMap a) where
     333  ppr (CCanMap given derived wanted) = ptext (sLit "CCanMap") <+> (ppr given) <+> (ppr derived) <+> (ppr wanted)
     334
    332335cCanMapToBag :: CCanMap a -> Cts
    333336cCanMapToBag cmap = foldUFM unionBags rest_wder (cts_given cmap)
    334337  where rest_wder = foldUFM unionBags rest_der  (cts_wanted cmap)
    data InertSet 
    415418
    416419       , inert_irreds       :: Cts  -- Irreducible predicates
    417420       , inert_frozen       :: Cts  -- All non-canonicals are kept here (as frozen errors)
     421       , inert_holes        :: CCanMap (HoleName Name)
    418422       }
    419423
    420424
    instance Outputable InertSet where 
    453457                , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts is)))
    454458                , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_ips is)))
    455459                , vcat (map ppr (Bag.bagToList $ ctTypeMapCts (inert_funeqs is)))
     460                , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_holes is)))
    456461                , text "Frozen errors =" <+> -- Clearly print frozen errors
    457462                    braces (vcat (map ppr (Bag.bagToList $ inert_frozen is)))
    458463                , text "Warning: Not displaying cached (solved) constraints"
    emptyInert = IS { inert_eqs = emptyVarEnv 
    466471                , inert_dicts   = emptyCCanMap
    467472                , inert_ips     = emptyCCanMap
    468473                , inert_funeqs  = emptyTM
     474                , inert_holes   = emptyCCanMap
    469475                }
    470476
    471477
    updInertSet is item 
    504510        upd_funeqs Nothing = Just item
    505511        upd_funeqs (Just _alredy_there) = panic "updInertSet: item already there!"
    506512    in is { inert_funeqs = alterTM pty upd_funeqs (inert_funeqs is) }
    507      
     513 
     514  | Just x <- isCHoleCan_Maybe item
     515  = is { inert_holes = updCCanMap (x,item) (inert_holes is) }
    508516  | otherwise
    509   = is { inert_frozen = inert_frozen is `Bag.snocBag` item }
     517  = trace "updInertSet" $ is { inert_frozen = inert_frozen is `Bag.snocBag` item }
    510518
    511519updInertSetTcS :: AtomicInert -> TcS ()
    512520-- Add a new item in the inerts of the monad
    extractUnsolved is@(IS {inert_eqs = eqs, inert_irreds = irreds}) 
    557565                        , inert_irreds = solved_irreds
    558566                        , inert_frozen = emptyCts
    559567                        , inert_funeqs = solved_funeqs
     568                        , inert_holes  = solved_holes
    560569                        }
    561570    in ((inert_frozen is, unsolved), is_solved)
    562571
    extractUnsolved is@(IS {inert_eqs = eqs, inert_irreds = irreds}) 
    570579
    571580        (unsolved_funeqs, solved_funeqs) = extractUnsolvedCtTypeMap (inert_funeqs is)
    572581
     582        (unsolved_holes, solved_holes)   = extractUnsolvedCMap (inert_holes is)
     583
    573584        unsolved = unsolved_eqs `unionBags` unsolved_irreds `unionBags`
    574585                   unsolved_ips `unionBags` unsolved_dicts `unionBags` unsolved_funeqs
     586                   `unionBags` unsolved_holes
    575587
    576588extractUnsolvedCtTypeMap :: TypeMap Ct -> (Cts,TypeMap Ct)
    577589extractUnsolvedCtTypeMap
    extractRelevantInerts wi 
    596608        extract_inert_relevants (CIrredEvCan { }) is =
    597609            let cts = inert_irreds is
    598610            in (cts, is { inert_irreds = emptyCts })
     611        extract_inert_relevants (CHoleCan { cc_hole_nm = nm }) is =
     612            let (cts, holes_map) = getRelevantCts nm (inert_holes is)
     613            in (cts, is { inert_holes = holes_map })
    599614        extract_inert_relevants _ is = (emptyCts,is)
    600615\end{code}
    601616
  • compiler/typecheck/TcSimplify.lhs

    diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
    index ae948b5..35da625 100644
    a b quantifyMe :: TyVarSet -- Quantifying over these 
    472472           -> Bool          -- True <=> quantify over this wanted
    473473quantifyMe qtvs ct
    474474  | isIPPred pred = True  -- Note [Inheriting implicit parameters]
     475  | isHolePred pred = True
    475476  | otherwise     = tyVarsOfType pred `intersectsVarSet` qtvs
    476477  where
    477478    pred = ctPred ct
  • compiler/typecheck/TcType.lhs

    diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
    index c947521..1a04aa1 100644
    a b module TcType ( 
    131131  mkTyVarTy, mkTyVarTys, mkTyConTy,
    132132
    133133  isClassPred, isEqPred, isIPPred,
    134   mkClassPred, mkIPPred,
     134  mkClassPred, mkIPPred, isHolePred,
    135135  isDictLikeTy,
    136136  tcSplitDFunTy, tcSplitDFunHead,
    137137  mkEqPred,
    data TcTyVarDetails 
    306306         
    307307  | MetaTv MetaInfo (IORef MetaDetails)
    308308
     309instance Outputable TcTyVarDetails where
     310  ppr (SkolemTv b)    = ptext (sLit "SkolemTv") <+> ppr b
     311  ppr RuntimeUnk      = ptext (sLit "RuntimeUnk")
     312  ppr (FlatSkol ty)   = ptext (sLit "FlatSkol") <+> ppr ty
     313  ppr (MetaTv info _) = ptext (sLit "MetaTv") <+> ppr info
     314
    309315vanillaSkolemTv, superSkolemTv :: TcTyVarDetails
    310316-- See Note [Binding when looking up instances] in InstEnv
    311317vanillaSkolemTv = SkolemTv False  -- Might be instantiated
    data MetaInfo 
    340346-- UserTypeCtxt describes the origin of the polymorphic type
    341347-- in the places where we need to an expression has that type
    342348
     349instance Outputable MetaInfo where
     350  ppr TauTv = ptext (sLit "TauTv")
     351  ppr SigTv = ptext (sLit "SigTv")
     352  ppr TcsTv = ptext (sLit "TcsTv")
     353
    343354data UserTypeCtxt
    344355  = FunSigCtxt Name     -- Function type signature
    345356                        -- Also used for types in SPECIALISE pragmas
  • compiler/types/TyCon.lhs

    diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
    index 0543092..8d46adb 100644
    a b module TyCon( 
    6565        tyConStupidTheta,
    6666        tyConArity,
    6767        tyConParent,
    68         tyConTuple_maybe, tyConClass_maybe, tyConIP_maybe,
     68        tyConTuple_maybe, tyConClass_maybe, tyConIP_maybe, tyConHole_maybe,
    6969        tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,
    7070        synTyConDefn, synTyConRhs, synTyConType,
    7171        tyConExtName,           -- External name for foreign types
    data TyConParent 
    551551        --      data R:TList a = ...
    552552        --      axiom co a :: T [a] ~ R:TList a
    553553        -- with R:TList's algTcParent = FamInstTyCon T [a] co
     554        | HoleTyCon (HoleName Name)
    554555
    555556instance Outputable TyConParent where
    556557    ppr NoParentTyCon           = text "No parent"
    okParent tc_name (AssocFamilyTyCon cls) = tc_name `elem` map tyConName (cla 
    566567okParent tc_name (ClassTyCon cls)            = tc_name == tyConName (classTyCon cls)
    567568okParent tc_name (IPTyCon ip)                = tc_name == ipTyConName ip
    568569okParent _       (FamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys
     570okParent tc_name (HoleTyCon hole)            = tc_name == holeNameName hole
    569571
    570572isNoParent :: TyConParent -> Bool
    571573isNoParent NoParentTyCon = True
    tyConIP_maybe :: TyCon -> Maybe (IPName Name) 
    14091411tyConIP_maybe (AlgTyCon {algTcParent = IPTyCon ip}) = Just ip
    14101412tyConIP_maybe _                                     = Nothing
    14111413
     1414tyConHole_maybe :: TyCon -> Maybe (HoleName Name)
     1415tyConHole_maybe (AlgTyCon {algTcParent = HoleTyCon name}) = Just name
     1416tyConHole_maybe _                                     = Nothing
     1417
    14121418----------------------------------------------------------------------------
    14131419tyConParent :: TyCon -> TyConParent
    14141420tyConParent (AlgTyCon {algTcParent = parent}) = parent
  • compiler/types/Type.lhs

    diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
    index 114e3e9..0547274 100644
    a b module Type ( 
    4949        mkFamilyTyConApp,
    5050        isDictLikeTy,
    5151        mkEqPred, mkClassPred,
    52         mkIPPred,
    53         noParenPred, isClassPred, isEqPred, isIPPred,
     52        mkIPPred, mkHolePred,
     53        noParenPred, isClassPred, isEqPred, isIPPred, isHolePred,
    5454        mkPrimEqType,
    5555
    5656        -- Deconstructing predicate types
    module Type ( 
    6060        getIPPredTy_maybe,
    6161
    6262        -- ** Common type constructors
    63         funTyCon,
     63        funTyCon, holeTyCon,
    6464
    6565        -- ** Predicates on types
    6666        isTypeVar, isKindVar,
    import TyCon 
    154154import TysPrim
    155155import {-# SOURCE #-} TysWiredIn ( eqTyCon, mkBoxedTupleTy )
    156156import PrelNames                 ( eqTyConKey )
     157import Name
    157158
    158159-- others
    159160import {-# SOURCE #-} IParam ( ipTyCon )
    160161import Unique           ( Unique, hasKey )
    161 import BasicTypes       ( IPName(..) )
     162import BasicTypes       ( IPName(..), HoleName(..), holeNameName )
    162163import Name             ( Name )
    163164import NameSet
    164165import StaticFlags
    isPredTy ty 
    815816isKindTy :: Type -> Bool
    816817isKindTy = isSuperKind . typeKind
    817818
    818 isClassPred, isEqPred, isIPPred :: PredType -> Bool
     819isClassPred, isEqPred, isIPPred, isHolePred :: PredType -> Bool
    819820isClassPred ty = case tyConAppTyCon_maybe ty of
    820821    Just tyCon | isClassTyCon tyCon -> True
    821822    _                               -> False
    isEqPred ty = case tyConAppTyCon_maybe ty of 
    825826isIPPred ty = case tyConAppTyCon_maybe ty of
    826827    Just tyCon | Just _ <- tyConIP_maybe tyCon -> True
    827828    _                                          -> False
     829isHolePred ty = case tyConAppTyCon_maybe ty of
     830    Just tycon | Just _ <- tyConHole_maybe tycon -> True
     831    _ -> False
    828832\end{code}
    829833
    830834Make PredTypes
    mkIPPred :: IPName Name -> Type -> PredType 
    856860mkIPPred ip ty = TyConApp (ipTyCon ip) [ty]
    857861\end{code}
    858862
     863\begin{code}
     864mkHolePred :: HoleName Name -> Type -> PredType
     865mkHolePred name ty = TyConApp (holeTyCon name) [ty]
     866
     867holeTyCon :: HoleName Name -> TyCon
     868holeTyCon name = case wiredInNameTyThing_maybe $ holeNameName name of
     869    Just (ATyCon tc) -> tc
     870    _                -> pprPanic "holeTyCon" (ppr name)
     871\end{code}
     872
    859873--------------------- Dictionary types ---------------------------------
    860874\begin{code}
    861875mkClassPred :: Class -> [Type] -> PredType
    data PredTree = ClassPred Class [Type] 
    911925              | IPPred (IPName Name) Type
    912926              | TuplePred [PredType]
    913927              | IrredPred PredType
     928              | HolePred (HoleName Name) Type
    914929
    915930predTreePredType :: PredTree -> PredType
    916931predTreePredType (ClassPred clas tys) = mkClassPred clas tys
    classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of 
    931946                   -> IPPred ip ty
    932947    Just (tc, tys) | isTupleTyCon tc
    933948                   -> TuplePred tys
     949    Just (tc, tys) | Just name <- tyConHole_maybe tc
     950                   , let [ty] = tys
     951                   -> HolePred name ty
    934952    _ -> IrredPred ev_ty
    935953\end{code}
    936954