Ticket #5910: patch3.diff

File patch3.diff, 50.5 KB (added by xnyhps, 3 years ago)
  • compiler/basicTypes/BasicTypes.lhs

    diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
    index c6226ca..f822ea8 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) = 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 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 d31c774..becb480 100644
    a b dsExpr (HsLam a_Match) 
    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 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 e55d78e..4974429 100644
    a b data NameCache 
    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
    type OrigNameCache = ModuleEnv (OccEnv Name) 
    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 parseName str = withSession $ \hsc_env -> do 
    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 $tab+ { warn Opt_WarnTabs (text "Tab character") } 
    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 }
    data Token 
    544548  | ITprefixqconsym (FastString,FastString)
    545549
    546550  | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
     551  | IThole         FastString
    547552
    548553  | ITchar       Char
    549554  | ITstring     FastString
    skip_one_varid :: (FastString -> Token) -> Action 
    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 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 } 
    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
    dbind : ipvar '=' exp { LL (IPBind (unLoc $1) $3) } 
    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
    getQCONSYM (L _ (ITqconsym x)) = x 
    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 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 
    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,
    mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_ip 
    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 import HsSyn 
    3434import TcRnMonad
    3535import TcEnv            ( thRnBrack )
    3636import RnEnv
    37 import RnTypes 
     37import RnTypes
    3838import RnPat
    3939import DynFlags
    4040import BasicTypes       ( FixityDirection(..) )
    rnExpr (ArithSeq _ seq) 
    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,
    import RdrHsSyn ( extractHsTyRdrTyVars, extractHsTysRdrTyVars ) 
    4040import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
    4141import RnEnv
    4242import TcRnMonad
    43 import IfaceEnv         ( newIPName )
     43import IfaceEnv         ( newIPName, newHoleName )
    4444import RdrName
    4545import PrelNames
    4646import TysPrim          ( funTyConName )
    import NameSet 
    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 )
    rnIPName :: IPName RdrName -> RnM (IPName Name) 
    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 hasEqualities givens = any (has_eq . evVarPred) givens 
    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
    tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys 
    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 module TcCanonical( 
    1313
    1414#include "HsVersions.h"
    1515
    16 import BasicTypes ( IPName )
     16import BasicTypes ( IPName, HoleName )
    1717import TcErrors
    1818import TcRnTypes
    1919import TcType
    canonicalize (CIrredEvCan { cc_flavor = fl 
    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
    canEvVar d fl pred_classifier 
    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
    constraint between the types. (On the other hand, the types in two 
    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 reportUnsolved runtimeCoercionErrors wanted 
    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
    reportUnsolved runtimeCoercionErrors wanted 
    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
    reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics } 
    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)
    mkFlatErr ctxt ct -- The constraint is always wanted 
    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
    reportFlatErrs :: 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
    mkIrredErr ctxt cts 
    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 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       ; 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 zonkExpr env (HsWrap co_fn expr) 
    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)
    zonkTypeZapping tv 
    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 import Pair () 
    5959import UniqFM
    6060import FastString ( sLit )
    6161import DynFlags
     62
     63import Control.Monad
     64import Type
    6265\end{code}
    6366**********************************************************************
    6467*                                                                    *
    kick_out_rewritable ct is@(IS { inert_cans = 
    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 }
    kick_out_rewritable ct is@(IS { inert_cans = 
    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
    kick_out_rewritable ct is@(IS { inert_cans = 
    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
    data InteractResult 
    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
    interactWithInertsStage wi 
    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
    doInteractWithInert (CIPCan { cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 }) 
    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 predTypeOccName :: PredType -> OccName 
    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")
    growPredTyVars pred tvs = go (classifyPredType pred) 
    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 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 
    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!
    tcRnSrcDecls boot_iface decls 
    463470        setGlobalTypeEnv tcg_env' final_type_env
    464471   } }
    465472
     473-- where
     474
    466475tc_rn_src_decls :: ModDetails
    467476                    -> [LHsDecl RdrName]
    468477                    -> TcM (TcGblEnv, TcLclEnv)
    tcRnExpr hsc_env ictxt rdr_expr 
    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 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 } ;
  • compiler/typecheck/TcRnTypes.lhs

    diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
    index f480bab..c928fda 100644
    a b module TcRnTypes( 
    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,
    import FastString 
    122123
    123124import Data.Set (Set)
    124125
     126import UniqSet
     127import qualified Data.Map as Map
    125128\end{code}
    126129
    127130
    data Ct 
    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}
    ctPred (CFunEqCan { cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 }) 
    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
    isCFunEqCan _ = False 
    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}
    instance Outputable Ct where 
    9931012                           CDictCan {}      -> "CDictCan"
    9941013                           CIPCan {}        -> "CIPCan"
    9951014                           CIrredEvCan {}   -> "CIrredEvCan"
     1015                           CHoleCan {}          -> "CHoleCan"
    9961016\end{code}
    9971017
    9981018\begin{code}
    andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 }) 
    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 data CCanMap a = CCanMap { cts_given :: UniqFM Cts 
    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)
    extractUnsolvedCMap 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 =
    data InertCans 
    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                     
    instance Outputable InertCans where 
    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
    emptyInert 
    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
    updInertSet is item 
    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 }
    extractUnsolved (IS { inert_cans = IC { inert_eqs = eqs 
    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
    extractUnsolved (IS { inert_cans = IC { inert_eqs = eqs 
    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
    extractUnsolved (IS { inert_cans = IC { inert_eqs = eqs 
    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
    extractRelevantInerts wi 
    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 simplifyInfer _top_lvl apply_mr name_taus wanteds 
    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
    quantifyMe :: TyVarSet -- Quantifying over these 
    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 module TcType ( 
    130130  mkTyVarTy, mkTyVarTys, mkTyConTy,
    131131
    132132  isClassPred, isEqPred, isIPPred,
    133   mkClassPred, mkIPPred,
     133  mkClassPred, mkIPPred, isHolePred,
    134134  isDictLikeTy,
    135135  tcSplitDFunTy, tcSplitDFunHead,
    136136  mkEqPred,
    data TcTyVarDetails 
    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
    data MetaInfo 
    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 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) 
    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 module Type ( 
    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,
    module Type ( 
    6364        getIPPredTy_maybe,
    6465
    6566        -- ** Common type constructors
    66         funTyCon,
     67        funTyCon, holeTyCon,
    6768
    6869        -- ** Predicates on types
    6970        isTypeVar, isKindVar,
    import TyCon 
    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
    isPredTy ty 
    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
    isEqPred ty = case tyConAppTyCon_maybe ty of 
    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
    mkIPPred :: IPName Name -> Type -> PredType 
    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
    data PredTree = ClassPred Class [Type] 
    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
    classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of 
    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