Skip to content

Commit

Permalink
Merge branch 'master' of ssh://darcs.haskell.org/srv/darcs/ghc
Browse files Browse the repository at this point in the history
  • Loading branch information
Richard Eisenberg committed Jun 28, 2013
2 parents fb96f13 + 7f65874 commit e56b9d5
Show file tree
Hide file tree
Showing 2 changed files with 52 additions and 75 deletions.
85 changes: 51 additions & 34 deletions compiler/typecheck/TcInteract.lhs
View file
Expand Up @@ -20,11 +20,12 @@ import VarSet
import Type
import Unify
import FamInstEnv
import InstEnv( lookupInstEnv, instanceDFunId )
import Var
import TcType
import PrelNames (singIClassName, ipClassNameKey )
import Id( idType )
import Class
import TyCon
import Name
Expand Down Expand Up @@ -1727,44 +1728,60 @@ matchClassInst _ clas [ k, ty ] _
matchClassInst inerts clas tys loc
= do { dflags <- getDynFlags
; let pred = mkClassPred clas tys
incoherent_ok = xopt Opt_IncoherentInstances dflags
; mb_result <- matchClass clas tys
; untch <- getUntouchables
; traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr pred
, text "inerts=" <+> ppr inerts
, text "untouchables=" <+> ppr untch ]
; case mb_result of
MatchInstNo -> return NoInstance
MatchInstMany -> return NoInstance -- defer any reactions of a multitude until
-- we learn more about the reagent
MatchInstSingle (_,_)
| not incoherent_ok && given_overlap untch
-> -- see Note [Instance and Given overlap]
do { traceTcS "Delaying instance application" $
vcat [ text "Workitem=" <+> pprType (mkClassPred clas tys)
, text "Relevant given dictionaries=" <+> ppr givens_for_this_clas ]
; return NoInstance
}
MatchInstSingle (dfun_id, mb_inst_tys) ->
do { checkWellStagedDFun pred dfun_id loc
-- mb_inst_tys :: Maybe TcType
-- See Note [DFunInstType: instantiating types] in InstEnv
; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys
; let (theta, _) = tcSplitPhiTy dfun_phi
; if null theta then
return (GenInst [] (EvDFunApp dfun_id tys []))
else do
{ evc_vars <- instDFunConstraints theta
; let new_ev_vars = freshGoals evc_vars
-- new_ev_vars are only the real new variables that can be emitted
dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars)
; return $ GenInst new_ev_vars dfun_app } }
}
; instEnvs <- getInstEnvs
; case lookupInstEnv instEnvs clas tys of
([], _, _) -- Nothing matches
-> do { traceTcS "matchClass not matching" $
vcat [ text "dict" <+> ppr pred ]
; return NoInstance }
([(ispec, inst_tys)], [], _) -- A single match
| not (xopt Opt_IncoherentInstances dflags)
, given_overlap untch
-> -- See Note [Instance and Given overlap]
do { traceTcS "Delaying instance application" $
vcat [ text "Workitem=" <+> pprType (mkClassPred clas tys)
, text "Relevant given dictionaries=" <+> ppr givens_for_this_clas ]
; return NoInstance }
| otherwise
-> do { let dfun_id = instanceDFunId ispec
; traceTcS "matchClass success" $
vcat [text "dict" <+> ppr pred,
text "witness" <+> ppr dfun_id
<+> ppr (idType dfun_id) ]
-- Record that this dfun is needed
; match_one dfun_id inst_tys }
(matches, _, _) -- More than one matches
-- Defer any reactions of a multitude
-- until we learn more about the reagent
-> do { traceTcS "matchClass multiple matches, deferring choice" $
vcat [text "dict" <+> ppr pred,
text "matches" <+> ppr matches]
; return NoInstance } }
where
pred = mkClassPred clas tys
match_one :: DFunId -> [Maybe TcType] -> TcS LookupInstResult
-- See Note [DFunInstType: instantiating types] in InstEnv
match_one dfun_id mb_inst_tys
= do { checkWellStagedDFun pred dfun_id loc
; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys
; let (theta, _) = tcSplitPhiTy dfun_phi
; if null theta then
return (GenInst [] (EvDFunApp dfun_id tys []))
else do
{ evc_vars <- instDFunConstraints theta
; let new_ev_vars = freshGoals evc_vars
-- new_ev_vars are only the real new variables that can be emitted
dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars)
; return $ GenInst new_ev_vars dfun_app } }
givens_for_this_clas :: Cts
givens_for_this_clas
= lookupUFM (cts_given (inert_dicts $ inert_cans inerts)) clas
Expand Down
42 changes: 1 addition & 41 deletions compiler/typecheck/TcSMonad.lhs
View file
Expand Up @@ -86,7 +86,7 @@ module TcSMonad (
getDefaultInfo, getDynFlags,
matchClass, matchFam, matchOpenFam, MatchInstResult (..),
matchFam, matchOpenFam,
checkWellStagedDFun,
pprEq -- Smaller utils, re-exported from TcM
-- TODO (DV): these are only really used in the
Expand Down Expand Up @@ -1635,46 +1635,6 @@ rewriteCtFlavor (CtWanted { ctev_evar = evar, ctev_pred = old_pred }) new_pred c
-- Matching and looking up classes and family instances
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
data MatchInstResult mi
= MatchInstNo -- No matching instance
| MatchInstSingle mi -- Single matching instance
| MatchInstMany -- Multiple matching instances
matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Maybe TcType]))
-- Look up a class constraint in the instance environment
matchClass clas tys
= do { let pred = mkClassPred clas tys
; instEnvs <- getInstEnvs
; case lookupInstEnv instEnvs clas tys of {
([], _unifs, _) -- Nothing matches
-> do { traceTcS "matchClass not matching" $
vcat [ text "dict" <+> ppr pred
{- , ppr instEnvs -} ]
; return MatchInstNo
} ;
([(ispec, inst_tys)], [], _) -- A single match
-> do { let dfun_id = is_dfun ispec
; traceTcS "matchClass success" $
vcat [text "dict" <+> ppr pred,
text "witness" <+> ppr dfun_id
<+> ppr (idType dfun_id) ]
-- Record that this dfun is needed
; return $ MatchInstSingle (dfun_id, inst_tys)
} ;
(matches, _unifs, _) -- More than one matches
-> do { traceTcS "matchClass multiple matches, deferring choice" $
vcat [text "dict" <+> ppr pred,
text "matches" <+> ppr matches]
; return MatchInstMany
}
}
}
matchOpenFam :: TyCon -> [Type] -> TcS (Maybe FamInstMatch)
matchOpenFam tycon args = wrapTcS $ tcLookupFamInst tycon args
Expand Down

0 comments on commit e56b9d5

Please sign in to comment.