diff options
| author | simonpj <unknown> | 2000-09-22 15:56:16 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 2000-09-22 15:56:16 +0000 |
| commit | 1bba522f5ec82c43abd2ba4e84127b9c915dd020 (patch) | |
| tree | 1a912e2e7f74da8abcca375d2559cb985af17544 /ghc/compiler | |
| parent | a8e1967fbb90eae923042827cef98a98d66d18e7 (diff) | |
| download | haskell-1bba522f5ec82c43abd2ba4e84127b9c915dd020.tar.gz | |
[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
Diffstat (limited to 'ghc/compiler')
52 files changed, 768 insertions, 1254 deletions
diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index df6fc9c8bb..5c0fc0a733 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -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 diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 7d9c03921d..97c99f8bb3 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -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 diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index 793cfc9954..72422f8c3d 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -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 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} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 81fac47ad9..0ed79e2078 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -21,7 +21,7 @@ module HsDecls ( #include "HsVersions.h" -- friends: -import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..), nullMonoBinds ) +import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..) ) import HsExpr ( HsExpr ) import HsPragmas ( DataPragmas, ClassPragmas ) import HsImpExp ( IE(..) ) @@ -29,7 +29,7 @@ import HsTypes import PprCore ( pprCoreRule ) import HsCore ( UfExpr(UfVar), UfBinder, IfaceSig(..), eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr ) import CoreSyn ( CoreRule(..) ) -import BasicTypes ( Fixity, NewOrData(..) ) +import BasicTypes ( NewOrData(..) ) import CallConv ( CallConv, pprCallConv ) import Name ( toRdrName ) diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index d431859400..829f9ab3c8 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -12,8 +12,8 @@ module HsExpr where import {-# SOURCE #-} HsMatches ( pprMatches, pprMatch, Match ) import HsBinds ( HsBinds(..) ) -import HsBasic ( HsLit ) -import BasicTypes ( Fixity(..), FixityDirection(..) ) +import HsLit ( HsLit, HsOverLit ) +import BasicTypes ( Fixity(..) ) import HsTypes ( HsType ) -- others: @@ -21,7 +21,7 @@ import Name ( Name, isLexSym ) import Outputable import PprType ( pprType, pprParendType ) import Type ( Type ) -import Var ( TyVar, Id ) +import Var ( TyVar ) import DataCon ( DataCon ) import CStrings ( CLabelString, pprCLabelString ) import BasicTypes ( Boxity, tupleParens ) @@ -36,11 +36,10 @@ import SrcLoc ( SrcLoc ) \begin{code} data HsExpr id pat - = HsVar id -- variable - | HsIPVar id -- implicit parameter - | HsLit HsLit -- literal - | HsLitOut HsLit -- TRANSLATION - Type -- (with its type) + = HsVar id -- variable + | HsIPVar id -- implicit parameter + | HsOverLit (HsOverLit id) -- Overloaded literals; eliminated by type checker + | HsLit HsLit -- Simple (non-overloaded) literals | HsLam (Match id pat) -- lambda | HsApp (HsExpr id pat) -- application @@ -61,7 +60,7 @@ data HsExpr id pat -- They are eventually removed by the type checker. | NegApp (HsExpr id pat) -- negated expr - (HsExpr id pat) -- the negate id (in a HsVar) + id -- the negate id (in a HsVar) | HsPar (HsExpr id pat) -- parenthesised expr @@ -216,10 +215,9 @@ ppr_expr (HsVar v) | isOperator v = parens (ppr v) | otherwise = ppr v -ppr_expr (HsIPVar v) = {- char '?' <> -} ppr v - -ppr_expr (HsLit lit) = ppr lit -ppr_expr (HsLitOut lit _) = ppr lit +ppr_expr (HsIPVar v) = {- char '?' <> -} ppr v +ppr_expr (HsLit lit) = ppr lit +ppr_expr (HsOverLit lit) = ppr lit ppr_expr (HsLam match) = hsep [char '\\', nest 2 (pprMatch (True,empty) match)] @@ -249,8 +247,7 @@ ppr_expr (OpApp e1 op fixity e2) | otherwise = char '`' <> ppr v <> char '`' -- Put it in backquotes if it's not an operator already -ppr_expr (NegApp e _) - = char '-' <+> pprParendExpr e +ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e ppr_expr (HsPar e) = parens (ppr_expr e) @@ -378,7 +375,7 @@ pprParendExpr expr in case expr of HsLit l -> ppr l - HsLitOut l _ -> ppr l + HsOverLit l -> ppr l HsVar _ -> pp_as_was HsIPVar _ -> pp_as_was diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 09494a1ad1..f28d443317 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -19,7 +19,7 @@ module HsPat ( #include "HsVersions.h" -- friends: -import HsBasic ( HsLit ) +import HsLit ( HsLit, HsOverLit ) import HsExpr ( HsExpr ) import HsTypes ( HsType ) import BasicTypes ( Fixity, Boxity, tupleParens ) @@ -27,7 +27,7 @@ import BasicTypes ( Fixity, Boxity, tupleParens ) -- others: import Var ( Id, TyVar ) import DataCon ( DataCon, dataConTyCon ) -import Name ( isDataSymOcc, getOccName, NamedThing ) +import Name ( Name, isDataSymOcc, getOccName, NamedThing ) import Maybes ( maybeToBool ) import Outputable import TyCon ( maybeTyConSingleCon ) @@ -52,12 +52,17 @@ data InPat name Fixity -- c.f. OpApp in HsExpr (InPat name) - | NPlusKPatIn name -- n+k pattern - HsLit + | NPatIn (HsOverLit name) + + | NPlusKPatIn name -- n+k pattern + (HsOverLit name) -- It'll always be an HsIntegral, but + -- we need those names to support -fuser-numerics + name -- Name for "-"; this supports -fuser-numerics + -- We don't do the same for >= because that isn't + -- affected by -fuser-numerics -- We preserve prefix negation and parenthesis for the precedence parser. - | NegPatIn (InPat name) -- negated pattern | ParPatIn (InPat name) -- parenthesised pattern | ListPatIn [InPat name] -- syntactic list @@ -74,13 +79,13 @@ data OutPat id | AsPat id -- as pattern (OutPat id) - | ListPat -- syntactic list - Type -- the type of the elements + | ListPat -- Syntactic list + Type -- The type of the elements [OutPat id] - | TuplePat [OutPat id] -- tuple + | TuplePat [OutPat id] -- Tuple Boxity - -- UnitPat is TuplePat [] + -- UnitPat is TuplePat [] | ConPat DataCon Type -- the type of the pattern @@ -90,31 +95,28 @@ data OutPat id -- ConOpPats are only used on the input side - | RecPat DataCon -- record constructor - Type -- the type of the pattern - [TyVar] -- Existentially bound type variables + | RecPat DataCon -- Record constructor + Type -- The type of the pattern + [TyVar] -- Existentially bound type variables [id] -- Ditto dictionaries [(Id, OutPat id, Bool)] -- True <=> source used punning | LitPat -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. HsLit - Type -- type of pattern + Type -- Type of pattern | NPat -- Used for *overloaded* literal patterns - HsLit -- the literal is retained so that + HsLit -- The literal is retained so that -- the desugarer can readily identify -- equations with identical literal-patterns - Type -- type of pattern, t - (HsExpr id (OutPat id)) - -- of type t -> Bool; detects match + -- Always HsInt, HsRat or HsString. + Type -- Type of pattern, t + (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match | NPlusKPat id - HsLit -- Same reason as for LitPat - -- (This could be an Integer, but then - -- it's harder to partitionEqnsByLit - -- in the desugarer.) - Type -- Type of pattern, t + Integer + Type -- Type of pattern, t (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match (HsExpr id (OutPat id)) -- Of type t -> t; subtracts k @@ -134,12 +136,17 @@ instance (Outputable name) => Outputable (InPat name) where pprInPat :: (Outputable name) => InPat name -> SDoc -pprInPat (WildPatIn) = char '_' -pprInPat (VarPatIn var) = ppr var -pprInPat (LitPatIn s) = ppr s -pprInPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty -pprInPat (LazyPatIn pat) = char '~' <> ppr pat -pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat]) +pprInPat (WildPatIn) = char '_' +pprInPat (VarPatIn var) = ppr var +pprInPat (LitPatIn s) = ppr s +pprInPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty +pprInPat (LazyPatIn pat) = char '~' <> ppr pat +pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat]) +pprInPat (ParPatIn pat) = parens (pprInPat pat) +pprInPat (ListPatIn pats) = brackets (interpp'SP pats) +pprInPat (TuplePatIn pats bx) = tupleParens bx (interpp'SP pats) +pprInPat (NPlusKPatIn n k _) = parens (hcat [ppr n, char '+', ppr k]) +pprInPat (NPatIn l) = ppr l pprInPat (ConPatIn c pats) | null pats = ppr c @@ -151,26 +158,6 @@ pprInPat (ConOpPatIn pat1 op fixity pat2) -- ToDo: use pprSym to print op (but this involves fiddling various -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) -pprInPat (NegPatIn pat) - = let - pp_pat = pprInPat pat - in - char '-' <> ( - case pat of - LitPatIn _ -> pp_pat - _ -> parens pp_pat - ) - -pprInPat (ParPatIn pat) - = parens (pprInPat pat) - -pprInPat (ListPatIn pats) - = brackets (interpp'SP pats) -pprInPat (TuplePatIn pats boxity) - = tupleParens boxity (interpp'SP pats) -pprInPat (NPlusKPatIn n k) - = parens (hcat [ppr n, char '+', ppr k]) - pprInPat (RecPatIn con rpats) = hsep [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))] where @@ -216,7 +203,7 @@ pprOutPat (RecPat con ty tvs dicts rpats) pprOutPat (LitPat l ty) = ppr l -- ToDo: print more pprOutPat (NPat l ty e) = ppr l -- ToDo: print more pprOutPat (NPlusKPat n k ty e1 e2) -- ToDo: print more - = parens (hcat [ppr n, char '+', ppr k]) + = parens (hcat [ppr n, char '+', integer k]) pprOutPat (DictPat dicts methods) = parens (sep [ptext SLIT("{-dict-}"), @@ -322,10 +309,10 @@ collect (LitPatIn _) bndrs = bndrs collect (SigPatIn pat _) bndrs = collect pat bndrs collect (LazyPatIn pat) bndrs = collect pat bndrs collect (AsPatIn a pat) bndrs = a : collect pat bndrs -collect (NPlusKPatIn n _) bndrs = n : bndrs +collect (NPlusKPatIn n _ _) bndrs = n : bndrs +collect (NPatIn _) bndrs = bndrs collect (ConPatIn c pats) bndrs = foldr collect bndrs pats collect (ConOpPatIn p1 c f p2) bndrs = collect p1 (collect p2 bndrs) -collect (NegPatIn pat) bndrs = collect pat bndrs collect (ParPatIn pat) bndrs = collect pat bndrs collect (ListPatIn pats) bndrs = foldr collect bndrs pats collect (TuplePatIn pats _) bndrs = foldr collect bndrs pats @@ -343,10 +330,10 @@ collect_pat (VarPatIn var) acc = acc collect_pat (LitPatIn _) acc = acc collect_pat (LazyPatIn pat) acc = collect_pat pat acc collect_pat (AsPatIn a pat) acc = collect_pat pat acc -collect_pat (NPlusKPatIn n _) acc = acc +collect_pat (NPatIn _) acc = acc +collect_pat (NPlusKPatIn n _ _) acc = acc collect_pat (ConPatIn c pats) acc = foldr collect_pat acc pats collect_pat (ConOpPatIn p1 c f p2) acc = collect_pat p1 (collect_pat p2 acc) -collect_pat (NegPatIn pat) acc = collect_pat pat acc collect_pat (ParPatIn pat) acc = collect_pat pat acc collect_pat (ListPatIn pats) acc = foldr collect_pat acc pats collect_pat (TuplePatIn pats _) acc = foldr collect_pat acc pats diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index bf722a508c..ad446c34fa 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -18,7 +18,7 @@ module HsSyn ( module HsDecls, module HsExpr, module HsImpExp, - module HsBasic, + module HsLit, module HsMatches, module HsPat, module HsTypes, @@ -34,7 +34,7 @@ import HsDecls import HsBinds import HsExpr import HsImpExp -import HsBasic +import HsLit import HsMatches import HsPat import HsTypes diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 678aaec080..a8da5dc1f1 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -8,15 +8,14 @@ module MkIface ( writeIface ) where #include "HsVersions.h" -import IO ( Handle, hPutStr, openFile, - hClose, hPutStrLn, IOMode(..) ) +import IO ( openFile, hClose, IOMode(..) ) import HsSyn import HsCore ( HsIdInfo(..), toUfExpr ) import RdrHsSyn ( RdrNameRuleDecl ) import HsPragmas ( DataPragmas(..), ClassPragmas(..) ) import HsTypes ( toHsTyVars ) -import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), +import BasicTypes ( Fixity(..), NewOrData(..), Version, bumpVersion, initialVersion, isLoopBreaker ) import RnMonad @@ -30,18 +29,18 @@ import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBindi import Var ( isId ) import VarSet import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks ) -import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..), InlinePragInfo(..), +import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..), CprInfo(..), CafInfo(..), inlinePragInfo, arityInfo, arityLowerBound, strictnessInfo, isBottomingStrictness, cafInfo, specInfo, cprInfo, occInfo, isNeverInlinePrag, - workerExists, workerInfo, WorkerInfo(..) + workerInfo, WorkerInfo(..) ) import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars ) import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars ) import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline ) -import Module ( moduleString, pprModule, pprModuleName, moduleUserString ) +import Module ( pprModuleName, moduleUserString ) import Name ( isLocallyDefined, isWiredInName, toRdrName, nameModule, Name, NamedThing(..) ) @@ -49,20 +48,17 @@ import OccName ( OccName, pprOccName ) import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize ) -import Class ( Class, classExtraBigSig ) -import FieldLabel ( fieldLabelName, fieldLabelType ) +import Class ( classExtraBigSig ) +import FieldLabel ( fieldLabelType ) import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, - deNoteType, classesToPreds, - Type, ThetaType, PredType(..), ClassContext + deNoteType, classesToPreds ) -import PprType -import Rules ( pprProtoCoreRule, ProtoCoreRule(..) ) +import Rules ( ProtoCoreRule(..) ) -import Bag ( bagToList, isEmptyBag ) -import Maybes ( catMaybes, maybeToBool ) +import Bag ( bagToList ) import UniqFM ( lookupUFM, listToUFM ) -import Util ( sortLt, mapAccumL ) +import Util ( sortLt ) import SrcLoc ( noSrcLoc ) import Bag import Outputable @@ -153,7 +149,7 @@ checkIface (Just iface) new_iface | otherwise -- Add updated version numbers = do { dumpIfSet opt_D_dump_hi_diffs "Interface file changes" pp_diffs ; - return (Just new_iface )} + return (Just final_iface )} where final_iface = new_iface { pi_vers = new_mod_vers, @@ -669,13 +665,6 @@ ifaceId get_idinfo is_rec id rhs find_fvs expr = exprSomeFreeVars interestingId expr - ------------ Sanity checking -------------- - -- The arity of a wrapper function should match its strictness, - -- or else an importing module will get very confused indeed. - arity_matches_strictness - = case work_info of - HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info - other -> True interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id) \end{code} diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index dffa2b79fb..eaaf83d41e 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -25,40 +25,24 @@ module ParseUtil ( -- , checkExpr -- HsExp -> P HsExp , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl - - - -- some built-in names (all :: RdrName) - , unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR - , tupleCon_RDR, tupleTyCon_RDR, ubxTupleCon_RDR, ubxTupleTyCon_RDR - , funTyCon_RDR - - -- pseudo-keywords, in var and tyvar forms (all :: RdrName) - , as_var_RDR, hiding_var_RDR, qualified_var_RDR, forall_var_RDR - , export_var_RDR, label_var_RDR, dynamic_var_RDR, unsafe_var_RDR - , stdcall_var_RDR, ccall_var_RDR - - , as_tyvar_RDR, hiding_tyvar_RDR, qualified_tyvar_RDR - , export_tyvar_RDR, label_tyvar_RDR, dynamic_tyvar_RDR - , unsafe_tyvar_RDR, stdcall_tyvar_RDR, ccall_tyvar_RDR - - , minus_RDR, pling_RDR, dot_RDR - ) where #include "HsVersions.h" import Lex -import HsSyn +import HsSyn -- Lots of it import SrcLoc -import RdrHsSyn +import RdrHsSyn ( mkNPlusKPatIn, unitTyCon_RDR, + RdrBinding(..), + RdrNameHsType, RdrNameBangType, RdrNameContext, + RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs, + RdrNameHsRecordBinds, RdrNameMonoBinds + ) import RdrName import CallConv -import PrelNames ( pRELUDE_Name, mkTupNameStr ) -import OccName ( dataName, tcName, varName, tvName, tcClsName, +import OccName ( dataName, varName, tcClsName, occNameSpace, setOccNameSpace, occNameUserString ) -import CmdLineOpts ( opt_NoImplicitPrelude ) import FastString ( unpackFS ) -import BasicTypes ( Boxity(..) ) import UniqFM ( UniqFM, listToUFM, lookupUFM ) import Outputable @@ -188,10 +172,11 @@ checkPat e [] = case e of EWildPat -> returnP WildPatIn HsVar x -> returnP (VarPatIn x) HsLit l -> returnP (LitPatIn l) + HsOverLit l -> returnP (NPatIn l) ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn) EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n) ExprWithTySig e t -> checkPat e [] `thenP` \e -> - -- pattern signatures are parsed as sigtypes, + -- Pattern signatures are parsed as sigtypes, -- but they aren't explicit forall points. Hence -- we have to remove the implicit forall here. let t' = case t of @@ -200,8 +185,9 @@ checkPat e [] = case e of in returnP (SigPatIn e t') - OpApp (HsVar n) (HsVar plus) _ (HsLit k@(HsInt _)) | plus == plus_RDR - -> returnP (NPlusKPatIn n k) + OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _)) + | plus == plus_RDR + -> returnP (mkNPlusKPatIn n lit) OpApp l op fix r -> checkPat l [] `thenP` \l -> checkPat r [] `thenP` \r -> @@ -209,7 +195,6 @@ checkPat e [] = case e of HsVar c -> returnP (ConOpPatIn l c fix r) _ -> patFail - NegApp l r -> checkPat l [] `thenP` (returnP . NegPatIn) HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn) ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps -> returnP (ListPatIn ps) @@ -229,92 +214,7 @@ checkPatField (n,e,b) = patFail = parseError "Parse error in pattern" ---------------------------------------------------------------------------- --- Check Expression Syntax - -{- -We can get away without checkExpr if the renamer generates errors for -pattern syntax used in expressions (wildcards, as patterns and lazy -patterns). - -checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr -checkExpr e = case e of - HsVar _ -> returnP e - HsIPVar _ -> returnP e - HsLit _ -> returnP e - HsLam match -> checkMatch match `thenP` (returnP.HsLam) - HsApp e1 e2 -> check2Exprs e1 e2 HsApp - OpApp e1 e2 fix e3 -> checkExpr e1 `thenP` \e1 -> - checkExpr e2 `thenP` \e2 -> - checkExpr e3 `thenP` \e3 -> - returnP (OpApp e1 e2 fix e3) - NegApp e neg -> checkExpr e `thenP` \e -> - returnP (NegApp e neg) - HsPar e -> check1Expr e HsPar - SectionL e1 e2 -> check2Exprs e1 e2 SectionL - SectionR e1 e2 -> check2Exprs e1 e2 SectionR - HsCase e alts -> mapP checkMatch alts `thenP` \alts -> - checkExpr e `thenP` \e -> - returnP (HsCase e alts) - HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf - - HsLet bs e -> check1Expr e (HsLet bs) - HsDo stmts -> mapP checkStmt stmts `thenP` (returnP . HsDo) - HsTuple es -> checkManyExprs es HsTuple - HsList es -> checkManyExprs es HsList - HsRecConstr c fields -> mapP checkField fields `thenP` \fields -> - returnP (HsRecConstr c fields) - HsRecUpdate e fields -> mapP checkField fields `thenP` \fields -> - checkExpr e `thenP` \e -> - returnP (HsRecUpdate e fields) - HsEnumFrom e -> check1Expr e HsEnumFrom - HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo - HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen - HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo - HsListComp e stmts -> mapP checkStmt stmts `thenP` \stmts -> - checkExpr e `thenP` \e -> - returnP (HsListComp e stmts) - RdrNameHsExprTypeSig loc e ty -> checkExpr e `thenP` \e -> - returnP (RdrNameHsExprTypeSig loc e ty) - _ -> parseError "parse error in expression" - --- type signature for polymorphic recursion!! -check1Expr :: RdrNameHsExpr -> (RdrNameHsExpr -> a) -> P a -check1Expr e f = checkExpr e `thenP` (returnP . f) - -check2Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a -check2Exprs e1 e2 f = - checkExpr e1 `thenP` \e1 -> - checkExpr e2 `thenP` \e2 -> - returnP (f e1 e2) - -check3Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a -check3Exprs e1 e2 e3 f = - checkExpr e1 `thenP` \e1 -> - checkExpr e2 `thenP` \e2 -> - checkExpr e3 `thenP` \e3 -> - returnP (f e1 e2 e3) - -checkManyExprs es f = - mapP checkExpr es `thenP` \es -> - returnP (f es) - -checkAlt (HsAlt loc p galts bs) - = checkGAlts galts `thenP` \galts -> returnP (HsAlt loc p galts bs) - -checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt -checkGAlts (HsGuardedAlts galts) - = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts) - -checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt loc) - -checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p) -checkStmt (HsQualifier e) = check1Expr e HsQualifier -checkStmt s@(HsLetStmt bs) = returnP s - -checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n) -checkField e = returnP e --} + --------------------------------------------------------------------------- -- Check Equation Syntax @@ -414,93 +314,5 @@ groupBindings binds = group Nothing binds RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds other -> bind `RdrAndBindings` group Nothing binds ------------------------------------------------------------------------------ --- Built-in names - -unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName -tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName -ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName - -unitCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual dataName unitName - | otherwise = mkPreludeQual dataName pRELUDE_Name unitName - -unitTyCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual tcName unitName - | otherwise = mkPreludeQual tcName pRELUDE_Name unitName - -nilCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual dataName listName - | otherwise = mkPreludeQual dataName pRELUDE_Name listName - -listTyCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual tcName listName - | otherwise = mkPreludeQual tcName pRELUDE_Name listName - -funTyCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual tcName funName - | otherwise = mkPreludeQual tcName pRELUDE_Name funName - -tupleCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Boxed arity)) - | otherwise = mkPreludeQual dataName pRELUDE_Name - (snd (mkTupNameStr Boxed arity)) - -tupleTyCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Boxed arity)) - | otherwise = mkPreludeQual tcName pRELUDE_Name - (snd (mkTupNameStr Boxed arity)) - - -ubxTupleCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Unboxed arity)) - | otherwise = mkPreludeQual dataName pRELUDE_Name - (snd (mkTupNameStr Unboxed arity)) - -ubxTupleTyCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Unboxed arity)) - | otherwise = mkPreludeQual tcName pRELUDE_Name - (snd (mkTupNameStr Unboxed arity)) - -unitName = SLIT("()") -funName = SLIT("(->)") -listName = SLIT("[]") - -asName = SLIT("as") -hidingName = SLIT("hiding") -qualifiedName = SLIT("qualified") -forallName = SLIT("forall") -exportName = SLIT("export") -labelName = SLIT("label") -dynamicName = SLIT("dynamic") -unsafeName = SLIT("unsafe") -stdcallName = SLIT("stdcall") -ccallName = SLIT("ccall") - -as_var_RDR = mkSrcUnqual varName asName -hiding_var_RDR = mkSrcUnqual varName hidingName -qualified_var_RDR = mkSrcUnqual varName qualifiedName -forall_var_RDR = mkSrcUnqual varName forallName -export_var_RDR = mkSrcUnqual varName exportName -label_var_RDR = mkSrcUnqual varName labelName -dynamic_var_RDR = mkSrcUnqual varName dynamicName -unsafe_var_RDR = mkSrcUnqual varName unsafeName -stdcall_var_RDR = mkSrcUnqual varName stdcallName -ccall_var_RDR = mkSrcUnqual varName ccallName - -as_tyvar_RDR = mkSrcUnqual tvName asName -hiding_tyvar_RDR = mkSrcUnqual tvName hidingName -qualified_tyvar_RDR = mkSrcUnqual tvName qualifiedName -export_tyvar_RDR = mkSrcUnqual tvName exportName -label_tyvar_RDR = mkSrcUnqual tvName labelName -dynamic_tyvar_RDR = mkSrcUnqual tvName dynamicName -unsafe_tyvar_RDR = mkSrcUnqual tvName unsafeName -stdcall_tyvar_RDR = mkSrcUnqual tvName stdcallName -ccall_tyvar_RDR = mkSrcUnqual tvName ccallName - -minus_RDR = mkSrcUnqual varName SLIT("-") -pling_RDR = mkSrcUnqual varName SLIT("!") -dot_RDR = mkSrcUnqual varName SLIT(".") - -plus_RDR = mkSrcUnqual varName SLIT("+") +plus_RDR = mkSrcUnqual varName SLIT("+") \end{code} diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 544b922ca2..122ab9ad19 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.35 2000/09/14 13:46:40 simonpj Exp $ +$Id: Parser.y,v 1.36 2000/09/22 15:56:13 simonpj Exp $ Haskell grammar. @@ -20,7 +20,7 @@ import Lex import ParseUtil import RdrName import PrelInfo ( mAIN_Name ) -import OccName ( varName, ipName, tcName, dataName, tcClsName, tvName ) +import OccName ( UserFS, varName, ipName, tcName, dataName, tcClsName, tvName ) import SrcLoc ( SrcLoc ) import Module import CallConv @@ -156,8 +156,6 @@ Conflicts: 14 shift/reduce '!' { ITbang } '.' { ITdot } - '/\\' { ITbiglam } -- GHC-extension symbols - '{' { ITocurly } -- special symbols '}' { ITccurly } vccurly { ITvccurly } -- virtual close curly (from layout) @@ -182,8 +180,6 @@ Conflicts: 14 shift/reduce IPVARID { ITipvarid $$ } -- GHC extension - PRAGMA { ITpragma $$ } - CHAR { ITchar $$ } STRING { ITstring $$ } INTEGER { ITinteger $$ } @@ -196,8 +192,6 @@ Conflicts: 14 shift/reduce PRIMDOUBLE { ITprimdouble $$ } CLITLIT { ITlitlit $$ } - UNKNOWN { ITunknown $$ } - %monad { P } { thenP } { returnP } %lexer { lexer } { ITeof } %name parse @@ -693,7 +687,7 @@ exp10 :: { RdrNameHsExpr } | 'let' declbinds 'in' exp { HsLet $2 $4 } | 'if' srcloc exp 'then' exp 'else' exp { HsIf $3 $5 $7 $2 } | 'case' srcloc exp 'of' altslist { HsCase $3 $5 $2 } - | '-' fexp { NegApp $2 (error "NegApp") } + | '-' fexp { mkHsNegApp $2 } | srcloc 'do' stmtlist { HsDo DoStmt $3 $1 } | '_ccall_' ccallid aexps0 { HsCCall $2 $3 False False cbot } @@ -730,7 +724,9 @@ aexp1 :: { RdrNameHsExpr } : qvar { HsVar $1 } | ipvar { HsIPVar $1 } | gcon { HsVar $1 } - | literal { HsLit $1 } + | literal { HsLit $1 } + | INTEGER { HsOverLit (mkHsIntegralLit $1) } + | RATIONAL { HsOverLit (mkHsFractionalLit $1) } | '(' exp ')' { HsPar $2 } | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed} | '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed } @@ -913,7 +909,7 @@ qvarop :: { RdrName } | '`' qvarid '`' { $2 } qvaropm :: { RdrName } - : qvarsymm { $1 } + : qvarsym_no_minus { $1 } | '`' qvarid '`' { $2 } conop :: { RdrName } @@ -944,41 +940,42 @@ qopm :: { RdrNameHsExpr } -- used in sections qvarid :: { RdrName } : varid { $1 } - | QVARID { case $1 of { (mod,n) -> - mkSrcQual varName mod n } } + | QVARID { mkSrcQual varName $1 } varid :: { RdrName } - : VARID { mkSrcUnqual varName $1 } - | 'as' { as_var_RDR } - | 'qualified' { qualified_var_RDR } - | 'hiding' { hiding_var_RDR } - | 'forall' { forall_var_RDR } - | 'export' { export_var_RDR } - | 'label' { label_var_RDR } - | 'dynamic' { dynamic_var_RDR } - | 'unsafe' { unsafe_var_RDR } - | 'stdcall' { stdcall_var_RDR } - | 'ccall' { ccall_var_RDR } + : varid_no_unsafe { $1 } + | 'unsafe' { mkSrcUnqual varName SLIT("unsafe") } varid_no_unsafe :: { RdrName } : VARID { mkSrcUnqual varName $1 } - | 'as' { as_var_RDR } - | 'qualified' { qualified_var_RDR } - | 'hiding' { hiding_var_RDR } - | 'forall' { forall_var_RDR } - | 'export' { export_var_RDR } - | 'label' { label_var_RDR } - | 'dynamic' { dynamic_var_RDR } - | 'stdcall' { stdcall_var_RDR } - | 'ccall' { ccall_var_RDR } + | special_id { mkSrcUnqual varName $1 } + | 'forall' { mkSrcUnqual varName SLIT("forall") } + +tyvar :: { RdrName } + : VARID { mkSrcUnqual tvName $1 } + | special_id { mkSrcUnqual tvName $1 } + | 'unsafe' { mkSrcUnqual tvName SLIT("unsafe") } + +-- These special_ids are treated as keywords in various places, +-- but as ordinary ids elsewhere. A special_id collects all thsee +-- except 'unsafe' and 'forall' whose treatment differs depending on context +special_id :: { UserFS } +special_id + : 'as' { SLIT("as") } + | 'qualified' { SLIT("qualified") } + | 'hiding' { SLIT("hiding") } + | 'export' { SLIT("export") } + | 'label' { SLIT("label") } + | 'dynamic' { SLIT("dynamic") } + | 'stdcall' { SLIT("stdcall") } + | 'ccall' { SLIT("ccall") } ----------------------------------------------------------------------------- -- ConIds qconid :: { RdrName } : conid { $1 } - | QCONID { case $1 of { (mod,n) -> - mkSrcQual dataName mod n } } + | QCONID { mkSrcQual dataName $1 } conid :: { RdrName } : CONID { mkSrcUnqual dataName $1 } @@ -988,8 +985,7 @@ conid :: { RdrName } qconsym :: { RdrName } : consym { $1 } - | QCONSYM { case $1 of { (mod,n) -> - mkSrcQual dataName mod n } } + | QCONSYM { mkSrcQual dataName $1 } consym :: { RdrName } : CONSYM { mkSrcUnqual dataName $1 } @@ -1001,37 +997,39 @@ qvarsym :: { RdrName } : varsym { $1 } | qvarsym1 { $1 } -qvarsymm :: { RdrName } - : varsymm { $1 } +qvarsym_no_minus :: { RdrName } + : varsym_no_minus { $1 } | qvarsym1 { $1 } +qvarsym1 :: { RdrName } +qvarsym1 : QVARSYM { mkSrcQual varName $1 } + varsym :: { RdrName } - : VARSYM { mkSrcUnqual varName $1 } - | '-' { minus_RDR } - | '!' { pling_RDR } - | '.' { dot_RDR } + : varsym_no_minus { $1 } + | '-' { mkSrcUnqual varName SLIT("-") } -varsymm :: { RdrName } -- varsym not including '-' +varsym_no_minus :: { RdrName } -- varsym not including '-' : VARSYM { mkSrcUnqual varName $1 } - | '!' { pling_RDR } - | '.' { dot_RDR } + | special_sym { mkSrcUnqual varName $1 } -qvarsym1 :: { RdrName } - : QVARSYM { case $1 of { (mod,n) -> - mkSrcQual varName mod n } } -literal :: { HsLit } - : INTEGER { HsInt $1 } - | CHAR { HsChar $1 } - | RATIONAL { HsFrac $1 } - | STRING { HsString $1 } +-- See comments with special_id +special_sym :: { UserFS } +special_sym : '!' { SLIT("!") } + | '.' { SLIT(".") } + +----------------------------------------------------------------------------- +-- Literals +literal :: { HsLit } + : CHAR { HsChar $1 } + | STRING { HsString $1 } | PRIMINTEGER { HsIntPrim $1 } | PRIMCHAR { HsCharPrim $1 } | PRIMSTRING { HsStringPrim $1 } | PRIMFLOAT { HsFloatPrim $1 } | PRIMDOUBLE { HsDoublePrim $1 } - | CLITLIT { HsLitLit $1 } + | CLITLIT { HsLitLit $1 (error "Parser.y: CLITLIT") } srcloc :: { SrcLoc } : {% getSrcLocP } @@ -1056,25 +1054,11 @@ tycon :: { RdrName } qtycon :: { RdrName } : tycon { $1 } - | QCONID { case $1 of { (mod,n) -> - mkSrcQual tcClsName mod n } } + | QCONID { mkSrcQual tcClsName $1 } qtycls :: { RdrName } : qtycon { $1 } -tyvar :: { RdrName } - : VARID { mkSrcUnqual tvName $1 } - | 'as' { as_tyvar_RDR } - | 'qualified' { qualified_tyvar_RDR } - | 'hiding' { hiding_tyvar_RDR } - | 'export' { export_tyvar_RDR } - | 'label' { label_tyvar_RDR } - | 'dynamic' { dynamic_tyvar_RDR } - | 'unsafe' { unsafe_tyvar_RDR } - | 'stdcall' { stdcall_tyvar_RDR } - | 'ccall' { ccall_tyvar_RDR } - -- NOTE: no 'forall' - commas :: { Int } : commas ',' { $1 + 1 } | ',' { 2 } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index d1b0e0ed02..75fa2934ef 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -55,7 +55,14 @@ module RdrHsSyn ( extractRuleBndrsTyVars, extractHsCtxtRdrTyVars, - mkOpApp, mkClassDecl, mkClassOpSig, mkConDecl, + mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl, + mkHsNegApp, mkHsIntegralLit, mkHsFractionalLit, mkNPlusKPatIn, + + + -- some built-in names (all :: RdrName) + unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR, + tupleCon_RDR, tupleTyCon_RDR, ubxTupleCon_RDR, ubxTupleTyCon_RDR, + funTyCon_RDR, cvBinds, cvMonoBindsAndSigs, @@ -65,18 +72,20 @@ module RdrHsSyn ( #include "HsVersions.h" -import HsSyn +import HsSyn -- Lots of it +import CmdLineOpts ( opt_NoImplicitPrelude ) import HsPat ( collectSigTysFromPats ) -import Name ( mkClassTyConOcc, mkClassDataConOcc ) import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, - mkSuperDictSelOcc, mkDefaultMethodOcc + mkSuperDictSelOcc, mkDefaultMethodOcc, + varName, dataName, tcName ) -import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc ) -import Util ( thenCmp ) +import PrelNames ( pRELUDE_Name, mkTupNameStr ) +import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, + mkSrcUnqual, mkPreludeQual + ) import HsPragmas import List ( nub ) -import BasicTypes ( RecFlag(..) ) -import Outputable +import BasicTypes ( Boxity(..), RecFlag(..) ) \end{code} @@ -189,6 +198,13 @@ extractPatsTyVars = filter isRdrTyVar . collectSigTysFromPats \end{code} + +%************************************************************************ +%* * +\subsection{Construction functions for Rdr stuff} +%* * +%************************************************************************ + mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon by deriving them from the name of the class. We fill in the names for the tycon and datacon corresponding to the class, by deriving them from the @@ -227,11 +243,70 @@ mkConDecl cname ex_vars cxt details loc wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname)) \end{code} -A useful function for building @OpApps@. The operator is always a variable, -and we don't know the fixity yet. +\begin{code} +mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr +-- If the type checker sees (negate 3#) it will barf, because negate +-- can't take an unboxed arg. But that is exactly what it will see when +-- we write "-3#". So we have to do the negation right now! +-- +-- We also do the same service for boxed literals, because this function +-- is also used for patterns (which, remember, are parsed as expressions) +-- and pattern don't have negation in them. +-- +-- Finally, it's important to represent minBound as minBound, and not +-- as (negate (-minBound)), becuase the latter is out of range. + +mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i)) +mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i)) +mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) + +mkHsNegApp (HsOverLit (HsIntegral i n)) = HsOverLit (HsIntegral (-i) n) +mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n) + +mkHsNegApp expr = NegApp expr (prelQual varName SLIT("negate")) +\end{code} + +\begin{code} +mkHsIntegralLit :: Integer -> HsOverLit RdrName +mkHsIntegralLit i = HsIntegral i (prelQual varName SLIT("fromInteger")) + +mkHsFractionalLit :: Rational -> HsOverLit RdrName +mkHsFractionalLit f = HsFractional f (prelQual varName SLIT("fromRational")) + +mkNPlusKPatIn :: RdrName -> HsOverLit RdrName -> RdrNamePat +mkNPlusKPatIn n k = NPlusKPatIn n k (prelQual varName SLIT("-")) +\end{code} + +A useful function for building @OpApps@. The operator is always a +variable, and we don't know the fixity yet. + +\begin{code} +mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2 +\end{code} \begin{code} -mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2 +----------------------------------------------------------------------------- +-- Built-in names +-- Qualified Prelude names are always in scope; so we can just say Prelude.[] +-- for the list type constructor, say. But it's not so easy when we say +-- -fno-implicit-prelude. Then you just get whatever "[]" happens to be in scope. + +unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName +tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName +ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName + +unitCon_RDR = prelQual dataName SLIT("()") +unitTyCon_RDR = prelQual tcName SLIT("()") +nilCon_RDR = prelQual dataName SLIT("[]") +listTyCon_RDR = prelQual tcName SLIT("[]") +funTyCon_RDR = prelQual tcName SLIT("(->)") +tupleCon_RDR arity = prelQual dataName (snd (mkTupNameStr Boxed arity)) +tupleTyCon_RDR arity = prelQual tcName (snd (mkTupNameStr Boxed arity)) +ubxTupleCon_RDR arity = prelQual dataName (snd (mkTupNameStr Unboxed arity)) +ubxTupleTyCon_RDR arity = prelQual tcName (snd (mkTupNameStr Unboxed arity)) + +prelQual ns occ | opt_NoImplicitPrelude = mkSrcUnqual ns occ + | otherwise = mkPreludeQual ns pRELUDE_Name occ \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 3a8f5a6df6..23c04ce5eb 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -46,11 +46,7 @@ import TysWiredIn -- others: import RdrName ( RdrName ) -import Name ( Name, OccName, Provenance(..), - NameSpace, tcName, clsName, varName, dataName, - mkKnownKeyGlobal, - getName, mkGlobalName, nameRdrName - ) +import Name ( Name, mkKnownKeyGlobal, getName ) import Class ( Class, classKey ) import TyCon ( tyConDataConsIfAvailable, TyCon ) import Type ( funTyCon ) @@ -290,6 +286,9 @@ knownKeyNames -- Others , (otherwiseId_RDR, otherwiseIdKey) + , (plusInteger_RDR, plusIntegerIdKey) + , (timesInteger_RDR, timesIntegerIdKey) + , (eqString_RDR, eqStringIdKey) , (assert_RDR, assertIdKey) , (runSTRep_RDR, runSTRepIdKey) ] @@ -371,7 +370,6 @@ because the list of ambiguous dictionaries hasn't been simplified. isCcallishClass, isCreturnableClass, isNoDictClass, isNumericClass, isStandardClass :: Class -> Bool -isFractionalClass clas = classKey clas `is_elem` fractionalClassKeys isNumericClass clas = classKey clas `is_elem` numericClassKeys isStandardClass clas = classKey clas `is_elem` standardClassKeys isCcallishClass clas = classKey clas `is_elem` cCallishClassKeys diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index d7a86c141d..379dff95e7 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -38,7 +38,7 @@ module PrelNames showString_RDR, showParen_RDR, readParen_RDR, lex_RDR, showSpace_RDR, showList___RDR, readList___RDR, negate_RDR, addr2Integer_RDR, ioTyCon_RDR, - foldr_RDR, build_RDR, getTag_RDR, + foldr_RDR, build_RDR, getTag_RDR, plusInteger_RDR, timesInteger_RDR, eqString_RDR, orderingTyCon_RDR, rationalTyCon_RDR, ratioTyCon_RDR, byteArrayTyCon_RDR, mutableByteArrayTyCon_RDR, foreignObjTyCon_RDR, @@ -73,7 +73,7 @@ module PrelNames #include "HsVersions.h" -import Module ( Module, ModuleName, mkPrelModule, mkSrcModule ) +import Module ( ModuleName, mkPrelModule, mkSrcModule ) import OccName ( NameSpace, varName, dataName, tcName, clsName ) import RdrName ( RdrName, mkPreludeQual ) import BasicTypes ( Boxity(..), Arity ) @@ -207,6 +207,7 @@ foldr_RDR = varQual pREL_BASE_Name SLIT("foldr") map_RDR = varQual pREL_BASE_Name SLIT("map") build_RDR = varQual pREL_BASE_Name SLIT("build") augment_RDR = varQual pREL_BASE_Name SLIT("augment") +eqString_RDR = varQual pREL_BASE_Name SLIT("eqString") -- Strings unpackCString_RDR = varQual pREL_BASE_Name SLIT("unpackCString#") @@ -267,7 +268,9 @@ minus_RDR = varQual pREL_NUM_Name SLIT("-") negate_RDR = varQual pREL_NUM_Name SLIT("negate") plus_RDR = varQual pREL_NUM_Name SLIT("+") times_RDR = varQual pREL_NUM_Name SLIT("*") -addr2Integer_RDR = varQual pREL_NUM_Name SLIT("addr2Integer") +addr2Integer_RDR = varQual pREL_NUM_Name SLIT("addr2Integer") +plusInteger_RDR = varQual pREL_NUM_Name SLIT("plusInteger") +timesInteger_RDR = varQual pREL_NUM_Name SLIT("timesInteger") -- Other numberic classes realClass_RDR = clsQual pREL_REAL_Name SLIT("Real") diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 26a1fc00c4..66f4589ad6 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -44,17 +44,17 @@ import BasicTypes ( Fixity(..), FixityDirection(..), import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) ) import CallConv ( cCallConv ) import HsPragmas ( noDataPragmas, noClassPragmas ) -import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind, UsageAnn(..) ) -import IdInfo ( ArityInfo, exactArity, CprInfo(..), InlinePragInfo(..) ) +import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind ) +import IdInfo ( exactArity, InlinePragInfo(..) ) import PrimOp ( CCall(..), CCallTarget(..) ) import Lex import RnMonad ( ImportVersion, ParsedIface(..), WhatsImported(..), - RdrNamePragma, ExportItem, RdrAvailInfo, GenAvailInfo(..), + ExportItem, RdrAvailInfo, GenAvailInfo(..), WhetherHasOrphans, IsBootInterface ) -import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual, mkRdrNameWkr ) -import Name ( OccName, Provenance ) +import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual ) +import Name ( OccName ) import OccName ( mkSysOccFS, tcName, varName, ipName, dataName, clsName, tvName, uvName, EncodedFS diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index df5fd66162..1ffe1f78ba 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -275,6 +275,7 @@ isOrphanDecl (RuleD (HsRule _ _ _ lhs _ _)) check (HsVar v) = not (isLocallyDefined v) check (HsApp f a) = check f && check a check (HsLit _) = False + check (HsOverLit _) = False check (OpApp l o _ r) = check l && check o && check r check (NegApp e _) = check e check (HsPar e) = check e diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index c3c31c0cb5..e230762be8 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -27,17 +27,16 @@ import RnHsSyn import RnMonad import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, - lookupGlobalOccRn, lookupOccRn, lookupSigOccRn, + lookupGlobalOccRn, lookupSigOccRn, warnUnusedLocalBinds, mapFvRn, - FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, - unknownNameErr + FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV ) import CmdLineOpts ( opt_WarnMissingSigs ) import Digraph ( stronglyConnComp, SCC(..) ) import Name ( OccName, Name, nameOccName, mkUnboundName, isUnboundName ) import NameSet import RdrName ( RdrName, rdrNameOcc ) -import BasicTypes ( RecFlag(..), TopLevelFlag(..) ) +import BasicTypes ( RecFlag(..) ) import List ( partition ) import Bag ( bagToList ) import Outputable diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 4a8b0d341a..620aa75d43 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -12,7 +12,6 @@ import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches, opt_WarnUnusedBinds, opt_WarnUnusedImports ) import HsSyn import RdrHsSyn ( RdrNameIE ) -import RnHsSyn ( RenamedHsType ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, mkRdrUnqual, qualifyRdrName ) @@ -22,23 +21,17 @@ import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName, - mkIPName, isWiredInName, hasBetterProv, + mkIPName, hasBetterProv, isLocallyDefined, nameOccName, setNameModule, nameModule, - pprOccName, isLocallyDefined, nameUnique, setNameProvenance, getNameProvenance, pprNameProvenance, extendNameEnv_C, plusNameEnv_C, nameEnvElts ) import NameSet -import OccName ( OccName, - mkDFunOcc, occNameUserString, occNameString, - occNameFlavour - ) -import TysWiredIn ( listTyCon ) -import Type ( funTyCon ) -import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule, pprModuleName ) +import OccName ( OccName, occNameUserString, occNameFlavour ) +import Module ( ModuleName, moduleName, mkVanillaModule, pprModuleName ) import FiniteMap import UniqSupply -import SrcLoc ( SrcLoc, noSrcLoc ) +import SrcLoc ( SrcLoc ) import Outputable import Util ( removeDups, equivClasses, thenCmp, sortLt ) import List ( nub ) @@ -677,11 +670,13 @@ addOneFV :: FreeVars -> Name -> FreeVars unitFV :: Name -> FreeVars emptyFVs :: FreeVars plusFVs :: [FreeVars] -> FreeVars +mkFVs :: [Name] -> FreeVars isEmptyFVs = isEmptyNameSet emptyFVs = emptyNameSet plusFVs = unionManyNameSets plusFV = unionNameSets +mkFVs = mkNameSet -- No point in adding implicitly imported names to the free-var set addOneFV s n = addOneToNameSet s n diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index b5b5036654..1cb5a3b75c 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -27,32 +27,28 @@ import RnMonad import RnEnv import RnIfaces ( lookupFixityRn ) import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts ) -import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity, negatePrecedence ) -import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, +import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity ) +import PrelInfo ( eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR, monadClass_RDR, enumClass_RDR, ordClass_RDR, ratioDataCon_RDR, negate_RDR, assertErr_RDR, - ioDataCon_RDR, addr2Integer_RDR, + ioDataCon_RDR, foldr_RDR, build_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import Name ( nameUnique, isLocallyDefined, NamedThing(..) - , mkSysLocalName, nameSrcLoc - ) +import TysWiredIn ( intTyCon, integerTyCon ) +import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc ) import NameSet import UniqFM ( isNullUFM ) import FiniteMap ( elemFM ) -import UniqSet ( emptyUniqSet, UniqSet ) +import UniqSet ( emptyUniqSet ) import Unique ( hasKey, assertIdKey ) import Util ( removeDups ) import ListSetOps ( unionLists ) import Maybes ( maybeToBool ) import Outputable -import Literal ( inIntRange, tARGET_MAX_INT ) -import RdrName ( mkSrcUnqual ) -import OccName ( varName ) \end{code} @@ -84,9 +80,20 @@ rnPat (SigPatIn pat ty) doc = text "a pattern type-signature" rnPat (LitPatIn lit) - = litOccurrence lit `thenRn` \ fvs1 -> - lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern - returnRn (LitPatIn lit, fvs1 `addOneFV` eq) + = litFVs lit `thenRn` \ fvs -> + returnRn (LitPatIn lit, fvs) + +rnPat (NPatIn lit) + = rnOverLit lit `thenRn` \ (lit', fvs1) -> + lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern + returnRn (NPatIn lit', fvs1 `addOneFV` eq) + +rnPat (NPlusKPatIn name lit minus) + = rnOverLit lit `thenRn` \ (lit', fvs) -> + lookupOrigName ordClass_RDR `thenRn` \ ord -> + lookupBndrRn name `thenRn` \ name' -> + lookupOccRn minus `thenRn` \ minus' -> + returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ord `addOneFV` minus') rnPat (LazyPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> @@ -116,33 +123,10 @@ rnPat (ConOpPatIn pat1 con _ pat2) ) `thenRn` \ pat' -> returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con') --- Negated patters can only be literals, and they are dealt with --- by negating the literal at compile time, not by using the negation --- operation in Num. So we don't need to make an implicit reference --- to negate_RDR. -rnPat neg@(NegPatIn pat) - = checkRn (valid_neg_pat pat) (negPatErr neg) - `thenRn_` - rnPat pat `thenRn` \ (pat', fvs) -> - returnRn (NegPatIn pat', fvs) - where - valid_neg_pat (LitPatIn (HsInt _)) = True - valid_neg_pat (LitPatIn (HsIntPrim _)) = True - valid_neg_pat (LitPatIn (HsFrac _)) = True - valid_neg_pat (LitPatIn (HsFloatPrim _)) = True - valid_neg_pat (LitPatIn (HsDoublePrim _)) = True - valid_neg_pat _ = False - rnPat (ParPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> returnRn (ParPatIn pat', fvs) -rnPat (NPlusKPatIn name lit) - = litOccurrence lit `thenRn` \ fvs -> - lookupOrigName ordClass_RDR `thenRn` \ ord -> - lookupBndrRn name `thenRn` \ name' -> - returnRn (NPlusKPatIn name' lit, fvs `addOneFV` ord) - rnPat (ListPatIn pats) = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name) @@ -291,16 +275,14 @@ rnExpr (HsIPVar v) = newIPName v `thenRn` \ name -> returnRn (HsIPVar name, emptyFVs) --- Special case for integral literals with a large magnitude: --- They are transformed into an expression involving only smaller --- integral literals. This improves constant folding. -rnExpr (HsLit (HsInt i)) - | not (inIntRange i) = rnExpr (horner tARGET_MAX_INT i) - rnExpr (HsLit lit) - = litOccurrence lit `thenRn` \ fvs -> + = litFVs lit `thenRn` \ fvs -> returnRn (HsLit lit, fvs) +rnExpr (HsOverLit lit) + = rnOverLit lit `thenRn` \ (lit', fvs) -> + returnRn (HsOverLit lit', fvs) + rnExpr (HsLam match) = rnMatch match `thenRn` \ (match', fvMatch) -> returnRn (HsLam match', fvMatch) @@ -330,16 +312,10 @@ rnExpr (OpApp e1 op _ e2) returnRn (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) --- constant-fold some negate applications on unboxed literals. Since --- negate is a polymorphic function, we have to do these here. -rnExpr (NegApp (HsLit (HsIntPrim i)) _) = rnExpr (HsLit (HsIntPrim (-i))) -rnExpr (NegApp (HsLit (HsFloatPrim i)) _) = rnExpr (HsLit (HsFloatPrim (-i))) -rnExpr (NegApp (HsLit (HsDoublePrim i)) _) = rnExpr (HsLit (HsDoublePrim (-i))) - rnExpr (NegApp e n) - = rnExpr e `thenRn` \ (e', fv_e) -> + = rnExpr e `thenRn` \ (e', fv_e) -> lookupOrigName negate_RDR `thenRn` \ neg -> - mkNegAppRn e' (HsVar neg) `thenRn` \ final_e -> + mkNegAppRn e' neg `thenRn` \ final_e -> returnRn (final_e, fv_e `addOneFV` neg) rnExpr (HsPar e) @@ -477,19 +453,10 @@ rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_` rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_` returnRn (EWildPat, emptyFVs) - --- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b -horner :: Integer -> Integer -> RdrNameHsExpr -horner b i | abs q <= 1 = if r == 0 || r == i then mkInt i else mkInt r `plus` mkInt (i-r) - | r == 0 = horner b q `times` mkInt b - | otherwise = mkInt r `plus` (horner b q `times` mkInt b) - where (q,r) = i `quotRem` b - mkInt i = HsLit (HsInt i) - plus = mkOp "+" - times = mkOp "*" - mkOp op = \x y -> HsPar (OpApp x (HsVar (mkSrcUnqual varName (_PK_ op))) (panic "fixity") y) \end{code} + + %************************************************************************ %* * \subsubsection{@Rbinds@s and @Rpats@s: in record expressions} @@ -715,14 +682,6 @@ mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) where (nofix_error, associate_right) = compareFixity fix1 fix2 -mkConOpPatRn p1@(NegPatIn neg_arg) - op2 - fix2@(Fixity prec2 dir2) - p2 - | prec2 > negatePrecedence -- Precedence of unary - is wired in - = addErrRn (precParseNegPatErr (ppr_op op2,fix2)) `thenRn_` - returnRn (ConOpPatIn p1 op2 fix2 p2) - mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment = ASSERT( not_op_pat p2 ) returnRn (ConOpPatIn p1 op fix p2) @@ -763,10 +722,6 @@ checkPrec op (ConOpPatIn _ op1 _ _) right in checkRn inf_ok (precParseErr infol infor) -checkPrec op (NegPatIn _) right - = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (ppr_op op,op_fix)) - checkPrec op pat right = returnRn () @@ -776,7 +731,7 @@ checkPrec op pat right checkSectionPrec left_or_right section op arg = case arg of OpApp _ op fix _ -> go_for_it (ppr_op op) fix - NegApp _ op -> go_for_it pp_prefix_minus negateFixity + NegApp _ _ -> go_for_it pp_prefix_minus negateFixity other -> returnRn () where HsVar op_name = op @@ -822,42 +777,32 @@ that the types and classes they involve are made available. \begin{code} -litOccurrence (HsChar _) - = returnRn (unitFV charTyCon_name) - -litOccurrence (HsCharPrim _) - = returnRn (unitFV (getName charPrimTyCon)) - -litOccurrence (HsString _) - = returnRn (unitFV listTyCon_name `plusFV` unitFV charTyCon_name) - -litOccurrence (HsStringPrim _) - = returnRn (unitFV (getName addrPrimTyCon)) +litFVs (HsChar c) = returnRn (unitFV charTyCon_name) +litFVs (HsCharPrim c) = returnRn (unitFV (getName charPrimTyCon)) +litFVs (HsString s) = returnRn (mkFVs [listTyCon_name, charTyCon_name]) +litFVs (HsStringPrim s) = returnRn (unitFV (getName addrPrimTyCon)) +litFVs (HsInt i) = returnRn (unitFV (getName intTyCon)) +litFVs (HsInteger i) = returnRn (unitFV (getName integerTyCon)) +litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon)) +litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon)) +litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon)) +litFVs (HsLitLit l bogus_ty) + = lookupOrigName ccallableClass_RDR `thenRn` \ cc -> + returnRn (unitFV cc) -litOccurrence (HsInt _) - = lookupOrigNames [numClass_RDR, addr2Integer_RDR] - -- Int and Integer are forced in by Num +rnOverLit (HsIntegral i n) + = lookupOccRn n `thenRn` \ n' -> + returnRn (HsIntegral i n', unitFV n') -litOccurrence (HsFrac _) - = lookupOrigNames [fractionalClass_RDR,ratioDataCon_RDR,addr2Integer_RDR] +rnOverLit (HsFractional i n) + = lookupOccRn n `thenRn` \ n' -> + lookupOrigNames [ratioDataCon_RDR] `thenRn` \ ns' -> -- We have to make sure that the Ratio type is imported with -- its constructor, because literals of type Ratio t are -- built with that constructor. -- The Rational type is needed too, but that will come in -- when fractionalClass does. - -litOccurrence (HsIntPrim _) - = returnRn (unitFV (getName intPrimTyCon)) - -litOccurrence (HsFloatPrim _) - = returnRn (unitFV (getName floatPrimTyCon)) - -litOccurrence (HsDoublePrim _) - = returnRn (unitFV (getName doublePrimTyCon)) - -litOccurrence (HsLitLit _) - = lookupOrigName ccallableClass_RDR `thenRn` \ cc -> - returnRn (unitFV cc) + returnRn (HsFractional i n', ns' `addOneFV` n') \end{code} %************************************************************************ @@ -913,16 +858,6 @@ dupFieldErr str (dup:rest) quotes (ppr dup), ptext SLIT("in record"), text str] -negPatErr pat - = sep [pp_prefix_minus <+> ptext SLIT("not applied to literal in pattern"), - quotes (ppr pat)] - -precParseNegPatErr op - = hang (ptext SLIT("precedence parsing error")) - 4 (hsep [pp_prefix_minus <+> ptext SLIT("has lower precedence than"), - ppr_opfix op, - ptext SLIT("in pattern")]) - precParseErr op1 op2 = hang (ptext SLIT("precedence parsing error")) 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 05412f5f8d..763816a43c 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -15,7 +15,6 @@ import TysWiredIn ( tupleTyCon, listTyCon, charTyCon ) import Name ( Name, getName ) import NameSet import BasicTypes ( Boxity ) -import Util import Outputable \end{code} @@ -47,6 +46,7 @@ type RenamedSig = Sig Name type RenamedStmt = Stmt Name RenamedPat type RenamedFixitySig = FixitySig Name type RenamedDeprecation = DeprecDecl Name +type RenamedHsOverLit = HsOverLit Name type RenamedClassOpPragmas = ClassOpPragmas Name type RenamedClassPragmas = ClassPragmas Name diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 6a24e25e84..ef23e33311 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -41,19 +41,18 @@ import ParseIface ( parseIface, IfaceStuff(..) ) import Name ( Name {-instance NamedThing-}, nameOccName, nameModule, isLocallyDefined, - isWiredInName, nameUnique, NamedThing(..), + isWiredInName, NamedThing(..), elemNameEnv, extendNameEnv ) -import Module ( Module, moduleString, pprModule, - mkVanillaModule, pprModuleName, - moduleUserString, moduleName, isLocalModule, +import Module ( Module, mkVanillaModule, pprModuleName, + moduleName, isLocalModule, ModuleName, WhereFrom(..), ) import RdrName ( RdrName, rdrNameOcc ) import NameSet import SrcLoc ( mkSrcLoc, SrcLoc ) import PrelInfo ( cCallishTyKeys ) -import Maybes ( MaybeErr(..), maybeToBool, orElse ) +import Maybes ( maybeToBool ) import Unique ( Uniquable(..) ) import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) @@ -953,6 +952,7 @@ mkImportExportInfo this_mod export_avails exports export_info = [(m, sortExport as) | (m,as) <- fmToList export_fm] in + traceRn (text "Modules in Ifaces: " <+> fsep (map ppr (keysFM mod_map))) `thenRn_` returnRn (export_info, import_info) @@ -1203,10 +1203,6 @@ getDeclErr name ptext SLIT("from module") <+> quotes (ppr (nameModule name)) ] -getDeclWarn name loc - = sep [ptext SLIT("Failed to find (optional) interface decl for") <+> quotes (ppr name), - ptext SLIT("desired at") <+> ppr loc] - importDeclWarn name = sep [ptext SLIT( "Compiler tried to import decl from interface file with same name as module."), diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 609f4230de..41d89609d7 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -34,9 +34,8 @@ import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO ) import HsSyn import RdrHsSyn -import RnHsSyn ( RenamedFixitySig, RenamedDeprecation ) +import RnHsSyn ( RenamedFixitySig ) import BasicTypes ( Version, defaultFixity ) -import SrcLoc ( noSrcLoc ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, WarnMsg, Message ) @@ -56,10 +55,8 @@ import NameSet import CmdLineOpts ( opt_D_dump_rn_trace, opt_HiMap ) import PrelInfo ( builtinNames ) import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) -import Unique ( Unique, getUnique, unboundKey ) -import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM, - addListToFM_C, addToFM_C, eltsFM, fmToList - ) +import Unique ( Unique ) +import FiniteMap ( FiniteMap, emptyFM, bagToFM ) import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) import UniqSupply import Outputable diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 71bd508b5d..5988b32c51 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -10,20 +10,15 @@ module RnNames ( #include "HsVersions.h" -import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports, - opt_SourceUnchanged, opt_WarnUnusedBinds - ) - -import HsSyn ( HsModule(..), HsDecl(..), TyClDecl(..), - IE(..), ieName, - ForeignDecl(..), ForKind(..), isDynamicExtName, - FixitySig(..), Sig(..), ImportDecl(..), +import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports, opt_SourceUnchanged ) + +import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..), collectTopBinders ) import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsModule, RdrNameHsDecl ) -import RnIfaces ( getInterfaceExports, getDeclBinders, getDeclSysBinders, +import RnIfaces ( getInterfaceExports, getDeclBinders, recordLocalSlurps, checkModUsage, findAndReadIface, outOfDate ) import RnEnv @@ -36,7 +31,7 @@ import Bag ( bagToList ) import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) ) import NameSet import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..), - isLocallyDefined, setNameProvenance, + setNameProvenance, nameOccName, getSrcLoc, pprProvenance, getNameProvenance, nameEnvElts ) @@ -45,8 +40,8 @@ import OccName ( setOccNameSpace, dataName ) import NameSet ( elemNameSet, emptyNameSet ) import Outputable import Maybes ( maybeToBool, catMaybes, mapMaybe ) -import UniqFM ( emptyUFM, listToUFM, plusUFM_C ) -import Util ( removeDups, equivClassesByUniq, sortLt ) +import UniqFM ( emptyUFM, listToUFM ) +import Util ( removeDups, sortLt ) import List ( partition ) \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 6f7dc486f0..15ad4fd94b 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -12,18 +12,18 @@ import RnExpr import HsSyn import HsPragmas import HsTypes ( hsTyVarNames, pprHsContext ) -import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar, mkRdrNameWkr ) +import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, extractRuleBndrsTyVars, extractHsTyRdrTyVars, - extractHsTysRdrTyVars, extractHsCtxtRdrTyVars + extractHsCtxtRdrTyVars ) import RnHsSyn import HsCore -import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr ) -import RnEnv ( bindTyVarsRn, lookupTopBndrRn, lookupOccRn, newIPName, - lookupOrigName, lookupOrigNames, lookupSysBinder, - bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn, +import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs ) +import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, + lookupOrigNames, lookupSysBinder, + bindLocalsFVRn, bindUVarRn, bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn, bindCoreLocalFVRn, bindCoreLocalsFVRn, bindLocalNames, checkDupOrQualNames, checkDupNames, @@ -34,11 +34,7 @@ import RnMonad import FunDeps ( oclose ) import Class ( FunDep ) - -import Name ( Name, OccName, - ExportFlag(..), Provenance(..), - nameOccName, NamedThing(..) - ) +import Name ( Name, OccName, nameOccName, NamedThing(..) ) import NameSet import FiniteMap ( elemFM ) import PrelInfo ( derivableClassKeys, cCallishClassKeys, @@ -902,13 +898,6 @@ forAllWarn doc ty tyvar (ptext SLIT("In") <+> doc)) } -forAllErr doc ty tyvar - = addErrRn ( - sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar), - nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))] - $$ - (ptext SLIT("In") <+> doc)) - badRuleLhsErr name lhs = sep [ptext SLIT("Rule") <+> ptext name <> colon, nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)] diff --git a/ghc/compiler/stgSyn/StgInterp.lhs b/ghc/compiler/stgSyn/StgInterp.lhs index 0e68c10244..dfcdd27e98 100644 --- a/ghc/compiler/stgSyn/StgInterp.lhs +++ b/ghc/compiler/stgSyn/StgInterp.lhs @@ -32,13 +32,12 @@ import PrelGHC --( unsafeCoerce#, dataToTag#, import IO ( hPutStr, stderr ) import PrelAddr ( Addr(..) ) import Addr ( intToAddr, addrToInt ) -import Storable import Addr -- again ... import Word import Bits +import Storable #endif - runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int #ifndef GHCI diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 416f0bfd58..e4995fe6f6 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -8,7 +8,7 @@ module Inst ( LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, - Inst, OverloadedLit(..), + Inst, pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts, newDictFromOld, newDicts, newClassDicts, newDictsAtLoc, @@ -37,13 +37,14 @@ module Inst ( #include "HsVersions.h" -import HsSyn ( HsLit(..), HsExpr(..) ) +import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) ) +import RnHsSyn ( RenamedHsOverLit ) import TcHsSyn ( TcExpr, TcId, mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId ) import TcMonad -import TcEnv ( TcIdSet, InstEnv, tcGetInstEnv, lookupInstEnv, InstLookupResult(..), - tcLookupValueByKey, tcLookupTyConByKey +import TcEnv ( TcIdSet, tcGetInstEnv, lookupInstEnv, InstLookupResult(..), + tcLookupValue, tcLookupValueByKey ) import TcType ( TcThetaType, TcType, TcTauType, TcTyVarSet, @@ -55,33 +56,26 @@ import Class ( Class, FunDep ) import FunDeps ( instantiateFdClassTys ) import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) -import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc, - getOccName, nameUnique ) +import Name ( mkDictOcc, mkMethodOcc, mkIPOcc, getOccName, nameUnique ) import PprType ( pprPred ) -import Type ( Type, PredType(..), ThetaType, - mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy, +import Type ( Type, PredType(..), + isTyVarTy, mkDictTy, mkPredTy, splitForAllTys, splitSigmaTy, funArgTy, splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, - mkSynTy, tidyOpenType, tidyOpenTypes + tidyOpenType, tidyOpenTypes ) import Subst ( emptyInScopeSet, mkSubst, mkInScopeSet, substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst ) import Literal ( inIntRange ) -import VarEnv ( lookupVarEnv, TidyEnv, - lookupSubstEnv, SubstResult(..) - ) +import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet ) -import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy ) -import TysWiredIn ( intDataCon, isIntTy, +import TysWiredIn ( isIntTy, floatDataCon, isFloatTy, doubleDataCon, isDoubleTy, - integerTy, isIntegerTy, - voidTy + isIntegerTy, voidTy ) -import Unique ( fromRationalClassOpKey, rationalTyConKey, - fromIntClassOpKey, fromIntegerClassOpKey, Unique - ) +import Unique ( Unique, hasKey, fromIntClassOpKey, fromIntegerClassOpKey ) import Maybe ( catMaybes ) import Util ( thenCmp, zipWithEqual, mapAccumL ) import Outputable @@ -166,8 +160,8 @@ data Inst | LitInst Unique - OverloadedLit - TcType -- The type at which the literal is used + RenamedHsOverLit -- The literal from the occurrence site + TcType -- The type at which the literal is used InstLoc | FunDep @@ -175,10 +169,6 @@ data Inst Class -- the class from which this arises [FunDep TcType] InstLoc - -data OverloadedLit - = OverloadedIntegral Integer -- The number - | OverloadedFractional Rational -- The number \end{code} Ordering @@ -203,17 +193,14 @@ cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2) cmpInst (Method _ _ _ _ _ _) other = LT -cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2) +cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `compare` ty2) cmpInst (LitInst _ _ _ _) (FunDep _ _ _ _) = LT cmpInst (LitInst _ _ _ _) other = GT cmpInst (FunDep _ clas1 fds1 _) (FunDep _ clas2 fds2 _) = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2) cmpInst (FunDep _ _ _ _) other = GT -cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2 -cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2 -cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT -cmpOverLit (OverloadedFractional _) (OverloadedIntegral _) = GT +-- and they can only have HsInt or HsFracs in them. \end{code} @@ -425,10 +412,10 @@ cases (the rest are caught in lookupInst). \begin{code} newOverloadedLit :: InstOrigin - -> OverloadedLit + -> RenamedHsOverLit -> TcType -> NF_TcM s (TcExpr, LIE) -newOverloadedLit orig (OverloadedIntegral i) ty +newOverloadedLit orig (HsIntegral i _) ty | isIntTy ty && inIntRange i -- Short cut for Int = returnNF_Tc (int_lit, emptyLIE) @@ -436,9 +423,8 @@ newOverloadedLit orig (OverloadedIntegral i) ty = returnNF_Tc (integer_lit, emptyLIE) where - intprim_lit = HsLitOut (HsIntPrim i) intPrimTy - integer_lit = HsLitOut (HsInt i) integerTy - int_lit = mkHsConApp intDataCon [] [intprim_lit] + int_lit = HsLit (HsInt i) + integer_lit = HsLit (HsInteger i) newOverloadedLit orig lit ty -- The general case = tcGetInstLoc orig `thenNF_Tc` \ loc -> @@ -532,7 +518,6 @@ zonkInst (FunDep u clas fds loc) = zonkFunDeps fds `thenNF_Tc` \ fds' -> returnNF_Tc (FunDep u clas fds' loc) -zonkPreds preds = mapNF_Tc zonkPred preds zonkInsts insts = mapNF_Tc zonkInst insts zonkFunDeps fds = mapNF_Tc zonkFd fds @@ -561,12 +546,7 @@ instance Outputable Inst where ppr inst = pprInst inst pprInst (LitInst u lit ty loc) - = hsep [case lit of - OverloadedIntegral i -> integer i - OverloadedFractional f -> rational f, - ptext SLIT("at"), - ppr ty, - show_uniq u] + = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u] pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u @@ -644,7 +624,7 @@ lookupInst dict@(Dict _ (Class clas tys) loc) (tyvars, rho) = splitForAllTys (idType dfun_id) ty_args = map subst_tv tyvars dfun_rho = substTy subst rho - (theta, tau) = splitRhoTy dfun_rho + (theta, _) = splitRhoTy dfun_rho ty_app = mkHsTyApp (HsVar dfun_id) ty_args subst_tv tv = case lookupSubstEnv tenv tv of Just (DoneTy ty) -> ty @@ -670,7 +650,7 @@ lookupInst inst@(Method _ id tys theta _ loc) -- Literals -lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc) +lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) | isIntTy ty && in_int_range -- Short cut for Int = returnNF_Tc (GenInst [] int_lit) -- GenInst, not SimpleInst, because int_lit is actually a constructor application @@ -678,42 +658,45 @@ lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc) | isIntegerTy ty -- Short cut for Integer = returnNF_Tc (GenInst [] integer_lit) - | in_int_range -- It's overloaded but small enough to fit into an Int - = tcLookupValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int -> + | in_int_range -- It's overloaded but small enough to fit into an Int + && from_integer_name `hasKey` fromIntegerClassOpKey -- And it's the built-in prelude fromInteger + -- (i.e. no funny business with user-defined + -- packages of numeric classes) + = -- So we can use the Prelude fromInt + tcLookupValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int -> newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) -> returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit)) | otherwise -- Alas, it is overloaded and a big literal! - = tcLookupValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer -> + = tcLookupValue from_integer_name `thenNF_Tc` \ from_integer -> newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) -> returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit)) where in_int_range = inIntRange i - intprim_lit = HsLitOut (HsIntPrim i) intPrimTy - integer_lit = HsLitOut (HsInt i) integerTy - int_lit = mkHsConApp intDataCon [] [intprim_lit] + integer_lit = HsLit (HsInteger i) + int_lit = HsLit (HsInt i) -- similar idea for overloaded floating point literals: if the literal is -- *definitely* a float or a double, generate the real thing here. -- This is essential (see nofib/spectral/nucleic). -lookupInst inst@(LitInst u (OverloadedFractional f) ty loc) +lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) | isFloatTy ty = returnNF_Tc (GenInst [] float_lit) | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit) | otherwise - = tcLookupValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational -> + = tcLookupValue from_rat_name `thenNF_Tc` \ from_rational -> newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> let rational_ty = funArgTy (idType method_id) - rational_lit = HsLitOut (HsFrac f) rational_ty + rational_lit = HsLit (HsRat f rational_ty) in returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit)) where - floatprim_lit = HsLitOut (HsFloatPrim f) floatPrimTy + floatprim_lit = HsLit (HsFloatPrim f) float_lit = mkHsConApp floatDataCon [] [floatprim_lit] - doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy + doubleprim_lit = HsLit (HsDoublePrim f) double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit] -- there are no `instances' of functional dependencies or implicit params diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 1ebd73452c..93f43261f7 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -12,14 +12,14 @@ module TcBinds ( tcBindsAndThen, tcTopBindsAndThen, import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcExpr ) -import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..), - Match(..), collectMonoBinders, andMonoBindList, andMonoBinds +import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), StmtCtxt(..), + Match(..), collectMonoBinders, andMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds ) -import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet ) +import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet ) import TcMonad -import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..), +import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..), newDicts, tyVarsOfInst, instToId, getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps ) @@ -35,32 +35,30 @@ import TcMonoType ( tcHsSigType, checkSigTyVars, ) import TcPat ( tcPat ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcType ( TcType, TcThetaType, - TcTyVar, - newTyVarTy, newTyVar, tcInstTcType, - zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar +import TcType ( TcThetaType, newTyVarTy, newTyVar, + zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar ) import TcUnify ( unifyTauTy, unifyTauTyLists ) -import Id ( Id, mkVanillaId, setInlinePragma, idFreeTyVars ) +import Id ( mkVanillaId, setInlinePragma, idFreeTyVars ) import Var ( idType, idName ) -import IdInfo ( setInlinePragInfo, InlinePragInfo(..) ) -import Name ( Name, getName, getOccName, getSrcLoc ) +import IdInfo ( InlinePragInfo(..) ) +import Name ( Name, getOccName, getSrcLoc ) import NameSet import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp, - splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, - mkPredTy, splitRhoTy, mkForAllTy, isUnLiftedType, + mkForAllTys, mkFunTys, + mkPredTy, mkForAllTy, isUnLiftedType, isUnboxedType, unboxedTypeKind, boxedTypeKind, openTypeKind ) import FunDeps ( tyVarFunDep, oclose ) -import Var ( TyVar, tyVarKind ) +import Var ( tyVarKind ) import VarSet import Bag import Util ( isIn ) import Maybes ( maybeToBool ) import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNotTopLevel ) import FiniteMap ( listToFM, lookupFM ) -import Unique ( ioTyConKey, mainKey, hasKey, Uniquable(..) ) +import Unique ( ioTyConKey, mainKey, hasKey ) import Outputable \end{code} @@ -908,21 +906,6 @@ valSpecSigCtxt v ty nest 4 (ppr v <+> dcolon <+> ppr ty)] ----------------------------------------------- -notAsPolyAsSigErr sig_tau mono_tyvars - = hang (ptext SLIT("A type signature is more polymorphic than the inferred type")) - 4 (vcat [text "Can't for-all the type variable(s)" <+> - pprQuotedList mono_tyvars, - text "in the type" <+> quotes (ppr sig_tau) - ]) - ------------------------------------------------ -badMatchErr sig_ty inferred_ty - = hang (ptext SLIT("Type signature doesn't match inferred type")) - 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sig_ty), - hang (ptext SLIT("Inferred :")) 4 (ppr inferred_ty) - ]) - ------------------------------------------------ unboxedPatBindErr id = ptext SLIT("variable in a lazy pattern binding has unboxed type: ") <+> quotes (ppr id) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 6b206bb72a..d4690c68f5 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -11,20 +11,18 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2, mkImplicitClassBinds, #include "HsVersions.h" import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..), - InPat(..), HsBinds(..), GRHSs(..), HsExpr(..), HsLit(..), HsType(..), HsPred(..), - mkSimpleMatch, - andMonoBinds, andMonoBindList, + mkSimpleMatch, andMonoBinds, andMonoBindList, isClassDecl, isClassOpSig, isPragSig, collectMonoBinders ) -import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) ) -import RnHsSyn ( RenamedTyClDecl, RenamedClassPragmas, +import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) +import RnHsSyn ( RenamedTyClDecl, RenamedClassOpSig, RenamedMonoBinds, RenamedContext, RenamedHsDecl, RenamedSig ) import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) -import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod ) +import Inst ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod ) import TcEnv ( TcId, ValueEnv, TyThing(..), TyThingDetails(..), tcAddImportedIdInfo, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName @@ -32,24 +30,20 @@ import TcEnv ( TcId, ValueEnv, TyThing(..), TyThingDetails(..), tcAddImportedId import TcBinds ( tcBindWithSigs, tcSpecSigs ) import TcMonoType ( tcHsSigType, tcClassContext, checkSigTyVars, sigCtxt, mkTcSig ) import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns ) -import TcType ( TcType, TcTyVar, tcInstTyVars, tcGetTyVar, zonkTcSigTyVars ) +import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars ) import TcMonad import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) -import Bag ( unionManyBags, bagToList ) +import Bag ( bagToList ) import Class ( classTyVars, classBigSig, classSelIds, classTyCon, Class, ClassOpItem ) import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods ) import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) -import DataCon ( mkDataCon, dataConId, dataConWrapId, notMarkedStrict ) -import Id ( Id, setInlinePragma, idUnfolding, idType, idName ) +import DataCon ( mkDataCon, notMarkedStrict ) +import Id ( Id, idType, idName ) import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) ) import NameSet ( NameSet, mkNameSet, elemNameSet, emptyNameSet ) import Outputable -import Type ( Type, ThetaType, ClassContext, - mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkDictTys, - mkSigmaTy, mkClassPred, classesOfPreds, - boxedTypeKind, mkArrowKind - ) -import Var ( tyVarKind, TyVar ) +import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkSigmaTy, mkClassPred ) +import Var ( TyVar ) import VarSet ( mkVarSet, emptyVarSet ) import Maybes ( seqMaybe ) \end{code} diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 6c45d81621..8ffabd0bf9 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -12,7 +12,7 @@ module TcDeriv ( tcDeriving ) where import HsSyn ( HsBinds(..), MonoBinds(..), collectMonoBinders ) import RdrHsSyn ( RdrNameMonoBinds ) -import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds ) +import RnHsSyn ( RenamedHsBinds ) import CmdLineOpts ( opt_D_dump_deriv ) import TcMonad @@ -28,20 +28,17 @@ import RnMonad ( RnNameSupply, import Bag ( Bag, emptyBag, unionBags, listToBag ) import Class ( classKey, Class ) -import ErrUtils ( dumpIfSet, Message, pprBagOfErrors ) +import ErrUtils ( dumpIfSet, Message ) import MkId ( mkDictFunId ) import Id ( mkVanillaId ) import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon ) import PrelInfo ( needsDataDeclCtxtClassKeys ) import Maybes ( maybeToBool, catMaybes ) import Module ( Module ) -import Name ( isLocallyDefined, getSrcLoc, - Name, NamedThing(..), - OccName, nameOccName - ) +import Name ( isLocallyDefined, getSrcLoc, NamedThing(..) ) import RdrName ( RdrName ) import RnMonad ( FixityEnv ) -import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) + import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, tyConTheta, maybeTyConSingleCon, isDataTyCon, isEnumerationTyCon, isAlgTyCon, TyCon diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 649722118f..da6a5bef68 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -9,20 +9,17 @@ module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where #include "HsVersions.h" import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - HsBinds(..), MonoBinds(..), Stmt(..), StmtCtxt(..), - mkMonoBind, nullMonoBinds + MonoBinds(..), StmtCtxt(..), + mkMonoBind, nullMonoBinds ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) -import TcHsSyn ( TcExpr, TcRecordBinds, mkHsConApp, - mkHsTyApp, mkHsLet - ) +import TcHsSyn ( TcExpr, TcRecordBinds, mkHsTyApp, mkHsLet ) import TcMonad import BasicTypes ( RecFlag(..) ) -import Inst ( Inst, InstOrigin(..), OverloadedLit(..), - LIE, emptyLIE, unitLIE, consLIE, plusLIE, plusLIEs, - lieToList, listToLIE, +import Inst ( InstOrigin(..), + LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit, newMethod, newIPDict, instOverloadedFun, newDicts, newClassDicts, getIPsOfLIE, instToId, ipToId @@ -36,24 +33,21 @@ import TcEnv ( tcInstId, ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt ) -import TcPat ( badFieldCon ) -import TcSimplify ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE ) +import TcPat ( badFieldCon, simpleHsLitTy ) +import TcSimplify ( tcSimplifyAndCheck, partitionPredsOfLIE ) import TcImprove ( tcImprove ) import TcType ( TcType, TcTauType, tcInstTyVars, tcInstTcType, tcSplitRhoTy, newTyVarTy, newTyVarTys, zonkTcType ) -import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) -import Id ( idType, recordSelectorFieldLabel, isRecordSelector, - Id, mkVanillaId - ) +import FieldLabel ( fieldLabelName, fieldLabelType, fieldLabelTyCon ) +import Id ( idType, recordSelectorFieldLabel, isRecordSelector, mkVanillaId ) import DataCon ( dataConFieldLabels, dataConSig, dataConStrictMarks, StrictnessMark(..) ) import Name ( Name, getName ) -import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, - ipName_maybe, +import Type ( mkFunTy, mkAppTy, mkTyVarTys, ipName_maybe, splitFunTy_maybe, splitFunTys, isNotUsgTy, mkTyConApp, splitSigmaTy, splitRhoTy, @@ -65,12 +59,8 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, import TyCon ( TyCon, tyConTyVars ) import Subst ( mkTopTyVarSubst, substClasses, substTy ) import UsageSPUtils ( unannotTy ) -import VarSet ( emptyVarSet, unionVarSet, elemVarSet, mkVarSet ) -import TyCon ( tyConDataCons ) -import TysPrim ( intPrimTy, charPrimTy, doublePrimTy, - floatPrimTy, addrPrimTy - ) -import TysWiredIn ( boolTy, charTy, stringTy ) +import VarSet ( elemVarSet, mkVarSet ) +import TysWiredIn ( boolTy ) import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy ) import Unique ( cCallableClassKey, cReturnableClassKey, enumFromClassOpKey, enumFromThenClassOpKey, @@ -207,88 +197,17 @@ tcMonoExpr (HsIPVar name) res_ty %************************************************************************ %* * -\subsection{Literals} -%* * -%************************************************************************ - -Overloaded literals. - -\begin{code} -tcMonoExpr (HsLit (HsInt i)) res_ty - = newOverloadedLit (LiteralOrigin (HsInt i)) - (OverloadedIntegral i) - res_ty `thenNF_Tc` \ stuff -> - returnTc stuff - -tcMonoExpr (HsLit (HsFrac f)) res_ty - = newOverloadedLit (LiteralOrigin (HsFrac f)) - (OverloadedFractional f) - res_ty `thenNF_Tc` \ stuff -> - returnTc stuff - - -tcMonoExpr (HsLit lit@(HsLitLit s)) res_ty - = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> - newClassDicts (LitLitOrigin (_UNPK_ s)) - [(cCallableClass,[res_ty])] `thenNF_Tc` \ (dicts, _) -> - returnTc (HsLitOut lit res_ty, dicts) -\end{code} - -Primitive literals: - -\begin{code} -tcMonoExpr (HsLit lit@(HsCharPrim c)) res_ty - = unifyTauTy res_ty charPrimTy `thenTc_` - returnTc (HsLitOut lit charPrimTy, emptyLIE) - -tcMonoExpr (HsLit lit@(HsStringPrim s)) res_ty - = unifyTauTy res_ty addrPrimTy `thenTc_` - returnTc (HsLitOut lit addrPrimTy, emptyLIE) - -tcMonoExpr (HsLit lit@(HsIntPrim i)) res_ty - = unifyTauTy res_ty intPrimTy `thenTc_` - returnTc (HsLitOut lit intPrimTy, emptyLIE) - -tcMonoExpr (HsLit lit@(HsFloatPrim f)) res_ty - = unifyTauTy res_ty floatPrimTy `thenTc_` - returnTc (HsLitOut lit floatPrimTy, emptyLIE) - -tcMonoExpr (HsLit lit@(HsDoublePrim d)) res_ty - = unifyTauTy res_ty doublePrimTy `thenTc_` - returnTc (HsLitOut lit doublePrimTy, emptyLIE) -\end{code} - -Unoverloaded literals: - -\begin{code} -tcMonoExpr (HsLit lit@(HsChar c)) res_ty - = unifyTauTy res_ty charTy `thenTc_` - returnTc (HsLitOut lit charTy, emptyLIE) - -tcMonoExpr (HsLit lit@(HsString str)) res_ty - = unifyTauTy res_ty stringTy `thenTc_` - returnTc (HsLitOut lit stringTy, emptyLIE) -\end{code} - -%************************************************************************ -%* * \subsection{Other expression forms} %* * %************************************************************************ \begin{code} -tcMonoExpr (HsPar expr) res_ty -- preserve parens so printing needn't guess where they go - = tcMonoExpr expr res_ty - --- perform the negate *before* overloading the integer, since the case --- of minBound on Ints fails otherwise. Could be done elsewhere, but --- convenient to do it here. +tcMonoExpr (HsLit lit) res_ty = tcLit lit res_ty +tcMonoExpr (HsOverLit lit) res_ty = newOverloadedLit (LiteralOrigin lit) lit res_ty +tcMonoExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty -tcMonoExpr (NegApp (HsLit (HsInt i)) neg) res_ty - = tcMonoExpr (HsLit (HsInt (-i))) res_ty - -tcMonoExpr (NegApp expr neg) res_ty - = tcMonoExpr (HsApp neg expr) res_ty +tcMonoExpr (NegApp expr neg) res_ty + = tcMonoExpr (HsApp (HsVar neg) expr) res_ty tcMonoExpr (HsLam match) res_ty = tcMatchLambda match res_ty `thenTc` \ (match',lie) -> @@ -1079,12 +998,36 @@ tcMonoExprs (expr:exprs) (ty:tys) \end{code} -% ================================================= +%************************************************************************ +%* * +\subsection{Literals} +%* * +%************************************************************************ -Errors and contexts -~~~~~~~~~~~~~~~~~~~ +Overloaded literals. + +\begin{code} +tcLit :: HsLit -> TcType -> TcM s (TcExpr, LIE) +tcLit (HsLitLit s _) res_ty + = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> + newClassDicts (LitLitOrigin (_UNPK_ s)) + [(cCallableClass,[res_ty])] `thenNF_Tc` \ (dicts, _) -> + returnTc (HsLit (HsLitLit s res_ty), dicts) + +tcLit lit res_ty + = unifyTauTy res_ty (simpleHsLitTy lit) `thenTc_` + returnTc (HsLit lit, emptyLIE) +\end{code} + + +%************************************************************************ +%* * +\subsection{Errors and contexts} +%* * +%************************************************************************ Mini-utils: + \begin{code} pp_nest_hang :: String -> SDoc -> SDoc pp_nest_hang lbl stuff = nest 2 (hang (text lbl) 4 stuff) @@ -1140,9 +1083,6 @@ lurkingRank2Err fun fun_ty 4 (vcat [ptext SLIT("It is applied to too few arguments"), ptext SLIT("so that the result type has for-alls in it")]) -rank2ArgCtxt arg expected_arg_ty - = ptext SLIT("In a polymorphic function argument:") <+> ppr arg - badFieldsUpd rbinds = hang (ptext SLIT("No constructor has all these fields:")) 4 (pprQuotedList fields) @@ -1155,15 +1095,6 @@ recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr notSelector field = hsep [quotes (ppr field), ptext SLIT("is not a record selector")] -illegalCcallTyErr isArg ty - = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in _ccall_ or _casm_:")]) - 4 (hsep [ppr ty]) - where - arg_or_res - | isArg = ptext SLIT("argument") - | otherwise = ptext SLIT("result") - - missingStrictFieldCon :: Name -> Name -> SDoc missingStrictFieldCon con field = hsep [ptext SLIT("Constructor") <+> quotes (ppr con), diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 4c00838abc..62f68c1713 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -21,21 +21,20 @@ module TcForeign import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), ExtName(Dynamic), isDynamicExtName, MonoBinds(..), - OutPat(..), ForKind(..) + ForKind(..) ) import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) import TcMonad import TcEnv ( newLocalId ) -import TcType ( tcSplitRhoTy, zonkTcTypeToType ) import TcMonoType ( tcHsBoxedSigType ) import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl ) -import TcExpr ( tcId, tcPolyExpr ) +import TcExpr ( tcPolyExpr ) import Inst ( emptyLIE, LIE, plusLIE ) import ErrUtils ( Message ) -import Id ( Id, idName, mkVanillaId ) +import Id ( Id, mkVanillaId ) import Name ( nameOccName ) import Type ( splitFunTys , splitTyConApp_maybe diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index fb87c89122..8798f09c55 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -31,21 +31,21 @@ import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), HsBinds(..), StmtCtxt(..), HsType(..), unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList ) -import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) +import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) import RdrName ( RdrName, mkSrcUnqual ) import RnMonad ( FixityEnv, lookupFixity ) import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) - , maxPrecedence, defaultFixity + , maxPrecedence , Boxity(..) ) import FieldLabel ( fieldLabelName ) import DataCon ( isNullaryDataCon, dataConTag, dataConOrigArgTys, dataConSourceArity, fIRST_TAG, - DataCon, ConTag, + DataCon, dataConFieldLabels ) import Name ( getOccString, getOccName, getSrcLoc, occNameString, occNameUserString, nameRdrName, varName, - OccName, Name, NamedThing(..), NameSpace, + Name, NamedThing(..), isDataSymOcc, isSymOcc ) @@ -59,7 +59,7 @@ import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy ) import Util ( mapAccumL, zipEqual, zipWithEqual, - zipWith3Equal, nOfThem, assocDefault ) + zipWith3Equal, nOfThem ) import Panic ( panic, assertPanic ) import Maybes ( maybeToBool ) import Constants @@ -1350,7 +1350,7 @@ parenify e = HsPar e -- For some reason the renamer doesn't reassociate it right, and I can't -- be bothered to find out why just now. -genOpApp e1 op e2 = mkOpApp e1 op e2 +genOpApp e1 op e2 = mkHsOpApp e1 op e2 \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index eceff0e733..60b1067688 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -18,7 +18,7 @@ import TcMonoType ( tcHsType ) import TcEnv ( ValueEnv, tcExtendTyVarEnv, tcExtendGlobalValEnv, tcSetValueEnv, tcLookupValueMaybe, - explicitLookupValue, badCon, badPrimOp, valueEnvIds + explicitLookupValue, valueEnvIds ) import RnHsSyn ( RenamedHsDecl ) @@ -36,9 +36,9 @@ import Id ( Id, mkId, mkVanillaId, import MkId ( mkCCallOpId ) import IdInfo import DataCon ( dataConSig, dataConArgTys ) -import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitAlgTyConApp_maybe, splitFunTys, unUsgTy ) +import Type ( mkTyVarTys, splitAlgTyConApp_maybe, unUsgTy ) import Var ( mkTyVar, tyVarKind ) -import Name ( Name, NamedThing(..), isLocallyDefined ) +import Name ( Name, isLocallyDefined ) import Demand ( wwLazy ) import ErrUtils ( pprBagOfErrors ) import Outputable diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs index 9093ccbbb8..76e3064cab 100644 --- a/ghc/compiler/typecheck/TcImprove.lhs +++ b/ghc/compiler/typecheck/TcImprove.lhs @@ -4,21 +4,17 @@ module TcImprove ( tcImprove ) where #include "HsVersions.h" import Name ( Name ) -import Class ( Class, FunDep, className, classExtraBigSig ) -import Unify ( unifyTyListsX, matchTys ) +import Class ( Class, FunDep, className ) +import Unify ( unifyTyListsX ) import Subst ( mkSubst, emptyInScopeSet, substTy ) import TcEnv ( tcGetInstEnv, classInstEnv ) import TcMonad -import TcType ( TcType, TcTyVar, TcTyVarSet, zonkTcType, zonkTcTypes ) +import TcType ( TcType, TcTyVarSet, zonkTcType ) import TcUnify ( unifyTauTyLists ) -import Inst ( LIE, Inst, LookupInstResult(..), - lookupInst, getFunDepsOfLIE, getIPsOfLIE, - zonkLIE, zonkFunDeps {- for debugging -} ) +import Inst ( LIE, getFunDepsOfLIE, getIPsOfLIE ) import VarSet ( VarSet, emptyVarSet, unionVarSet ) -import VarEnv ( emptyVarEnv ) import FunDeps ( instantiateFdClassTys ) -import Outputable -import List ( elemIndex, nub ) +import List ( nub ) \end{code} \begin{code} @@ -125,15 +121,6 @@ zonkEqTys ts1 ts2 mapTc zonkTcType ts2 `thenTc` \ ts2' -> returnTc (ts1' == ts2') -zonkMatchTys ts1 free ts2 - = mapTc zonkTcType ts1 `thenTc` \ ts1' -> - mapTc zonkTcType ts2 `thenTc` \ ts2' -> - -- pprTrace "zMT" (ppr (ts1', free, ts2')) $ - case matchTys free ts2' ts1' of - Just (subst, []) -> -- pprTrace "zMT match!" empty $ - returnTc (Just subst) - Nothing -> returnTc Nothing - zonkUnifyTys free ts1 ts2 = mapTc zonkTcType ts1 `thenTc` \ ts1' -> mapTc zonkTcType ts2 `thenTc` \ ts2' -> diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 38a4f3fcde..baf3b54dd6 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -9,8 +9,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where #include "HsVersions.h" import HsSyn ( HsDecl(..), InstDecl(..), - HsBinds(..), MonoBinds(..), - HsExpr(..), InPat(..), HsLit(..), Sig(..), + MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), andMonoBindList ) import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl ) @@ -20,7 +19,7 @@ import TcBinds ( tcSpecSigs ) import TcClassDcl ( tcMethodBind, checkFromThisClass ) import TcMonad import RnMonad ( RnNameSupply, FixityEnv ) -import Inst ( Inst, InstOrigin(..), +import Inst ( InstOrigin(..), newDicts, newClassDicts, LIE, emptyLIE, plusLIE, plusLIEs ) import TcDeriv ( tcDeriving ) @@ -30,33 +29,32 @@ import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, import TcInstUtil ( InstInfo(..), classDataCon ) import TcMonoType ( tcHsSigType ) import TcSimplify ( tcSimplifyAndCheck ) -import TcType ( TcTyVar, zonkTcSigTyVars ) +import TcType ( zonkTcSigTyVars ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, foldBag, Bag ) import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances ) -import Class ( classBigSig, Class ) -import Var ( idName, idType, Id, TyVar ) -import Maybes ( maybeToBool, catMaybes, expectJust ) +import Class ( classBigSig ) +import Var ( idName, idType ) +import Maybes ( maybeToBool, expectJust ) import MkId ( mkDictFunId ) import Module ( Module ) -import Name ( isLocallyDefined, NamedThing(..) ) +import Name ( isLocallyDefined ) import NameSet ( emptyNameSet ) import PrelInfo ( eRROR_ID ) import PprType ( pprConstraint ) import TyCon ( isSynTyCon, tyConDerivings ) -import Type ( Type, isUnLiftedType, mkTyVarTys, - splitSigmaTy, isTyVarTy, +import Type ( mkTyVarTys, splitSigmaTy, isTyVarTy, splitTyConApp_maybe, splitDictTy_maybe, - getClassTys_maybe, splitAlgTyConApp_maybe, + splitAlgTyConApp_maybe, classesToPreds, classesOfPreds, unUsgTy, tyVarsOfTypes ) import Subst ( mkTopTyVarSubst, substClasses ) import VarSet ( mkVarSet, varSetElems ) -import TysWiredIn ( stringTy, isFFIArgumentTy, isFFIResultTy ) -import Unique ( Unique, cCallableClassKey, cReturnableClassKey, hasKey, Uniquable(..) ) +import TysWiredIn ( isFFIArgumentTy, isFFIResultTy ) +import Unique ( cCallableClassKey, cReturnableClassKey, hasKey ) import Outputable \end{code} @@ -422,7 +420,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys -- mention the constructor, which doesn't exist for CCallable, CReturnable -- Hardly beautiful, but only three extra lines. HsApp (TyApp (HsVar eRROR_ID) [(unUsgTy . idType) this_dict_id]) - (HsLitOut (HsString msg) stringTy) + (HsLit (HsString msg)) | otherwise -- The common case = mkHsConApp dict_constr inst_tys' (map HsVar (sc_dict_ids ++ meth_ids)) diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index 5638cf1acd..0dc6ab91c7 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -22,7 +22,7 @@ import TcEnv ( InstEnv, emptyInstEnv, addToInstEnv ) import Bag ( bagToList, Bag ) import Class ( Class ) import Var ( TyVar, Id, idName ) -import Maybes ( MaybeErr(..), mkLookupFunDef ) +import Maybes ( MaybeErr(..) ) import Name ( getSrcLoc, nameModule, isLocallyDefined ) import SrcLoc ( SrcLoc ) import Type ( Type, ClassContext ) @@ -30,8 +30,6 @@ import PprType ( pprConstraint ) import Class ( classTyCon ) import DataCon ( DataCon ) import TyCon ( tyConDataCons ) -import Unique ( Unique, getUnique ) -import Util ( equivClassesByUniq ) import Outputable \end{code} diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index eddaca1675..658c3e804e 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -20,8 +20,8 @@ import TcHsSyn ( TcMatch, TcGRHSs, TcStmt ) import TcMonad import TcMonoType ( kcHsSigType, kcTyVarScope, newSigTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt ) -import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs ) -import TcEnv ( tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars, tcGetGlobalTyVars ) +import Inst ( LIE, plusLIE, emptyLIE, plusLIEs ) +import TcEnv ( tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars ) import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig ) import TcType ( TcType, newTyVarTy ) import TcBinds ( tcBindsAndThen ) @@ -31,7 +31,7 @@ import Name ( Name ) import TysWiredIn ( boolTy ) import BasicTypes ( RecFlag(..) ) -import Type ( Kind, tyVarsOfType, isTauTy, mkFunTy, boxedTypeKind, openTypeKind ) +import Type ( tyVarsOfType, isTauTy, mkFunTy, boxedTypeKind, openTypeKind ) import VarSet import Var ( Id ) import Bag diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 03e4c4675c..382984fc8d 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -15,20 +15,19 @@ import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_types, opt_PprStyle_Debug ) import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) ) import HsTypes ( toHsType ) import RnHsSyn ( RenamedHsModule ) -import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, +import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl, TypecheckedRuleDecl, zonkTopBinds, zonkForeignExports, zonkRules ) import TcMonad -import Inst ( Inst, emptyLIE, plusLIE ) +import Inst ( emptyLIE, plusLIE ) import TcBinds ( tcTopBindsAndThen ) import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) -import TcEnv ( tcExtendGlobalValEnv, tcExtendTypeEnv, +import TcEnv ( tcExtendGlobalValEnv, getEnvTyCons, getEnvClasses, tcLookupValueByKeyMaybe, - tcSetValueEnv, tcSetInstEnv, - initEnv, + tcSetValueEnv, tcSetInstEnv, initEnv, ValueEnv, ) import TcRules ( tcRules ) @@ -39,21 +38,20 @@ import TcInstUtil ( buildInstanceEnv, InstInfo ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import TcTyDecls ( mkImplicitDataBinds ) -import TcType ( TcType, TcKind ) import RnMonad ( RnNameSupply, FixityEnv ) import Bag ( isEmptyBag ) -import ErrUtils ( Message, printErrorsAndWarnings, dumpIfSet ) -import Id ( Id, idType, idName ) +import ErrUtils ( printErrorsAndWarnings, dumpIfSet ) +import Id ( idType, idName ) import Module ( pprModuleName, mkThisModule ) -import Name ( Name, nameUnique, nameOccName, isLocallyDefined, isGlobalName, - toRdrName, nameEnvElts, NamedThing(..) +import Name ( nameOccName, isLocallyDefined, isGlobalName, + toRdrName, nameEnvElts, ) import OccName ( isSysOcc ) -import TyCon ( TyCon, tyConKind, tyConClass_maybe ) -import Class ( Class, classSelIds, classTyCon ) +import TyCon ( TyCon, tyConClass_maybe ) +import Class ( Class ) import PrelInfo ( mAIN_Name ) -import Unique ( Unique, mainKey ) +import Unique ( mainKey ) import UniqSupply ( UniqSupply ) import Maybes ( maybeToBool ) import Util diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 5b3e11fbd9..ec877f477d 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -45,11 +45,10 @@ module TcMonad( import {-# SOURCE #-} TcEnv ( TcEnv ) -import HsSyn ( HsLit ) -import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr ) +import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit ) import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType, ) -import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, Message, WarnMsg ) +import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg ) import CmdLineOpts ( opt_PprStyle_Debug ) import Bag ( Bag, emptyBag, isEmptyBag, @@ -57,7 +56,7 @@ import Bag ( Bag, emptyBag, isEmptyBag, import Class ( Class ) import Name ( Name ) import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar ) -import VarEnv ( TyVarEnv, emptyVarEnv, TidyEnv, emptyTidyEnv ) +import VarEnv ( TidyEnv, emptyTidyEnv ) import VarSet ( TyVarSet ) import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply, UniqSM, initUs_ ) @@ -659,7 +658,7 @@ data InstOrigin | InstanceDeclOrigin -- Typechecking an instance decl - | LiteralOrigin HsLit -- Occurrence of a literal + | LiteralOrigin RenamedHsOverLit -- Occurrence of a literal | PatOrigin RenamedPat diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index fbf9a71f5a..621649c3f4 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -27,7 +27,7 @@ import TcMonad import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars, tcExtendUVarEnv, tcLookupUVar, tcGetGlobalTyVars, valueEnvIds, - TyThing(..), tyThingKind, tcExtendKindEnv + TyThing(..), tcExtendKindEnv ) import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType, newKindVar, tcInstSigVar, @@ -36,33 +36,33 @@ import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType, import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr, instFunDeps, instFunDepsOfTheta ) import FunDeps ( tyVarFunDep, oclose ) -import TcUnify ( unifyKind, unifyKinds, unifyOpenTypeKind ) +import TcUnify ( unifyKind, unifyOpenTypeKind ) import Type ( Type, Kind, PredType(..), ThetaType, UsageAnn(..), mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy, mkUsForAllTy, zipFunTys, hoistForAllTys, - mkSigmaTy, mkDictTy, mkPredTy, mkTyConApp, + mkSigmaTy, mkPredTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy, mkRhoTy, boxedTypeKind, unboxedTypeKind, mkArrowKind, mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe, tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars, - tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, mkForAllTys, + tyVarsOfType, tyVarsOfPred, mkForAllTys, classesOfPreds ) -import PprType ( pprConstraint, pprType, pprPred ) +import PprType ( pprType, pprPred ) import Subst ( mkTopTyVarSubst, substTy ) import Id ( mkVanillaId, idName, idType, idFreeTyVars ) -import Var ( TyVar, mkTyVar, tyVarKind, mkNamedUVar, varName ) +import Var ( TyVar, mkTyVar, tyVarKind, mkNamedUVar ) import VarEnv import VarSet import ErrUtils ( Message ) import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind ) import Class ( ClassContext, classArity, classTyCon ) -import Name ( Name, OccName, isLocallyDefined ) +import Name ( Name, isLocallyDefined ) import TysWiredIn ( mkListTy, mkTupleTy ) -import UniqFM ( elemUFM, foldUFM ) +import UniqFM ( elemUFM ) import BasicTypes ( Boxity(..) ) import SrcLoc ( SrcLoc ) -import Util ( mapAccumL, isSingleton, removeDups ) +import Util ( mapAccumL, isSingleton ) import Outputable \end{code} @@ -843,8 +843,6 @@ sigPatCtxt bound_tvs bound_ids tidy_env \begin{code} tcsigCtxt v = ptext SLIT("In a type signature for") <+> quotes (ppr v) -typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty) - typeKindCtxt :: RenamedHsType -> Message typeKindCtxt ty = sep [ptext SLIT("When checking that"), nest 2 (quotes (ppr ty)), diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index cedbd56d08..3ffa6c9dbf 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -4,16 +4,16 @@ \section[TcPat]{Typechecking patterns} \begin{code} -module TcPat ( tcPat, tcPatBndr_NoSigs, badFieldCon, polyPatSig ) where +module TcPat ( tcPat, tcPatBndr_NoSigs, simpleHsLitTy, badFieldCon, polyPatSig ) where #include "HsVersions.h" -import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..), Sig(..) ) +import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsOverLit(..), HsExpr(..) ) import RnHsSyn ( RenamedPat ) import TcHsSyn ( TcPat, TcId ) import TcMonad -import Inst ( Inst, OverloadedLit(..), InstOrigin(..), +import Inst ( InstOrigin(..), emptyLIE, plusLIE, LIE, newMethod, newOverloadedLit, newDicts, newClassDicts ) @@ -27,18 +27,18 @@ import TcMonoType ( tcHsSigType ) import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy ) import CmdLineOpts ( opt_IrrefutableTuples ) -import DataCon ( DataCon, dataConSig, dataConFieldLabels, +import DataCon ( dataConSig, dataConFieldLabels, dataConSourceArity ) -import Id ( Id, idType, isDataConWrapId_maybe ) -import Type ( Type, isTauTy, mkTyConApp, mkClassPred, boxedTypeKind ) +import Id ( isDataConWrapId_maybe ) +import Type ( isTauTy, mkTyConApp, mkClassPred, boxedTypeKind ) import Subst ( substTy, substClasses ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) -import TysWiredIn ( charTy, stringTy, intTy ) -import Unique ( eqClassOpKey, geClassOpKey, minusClassOpKey, - cCallableClassKey +import TysWiredIn ( charTy, stringTy, intTy, integerTy ) +import Unique ( eqClassOpKey, geClassOpKey, + cCallableClassKey, eqStringIdKey, ) import BasicTypes ( isBoxed ) import Bag @@ -122,16 +122,6 @@ tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty tcPat tc_bndr WildPatIn pat_ty = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE) -tcPat tc_bndr (NegPatIn pat) pat_ty - = tcPat tc_bndr (negate_lit pat) pat_ty - where - negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i)) - negate_lit (LitPatIn (HsIntPrim i)) = LitPatIn (HsIntPrim (-i)) - negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f)) - negate_lit (LitPatIn (HsFloatPrim f)) = LitPatIn (HsFloatPrim (-f)) - negate_lit (LitPatIn (HsDoublePrim f)) = LitPatIn (HsDoublePrim (-f)) - negate_lit _ = panic "TcPat:negate_pat" - tcPat tc_bndr (ParPatIn parend_pat) pat_ty = tcPat tc_bndr parend_pat pat_ty @@ -267,71 +257,65 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty %************************************************************************ %* * -\subsection{Non-overloaded literals} +\subsection{Literals} %* * %************************************************************************ \begin{code} -tcPat tc_bndr (LitPatIn lit@(HsChar _)) pat_ty = tcSimpleLitPat lit charTy pat_ty -tcPat tc_bndr (LitPatIn lit@(HsIntPrim _)) pat_ty = tcSimpleLitPat lit intPrimTy pat_ty -tcPat tc_bndr (LitPatIn lit@(HsCharPrim _)) pat_ty = tcSimpleLitPat lit charPrimTy pat_ty -tcPat tc_bndr (LitPatIn lit@(HsStringPrim _)) pat_ty = tcSimpleLitPat lit addrPrimTy pat_ty -tcPat tc_bndr (LitPatIn lit@(HsFloatPrim _)) pat_ty = tcSimpleLitPat lit floatPrimTy pat_ty -tcPat tc_bndr (LitPatIn lit@(HsDoublePrim _)) pat_ty = tcSimpleLitPat lit doublePrimTy pat_ty - -tcPat tc_bndr (LitPatIn lit@(HsLitLit s)) pat_ty +tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty -- cf tcExpr on LitLits = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> newDicts (LitLitOrigin (_UNPK_ s)) [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ (dicts, _) -> - returnTc (LitPat lit pat_ty, dicts, emptyBag, emptyBag, emptyLIE) + returnTc (LitPat (HsLitLit s pat_ty) pat_ty, dicts, emptyBag, emptyBag, emptyLIE) + +tcPat tc_bndr pat@(LitPatIn lit@(HsString _)) pat_ty + = unifyTauTy pat_ty stringTy `thenTc_` + tcLookupValueByKey eqStringIdKey `thenNF_Tc` \ eq_id -> + returnTc (NPat lit stringTy (HsVar eq_id `HsApp` HsLit lit), + emptyLIE, emptyBag, emptyBag, emptyLIE) + +tcPat tc_bndr (LitPatIn simple_lit) pat_ty + = unifyTauTy pat_ty (simpleHsLitTy simple_lit) `thenTc_` + returnTc (LitPat simple_lit pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE) + +tcPat tc_bndr pat@(NPatIn over_lit) pat_ty + = newOverloadedLit (PatOrigin pat) over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> + tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id -> + newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ (lie2, eq_id) -> + + returnTc (NPat lit' pat_ty (HsApp (HsVar eq_id) over_lit_expr), + lie1 `plusLIE` lie2, + emptyBag, emptyBag, emptyLIE) + where + origin = PatOrigin pat + lit' = case over_lit of + HsIntegral i _ -> HsInteger i + HsFractional f _ -> HsRat f pat_ty \end{code} %************************************************************************ %* * -\subsection{Overloaded patterns: int literals and \tr{n+k} patterns} +\subsection{n+k patterns} %* * %************************************************************************ \begin{code} -tcPat tc_bndr pat@(LitPatIn lit@(HsString str)) pat_ty - = unifyTauTy pat_ty stringTy `thenTc_` - tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ sel_id -> - newMethod (PatOrigin pat) sel_id [stringTy] `thenNF_Tc` \ (lie, eq_id) -> - let - comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy) - in - returnTc (NPat lit stringTy comp_op, lie, emptyBag, emptyBag, emptyLIE) - - -tcPat tc_bndr pat@(LitPatIn lit@(HsInt i)) pat_ty - = tcOverloadedLitPat pat lit (OverloadedIntegral i) pat_ty - -tcPat tc_bndr pat@(LitPatIn lit@(HsFrac f)) pat_ty - = tcOverloadedLitPat pat lit (OverloadedFractional f) pat_ty - - -tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsInt i)) pat_ty +tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus) pat_ty = tc_bndr name pat_ty `thenTc` \ bndr_id -> + tcLookupValue minus `thenNF_Tc` \ minus_sel_id -> tcLookupValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id -> - tcLookupValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id -> - - newOverloadedLit origin - (OverloadedIntegral i) pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> - + newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ (lie2, ge_id) -> newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ (lie3, minus_id) -> - returnTc (NPlusKPat bndr_id lit pat_ty + returnTc (NPlusKPat bndr_id i pat_ty (SectionR (HsVar ge_id) over_lit_expr) (SectionR (HsVar minus_id) over_lit_expr), lie1 `plusLIE` lie2 `plusLIE` lie3, emptyBag, unitBag (name, bndr_id), emptyLIE) where origin = PatOrigin pat - -tcPat tc_bndr (NPlusKPatIn pat other) pat_ty - = panic "TcPat:NPlusKPat: not an HsInt literal" \end{code} %************************************************************************ @@ -364,24 +348,19 @@ tcPats tc_bndr (ty:tys) (pat:pats) ------------------------------------------------------ \begin{code} -tcSimpleLitPat lit lit_ty pat_ty - = unifyTauTy pat_ty lit_ty `thenTc_` - returnTc (LitPat lit lit_ty, emptyLIE, emptyBag, emptyBag, emptyLIE) - - -tcOverloadedLitPat pat lit over_lit pat_ty - = newOverloadedLit (PatOrigin pat) over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> - tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id -> - newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ (lie2, eq_id) -> - - returnTc (NPat lit pat_ty (HsApp (HsVar eq_id) - over_lit_expr), - lie1 `plusLIE` lie2, - emptyBag, emptyBag, emptyLIE) - where - origin = PatOrigin pat +simpleHsLitTy :: HsLit -> TcType +simpleHsLitTy (HsCharPrim c) = charPrimTy +simpleHsLitTy (HsStringPrim s) = addrPrimTy +simpleHsLitTy (HsInt i) = intTy +simpleHsLitTy (HsInteger i) = integerTy +simpleHsLitTy (HsIntPrim i) = intPrimTy +simpleHsLitTy (HsFloatPrim f) = floatPrimTy +simpleHsLitTy (HsDoublePrim d) = doublePrimTy +simpleHsLitTy (HsChar c) = charTy +simpleHsLitTy (HsString str) = stringTy \end{code} + ------------------------------------------------------ \begin{code} tcConstructor pat con_name pat_ty @@ -453,14 +432,6 @@ tcConPat tc_bndr pat con_name arg_pats pat_ty patCtxt pat = hang (ptext SLIT("In the pattern:")) 4 (ppr pat) -recordLabel field_label - = hang (hcat [ptext SLIT("When matching record field"), ppr field_label]) - 4 (hcat [ptext SLIT("with its immediately enclosing constructor")]) - -recordRhs field_label pat - = hang (ptext SLIT("In the record field pattern")) - 4 (sep [ppr field_label, char '=', ppr pat]) - badFieldCon :: Name -> Name -> SDoc badFieldCon con field = hsep [ptext SLIT("Constructor") <+> quotes (ppr con), diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 808165d1ed..c58a6f719d 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -18,16 +18,13 @@ import TcType ( zonkTcTypes, zonkTcTyVarToTyVar, newTyVarTy ) import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) import TcMonoType ( kcTyVarScope, kcHsSigType, tcHsSigType, newSigTyVars, checkSigTyVars ) import TcExpr ( tcExpr ) -import TcEnv ( tcExtendLocalValEnv, newLocalId, - tcExtendTyVarEnv - ) +import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv ) import Inst ( LIE, emptyLIE, plusLIEs, instToId ) import Id ( idType, idName, mkVanillaId ) import VarSet import Type ( tyVarsOfTypes, openTypeKind ) import Bag ( bagToList ) import Outputable -import Util \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index acb0827e2c..fc9757f08a 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -131,7 +131,7 @@ import TcHsSyn ( TcExpr, TcId, import TcMonad import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), - tyVarsOfInst, tyVarsOfInsts, + tyVarsOfInst, isDict, isClassDict, isMethod, notFunDep, isStdClassTyVarDict, isMethodFor, instToId, instBindingRequired, instCanBeGeneralised, @@ -141,18 +141,18 @@ import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), instLoc, pprInst, zonkInst, tidyInst, tidyInsts, Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE, unitLIE, consLIE, plusLIE, - lieToList, listToLIE + lieToList ) import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, - InstEnv, lookupInstEnv, InstLookupResult(..) + lookupInstEnv, InstLookupResult(..) ) -import TcType ( TcType, TcTyVarSet ) +import TcType ( TcTyVarSet ) import TcUnify ( unifyTauTy ) import Id ( idType ) import Class ( Class, classBigSig ) import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass ) -import Type ( Type, ThetaType, TauType, ClassContext, +import Type ( Type, ClassContext, mkTyVarTy, getTyVar, isTyVarTy, splitSigmaTy, tyVarsOfTypes ) @@ -1240,14 +1240,6 @@ warnDefault dicts default_ty (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts -addRuleLhsErr dict - = addInstErrTcM (instLoc dict) - (tidy_env, - vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict), - nest 4 (ptext SLIT("LHS of a rule must have no overloading"))]) - where - (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict - addTopIPErr dict = addInstErrTcM (instLoc dict) (tidy_env, diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 6e4e0d6763..23b336ae88 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -12,12 +12,12 @@ module TcTyClsDecls ( import HsSyn ( HsDecl(..), TyClDecl(..), HsType(..), HsTyVarBndr, - ConDecl(..), ConDetails(..), BangType(..), + ConDecl(..), ConDetails(..), Sig(..), HsPred(..), HsTupCon(..), tyClDeclName, hsTyVarNames, isClassDecl, isSynDecl, isClassOpSig, getBangType ) import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name ) -import BasicTypes ( RecFlag(..), NewOrData(..), Arity ) +import BasicTypes ( RecFlag(..), NewOrData(..) ) import TcMonad import TcEnv ( ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind, @@ -26,7 +26,7 @@ import TcEnv ( ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind, import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep ) import TcClassDcl ( tcClassDecl1 ) import TcMonoType ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars ) -import TcType ( TcKind, newKindVar, newKindVars, zonkKindEnv ) +import TcType ( TcKind, newKindVar, zonkKindEnv ) import TcUnify ( unifyKind ) import Type ( Kind, mkArrowKind, boxedTypeKind, zipFunTys ) @@ -34,18 +34,15 @@ import Variance ( calcTyConArgVrcs ) import Class ( Class, mkClass, classTyCon ) import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), mkSynTyCon, mkAlgTyCon, mkClassTyCon ) import DataCon ( isNullaryDataCon ) -import Var ( TyVar, tyVarKind, varName ) -import VarEnv +import Var ( varName ) import FiniteMap -import Bag import Digraph ( stronglyConnComp, SCC(..) ) import Name ( Name, NamedThing(..), NameEnv, getSrcLoc, isTvOcc, nameOccName, mkNameEnv, lookupNameEnv_NF ) import Outputable import Maybes ( mapMaybe, catMaybes ) -import UniqSet ( UniqSet, emptyUniqSet, - unitUniqSet, unionUniqSets, +import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) import ErrUtils ( Message ) import Unique ( Unique, Uniquable(..) ) @@ -457,7 +454,6 @@ get_sigs sigs ---------------------------------------------------- set_name name = unitUniqSet (getUnique name) -set_to_bag set = listToBag (uniqSetToList set) \end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index e95a944968..6ef01c048c 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -14,20 +14,19 @@ module TcTyDecls ( import HsSyn ( MonoBinds(..), TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..), - andMonoBindList, getBangType + getBangType ) import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext ) import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) -import BasicTypes ( RecFlag(..), NewOrData(..) ) +import BasicTypes ( NewOrData(..) ) import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, kcTyVarScope, tcClassContext, kcHsContext, kcHsSigType, mkImmutTyVars ) import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcLookupValueByKey, TyThing(..), TyThingDetails(..) ) import TcMonad -import TcUnify ( unifyKind ) -import Class ( Class, ClassContext ) +import Class ( ClassContext ) import DataCon ( DataCon, mkDataCon, dataConFieldLabels, dataConId, dataConWrapId, markedStrict, notMarkedStrict, markedUnboxed, dataConRepType @@ -35,24 +34,19 @@ import DataCon ( DataCon, mkDataCon, import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId ) import FieldLabel import Var ( Id, TyVar ) -import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique ) +import Name ( Name, isLocallyDefined, NamedThing(..) ) import Outputable -import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon, - tyConDataConsIfAvailable, tyConTyVars, - isSynTyCon, isNewTyCon +import TyCon ( TyCon, isSynTyCon, isNewTyCon, + tyConDataConsIfAvailable, tyConTyVars ) -import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys, - mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy, - mkTyVarTy, splitAlgTyConApp_maybe, - mkArrowKind, mkArrowKinds, boxedTypeKind, - isUnboxedType, Type, ThetaType, classesOfPreds +import Type ( tyVarsOfTypes, splitFunTy, applyTys, + mkTyConApp, mkTyVarTys, mkForAllTys, + splitAlgTyConApp_maybe, Type ) import TysWiredIn ( unitTy ) -import Var ( tyVarKind ) import VarSet ( intersectVarSet, isEmptyVarSet ) import Unique ( unpackCStringIdKey, unpackCStringUtf8IdKey ) import Util ( equivClasses ) -import FiniteMap ( FiniteMap, lookupWithDefaultFM ) \end{code} %************************************************************************ diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index e57e125f62..9c3e3bf565 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -678,6 +678,8 @@ ClassPred and ClassContext are used in class and instance declarations. %************************************************************************ \begin{code} +-- f :: (C a, ?x :: Int -> Int) => a -> Int +-- Here the "C a" and "?x :: Int -> Int" are Preds data PredType = Class Class [Type] | IParam Name Type deriving( Eq, Ord ) |