Commit 1bba522f authored by simonpj's avatar simonpj

[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
parent a8e1967f
......@@ -31,7 +31,7 @@ module RdrName (
#include "HsVersions.h"
import OccName ( NameSpace, tcName,
OccName,
OccName, UserFS,
mkSysOccFS,
mkSrcOccFS, mkSrcVarOcc,
isDataOcc, isTvOcc, mkWorkerOcc
......@@ -89,8 +89,8 @@ mkRdrQual mod occ = RdrName (Qual mod) occ
mkSrcUnqual :: NameSpace -> FAST_STRING -> RdrName
mkSrcUnqual sp n = RdrName Unqual (mkSrcOccFS sp n)
mkSrcQual :: NameSpace -> FAST_STRING -> FAST_STRING -> RdrName
mkSrcQual sp m n = RdrName (Qual (mkSrcModuleFS m)) (mkSrcOccFS sp n)
mkSrcQual :: NameSpace -> (UserFS, UserFS) -> RdrName
mkSrcQual sp (m, n) = RdrName (Qual (mkSrcModuleFS m)) (mkSrcOccFS sp n)
-- These two are used when parsing interface files
-- They do not encode the module and occurrence name
......
......@@ -77,6 +77,7 @@ module Unique (
enumFromToClassOpKey,
eqClassKey,
eqClassOpKey,
eqStringIdKey,
errorIdKey,
falseDataConKey,
failMClassOpKey,
......@@ -141,6 +142,7 @@ module Unique (
parErrorIdKey,
parIdKey,
patErrorIdKey,
plusIntegerIdKey,
ratioDataConKey,
ratioTyConKey,
rationalTyConKey,
......@@ -167,6 +169,7 @@ module Unique (
stableNameTyConKey,
statePrimTyConKey,
timesIntegerIdKey,
typeConKey,
kindConKey,
boxityConKey,
......@@ -599,8 +602,7 @@ stablePtrDataConKey = mkPreludeDataConUnique 12
stableNameDataConKey = mkPreludeDataConUnique 13
trueDataConKey = mkPreludeDataConUnique 14
wordDataConKey = mkPreludeDataConUnique 15
stDataConKey = mkPreludeDataConUnique 16
ioDataConKey = mkPreludeDataConUnique 17
ioDataConKey = mkPreludeDataConUnique 16
\end{code}
%************************************************************************
......@@ -625,7 +627,7 @@ integerZeroIdKey = mkPreludeMiscIdUnique 12
int2IntegerIdKey = mkPreludeMiscIdUnique 13
addr2IntegerIdKey = mkPreludeMiscIdUnique 14
irrefutPatErrorIdKey = mkPreludeMiscIdUnique 15
lexIdKey = mkPreludeMiscIdUnique 16
eqStringIdKey = mkPreludeMiscIdUnique 16
noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 17
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 18
parErrorIdKey = mkPreludeMiscIdUnique 20
......@@ -649,6 +651,8 @@ returnIOIdKey = mkPreludeMiscIdUnique 37
deRefStablePtrIdKey = mkPreludeMiscIdUnique 38
makeStablePtrIdKey = mkPreludeMiscIdUnique 39
getTagIdKey = mkPreludeMiscIdUnique 40
plusIntegerIdKey = mkPreludeMiscIdUnique 41
timesIntegerIdKey = mkPreludeMiscIdUnique 42
\end{code}
Certain class operations from Prelude classes. They get their own
......
......@@ -173,6 +173,10 @@ newMutTyVar :: Name -> Kind -> IO TyVar
newMutTyVar name kind = newTyVar name kind False
newSigTyVar :: Name -> Kind -> IO TyVar
-- Type variables from type signatures are still mutable, because
-- they may get unified with type variables from other signatures
-- But they do contain a flag to distinguish them, so we can tell if
-- we unify them with a non-type-variable.
newSigTyVar name kind = newTyVar name kind True
newTyVar name kind is_sig
......
......@@ -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
......
......@@ -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,
......
......@@ -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}
......@@ -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.
......
......@@ -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}
......
......@@ -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)