X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=defa5bffc7deb48a145dfea2d0ec1d2c3cb4e6e3;hb=ecdaf6bc29d23bd704df8c65442ee08032a585fc;hp=7bb1d5e38da7d342a68659e4212fd8d0949a9405;hpb=6c7b41cc2b24f533697a62bf1843507ae043fc97;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 7bb1d5e..defa5bf 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -20,7 +20,8 @@ module TcHsSyn (
 	mkHsConApp, mkHsDictLet, mkHsApp,
 	hsLitType, hsLPatType, hsPatType, 
 	mkHsAppTy, mkSimpleHsAlt,
-	nlHsIntLit, mkVanillaTuplePat,
+	nlHsIntLit, mkVanillaTuplePat, 
+	shortCutLit, hsOverLitName,
 	
 	mkArbitraryType,	-- Put this elsewhere?
 
@@ -40,16 +41,19 @@ import HsSyn	-- oodles of it
 import Id
 
 import TcRnMonad
+import PrelNames
 import Type
 import TcType
 import TcMType
 import TysPrim
 import TysWiredIn
 import TyCon
+import DataCon
 import Name
 import Var
 import VarSet
 import VarEnv
+import Literal
 import BasicTypes
 import Maybes
 import Unique
@@ -57,6 +61,7 @@ import SrcLoc
 import Util
 import Bag
 import Outputable
+import FastString
 \end{code}
 
 \begin{code}
@@ -117,12 +122,47 @@ hsLitType (HsString str)   = stringTy
 hsLitType (HsStringPrim s) = addrPrimTy
 hsLitType (HsInt i)	   = intTy
 hsLitType (HsIntPrim i)    = intPrimTy
+hsLitType (HsWordPrim w)   = wordPrimTy
 hsLitType (HsInteger i ty) = ty
 hsLitType (HsRat _ ty)	   = ty
 hsLitType (HsFloatPrim f)  = floatPrimTy
 hsLitType (HsDoublePrim d) = doublePrimTy
 \end{code}
 
+Overloaded literals. Here mainly becuase it uses isIntTy etc
+
+\begin{code}
+shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId)
+shortCutLit (HsIntegral i) ty
+  | isIntTy ty && inIntRange i   = Just (HsLit (HsInt i))
+  | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
+  | isIntegerTy ty 	       	 = Just (HsLit (HsInteger i ty))
+  | otherwise		       	 = shortCutLit (HsFractional (fromInteger i)) ty
+	-- The 'otherwise' case is important
+	-- Consider (3 :: Float).  Syntactically it looks like an IntLit,
+	-- so we'll call shortCutIntLit, but of course it's a float
+	-- This can make a big difference for programs with a lot of
+	-- literals, compiled without -O
+
+shortCutLit (HsFractional f) ty
+  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
+  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
+  | otherwise     = Nothing
+
+shortCutLit (HsIsString s) ty
+  | isStringTy ty = Just (HsLit (HsString s))
+  | otherwise     = Nothing
+
+mkLit :: DataCon -> HsLit -> HsExpr Id
+mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
+
+------------------------------
+hsOverLitName :: OverLitVal -> Name
+-- Get the canonical 'fromX' name for a particular OverLitVal
+hsOverLitName (HsIntegral {})   = fromIntegerName
+hsOverLitName (HsFractional {}) = fromRationalName
+hsOverLitName (HsIsString {})   = fromStringName
+\end{code}
 
 %************************************************************************
 %*									*
@@ -562,8 +602,8 @@ zonkCoFn env WpInline = return (env, WpInline)
 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
 				    ; (env2, c2') <- zonkCoFn env1 c2
 				    ; return (env2, WpCompose c1' c2') }
-zonkCoFn env (WpCo co)      = do { co' <- zonkTcTypeToType env co
-				 ; return (env, WpCo co') }
+zonkCoFn env (WpCast co)    = do { co' <- zonkTcTypeToType env co
+				 ; return (env, WpCast co') }
 zonkCoFn env (WpLam id)     = do { id' <- zonkDictBndr env id
 				 ; let env1 = extendZonkEnv1 env id'
 				 ; return (env1, WpLam id') }
@@ -584,17 +624,10 @@ zonkDo env do_or_lc      = do_or_lc
 
 -------------------------------------------------------------------------
 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
-zonkOverLit env ol = 
-    let 
-        zonkedStuff = do ty' <- zonkTcTypeToType env (overLitType ol)
-                         e' <- zonkExpr env (overLitExpr ol)
-                         return (e', ty')
-        ru f (x, y) = return (f x y)
-    in
-      case ol of 
-        (HsIntegral i _ _)   -> ru (HsIntegral i) =<< zonkedStuff
-        (HsFractional r _ _) -> ru (HsFractional r) =<< zonkedStuff
-        (HsIsString s _ _)   -> ru (HsIsString s) =<< zonkedStuff
+zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
+  = do	{ ty' <- zonkTcTypeToType env ty
+	; e' <- zonkExpr env e
+ 	; return (lit { ol_witness = e', ol_type = ty' }) }
 
 -------------------------------------------------------------------------
 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
@@ -1022,10 +1055,10 @@ mkArbitraryType warn tv
     (args,res) = splitKindFunTys kind
     tup_tc     = tupleTyCon Boxed (length args)
 		
-    msg = vcat [ hang (ptext SLIT("Inventing strangely-kinded Any TyCon"))
-		    2 (ptext SLIT("of kind") <+> quotes (ppr kind))
-	       , nest 2 (ptext SLIT("from an instantiation of type variable") <+> quotes (ppr tv))
-	       , ptext SLIT("This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv)
-	       , nest 2 (ptext SLIT("but is harmless without -O (and usually harmless anyway)."))
-	       , ptext SLIT("See http://hackage.haskell.org/trac/ghc/ticket/959 for details")  ]
+    msg = vcat [ hang (ptext (sLit "Inventing strangely-kinded Any TyCon"))
+		    2 (ptext (sLit "of kind") <+> quotes (ppr kind))
+	       , nest 2 (ptext (sLit "from an instantiation of type variable") <+> quotes (ppr tv))
+	       , ptext (sLit "This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv)
+	       , nest 2 (ptext (sLit "but is harmless without -O (and usually harmless anyway)."))
+	       , ptext (sLit "See http://hackage.haskell.org/trac/ghc/ticket/959 for details")  ]
 \end{code}