#include "HsVersions.h"
import OccName ( NameSpace, tcName,
- OccName,
+ OccName, UserFS,
mkSysOccFS,
mkSrcOccFS, mkSrcVarOcc,
isDataOcc, isTvOcc, mkWorkerOcc
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
enumFromToClassOpKey,
eqClassKey,
eqClassOpKey,
+ eqStringIdKey,
errorIdKey,
falseDataConKey,
failMClassOpKey,
parErrorIdKey,
parIdKey,
patErrorIdKey,
+ plusIntegerIdKey,
ratioDataConKey,
ratioTyConKey,
rationalTyConKey,
stableNameTyConKey,
statePrimTyConKey,
+ timesIntegerIdKey,
typeConKey,
kindConKey,
boxityConKey,
stableNameDataConKey = mkPreludeDataConUnique 13
trueDataConKey = mkPreludeDataConUnique 14
wordDataConKey = mkPreludeDataConUnique 15
-stDataConKey = mkPreludeDataConUnique 16
-ioDataConKey = mkPreludeDataConUnique 17
+ioDataConKey = mkPreludeDataConUnique 16
\end{code}
%************************************************************************
int2IntegerIdKey = mkPreludeMiscIdUnique 13
addr2IntegerIdKey = mkPreludeMiscIdUnique 14
irrefutPatErrorIdKey = mkPreludeMiscIdUnique 15
-lexIdKey = mkPreludeMiscIdUnique 16
+eqStringIdKey = mkPreludeMiscIdUnique 16
noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 17
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 18
parErrorIdKey = mkPreludeMiscIdUnique 20
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
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
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
)
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
| 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
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
-> 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
addAutoScc _ pair
= returnDs pair
-
-noUserSCC (Note (SCC _) _) = False
-worthSCC core_expr = True
\end{code}
If profiling and dealing with a dict binding,
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
%************************************************************************
%* *
-\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) ->
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)
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}
+
+
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.
CanItFail(..), EquationInfo(..), MatchResult(..),
EqnNo, EqnSet,
- tidyLitPat,
+ tidyLitPat, tidyNPat,
mkDsLet, mkDsLets,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
mkErrorAppDs, mkNilExpr, mkConsExpr,
- mkStringLit, mkStringLitFS,
+ mkStringLit, mkStringLitFS, mkIntegerLit,
mkSelectorBinds, mkTupleExpr, mkTupleSelector,
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
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}
%************************************************************************
\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}
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
safeChar c = c >= 1 && c <= 0xFF
\end{code}
+
%************************************************************************
%* *
\subsection[mkSelectorBind]{Make a selector bind}
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...
import {-# SOURCE #-} DsExpr ( dsExpr )
import HsSyn ( HsLit(..), OutPat(..), HsExpr(..) )
+import TcHsSyn ( TypecheckedPat )
import CoreSyn ( Expr(..), Bind(..) )
import Id ( Id )
import Literal ( mkMachInt, Literal(..) )
import Maybes ( catMaybes )
-import Type ( Type, isUnLiftedType )
+import Type ( isUnLiftedType )
import Panic ( panic, assertPanic )
\end{code}
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 ->
-- 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 ->
\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 ->
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
-- 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}
#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(..) )
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 )
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:
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 )
\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
-- 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
| 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)]
| 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)
in
case expr of
HsLit l -> ppr l
- HsLitOut l _ -> ppr l
+ HsOverLit l -> ppr l
HsVar _ -> pp_as_was
HsIPVar _ -> pp_as_was
#include "HsVersions.h"
-- friends:
-import HsBasic ( HsLit )
+import HsLit ( HsLit, HsOverLit )
import HsExpr ( HsExpr )
import HsTypes ( HsType )
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 )
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
| 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
-- 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
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
-- 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
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-}"),
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
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
module HsDecls,
module HsExpr,
module HsImpExp,
- module HsBasic,
+ module HsLit,
module HsMatches,
module HsPat,
module HsTypes,
import HsBinds
import HsExpr
import HsImpExp
-import HsBasic
+import HsLit
import HsMatches
import HsPat
import HsTypes
#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
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(..)
)
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
| 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,
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}
-- , 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
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
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 ->
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)
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
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}
{-
-----------------------------------------------------------------------------
-$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.
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
'!' { ITbang }
'.' { ITdot }
- '/\\' { ITbiglam } -- GHC-extension symbols
-
'{' { ITocurly } -- special symbols
'}' { ITccurly }
vccurly { ITvccurly } -- virtual close curly (from layout)
IPVARID { ITipvarid $$ } -- GHC extension
- PRAGMA { ITpragma $$ }
-
CHAR { ITchar $$ }
STRING { ITstring $$ }
INTEGER { ITinteger $$ }
PRIMDOUBLE { ITprimdouble $$ }
CLITLIT { ITlitlit $$ }
- UNKNOWN { ITunknown $$ }
-
%monad { P } { thenP } { returnP }
%lexer { lexer } { ITeof }
%name parse
| '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 }
: 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 }
| '`' qvarid '`' { $2 }
qvaropm :: { RdrName }
- : qvarsymm { $1 }
+ : qvarsym_no_minus { $1 }
| '`' qvarid '`' { $2 }
conop :: { RdrName }
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 }
qconsym :: { RdrName }
: consym { $1 }
- | QCONSYM { case $1 of { (mod,n) ->
- mkSrcQual dataName mod n } }
+ | QCONSYM { mkSrcQual dataName $1 }
consym :: { RdrName }
: CONSYM { mkSrcUnqual dataName $1 }
: 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 }
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 }
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,
#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}
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
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}
%************************************************************************
-- 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 )
-- Others
, (otherwiseId_RDR, otherwiseIdKey)
+ , (plusInteger_RDR, plusIntegerIdKey)
+ , (timesInteger_RDR, timesIntegerIdKey)
+ , (eqString_RDR, eqStringIdKey)
, (assert_RDR, assertIdKey)
, (runSTRep_RDR, runSTRepIdKey)
]
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
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,
#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 )
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#")
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")
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
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
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
opt_WarnUnusedBinds, opt_WarnUnusedImports )
import HsSyn
import RdrHsSyn ( RdrNameIE )
-import RnHsSyn ( RenamedHsType )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
mkRdrUnqual, qualifyRdrName
)
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 )
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
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}
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) ->
) `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)
= 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)
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)
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}
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)
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 ()
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
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}
%************************************************************************
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"),
import Name ( Name, getName )
import NameSet
import BasicTypes ( Boxity )
-import Util
import Outputable
\end{code}
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
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 )
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)
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."),
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
)
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
#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
import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
import NameSet
import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..),
- isLocallyDefined, setNameProvenance,
+ setNameProvenance,
nameOccName, getSrcLoc, pprProvenance, getNameProvenance,
nameEnvElts
)
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}
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,
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,
(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)]
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
LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE,
plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
- Inst, OverloadedLit(..),
+ Inst,
pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
newDictFromOld, newDicts, newClassDicts, newDictsAtLoc,
#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,
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
| 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
Class -- the class from which this arises
[FunDep TcType]
InstLoc
-
-data OverloadedLit
- = OverloadedIntegral Integer -- The number
- | OverloadedFractional Rational -- The number
\end{code}
Ordering
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}
\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)
= 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 ->
= 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
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
(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
-- 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
| 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
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
)
)
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}
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)
#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
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}
import HsSyn ( HsBinds(..), MonoBinds(..), collectMonoBinders )
import RdrHsSyn ( RdrNameMonoBinds )
-import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds )
+import RnHsSyn ( RenamedHsBinds )
import CmdLineOpts ( opt_D_dump_deriv )
import TcMonad
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
#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
)
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,
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,
%************************************************************************
%* *
-\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) ->
\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)
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)
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),
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
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
)
floatPrimTy, doublePrimTy
)
import Util ( mapAccumL, zipEqual, zipWithEqual,
- zipWith3Equal, nOfThem, assocDefault )
+ zipWith3Equal, nOfThem )
import Panic ( panic, assertPanic )
import Maybes ( maybeToBool )
import Constants
-- 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}
import TcEnv ( ValueEnv, tcExtendTyVarEnv,
tcExtendGlobalValEnv, tcSetValueEnv,
tcLookupValueMaybe,
- explicitLookupValue, badCon, badPrimOp, valueEnvIds
+ explicitLookupValue, valueEnvIds
)
import RnHsSyn ( RenamedHsDecl )
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
#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}
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' ->
#include "HsVersions.h"
import HsSyn ( HsDecl(..), InstDecl(..),
- HsBinds(..), MonoBinds(..),
- HsExpr(..), InPat(..), HsLit(..), Sig(..),
+ MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
andMonoBindList
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
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 )
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}
-- 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))
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 )
import Class ( classTyCon )
import DataCon ( DataCon )
import TyCon ( tyConDataCons )
-import Unique ( Unique, getUnique )
-import Util ( equivClassesByUniq )
import Outputable
\end{code}
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 )
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
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 )
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
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,
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_ )
| InstanceDeclOrigin -- Typechecking an instance decl
- | LiteralOrigin HsLit -- Occurrence of a literal
+ | LiteralOrigin RenamedHsOverLit -- Occurrence of a literal
| PatOrigin RenamedPat
import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars,
tcExtendUVarEnv, tcLookupUVar,
tcGetGlobalTyVars, valueEnvIds,
- TyThing(..), tyThingKind, tcExtendKindEnv
+ TyThing(..), tcExtendKindEnv
)
import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
newKindVar, tcInstSigVar,
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}
\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)),
\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
)
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
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
%************************************************************************
%* *
-\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}
%************************************************************************
------------------------------------------------------
\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
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),
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}
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
- tyVarsOfInst, tyVarsOfInsts,
+ tyVarsOfInst,
isDict, isClassDict, isMethod, notFunDep,
isStdClassTyVarDict, isMethodFor,
instToId, instBindingRequired, instCanBeGeneralised,
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
)
(_, 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,
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,
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 )
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(..) )
----------------------------------------------------
set_name name = unitUniqSet (getUnique name)
-set_to_bag set = listToBag (uniqSetToList set)
\end{code}
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
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}
%************************************************************************
%************************************************************************
\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 )
projects / ghc-hetmet.git / commitdiff