X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fprelude%2FPrelRules.lhs;h=d3657f54e10cbb9e9b88e9d3de3cc93a19ac311f;hb=8407d75daa79566600c8c3f329792ae3a3810f84;hp=165d0088a7fea16d4789f77d0a23f26a083ea8a6;hpb=5943ce90c9c9d4319eec3cfe1fb3315f018e1c45;p=ghc-hetmet.git

diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 165d008..d3657f5 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -15,6 +15,13 @@ ToDo:
 
 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
 
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module PrelRules ( primOpRules, builtinRules ) where
 
 #include "HsVersions.h"
@@ -28,7 +35,7 @@ import Literal		( Literal(..), mkMachInt, mkMachWord
 			, narrow8WordLit, narrow16WordLit, narrow32WordLit
 			, char2IntLit, int2CharLit
 			, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
-			, float2DoubleLit, double2FloatLit
+			, float2DoubleLit, double2FloatLit, litFitsInChar
 			)
 import PrimOp		( PrimOp(..), tagToEnumKey )
 import TysWiredIn	( boolTy, trueDataConId, falseDataConId )
@@ -119,7 +126,7 @@ primOpRules op op_name = primop_rule op
     primop_rule Narrow16WordOp 	= one_lit (litCoerce narrow16WordLit)
     primop_rule Narrow32WordOp 	= one_lit (litCoerce narrow32WordLit)
     primop_rule OrdOp   	= one_lit (litCoerce char2IntLit)
-    primop_rule ChrOp    	= one_lit (litCoerce int2CharLit)
+    primop_rule ChrOp    	= one_lit (predLitCoerce litFitsInChar int2CharLit)
     primop_rule Float2IntOp	= one_lit (litCoerce float2IntLit)
     primop_rule Int2FloatOp	= one_lit (litCoerce int2FloatLit)
     primop_rule Double2IntOp	= one_lit (litCoerce double2IntLit)
@@ -199,6 +206,11 @@ so this could be cleaned up.
 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
 litCoerce fn lit = Just (Lit (fn lit))
 
+predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr
+predLitCoerce p fn lit
+   | p lit     = Just (Lit (fn lit))
+   | otherwise = Nothing
+
 --------------------------
 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
 cmpOp cmp l1 l2
@@ -316,7 +328,7 @@ litEq :: Name
       -> [CoreRule]
 litEq op_name is_eq
   = [BuiltinRule { ru_name = occNameFS (nameOccName op_name) 
-				`appendFS` FSLIT("->case"),
+				`appendFS` (fsLit "->case"),
 		   ru_fn = op_name, 
 		   ru_nargs = 2, ru_try = rule_fn }]
   where
@@ -476,11 +488,11 @@ are explicit.)
 builtinRules :: [CoreRule]
 -- Rules for non-primops that can't be expressed using a RULE pragma
 builtinRules
-  = [ BuiltinRule { ru_name = FSLIT("AppendLitString"), ru_fn = unpackCStringFoldrName,
+  = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName,
 		    ru_nargs = 4, ru_try = match_append_lit },
-      BuiltinRule { ru_name = FSLIT("EqString"), ru_fn = eqStringName,
+      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
 		    ru_nargs = 2, ru_try = match_eq_string },
-      BuiltinRule { ru_name = FSLIT("Inline"), ru_fn = inlineIdName,
+      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
 		    ru_nargs = 2, ru_try = match_inline }
     ]