Fix Trac #2246; overhaul handling of overloaded literals

The real work of fixing Trac #2246 is to use shortCutLit in
MatchLit.dsOverLit, so that type information discovered late in the
day by the type checker can still be exploited during desugaring.

However, as usual I found myself doing some refactoring along the
way, to tidy up the handling of overloaded literals.   The main
change is to split HsOverLit into a record, which in turn uses
a sum type for the three variants.  This makes the code significantly
more modular.

data HsOverLit id
  = OverLit {
	ol_val :: OverLitVal, 
	ol_rebindable :: Bool,		-- True <=> rebindable syntax
					-- False <=> standard syntax
	ol_witness :: SyntaxExpr id,	-- Note [Overloaded literal witnesses]
	ol_type :: PostTcType }

data OverLitVal
  = HsIntegral   !Integer   	-- Integer-looking literals;
  | HsFractional !Rational   	-- Frac-looking literals
  | HsIsString   !FastString 	-- String-looking literals

3 files changed, 60 insertions, 42 deletions

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 75186feecb..c5b13eb2d3 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -433,11 +433,11 @@ get_lit :: Pat id -> Maybe HsLit
 -- Get a representative HsLit to stand for the OverLit
 -- It doesn't matter which one, because they will only be compared
 -- with other HsLits gotten in the same way
-get_lit (LitPat lit)			 = Just lit
-get_lit (NPat (HsIntegral i   _ _) mb _) = Just (HsIntPrim   (mb_neg mb i))
-get_lit (NPat (HsFractional f _ _) mb _) = Just (HsFloatPrim (mb_neg mb f))
-get_lit (NPat (HsIsString s   _ _)  _ _) = Just (HsStringPrim s)
-get_lit _                                = Nothing
+get_lit (LitPat lit)				          = Just lit
+get_lit (NPat (OverLit { ol_val = HsIntegral i})    mb _) = Just (HsIntPrim   (mb_neg mb i))
+get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg mb f))
+get_lit (NPat (OverLit { ol_val = HsIsString s })   _  _) = Just (HsStringPrim s)
+get_lit _                                	          = Nothing
 
 mb_neg :: Num a => Maybe b -> a -> a
 mb_neg Nothing  v = v
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index ca4fae4219..c045ca417e 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1293,15 +1293,18 @@ mk_rational :: Rational -> DsM HsLit
 mk_rational r = do rat_ty <- lookupType rationalTyConName
                    return $ HsRat r rat_ty
 mk_string :: FastString -> DsM HsLit
-mk_string s   = do return $ HsString s
+mk_string s = return $ HsString s
 
 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
-repOverloadedLiteral (HsIntegral i _ _)   = do { lit <- mk_integer  i; repLiteral lit }
-repOverloadedLiteral (HsFractional f _ _) = do { lit <- mk_rational f; repLiteral lit }
-repOverloadedLiteral (HsIsString s _ _)   = do { lit <- mk_string   s; repLiteral lit }
+repOverloadedLiteral (OverLit { ol_val = val})
+  = do { lit <- mk_lit val; repLiteral lit }
 	-- The type Rational will be in the environment, becuase 
 	-- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
 	-- and rationalL is sucked in when any TH stuff is used
+
+mk_lit (HsIntegral i)   = mk_integer  i
+mk_lit (HsFractional f) = mk_rational f
+mk_lit (HsIsString s)   = mk_string   s
               
 --------------- Miscellaneous -------------------
 
diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 4deb51c9d1..6d7db7cce8 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -19,10 +19,12 @@ import DsMonad
 import DsUtils
 
 import HsSyn
+
 import Id
 import CoreSyn
 import TyCon
 import DataCon
+import TcHsSyn	( shortCutLit )
 import TcType
 import Type
 import PrelNames
@@ -85,11 +87,21 @@ dsLit (HsRat r ty) = do
 dsOverLit :: HsOverLit Id -> DsM CoreExpr
 -- Post-typechecker, the SyntaxExpr field of an OverLit contains 
 -- (an expression for) the literal value itself
-dsOverLit (HsIntegral   _ lit _) = dsExpr lit
-dsOverLit (HsFractional _ lit _) = dsExpr lit
-dsOverLit (HsIsString   _ lit _) = dsExpr lit
+dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable 
+		   , ol_witness = witness, ol_type = ty })
+  | not rebindable
+  , Just expr <- shortCutLit val ty = dsExpr expr	-- Note [Literal short cut]
+  | otherwise			    = dsExpr witness
 \end{code}
 
+Note [Literal short cut]
+~~~~~~~~~~~~~~~~~~~~~~~~
+The type checker tries to do this short-cutting as early as possible, but 
+becuase of unification etc, more information is available to the desugarer.
+And where it's possible to generate the correct literal right away, it's
+much better do do so.
+
+
 \begin{code}
 hsLitKey :: HsLit -> Literal
 -- Get a Core literal to use (only) a grouping key
@@ -108,13 +120,14 @@ hsLitKey l                 = pprPanic "hsLitKey" (ppr l)
 
 hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
 -- Ditto for HsOverLit; the boolean indicates to negate
-hsOverLitKey (HsIntegral i _ _)   False = MachInt i
-hsOverLitKey (HsIntegral i _ _)   True  = MachInt (-i)
-hsOverLitKey (HsFractional r _ _) False = MachFloat r
-hsOverLitKey (HsFractional r _ _) True  = MachFloat (-r)
-hsOverLitKey (HsIsString s _ _)   False = MachStr s
-hsOverLitKey l                    _     = pprPanic "hsOverLitKey" (ppr l)
--- negated string should never happen
+hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
+
+litValKey :: OverLitVal -> Bool -> Literal
+litValKey (HsIntegral i)   False = MachInt i
+litValKey (HsIntegral i)   True  = MachInt (-i)
+litValKey (HsFractional r) False = MachFloat r
+litValKey (HsFractional r) True  = MachFloat (-r)
+litValKey (HsIsString s)   neg   = ASSERT( not neg) MachStr s
 \end{code}
 
 %************************************************************************
@@ -141,41 +154,43 @@ tidyLitPat lit = LitPat lit
 
 ----------------
 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
-tidyNPat over_lit mb_neg eq 
-  | isIntTy    (overLitType over_lit) = mk_con_pat intDataCon    (HsIntPrim int_val)
-  | isWordTy   (overLitType over_lit) = mk_con_pat wordDataCon   (HsWordPrim int_val)
-  | isFloatTy  (overLitType over_lit) = mk_con_pat floatDataCon  (HsFloatPrim  rat_val)
-  | isDoubleTy (overLitType over_lit) = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
+tidyNPat over_lit@(OverLit val False _ ty) mb_neg eq 
+	-- Take short cuts only if the literal is not using rebindable syntax
+  | isIntTy    ty = mk_con_pat intDataCon    (HsIntPrim int_val)
+  | isWordTy   ty = mk_con_pat wordDataCon   (HsWordPrim int_val)
+  | isFloatTy  ty = mk_con_pat floatDataCon  (HsFloatPrim  rat_val)
+  | isDoubleTy ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
 --  | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
-  | otherwise	      = NPat over_lit mb_neg eq
   where
     mk_con_pat :: DataCon -> HsLit -> Pat Id
-    mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] (overLitType over_lit))
+    mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
 
-    neg_lit = case (mb_neg, over_lit) of
-		(Nothing, 	       _)   -> over_lit
-		(Just _,  HsIntegral i s ty)   -> HsIntegral   (-i) s ty
-		(Just _,  HsFractional f s ty) -> HsFractional (-f) s ty
-		(Just _,  HsIsString {})       -> panic "tidyNPat/neg_lit HsIsString"
+    neg_val = case (mb_neg, val) of
+		(Nothing, 	       _) -> val
+		(Just _,  HsIntegral   i) -> HsIntegral   (-i)
+		(Just _,  HsFractional f) -> HsFractional (-f)
+		(Just _,  HsIsString _)	  -> panic "tidyNPat"
 			     
     int_val :: Integer
-    int_val = case neg_lit of
-		HsIntegral   i _ _ -> i
-		HsFractional {}    -> panic "tidyNPat/int_val HsFractional"
-		HsIsString   {}    -> panic "tidyNPat/int_val HsIsString"
+    int_val = case neg_val of
+		HsIntegral i -> i
+		_ -> panic "tidyNPat"
 	
     rat_val :: Rational
-    rat_val = case neg_lit of
-		HsIntegral   i _ _ -> fromInteger i
-		HsFractional f _ _ -> f
-		HsIsString   {}    -> panic "tidyNPat/rat_val HsIsString"
+    rat_val = case neg_val of
+		HsIntegral   i -> fromInteger i
+		HsFractional f -> f
+		_ -> panic "tidyNPat"
 	
 {-
     str_val :: FastString
-    str_val = case neg_lit of
-		HsIsString   s _ _ -> s
-		_                  -> error "tidyNPat"
+    str_val = case val of
+		HsIsString s -> s
+		_ -> panic "tidyNPat"
 -}
+
+tidyNPat over_lit mb_neg eq 
+  = NPat over_lit mb_neg eq
 \end{code}