[project @ 2000-09-22 15:56:12 by simonpj]

--------------------------------------------------
	Tidying up HsLit, and making it possible to define
		your own numeric library

		Simon PJ 22 Sept 00
	--------------------------------------------------

** NOTE: I did these changes on the aeroplane.  They should compile,
	 and the Prelude still compiles OK, but it's entirely 
	 possible that I've broken something

The original reason for this many-file but rather shallow
commit is that it's impossible in Haskell to write your own
numeric library.  Why?  Because when you say '1' you get 
(Prelude.fromInteger 1), regardless of what you hide from the
Prelude, or import from other libraries you have written.  So the
idea is to extend the -fno-implicit-prelude flag so that 
in addition to no importing the Prelude, you can rebind 
	fromInteger	-- Applied to literal constants
	fromRational	-- Ditto
	negate		-- Invoked by the syntax (-x)
	the (-) used when desugaring n+k patterns

After toying with other designs, I eventually settled on a simple,
crude one: rather than adding a new flag, I just extended the
semantics of -fno-implicit-prelude so that uses of fromInteger,
fromRational and negate are all bound to "whatever is in scope" 
rather than "the fixed Prelude functions".  So if you say

	{-# OPTIONS -fno-implicit-prelude #-}
	module M where
 	import MyPrelude( fromInteger )

	x = 3

the literal 3 will use whatever (unqualified) "fromInteger" is in scope,
in this case the one gotten from MyPrelude.


On the way, though, I studied how HsLit worked, and did a substantial tidy
up, deleting quite a lot of code along the way.  In particular.

* HsBasic.lhs is renamed HsLit.lhs.  It defines the HsLit type.

* There are now two HsLit types, both defined in HsLit.
	HsLit for non-overloaded literals (like 'x')
	HsOverLit for overloaded literals (like 1 and 2.3)

* HsOverLit completely replaces Inst.OverloadedLit, which disappears.
  An HsExpr can now be an HsOverLit as well as an HsLit.

* HsOverLit carries the Name of the fromInteger/fromRational operation,
  so that the renamer can help with looking up the unqualified name 
  when -fno-implicit-prelude is on.  Ditto the HsExpr for negation.
  It's all very tidy now.

* RdrHsSyn contains the stuff that handles -fno-implicit-prelude
  (see esp RdrHsSyn.prelQual).  RdrHsSyn also contains all the "smart constructors"
  used by the parser when building HsSyn.  See for example RdrHsSyn.mkNegApp
  (previously the renamer (!) did the business of turning (- 3#) into -3#).

* I tidied up the handling of "special ids" in the parser.  There's much
  less duplication now.

* Move Sven's Horner stuff to the desugarer, where it belongs.  
  There's now a nice function DsUtils.mkIntegerLit which brings together
  related code from no fewer than three separate places into one single
  place.  Nice!

* A nice tidy-up in MatchLit.partitionEqnsByLit became possible.

* Desugaring of HsLits is now much tidier (DsExpr.dsLit)

* Some stuff to do with RdrNames is moved from ParseUtil.lhs to RdrHsSyn.lhs,
  which is where it really belongs.

* I also removed 
	many unnecessary imports from modules 
	quite a bit of dead code
  in divers places

7 files changed, 192 insertions, 254 deletions

diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs
index 45a1ad8fcd..c9c978158b 100644
--- a/ghc/compiler/deSugar/Check.lhs
+++ b/ghc/compiler/deSugar/Check.lhs
@@ -13,21 +13,14 @@ module Check ( check , ExhaustivePat ) where
 import HsSyn		
 import TcHsSyn		( TypecheckedPat )
 import DsHsSyn		( outPatType ) 
-import CoreSyn		
-
-import DsUtils		( EquationInfo(..),
-			  MatchResult(..),
-			  EqnSet,
-			  CanItFail(..),
+import DsUtils		( EquationInfo(..), MatchResult(..), EqnSet, CanItFail(..),
 			  tidyLitPat
  			)
 import Id		( idType )
 import DataCon		( DataCon, dataConTyCon, dataConArgTys,
 			  dataConSourceArity, dataConFieldLabels )
 import Name             ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkSrcVarOcc )
-import Type		( Type, splitAlgTyConApp, mkTyVarTys,
-                          splitTyConApp_maybe
-			)
+import Type		( splitAlgTyConApp, mkTyVarTys, splitTyConApp_maybe )
 import TysWiredIn	( nilDataCon, consDataCon, 
                           mkListTy, mkTupleTy, tupleCon
 			)
@@ -151,13 +144,7 @@ untidy b (ConOpPatIn pat1 name fixity pat2) =
 untidy _ (ListPatIn pats)  = ListPatIn (map untidy_no_pars pats) 
 untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
 
-untidy _ (SigPatIn pat ty)      = panic "Check.untidy: SigPatIn"
-untidy _ (LazyPatIn pat)        = panic "Check.untidy: LazyPatIn"
-untidy _ (AsPatIn name pat)     = panic "Check.untidy: AsPatIn"
-untidy _ (NPlusKPatIn name lit) = panic "Check.untidy: NPlusKPatIn"
-untidy _ (NegPatIn ipat)        = panic "Check.untidy: NegPatIn"
-untidy _ (ParPatIn pat)         = panic "Check.untidy: ParPatIn"
-untidy _ (RecPatIn name fields) = panic "Check.untidy: RecPatIn"
+untidy _ pat = pprPanic "Check.untidy: SigPatIn" (ppr pat)
 
 pars :: NeedPars -> WarningPat -> WarningPat
 pars True p = ParPatIn p
@@ -625,8 +612,8 @@ simplify_pat (RecPat dc ty ex_tvs dicts idps)
       | nm == n    = (nm,p):xs
       | otherwise  = x : insertNm nm p xs
 
-simplify_pat pat@(LitPat lit lit_ty)        = tidyLitPat lit lit_ty pat
-simplify_pat pat@(NPat   lit lit_ty hsexpr) = tidyLitPat lit lit_ty pat
+simplify_pat pat@(LitPat lit lit_ty)        = tidyLitPat lit pat
+simplify_pat pat@(NPat   lit lit_ty hsexpr) = tidyLitPat lit pat
 
 simplify_pat (NPlusKPat	id hslit ty hsexpr1 hsexpr2) = 
      WildPat ty
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 98af452779..546c80e66b 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -24,14 +24,12 @@ import DsGRHSs		( dsGuarded )
 import DsUtils
 import Match		( matchWrapper )
 
-import CmdLineOpts	( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, 
-			  opt_AutoSccsOnExportedToplevs, opt_AutoSccsOnDicts
-		        )
-import CostCentre	( CostCentre, mkAutoCC, IsCafCC(..) )
+import CmdLineOpts	( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
+import CostCentre	( mkAutoCC, IsCafCC(..) )
 import Id		( idType, idName, isUserExportedId, isSpecPragmaId, Id )
 import NameSet
 import VarSet
-import Type		( mkTyVarTy, isDictTy )
+import Type		( mkTyVarTy )
 import Subst		( mkTyVarSubst, substTy )
 import TysWiredIn	( voidTy )
 import Outputable
@@ -200,7 +198,7 @@ addAutoScc :: AutoScc		-- if needs be, decorate toplevs?
 	   -> DsM (Id, CoreExpr)
 
 addAutoScc (TopLevelAddSccs auto_scc_fn) pair@(bndr, core_expr) 
- | do_auto_scc && worthSCC core_expr
+ | do_auto_scc
      = getModuleDs `thenDs` \ mod ->
        returnDs (bndr, mkSCC (mkAutoCC top_bndr mod NotCafCC) core_expr)
  where do_auto_scc = isJust maybe_auto_scc
@@ -209,9 +207,6 @@ addAutoScc (TopLevelAddSccs auto_scc_fn) pair@(bndr, core_expr)
 
 addAutoScc _ pair
      = returnDs pair
-
-noUserSCC (Note (SCC _) _) = False
-worthSCC core_expr         = True
 \end{code}
 
 If profiling and dealing with a dict binding,
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 7dfb84a1aa..6e2efa0788 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -26,28 +26,25 @@ import DsGRHSs		( dsGuarded )
 import DsCCall		( dsCCall, resultWrapper )
 import DsListComp	( dsListComp )
 import DsUtils		( mkErrorAppDs, mkDsLets, mkStringLit, mkStringLitFS, 
-			  mkConsExpr, mkNilExpr
+			  mkConsExpr, mkNilExpr, mkIntegerLit
 			)
 import Match		( matchWrapper, matchSimply )
 
 import CostCentre	( mkUserCC )
 import Id		( Id, idType, recordSelectorFieldLabel )
 import PrelInfo		( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
-import DataCon		( DataCon, dataConWrapId, dataConTyCon, dataConArgTys, dataConFieldLabels )
+import DataCon		( DataCon, dataConWrapId, dataConArgTys, dataConFieldLabels )
 import DataCon		( isExistentialDataCon )
-import Literal		( Literal(..), inIntRange )
+import Literal		( Literal(..) )
 import Type		( splitFunTys,
 			  splitAlgTyConApp, splitAlgTyConApp_maybe, splitTyConApp_maybe, 
 			  isNotUsgTy, unUsgTy,
 			  splitAppTy, isUnLiftedType, Type
 			)
-import TysWiredIn	( tupleCon, listTyCon,
-			  charDataCon, charTy, stringTy,
-			  smallIntegerDataCon, isIntegerTy
-			)
+import TysWiredIn	( tupleCon, listTyCon, charDataCon, intDataCon, isIntegerTy )
 import BasicTypes	( RecFlag(..), Boxity(..) )
 import Maybes		( maybeToBool )
-import Unique		( hasKey, ratioTyConKey, addr2IntegerIdKey )
+import Unique		( hasKey, ratioTyConKey )
 import Util		( zipEqual, zipWithEqual )
 import Outputable
 
@@ -111,102 +108,17 @@ dsLet (MonoBind binds sigs is_rec) body
 
 %************************************************************************
 %*									*
-\subsection[DsExpr-vars-and-cons]{Variables and constructors}
+\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
 %*									*
 %************************************************************************
 
 \begin{code}
 dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
 
-dsExpr e@(HsVar var) = returnDs (Var var)
-dsExpr e@(HsIPVar var) = returnDs (Var var)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[DsExpr-literals]{Literals}
-%*									*
-%************************************************************************
-
-We give int/float literals type @Integer@ and @Rational@, respectively.
-The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
-around them.
-
-ToDo: put in range checks for when converting ``@i@''
-(or should that be in the typechecker?)
-
-For numeric literals, we try to detect there use at a standard type
-(@Int@, @Float@, etc.) are directly put in the right constructor.
-[NB: down with the @App@ conversion.]
-
-See also below where we look for @DictApps@ for \tr{plusInt}, etc.
-
-\begin{code}
-dsExpr (HsLitOut (HsString s) _)
-  | _NULL_ s
-  = returnDs (mkNilExpr charTy)
-
-  | _LENGTH_ s == 1
-  = let
-	the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_INT_ s))]
-	the_nil  = mkNilExpr charTy
-	the_cons = mkConsExpr charTy the_char the_nil
-    in
-    returnDs the_cons
-
-
--- "_" => build (\ c n -> c 'c' n)	-- LATER
-
-dsExpr (HsLitOut (HsString str) _)
-  = mkStringLitFS str
-
-dsExpr (HsLitOut (HsLitLit str) ty)
-  = ASSERT( maybeToBool maybe_ty )
-    returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
-  where
-    (maybe_ty, wrap_fn) = resultWrapper ty
-    Just rep_ty 	= maybe_ty
-
-dsExpr (HsLitOut (HsInt i) ty)
-  = mkIntegerLit i
-
-
-dsExpr (HsLitOut (HsFrac r) ty)
-  = mkIntegerLit (numerator r)		`thenDs` \ num ->
-    mkIntegerLit (denominator r)	`thenDs` \ denom ->
-    returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
-  where
-    (ratio_data_con, integer_ty)
-      = case (splitAlgTyConApp_maybe ty) of
-	  Just (tycon, [i_ty], [con])
-	    -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
-	       (con, i_ty)
-
-	  _ -> (panic "ratio_data_con", panic "integer_ty")
-
-
--- others where we know what to do:
-
-dsExpr (HsLitOut (HsIntPrim i) _) 
-  = returnDs (mkIntLit i)
-
-dsExpr (HsLitOut (HsFloatPrim f) _)
-  = returnDs (mkLit (MachFloat f))
-
-dsExpr (HsLitOut (HsDoublePrim d) _)
-  = returnDs (mkLit (MachDouble d))
-    -- ToDo: range checking needed!
-
-dsExpr (HsLitOut (HsChar c) _)
-  = returnDs ( mkConApp charDataCon [mkLit (MachChar c)] )
-
-dsExpr (HsLitOut (HsCharPrim c) _)
-  = returnDs (mkLit (MachChar c))
-
-dsExpr (HsLitOut (HsStringPrim s) _)
-  = returnDs (mkLit (MachStr s))
-
--- end of literals magic. --
+dsExpr (HsVar var)	 = returnDs (Var var)
+dsExpr (HsIPVar var)     = returnDs (Var var)
+dsExpr (HsLit lit)       = dsLit lit
+-- HsOverLit has been gotten rid of by the type checker
 
 dsExpr expr@(HsLam a_Match)
   = matchWrapper LambdaMatch [a_Match] "lambda"	`thenDs` \ (binders, matching_code) ->
@@ -619,7 +531,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
 	    let
 		(_, a_ty)  = splitAppTy (exprType expr2) -- Must be of form (m a)
 		fail_expr  = HsApp (TyApp (HsVar fail_id) [b_ty])
-                                   (HsLitOut (HsString (_PK_ msg)) stringTy)
+                                   (HsLit (HsString (_PK_ msg)))
 	        msg = ASSERT2( isNotUsgTy a_ty, ppr a_ty )
                       ASSERT2( isNotUsgTy b_ty, ppr b_ty )
                       "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
@@ -649,20 +561,57 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
 			ListComp -> "comprehension"
 \end{code}
 
-\begin{code}
-var_pat (WildPat _) = True
-var_pat (VarPat _) = True
-var_pat _ = False
-\end{code}
+
+%************************************************************************
+%*									*
+\subsection[DsExpr-literals]{Literals}
+%*									*
+%************************************************************************
+
+We give int/float literals type @Integer@ and @Rational@, respectively.
+The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
+around them.
+
+ToDo: put in range checks for when converting ``@i@''
+(or should that be in the typechecker?)
+
+For numeric literals, we try to detect there use at a standard type
+(@Int@, @Float@, etc.) are directly put in the right constructor.
+[NB: down with the @App@ conversion.]
+
+See also below where we look for @DictApps@ for \tr{plusInt}, etc.
 
 \begin{code}
-mkIntegerLit :: Integer -> DsM CoreExpr
-mkIntegerLit i
-  | inIntRange i  	-- Small enough, so start from an Int
-  = returnDs (mkConApp smallIntegerDataCon [mkIntLit i])
-
-  | otherwise 		-- Big, so start from a string
-  = dsLookupGlobalValue addr2IntegerIdKey	`thenDs` \ addr2IntegerId ->
-    returnDs (App (Var addr2IntegerId) (Lit (MachStr (_PK_ (show i)))))
+dsLit :: HsLit -> DsM CoreExpr
+dsLit (HsChar c)       = returnDs (mkConApp charDataCon [mkLit (MachChar c)])
+dsLit (HsCharPrim c)   = returnDs (mkLit (MachChar c))
+dsLit (HsString str)   = mkStringLitFS str
+dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
+dsLit (HsInteger i)    = mkIntegerLit i
+dsLit (HsInt i)	       = returnDs (mkConApp intDataCon [mkIntLit i])
+dsLit (HsIntPrim i)    = returnDs (mkIntLit i)
+dsLit (HsFloatPrim f)  = returnDs (mkLit (MachFloat f))
+dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
+dsLit (HsLitLit str ty)
+  = ASSERT( maybeToBool maybe_ty )
+    returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
+  where
+    (maybe_ty, wrap_fn) = resultWrapper ty
+    Just rep_ty 	= maybe_ty
+
+dsLit (HsRat r ty)
+  = mkIntegerLit (numerator r)		`thenDs` \ num ->
+    mkIntegerLit (denominator r)	`thenDs` \ denom ->
+    returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
+  where
+    (ratio_data_con, integer_ty)
+      = case (splitAlgTyConApp_maybe ty) of
+	  Just (tycon, [i_ty], [con])
+	    -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+	       (con, i_ty)
+
+	  _ -> (panic "ratio_data_con", panic "integer_ty")
 \end{code}
 
+
+
diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index 9c2557ffb6..31e4428871 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -13,13 +13,13 @@ import {-# SOURCE #-} Match   ( matchSinglePat )
 
 import HsSyn		( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..) )
 import TcHsSyn		( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt )
-import CoreSyn		( CoreExpr, Bind(..) )
+import CoreSyn		( CoreExpr )
 import Type		( Type )
 
 import DsMonad
 import DsUtils
 import PrelInfo		( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
-import Unique		( otherwiseIdKey, trueDataConKey, hasKey, Uniquable(..) )
+import Unique		( otherwiseIdKey, trueDataConKey, hasKey )
 \end{code}
 
 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 2221c26089..28a739c376 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -10,7 +10,7 @@ module DsUtils (
 	CanItFail(..), EquationInfo(..), MatchResult(..),
         EqnNo, EqnSet,
 
-	tidyLitPat, 
+	tidyLitPat, tidyNPat,
 
 	mkDsLet, mkDsLets,
 
@@ -21,7 +21,7 @@ module DsUtils (
 	mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
 
 	mkErrorAppDs, mkNilExpr, mkConsExpr,
-	mkStringLit, mkStringLitFS,
+	mkStringLit, mkStringLitFS, mkIntegerLit, 
 
 	mkSelectorBinds, mkTupleExpr, mkTupleSelector,
 
@@ -42,7 +42,7 @@ import DsMonad
 import CoreUtils	( exprType, mkIfThenElse )
 import PrelInfo		( iRREFUT_PAT_ERROR_ID )
 import Id		( idType, Id, mkWildId )
-import Literal		( Literal(..) )
+import Literal		( Literal(..), inIntRange, tARGET_MAX_INT )
 import TyCon		( isNewTyCon, tyConDataCons )
 import DataCon		( DataCon, StrictnessMark, maybeMarkedUnboxed, 
 			  dataConStrictMarks, dataConId, splitProductType_maybe
@@ -50,27 +50,21 @@ import DataCon		( DataCon, StrictnessMark, maybeMarkedUnboxed,
 import Type		( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy,
 			  Type
 			)
-import TysPrim		( intPrimTy, 
-                          charPrimTy, 
-                          floatPrimTy, 
-                          doublePrimTy,
-			  addrPrimTy, 
-                          wordPrimTy
-			)
+import TysPrim		( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy )
 import TysWiredIn	( nilDataCon, consDataCon, 
                           tupleCon,
 			  stringTy,
 			  unitDataConId, unitTy,
                           charTy, charDataCon, 
-                          intTy, intDataCon,
+                          intTy, intDataCon, smallIntegerDataCon, 
 			  floatTy, floatDataCon, 
-                          doubleTy, doubleDataCon, 
-                          addrTy, addrDataCon,
-                          wordTy, wordDataCon
+                          doubleTy, doubleDataCon,
+			  stringTy
 			)
 import BasicTypes	( Boxity(..) )
 import UniqSet		( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
-import Unique		( unpackCStringIdKey, unpackCStringUtf8IdKey )
+import Unique		( unpackCStringIdKey, unpackCStringUtf8IdKey, 
+			  plusIntegerIdKey, timesIntegerIdKey )
 import Outputable
 import UnicodeUtil      ( stringToUtf8 )
 \end{code}
@@ -84,46 +78,34 @@ import UnicodeUtil      ( stringToUtf8 )
 %************************************************************************
 
 \begin{code}
-tidyLitPat lit lit_ty default_pat
-  | lit_ty == charTy      = ConPat charDataCon   lit_ty [] [] [LitPat (mk_char lit)   charPrimTy]
-  | lit_ty == intTy    	  = ConPat intDataCon    lit_ty [] [] [LitPat (mk_int lit)    intPrimTy]
-  | lit_ty == wordTy   	  = ConPat wordDataCon   lit_ty [] [] [LitPat (mk_word lit)   wordPrimTy]
-  | lit_ty == addrTy   	  = ConPat addrDataCon   lit_ty [] [] [LitPat (mk_addr lit)   addrPrimTy]
-  | lit_ty == floatTy  	  = ConPat floatDataCon  lit_ty [] [] [LitPat (mk_float lit)  floatPrimTy]
-  | lit_ty == doubleTy 	  = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
-
-	-- Convert short string-literal patterns like "f" to 'f':[]
-  | str_lit lit           = mk_list lit
-
-  | otherwise = default_pat
-
+tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat
+tidyLitPat (HsChar c) pat = ConPat charDataCon   charTy [] [] [LitPat (HsCharPrim c)   charPrimTy]
+tidyLitPat lit        pat = pat
+
+tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat
+tidyNPat (HsString s) _ pat
+  | _LENGTH_ s <= 1	-- Short string literals only
+  = foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
+	  (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s)
+	-- The stringTy is the type of the whole pattern, not 
+	-- the type to instantiate (:) or [] with!
   where
-    mk_int    (HsInt i)      = HsIntPrim i
-    mk_int    l@(HsLitLit s) = l
-
-    mk_char   (HsChar c)     = HsCharPrim c
-    mk_char   l@(HsLitLit s) = l
-
-    mk_word   l@(HsLitLit s) = l
+    mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
 
-    mk_addr   l@(HsLitLit s) = l
+tidyNPat lit lit_ty default_pat
+  | lit_ty == intTy    	= ConPat intDataCon    lit_ty [] [] [LitPat (mk_int lit)    intPrimTy]
+  | lit_ty == floatTy  	= ConPat floatDataCon  lit_ty [] [] [LitPat (mk_float lit)  floatPrimTy]
+  | lit_ty == doubleTy 	= ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
+  | otherwise		= default_pat
 
-    mk_float  (HsInt i)      = HsFloatPrim (fromInteger i)
-    mk_float  (HsFrac f)     = HsFloatPrim f
-    mk_float  l@(HsLitLit s) = l
-
-    mk_double (HsInt i)      = HsDoublePrim (fromInteger i)
-    mk_double (HsFrac f)     = HsDoublePrim f
-    mk_double l@(HsLitLit s) = l
-
-    str_lit (HsString s)     = _LENGTH_ s <= 1	-- Short string literals only
-    str_lit _                = False
+  where
+    mk_int    (HsInteger i) = HsIntPrim i
 
-    mk_list (HsString s)     = foldr
-	(\c pat -> ConPat consDataCon lit_ty [] [] [mk_char_lit c,pat])
-	(ConPat nilDataCon lit_ty [] [] []) (_UNPK_INT_ s)
+    mk_float  (HsInteger i) = HsFloatPrim (fromInteger i)
+    mk_float  (HsRat f _)   = HsFloatPrim f
 
-    mk_char_lit c            = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
+    mk_double (HsInteger i) = HsDoublePrim (fromInteger i)
+    mk_double (HsRat f _)   = HsDoublePrim f
 \end{code}
 
 
@@ -382,20 +364,67 @@ mkErrorAppDs err_id ty msg
     mkStringLit full_msg		`thenDs` \ core_msg ->
     returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, core_msg])
     -- unUsgTy *required* -- KSW 1999-04-07
+\end{code}
+
+
+*************************************************************
+%*									*
+\subsection{Making literals}
+%*									*
+%************************************************************************
+
+\begin{code}
+mkIntegerLit :: Integer -> DsM CoreExpr
+mkIntegerLit i
+  | inIntRange i  	-- Small enough, so start from an Int
+  = returnDs (mkSmallIntegerLit i)
+
+-- Special case for integral literals with a large magnitude:
+-- They are transformed into an expression involving only smaller
+-- integral literals. This improves constant folding.
+
+  | otherwise 		-- Big, so start from a string
+  = dsLookupGlobalValue plusIntegerIdKey	`thenDs` \ plus_id ->
+    dsLookupGlobalValue timesIntegerIdKey	`thenDs` \ times_id ->
+    let 
+        plus a b  = Var plus_id  `App` a `App` b
+        times a b = Var times_id `App` a `App` b
+
+	-- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
+	horner :: Integer -> Integer -> CoreExpr
+	horner b i | abs q <= 1 = if r == 0 || r == i 
+				  then mkSmallIntegerLit i 
+				  else mkSmallIntegerLit r `plus` mkSmallIntegerLit (i-r)
+	           | r == 0     =                   	      horner b q `times` mkSmallIntegerLit b
+	           | otherwise  = mkSmallIntegerLit r `plus` (horner b q `times` mkSmallIntegerLit b)
+  		   where
+		     (q,r) = i `quotRem` b
+
+    in
+    returnDs (horner tARGET_MAX_INT i)
+
+mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i]
 
 mkStringLit   :: String       -> DsM CoreExpr
 mkStringLit str	= mkStringLitFS (_PK_ str)
 
 mkStringLitFS :: FAST_STRING  -> DsM CoreExpr
 mkStringLitFS str
+  | _NULL_ str
+  = returnDs (mkNilExpr charTy)
+
+  | _LENGTH_ str == 1
+  = let
+	the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_INT_ str))]
+    in
+    returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
+
   | all safeChar chars
-  =
-    dsLookupGlobalValue unpackCStringIdKey	`thenDs` \ unpack_id ->
+  = dsLookupGlobalValue unpackCStringIdKey	`thenDs` \ unpack_id ->
     returnDs (App (Var unpack_id) (Lit (MachStr str)))
 
   | otherwise
-  =
-    dsLookupGlobalValue unpackCStringUtf8IdKey	`thenDs` \ unpack_id ->
+  = dsLookupGlobalValue unpackCStringUtf8IdKey	`thenDs` \ unpack_id ->
     returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
 
   where
@@ -403,6 +432,7 @@ mkStringLitFS str
     safeChar c = c >= 1 && c <= 0xFF
 \end{code}
 
+
 %************************************************************************
 %*									*
 \subsection[mkSelectorBind]{Make a selector bind}
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index 5fd2b0db25..7f6136af14 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -505,17 +505,13 @@ tidy1 v (DictPat dicts methods) match_result
     num_of_d_and_ms	 = length dicts + length methods
     dict_and_method_pats = map VarPat (dicts ++ methods)
 
-
--- deeply ugly mangling for some (common) NPats/LitPats
-
--- LitPats: the desugarer only sees these at well-known types
-
+-- LitPats: we *might* be able to replace these w/ a simpler form
 tidy1 v pat@(LitPat lit lit_ty) match_result
-  = returnDs (tidyLitPat lit lit_ty pat, match_result)
+  = returnDs (tidyLitPat lit pat, match_result)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
 tidy1 v pat@(NPat lit lit_ty _) match_result
-  = returnDs (tidyLitPat lit lit_ty pat, match_result)
+  = returnDs (tidyNPat lit lit_ty pat, match_result)
 
 -- and everything else goes through unchanged...
 
diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs
index fd57f0dc40..308ca8fe98 100644
--- a/ghc/compiler/deSugar/MatchLit.lhs
+++ b/ghc/compiler/deSugar/MatchLit.lhs
@@ -12,6 +12,7 @@ import {-# SOURCE #-} Match  ( match )
 import {-# SOURCE #-} DsExpr ( dsExpr )
 
 import HsSyn		( HsLit(..), OutPat(..), HsExpr(..) )
+import TcHsSyn		( TypecheckedPat )
 import CoreSyn		( Expr(..), Bind(..) )
 import Id		( Id )
 
@@ -20,7 +21,7 @@ import DsUtils
 
 import Literal		( mkMachInt, Literal(..) )
 import Maybes		( catMaybes )
-import Type		( Type, isUnLiftedType )
+import Type		( isUnLiftedType )
 import Panic		( panic, assertPanic )
 \end{code}
 
@@ -47,10 +48,10 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_t
   where
     match_prims_used _ [{-no more eqns-}] = returnDs []
 
-    match_prims_used vars eqns_info@(EqnInfo n ctx ((LitPat literal lit_ty):ps1) _ : eqns)
+    match_prims_used vars eqns_info@(EqnInfo n ctx (pat@(LitPat literal lit_ty):ps1) _ : eqns)
       = let
 	    (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
-	      = partitionEqnsByLit Nothing literal eqns_info
+	      = partitionEqnsByLit pat eqns_info
 	in
 	-- recursive call to make other alts...
 	match_prims_used vars eqns_not_for_this_lit       `thenDs` \ rest_of_alts ->
@@ -59,28 +60,28 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_t
 	-- now do the business to make the alt for _this_ LitPat ...
 	match vars shifted_eqns_for_this_lit 	`thenDs` \ match_result ->
 	returnDs (
-	    (mk_core_lit lit_ty literal, match_result)
+	    (mk_core_lit literal, match_result)
 	    : rest_of_alts
 	)
       where
-	mk_core_lit :: Type -> HsLit -> Literal
-
-	mk_core_lit ty (HsIntPrim     i) = mkMachInt  i
-	mk_core_lit ty (HsCharPrim    c) = MachChar   c
-	mk_core_lit ty (HsStringPrim  s) = MachStr    s
-	mk_core_lit ty (HsFloatPrim   f) = MachFloat  f
-	mk_core_lit ty (HsDoublePrim  d) = MachDouble d
-	mk_core_lit ty (HsLitLit      s) = ASSERT(isUnLiftedType ty)
-				           MachLitLit s ty
-    	mk_core_lit ty other	         = panic "matchLiterals:mk_core_lit:unhandled"
+	mk_core_lit :: HsLit -> Literal
+
+	mk_core_lit (HsIntPrim     i) 	 = mkMachInt  i
+	mk_core_lit (HsCharPrim    c) 	 = MachChar   c
+	mk_core_lit (HsStringPrim  s) 	 = MachStr    s
+	mk_core_lit (HsFloatPrim   f) 	 = MachFloat  f
+	mk_core_lit (HsDoublePrim  d)    = MachDouble d
+	mk_core_lit (HsLitLit      s ty) = ASSERT(isUnLiftedType ty)
+		    		           MachLitLit s ty
+    	mk_core_lit other	         = panic "matchLiterals:mk_core_lit:unhandled"
 \end{code}
 
 \begin{code}
 matchLiterals all_vars@(var:vars)
-  eqns_info@(EqnInfo n ctx ((NPat literal lit_ty eq_chk):ps1) _ : eqns)
+  eqns_info@(EqnInfo n ctx (pat@(NPat literal lit_ty eq_chk):ps1) _ : eqns)
   = let
 	(shifted_eqns_for_this_lit, eqns_not_for_this_lit)
-	  = partitionEqnsByLit Nothing literal eqns_info
+	  = partitionEqnsByLit pat eqns_info
     in
     dsExpr (HsApp eq_chk (HsVar var))		`thenDs` \ pred_expr ->
     match vars shifted_eqns_for_this_lit        `thenDs` \ inner_match_result ->
@@ -107,10 +108,10 @@ We generate:
 
 
 \begin{code}
-matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx ((NPlusKPat master_n k ty ge sub):ps1) _ : eqns)
+matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (pat@(NPlusKPat master_n k ty ge sub):ps1) _ : eqns)
   = let
 	(shifted_eqns_for_this_lit, eqns_not_for_this_lit)
-	  = partitionEqnsByLit (Just master_n) k eqns_info
+	  = partitionEqnsByLit pat eqns_info
     in
     match vars shifted_eqns_for_this_lit	`thenDs` \ inner_match_result ->
 
@@ -135,10 +136,7 @@ that are ``same''/different as one we are looking at.  We need to know
 whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
 
 \begin{code}
-partitionEqnsByLit :: Maybe Id 	-- (Just v) for N-plus-K patterns, where v
-				-- is the "master" variable;
-				-- Nothing for NPats and LitPats
-		   -> HsLit
+partitionEqnsByLit :: TypecheckedPat
 		   -> [EquationInfo]
 		   -> ([EquationInfo], 	-- These ones are for this lit, AND
 					-- they've been "shifted" by stripping
@@ -147,51 +145,34 @@ partitionEqnsByLit :: Maybe Id 	-- (Just v) for N-plus-K patterns, where v
 					-- are exactly as fed in.
 		      )
 
-partitionEqnsByLit nPlusK lit eqns
+partitionEqnsByLit master_pat eqns
   = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys))
-	(unzip (map (partition_eqn nPlusK lit) eqns))
+	(unzip (map (partition_eqn master_pat) eqns))
   where
-    partition_eqn :: Maybe Id -> HsLit -> EquationInfo ->
-		(Maybe EquationInfo, Maybe EquationInfo)
+    partition_eqn :: TypecheckedPat -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo)
 
-    partition_eqn Nothing lit (EqnInfo n ctx (LitPat k _ : remaining_pats) match_result)
-      | lit `eq_lit` k  = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
+    partition_eqn (LitPat k1 _) (EqnInfo n ctx (LitPat k2 _ : remaining_pats) match_result)
+      | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
 			  -- NB the pattern is stripped off the EquationInfo
 
-    partition_eqn Nothing lit (EqnInfo n ctx (NPat k _ _ : remaining_pats) match_result)
-      | lit `eq_lit` k  = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
+    partition_eqn (NPat k1 _ _) (EqnInfo n ctx (NPat k2 _ _ : remaining_pats) match_result)
+      | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
 			  -- NB the pattern is stripped off the EquationInfo
 
-    partition_eqn (Just master_n) lit
-        (EqnInfo n ctx (NPlusKPat n' k _ _ _ : remaining_pats) match_result)
-      | lit `eq_lit` k  = (Just (EqnInfo n ctx remaining_pats new_match_result), Nothing)
+    partition_eqn (NPlusKPat master_n k1 _ _ _)
+ 	          (EqnInfo n ctx (NPlusKPat n' k2 _ _ _ : remaining_pats) match_result)
+      | k1 == k2 = (Just (EqnInfo n ctx remaining_pats new_match_result), Nothing)
 			  -- NB the pattern is stripped off the EquationInfo
       where
 	new_match_result | master_n == n' = match_result
 			 | otherwise 	  = mkCoLetsMatchResult
-			       [NonRec n' (Var master_n)] match_result
+					       [NonRec n' (Var master_n)] match_result
 
 	-- Wild-card patterns, which will only show up in the shadows,
         -- go into both groups
-    partition_eqn nPlusK lit
-                  eqn@(EqnInfo n ctx (WildPat _ : remaining_pats) match_result)
+    partition_eqn master_pat eqn@(EqnInfo n ctx (WildPat _ : remaining_pats) match_result)
 			= (Just (EqnInfo n ctx remaining_pats match_result), Just eqn)
 
 	-- Default case; not for this pattern
-    partition_eqn nPlusK lit eqn = (Nothing, Just eqn)
-
--- ToDo: meditate about this equality business...
-
-eq_lit (HsInt  i1)   	 (HsInt  i2)       = i1 == i2
-eq_lit (HsFrac f1) 	 (HsFrac f2)       = f1 == f2
-
-eq_lit (HsIntPrim i1)	 (HsIntPrim i2)    = i1 == i2
-eq_lit (HsFloatPrim f1)  (HsFloatPrim f2)  = f1 == f2
-eq_lit (HsDoublePrim d1) (HsDoublePrim d2) = d1 == d2
-eq_lit (HsChar c1) 	 (HsChar c2)       = c1 == c2
-eq_lit (HsCharPrim c1)	 (HsCharPrim c2)   = c1 == c2
-eq_lit (HsString s1)	 (HsString s2)     = s1 == s2
-eq_lit (HsStringPrim s1) (HsStringPrim s2) = s1 == s2
-eq_lit (HsLitLit s1)	 (HsLitLit s2)     = s1 == s2 -- ToDo: ??? (dubious)
-eq_lit other1	      	 other2		   = panic "matchLiterals:eq_lit"
+    partition_eqn master_pat eqn = (Nothing, Just eqn)
 \end{code}