[commit: ghc] wip/type-app: Refactor overloaded literals back to Inst (7b815d8)
git at git.haskell.org
git at git.haskell.org
Fri Aug 7 12:07:22 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/type-app
Link : http://ghc.haskell.org/trac/ghc/changeset/7b815d8e772ace0092103c781182c058feed8ee1/ghc
>---------------------------------------------------------------
commit 7b815d8e772ace0092103c781182c058feed8ee1
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Wed Aug 5 12:47:27 2015 -0400
Refactor overloaded literals back to Inst
>---------------------------------------------------------------
7b815d8e772ace0092103c781182c058feed8ee1
compiler/typecheck/Inst.hs | 41 +++++++++++++++++++++++++++++++++++++++--
compiler/typecheck/TcExpr.hs | 6 ++++--
compiler/typecheck/TcPat.hs | 4 ++--
compiler/typecheck/TcUnify.hs | 41 +----------------------------------------
4 files changed, 46 insertions(+), 46 deletions(-)
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index 338bd0d..c0f4081 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -6,7 +6,7 @@
The @Inst@ type: dictionaries or method instances
-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, TupleSections #-}
module Inst (
deeplySkolemise,
@@ -15,7 +15,7 @@ module Inst (
newWanted, newWanteds,
emitWanted, emitWanteds,
- newNonTrivialOverloadedLit, mkOverLit,
+ newOverloadedLit, newNonTrivialOverloadedLit, mkOverLit,
newClsInst,
tcGetInsts, tcGetInstEnvs, getOverlapFlag,
@@ -331,6 +331,43 @@ instStupidTheta orig theta
-}
+{-
+In newOverloadedLit we convert directly to an Int or Integer if we
+know that's what we want. This may save some time, by not
+temporarily generating overloaded literals, but it won't catch all
+cases (the rest are caught in lookupInst).
+
+-}
+
+newOverloadedLit :: HsOverLit Name
+ -> TcSigmaType -- if nec'y, this type is instantiated...
+ -> CtOrigin -- ... using this CtOrigin
+ -> TcM (HsWrapper, HsOverLit TcId)
+ -- wrapper :: input type "->" type of result
+newOverloadedLit
+ lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty res_orig
+ | not rebindable
+ -- all built-in overloaded lits are not higher-rank, so skolemise.
+ -- this is necessary for shortCutLit.
+ = do { (wrap, insted_ty) <- deeplyInstantiate res_orig res_ty
+ ; dflags <- getDynFlags
+ ; case shortCutLit dflags val insted_ty of
+ -- Do not generate a LitInst for rebindable syntax.
+ -- Reason: If we do, tcSimplify will call lookupInst, which
+ -- will call tcSyntaxName, which does unification,
+ -- which tcSimplify doesn't like
+ Just expr -> return ( wrap
+ , lit { ol_witness = expr, ol_type = insted_ty
+ , ol_rebindable = False } )
+ Nothing -> (wrap, ) <$>
+ newNonTrivialOverloadedLit orig lit insted_ty }
+
+ | otherwise
+ = do { lit' <- newNonTrivialOverloadedLit orig lit res_ty
+ ; return (idHsWrapper, lit') }
+ where
+ orig = LiteralOrigin lit
+
-- Does not handle things that 'shortCutLit' can handle. See also
-- newOverloadedLit in TcUnify
newNonTrivialOverloadedLit :: CtOrigin
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 96bbbbd..f066d8a 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -192,8 +192,10 @@ tcExpr (HsCoreAnn src lbl expr) res_ty
; return (HsCoreAnn src lbl expr', orig) }
tcExpr (HsOverLit lit) res_ty
- = do { (wrap, lit') <- newOverloadedLit Expected lit res_ty
- ; return (mkHsWrap wrap $ HsOverLit lit', LiteralOrigin lit) }
+ = do { (_wrap, lit') <- newOverloadedLit lit res_ty
+ (Shouldn'tHappenOrigin "HsOverLit")
+ ; MASSERT( isIdHsWrapper _wrap )
+ ; return (HsOverLit lit', LiteralOrigin lit) }
tcExpr (NegApp expr neg_expr) res_ty
= do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index 9fa58e8..3997ed6 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -636,7 +636,7 @@ tc_pat _ (LitPat simple_lit) pat_ty thing_inside
tc_pat (PE { pe_orig = pat_orig })
(NPat (L l over_lit) mb_neg eq) pat_ty thing_inside
= do { let orig = LiteralOrigin over_lit
- ; (wrap, lit') <- newOverloadedLit (Actual pat_orig) over_lit pat_ty
+ ; (wrap, lit') <- newOverloadedLit over_lit pat_ty pat_orig
; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy)
; mb_neg' <- case mb_neg of
Nothing -> return Nothing -- Positive literal
@@ -651,7 +651,7 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) ge minus) pat_ty thing_inside
= do { (co, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
; let pat_ty' = idType bndr_id
orig = LiteralOrigin lit
- ; (wrap_lit, lit') <- newOverloadedLit (Actual $ pe_orig penv) lit pat_ty'
+ ; (wrap_lit, lit') <- newOverloadedLit lit pat_ty' (pe_orig penv)
-- The '>=' and '-' parts are re-mappable syntax
; ge' <- tcSyntaxOp orig ge (mkFunTys [pat_ty', pat_ty'] boolTy)
diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
index 7e12449..507eb40 100644
--- a/compiler/typecheck/TcUnify.hs
+++ b/compiler/typecheck/TcUnify.hs
@@ -29,7 +29,6 @@ module TcUnify (
matchExpectedAppTy,
matchExpectedFunTys, matchExpectedFunTysPart,
matchExpectedFunKind,
- newOverloadedLit,
wrapFunResCoercion
) where
@@ -41,10 +40,9 @@ import TypeRep
import TcMType
import TcRnMonad
import TcType
-import TcHsSyn ( shortCutLit )
import Type
import TcEvidence
-import Name ( Name, isSystemName )
+import Name ( isSystemName )
import Inst
import Kind
import TyCon
@@ -409,43 +407,6 @@ matchExpectedAppTy orig_ty
-- not enough to lose sleep over.
{-
-In newOverloadedLit we convert directly to an Int or Integer if we
-know that's what we want. This may save some time, by not
-temporarily generating overloaded literals, but it won't catch all
-cases (the rest are caught in lookupInst).
-
-This is here because of its dependency on the Expected/Actual
-functions above.
--}
-
-newOverloadedLit :: ExpOrAct
- -> HsOverLit Name
- -> TcSigmaType
- -> TcM (HsWrapper, HsOverLit TcId)
-newOverloadedLit ea
- lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty
- | not rebindable
- -- all built-in overloaded lits are not higher-rank, so skolemise.
- -- this is necessary for shortCutLit.
- = exposeRhoType ea res_ty $ \ res_rho -> liftM (idHsWrapper,) $
- do { dflags <- getDynFlags
- ; case shortCutLit dflags val res_rho of
- -- Do not generate a LitInst for rebindable syntax.
- -- Reason: If we do, tcSimplify will call lookupInst, which
- -- will call tcSyntaxName, which does unification,
- -- which tcSimplify doesn't like
- Just expr -> return (lit { ol_witness = expr, ol_type = res_rho
- , ol_rebindable = False })
- Nothing -> newNonTrivialOverloadedLit orig lit res_rho }
-
- | otherwise
- = do { lit' <- newNonTrivialOverloadedLit orig lit res_ty
- ; return (idHsWrapper, lit') }
- where
- orig = LiteralOrigin lit
-
-
-{-
************************************************************************
* *
Subsumption checking
More information about the ghc-commits
mailing list