Ticket #5910: patch.diff

compiler/basicTypes/BasicTypes.lhs

@@ -40 +40 @@
         compareFixity,
 
         IPName(..), ipNameName, mapIPName,
+  HoleName(..), holeNameName, mapHoleName,
 
         RecFlag(..), isRec, isNonRec, boolToRecFlag,
 
@@ -189 +190 @@
 
 instance Outputable name => Outputable (IPName name) where
     ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters
+
+
+newtype HoleName name = HoleName name -- _x
+  deriving( Eq, Data, Typeable )
+
+instance Ord a => Ord (HoleName a) where
+  compare (HoleName a) (HoleName b) = compare a b
+
+instance Functor HoleName where
+    fmap = mapHoleName
+
+holeNameName :: HoleName name -> name
+holeNameName (HoleName n) = n
+
+mapHoleName :: (a->b) -> HoleName a -> HoleName b
+mapHoleName f (HoleName n) = HoleName (f n)
+
+instance Outputable name => Outputable (HoleName name) where
+    ppr (HoleName n) = char '_' <> ppr n -- Ordinary holes
+
 \end{code}
 
 %************************************************************************

compiler/basicTypes/Unique.lhs

@@ -181 +181 @@
 
 instance Uniquable n => Uniquable (IPName n) where
   getUnique (IPName n) = getUnique n
+
+instance Uniquable n => Uniquable (HoleName n) where
+  getUnique (HoleName n) = getUnique n
 \end{code}
 
 

compiler/deSugar/Coverage.lhs

@@ -540 +540 @@
                 (addTickHsExpr e)       -- explicitly no tick on inside
 
 addTickHsExpr e@(HsType _) = return e
+addTickHsExpr e@(HsHole _) = return e
 
 -- Others dhould never happen in expression content.
 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)

compiler/deSugar/DsExpr.lhs

@@ -229 +229 @@
 
 dsExpr (HsApp fun arg)
   = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
+
+dsExpr (HsHole nm)
+  = return (Var $ holeNameName nm)
 \end{code}
 
 Note [Desugaring vars]

compiler/hsSyn/HsExpr.lhs

@@ -290 +290 @@
 
   |  HsWrap     HsWrapper    -- TRANSLATION
                 (HsExpr id)
+  |  HsHole     (HoleName id)
   deriving (Data, Typeable)
 
 -- HsTupArg is used for tuple sections
@@ -545 +546 @@
 ppr_expr (HsArrForm op _ args)
   = hang (ptext (sLit "(|") <> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
+ppr_expr (HsHole name)
+  = ppr name
 
 pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
 pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)

compiler/iface/IfaceEnv.lhs

@@ -12 +12 @@
         newGlobalBinder, newImplicitBinder, 
         lookupIfaceTop,
         lookupOrig, lookupOrigNameCache, extendNameCache,
-        newIPName, newIfaceName, newIfaceNames,
+        newIPName, newHoleName, newIfaceName, newIfaceNames,
         extendIfaceIdEnv, extendIfaceTyVarEnv, 
         tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar,
 
@@ -42 +42 @@
 import SrcLoc
 import BasicTypes
 
+import TysPrim
+import TysWiredIn
+import Coercion
+
 import Outputable
 import Exception     ( evaluate )
 
@@ -181 +185 @@
 newIPName ip = updNameCache $ flip allocateIPName ip
 \end{code}
 
+\begin{code}
+newHoleName :: FastString -> TcRnIf m n (HoleName Name)
+newHoleName name = updNameCache $ \name_cache -> case Map.lookup name $ nsHoles name_cache of
+    Just name_hole -> (name_cache, name_hole)
+    Nothing        -> (new_ns, name_hole)
+      where
+        (us_here, us') = splitUniqSupply (nsUniqs name_cache)
+        new_holecache = Map.insert name name_hole $ nsHoles name_cache
+        tycon_u:datacon_u:dc_wrk_u:co_ax_u:_ = uniqsFromSupply us_here
+        name_hole  = mkHoleName name tycon_u datacon_u dc_wrk_u co_ax_u
+        new_ns     = name_cache { nsUniqs = us', nsHoles = new_holecache }
+
+\end{code}
+
 %************************************************************************
 %*                                                                      *
                 Name cache access
@@ -249 +267 @@
 initNameCache us names
   = NameCache { nsUniqs = us,
                 nsNames = initOrigNames names,
-                nsIPs   = Map.empty }
+                nsIPs   = Map.empty,
+                nsHoles = Map.empty }
 
 initOrigNames :: [Name] -> OrigNameCache
 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names

compiler/main/HscTypes.lhs

@@ -1762 +1762 @@
                 -- ^ Supply of uniques
                 nsNames :: OrigNameCache,
                 -- ^ Ensures that one original name gets one unique
-                nsIPs   :: OrigIParamCache
+                nsIPs   :: OrigIParamCache,
                 -- ^ Ensures that one implicit parameter name gets one unique
+                nsHoles :: OrigHoleCache
    }
 
 -- | Per-module cache of original 'OccName's given 'Name's
@@ -1771 +1772 @@
 
 -- | Module-local cache of implicit parameter 'OccName's given 'Name's
 type OrigIParamCache = Map FastString (IPName Name)
+
+type OrigHoleCache = Map FastString (HoleName Name)
 \end{code}
 
 

compiler/main/InteractiveEval.hs

@@ -932 +932 @@
 exprType :: GhcMonad m => String -> m Type
 exprType expr = withSession $ \hsc_env -> do
    ty <- liftIO $ hscTcExpr hsc_env expr
-   return $ tidyType emptyTidyEnv ty
+   return {-$ tidyType emptyTidyEnv-} ty
 
 -- -----------------------------------------------------------------------------
 -- Getting the kind of a type

compiler/parser/Lexer.x

@@ -105 +105 @@
 
 $unismall  = \x02 -- Trick Alex into handling Unicode. See alexGetChar.
 $ascsmall  = [a-z]
-$small     = [$ascsmall $unismall \_]
+$small     = [$ascsmall $unismall]
 
 $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar.
 $graphic   = [$small $large $symbol $digit $special $unigraphic \:\"\']
@@ -338 +338 @@
          { token ITcubxparen }
 }
 
+<0> {
+  \_ @varid { skip_one_varid IThole }
+}
+
 <0,option_prags> {
   \(                                    { special IToparen }
   \)                                    { special ITcparen }
@@ -538 +542 @@
   | ITprefixqconsym (FastString,FastString)
 
   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
+  | IThole         FastString 
 
   | ITchar       Char
   | ITstring     FastString

compiler/parser/Parser.y.pp

@@ -322 +322 @@
  PREFIXQCONSYM  { L _ (ITprefixqconsym  _) }
 
  IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension
+ HOLEVARID      { L _ (IThole     _) }
 
  CHAR           { L _ (ITchar     _) }
  STRING         { L _ (ITstring   _) }
@@ -1436 +1437 @@
 
 aexp2   :: { LHsExpr RdrName }
         : ipvar                         { L1 (HsIPVar $! unLoc $1) }
+        | hole                          { L1 (HsHole  $! unLoc $1) }
         | qcname                        { L1 (HsVar   $! unLoc $1) }
         | literal                       { L1 (HsLit   $! unLoc $1) }
 -- This will enable overloaded strings permanently.  Normally the renamer turns HsString
@@ -1750 +1752 @@
 ipvar   :: { Located (IPName RdrName) }
         : IPDUPVARID            { L1 (IPName (mkUnqual varName (getIPDUPVARID $1))) }
 
+hole    :: { Located (HoleName RdrName) }
+        : HOLEVARID             { L1 (HoleName (mkUnqual varName $ getHOLEVARID $1)) }
+
 -----------------------------------------------------------------------------
 -- Warnings and deprecations
 
@@ -2069 +2074 @@
 getPREFIXQVARSYM (L _ (ITprefixqvarsym  x)) = x
 getPREFIXQCONSYM (L _ (ITprefixqconsym  x)) = x
 getIPDUPVARID   (L _ (ITdupipvarid   x)) = x
+getHOLEVARID    (L _ (IThole     x)) = x
 getCHAR         (L _ (ITchar     x)) = x
 getSTRING       (L _ (ITstring   x)) = x
 getINTEGER      (L _ (ITinteger  x)) = x

compiler/prelude/TysWiredIn.lhs

@@ -73 +73 @@
         eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon,
 
         -- * Implicit parameter predicates
-        mkIPName
+        mkIPName,
+
+        mkHoleName
     ) where
 
 #include "HsVersions.h"
@@ -94 +96 @@
 import TypeRep
 import RdrName
 import Name
-import BasicTypes       ( TupleSort(..), tupleSortBoxity, IPName(..), 
+import BasicTypes       ( TupleSort(..), tupleSortBoxity, IPName(..), HoleName(..),
                           Arity, RecFlag(..), Boxity(..), HsBang(..) )
 import ForeignCall
 import Unique           ( incrUnique, mkTupleTyConUnique,
@@ -424 +426 @@
     co_ax_name = mkPrimTyConName ip co_ax_u tycon
 \end{code}
 
+\begin{code}
+mkHoleName :: FastString
+         -> Unique -> Unique -> Unique -> Unique
+         -> HoleName Name
+mkHoleName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_hole
+  where
+    name_hole = HoleName tycon_name
+
+    tycon_name = mkPrimTyConName ip tycon_u tycon
+    tycon      = mkAlgTyCon tycon_name
+                   (liftedTypeKind `mkArrowKind` constraintKind)
+                   [alphaTyVar]
+                   Nothing
+                   []      -- No stupid theta
+                   (NewTyCon { data_con    = datacon, 
+                               nt_rhs      = mkTyVarTy alphaTyVar,
+                               nt_etad_rhs = ([alphaTyVar], mkTyVarTy alphaTyVar),
+                               nt_co       = mkNewTypeCo co_ax_name tycon [alphaTyVar] (mkTyVarTy alphaTyVar) })
+                   (HoleTyCon name_hole)
+                   NonRecursive
+                   False
+
+    datacon_name = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "IPBox") datacon_u datacon
+    datacon      = pcDataCon' datacon_name dc_wrk_u [alphaTyVar] [mkTyVarTy alphaTyVar] tycon
+
+    co_ax_name = mkPrimTyConName ip co_ax_u tycon
+\end{code}
+
 %************************************************************************
 %*                                                                      *
 \subsection[TysWiredIn-boxed-prim]{The ``boxed primitive'' types (@Char@, @Int@, etc)}

compiler/rename/RnExpr.lhs

@@ -34 +34 @@
 import TcRnMonad
 import TcEnv            ( thRnBrack )
 import RnEnv
-import RnTypes          ( rnHsTypeFVs, rnSplice, rnIPName, checkTH,
+import RnTypes          ( rnHsTypeFVs, rnSplice, rnIPName, rnHoleName, checkTH,
                           mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
 import RnPat
 import DynFlags
@@ -293 +293 @@
 rnExpr (PArrSeq _ seq)
   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
     return (PArrSeq noPostTcExpr new_seq, fvs)
+
+rnExpr (HsHole name)
+  = do { name' <- rnHoleName name
+       ; return (HsHole name', emptyFVs)
+       }
 \end{code}
 
 These three are pattern syntax appearing in expressions.

compiler/rename/RnTypes.lhs

@@ -16 +16 @@
         rnHsType, rnLHsType, rnLHsTypes, rnContext,
         rnHsKind, rnLHsKind, rnLHsMaybeKind,
         rnHsSigType, rnLHsInstType, rnHsTypeFVs, rnConDeclFields,
-        rnIPName,
+        rnIPName, rnHoleName,
 
         -- Precence related stuff
         mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
@@ -41 +41 @@
 import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
 import RnEnv
 import TcRnMonad
-import IfaceEnv         ( newIPName )
+import IfaceEnv         ( newIPName, newHoleName )
 import RdrName
 import PrelNames
 import TysPrim          ( funTyConName )
@@ -51 +51 @@
 
 import Util             ( filterOut )
 import BasicTypes       ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFixity, 
-                          Fixity(..), FixityDirection(..) )
+                          Fixity(..), FixityDirection(..), HoleName(..), holeNameName )
 import Outputable
 import FastString
 import Control.Monad    ( unless, zipWithM )
@@ -344 +344 @@
 rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n)))
 \end{code}
 
+\begin{code}
+rnHoleName :: HoleName RdrName -> RnM (HoleName Name)
+rnHoleName n = newHoleName (occNameFS (rdrNameOcc (holeNameName n)))
+\end{code}
+
 
 %************************************************************************
 %*                                                                      *

compiler/typecheck/Inst.lhs

@@ -519 +519 @@
     has_eq' (ClassPred cls _tys) = any has_eq (classSCTheta cls)
     has_eq' (TuplePred ts)       = any has_eq ts
     has_eq' (IrredPred _)        = True -- Might have equalities in it after reduction?
+    has_eq' (HolePred {})        = False
 
 ---------------- Getting free tyvars -------------------------
 
@@ -529 +530 @@
 tyVarsOfCt (CIPCan { cc_ip_ty = ty })                   = tyVarsOfType ty
 tyVarsOfCt (CIrredEvCan { cc_ty = ty })                 = tyVarsOfType ty
 tyVarsOfCt (CNonCanonical { cc_id = ev })               = tyVarsOfEvVar ev
+tyVarsOfCt (CHoleCan { cc_hole_ty = ty })               = tyVarsOfType ty
 
 tyVarsOfCDict :: Ct -> TcTyVarSet 
 tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys

compiler/typecheck/TcCanonical.lhs

@@ -13 +13 @@
 
 #include "HsVersions.h"
 
-import BasicTypes ( IPName )
+import BasicTypes ( IPName, HoleName )
 import TcErrors
 import TcRnTypes
 import TcType
@@ -37 +37 @@
 import TcSMonad
 import FastString
 
+import qualified TcMType
+
 import Data.Maybe ( isNothing )
 import Data.List  ( zip4 )
 \end{code}
@@ -204 +206 @@
                           , cc_depth = d
                           , cc_ty = xi })
   = canIrred d fl ev xi
+canonicalize (CHoleCan { cc_id = ev, cc_depth = d
+                       , cc_flavor = fl
+                       , cc_hole_nm = nm
+                       , cc_hole_ty = xi })
+  = canHole d fl ev nm xi
 
 
 canEvVar :: EvVar -> PredTree 
@@ -216 +223 @@
       IPPred nm ty      -> canIP      d fl ev nm ty
       IrredPred ev_ty   -> canIrred   d fl ev ev_ty
       TuplePred tys     -> canTuple   d fl ev tys
+      HolePred name ty  -> canHole  d fl ev name ty
 \end{code}
 
 
@@ -263 +271 @@
   =    -- Note [Canonical implicit parameter constraints] explains why it's 
        -- possible in principle to not flatten, but since flattening applies 
        -- the inert substitution we choose to flatten anyway.
-    do { (xi,co) <- flatten d fl (mkIPPred nm ty)
+    do { (xi,co) <- trace "canIP" $ flatten d fl (mkIPPred nm ty)
        ; let no_flattening = isTcReflCo co 
        ; if no_flattening then
             let IPPred _ xi_in = classifyPredType xi 
@@ -296 +304 @@
 class constraints for the same class MAY be equal, so they need to be
 flattened in the first place to facilitate comparing them.)
 
+\begin{code}
+canHole :: SubGoalDepth -- Depth 
+      -> CtFlavor -> EvVar 
+      -> HoleName Name -> Type -> TcS StopOrContinue
+canHole d fl v nm ty
+  = do { (xi,co) <- flatten d fl (mkHolePred nm ty)
+       ; let no_flattening = isTcReflCo co
+       ; if no_flattening then
+            let HolePred _ xi_in = classifyPredType xi
+            in continueWith $ CHoleCan { cc_id = v, cc_flavor = fl
+                                       , cc_hole_nm = nm, cc_hole_ty = xi_in
+                                       , cc_depth = d
+                                       }
+         else
+            error "false"
+       }
+\end{code}
+
 %************************************************************************
 %*                                                                      *
 %*                      Class Canonicalization

compiler/typecheck/TcErrors.lhs

@@ -294 +294 @@
           ClassPred {}  -> go cts (ct:dicts) ips irreds
           IPPred {}     -> go cts dicts (ct:ips) irreds
           IrredPred {}  -> go cts dicts ips (ct:irreds)
+          HolePred {}   -> go cts dicts ips irreds
           _             -> panic "mkFlat"
     -- TuplePreds should have been expanded away by the constraint
     -- simplifier, so they shouldn't show up at this point

compiler/typecheck/TcExpr.lhs

@@ -63 +63 @@
 import Outputable
 import FastString
 import Control.Monad
+
+import TypeRep
+import qualified Data.Map as Map
 \end{code}
 
 %************************************************************************
@@ -90 +93 @@
   = do { traceTc "tcPolyExprNC" (ppr res_ty)
        ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho ->
                             tcMonoExprNC expr rho
+       ; sk <- deeplySkolemise res_ty
        ; return (mkLHsWrap gen_fn expr') }
 
 ---------------
@@ -214 +218 @@
         -- so it's not enabled yet.
         -- Can't eliminate it altogether from the parser, because the
         -- same parser parses *patterns*.
+tcExpr (HsHole name) res_ty
+  = do { traceTc "tcExpr.HsHole" (ppr $ res_ty)
+       ; let origin = OccurrenceOf $ holeNameName name
+       -- Update the local environment with our ty
+       ; (g, l) <- getEnvs
+       ; holes <- readTcRef $ tcl_holes l
+       ; ty <- newFlexiTyVarTy liftedTypeKind
+       
+       -- Emit the constraint
+       ; var <- emitWanted origin (mkHolePred name ty)
+       ; traceTc "tcExpr.HsHole: Creating new ty for hole" (ppr ty)
+       ; writeTcRef (tcl_holes l) (Map.insert name (ty, tcl_lie l) holes)
+
+       ; tcWrapResult (HsHole $ HoleName var) ty res_ty }
 \end{code}
 
 

compiler/typecheck/TcHsSyn.lhs

@@ -703 +703 @@
     zonkExpr env1 expr  `thenM` \ new_expr ->
     return (HsWrap new_co_fn new_expr)
 
+zonkExpr env h@(HsHole nm)
+  = do {
+    traceTc "zonkExpr.HsHole" (ppr h);
+    return (HsHole nm)
+    }
+
 zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
 
 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)

compiler/typecheck/TcInteract.lhs

@@ -56 +56 @@
 import UniqFM
 import FastString ( sLit ) 
 import DynFlags
+
+import Control.Monad
+import Type
 \end{code}
 **********************************************************************
 *                                                                    * 
@@ -415 +418 @@
                            , inert_funeqs = funeqmap
                            , inert_irreds = irreds
                            , inert_frozen = frozen
+                           , inert_holes  = holemap
                            } )
   = ((kicked_out, eqmap), remaining)
   where
     kicked_out = WorkList { wl_eqs    = []
                           , wl_funeqs = bagToList feqs_out
                           , wl_rest   = bagToList (fro_out `andCts` dicts_out 
-                                          `andCts` ips_out `andCts` irs_out) }
+                                          `andCts` ips_out `andCts` irs_out `andCts` holes_out) }
   
     remaining = IS { inert_eqs = emptyVarEnv
                    , inert_eq_tvs = inscope -- keep the same, safe and cheap
@@ -430 +434 @@
                    , inert_funeqs = feqs_in
                    , inert_irreds = irs_in
                    , inert_frozen = fro_in 
+                   , inert_holes = holes_in
                    }
 
     fl = cc_flavor ct
     tv = cc_tyvar ct
                                
     (ips_out,   ips_in)     = partitionCCanMap rewritable ipmap
+    (holes_out, holes_in)   = partitionCCanMap rewritable holemap
 
     (feqs_out,  feqs_in)    = partitionCtTypeMap rewritable funeqmap
     (dicts_out, dicts_in)   = partitionCCanMap rewritable dictmap
@@ -686 +692 @@
     | IRInertConsumed    { ir_fire :: String } 
     | IRKeepGoing        { ir_fire :: String }
 
+
+instance Outputable InteractResult where
+  ppr (IRWorkItemConsumed str) = ptext (sLit "IRWorkItemConsumed ") <+> text str
+  ppr (IRInertConsumed str) = ptext (sLit "IRInertConsumed ") <+> text str
+  ppr (IRKeepGoing str) = ptext (sLit "IRKeepGoing ") <+> text str
+
 irWorkItemConsumed :: String -> TcS InteractResult
 irWorkItemConsumed str = return (IRWorkItemConsumed str) 
 
@@ -703 +715 @@
 -- react with anything at this stage. 
 interactWithInertsStage wi 
   = do { ctxt <- getTcSContext
+       ; traceTcS "interactWithInertsStage" (ppr $ simplEqsOnly ctxt)
        ; if simplEqsOnly ctxt then 
              return (ContinueWith wi)
          else 
-             extractRelevantInerts wi >>= 
-               foldlBagM interact_next (ContinueWith wi) }
+             do { relevant <- extractRelevantInerts wi
+                ; traceTcS "interactWithInertsStage: Relevant" (ppr relevant)
+                ; foldlBagM interact_next (ContinueWith wi) relevant
+                }
+       }
 
   where interact_next Stop atomic_inert 
-          = updInertSetTcS atomic_inert >> return Stop
+          = trace "interact_next Stop" $ updInertSetTcS atomic_inert >> return Stop
         interact_next (ContinueWith wi) atomic_inert 
           = do { ir <- doInteractWithInert atomic_inert wi
                ; let mk_msg rule keep_doc 
                        = text rule <+> keep_doc
                          <+> vcat [ ptext (sLit "Inert =") <+> ppr atomic_inert
                                   , ptext (sLit "Work =")  <+> ppr wi ]
+               ; traceTcS "interact_next ContinueWith" (ppr ir)
                ; case ir of 
                    IRWorkItemConsumed { ir_fire = rule } 
                        -> do { bumpStepCountTcS
@@ -851 +868 @@
   where
     lhss_match = tc1 == tc2 && eqTypes args1 args2 
 
+doInteractWithInert (CHoleCan id1 fl1 nm1 ty1 d1) workitem@(CHoleCan id2 fl2 nm2 ty2 d2)
+  | nm1 == nm2 && isGivenOrSolved fl2 && isGivenOrSolved fl1
+  = irInertConsumed "Hole/Hole (override inert)"
+  | nm1 == nm2 && ty1 `eqType` ty2 
+  = solveOneFromTheOther "Hole/Hole" (EvId id1,fl1) workitem
 
+  | nm1 == nm2
+  = do { let flav = Wanted (combineCtLoc fl1 fl2)
+       ; eqv <- newEqVar flav ty2 ty1
+       ; when (isNewEvVar eqv) $
+              (let ct = CNonCanonical { cc_id     = evc_the_evvar eqv 
+                                      , cc_flavor = flav
+                                      , cc_depth  = d2 }
+              in updWorkListTcS (extendWorkListEq ct))
+       ; case fl2 of
+          Given {} -> pprPanic "Unexpected given Hole" (ppr workitem)
+          Derived {} -> pprPanic "Unexpected derived Hole" (ppr workitem)
+          Wanted {} ->
+              do { _ <- setEvBind id2
+                        (mkEvCast id1 (mkTcSymCo (mkTcTyConAppCo (holeTyCon nm1) [mkTcCoVarCo (evc_the_evvar eqv)]))) fl2
+                 ; irWorkItemConsumed "Hole/Hole (solved by rewriting)" }
+       }
 doInteractWithInert _ _ = irKeepGoing "NOP"
 
 

compiler/typecheck/TcMType.lhs

@@ -167 +167 @@
 predTypeOccName ty = case classifyPredType ty of
     ClassPred cls _ -> mkDictOcc (getOccName cls)
     IPPred ip _     -> mkVarOccFS (ipFastString ip)
+    HolePred name _ -> mkVarOccFS (occNameFS $ nameOccName $ holeNameName name)
     EqPred _ _      -> mkVarOccFS (fsLit "cobox")
     TuplePred _     -> mkVarOccFS (fsLit "tup")
     IrredPred _     -> mkVarOccFS (fsLit "irred")
@@ -1386 +1387 @@
     go (EqPred ty1 ty2)  = grow (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2)
     go (TuplePred ts)    = unionVarSets (map (go . classifyPredType) ts)
     go (IrredPred ty)    = grow (tyVarsOfType ty)
+    go (HolePred _ ty)   = tyVarsOfType ty
 \end{code}
     
 Note [Implicit parameters and ambiguity] 

compiler/typecheck/TcRnDriver.lhs

@@ -40 +40 @@
 import TcAnnotations
 import TcBinds
 import HeaderInfo       ( mkPrelImports )
-import TcType   ( tidyTopType )
+import TcType   ( tidyTopType, tidyType )
 import TcDefaults
 import TcEnv
 import TcRules
@@ -100 +100 @@
 
 import Control.Monad
 
+import System.IO
+import TypeRep
+import qualified Data.Map as Map
+import TcType
+
 #include "HsVersions.h"
 \end{code}
 
@@ -429 +434 @@
                         simplifyTop lie ;
         traceTc "Tc9" empty ;
 
+        traceRn (text "tcRnSrcDecls:" <+> (ppr lie)) ;
+
         failIfErrsM ;   -- Don't zonk if there have been errors
                         -- It's a waste of time; and we may get debug warnings
                         -- about strangely-typed TyCons!
@@ -461 +468 @@
         setGlobalTypeEnv tcg_env' final_type_env
    } }
 
+-- where
+
 tc_rn_src_decls :: ModDetails
                     -> [LHsDecl RdrName]
                     -> TcM (TcGblEnv, TcLclEnv)
@@ -1423 +1432 @@
         -- it might have a rank-2 type (e.g. :t runST)
     uniq <- newUnique ;
     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
-    ((_tc_expr, res_ty), lie)   <- captureConstraints (tcInferRho rn_expr) ;
-    ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
+    ((_tc_expr, res_ty), lie)   <- captureConstraints (tcInferRho rn_expr) ;
+
+
+    (g, l) <- getEnvs ;
+    holes <- readTcRef $ tcl_holes l ;
+
+    ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ 
                                       {-# SCC "simplifyInfer" #-}
                                       simplifyInfer True {- Free vars are closed -}
                                                     False {- No MR for now -}
-                                                    [(fresh_it, res_ty)]
+                                                    ([(fresh_it, res_ty)]) -- ++ (map (\(nm,(ty,_)) -> (holeNameName nm, ty)) $ Map.toList holes))
                                                     lie  ;
+        let { (holes, dicts') = splitEvs dicts [] [] } ;
+    
+    traceRn (text "tcRnExpr1:" <+> (ppr holes <+> ppr dicts')) ;
+
     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
+    
+    traceRn (text "tcRnExpr2:" <+> (ppr lie_top)) ;
+
+    let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts' res_ty) } ;
+    result <- zonkTcType all_expr_ty ;
+
 
-    let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
-    zonkTcType all_expr_ty
+    zonked_holes <- zonkHoles $ map (apsnd (mkForAllTys qtvs) . apsnd (mkPiTypes dicts') . unwrapHole . varType) $ holes ;
+
+    let { (env, tidied_holes) = apsnd (map (apsnd split)) $ foldr tidy (emptyTidyEnv, []) zonked_holes } ;
+
+    liftIO $ putStrLn $ showSDoc ((ptext $ sLit "Found the following holes: ")
+                                $+$ (vcat $ map (\(nm, ty) -> text "_" <> ppr nm <+> colon <> colon <+> ppr ty) tidied_holes));
+
+    return $ snd $ tidyOpenType env result
     }
+    where tidy (nm, ty) (env, tys) = let (env', ty') = tidyOpenType env ty
+                                     in (env', (nm, ty') : tys)
+
+          split t = let (_, ctxt, ty') = tcSplitSigmaTy $ tidyTopType t
+                    in mkPhiTy ctxt ty'
+
+          splitEvs [] hls dcts = (hls, dcts)
+          splitEvs (evvar:xs) hls dcts = case classifyPredType $ varType evvar of
+                                                                                HolePred {} -> splitEvs xs (evvar:hls) dcts
+                                                                                _ -> splitEvs xs hls (evvar:dcts)
+          -- unwrap what was wrapped in mkHolePred
+          unwrapHole (TyConApp nm [ty]) = (nm, ty)
+
+          -- zonk the holes, but keep the name
+          zonkHoles = mapM (\(nm, ty) -> liftM (\t -> (nm, t)) $ zonkTcType ty)
+
+          apsnd f (a, b) = (a, f b)
+
+          f (_, b) = let (Just (ATyCon tc)) = wiredInNameTyThing_maybe b
+                         (Just (_, ty, _)) = trace ("unwrapNewTyCon_maybe" ++ (showSDoc $ ppr tc)) $ unwrapNewTyCon_maybe tc
+                                 in (b, ty)
 
 --------------------------
 tcRnImportDecls :: HscEnv

compiler/typecheck/TcRnMonad.lhs

@@ -53 +53 @@
 import Data.IORef
 import qualified Data.Set as Set
 import Control.Monad
+
+import qualified Data.Map as Map
 \end{code}
 
 
@@ -86 +88 @@
         infer_var    <- newIORef True ;
         lie_var      <- newIORef emptyWC ;
         dfun_n_var   <- newIORef emptyOccSet ;
+        holes_var    <- newIORef Map.empty ;
         type_env_var <- case hsc_type_env_var hsc_env of {
                            Just (_mod, te_var) -> return te_var ;
                            Nothing             -> newIORef emptyNameEnv } ;
@@ -151 +154 @@
                 tcl_tyvars     = tvs_var,
                 tcl_lie        = lie_var,
                 tcl_meta       = meta_var,
-                tcl_untch      = initTyVarUnique
+                tcl_untch      = initTyVarUnique,
+                tcl_holes      = holes_var
              } ;
         } ;
 

compiler/typecheck/TcRnTypes.lhs

@@ -54 +54 @@
         Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, 
         singleCt, extendCts, isEmptyCts, isCTyEqCan, 
         isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe,
+        isCHoleCan_Maybe, isCHoleCan,
         isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, 
         isGivenCt_maybe, isGivenOrSolvedCt,
         ctWantedLoc,
         SubGoalDepth, mkNonCanonical, ctPred, 
 
         WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
-        andWC, addFlats, addImplics, mkFlatWC,
+        andWC, unionsWC, addFlats, addImplics, mkFlatWC,
 
         Implication(..),
         CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
@@ -123 +124 @@
 
 import Data.Set (Set)
 
+import UniqSet
+import qualified Data.Map as Map
 \end{code}
 
 
@@ -444 +447 @@
         -- TcMetaTyVars have 
         tcl_meta  :: TcRef Unique,  -- The next free unique for TcMetaTyVars
                                     -- Guaranteed to be allocated linearly
-        tcl_untch :: Unique         -- Any TcMetaTyVar with 
+        tcl_untch :: Unique,        -- Any TcMetaTyVar with 
                                     --     unique >= tcl_untch is touchable
                                     --     unique <  tcl_untch is untouchable
+        tcl_holes :: TcRef (Map.Map (HoleName Name) (Type, TcRef WantedConstraints))
     }
 
 type TcTypeEnv = NameEnv TcTyThing
@@ -908 +912 @@
       cc_depth  :: SubGoalDepth
     }
 
+  | CHoleCan {
+      cc_id       :: EvVar,
+      cc_flavor   :: CtFlavor,
+      cc_hole_nm  :: HoleName Name,
+      cc_hole_ty  :: TcTauType, -- Not a Xi! See same not as above
+      cc_depth    :: SubGoalDepth        -- See Note [WorkList]
+    }
+
 \end{code}
 
 \begin{code}
@@ -925 +937 @@
 ctPred (CIPCan { cc_ip_nm = nm, cc_ip_ty = xi }) 
   = mkIPPred nm xi
 ctPred (CIrredEvCan { cc_ty = xi }) = xi
+ctPred (CHoleCan { cc_hole_nm = nm, cc_hole_ty = xi})
+  = mkHolePred nm xi
 \end{code}
 
 
@@ -977 +991 @@
 isCNonCanonical :: Ct -> Bool
 isCNonCanonical (CNonCanonical {}) = True 
 isCNonCanonical _ = False 
+
+isCHoleCan :: Ct -> Bool
+isCHoleCan (CHoleCan {}) = True
+isCHoleCan _ = False
+
+isCHoleCan_Maybe :: Ct -> Maybe (HoleName Name)
+isCHoleCan_Maybe (CHoleCan { cc_hole_nm = nm }) = Just nm
+isCHoleCan_Maybe _ = Nothing
 \end{code}
 
 \begin{code}
@@ -992 +1014 @@
                            CDictCan {}      -> "CDictCan"
                            CIPCan {}        -> "CIPCan"
                            CIrredEvCan {}   -> "CIrredEvCan"
+                           CHoleCan {}          -> "CHoleCan"
 \end{code}
 
 \begin{code}
@@ -1058 +1081 @@
        , wc_impl  = i1 `unionBags` i2
        , wc_insol = n1 `unionBags` n2 }
 
+unionsWC :: [WantedConstraints] -> WantedConstraints
+unionsWC = foldr andWC emptyWC
+
 addFlats :: WantedConstraints -> Bag Ct -> WantedConstraints
 addFlats wc cts
   = wc { wc_flat = wc_flat wc `unionBags` cts }

compiler/typecheck/TcSMonad.lhs

@@ -329 +329 @@
                          , cts_wanted  :: UniqFM Cts } 
                                           -- Invariant: all Wanted
 
+instance Outputable (CCanMap a) where
+  ppr (CCanMap given derived wanted) = ptext (sLit "CCanMap") <+> (ppr given) <+> (ppr derived) <+> (ppr wanted)
+
 cCanMapToBag :: CCanMap a -> Cts 
 cCanMapToBag cmap = foldUFM unionBags rest_wder (cts_given cmap)
   where rest_wder = foldUFM unionBags rest_der  (cts_wanted cmap) 
@@ -415 +418 @@
 
        , inert_irreds       :: Cts  -- Irreducible predicates
        , inert_frozen       :: Cts  -- All non-canonicals are kept here (as frozen errors)
+       , inert_holes        :: CCanMap (HoleName Name)
        }
 
 
@@ -453 +457 @@
                 , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts is)))
                 , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_ips is))) 
                 , vcat (map ppr (Bag.bagToList $ ctTypeMapCts (inert_funeqs is)))
+                , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_holes is))) 
                 , text "Frozen errors =" <+> -- Clearly print frozen errors
                     braces (vcat (map ppr (Bag.bagToList $ inert_frozen is)))
                 , text "Warning: Not displaying cached (solved) constraints"
@@ -466 +471 @@
                 , inert_dicts   = emptyCCanMap
                 , inert_ips     = emptyCCanMap
                 , inert_funeqs  = emptyTM
+                , inert_holes   = emptyCCanMap
                 }
 
 
@@ -504 +510 @@
         upd_funeqs Nothing = Just item
         upd_funeqs (Just _alredy_there) = panic "updInertSet: item already there!"
     in is { inert_funeqs = alterTM pty upd_funeqs (inert_funeqs is) }
-     
+  
+  | Just x <- isCHoleCan_Maybe item
+  = is { inert_holes = updCCanMap (x,item) (inert_holes is) }
   | otherwise 
-  = is { inert_frozen = inert_frozen is `Bag.snocBag` item }
+  = trace "updInertSet" $ is { inert_frozen = inert_frozen is `Bag.snocBag` item }
 
 updInertSetTcS :: AtomicInert -> TcS ()
 -- Add a new item in the inerts of the monad
@@ -557 +565 @@
                         , inert_irreds = solved_irreds
                         , inert_frozen = emptyCts
                         , inert_funeqs = solved_funeqs
+                        , inert_holes  = solved_holes
                         }
     in ((inert_frozen is, unsolved), is_solved)
 
@@ -570 +579 @@
 
         (unsolved_funeqs, solved_funeqs) = extractUnsolvedCtTypeMap (inert_funeqs is)
 
+        (unsolved_holes, solved_holes)   = extractUnsolvedCMap (inert_holes is)
+
         unsolved = unsolved_eqs `unionBags` unsolved_irreds `unionBags`
                    unsolved_ips `unionBags` unsolved_dicts `unionBags` unsolved_funeqs
+                   `unionBags` unsolved_holes
 
 extractUnsolvedCtTypeMap :: TypeMap Ct -> (Cts,TypeMap Ct)
 extractUnsolvedCtTypeMap
@@ -596 +608 @@
         extract_inert_relevants (CIrredEvCan { }) is = 
             let cts = inert_irreds is 
             in (cts, is { inert_irreds = emptyCts })
+        extract_inert_relevants (CHoleCan { cc_hole_nm = nm }) is =
+            let (cts, holes_map) = getRelevantCts nm (inert_holes is) 
+            in (cts, is { inert_holes = holes_map })
         extract_inert_relevants _ is = (emptyCts,is)
 \end{code}
 

compiler/typecheck/TcSimplify.lhs

@@ -472 +472 @@
            -> Bool          -- True <=> quantify over this wanted
 quantifyMe qtvs ct
   | isIPPred pred = True  -- Note [Inheriting implicit parameters]
+  | isHolePred pred = True
   | otherwise     = tyVarsOfType pred `intersectsVarSet` qtvs
   where
     pred = ctPred ct

compiler/typecheck/TcType.lhs

@@ -131 +131 @@
   mkTyVarTy, mkTyVarTys, mkTyConTy,
 
   isClassPred, isEqPred, isIPPred,
-  mkClassPred, mkIPPred,
+  mkClassPred, mkIPPred, isHolePred,
   isDictLikeTy,
   tcSplitDFunTy, tcSplitDFunHead, 
   mkEqPred,
@@ -306 +306 @@
           
   | MetaTv MetaInfo (IORef MetaDetails)
 
+instance Outputable TcTyVarDetails where
+  ppr (SkolemTv b)    = ptext (sLit "SkolemTv") <+> ppr b
+  ppr RuntimeUnk      = ptext (sLit "RuntimeUnk")
+  ppr (FlatSkol ty)   = ptext (sLit "FlatSkol") <+> ppr ty
+  ppr (MetaTv info _) = ptext (sLit "MetaTv") <+> ppr info
+
 vanillaSkolemTv, superSkolemTv :: TcTyVarDetails
 -- See Note [Binding when looking up instances] in InstEnv
 vanillaSkolemTv = SkolemTv False  -- Might be instantiated
@@ -340 +346 @@
 -- UserTypeCtxt describes the origin of the polymorphic type
 -- in the places where we need to an expression has that type
 
+instance Outputable MetaInfo where
+  ppr TauTv = ptext (sLit "TauTv")
+  ppr SigTv = ptext (sLit "SigTv")
+  ppr TcsTv = ptext (sLit "TcsTv")
+
 data UserTypeCtxt
   = FunSigCtxt Name     -- Function type signature
                         -- Also used for types in SPECIALISE pragmas

compiler/types/TyCon.lhs

@@ -65 +65 @@
         tyConStupidTheta,
         tyConArity,
         tyConParent,
-        tyConTuple_maybe, tyConClass_maybe, tyConIP_maybe,
+        tyConTuple_maybe, tyConClass_maybe, tyConIP_maybe, tyConHole_maybe,
         tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,
         synTyConDefn, synTyConRhs, synTyConType,
         tyConExtName,           -- External name for foreign types
@@ -551 +551 @@
         --      data R:TList a = ...
         --      axiom co a :: T [a] ~ R:TList a
         -- with R:TList's algTcParent = FamInstTyCon T [a] co
+        | HoleTyCon (HoleName Name)
 
 instance Outputable TyConParent where
     ppr NoParentTyCon           = text "No parent"
@@ -566 +567 @@
 okParent tc_name (ClassTyCon cls)            = tc_name == tyConName (classTyCon cls)
 okParent tc_name (IPTyCon ip)                = tc_name == ipTyConName ip
 okParent _       (FamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys
+okParent tc_name (HoleTyCon hole)            = tc_name == holeNameName hole
 
 isNoParent :: TyConParent -> Bool
 isNoParent NoParentTyCon = True
@@ -1409 +1411 @@
 tyConIP_maybe (AlgTyCon {algTcParent = IPTyCon ip}) = Just ip
 tyConIP_maybe _                                     = Nothing
 
+tyConHole_maybe :: TyCon -> Maybe (HoleName Name)
+tyConHole_maybe (AlgTyCon {algTcParent = HoleTyCon name}) = Just name
+tyConHole_maybe _                                     = Nothing
+
 ----------------------------------------------------------------------------
 tyConParent :: TyCon -> TyConParent
 tyConParent (AlgTyCon {algTcParent = parent}) = parent

compiler/types/Type.lhs

@@ -49 +49 @@
         mkFamilyTyConApp,
         isDictLikeTy,
         mkEqPred, mkClassPred,
-        mkIPPred,
-        noParenPred, isClassPred, isEqPred, isIPPred,
+        mkIPPred, mkHolePred,
+        noParenPred, isClassPred, isEqPred, isIPPred, isHolePred,
         mkPrimEqType,
 
         -- Deconstructing predicate types
@@ -60 +60 @@
         getIPPredTy_maybe,
 
         -- ** Common type constructors
-        funTyCon,
+        funTyCon, holeTyCon,
 
         -- ** Predicates on types
         isTypeVar, isKindVar,
@@ -154 +154 @@
 import TysPrim
 import {-# SOURCE #-} TysWiredIn ( eqTyCon, mkBoxedTupleTy )
 import PrelNames                 ( eqTyConKey )
+import Name
 
 -- others
 import {-# SOURCE #-} IParam ( ipTyCon )
 import Unique           ( Unique, hasKey )
-import BasicTypes       ( IPName(..) )
+import BasicTypes       ( IPName(..), HoleName(..), holeNameName )
 import Name             ( Name )
 import NameSet
 import StaticFlags
@@ -815 +816 @@
 isKindTy :: Type -> Bool
 isKindTy = isSuperKind . typeKind
 
-isClassPred, isEqPred, isIPPred :: PredType -> Bool
+isClassPred, isEqPred, isIPPred, isHolePred :: PredType -> Bool
 isClassPred ty = case tyConAppTyCon_maybe ty of
     Just tyCon | isClassTyCon tyCon -> True
     _                               -> False
@@ -825 +826 @@
 isIPPred ty = case tyConAppTyCon_maybe ty of
     Just tyCon | Just _ <- tyConIP_maybe tyCon -> True
     _                                          -> False
+isHolePred ty = case tyConAppTyCon_maybe ty of
+    Just tycon | Just _ <- tyConHole_maybe tycon -> True
+    _ -> False
 \end{code}
 
 Make PredTypes
@@ -856 +860 @@
 mkIPPred ip ty = TyConApp (ipTyCon ip) [ty]
 \end{code}
 
+\begin{code}
+mkHolePred :: HoleName Name -> Type -> PredType
+mkHolePred name ty = TyConApp (holeTyCon name) [ty]
+
+holeTyCon :: HoleName Name -> TyCon
+holeTyCon name = case wiredInNameTyThing_maybe $ holeNameName name of
+    Just (ATyCon tc) -> tc
+    _                -> pprPanic "holeTyCon" (ppr name)
+\end{code}
+
 --------------------- Dictionary types ---------------------------------
 \begin{code}
 mkClassPred :: Class -> [Type] -> PredType
@@ -911 +925 @@
               | IPPred (IPName Name) Type
               | TuplePred [PredType]
               | IrredPred PredType
+              | HolePred (HoleName Name) Type
 
 predTreePredType :: PredTree -> PredType
 predTreePredType (ClassPred clas tys) = mkClassPred clas tys
@@ -931 +946 @@
                    -> IPPred ip ty
     Just (tc, tys) | isTupleTyCon tc
                    -> TuplePred tys
+    Just (tc, tys) | Just name <- tyConHole_maybe tc
+                   , let [ty] = tys
+                   -> HolePred name ty
     _ -> IrredPred ev_ty
 \end{code}