Make literals in the syntax tree strict

[ghc-hetmet.git] / compiler / hsSyn / HsLit.lhs

diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs
index f4c9cf7..a85bc62 100644 (file)
--- a/compiler/hsSyn/HsLit.lhs
+++ b/compiler/hsSyn/HsLit.lhs
@@ -9,7 +9,8 @@ module HsLit where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} HsExpr( SyntaxExpr )
+import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
+import HsTypes (PostTcType)
 import Type    ( Type )
 import Outputable
 import FastString
@@ -51,30 +52,51 @@ instance Eq HsLit where
   (HsRat x1 _)     == (HsRat x2 _)      = x1==x2
   (HsFloatPrim x1)  == (HsFloatPrim x2)  = x1==x2
   (HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2
-  lit1             == lit2              = False
+  _                 == _                 = False
 
 data HsOverLit id      -- An overloaded literal
-  = HsIntegral  Integer  (SyntaxExpr id)       -- Integer-looking literals;
-  | HsFractional Rational (SyntaxExpr id)      -- Frac-looking literals
+  = HsIntegral   !Integer    (SyntaxExpr id)  PostTcType       -- Integer-looking literals;
+  | HsFractional !Rational   (SyntaxExpr id)  PostTcType       -- Frac-looking literals
+  | HsIsString   !FastString (SyntaxExpr id)  PostTcType       -- String-looking literals
   -- Before type checking, the SyntaxExpr is 'fromInteger' or 'fromRational'
   -- After type checking, it is (fromInteger 3) or lit_78; that is,
   -- the expression that should replace the literal.
   -- This is unusual, because we're replacing 'fromInteger' with a call 
   -- to fromInteger.  Reason: it allows commoning up of the fromInteger
   -- calls, which wouldn't be possible if the desguarar made the application
+  --
+  -- The PostTcType in each branch records the type the overload literal is
+  -- found to have.
+
+overLitExpr :: HsOverLit id -> SyntaxExpr id
+overLitExpr (HsIntegral _ e _) = e
+overLitExpr (HsFractional _ e _) = e
+overLitExpr (HsIsString _ e _) = e
+
+overLitType :: HsOverLit id -> PostTcType
+overLitType (HsIntegral _ _ t) = t
+overLitType (HsFractional _ _ t) = t
+overLitType (HsIsString _ _ t) = t
+
 
 -- Comparison operations are needed when grouping literals
 -- for compiling pattern-matching (module MatchLit)
 instance Eq (HsOverLit id) where
-  (HsIntegral i1 _)   == (HsIntegral i2 _)   = i1 == i2
-  (HsFractional f1 _) == (HsFractional f2 _) = f1 == f2
-  l1                 == l2                  = False
+  (HsIntegral i1 _ _)   == (HsIntegral i2 _ _)   = i1 == i2
+  (HsFractional f1 _ _) == (HsFractional f2 _ _) = f1 == f2
+  (HsIsString s1 _ _)   == (HsIsString s2 _ _)   = s1 == s2
+  _                     == _                     = False
 
 instance Ord (HsOverLit id) where
-  compare (HsIntegral i1 _)   (HsIntegral i2 _)   = i1 `compare` i2
-  compare (HsIntegral _ _)    (HsFractional _ _)  = LT
-  compare (HsFractional f1 _) (HsFractional f2 _) = f1 `compare` f2
-  compare (HsFractional f1 _) (HsIntegral _ _)    = GT
+  compare (HsIntegral i1 _ _)   (HsIntegral i2 _ _)   = i1 `compare` i2
+  compare (HsIntegral _ _ _)    (HsFractional _ _ _)  = LT
+  compare (HsIntegral _ _ _)    (HsIsString _ _ _)    = LT
+  compare (HsFractional f1 _ _) (HsFractional f2 _ _) = f1 `compare` f2
+  compare (HsFractional _ _ _)  (HsIntegral _ _ _)    = GT
+  compare (HsFractional _ _ _)  (HsIsString _ _ _)    = LT
+  compare (HsIsString s1 _ _)   (HsIsString s2 _ _)   = s1 `compare` s2
+  compare (HsIsString _ _ _)    (HsIntegral _ _ _)    = GT
+  compare (HsIsString _ _ _)    (HsFractional _ _ _)  = GT
 \end{code}
 
 \begin{code}
@@ -91,7 +113,9 @@ instance Outputable HsLit where
     ppr (HsDoublePrim d) = rational d <> text "##"
     ppr (HsIntPrim i)   = integer i  <> char '#'
 
-instance Outputable (HsOverLit id) where
-  ppr (HsIntegral i _)   = integer i
-  ppr (HsFractional f _) = rational f
+-- in debug mode, print the expression that it's resolved to, too
+instance OutputableBndr id => Outputable (HsOverLit id) where
+  ppr (HsIntegral i e _)   = integer i <+> (ifPprDebug (parens (pprExpr e)))
+  ppr (HsFractional f e _) = rational f <+> (ifPprDebug (parens (pprExpr e)))
+  ppr (HsIsString s e _)   = pprHsString s <+> (ifPprDebug (parens (pprExpr e)))
 \end{code}