Refactor overloaded literals back to Inst
authorRichard Eisenberg <eir@cis.upenn.edu>
Wed, 5 Aug 2015 16:47:27 +0000 (12:47 -0400)
committerRichard Eisenberg <eir@cis.upenn.edu>
Wed, 5 Aug 2015 16:47:27 +0000 (12:47 -0400)
compiler/typecheck/Inst.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcUnify.hs

index 338bd0d..c0f4081 100644 (file)
@@ -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
index 96bbbbd..f066d8a 100644 (file)
@@ -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
index 9fa58e8..3997ed6 100644 (file)
@@ -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)
index 7e12449..507eb40 100644 (file)
@@ -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