Ticket #5910: patch.diff

File patch.diff, 45.6 KB (added by xnyhps, 2 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