Ticket #5910: patch3.diff

File patch3.diff, 50.5 KB (added by xnyhps, 14 months ago)

  • compiler/basicTypes/BasicTypes.lhs 

    diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index c6226ca..f822ea8 100644
    a b  
    4040        compareFixity, 
    4141 
    4242        IPName(..), ipNameName, mapIPName, 
     43  HoleName(..), holeNameName, mapHoleName, 
    4344 
    4445        RecFlag(..), isRec, isNonRec, boolToRecFlag, 
    4546 
    … …  
    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) = text "_?" <> ppr n 
     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  
    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  
    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 d31c774..becb480 100644
    a b  
    231231 
    232232dsExpr (HsApp fun arg) 
    233233  = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg 
     234 
     235dsExpr (HsHole nm) 
     236  = return (Var $ holeNameName nm) 
    234237\end{code} 
    235238 
    236239Note [Desugaring vars] 

  • compiler/hsSyn/HsExpr.lhs 

    diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 08d1281..90b9f59 100644
    a b  
    290290 
    291291  |  HsWrap     HsWrapper    -- TRANSLATION 
    292292                (HsExpr id) 
     293  |  HsHole     (HoleName id) 
    293294  deriving (Data, Typeable) 
    294295 
    295296-- HsTupArg is used for tuple sections 
    … …  
    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  
    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 
    … …  
    4242import SrcLoc 
    4343import BasicTypes 
    4444 
     45import TysPrim 
     46import TysWiredIn 
     47import Coercion 
     48 
    4549import Outputable 
    4650import Exception     ( evaluate ) 
    4751 
    … …  
    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 
    … …  
    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 e55d78e..4974429 100644
    a b  
    17561756                -- ^ Supply of uniques 
    17571757                nsNames :: OrigNameCache, 
    17581758                -- ^ Ensures that one original name gets one unique 
    1759                 nsIPs   :: OrigIParamCache 
     1759                nsIPs   :: OrigIParamCache, 
    17601760                -- ^ Ensures that one implicit parameter name gets one unique 
     1761                nsHoles :: OrigHoleCache 
    17611762   } 
    17621763 
    17631764-- | Per-module cache of original 'OccName's given 'Name's 
    … …  
    17651766 
    17661767-- | Module-local cache of implicit parameter 'OccName's given 'Name's 
    17671768type OrigIParamCache = Map FastString (IPName Name) 
     1769 
     1770type OrigHoleCache = Map FastString (HoleName Name) 
    17681771\end{code} 
    17691772 
    17701773 

  • compiler/main/InteractiveEval.hs 

    diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 8cc94a3..fde4843 100644
    a b  
    927927exprType :: GhcMonad m => String -> m Type 
    928928exprType expr = withSession $ \hsc_env -> do 
    929929   ty <- liftIO $ hscTcExpr hsc_env expr 
    930    return $ tidyType emptyTidyEnv ty 
     930   return {-$ tidyType emptyTidyEnv-} ty 
    931931 
    932932-- ----------------------------------------------------------------------------- 
    933933-- Getting the kind of a type 

  • compiler/parser/Lexer.x 

    diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 378a25c..4e6b29d 100644
    a b  
    344344         { token ITcubxparen } 
    345345} 
    346346 
     347<0> { 
     348  \_\? @varid { skip_two_varid IThole } 
     349} 
     350 
    347351<0,option_prags> { 
    348352  \(                                    { special IToparen } 
    349353  \)                                    { special ITcparen } 
    … …  
    544548  | ITprefixqconsym (FastString,FastString) 
    545549 
    546550  | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x 
     551  | IThole         FastString 
    547552 
    548553  | ITchar       Char 
    549554  | ITstring     FastString 
    … …  
    729734skip_one_varid f span buf len 
    730735  = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) 
    731736 
     737skip_two_varid :: (FastString -> Token) -> Action 
     738skip_two_varid f span buf len 
     739  = return (L span $! f (lexemeToFastString (stepOn $ stepOn buf) (len-2))) 
     740 
    732741strtoken :: (String -> Token) -> Action 
    733742strtoken f span buf len = 
    734743  return (L span $! (f $! lexemeToString buf len)) 

  • compiler/parser/Parser.y.pp 

    diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index fc6a950..81ca98a 100644
    a b  
    322322 PREFIXQCONSYM  { L _ (ITprefixqconsym  _) } 
    323323 
    324324 IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension 
     325 HOLEVARID      { L _ (IThole     _) } 
    325326 
    326327 CHAR           { L _ (ITchar     _) } 
    327328 STRING         { L _ (ITstring   _) } 
    … …  
    14511452 
    14521453aexp2   :: { LHsExpr RdrName } 
    14531454        : ipvar                         { L1 (HsIPVar $! unLoc $1) } 
     1455        | hole                          { L1 (HsHole  $! unLoc $1) } 
    14541456        | qcname                        { L1 (HsVar   $! unLoc $1) } 
    14551457        | literal                       { L1 (HsLit   $! unLoc $1) } 
    14561458-- This will enable overloaded strings permanently.  Normally the renamer turns HsString 
    … …  
    17651767ipvar   :: { Located (IPName RdrName) } 
    17661768        : IPDUPVARID            { L1 (IPName (mkUnqual varName (getIPDUPVARID $1))) } 
    17671769 
     1770hole    :: { Located (HoleName RdrName) } 
     1771        : HOLEVARID             { L1 (HoleName (mkUnqual varName $ getHOLEVARID $1)) } 
     1772 
    17681773----------------------------------------------------------------------------- 
    17691774-- Warnings and deprecations 
    17701775 
    … …  
    20822087getPREFIXQVARSYM (L _ (ITprefixqvarsym  x)) = x 
    20832088getPREFIXQCONSYM (L _ (ITprefixqconsym  x)) = x 
    20842089getIPDUPVARID   (L _ (ITdupipvarid   x)) = x 
     2090getHOLEVARID    (L _ (IThole     x)) = x 
    20852091getCHAR         (L _ (ITchar     x)) = x 
    20862092getSTRING       (L _ (ITstring   x)) = x 
    20872093getINTEGER      (L _ (ITinteger  x)) = x 

  • compiler/prelude/TysWiredIn.lhs 

    diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 4b7f043..5718aaf 100644
    a b  
    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" 
    … …  
    9597import TypeRep 
    9698import RdrName 
    9799import Name 
    98 import BasicTypes       ( TupleSort(..), tupleSortBoxity, IPName(..),  
     100import BasicTypes       ( TupleSort(..), tupleSortBoxity, IPName(..), HoleName(..), 
    99101                          Arity, RecFlag(..), Boxity(..), HsBang(..) ) 
    100102import ForeignCall 
    101103import Unique           ( incrUnique, mkTupleTyConUnique, 
    … …  
    428430    co_ax_name = mkPrimTyConName ip co_ax_u tycon 
    429431\end{code} 
    430432 
     433\begin{code} 
     434mkHoleName :: FastString 
     435         -> Unique -> Unique -> Unique -> Unique 
     436         -> HoleName Name 
     437mkHoleName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_hole 
     438  where 
     439    name_hole = HoleName tycon_name 
     440 
     441    tycon_name = mkPrimTyConName ip tycon_u tycon 
     442    tycon      = mkAlgTyCon tycon_name 
     443                   (liftedTypeKind `mkArrowKind` constraintKind) 
     444                   [alphaTyVar] 
     445                   Nothing 
     446                   []      -- No stupid theta 
     447                   (NewTyCon { data_con    = datacon,  
     448                               nt_rhs      = mkTyVarTy alphaTyVar, 
     449                               nt_etad_rhs = ([alphaTyVar], mkTyVarTy alphaTyVar), 
     450                               nt_co       = mkNewTypeCo co_ax_name tycon [alphaTyVar] (mkTyVarTy alphaTyVar) }) 
     451                   (HoleTyCon name_hole) 
     452                   NonRecursive 
     453                   False 
     454 
     455    datacon_name = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "IPBox") datacon_u datacon 
     456    datacon      = pcDataCon' datacon_name dc_wrk_u [alphaTyVar] [mkTyVarTy alphaTyVar] tycon 
     457 
     458    co_ax_name = mkPrimTyConName ip co_ax_u tycon 
     459\end{code} 
     460 
    431461%************************************************************************ 
    432462%*                                                                      * 
    433463\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 b884d4a..27d154b 100644
    a b  
    3434import TcRnMonad 
    3535import TcEnv            ( thRnBrack ) 
    3636import RnEnv 
    37 import RnTypes   
     37import RnTypes 
    3838import RnPat 
    3939import DynFlags 
    4040import BasicTypes       ( FixityDirection(..) ) 
    … …  
    292292rnExpr (PArrSeq _ seq) 
    293293  = rnArithSeq seq       `thenM` \ (new_seq, fvs) -> 
    294294    return (PArrSeq noPostTcExpr new_seq, fvs) 
     295 
     296rnExpr (HsHole name) 
     297  = do { name' <- rnHoleName name 
     298       ; return (HsHole name', emptyFVs) 
     299       } 
    295300\end{code} 
    296301 
    297302These three are pattern syntax appearing in expressions. 

  • compiler/rename/RnTypes.lhs 

    diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 2c5a5a5..c954f8b 100644
    a b  
    1212-- for details 
    1313 
    1414module RnTypes (  
    15         -- Type related stuff 
    16         rnHsType, rnLHsType, rnLHsTypes, rnContext, 
     15        -- Type related stuff 
     16        rnHsType, rnLHsType, rnLHsTypes, rnContext, 
    1717        rnHsKind, rnLHsKind, rnLHsMaybeKind, 
    18         rnHsSigType, rnLHsInstType, rnConDeclFields, 
    19         rnIPName, 
     18        rnHsSigType, rnLHsInstType, rnConDeclFields, 
     19        rnIPName, rnHoleName, 
    2020 
    2121        -- Precence related stuff 
    2222        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, 
    … …  
    4040import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc ) 
    4141import RnEnv 
    4242import TcRnMonad 
    43 import IfaceEnv         ( newIPName ) 
     43import IfaceEnv         ( newIPName, newHoleName ) 
    4444import RdrName 
    4545import PrelNames 
    4646import TysPrim          ( funTyConName ) 
    … …  
    5050 
    5151import Util             ( filterOut ) 
    5252import BasicTypes       ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFixity,  
    53                           Fixity(..), FixityDirection(..) ) 
     53                          Fixity(..), FixityDirection(..), HoleName(..), holeNameName ) 
    5454import Outputable 
    5555import FastString 
    5656import Control.Monad    ( unless ) 
    … …  
    480480rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n))) 
    481481\end{code} 
    482482 
     483\begin{code} 
     484rnHoleName :: HoleName RdrName -> RnM (HoleName Name) 
     485rnHoleName n = newHoleName (occNameFS (rdrNameOcc (holeNameName n))) 
     486\end{code} 
     487 
    483488 
    484489%************************************************************************ 
    485490%*                                                                      * 

  • compiler/typecheck/Inst.lhs 

    diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index ffaeac8..4f5a000 100644
    a b  
    518518    has_eq' (ClassPred cls _tys) = any has_eq (classSCTheta cls) 
    519519    has_eq' (TuplePred ts)       = any has_eq ts 
    520520    has_eq' (IrredPred _)        = True -- Might have equalities in it after reduction? 
     521    has_eq' (HolePred {})        = False 
    521522 
    522523---------------- Getting free tyvars ------------------------- 
    523524 
    … …  
    528529tyVarsOfCt (CIPCan { cc_ip_ty = ty })                   = tyVarsOfType ty 
    529530tyVarsOfCt (CIrredEvCan { cc_ty = ty })                 = tyVarsOfType ty 
    530531tyVarsOfCt (CNonCanonical { cc_flavor = fl })           = tyVarsOfType (ctFlavPred fl) 
     532tyVarsOfCt (CHoleCan { cc_hole_ty = ty })               = tyVarsOfType ty 
    531533 
    532534tyVarsOfCDict :: Ct -> TcTyVarSet  
    533535tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys 

  • compiler/typecheck/TcCanonical.lhs 

    diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index b24f76c..eb0a752 100644
    a b  
    1313 
    1414#include "HsVersions.h" 
    1515 
    16 import BasicTypes ( IPName ) 
     16import BasicTypes ( IPName, HoleName ) 
    1717import TcErrors 
    1818import TcRnTypes 
    1919import TcType 
    … …  
    206206                          , cc_depth = d 
    207207                          , cc_ty = xi }) 
    208208  = canIrred d fl xi 
    209  
     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 nm xi 
    210214 
    211215canEvVar :: SubGoalDepth  
    212216         -> CtFlavor  
    … …  
    220224      IPPred nm ty      -> canIP      d fl nm ty 
    221225      IrredPred ev_ty   -> canIrred   d fl ev_ty 
    222226      TuplePred tys     -> canTuple   d fl tys 
     227      HolePred name ty  -> canHole    d fl name ty 
    223228\end{code} 
    224229 
    225230 
    … …  
    280285class constraints for the same class MAY be equal, so they need to be 
    281286flattened in the first place to facilitate comparing them.) 
    282287 
     288\begin{code} 
     289canHole :: SubGoalDepth -- Depth  
     290      -> CtFlavor 
     291      -> HoleName Name -> Type -> TcS StopOrContinue 
     292canHole d fl nm ty 
     293  = do { (xi,co) <- flatten d fl (mkHolePred nm ty) 
     294       ; mb <- rewriteCtFlavor fl xi co  
     295       ; case mb of 
     296            Just new_fl -> let HolePred _ xi_in = classifyPredType xi 
     297                           in continueWith $ CHoleCan { cc_flavor = new_fl 
     298                                                      , cc_hole_nm = nm, cc_hole_ty = xi_in 
     299                                                      , cc_depth = d } 
     300            Nothing -> return Stop } 
     301\end{code} 
     302 
    283303%************************************************************************ 
    284304%*                                                                      * 
    285305%*                      Class Canonicalization 

  • compiler/typecheck/TcErrors.lhs 

    diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 0fcd0d4..9bcb455 100644
    a b  
    7171         wanted  <- zonkWC wanted 
    7272 
    7373       ; env0 <- tcInitTidyEnv 
    74        ; defer <- if runtimeCoercionErrors  
    75                   then do { ev <- newTcEvBinds 
    76                           ; return (Just ev) } 
    77                   else return Nothing 
     74       ; defer <- newTcEvBinds -- if runtimeCoercionErrors  
     75                  -- then do { ev <- newTcEvBinds 
     76                  --        ; return (Just ev) } 
     77                  -- else return Nothing 
    7878 
    7979       ; errs_so_far <- ifErrsM (return True) (return False) 
    8080       ; let tidy_env = tidyFreeTyVars env0 free_tvs 
    … …  
    8383                            , cec_insol = errs_so_far 
    8484                            , cec_extra = empty 
    8585                            , cec_tidy  = tidy_env 
    86                             , cec_defer = defer } 
     86                            , cec_defer = Just defer } 
    8787 
    8888       ; traceTc "reportUnsolved" (ppr free_tvs $$ ppr wanted) 
    8989 
    9090       ; reportWanteds err_ctxt wanted 
    9191 
    92        ; case defer of 
    93            Nothing -> return emptyBag 
    94            Just ev -> getTcEvBinds ev } 
     92       ; getTcEvBinds defer } 
    9593 
    9694-------------------------------------------- 
    9795--      Internal functions 
    … …  
    144142 
    145143reportTidyWanteds :: ReportErrCtxt -> Bag Ct -> Bag Ct -> Bag Implication -> TcM () 
    146144reportTidyWanteds ctxt insols flats implics 
    147   | Just ev_binds_var <- cec_defer ctxt 
    148   = do { -- Defer errors to runtime 
    149          -- See Note [Deferring coercion errors to runtime] in TcSimplify 
    150          mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr)  
    151                   (flats `unionBags` insols) 
    152        ; mapBagM_ (reportImplic ctxt) implics } 
    153  
    154   | otherwise 
    155   = do { reportInsolsAndFlats ctxt insols flats 
    156        ; mapBagM_ (reportImplic ctxt) implics } 
     145  = do { 
     146     ; let Just ev_binds_var = cec_defer ctxt 
     147     ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors 
     148     ; if runtimeCoercionErrors then  
     149       do { -- Defer errors to runtime 
     150             -- See Note [Deferring coercion errors to runtime] in TcSimplify 
     151             mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr)  
     152                      (flats `unionBags` insols) 
     153           ; mapBagM_ (reportImplic ctxt) implics 
     154          } 
     155       else  
     156       do { 
     157            ; traceTc "reportTidyWanteds" (ppr (filterBag (isHole) (flats `unionBags` insols))) 
     158            ; mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) 
     159                       (filterBag isHole (flats `unionBags` insols)) 
     160            ; reportInsolsAndFlats ctxt (filterBag (not.isHole) insols) (filterBag (not.isHole) flats) 
     161            ; mapBagM_ (reportImplic ctxt) implics 
     162          } 
     163     } 
     164       where isHole ct = case classifyPredType (ctPred ct) of 
     165                            HolePred {} -> True 
     166                            _           -> False 
    157167              
    158168 
    159169deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg)  
    … …  
    261271      IPPred {}     -> mkIPErr    ctxt [ct] 
    262272      IrredPred {}  -> mkIrredErr ctxt [ct] 
    263273      EqPred {}     -> mkEqErr1 ctxt ct 
     274      HolePred {}   -> mkHoleErr  ctxt [ct] 
    264275      TuplePred {}  -> panic "mkFlat" 
    265276       
    266277reportAmbigErrs :: ReportErrCtxt -> Reporter 
    … …  
    278289reportFlatErrs ctxt cts 
    279290  = tryReporters 
    280291      [ ("Equalities", is_equality, groupErrs (mkEqErr ctxt)) ] 
    281       (\cts -> do { let (dicts, ips, irreds) = go cts [] [] [] 
     292      (\cts -> do { let (dicts, ips, irreds, holes) = go cts [] [] [] [] 
    282293                  ; groupErrs (mkIPErr    ctxt) ips    
    283294                  ; groupErrs (mkIrredErr ctxt) irreds 
     295                  ; groupErrs (mkHoleErr  ctxt) holes 
    284296                  ; groupErrs (mkDictErr  ctxt) dicts }) 
    285297      cts 
    286298  where 
    287299    is_equality _ (EqPred {}) = True 
    288300    is_equality _ _           = False 
    289301 
    290     go [] dicts ips irreds 
    291       = (dicts, ips, irreds) 
    292     go (ct:cts) dicts ips irreds 
     302    go [] dicts ips irreds holes 
     303      = (dicts, ips, irreds, holes) 
     304    go (ct:cts) dicts ips irreds holes 
    293305      = case classifyPredType (ctPred ct) of 
    294           ClassPred {}  -> go cts (ct:dicts) ips irreds 
    295           IPPred {}     -> go cts dicts (ct:ips) irreds 
    296           IrredPred {}  -> go cts dicts ips (ct:irreds) 
     306          ClassPred {}  -> go cts (ct:dicts) ips irreds holes 
     307          IPPred {}     -> go cts dicts (ct:ips) irreds holes 
     308          IrredPred {}  -> go cts dicts ips (ct:irreds) holes 
     309          HolePred {}   -> go cts dicts ips irreds (ct:holes) 
    297310          _             -> panic "mkFlat" 
    298311    -- TuplePreds should have been expanded away by the constraint 
    299312    -- simplifier, so they shouldn't show up at this point 
    … …  
    384397    msg = couldNotDeduce givens (map ctPred cts, orig) 
    385398\end{code} 
    386399 
     400\begin{code} 
     401mkHoleErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg 
     402mkHoleErr ctxt cts 
     403  = mkErrorReport ctxt msg 
     404  where 
     405    (ct1:_) = cts 
     406    orig    = ctLocOrigin (ctWantedLoc ct1) 
     407    preds   = map ctPred cts 
     408    msg = foundAHole preds 
     409 
     410foundAHole :: ThetaType -> SDoc 
     411foundAHole [TyConApp nm [ty]] = (text "Found hole _?") <> ppr nm <+> (text "with type") <+> ppr ty 
     412\end{code} 
    387413 
    388414%************************************************************************ 
    389415%*                                                                      * 

  • compiler/typecheck/TcExpr.lhs 

    diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 488e654..9cc7a0b 100644
    a b  
    6363import Outputable 
    6464import FastString 
    6565import Control.Monad 
     66 
     67import TypeRep 
     68import qualified Data.Map as Map 
    6669\end{code} 
    6770 
    6871%************************************************************************ 
    … …  
    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--------------- 
    … …  
    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       ; ty <- newFlexiTyVarTy liftedTypeKind 
     225        
     226       -- Emit the constraint 
     227       ; var <- emitWanted origin (mkHolePred name ty) 
     228       ; traceTc "tcExpr.HsHole: Creating new ty for hole" (ppr ty) 
     229 
     230       ; tcWrapResult (HsHole $ HoleName var) ty res_ty } 
    217231\end{code} 
    218232 
    219233 

  • compiler/typecheck/TcHsSyn.lhs 

    diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 75dedd0..2c82808 100644
    a b  
    701701    zonkExpr env1 expr  `thenM` \ new_expr -> 
    702702    return (HsWrap new_co_fn new_expr) 
    703703 
     704zonkExpr env h@(HsHole nm) 
     705  = do { 
     706    traceTc "zonkExpr.HsHole" (ppr h); 
     707    return (HsHole nm) 
     708    } 
     709 
    704710zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) 
    705711 
    706712zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id) 
    … …  
    13051311                  -- ty is actually a kind, zonk to AnyK 
    13061312                  then anyKind 
    13071313                  else anyTypeOfKind (defaultKind (tyVarKind tv)) 
     1314       ; traceTc "zonkTypeZapping" (ppr tv) 
    13081315       ; writeMetaTyVar tv ty 
    13091316       ; return ty } 
    13101317 

  • compiler/typecheck/TcInteract.lhs 

    diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 01dcda8..8818fd5 100644
    a b  
    5959import UniqFM 
    6060import FastString ( sLit )  
    6161import DynFlags 
     62 
     63import Control.Monad 
     64import Type 
    6265\end{code} 
    6366********************************************************************** 
    6467*                                                                    *  
    … …  
    375378                                      , inert_dicts  = dictmap 
    376379                                      , inert_ips    = ipmap 
    377380                                      , inert_funeqs = funeqmap 
    378                                       , inert_irreds = irreds } 
     381                                      , inert_irreds = irreds 
     382                                      , inert_holes  = holemap } 
    379383                              , inert_frozen = frozen }) 
    380384  = ((kicked_out,eqmap), remaining) 
    381385  where 
    382386    rest_out = fro_out `andCts` dicts_out  
    383                    `andCts` ips_out `andCts` irs_out 
     387                   `andCts` ips_out `andCts` irs_out `andCts` holes_out 
    384388    kicked_out = WorkList { wl_eqs    = [] 
    385389                          , wl_funeqs = bagToList feqs_out 
    386390                          , wl_rest   = bagToList rest_out } 
    … …  
    391395                                     , inert_dicts = dicts_in 
    392396                                     , inert_ips = ips_in 
    393397                                     , inert_funeqs = feqs_in 
    394                                      , inert_irreds = irs_in } 
     398                                     , inert_irreds = irs_in 
     399                                     , inert_holes = holes_in } 
    395400                   , inert_frozen = fro_in }  
    396401                -- NB: Notice that don't rewrite  
    397402                -- inert_solved, inert_flat_cache and inert_solved_funeqs 
    … …  
    401406    tv = cc_tyvar ct 
    402407                                
    403408    (ips_out,   ips_in)     = partitionCCanMap rewritable ipmap 
     409    (holes_out, holes_in)   = partitionCCanMap rewritable holemap 
    404410 
    405411    (feqs_out,  feqs_in)    = partCtFamHeadMap rewritable funeqmap 
    406412    (dicts_out, dicts_in)   = partitionCCanMap rewritable dictmap 
    … …  
    657663    | IRInertConsumed    { ir_fire :: String }  
    658664    | IRKeepGoing        { ir_fire :: String } 
    659665 
     666 
     667instance Outputable InteractResult where 
     668  ppr (IRWorkItemConsumed str) = ptext (sLit "IRWorkItemConsumed ") <+> text str 
     669  ppr (IRInertConsumed str) = ptext (sLit "IRInertConsumed ") <+> text str 
     670  ppr (IRKeepGoing str) = ptext (sLit "IRKeepGoing ") <+> text str 
     671 
    660672irWorkItemConsumed :: String -> TcS InteractResult 
    661673irWorkItemConsumed str = return (IRWorkItemConsumed str)  
    662674 
    … …  
    684696              ; foldlBagM interact_next (ContinueWith wi) rels } } 
    685697 
    686698  where interact_next Stop atomic_inert  
    687           = updInertSetTcS atomic_inert >> return Stop 
     699          = trace "interact_next Stop" $ updInertSetTcS atomic_inert >> return Stop 
    688700        interact_next (ContinueWith wi) atomic_inert  
    689701          = do { ir <- doInteractWithInert atomic_inert wi 
    690702               ; let mk_msg rule keep_doc  
    … …  
    836848          | Wanted wl _  <- ifl = wl 
    837849          | Derived wl _ <- ifl = wl 
    838850          | otherwise = panic "Solve IP: no WantedLoc!" 
     851 
     852doInteractWithInert (CHoleCan id1 fl1 nm1 ty1 d1) workitem@(CHoleCan id2 fl2 nm2 ty2 d2) 
     853  | nm1 == nm2 && isGivenOrSolved fl2 && isGivenOrSolved fl1 
     854  = irInertConsumed "Hole/Hole (override inert)" 
     855  | nm1 == nm2 && ty1 `eqType` ty2  
     856  = solveOneFromTheOther "Hole/Hole" fl1 workitem 
     857 
     858  | nm1 == nm2 
     859  = do { mb_eqv <- newWantedEvVar (mkEqPred ty2 ty1) 
     860         -- co :: ty2 ~ ty1, see Note [Efficient orientation] 
     861       ; cv <- case mb_eqv of 
     862                 Fresh eqv  ->  
     863                   do { updWorkListTcS $ extendWorkListEq $  
     864                        CNonCanonical { cc_flavor = Wanted new_wloc eqv 
     865                                      , cc_depth = cc_depth workitem } 
     866                      ; return eqv } 
     867                 Cached eqv -> return eqv 
     868       ; case fl2 of 
     869            Wanted  {} -> 
     870              let hole_co = mkTcTyConAppCo (holeTyCon nm1) [mkTcCoVarCo cv] 
     871              in do { setEvBind (ctId workitem) $ 
     872                      mkEvCast (flav_evar fl1) (mkTcSymCo hole_co) 
     873                    ; irWorkItemConsumed "Hole/Hole (solved by rewriting)" } 
     874            _ -> pprPanic "Unexpected Hole constraint" (ppr workitem) } 
     875  where new_wloc 
     876          | Wanted wl _  <- fl2 = wl 
     877          | Derived wl _ <- fl2 = wl 
     878          | Wanted wl _  <- fl1 = wl 
     879          | Derived wl _ <- fl1 = wl 
     880          | otherwise = panic "Solve Hole: no WantedLoc!" 
    839881     
    840882 
    841883doInteractWithInert ii@(CFunEqCan { cc_flavor = fl1, cc_fun = tc1 

  • compiler/typecheck/TcMType.lhs 

    diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index a8460af..afb677b 100644
    a b  
    171171predTypeOccName ty = case classifyPredType ty of 
    172172    ClassPred cls _ -> mkDictOcc (getOccName cls) 
    173173    IPPred ip _     -> mkVarOccFS (ipFastString ip) 
     174    HolePred name _ -> mkVarOccFS (occNameFS $ nameOccName $ holeNameName name) 
    174175    EqPred _ _      -> mkVarOccFS (fsLit "cobox") 
    175176    TuplePred _     -> mkVarOccFS (fsLit "tup") 
    176177    IrredPred _     -> mkVarOccFS (fsLit "irred") 
    … …  
    14461447    go (EqPred ty1 ty2)  = grow (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2) 
    14471448    go (TuplePred ts)    = unionVarSets (map (go . classifyPredType) ts) 
    14481449    go (IrredPred ty)    = grow (tyVarsOfType ty) 
     1450    go (HolePred _ ty)   = tyVarsOfType ty 
    14491451\end{code} 
    14501452     
    14511453Note [Implicit parameters and ambiguity]  

  • compiler/typecheck/TcRnDriver.lhs 

    diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 0128f18..5649619 100644
    a b  
    4040import TcAnnotations 
    4141import TcBinds 
    4242import HeaderInfo       ( mkPrelImports ) 
    43 import TcType   ( tidyTopType ) 
     43import TcType   ( tidyTopType, tidyType ) 
    4444import TcDefaults 
    4545import TcEnv 
    4646import TcRules 
    … …  
    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 
    … …  
    431436                        simplifyTop lie ; 
    432437        traceTc "Tc9" empty ; 
    433438 
     439        traceRn (text "tcRnSrcDecls:" <+> (ppr lie)) ; 
     440 
    434441        failIfErrsM ;   -- Don't zonk if there have been errors 
    435442                        -- It's a waste of time; and we may get debug warnings 
    436443                        -- about strangely-typed TyCons! 
    … …  
    463470        setGlobalTypeEnv tcg_env' final_type_env 
    464471   } } 
    465472 
     473-- where 
     474 
    466475tc_rn_src_decls :: ModDetails 
    467476                    -> [LHsDecl RdrName] 
    468477                    -> TcM (TcGblEnv, TcLclEnv) 
    … …  
    14311440        -- it might have a rank-2 type (e.g. :t runST) 
    14321441    uniq <- newUnique ; 
    14331442    let { fresh_it  = itName uniq (getLoc rdr_expr) } ; 
    1434     ((_tc_expr, res_ty), lie)   <- captureConstraints (tcInferRho rn_expr) ; 
    1435     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ 
     1443    ((_tc_expr, res_ty), lie)   <- captureConstraints (tcInferRho rn_expr) ; 
     1444 
     1445 
     1446    (g, l) <- getEnvs ; 
     1447 
     1448    ((qtvs, dicts, _, _), lie_top) <- captureConstraints $  
    14361449                                      {-# SCC "simplifyInfer" #-} 
    14371450                                      simplifyInfer True {- Free vars are closed -} 
    14381451                                                    False {- No MR for now -} 
    1439                                                     [(fresh_it, res_ty)] 
     1452                                                    ([(fresh_it, res_ty)]) -- ++ (map (\(nm,(ty,_)) -> (holeNameName nm, ty)) $ Map.toList holes)) 
    14401453                                                    lie  ; 
     1454        let { (holes, dicts') = splitEvs dicts [] [] } ; 
     1455     
     1456    traceRn (text "tcRnExpr1:" <+> (ppr holes <+> ppr dicts')) ; 
     1457 
    14411458    _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings 
     1459     
     1460    traceRn (text "tcRnExpr2:" <+> (ppr lie_top)) ; 
     1461 
     1462    let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts' res_ty) } ; 
     1463    result <- zonkTcType all_expr_ty ; 
     1464 
    14421465 
    1443     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; 
    1444     zonkTcType all_expr_ty 
     1466    zonked_holes <- zonkHoles $ map (apsnd (mkForAllTys qtvs) . apsnd (mkPiTypes dicts') . unwrapHole . varType) $ holes ; 
     1467 
     1468    let { (env, tidied_holes) = apsnd (map (apsnd split)) $ foldr tidy (emptyTidyEnv, []) zonked_holes } ; 
     1469 
     1470    liftIO $ putStrLn $ showSDoc ((ptext $ sLit "Found the following holes: ") 
     1471                                $+$ (vcat $ map (\(nm, ty) -> text "_?" <> ppr nm <+> colon <> colon <+> ppr ty) tidied_holes)); 
     1472 
     1473    return $ snd $ tidyOpenType env result 
    14451474    } 
     1475    where tidy (nm, ty) (env, tys) = let (env', ty') = tidyOpenType env ty 
     1476                                     in (env', (nm, ty') : tys) 
     1477 
     1478          split t = let (_, ctxt, ty') = tcSplitSigmaTy $ tidyTopType t 
     1479                    in mkPhiTy ctxt ty' 
     1480 
     1481          splitEvs [] hls dcts = (hls, dcts) 
     1482          splitEvs (evvar:xs) hls dcts = case classifyPredType $ varType evvar of 
     1483                                                                                HolePred {} -> splitEvs xs (evvar:hls) dcts 
     1484                                                                                _ -> splitEvs xs hls (evvar:dcts) 
     1485          -- unwrap what was wrapped in mkHolePred 
     1486          unwrapHole (TyConApp nm [ty]) = (nm, ty) 
     1487 
     1488          -- zonk the holes, but keep the name 
     1489          zonkHoles = mapM (\(nm, ty) -> liftM (\t -> (nm, t)) $ zonkTcType ty) 
     1490 
     1491          apsnd f (a, b) = (a, f b) 
     1492 
     1493          f (_, b) = let (Just (ATyCon tc)) = wiredInNameTyThing_maybe b 
     1494                         (Just (_, ty, _)) = trace ("unwrapNewTyCon_maybe" ++ (showSDoc $ ppr tc)) $ unwrapNewTyCon_maybe tc 
     1495                                 in (b, ty) 
    14461496 
    14471497-------------------------- 
    14481498tcRnImportDecls :: HscEnv 

  • compiler/typecheck/TcRnMonad.lhs 

    diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 0d20be2..77c78b7 100644
    a b  
    5353import Data.IORef 
    5454import qualified Data.Set as Set 
    5555import Control.Monad 
     56 
     57import qualified Data.Map as Map 
    5658\end{code} 
    5759 
    5860 
    … …  
    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 } ; 

  • compiler/typecheck/TcRnTypes.lhs 

    diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index f480bab..c928fda 100644
    a b  
    5454        Xi, Ct(..), Cts, emptyCts, andCts, andManyCts,  
    5555        singleCt, extendCts, isEmptyCts, isCTyEqCan, isCFunEqCan, 
    5656        isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, 
     57        isCHoleCan_Maybe, isCHoleCan, 
    5758        isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,  
    5859        isGivenCt, isGivenOrSolvedCt, 
    5960        ctWantedLoc, 
    6061        SubGoalDepth, mkNonCanonical, ctPred, ctFlavPred, ctId, ctFlavId, 
    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, 
    … …  
    122123 
    123124import Data.Set (Set) 
    124125 
     126import UniqSet 
     127import qualified Data.Map as Map 
    125128\end{code} 
    126129 
    127130 
    … …  
    901904      cc_depth  :: SubGoalDepth 
    902905    } 
    903906 
     907  | CHoleCan { 
     908      cc_id       :: EvVar, 
     909      cc_flavor   :: CtFlavor, 
     910      cc_hole_nm  :: HoleName Name, 
     911      cc_hole_ty  :: TcTauType, -- Not a Xi! See same not as above 
     912      cc_depth    :: SubGoalDepth        -- See Note [WorkList] 
     913    } 
     914 
    904915\end{code} 
    905916 
    906917\begin{code} 
    … …  
    918929ctPred (CIPCan { cc_ip_nm = nm, cc_ip_ty = xi })  
    919930  = mkIPPred nm xi 
    920931ctPred (CIrredEvCan { cc_ty = xi }) = xi 
    921  
     932ctPred (CHoleCan { cc_hole_nm = nm, cc_hole_ty = xi}) 
     933  = mkHolePred nm xi 
    922934 
    923935ctId :: Ct -> EvVar 
    924936-- Precondition: not a derived! 
    925937ctId ct = ctFlavId (cc_flavor ct) 
    926  
    927938\end{code} 
    928939 
    929940 
    … …  
    980991isCNonCanonical :: Ct -> Bool 
    981992isCNonCanonical (CNonCanonical {}) = True  
    982993isCNonCanonical _ = 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 
    9831002\end{code} 
    9841003 
    9851004\begin{code} 
    … …  
    9931012                           CDictCan {}      -> "CDictCan" 
    9941013                           CIPCan {}        -> "CIPCan" 
    9951014                           CIrredEvCan {}   -> "CIrredEvCan" 
     1015                           CHoleCan {}          -> "CHoleCan" 
    9961016\end{code} 
    9971017 
    9981018\begin{code} 
    … …  
    10591079       , wc_impl  = i1 `unionBags` i2 
    10601080       , wc_insol = n1 `unionBags` n2 } 
    10611081 
     1082unionsWC :: [WantedConstraints] -> WantedConstraints 
     1083unionsWC = foldr andWC emptyWC 
     1084 
    10621085addFlats :: WantedConstraints -> Bag Ct -> WantedConstraints 
    10631086addFlats wc cts 
    10641087  = 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 33a049e..9696651 100644
    a b  
    285285                         , cts_wanted  :: UniqFM Cts }  
    286286                                          -- Invariant: all Wanted 
    287287 
     288instance Outputable (CCanMap a) where 
     289  ppr (CCanMap given derived wanted) = ptext (sLit "CCanMap") <+> (ppr given) <+> (ppr derived) <+> (ppr wanted) 
     290 
    288291cCanMapToBag :: CCanMap a -> Cts  
    289292cCanMapToBag cmap = foldUFM unionBags rest_wder (cts_given cmap) 
    290293  where rest_wder = foldUFM unionBags rest_der  (cts_wanted cmap)  
    … …  
    355358  in (wntd `unionBags` derd,  
    356359      cmap { cts_wanted = emptyUFM, cts_derived = emptyUFM }) 
    357360 
    358  
    359361-- Maps from PredTypes to Constraints 
    360362type CtTypeMap = TypeMap Ct 
    361363newtype CtPredMap =  
    … …  
    421423              -- Family equations, index is the whole family head type. 
    422424       , inert_irreds :: Cts        
    423425              -- Irreducible predicates 
     426       , inert_holes :: CCanMap (HoleName Name) 
    424427       } 
    425428     
    426429                      
    … …  
    497500                 , vcat (map ppr (Bag.bagToList $  
    498501                                  ctTypeMapCts (unCtFamHeadMap $ inert_funeqs ics))) 
    499502                 , vcat (map ppr (Bag.bagToList $ inert_irreds ics)) 
     503                 , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_holes ics))) 
    500504                 ] 
    501505             
    502506instance Outputable InertSet where  
    … …  
    515519                         , inert_dicts  = emptyCCanMap 
    516520                         , inert_ips    = emptyCCanMap 
    517521                         , inert_funeqs = CtFamHeadMap emptyTM  
    518                          , inert_irreds = emptyCts } 
     522                         , inert_irreds = emptyCts 
     523                         , inert_holes  = emptyCCanMap } 
    519524       , inert_frozen        = emptyCts 
    520525       , inert_flat_cache    = CtFamHeadMap emptyTM 
    521526       , inert_solved        = CtPredMap emptyTM  
    … …  
    563568 
    564569          | Just x  <- isCIPCan_Maybe item      -- IP  
    565570          = ics { inert_ips   = updCCanMap (x,item) (inert_ips ics) }   
     571 
     572          | Just x <- isCHoleCan_Maybe item 
     573          = ics { inert_holes = updCCanMap (x,item) (inert_holes ics) } 
    566574             
    567575          | isCIrredEvCan item                  -- Presently-irreducible evidence 
    568576          = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item } 
    … …  
    639647                                      , inert_ips    = ips 
    640648                                      , inert_funeqs = funeqs 
    641649                                      , inert_dicts  = dicts 
     650                                      , inert_holes  = holes 
    642651                                      } 
    643652                    , inert_frozen = frozen 
    644653                    , inert_solved = solved 
    … …  
    651660                                          , inert_dicts  = solved_dicts 
    652661                                          , inert_ips    = solved_ips 
    653662                                          , inert_irreds = solved_irreds 
    654                                           , inert_funeqs = solved_funeqs } 
     663                                          , inert_funeqs = solved_funeqs 
     664                                          , inert_holes  = solved_holes } 
    655665                        , inert_frozen = emptyCts -- All out 
    656666                                          
    657667                              -- At some point, I used to flush all the solved, in  
    … …  
    674684        (unsolved_funeqs, solved_funeqs) =  
    675685          partCtFamHeadMap (not . isGivenOrSolved . cc_flavor) funeqs 
    676686 
     687        (unsolved_holes, solved_holes)   = extractUnsolvedCMap holes 
     688 
    677689        unsolved = unsolved_eqs `unionBags` unsolved_irreds `unionBags` 
    678690                   unsolved_ips `unionBags` unsolved_dicts `unionBags` unsolved_funeqs 
     691                   `unionBags` unsolved_holes 
    679692 
    680693 
    681694 
    … …  
    707720        extract_ics_relevants (CIPCan { cc_ip_nm = nm } ) ics =  
    708721            let (cts, ips_map) = getRelevantCts nm (inert_ips ics)  
    709722            in (cts, ics { inert_ips = ips_map }) 
     723        extract_ics_relevants (CHoleCan { cc_hole_nm = nm } ) ics =  
     724            let (cts, holes_map) = getRelevantCts nm (inert_holes ics)  
     725            in (cts, ics { inert_holes = holes_map }) 
    710726        extract_ics_relevants (CIrredEvCan { }) ics =  
    711727            let cts = inert_irreds ics  
    712728            in (cts, ics { inert_irreds = emptyCts }) 

  • compiler/typecheck/TcSimplify.lhs 

    diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 3c3c7f7..b8c7e4e 100644
    a b  
    294294            -- unless we are deferring errors to runtime 
    295295       ; when (not runtimeCoercionErrors && insolubleWC simpl_results) $  
    296296         do { _ev_binds <- reportUnsolved False simpl_results  
     297            ; traceTc "There is an insoluble constraint, failing already" empty 
    297298            ; failM } 
    298299 
    299300            -- Step 3  
    … …  
    471472           -> Bool          -- True <=> quantify over this wanted 
    472473quantifyMe qtvs ct 
    473474  | isIPPred pred = True  -- Note [Inheriting implicit parameters] 
     475  | isHolePred pred = True 
    474476  | otherwise     = tyVarsOfType pred `intersectsVarSet` qtvs 
    475477  where 
    476478    pred = ctPred ct 

  • compiler/typecheck/TcType.lhs 

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

  • compiler/types/TyCon.lhs 

    diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index a0a69c6..991bf6e 100644
    a b  
    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 
    … …  
    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" 
    … …  
    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 
    … …  
    14101412tyConIP_maybe (AlgTyCon {algTcParent = IPTyCon ip}) = Just ip 
    14111413tyConIP_maybe _                                     = Nothing 
    14121414 
     1415tyConHole_maybe :: TyCon -> Maybe (HoleName Name) 
     1416tyConHole_maybe (AlgTyCon {algTcParent = HoleTyCon name}) = Just name 
     1417tyConHole_maybe _                                     = Nothing 
     1418 
    14131419---------------------------------------------------------------------------- 
    14141420tyConParent :: TyCon -> TyConParent 
    14151421tyConParent (AlgTyCon {algTcParent = parent}) = parent 

  • compiler/types/Type.lhs 

    diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 89c460e..c1f6309 100644
    a b  
    5353        isDictLikeTy, 
    5454        mkNakedEqPred, mkEqPred, mkPrimEqPred, 
    5555        mkClassPred, 
    56         mkIPPred, 
     56        mkIPPred, mkHolePred, 
    5757        noParenPred, isClassPred, isEqPred, isIPPred, 
    58          
     58        isHolePred, 
     59 
    5960        -- Deconstructing predicate types 
    6061        PredTree(..), predTreePredType, classifyPredType, 
    6162        getClassPredTys, getClassPredTys_maybe, 
    … …  
    6364        getIPPredTy_maybe, 
    6465 
    6566        -- ** Common type constructors 
    66         funTyCon, 
     67        funTyCon, holeTyCon, 
    6768 
    6869        -- ** Predicates on types 
    6970        isTypeVar, isKindVar, 
    … …  
    158159import TysPrim 
    159160import {-# SOURCE #-} TysWiredIn ( eqTyCon, mkBoxedTupleTy ) 
    160161import PrelNames                 ( eqTyConKey ) 
     162import Name 
    161163 
    162164-- others 
    163165import {-# SOURCE #-} IParam ( ipTyCon ) 
    164166import Unique           ( Unique, hasKey ) 
    165 import BasicTypes       ( IPName(..) ) 
     167import BasicTypes       ( IPName(..), HoleName(..), holeNameName ) 
    166168import Name             ( Name ) 
    167169import NameSet 
    168170import StaticFlags 
    … …  
    844846isKindTy :: Type -> Bool 
    845847isKindTy = isSuperKind . typeKind 
    846848 
    847 isClassPred, isEqPred, isIPPred :: PredType -> Bool 
     849isClassPred, isEqPred, isIPPred, isHolePred :: PredType -> Bool 
    848850isClassPred ty = case tyConAppTyCon_maybe ty of 
    849851    Just tyCon | isClassTyCon tyCon -> True 
    850852    _                               -> False 
    … …  
    854856isIPPred ty = case tyConAppTyCon_maybe ty of 
    855857    Just tyCon | Just _ <- tyConIP_maybe tyCon -> True 
    856858    _                                          -> False 
     859isHolePred ty = case tyConAppTyCon_maybe ty of 
     860    Just tycon | Just _ <- tyConHole_maybe tycon -> True 
     861    _ -> False 
    857862\end{code} 
    858863 
    859864Make PredTypes 
    … …  
    890895mkIPPred ip ty = TyConApp (ipTyCon ip) [ty] 
    891896\end{code} 
    892897 
     898\begin{code} 
     899mkHolePred :: HoleName Name -> Type -> PredType 
     900mkHolePred name ty = TyConApp (holeTyCon name) [ty] 
     901 
     902holeTyCon :: HoleName Name -> TyCon 
     903holeTyCon name = case wiredInNameTyThing_maybe $ holeNameName name of 
     904    Just (ATyCon tc) -> tc 
     905    _                -> pprPanic "holeTyCon" (ppr name) 
     906\end{code} 
     907 
    893908--------------------- Dictionary types --------------------------------- 
    894909\begin{code} 
    895910mkClassPred :: Class -> [Type] -> PredType 
    … …  
    945960              | IPPred (IPName Name) Type 
    946961              | TuplePred [PredType] 
    947962              | IrredPred PredType 
     963              | HolePred (HoleName Name) Type 
    948964 
    949965predTreePredType :: PredTree -> PredType 
    950966predTreePredType (ClassPred clas tys) = mkClassPred clas tys 
    … …  
    965981                   -> IPPred ip ty 
    966982    Just (tc, tys) | isTupleTyCon tc 
    967983                   -> TuplePred tys 
     984    Just (tc, tys) | Just name <- tyConHole_maybe tc 
     985                   , let [ty] = tys 
     986                   -> HolePred name ty 
    968987    _ -> IrredPred ev_ty 
    969988\end{code} 
    970989