diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index cd0ec9bcc87a5d576a619df87109fc5860995a9f..669be86bdd6f833147c7bfc50c2c8bc649b1dec6 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -20,6 +20,7 @@ module MkId (
mkDataConId,
mkRecordSelId,
+ mkNewTySelId,
mkPrimitiveId
) where
@@ -240,6 +241,40 @@ mkRecordSelId field_label selector_ty
\end{code}
+%************************************************************************
+%* *
+\subsection{Newtype field selectors}
+%* *
+%************************************************************************
+
+Possibly overkill to do it this way:
+
+\begin{code}
+mkNewTySelId field_label selector_ty = sel_id
+ where
+ sel_id = mkId (fieldLabelName field_label) selector_ty
+ (RecordSelId field_label) info
+
+ info = exactArity 1 `setArityInfo` (
+ unfolding `setUnfoldingInfo`
+ noIdInfo)
+ -- ToDo: consider adding further IdInfo
+
+ unfolding = mkUnfolding sel_rhs
+
+ (tyvars, theta, tau) = splitSigmaTy selector_ty
+ (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
+ -- tau is of form (T a b c -> field-type)
+ (tycon, _, data_cons) = splitAlgTyConApp data_ty
+ tyvar_tys = mkTyVarTys tyvars
+
+ [data_id] = mkTemplateLocals [data_ty]
+ sel_rhs = mkLams tyvars $ Lam data_id $
+ Note (Coerce rhs_ty data_ty) (Var data_id)
+
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Dictionary selectors}
diff --git a/ghc/compiler/basicTypes/Name.hi-boot b/ghc/compiler/basicTypes/Name.hi-boot
index 24b358b113f2735e33bab9f606123767db80de7c..8c578f319eccd48722f8f9115e1379c33ff5881a 100644
--- a/ghc/compiler/basicTypes/Name.hi-boot
+++ b/ghc/compiler/basicTypes/Name.hi-boot
@@ -3,3 +3,4 @@ _exports_
Name Name;
_declarations_
1 data Name;
+
diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs
index f17156c09b5aceab6015168a6537ccf8652d9c2f..4ecd069360b90634324d1d0b36fd434e400528fb 100644
--- a/ghc/compiler/basicTypes/OccName.lhs
+++ b/ghc/compiler/basicTypes/OccName.lhs
@@ -20,6 +20,7 @@ module OccName (
mkClassTyConOcc, mkClassDataConOcc,
isTvOcc, isTCOcc, isVarOcc, isConSymOcc, isConOcc, isSymOcc,
+ isWildCardOcc, isAnonOcc,
pprOccName, occNameString, occNameFlavour,
-- The basic form of names
@@ -390,7 +391,7 @@ occNameFlavour (OccName TvOcc _ _ _) = "Type variable"
occNameFlavour (OccName TCOcc s _ _) = "Type constructor or class"
isVarOcc, isTCOcc, isTvOcc,
- isConSymOcc, isSymOcc :: OccName -> Bool
+ isConSymOcc, isSymOcc, isWildCardOcc :: OccName -> Bool
isVarOcc (OccName VarOcc _ _ _) = True
isVarOcc other = False
@@ -406,6 +407,10 @@ isConSymOcc (OccName _ s _ _) = isLexConSym s
isSymOcc (OccName _ s _ _) = isLexSym s
isConOcc (OccName _ s _ _) = isLexCon s
+
+isWildCardOcc (OccName _ s _ _) = (_HEAD_ s) == '_' && _LENGTH_ s == 1
+
+isAnonOcc (OccName _ s _ _) = (_HEAD_ s) == '_'
\end{code}
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index d91bf45e56b4cc1b41671583f2c9cde6f74422ff..f518899db67a8cf9e615b975a0f508395c9368e2 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -49,11 +49,13 @@ module Unique (
arrayPrimTyConKey,
assertIdKey,
augmentIdKey,
+ bindIOIdKey,
boolTyConKey,
boundedClassKey,
boxedConKey,
buildIdKey,
byteArrayPrimTyConKey,
+ byteArrayTyConKey,
cCallableClassKey,
cReturnableClassKey,
charDataConKey,
@@ -61,6 +63,7 @@ module Unique (
charTyConKey,
concatIdKey,
consDataConKey,
+ deRefStablePtrIdKey,
doubleDataConKey,
doublePrimTyConKey,
doubleTyConKey,
@@ -73,6 +76,7 @@ module Unique (
eqClassOpKey,
errorIdKey,
falseDataConKey,
+ failMClassOpKey,
filterIdKey,
floatDataConKey,
floatPrimTyConKey,
@@ -83,7 +87,6 @@ module Unique (
foreignObjDataConKey,
foreignObjPrimTyConKey,
foreignObjTyConKey,
- weakPrimTyConKey,
fractionalClassKey,
fromEnumClassOpKey,
fromIntClassOpKey,
@@ -117,13 +120,14 @@ module Unique (
ixClassKey,
listTyConKey,
mainKey,
+ makeStablePtrIdKey,
mapIdKey,
minusClassOpKey,
monadClassKey,
monadPlusClassKey,
- monadZeroClassKey,
mutableArrayPrimTyConKey,
mutableByteArrayPrimTyConKey,
+ mutableByteArrayTyConKey,
mutVarPrimTyConKey,
nilDataConKey,
noMethodBindingErrorIdKey,
@@ -169,6 +173,7 @@ module Unique (
toEnumClassOpKey,
traceIdKey,
trueDataConKey,
+ unboundKey,
unboxedConKey,
unpackCString2IdKey,
unpackCStringAppendIdKey,
@@ -176,8 +181,7 @@ module Unique (
unpackCStringIdKey,
unsafeCoerceIdKey,
ushowListIdKey,
- voidIdKey,
- voidTyConKey,
+ weakPrimTyConKey,
wordDataConKey,
wordPrimTyConKey,
wordTyConKey,
@@ -190,14 +194,7 @@ module Unique (
word64DataConKey,
word64PrimTyConKey,
word64TyConKey,
- zeroClassOpKey,
- zipIdKey,
- bindIOIdKey,
- deRefStablePtrIdKey,
- makeStablePtrIdKey,
- unboundKey,
- byteArrayTyConKey,
- mutableByteArrayTyConKey
+ zipIdKey
) where
#include "HsVersions.h"
@@ -464,21 +461,20 @@ floatingClassKey = mkPreludeClassUnique 5
fractionalClassKey = mkPreludeClassUnique 6
integralClassKey = mkPreludeClassUnique 7
monadClassKey = mkPreludeClassUnique 8
-monadZeroClassKey = mkPreludeClassUnique 9
-monadPlusClassKey = mkPreludeClassUnique 10
-functorClassKey = mkPreludeClassUnique 11
-numClassKey = mkPreludeClassUnique 12
-ordClassKey = mkPreludeClassUnique 13
-readClassKey = mkPreludeClassUnique 14
-realClassKey = mkPreludeClassUnique 15
-realFloatClassKey = mkPreludeClassUnique 16
-realFracClassKey = mkPreludeClassUnique 17
-showClassKey = mkPreludeClassUnique 18
+monadPlusClassKey = mkPreludeClassUnique 9
+functorClassKey = mkPreludeClassUnique 10
+numClassKey = mkPreludeClassUnique 11
+ordClassKey = mkPreludeClassUnique 12
+readClassKey = mkPreludeClassUnique 13
+realClassKey = mkPreludeClassUnique 14
+realFloatClassKey = mkPreludeClassUnique 15
+realFracClassKey = mkPreludeClassUnique 16
+showClassKey = mkPreludeClassUnique 17
-cCallableClassKey = mkPreludeClassUnique 19
-cReturnableClassKey = mkPreludeClassUnique 20
+cCallableClassKey = mkPreludeClassUnique 18
+cReturnableClassKey = mkPreludeClassUnique 19
-ixClassKey = mkPreludeClassUnique 21
+ixClassKey = mkPreludeClassUnique 20
\end{code}
%************************************************************************
@@ -534,14 +530,13 @@ word16TyConKey = mkPreludeTyConUnique 60
word32TyConKey = mkPreludeTyConUnique 61
word64PrimTyConKey = mkPreludeTyConUnique 62
word64TyConKey = mkPreludeTyConUnique 63
-voidTyConKey = mkPreludeTyConUnique 64
-boxedConKey = mkPreludeTyConUnique 65
-unboxedConKey = mkPreludeTyConUnique 66
-anyBoxConKey = mkPreludeTyConUnique 67
-kindConKey = mkPreludeTyConUnique 68
-boxityConKey = mkPreludeTyConUnique 69
-typeConKey = mkPreludeTyConUnique 70
-threadIdPrimTyConKey = mkPreludeTyConUnique 71
+boxedConKey = mkPreludeTyConUnique 64
+unboxedConKey = mkPreludeTyConUnique 65
+anyBoxConKey = mkPreludeTyConUnique 66
+kindConKey = mkPreludeTyConUnique 67
+boxityConKey = mkPreludeTyConUnique 68
+typeConKey = mkPreludeTyConUnique 69
+threadIdPrimTyConKey = mkPreludeTyConUnique 70
\end{code}
%************************************************************************
@@ -615,15 +610,14 @@ unpackCString2IdKey = mkPreludeMiscIdUnique 27
unpackCStringAppendIdKey = mkPreludeMiscIdUnique 28
unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 29
unpackCStringIdKey = mkPreludeMiscIdUnique 30
-voidIdKey = mkPreludeMiscIdUnique 31
-ushowListIdKey = mkPreludeMiscIdUnique 32
-unsafeCoerceIdKey = mkPreludeMiscIdUnique 33
-concatIdKey = mkPreludeMiscIdUnique 34
-filterIdKey = mkPreludeMiscIdUnique 35
-zipIdKey = mkPreludeMiscIdUnique 36
-bindIOIdKey = mkPreludeMiscIdUnique 37
-deRefStablePtrIdKey = mkPreludeMiscIdUnique 38
-makeStablePtrIdKey = mkPreludeMiscIdUnique 39
+ushowListIdKey = mkPreludeMiscIdUnique 31
+unsafeCoerceIdKey = mkPreludeMiscIdUnique 32
+concatIdKey = mkPreludeMiscIdUnique 33
+filterIdKey = mkPreludeMiscIdUnique 34
+zipIdKey = mkPreludeMiscIdUnique 35
+bindIOIdKey = mkPreludeMiscIdUnique 36
+deRefStablePtrIdKey = mkPreludeMiscIdUnique 37
+makeStablePtrIdKey = mkPreludeMiscIdUnique 38
\end{code}
Certain class operations from Prelude classes. They get their own
@@ -641,7 +635,7 @@ enumFromToClassOpKey = mkPreludeMiscIdUnique 107
enumFromThenToClassOpKey = mkPreludeMiscIdUnique 108
eqClassOpKey = mkPreludeMiscIdUnique 109
geClassOpKey = mkPreludeMiscIdUnique 110
-zeroClassOpKey = mkPreludeMiscIdUnique 112
+failMClassOpKey = mkPreludeMiscIdUnique 112
thenMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
-- Just a place holder for unbound variables produced by the renamer:
unboundKey = mkPreludeMiscIdUnique 114
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 3cc58a675d20b1c7ed5d57920df16e411438fec8..ddf179dffef65d797ed86032a6f8c9435455d47b 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.18 1998/12/22 12:55:55 simonm Exp $
+% $Id: CgExpr.lhs,v 1.19 1999/01/14 17:58:46 sof Exp $
%
%********************************************************
%* *
@@ -18,6 +18,7 @@ import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE )
import StgSyn
import CgMonad
import AbsCSyn
+import AbsCUtils ( mkAbstractCs )
import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
@@ -423,15 +424,29 @@ Little helper for primitives that return unboxed tuples.
\begin{code}
primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
primRetUnboxedTuple op args res_ty
- = let (tc,ty_args) = case splitTyConAppThroughNewTypes res_ty of
- Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
- Just pr -> pr
-
- prim_reps = map typePrimRep ty_args
- temp_uniqs = map mkBuiltinUnique [0..length ty_args]
- temp_amodes = zipWith CTemp temp_uniqs prim_reps
+ = getArgAmodes args `thenFC` \ arg_amodes ->
+ {-
+ put all the arguments in temporaries so they don't get stomped when
+ we push the return address.
+ -}
+ let
+ n_args = length args
+ arg_uniqs = map mkBuiltinUnique [0 .. n_args-1]
+ arg_reps = map getArgPrimRep args
+ arg_temps = zipWith CTemp arg_uniqs arg_reps
+ in
+ absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
+ {-
+ allocate some temporaries for the return values.
+ -}
+ let
+ (tc,ty_args) = case splitTyConAppThroughNewTypes res_ty of
+ Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
+ Just pr -> pr
+ prim_reps = map typePrimRep ty_args
+ temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
+ temp_amodes = zipWith CTemp temp_uniqs prim_reps
in
- returnUnboxedTuple temp_amodes
- (getArgAmodes args `thenFC` \ arg_amodes ->
- absC (COpStmt temp_amodes op arg_amodes []))
+ returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
+
\end{code}
diff --git a/ghc/compiler/deSugar/DsExpr.hi-boot b/ghc/compiler/deSugar/DsExpr.hi-boot
index 55e849c009b0e1a653068ed83068efc30c50877c..2a163faf5f660d16987cfbf14d71c4c29217eab6 100644
--- a/ghc/compiler/deSugar/DsExpr.hi-boot
+++ b/ghc/compiler/deSugar/DsExpr.hi-boot
@@ -4,3 +4,4 @@ DsExpr dsExpr dsLet;
_declarations_
1 dsExpr _:_ TcHsSyn.TypecheckedHsExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
1 dsLet _:_ TcHsSyn.TypecheckedHsBinds -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
+
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 6d4998110d4739f4e22f2991917725fd938ca32f..afdf16641fce541874577f8242ae1e0289bf3d5c 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -35,7 +35,7 @@ import FieldLabel ( FieldLabel )
import Id ( Id, idType, recordSelectorFieldLabel )
import Const ( Con(..) )
import DataCon ( DataCon, dataConId, dataConTyCon, dataConArgTys, dataConFieldLabels )
-import Const ( mkMachInt, Literal(..) )
+import Const ( mkMachInt, Literal(..), mkStrLit )
import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import TyCon ( isNewTyCon )
import DataCon ( isExistentialDataCon )
@@ -328,7 +328,7 @@ dsExpr (HsLet binds body)
= dsExpr body `thenDs` \ body' ->
dsLet binds body'
-dsExpr (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty src_loc)
+dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc)
| maybeToBool maybe_list_comp
= -- Special case for list comprehensions
putSrcLocDs src_loc $
@@ -336,7 +336,7 @@ dsExpr (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty src_loc)
| otherwise
= putSrcLocDs src_loc $
- dsDo do_or_lc stmts return_id then_id zero_id result_ty
+ dsDo do_or_lc stmts return_id then_id fail_id result_ty
where
maybe_list_comp
= case (do_or_lc, splitTyConApp_maybe result_ty) of
@@ -563,7 +563,6 @@ dsExpr (DictApp expr dicts) -- becomes a curried application
\begin{code}
-
#ifdef DEBUG
-- HsSyn constructs that just shouldn't be here:
dsExpr (HsDo _ _ _) = panic "dsExpr:HsDo"
@@ -585,11 +584,11 @@ dsDo :: StmtCtxt
-> [TypecheckedStmt]
-> Id -- id for: return m
-> Id -- id for: (>>=) m
- -> Id -- id for: zero m
+ -> Id -- id for: fail m
-> Type -- Element type; the whole expression has type (m t)
-> DsM CoreExpr
-dsDo do_or_lc stmts return_id then_id zero_id result_ty
+dsDo do_or_lc stmts return_id then_id fail_id result_ty
= let
(_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b)
@@ -600,7 +599,12 @@ dsDo do_or_lc stmts return_id then_id zero_id result_ty
go (GuardStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
- returnDs (mkIfThenElse expr2 rest (App (Var zero_id) (Type b_ty)))
+ let msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in
+ returnDs (mkIfThenElse expr2
+ rest
+ (App (App (Var fail_id)
+ (Type b_ty))
+ (mkLit (mkStrLit msg stringTy))))
go (ExprStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
@@ -624,13 +628,17 @@ dsDo do_or_lc stmts return_id then_id zero_id result_ty
dsExpr expr `thenDs` \ expr2 ->
let
(_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a)
- zero_expr = TyApp (HsVar zero_id) [b_ty]
- main_match = mkSimpleMatch [pat] (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty locn)
+ fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty]) (HsLitOut (HsString (_PK_ msg)) stringTy)
+ msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
+ main_match = mkSimpleMatch [pat]
+ (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty locn)
(Just result_ty) locn
the_matches
- = if failureFreePat pat
- then [main_match]
- else [main_match, mkSimpleMatch [WildPat a_ty] zero_expr (Just result_ty) locn]
+ | failureFreePat pat = [main_match]
+ | otherwise =
+ [ main_match
+ , mkSimpleMatch [WildPat a_ty] fail_expr (Just result_ty) locn
+ ]
in
matchWrapper DoBindMatch the_matches match_msg
`thenDs` \ (binders, matching_code) ->
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 2e10554ccc765ae331b23ee77008a1521f6543f8..2811ee6ca514ef6a4a48f19b5e8f5b9276bef488 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -276,8 +276,9 @@ data ConDetails name
| RecCon -- record-style con decl
[([name], BangType name)] -- list of "fields"
- | NewCon -- newtype con decl
+ | NewCon -- newtype con decl, possibly with a labelled field.
(HsType name)
+ (Maybe name) -- Just x => labelled field 'x'
data BangType name
= Banged (HsType name) -- HsType: to allow Haskell extensions
@@ -295,9 +296,14 @@ ppr_con_details con (InfixCon ty1 ty2)
ppr_con_details con (VanillaCon tys)
= ppr con <+> hsep (map (ppr_bang) tys)
-ppr_con_details con (NewCon ty)
+ppr_con_details con (NewCon ty Nothing)
= ppr con <+> pprParendHsType ty
+ppr_con_details con (NewCon ty (Just x))
+ = ppr con <+> braces pp_field
+ where
+ pp_field = ppr x <+> dcolon <+> pprParendHsType ty
+
ppr_con_details con (RecCon fields)
= ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
where
diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot b/ghc/compiler/hsSyn/HsExpr.hi-boot
index 64b4a2fc978aaa500a644b1b56f4c21b9b53f81d..dd003096b7fcb37573ce567dac55a65e43dea599 100644
--- a/ghc/compiler/hsSyn/HsExpr.hi-boot
+++ b/ghc/compiler/hsSyn/HsExpr.hi-boot
@@ -4,3 +4,4 @@ HsExpr HsExpr pprExpr;
_declarations_
1 data HsExpr i p;
1 pprExpr _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;;
+
diff --git a/ghc/compiler/parser/constr.ugn b/ghc/compiler/parser/constr.ugn
index 7894455ac392023c0fe81f0c3298c289dd430be8..5d678c86980488e4dc37a2853d4c3802f61e832d 100644
--- a/ghc/compiler/parser/constr.ugn
+++ b/ghc/compiler/parser/constr.ugn
@@ -34,6 +34,7 @@ type constr;
/* constr in simple "newtype" form: */
constrnew : < gconnid : qid;
gconnty : ttype;
+ gconnla : maybe; /* Maybe qvar */
gconnline : long; >;
/* constr with a existential prefixed context C => ... */
diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex
index eea945c9683e22955dcd597f11cbb89e4a0024f1..02bc1ef711b5a7cf8255840233eb21836f5c59dc 100644
--- a/ghc/compiler/parser/hslexer.flex
+++ b/ghc/compiler/parser/hslexer.flex
@@ -137,6 +137,8 @@ static void new_filename PROTO((char *));
static int Return PROTO((int));
static void hsentercontext PROTO((int));
+static BOOLEAN is_commment PROTO((char*, int));
+
/* Special file handling for IMPORTS */
/* Note: imports only ever go *one deep* (hence no need for a stack) WDP 94/09 */
@@ -242,7 +244,7 @@ F {N}"."{N}(("e"|"E")("+"|"-")?{N})?
S [!#$%&*+./<=>?@\\^|\-~:\xa1-\xbf\xd7\xf7]
SId {S}{S}*
L [A-Z\xc0-\xd6\xd8-\xde]
-l [a-z\xdf-\xf6\xf8-\xff]
+l [a-z_\xdf-\xf6\xf8-\xff]
I {L}|{l}
i {L}|{l}|[0-9'_]
Id {I}{i}*
@@ -268,7 +270,6 @@ NL [\n\r]
*/
%}
-<Code,GlaExt,StringEsc>"--"[^\n\r]*{NL}?{WS}* |
<Code,GlaExt,UserPragma,StringEsc>{WS}+ { noGap = FALSE; }
%{
@@ -430,7 +431,6 @@ NL [\n\r]
<Code,GlaExt,UserPragma>"," { RETURN(COMMA); }
<Code,GlaExt>";" { RETURN(SEMI); }
<Code,GlaExt>"`" { RETURN(BQUOTE); }
-<Code,GlaExt>"_" { RETURN(WILDCARD); }
<Code,GlaExt>"." { RETURN(DOT); }
<Code,GlaExt>".." { RETURN(DOTDOT); }
@@ -536,8 +536,16 @@ NL [\n\r]
RETURN(isconstr(yytext) ? CONID : VARID);
}
<Code,GlaExt,UserPragma>{SId} {
- hsnewid(yytext, yyleng);
- RETURN(isconstr(yytext) ? CONSYM : VARSYM);
+ if (is_commment(yytext,yyleng)) {
+ int c;
+ while ((c = input()) != '\n' && c != '\r' && c!= EOF )
+ ;
+ if (c != EOF)
+ unput(c);
+ } else {
+ hsnewid(yytext, yyleng);
+ RETURN(isconstr(yytext) ? CONSYM : VARSYM);
+ }
}
<Code,GlaExt,UserPragma>{Mod}"."{Id}"#" {
BOOLEAN is_constr;
@@ -737,6 +745,19 @@ NL [\n\r]
<CharEsc>\\ { addchar(*yytext); POP_STATE; }
<StringEsc>\\ { if (noGap) { addchar(*yytext); } POP_STATE; }
+%{
+/*
+ Not 100% correct, tokenizes "foo \ --<>--
+ \ bar"
+
+ as "foo bar", but this is not correct as per Haskell 98 report and its
+ maximal munch rule for "--"-style comments.
+
+ For the moment, not deemed worthy to fix.
+*/
+%}
+<StringEsc>"--"[^\n\r]*{NL}?{WS}* { noGap=FALSE; }
+
<CharEsc,StringEsc>["'] { addchar(*yytext); POP_STATE; }
<CharEsc,StringEsc>NUL { addchar('\000'); POP_STATE; }
<CharEsc,StringEsc>SOH { addchar('\001'); POP_STATE; }
@@ -837,6 +858,7 @@ NL [\n\r]
<Comment>"-}" { if (--nested_comments == 0) POP_STATE; }
<Comment>(.|\n) ;
+
%{
/*
* Illegal characters. This used to be a single rule, but we might as well
@@ -974,6 +996,11 @@ new_filename(char *f) /* This looks pretty dodgy to me (WDP) */
forcing insertion of ; or } as appropriate
*/
+#ifdef HSP_DEBUG
+#define LAYOUT_DEBUG
+#endif
+
+
static BOOLEAN
hsshouldindent(void)
{
@@ -985,7 +1012,7 @@ hsshouldindent(void)
void
hssetindent(void)
{
-#ifdef HSP_DEBUG
+#ifdef LAYOUT_DEBUG
fprintf(stderr, "hssetindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
#endif
@@ -1014,7 +1041,7 @@ hssetindent(void)
void
hsincindent(void)
{
-#ifdef HSP_DEBUG
+#ifdef LAYOUT_DEBUG
fprintf(stderr, "hsincindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
#endif
hsentercontext(indenttab[icontexts] & ~1);
@@ -1042,7 +1069,7 @@ hsentercontext(int indent)
}
forgetindent = FALSE;
indenttab[icontexts] = indent;
-#ifdef HSP_DEBUG
+#ifdef LAYOUT_DEBUG
fprintf(stderr, "hsentercontext:indent=%d,hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", indent, hscolno, hspcolno, icontexts, INDENTPT);
#endif
}
@@ -1053,7 +1080,7 @@ void
hsendindent(void)
{
--icontexts;
-#ifdef HSP_DEBUG
+#ifdef LAYOUT_DEBUG
fprintf(stderr, "hsendindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
#endif
}
@@ -1061,14 +1088,12 @@ hsendindent(void)
/*
* Return checks the indentation level and returns ;, } or the specified token.
*/
-
static int
Return(int tok)
{
#ifdef HSP_DEBUG
extern int yyleng;
#endif
-
if (hsshouldindent()) {
if (hspcolno < INDENTPT) {
#ifdef HSP_DEBUG
@@ -1084,6 +1109,7 @@ Return(int tok)
return (SEMI);
}
}
+
hssttok = -1;
#ifdef HSP_DEBUG
fprintf(stderr, "returning %d (%d:%d)\n", tok, hspcolno, INDENTPT);
@@ -1344,3 +1370,21 @@ hsnewqid(char *name, int length)
return isconstr(dot+1);
}
+
+static
+BOOLEAN
+is_commment(char* lexeme, int len)
+{
+ char* ptr;
+ int i;
+
+ if (len < 2) {
+ return FALSE;
+ }
+
+ for(i=0;i<len;i++) {
+ if (lexeme[i] != '-') return FALSE;
+ }
+ return TRUE;
+}
+
diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y
index 920d6aa688e4718590ddc91f95b4e7659c6518a9..7e1824511bebc5560669dff9be3208f53739a1c7 100644
--- a/ghc/compiler/parser/hsparser.y
+++ b/ghc/compiler/parser/hsparser.y
@@ -128,7 +128,7 @@ BOOLEAN pat_check=TRUE;
%token OCURLY CCURLY VCCURLY
%token COMMA SEMI OBRACK CBRACK
-%token WILDCARD BQUOTE OPAREN CPAREN
+%token BQUOTE OPAREN CPAREN
%token OUNBOXPAREN CUNBOXPAREN
@@ -232,10 +232,10 @@ BOOLEAN pat_check=TRUE;
dorest stmts stmt
rbinds rbinds1 rpats rpats1 list_exps list_rest
qvarsk qvars_list
- constrs constr1 fields conargatypes
+ constrs fields conargatypes
tautypes atypes
types_and_maybe_ids
- pats simple_context simple_context_list
+ pats simple_context simple_context_list
export_list enames
import_list inames
impdecls maybeimpdecls impdecl
@@ -274,10 +274,10 @@ BOOLEAN pat_check=TRUE;
gcon gconk gtycon itycon qop1 qvarop1
ename iname
-%type <ubinding> topdecl topdecls letdecls
+%type <ubinding> topdecl topdecls topdecls1 letdecls
typed datad newtd classd instd defaultd foreignd
- decl decls fixdecl fix_op fix_ops valdef
- maybe_where cbody rinst type_and_maybe_id
+ decl decls decls1 fixdecl fix_op fix_ops valdef
+ maybe_where type_and_maybe_id
%type <uttype> polytype
conargatype conapptype
@@ -286,7 +286,7 @@ BOOLEAN pat_check=TRUE;
atype polyatype
simple_con_app simple_con_app1 inst_type
-%type <uconstr> constr constr_after_context field
+%type <uconstr> constr constr_after_context field constr1
%type <ustring> FLOAT INTEGER INTPRIM
FLOATPRIM DOUBLEPRIM CLITLIT
@@ -368,7 +368,7 @@ enames : ename { $$ = lsing($1); }
| enames COMMA ename { $$ = lapp($1,$3); }
;
ename : qvar
- | qcon
+ | gcon
;
@@ -392,11 +392,12 @@ impdecl : importkey modid impspec
;
impspec : /* empty */ { $$ = mknothing(); }
- | OPAREN CPAREN { $$ = mkjust(mkleft(Lnil)); }
- | OPAREN import_list CPAREN { $$ = mkjust(mkleft($2)); }
- | OPAREN import_list COMMA CPAREN { $$ = mkjust(mkleft($2)); }
- | HIDING OPAREN import_list CPAREN { $$ = mkjust(mkright($3)); }
- | HIDING OPAREN import_list COMMA CPAREN { $$ = mkjust(mkright($3)); }
+ | OPAREN CPAREN { $$ = mkjust(mkleft(Lnil)); }
+ | OPAREN import_list CPAREN { $$ = mkjust(mkleft($2)); }
+ | OPAREN import_list COMMA CPAREN { $$ = mkjust(mkleft($2)); }
+ | HIDING OPAREN CPAREN { $$ = mkjust(mkright(Lnil)); }
+ | HIDING OPAREN import_list CPAREN { $$ = mkjust(mkright($3)); }
+ | HIDING OPAREN import_list COMMA CPAREN { $$ = mkjust(mkright($3)); }
;
import_list:
@@ -432,8 +433,10 @@ iname : var { $$ = mknoqual($1); }
* *
**********************************************************************/
-topdecls: topdecl
- | topdecls SEMI topdecl
+topdecls: topdecls1 opt_semi { $$ = $1; }
+
+topdecls1: topdecl
+ | topdecls1 SEMI topdecl
{
if($1 != NULL)
if($3 != NULL)
@@ -473,31 +476,26 @@ datad : datakey simple_con_app EQUAL constrs deriving
;
newtd : newtypekey simple_con_app EQUAL constr1 deriving
- { $$ = mkntbind(Lnil,$2,$4,$5,startlineno); }
+ { $$ = mkntbind(Lnil,$2,lsing($4),$5,startlineno); }
| newtypekey simple_context DARROW simple_con_app EQUAL constr1 deriving
- { $$ = mkntbind($2,$4,$6,$7,startlineno); }
+ { $$ = mkntbind($2,$4,lsing($6),$7,startlineno); }
;
deriving: /* empty */ { $$ = mknothing(); }
| DERIVING dtyclses { $$ = mkjust($2); }
;
-classd : classkey apptype DARROW simple_con_app1 cbody
+classd : classkey apptype DARROW simple_con_app1 maybe_where
/* Context can now be more than simple_context */
{ $$ = mkcbind(type2context($2),$4,$5,startlineno); }
- | classkey apptype cbody
+ | classkey apptype maybe_where
/* We have to say apptype rather than simple_con_app1, else
we get reduce/reduce errs */
{ check_class_decl_head($2);
$$ = mkcbind(Lnil,$2,$3,startlineno); }
;
-cbody : /* empty */ { $$ = mknullbind(); }
- | WHERE ocurly decls ccurly { checkorder($3); $$ = $3; }
- | WHERE vocurly decls vccurly { checkorder($3); $$ = $3; }
- ;
-
-instd : instkey inst_type rinst { $$ = mkibind($2,$3,startlineno); }
+instd : instkey inst_type maybe_where { $$ = mkibind($2,$3,startlineno); }
;
/* Compare polytype */
@@ -509,11 +507,6 @@ inst_type : apptype DARROW apptype { is_context_format( $3, 0 ); /* Check the
;
-rinst : /* empty */ { $$ = mknullbind(); }
- | WHERE ocurly decls ccurly { $$ = $3; }
- | WHERE vocurly decls vccurly { $$ = $3; }
- ;
-
defaultd: defaultkey OPAREN tautypes CPAREN { $$ = mkdbind($3,startlineno); }
| defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); }
;
@@ -543,10 +536,10 @@ unsafe_flag: UNSAFE { $$ = 1; }
| /*empty*/ { $$ = 0; }
;
+decls : decls1 opt_semi { $$ = $1; }
-
-decls : decl
- | decls SEMI decl
+decls1 : decl
+ | decls1 SEMI decl
{
if(SAMEFN)
{
@@ -558,6 +551,10 @@ decls : decl
}
;
+opt_semi : /*empty*/
+ | SEMI
+ ;
+
/*
Note: if there is an iclasop_pragma here, then we must be
doing a class-op in an interface -- unless the user is up
@@ -622,7 +619,6 @@ decl : fixdecl
/* end of user-specified pragmas */
| valdef
- | /* empty */ { $$ = mknullbind(); FN = NULL; SAMEFN = 0; }
;
fixdecl : INFIXL INTEGER { Precedence = checkfixity($2); Fixity = INFIXL; }
@@ -769,10 +765,11 @@ simple_con_app1: gtycon tyvar { $$ = mktapp(mktname($1),mknamedtvar($2)); }
;
simple_context : OPAREN simple_context_list CPAREN { $$ = $2; }
+ | OPAREN CPAREN { $$ = Lnil; }
| simple_con_app1 { $$ = lsing($1); }
;
-simple_context_list: simple_con_app1 { $$ = lsing($1); }
+simple_context_list : simple_con_app1 { $$ = lsing($1); }
| simple_context_list COMMA simple_con_app1 { $$ = lapp($1,$3); }
;
@@ -819,6 +816,7 @@ constr_after_context :
| conargatype qconop conargatype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
/* Con { op1 :: Int } */
+ | qtycon OCURLY CCURLY { $$ = mkconstrrec($1,Lnil,hsplineno); }
| qtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); }
| OPAREN qconsym CPAREN OCURLY fields CCURLY { $$ = mkconstrrec($2,$5,hsplineno); }
;
@@ -845,7 +843,8 @@ field : qvars_list DCOLON polytype { $$ = mkfield($1,$3); }
| qvars_list DCOLON BANG polyatype { $$ = mkfield($1,mktbang($4)); }
;
-constr1 : gtycon conargatype { $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
+constr1 : gtycon conargatype { $$ = mkconstrnew($1,$2,mknothing(),hsplineno); }
+ | gtycon OCURLY qvar DCOLON polytype CCURLY { $$ = mkconstrnew($1,$5,mkjust($3),hsplineno); }
;
@@ -916,7 +915,7 @@ maybe_where:
WHERE ocurly decls ccurly { $$ = $3; }
| WHERE vocurly decls vccurly { $$ = $3; }
/* A where containing no decls is OK */
- | WHERE SEMI { $$ = mknullbind(); }
+ | WHERE { $$ = mknullbind(); }
| /* empty */ { $$ = mknullbind(); }
;
@@ -1070,7 +1069,6 @@ aexp : qvar { $$ = mkident($1); }
/* these add 2 S/R conflict with with aexp . OCURLY rbinds CCURLY */
| qvar AT aexp { checkinpat(); $$ = mkas($1,$3); }
| LAZY aexp { checkinpat(); $$ = mklazyp($2); }
- | WILDCARD { checkinpat(); $$ = mkwildp(); }
;
/* ccall arguments */
@@ -1093,8 +1091,7 @@ rbinds1 : rbind { $$ = lsing($1); }
| rbinds1 COMMA rbind { $$ = lapp($1,$3); }
;
-rbind : qvar { $$ = mkrbind($1,mknothing()); }
- | qvar EQUAL exp { $$ = mkrbind($1,mkjust($3)); }
+rbind : qvar EQUAL exp { $$ = mkrbind($1,mkjust($3)); }
;
texps : exp { $$ = lsing($1); }
@@ -1261,7 +1258,6 @@ apat : gcon { $$ = mkident($1); }
apatc : qvar { $$ = mkident($1); }
| qvar AT apat { $$ = mkas($1,$3); }
| lit_constant { $$ = mklit($1); }
- | WILDCARD { $$ = mkwildp(); }
| OPAREN pat CPAREN { $$ = mkpar($2); }
| OPAREN pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
| OUNBOXPAREN pat COMMA pats CUNBOXPAREN { $$ = mkutuple(mklcons($2,$4)); }
@@ -1303,8 +1299,7 @@ rpats1 : rpat { $$ = lsing($1); }
| rpats1 COMMA rpat { $$ = lapp($1,$3); }
;
-rpat : qvar { $$ = mkrbind($1,mknothing()); }
- | qvar EQUAL pat { $$ = mkrbind($1,mkjust($3)); }
+rpat : qvar EQUAL pat { $$ = mkrbind($1,mkjust($3)); }
;
@@ -1330,7 +1325,6 @@ conpatk : gconk { $$ = mkident($1); }
apatck : qvark { $$ = mkident($1); }
| qvark AT apat { $$ = mkas($1,$3); }
| lit_constant { $$ = mklit($1); setstartlineno(); }
- | WILDCARD { $$ = mkwildp(); setstartlineno(); }
| oparenkey pat CPAREN { $$ = mkpar($2); }
| oparenkey pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
| ounboxparenkey pat COMMA pats CUNBOXPAREN
diff --git a/ghc/compiler/parser/id.c b/ghc/compiler/parser/id.c
index 053dc449f71f7169caefd0082c4bad98bad0d106..0ee41f8b23da9620fcf8a9d5ee4928c1c45c0f57 100644
--- a/ghc/compiler/parser/id.c
+++ b/ghc/compiler/parser/id.c
@@ -285,7 +285,7 @@ qid_to_pmod(q)
ARROWCON function arrow ->
LISTCON list type constructor [], or the empty list []
- UNITCON unit type constructor (), or the unity value ()
+ UNITCON unit type constructor (), or the unit value ()
n n-tuple type constructor (,,,)
*/
diff --git a/ghc/compiler/parser/syntax.c b/ghc/compiler/parser/syntax.c
index 989ce0c0bca05e5f30c59e1b3a2f81db604250f9..244e6940f49ea9da53932a0f1ce4a7bdcde08ef7 100644
--- a/ghc/compiler/parser/syntax.c
+++ b/ghc/compiler/parser/syntax.c
@@ -563,7 +563,6 @@ checknobangs(app)
}
}
-
/* Check that a type is of the form
C a1 a2 .. an
where n>=1, and the ai are all type variables
diff --git a/ghc/compiler/parser/type2context.c b/ghc/compiler/parser/type2context.c
index 468df298eea8c64ebebf61f293ac3d38a5264714..fd142cd0ae82465d81bcd93fde7d65b9bd8598ad 100644
--- a/ghc/compiler/parser/type2context.c
+++ b/ghc/compiler/parser/type2context.c
@@ -44,14 +44,22 @@ type2context(t)
return(gttuple(t)); /* args */
-
- case tapp:
case tname:
+ switch(tqid(gtypeid(t))) {
+ case gid:
+ if (strcmp("()",gidname(gtypeid(t))) == 0)
+ return (Lnil);
+ default: ;
+ }
+ case tapp:
/* a single item, ensure correct format */
is_context_format(t, 0);
return(lsing(t));
case namedtvar:
+ fprintf(stderr, "namedtvar: %d %s\n", hashIds, gnamedtvar(t));
+ if (strcmp("()", gnamedtvar(t)) == 0)
+ return (Lnil);
hsperror ("type2context: unexpected namedtvar found in a context");
case tllist:
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index eca0bd8724099e57d552a8b9f2fab13f7c26c095..6c4049ea5d81962715e1534070a3d5569c273955 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -44,7 +44,7 @@ module PrelInfo (
-- RdrNames for lots of things, mainly used in derivings
eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR,
compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR,
- enumFromThen_RDR, enumFromThenTo_RDR, fromEnum_RDR, toEnum_RDR,
+ enumFromThen_RDR, enumFromThenTo_RDR, succ_RDR, pred_RDR, fromEnum_RDR, toEnum_RDR,
ratioDataCon_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR,
readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR,
ltTag_RDR, eqTag_RDR, gtTag_RDR, eqH_Char_RDR, ltH_Char_RDR,
@@ -58,7 +58,7 @@ module PrelInfo (
numClass_RDR, fractionalClass_RDR, eqClass_RDR,
ccallableClass_RDR, creturnableClass_RDR,
- monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
+ monadClass_RDR, enumClass_RDR, ordClass_RDR,
ioDataCon_RDR,
mkTupConRdrName, mkUbxTupConRdrName
@@ -193,7 +193,6 @@ data_tycons
, int64TyCon
, integerTyCon
, listTyCon
- , voidTyCon
, wordTyCon
, word8TyCon
, word16TyCon
@@ -212,8 +211,13 @@ data_tycons
\begin{code}
wired_in_ids
= [ -- These error-y things are wired in because we don't yet have
- -- a way to express in an inteface file that the result type variable
+ -- a way to express in an interface file that the result type variable
-- is 'open'; that is can be unified with an unboxed type
+ --
+ -- [The interface file format now carry such information, but there's
+ -- no way yet of expressing at the definition site for these error-reporting
+ -- functions that they have an 'open' result type. -- sof 1/99]
+ --
aBSENT_ERROR_ID
, eRROR_ID
, iRREFUT_PAT_ERROR_ID
@@ -368,7 +372,6 @@ knownKeyNames
, (numClass_RDR, numClassKey) -- mentioned, numeric
, (enumClass_RDR, enumClassKey) -- derivable
, (monadClass_RDR, monadClassKey)
- , (monadZeroClass_RDR, monadZeroClassKey)
, (monadPlusClass_RDR, monadPlusClassKey)
, (functorClass_RDR, functorClassKey)
, (showClass_RDR, showClassKey) -- derivable
@@ -397,7 +400,7 @@ knownKeyNames
, (eq_RDR, eqClassOpKey)
, (thenM_RDR, thenMClassOpKey)
, (returnM_RDR, returnMClassOpKey)
- , (zeroM_RDR, zeroClassOpKey)
+ , (failM_RDR, failMClassOpKey)
, (fromRational_RDR, fromRationalClassOpKey)
, (deRefStablePtr_RDR, deRefStablePtrIdKey)
@@ -466,7 +469,6 @@ boundedClass_RDR = tcQual (pREL_BASE, SLIT("Bounded"))
numClass_RDR = tcQual (pREL_BASE, SLIT("Num"))
enumClass_RDR = tcQual (pREL_BASE, SLIT("Enum"))
monadClass_RDR = tcQual (pREL_BASE, SLIT("Monad"))
-monadZeroClass_RDR = tcQual (pREL_BASE, SLIT("MonadZero"))
monadPlusClass_RDR = tcQual (pREL_BASE, SLIT("MonadPlus"))
functorClass_RDR = tcQual (pREL_BASE, SLIT("Functor"))
showClass_RDR = tcQual (pREL_BASE, SLIT("Show"))
@@ -484,6 +486,8 @@ creturnableClass_RDR = tcQual (pREL_GHC, SLIT("CReturnable"))
fromInt_RDR = varQual (pREL_BASE, SLIT("fromInt"))
fromInteger_RDR = varQual (pREL_BASE, SLIT("fromInteger"))
minus_RDR = varQual (pREL_BASE, SLIT("-"))
+succ_RDR = varQual (pREL_BASE, SLIT("succ"))
+pred_RDR = varQual (pREL_BASE, SLIT("pred"))
toEnum_RDR = varQual (pREL_BASE, SLIT("toEnum"))
fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum"))
enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom"))
@@ -493,7 +497,7 @@ enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo"))
thenM_RDR = varQual (pREL_BASE, SLIT(">>="))
returnM_RDR = varQual (pREL_BASE, SLIT("return"))
-zeroM_RDR = varQual (pREL_BASE, SLIT("zero"))
+failM_RDR = varQual (pREL_BASE, SLIT("fail"))
fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational"))
negate_RDR = varQual (pREL_BASE, SLIT("negate"))
@@ -518,8 +522,8 @@ not_RDR = varQual (pREL_BASE, SLIT("not"))
compose_RDR = varQual (pREL_BASE, SLIT("."))
append_RDR = varQual (pREL_BASE, SLIT("++"))
map_RDR = varQual (pREL_BASE, SLIT("map"))
-concat_RDR = varQual (mONAD, SLIT("concat"))
-filter_RDR = varQual (mONAD, SLIT("filter"))
+concat_RDR = varQual (pREL_LIST, SLIT("concat"))
+filter_RDR = varQual (pREL_LIST, SLIT("filter"))
zip_RDR = varQual (pREL_LIST, SLIT("zip"))
showList___RDR = varQual (pREL_BASE, SLIT("showList__"))
@@ -602,15 +606,20 @@ deriving_occ_info
, (ordClassKey, [intTyCon_RDR, compose_RDR, eqTag_RDR])
-- EQ (from Ordering) is needed to force in the constructors
-- as well as the type constructor.
- , (enumClassKey, [intTyCon_RDR, map_RDR])
+ , (enumClassKey, [intTyCon_RDR, map_RDR, plus_RDR, showsPrec_RDR, append_RDR])
+ -- The last two Enum deps are only used to produce better
+ -- error msgs for derived toEnum methods.
, (boundedClassKey, [intTyCon_RDR])
, (showClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR,
showParen_RDR, showSpace_RDR, showList___RDR])
, (readClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, append_RDR,
- lex_RDR, readParen_RDR, readList___RDR])
+ lex_RDR, readParen_RDR, readList___RDR, thenM_RDR])
+ -- returnM (and the rest of the Monad class decl)
+ -- will be forced in as result of depending
+ -- on thenM. -- SOF 1/99
, (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR, enumFromTo_RDR,
- returnM_RDR, zeroM_RDR])
- -- the last two are needed to force returnM, thenM and zeroM
+ returnM_RDR, failM_RDR])
+ -- the last two are needed to force returnM, thenM and failM
-- in before typechecking the list(monad) comprehension
-- generated for derived Ix instances (range method)
-- of single constructor types. -- SOF 8/97
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 3b35044daa6dd5f646b5cd1059e0a0e963ae3d11..4a6e215de98b0efd70426070ba7a15e4ca27ac8d 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -161,6 +161,7 @@ data PrimOp
| TakeMVarOp
| PutMVarOp
| SameMVarOp
+ | IsEmptyMVarOp
-- exceptions
| CatchOp
@@ -490,36 +491,37 @@ tagOf_PrimOp NewMVarOp = ILIT(196)
tagOf_PrimOp TakeMVarOp = ILIT(197)
tagOf_PrimOp PutMVarOp = ILIT(198)
tagOf_PrimOp SameMVarOp = ILIT(199)
-tagOf_PrimOp MakeForeignObjOp = ILIT(200)
-tagOf_PrimOp WriteForeignObjOp = ILIT(201)
-tagOf_PrimOp MkWeakOp = ILIT(202)
-tagOf_PrimOp DeRefWeakOp = ILIT(203)
-tagOf_PrimOp MakeStablePtrOp = ILIT(204)
-tagOf_PrimOp DeRefStablePtrOp = ILIT(205)
-tagOf_PrimOp EqStablePtrOp = ILIT(206)
-tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(207)
-tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(208)
-tagOf_PrimOp SeqOp = ILIT(209)
-tagOf_PrimOp ParOp = ILIT(210)
-tagOf_PrimOp ForkOp = ILIT(211)
-tagOf_PrimOp KillThreadOp = ILIT(212)
-tagOf_PrimOp DelayOp = ILIT(213)
-tagOf_PrimOp WaitReadOp = ILIT(214)
-tagOf_PrimOp WaitWriteOp = ILIT(215)
-tagOf_PrimOp ParGlobalOp = ILIT(216)
-tagOf_PrimOp ParLocalOp = ILIT(217)
-tagOf_PrimOp ParAtOp = ILIT(218)
-tagOf_PrimOp ParAtAbsOp = ILIT(219)
-tagOf_PrimOp ParAtRelOp = ILIT(220)
-tagOf_PrimOp ParAtForNowOp = ILIT(221)
-tagOf_PrimOp CopyableOp = ILIT(222)
-tagOf_PrimOp NoFollowOp = ILIT(223)
-tagOf_PrimOp NewMutVarOp = ILIT(224)
-tagOf_PrimOp ReadMutVarOp = ILIT(225)
-tagOf_PrimOp WriteMutVarOp = ILIT(226)
-tagOf_PrimOp SameMutVarOp = ILIT(227)
-tagOf_PrimOp CatchOp = ILIT(228)
-tagOf_PrimOp RaiseOp = ILIT(229)
+tagOf_PrimOp IsEmptyMVarOp = ILIT(200)
+tagOf_PrimOp MakeForeignObjOp = ILIT(201)
+tagOf_PrimOp WriteForeignObjOp = ILIT(202)
+tagOf_PrimOp MkWeakOp = ILIT(203)
+tagOf_PrimOp DeRefWeakOp = ILIT(204)
+tagOf_PrimOp MakeStablePtrOp = ILIT(205)
+tagOf_PrimOp DeRefStablePtrOp = ILIT(206)
+tagOf_PrimOp EqStablePtrOp = ILIT(207)
+tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(208)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(209)
+tagOf_PrimOp SeqOp = ILIT(210)
+tagOf_PrimOp ParOp = ILIT(211)
+tagOf_PrimOp ForkOp = ILIT(212)
+tagOf_PrimOp KillThreadOp = ILIT(213)
+tagOf_PrimOp DelayOp = ILIT(214)
+tagOf_PrimOp WaitReadOp = ILIT(215)
+tagOf_PrimOp WaitWriteOp = ILIT(216)
+tagOf_PrimOp ParGlobalOp = ILIT(217)
+tagOf_PrimOp ParLocalOp = ILIT(218)
+tagOf_PrimOp ParAtOp = ILIT(219)
+tagOf_PrimOp ParAtAbsOp = ILIT(220)
+tagOf_PrimOp ParAtRelOp = ILIT(221)
+tagOf_PrimOp ParAtForNowOp = ILIT(222)
+tagOf_PrimOp CopyableOp = ILIT(223)
+tagOf_PrimOp NoFollowOp = ILIT(224)
+tagOf_PrimOp NewMutVarOp = ILIT(225)
+tagOf_PrimOp ReadMutVarOp = ILIT(226)
+tagOf_PrimOp WriteMutVarOp = ILIT(227)
+tagOf_PrimOp SameMutVarOp = ILIT(228)
+tagOf_PrimOp CatchOp = ILIT(229)
+tagOf_PrimOp RaiseOp = ILIT(230)
tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op)
--panic# "tagOf_PrimOp: pattern-match"
@@ -751,6 +753,7 @@ allThePrimOps
TakeMVarOp,
PutMVarOp,
SameMVarOp,
+ IsEmptyMVarOp,
MakeForeignObjOp,
WriteForeignObjOp,
MkWeakOp,
@@ -1450,6 +1453,16 @@ primOpInfo SameMVarOp
mvar_ty = mkMVarPrimTy s elt
in
mkGenPrimOp SLIT("sameMVar#") [s_tv, elt_tv] [mvar_ty, mvar_ty] boolTy
+
+primOpInfo IsEmptyMVarOp
+ = let
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+ state = mkStatePrimTy s
+ in
+ mkGenPrimOp SLIT("isEmptyMVar#") [s_tv, elt_tv]
+ [mkMVarPrimTy s elt, mkStatePrimTy s]
+ (unboxedPair [state, intPrimTy])
+
\end{code}
%************************************************************************
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 3d234338500b4314aa8f3609436bcff8ae93a466..3a2a16f91212d7f88f826394aa37e4681e45c6ff 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -30,8 +30,6 @@ module TysWiredIn (
isFloatTy,
floatTyCon,
- voidTyCon, voidTy,
-
intDataCon,
intTy,
intTyCon,
@@ -43,8 +41,6 @@ module TysWiredIn (
int32TyCon,
int64TyCon,
- int64DataCon,
--- int64Ty,
integerTy,
integerTyCon,
@@ -73,6 +69,7 @@ module TysWiredIn (
stringTy,
trueDataCon,
unitTy,
+ voidTy,
wordDataCon,
wordTy,
wordTyCon,
@@ -80,9 +77,6 @@ module TysWiredIn (
word8TyCon,
word16TyCon,
word32TyCon,
-
- word64DataCon,
--- word64Ty,
word64TyCon,
isFFIArgumentTy, -- :: Type -> Bool
@@ -271,12 +265,13 @@ unboxedPairDataCon = unboxedTupleCon 2
--
-- ) It's boxed; there is only one value of this
-- type, namely "void", whose semantics is just bottom.
-
-voidTy = mkTyConTy voidTyCon
-voidTyCon = pcNonRecDataTyCon voidTyConKey pREL_GHC SLIT("Void") [] [{-No data cons-}]
-
+--
+-- Haskell 98 drops the definition of a Void type, so we just 'simulate'
+-- voidTy using ().
+voidTy = unitTy
\end{code}
+
\begin{code}
charTy = mkTyConTy charTyCon
@@ -317,10 +312,9 @@ int32TyCon = pcNonRecDataTyCon int32TyConKey iNT SLIT("Int32") [] [int32DataCon]
where
int32DataCon = pcDataCon int32DataConKey iNT SLIT("I32#") [] [] [intPrimTy] int32TyCon
-int64Ty = mkTyConTy int64TyCon
-
int64TyCon = pcNonRecDataTyCon int64TyConKey pREL_ADDR SLIT("Int64") [] [int64DataCon]
-int64DataCon = pcDataCon int64DataConKey pREL_ADDR SLIT("I64#") [] [] [int64PrimTy] int64TyCon
+ where
+ int64DataCon = pcDataCon int64DataConKey pREL_ADDR SLIT("I64#") [] [] [int64PrimTy] int64TyCon
\end{code}
\begin{code}
@@ -342,10 +336,9 @@ word32TyCon = pcNonRecDataTyCon word32TyConKey wORD SLIT("Word32") [] [word32D
where
word32DataCon = pcDataCon word32DataConKey wORD SLIT("W32#") [] [] [wordPrimTy] word32TyCon
-word64Ty = mkTyConTy word64TyCon
-
word64TyCon = pcNonRecDataTyCon word64TyConKey pREL_ADDR SLIT("Word64") [] [word64DataCon]
-word64DataCon = pcDataCon word64DataConKey pREL_ADDR SLIT("W64#") [] [] [word64PrimTy] word64TyCon
+ where
+ word64DataCon = pcDataCon word64DataConKey pREL_ADDR SLIT("W64#") [] [] [word64PrimTy] word64TyCon
\end{code}
\begin{code}
diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs
index 116f6bdcfbb24583b0b0a627ff4bb9d170cd0318..4699de9869f912ed66607d7b1ba7410924937b99 100644
--- a/ghc/compiler/reader/Lex.lhs
+++ b/ghc/compiler/reader/Lex.lhs
@@ -217,7 +217,7 @@ lexIface cont buf =
-- Numbers and comments
'-'# ->
case lookAhead# buf 1# of
- '-'# -> lex_comment cont (stepOnBy# buf 2#)
+-- '-'# -> lex_comment cont (stepOnBy# buf 2#)
c ->
if is_digit c
then lex_num cont (negate) (ord# c -# ord# '0'#) (incLexeme (incLexeme buf))
@@ -486,7 +486,10 @@ lex_id cont buf =
lex_sym cont buf =
case expandWhile# is_symbol buf of
- buf' -> case lookupUFM haskellKeySymsFM lexeme of {
+ buf'
+ | is_comment lexeme -> lex_comment cont new_buf
+ | otherwise ->
+ case lookupUFM haskellKeySymsFM lexeme of {
Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
cont kwd_token new_buf ;
Nothing -> --trace ("sym: "++unpackFS lexeme) $
@@ -495,6 +498,15 @@ lex_sym cont buf =
where lexeme = lexemeToFastString buf'
new_buf = stepOverLexeme buf'
+ is_comment fs
+ | len < 2 = False
+ | otherwise = trundle 0
+ where
+ len = lengthFS fs
+
+ trundle n | n == len = True
+ | otherwise = indexFS fs n == '-' && trundle (n+1)
+
lex_con cont buf =
case expandWhile# is_ident buf of { buf1 ->
case expandWhile# (eqChar# '#'#) buf1 of { buf' ->
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index df4e61f8ada5ab122629a538e8350eed3dfa21ef..d789197dd3bfdb30dd9c2bc60b8cbbf7d3600672 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -21,7 +21,7 @@ import CallConv
import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts )
import Name ( OccName, srcTvOcc, srcVarOcc, srcTCOcc,
Module, mkModuleFS,
- isConOcc, isLexConId
+ isConOcc, isLexConId, isWildCardOcc
)
import Outputable
import SrcLoc ( SrcLoc )
@@ -311,7 +311,6 @@ wlkExpr expr
U_hmodule _ _ _ _ _ _ -> error "U_hmodule"
U_as _ _ -> error "U_as"
U_lazyp _ -> error "U_lazyp"
- U_wildp -> error "U_wildp"
U_qual _ _ -> error "U_qual"
U_guard _ -> error "U_guard"
U_seqlet _ -> error "U_seqlet"
@@ -395,19 +394,18 @@ wlkPat pat
wlkLiteral lit `thenUgn` \ lit ->
returnUgn (NPlusKPatIn var lit)
- U_wildp -> returnUgn WildPatIn -- wildcard pattern
-
U_lit lit -> -- literal pattern
wlkLiteral lit `thenUgn` \ lit ->
returnUgn (LitPatIn lit)
U_ident nn -> -- simple identifier
wlkVarId nn `thenUgn` \ n ->
+ let occ = rdrNameOcc n in
returnUgn (
- if isConOcc (rdrNameOcc n) then
+ if isConOcc occ then
ConPatIn n []
else
- VarPatIn n
+ if (isWildCardOcc occ) then WildPatIn else (VarPatIn n)
)
U_ap l r -> -- "application": there's a list of patterns lurking here!
@@ -429,6 +427,8 @@ wlkPat pat
U_ap l r ->
wlkPat r `thenUgn` \ rpat ->
collect_pats l (rpat:acc)
+ U_par l ->
+ collect_pats l acc
other ->
wlkPat other `thenUgn` \ pat ->
returnUgn (pat,acc)
@@ -839,24 +839,25 @@ wlkConDecl (U_constrinf cty1 cop cty2 srcline)
wlkBangType cty2 `thenUgn` \ ty2 ->
returnUgn (ConDecl op [] [] (InfixCon ty1 ty2) src_loc)
-wlkConDecl (U_constrnew ccon cty srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkDataId ccon `thenUgn` \ con ->
- wlkHsSigType cty `thenUgn` \ ty ->
- returnUgn (ConDecl con [] [] (NewCon ty) src_loc)
+wlkConDecl (U_constrnew ccon cty mb_lab srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkDataId ccon `thenUgn` \ con ->
+ wlkHsSigType cty `thenUgn` \ ty ->
+ wlkMaybe rdVarId mb_lab `thenUgn` \ mb_lab ->
+ returnUgn (ConDecl con [] [] (NewCon ty mb_lab) src_loc)
wlkConDecl (U_constrrec ccon cfields srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkDataId ccon `thenUgn` \ con ->
wlkList rd_field cfields `thenUgn` \ fields_lists ->
returnUgn (ConDecl con [] [] (RecCon fields_lists) src_loc)
- where
+ where
rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
- rd_field pt
- = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
- wlkList rdVarId fvars `thenUgn` \ vars ->
- wlkBangType fty `thenUgn` \ ty ->
- returnUgn (vars, ty)
+ rd_field pt =
+ rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
+ wlkList rdVarId fvars `thenUgn` \ vars ->
+ wlkBangType fty `thenUgn` \ ty ->
+ returnUgn (vars, ty)
-----------------
rdBangType pt = rdU_ttype pt `thenUgn` wlkBangType
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 007b339a3a0ede7002f1b78cc0f2e89b76de1d6b..30c1478f264ebb963419afcbe5e8d5b2d080788f 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -315,7 +315,9 @@ constr : src_loc ex_stuff data_fs batypes { mkConDecl (ifaceUnqualVar $3) $2
newtype_constr :: { [RdrNameConDecl] {- Empty if handwritten abstract -} }
newtype_constr : { [] }
- | src_loc '=' ex_stuff data_name atype { [mkConDecl $4 $3 (NewCon $5) $1] }
+ | src_loc '=' ex_stuff data_name atype { [mkConDecl $4 $3 (NewCon $5 Nothing) $1] }
+ | src_loc '=' ex_stuff data_name '{' var_name '::' atype '}'
+ { [mkConDecl $4 $3 (NewCon $8 (Just $6)) $1] }
ex_stuff :: { ([HsTyVar RdrName], RdrNameContext) }
ex_stuff : { ([],[]) }
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index cea1ee7b4dbe9035cb7332596356da51a60f8b91..91a7b84129c653272ed03c75c93cee3bcccbf6bd 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -286,13 +286,14 @@ reportUnusedNames (RnEnv gbl_env _) avail_env (ExportEnv export_avails _) mentio
defined_names = mkNameSet (concat (rdrEnvElts gbl_env))
defined_but_not_used = defined_names `minusNameSet` really_used_names
- -- Filter out the ones only defined implicitly
+ -- Filter out the ones only defined implicitly or whose OccNames
+ -- start with an '_', which we won't report.
bad_guys = filter is_explicit (nameSetToList defined_but_not_used)
is_explicit n = case getNameProvenance n of
LocalDef _ _ -> True
NonLocalDef (UserImport _ _ explicit) _ _ -> explicit
other -> False
-
+
-- Now group by whether locally defined or imported;
-- one group is the locally-defined ones, one group per import module
groups = equivClasses cmp bad_guys
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index 07e4fa12072152450e745167bbf00d9b790b5647..31e376be00752be032a78130a45383e0ee2fc2bd 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -454,7 +454,9 @@ renameSigs top_lev inst_decl binders sigs
(goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs')
not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies
spec_inst_sigs = [s | s@(SpecInstSig _ _) <- goodies]
- type_sig_vars = [n | Sig n _ _ <- goodies]
+ type_sig_vars = [n | Sig n _ _ <- goodies]
+ fixes = [f | f@(FixSig _) <- goodies]
+ idecl_type_sigs = [s | s@(Sig _ _ _) <- goodies]
sigs_required = case top_lev of {TopLevel -> opt_WarnMissingSigs; NotTopLevel -> False}
un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
| otherwise = []
@@ -464,7 +466,9 @@ renameSigs top_lev inst_decl binders sigs
(if not inst_decl then
mapRn unknownSigErr spec_inst_sigs
else
- returnRn []
+ -- We're being strict here, outlawing the presence
+ -- of type signatures within an instance declaration.
+ mapRn unknownSigErr (fixes ++ idecl_type_sigs)
) `thenRn_`
mapRn (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`
@@ -532,6 +536,7 @@ sig_tag (SpecSig n1 _ _ _) = ILIT(2)
sig_tag (InlineSig n1 _) = ILIT(3)
sig_tag (NoInlineSig n1 _) = ILIT(4)
sig_tag (SpecInstSig _ _) = ILIT(5)
+sig_tag (FixSig _) = ILIT(6)
sig_tag _ = panic# "tag(RnBinds)"
\end{code}
@@ -558,12 +563,13 @@ unknownSigErr sig
where
(what_it_is, loc) = sig_doc sig
-sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
-sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
-sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
-sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)
-sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc)
-sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
+sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
+sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
+sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
+sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)
+sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc)
+sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
+sig_doc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
missingSigWarn var
= sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)]
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 30f5f1939cfe086b7da71b59ebbbf69a202ee2b4..066c9919fbba3d582e18cea3c48c7b7949dbc867 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -21,7 +21,7 @@ import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
ImportReason(..), getSrcLoc,
mkLocalName, mkGlobalName,
nameOccName,
- pprOccName, isLocalName, isLocallyDefined,
+ pprOccName, isLocalName, isLocallyDefined, isAnonOcc,
setNameProvenance, getNameProvenance, pprNameProvenance
)
import NameSet
@@ -169,6 +169,7 @@ newLocalNames rdr_names
n = length rdr_names
(us', us1) = splitUniqSupply us
uniqs = uniqsFromSupply n us1
+ -- Note: we're not making use of the source location. Not good.
locals = [ mkLocalName uniq (rdrNameOcc rdr_name)
| ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs
]
@@ -680,8 +681,8 @@ warnUnusedTopNames ns
= returnRn () -- Don't force ns unless necessary
warnUnusedTopNames (n:ns)
- | is_local && opt_WarnUnusedBinds = warnUnusedNames ns
- | not is_local && opt_WarnUnusedImports = warnUnusedNames ns
+ | is_local && opt_WarnUnusedBinds = warnUnusedNames False{-include name's provenance-} ns
+ | not is_local && opt_WarnUnusedImports = warnUnusedNames False ns
where
is_local = isLocallyDefined n
@@ -689,23 +690,35 @@ warnUnusedTopName other = returnRn ()
warnUnusedBinds ns
| not opt_WarnUnusedBinds = returnRn ()
- | otherwise = warnUnusedNames ns
+ | otherwise = warnUnusedNames False ns
+{-
+ Haskell 98 encourages compilers to suppress warnings about
+ unused names in a pattern if they start with "_". Which
+ we do here.
+
+ Note: omit the inclusion of the names' provenance in the
+ generated warning -- it's already given in the header
+ of the warning (+ the local names we've been given have
+ a provenance that's ultra low in content.)
+
+-}
warnUnusedMatches names
- | opt_WarnUnusedMatches = warnUnusedNames names
+ | opt_WarnUnusedMatches = warnUnusedNames True (filter (not.isAnonOcc.getOccName) names)
| otherwise = returnRn ()
-warnUnusedNames :: [Name] -> RnM s d ()
-warnUnusedNames []
+warnUnusedNames :: Bool{-display provenance-} -> [Name] -> RnM s d ()
+warnUnusedNames _ []
= returnRn ()
-warnUnusedNames names
+warnUnusedNames short_msg names
= addWarnRn $
sep [text "The following names are unused:",
- nest 4 (vcat (map pp names))]
+ nest 4 ((if short_msg then hsep else vcat) (map pp names))]
where
- pp n = ppr n <> comma <+> pprNameProvenance n
-
+ pp n
+ | short_msg = ppr n
+ | otherwise = ppr n <> comma <+> pprNameProvenance n
addNameClashErrRn rdr_name names
{- NO LONGER NEEDED WITH LAZY NAME-CLASH REPORTING
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 6eaa5ea0d6660f8b9e561f3acd860cb9b3c836a9..6a050db482832bfed2fbde4b5d3090b6d3dd6a3b 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -29,7 +29,7 @@ import CmdLineOpts ( opt_GlasgowExts )
import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
ccallableClass_RDR, creturnableClass_RDR,
- monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
+ monadClass_RDR, enumClass_RDR, ordClass_RDR,
ratioDataCon_RDR, negate_RDR, assertErr_RDR,
ioDataCon_RDR
)
@@ -355,7 +355,7 @@ rnExpr (HsLet binds expr)
rnExpr (HsDo do_or_lc stmts src_loc)
= pushSrcLocRn src_loc $
- lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too
+ lookupImplicitOccRn monadClass_RDR `thenRn_`
rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
returnRn (HsDo do_or_lc stmts' src_loc, fvs)
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 20f88177356067dc2fec551650b4eb2fa4493c9d..543866a79584a72cf6f4623b53688ea17c301e38 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -25,7 +25,7 @@ import CmdLineOpts ( opt_PruneTyDecls, opt_PruneInstDecls,
import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..),
HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..),
FixitySig(..),
- hsDeclName, countTyClDecls, isDataDecl
+ hsDeclName, countTyClDecls, isDataDecl, nonFixitySigs
)
import BasicTypes ( Version, NewOrData(..), IfaceFlavour(..) )
import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl,
@@ -925,7 +925,11 @@ getDeclBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc
= new_name cname src_loc `thenRn` \ class_name ->
-- Record the names for the class ops
- mapRn (getClassOpNames new_name) sigs `thenRn` \ sub_names ->
+ let
+ -- ignoring fixity declarations
+ nonfix_sigs = nonFixitySigs sigs
+ in
+ mapRn (getClassOpNames new_name) nonfix_sigs `thenRn` \ sub_names ->
returnRn (AvailTC class_name (class_name : sub_names))
@@ -946,10 +950,15 @@ getConFieldNames new_name (ConDecl con _ _ (RecCon fielddecls) src_loc : rest)
where
fields = concat (map fst fielddecls)
-getConFieldNames new_name (ConDecl con _ _ _ src_loc : rest)
+getConFieldNames new_name (ConDecl con _ _ condecl src_loc : rest)
= new_name con src_loc `thenRn` \ n ->
+ (case condecl of
+ NewCon _ (Just f) ->
+ new_name f src_loc `thenRn` \ new_f ->
+ returnRn [n,new_f]
+ _ -> returnRn [n]) `thenRn` \ nn ->
getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (n:ns)
+ returnRn (nn ++ ns)
getConFieldNames new_name [] = returnRn []
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index b6c6c627d41b0674225d60a2c24fbfbeb34f0122..34966a75e7bc8a5ba76278e4ef20a0f23dc0aa71 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -396,9 +396,15 @@ rnConDetails doc locn (InfixCon ty1 ty2)
rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
-rnConDetails doc locn (NewCon ty)
- = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
- returnRn (NewCon new_ty, fvs)
+rnConDetails doc locn (NewCon ty mb_field)
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
+ rn_field mb_field `thenRn` \ new_mb_field ->
+ returnRn (NewCon new_ty new_mb_field, fvs)
+ where
+ rn_field Nothing = returnRn Nothing
+ rn_field (Just f) =
+ lookupBndrRn f `thenRn` \ new_f ->
+ returnRn (Just new_f)
rnConDetails doc locn (RecCon fields)
= checkDupOrQualNames doc field_names `thenRn_`
diff --git a/ghc/compiler/specialise/SpecEnv.hi-boot b/ghc/compiler/specialise/SpecEnv.hi-boot
index 077a6efc69b2be13e8912a03cf08f2fd43eae949..5f16e24d5d1dc929daee853635219182776829a5 100644
--- a/ghc/compiler/specialise/SpecEnv.hi-boot
+++ b/ghc/compiler/specialise/SpecEnv.hi-boot
@@ -3,3 +3,4 @@ _exports_
SpecEnv SpecEnv ;
_declarations_
1 data SpecEnv a ;
+
diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs
index 7335631009c7fa672eb03c2c4a05eec1ae5ac919..758258b2955a6efd4d6ad13a0b39ef2565d7c302 100644
--- a/ghc/compiler/typecheck/TcDefaults.lhs
+++ b/ghc/compiler/typecheck/TcDefaults.lhs
@@ -16,7 +16,7 @@ import TcEnv ( tcLookupClassByKey )
import TcMonoType ( tcHsType )
import TcSimplify ( tcSimplifyCheckThetas )
-import TysWiredIn ( intTy, doubleTy )
+import TysWiredIn ( integerTy, doubleTy )
import Type ( Type )
import Unique ( numClassKey )
import ErrUtils ( addShortErrLocLine )
@@ -25,7 +25,7 @@ import Util
\end{code}
\begin{code}
-default_default = [intTy, doubleTy] -- language-specified default `default'
+default_default = [integerTy, doubleTy ]
tcDefaults :: [RenamedHsDecl]
-> TcM s [Type] -- defaulting types to heave
diff --git a/ghc/compiler/typecheck/TcExpr.hi-boot b/ghc/compiler/typecheck/TcExpr.hi-boot
index 08fe08e53572907c42b887f3191ab72426f4e9ab..c0df69732756690fc3b8c4c44752bd74514d3695 100644
--- a/ghc/compiler/typecheck/TcExpr.hi-boot
+++ b/ghc/compiler/typecheck/TcExpr.hi-boot
@@ -7,3 +7,4 @@ _declarations_
-> TcMonad.TcType
-> TcMonad.TcM s (TcHsSyn.TcExpr, Inst.LIE) ;;
+
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 466a6992b5b42ae122d0abae89fd4a023bbd06ca..aae7a2489605fedf8ff79675ddc1871ac6e2e30c 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -9,12 +9,11 @@ module TcExpr ( tcExpr, tcPolyExpr, tcId ) where
#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsBinds(..), Stmt(..), StmtCtxt(..),
- failureFreePat
+ HsBinds(..), Stmt(..), StmtCtxt(..)
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds,
- mkHsTyApp
+ mkHsTyApp, maybeBoxedPrimType
)
import TcMonad
@@ -69,7 +68,7 @@ import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy,
import Unique ( cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
- thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
+ thenMClassOpKey, failMClassOpKey, returnMClassOpKey
)
import Outputable
import Maybes ( maybeToBool )
@@ -365,7 +364,6 @@ tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
-- constraints on the argument and result types.
mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
-
returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty])
(CCall lbl args' may_gc is_asm result_ty),
-- do the wrapping in the newtype constructor here
@@ -849,6 +847,12 @@ tcDoStmts do_or_lc stmts src_loc res_ty
newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind) `thenNF_Tc` \ m ->
newTyVarTy boxedTypeKind `thenNF_Tc` \ elt_ty ->
unifyTauTy res_ty (mkAppTy m elt_ty) `thenTc_`
+ -- If it's a comprehension we're dealing with,
+ -- force it to be a list comprehension.
+ -- (as of Haskell 98, monad comprehensions are no more.)
+ (case do_or_lc of
+ ListComp -> unifyListTy res_ty `thenTc_` returnTc ()
+ _ -> returnTc ()) `thenTc_`
tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
@@ -862,20 +866,14 @@ tcDoStmts do_or_lc stmts src_loc res_ty
--
tcLookupValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
tcLookupValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
- tcLookupValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
+ tcLookupValueByKey failMClassOpKey `thenNF_Tc` \ fail_sel_id ->
newMethod DoOrigin return_sel_id [m] `thenNF_Tc` \ (return_lie, return_id) ->
newMethod DoOrigin then_sel_id [m] `thenNF_Tc` \ (then_lie, then_id) ->
- newMethod DoOrigin zero_sel_id [m] `thenNF_Tc` \ (zero_lie, zero_id) ->
+ newMethod DoOrigin fail_sel_id [m] `thenNF_Tc` \ (fail_lie, fail_id) ->
let
- monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
- perhaps_zero_lie | all failure_free stmts' = emptyLIE
- | otherwise = zero_lie
-
- failure_free (BindStmt pat _ _) = failureFreePat pat
- failure_free (GuardStmt _ _) = False
- failure_free other_stmt = True
+ monad_lie = then_lie `plusLIE` return_lie `plusLIE` fail_lie
in
- returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id res_ty src_loc,
+ returnTc (HsDoOut do_or_lc stmts' return_id then_id fail_id res_ty src_loc,
stmts_lie `plusLIE` monad_lie)
\end{code}
@@ -1037,4 +1035,14 @@ recordUpdCtxt = ptext SLIT("In a record update construct")
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")
+
+
\end{code}
diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index 253c7bc7a157220cccdc92c40aecb88e9fca42a8..cf850f148496ae2fda4c6992c92dec234adae231 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -29,7 +29,7 @@ import TcMonad
import TcEnv ( newLocalId )
import TcType ( tcInstTcType, typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
import TcMonoType ( tcHsType )
-import TcHsSyn ( TcMonoBinds, maybeBoxedPrimType, TypecheckedForeignDecl,
+import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl,
TcForeignExportDecl )
import TcExpr ( tcId, tcPolyExpr )
import Inst ( emptyLIE, LIE, plusLIE )
diff --git a/ghc/compiler/typecheck/TcGRHSs.hi-boot b/ghc/compiler/typecheck/TcGRHSs.hi-boot
new file mode 100644
index 0000000000000000000000000000000000000000..a88316f66d9fd19d13d0164687d4cce640017305
--- /dev/null
+++ b/ghc/compiler/typecheck/TcGRHSs.hi-boot
@@ -0,0 +1,11 @@
+_interface_ TcGRHSs 2
+_exports_
+TcGRHSs tcGRHSsAndBinds;
+_declarations_
+2 tcGRHSsAndBinds _:_ _forall_ [s] =>
+ RnHsSyn.RenamedGRHSsAndBinds
+ -> TcMonad.TcType s
+ -> HsExpr.StmtCtxt
+ -> TcMonad.TcM s (TcHsSyn.TcGRHSsAndBinds s, Inst.LIE s) ;;
+
+
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 2c32c8c3595a719d91715072e9a0b758d1202ae5..cc3e2050d03a324df0f2a9e15f3c6d083e4c6bd8 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -417,6 +417,9 @@ we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
\begin{verbatim}
instance ... Enum (Foo ...) where
+ succ x = toEnum (1 + fromEnum x)
+ pred x = toEnum (fromEnum x - 1)
+
toEnum i = tag2con_Foo i
enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
@@ -443,16 +446,49 @@ For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
gen_Enum_binds :: TyCon -> RdrNameMonoBinds
gen_Enum_binds tycon
- = to_enum `AndMonoBinds`
+ = succ_enum `AndMonoBinds`
+ pred_enum `AndMonoBinds`
+ to_enum `AndMonoBinds`
enum_from `AndMonoBinds`
enum_from_then `AndMonoBinds`
from_enum
where
tycon_loc = getSrcLoc tycon
+ occ_nm = getOccString tycon
+
+ succ_enum
+ = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
+ untag_Expr tycon [(a_RDR, ah_RDR)] $
+ HsIf (HsApp (HsApp (HsVar eq_RDR)
+ (HsVar (maxtag_RDR tycon)))
+ (mk_easy_App mkInt_RDR [ah_RDR]))
+ (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
+ (HsApp (HsVar (tag2con_RDR tycon))
+ (HsApp (HsApp (HsVar plus_RDR)
+ (mk_easy_App mkInt_RDR [ah_RDR]))
+ (HsLit (HsInt 1))))
+ tycon_loc
+
+ pred_enum
+ = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
+ untag_Expr tycon [(a_RDR, ah_RDR)] $
+ HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
+ (mk_easy_App mkInt_RDR [ah_RDR]))
+ (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
+ (HsApp (HsVar (tag2con_RDR tycon))
+ (HsApp (HsApp (HsVar plus_RDR)
+ (mk_easy_App mkInt_RDR [ah_RDR]))
+ (HsLit (HsInt (-1)))))
+ tycon_loc
to_enum
= mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
- mk_easy_App (tag2con_RDR tycon) [a_RDR]
+ HsIf (HsApp (HsApp (HsVar gt_RDR)
+ (HsVar a_RDR))
+ (HsVar (maxtag_RDR tycon)))
+ (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
+ (mk_easy_App (tag2con_RDR tycon) [a_RDR])
+ tycon_loc
enum_from
= mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
@@ -1157,6 +1193,30 @@ nested_compose_Expr (e:es)
-- We generate these to keep the desugarer from complaining that they *might* happen!
impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
+-- illegal_Expr is used when signalling error conditions in the RHS of a derived
+-- method. It is currently only used by Enum.{succ,pred}
+illegal_Expr meth tp msg =
+ HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
+
+-- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
+-- to include the value of a_RDR in the error string.
+illegal_toEnum_tag tp maxtag =
+ HsApp (HsVar error_RDR)
+ (HsApp (HsApp (HsVar append_RDR)
+ (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
+ (HsApp (HsApp (HsApp
+ (HsVar showsPrec_RDR)
+ (HsLit (HsInt 0)))
+ (HsVar a_RDR))
+ (HsApp (HsApp
+ (HsVar append_RDR)
+ (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
+ (HsApp (HsApp (HsApp
+ (HsVar showsPrec_RDR)
+ (HsLit (HsInt 0)))
+ (HsVar maxtag))
+ (HsLit (HsString (_PK_ ")")))))))
+
parenify e@(HsVar _) = e
parenify e = HsPar e
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 2b7b4ad06f9a210ee14780194236f45bd4079e7a..aa21d9881fbf33ec13a24649c28cef81d667553f 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -426,7 +426,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
dict_rhs
| null scs_and_meths
- = -- Blatant special case for CCallable, CReturnable [and Eval -- sof 5/98]
+ = -- Blatant special case for CCallable, CReturnable
-- If the dictionary is empty then we should never
-- select anything from it, so we make its RHS just
-- emit an error message. This in turn means that we don't
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 517e8b2d2bd034f04649718687025cefdeb7cf55..10a07f3e592f78d15a6ee321e33df03e9f83be66 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -38,7 +38,8 @@ import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import TcTyDecls ( mkDataBinds )
import TcType ( TcType, typeToTcType,
- TcKind, kindToTcKind
+ TcKind, kindToTcKind,
+ newTyVarTy
)
import RnMonad ( RnNameSupply )
@@ -51,7 +52,8 @@ import Name ( Name, nameUnique, isLocallyDefined, pprModule, NamedThing(..) )
import TyCon ( TyCon, tyConKind )
import DataCon ( dataConId )
import Class ( Class, classSelIds, classTyCon )
-import Type ( mkTyConApp, Type )
+import Type ( mkTyConApp, mkForAllTy, mkTyVarTy,
+ boxedTypeKind, getTyVar, Type )
import TysWiredIn ( unitTy )
import PrelMods ( mAIN )
import PrelInfo ( main_NAME, ioTyCon_NAME,
@@ -285,12 +287,15 @@ tcCheckMainSig mod_name
tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon ->
tcLookupValueMaybe main_NAME `thenNF_Tc` \ maybe_main_id ->
case maybe_main_id of {
- Nothing -> failWithTc noMainErr ;
+ Nothing -> failWithTc noMainErr ;
Just main_id ->
-- Check that it has the right type (or a more general one)
+ -- As of Haskell 98, anything that unifies with (IO a) is OK.
+ newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv ->
let
- expected_tau = typeToTcType (mkTyConApp ioTyCon [unitTy])
+ tv = getTyVar "tcCheckMainSig" t_tv
+ expected_tau = typeToTcType ((mkTyConApp ioTyCon [t_tv]))
in
tcId main_NAME `thenNF_Tc` \ (_, lie, main_tau) ->
tcSetErrCtxt mainTyCheckCtxt $
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index fef10a9026b4e7eddc4b34880646c28bdc18e7dd..ad166c1776707d5f828670f67072626a6d0b154f 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -148,7 +148,7 @@ import VarSet ( mkVarSet )
import Bag ( bagToList )
import Class ( Class, ClassInstEnv, classBigSig, classInstEnv )
-import PrelInfo ( isNumericClass, isCreturnableClass )
+import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
isTyVarTy, substTopTheta, splitSigmaTy, tyVarsOfTypes
@@ -997,7 +997,11 @@ disambigGroup :: [Inst] -- All standard classes of form (C a)
-> TcM s TcDictBinds
disambigGroup dicts
- | any isNumericClass classes -- Guaranteed all standard classes
+ | any isNumericClass classes -- Guaranteed all standard classes
+ -- see comment at the end of function for reasons as to
+ -- why the defaulting mechanism doesn't apply to groups that
+ -- include CCallable or CReturnable dicts.
+ && not (any isCcallishClass classes)
= -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
-- SO, TRY DEFAULT TYPES IN ORDER
@@ -1051,7 +1055,37 @@ disambigGroup dicts
classes = map get_clas dicts
\end{code}
+[Aside - why the defaulting mechanism is turned off when
+ dealing with arguments and results to ccalls.
+When typechecking _ccall_s, TcExpr ensures that the external
+function is only passed arguments (and in the other direction,
+results) of a restricted set of 'native' types. This is
+implemented via the help of the pseudo-type classes,
+@CReturnable@ (CR) and @CCallable@ (CC.)
+
+The interaction between the defaulting mechanism for numeric
+values and CC & CR can be a bit puzzling to the user at times.
+For example,
+
+ x <- _ccall_ f
+ if (x /= 0) then
+ _ccall_ g x
+ else
+ return ()
+
+What type has 'x' got here? That depends on the default list
+in operation, if it is equal to Haskell 98's default-default
+of (Integer, Double), 'x' has type Double, since Integer
+is not an instance of CR. If the default list is equal to
+Haskell 1.4's default-default of (Int, Double), 'x' has type
+Int.
+
+To try to minimise the potential for surprises here, the
+defaulting mechanism is turned off in the presence of
+CCallable and CReturnable.
+
+]
Errors and contexts
~~~~~~~~~~~~~~~~~~~
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 4f1fa0c5ebb168e6b22c7730fe9848ac51132fc6..2a27a16aec252bba57c80514ab07aa09acb6a880 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -296,7 +296,7 @@ get_con (ConDecl _ _ ctxt details _)
----------------------------------------------------
get_con_details (VanillaCon btys) = unionManyUniqSets (map get_bty btys)
get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
-get_con_details (NewCon ty) = get_ty ty
+get_con_details (NewCon ty _) = get_ty ty
get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbtys)
----------------------------------------------------
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 181f8301173c1a4077787fad6f20e1faccd31252..5d549435163559652b6bcea505c87dcc97797e0e 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -33,7 +33,7 @@ import Class ( Class )
import DataCon ( DataCon, dataConSig, mkDataCon, isNullaryDataCon,
dataConFieldLabels, dataConId
)
-import MkId ( mkDataConId, mkRecordSelId )
+import MkId ( mkDataConId, mkRecordSelId, mkNewTySelId )
import Id ( getIdUnfolding )
import CoreUnfold ( getUnfoldingTemplate )
import FieldLabel
@@ -41,7 +41,7 @@ import Var ( Id, TyVar )
import Name ( isLocallyDefined, OccName, NamedThing(..) )
import Outputable
import TyCon ( TyCon, mkSynTyCon, mkAlgTyCon, isAlgTyCon,
- isSynTyCon, tyConDataCons
+ isSynTyCon, tyConDataCons, isNewTyCon
)
import Type ( getTyVar, tyVarsOfTypes,
mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
@@ -86,7 +86,7 @@ kcConDecl (ConDecl _ ex_tvs ex_ctxt details loc)
where
kc_con (VanillaCon btys) = mapTc kc_bty btys `thenTc_` returnTc ()
kc_con (InfixCon bty1 bty2) = mapTc kc_bty [bty1,bty2] `thenTc_` returnTc ()
- kc_con (NewCon ty) = tcHsType ty `thenTc_` returnTc ()
+ kc_con (NewCon ty _) = tcHsType ty `thenTc_` returnTc ()
kc_con (RecCon flds) = mapTc kc_field flds `thenTc_` returnTc ()
kc_bty (Banged ty) = tcHsType ty
@@ -168,7 +168,7 @@ tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details
= case details of
VanillaCon btys -> tc_datacon btys
InfixCon bty1 bty2 -> tc_datacon [bty1,bty2]
- NewCon ty -> tc_newcon ty
+ NewCon ty mb_f -> tc_newcon ty mb_f
RecCon fields -> tc_rec_con fields
where
tc_datacon btys
@@ -179,11 +179,17 @@ tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details
mapTc tcHsTopType tys `thenTc` \ arg_tys ->
mk_data_con arg_stricts arg_tys []
- tc_newcon ty
+ tc_newcon ty mb_f
= tcHsTopBoxedType ty `thenTc` \ arg_ty ->
-- can't allow an unboxed type here, because we're effectively
-- going to remove the constructor while coercing it to a boxed type.
- mk_data_con [NotMarkedStrict] [arg_ty] []
+ let
+ field_label =
+ case mb_f of
+ Nothing -> []
+ Just f -> [mkFieldLabel (getName f) arg_ty (head allFieldLabelTags)]
+ in
+ mk_data_con [NotMarkedStrict] [arg_ty] field_label
tc_rec_con fields
= checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
@@ -254,8 +260,7 @@ mkDataBinds (tycon : tycons)
returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
mkDataBinds_one tycon
- = ASSERT( isAlgTyCon tycon )
- mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
+ = mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
let
data_ids = map dataConId data_cons ++ sel_ids
@@ -303,7 +308,9 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
field_ty
selector_id :: Id
- selector_id = mkRecordSelId first_field_label selector_ty
+ selector_id
+ | isNewTyCon tycon = mkNewTySelId first_field_label selector_ty
+ | otherwise = mkRecordSelId first_field_label selector_ty
\end{code}
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 038789bac742e5e180ebbff829a537cc851a3493..7d3a79de2836a671b5539531e01c056ee8b7a18d 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -333,7 +333,7 @@ zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty
zonk_unbound_tyvar tv
= zonkTcKindToKind (tyVarKind tv) `thenNF_Tc` \ kind ->
if kind == boxedTypeKind then
- tcPutTyVar tv voidTy -- Just to creating a new tycon in
+ tcPutTyVar tv voidTy -- Just to avoid creating a new tycon in
-- this vastly common case
else
tcPutTyVar tv (TyConApp (mk_void_tycon tv) [])
diff --git a/ghc/compiler/types/TyCon.hi-boot b/ghc/compiler/types/TyCon.hi-boot
index 27f630b49768245fb4332fc254c9a3ed14ac8aa0..930f95809a8a352d36c72774afa7ec12017162b1 100644
--- a/ghc/compiler/types/TyCon.hi-boot
+++ b/ghc/compiler/types/TyCon.hi-boot
@@ -6,3 +6,4 @@ _declarations_
1 isTupleTyCon _:_ TyCon -> PrelBase.Bool ;;
1 isUnboxedTupleTyCon _:_ TyCon -> PrelBase.Bool ;;
1 isFunTyCon _:_ TyCon -> PrelBase.Bool ;;
+
diff --git a/ghc/compiler/types/Type.hi-boot b/ghc/compiler/types/Type.hi-boot
index e9911f653ca2fdf6f100a5b4c0ef7aca307e78a9..cc55830626a776ab1a4f0f321be3446d4ae2a3ed 100644
--- a/ghc/compiler/types/Type.hi-boot
+++ b/ghc/compiler/types/Type.hi-boot
@@ -6,3 +6,4 @@ _declarations_
1 type Kind = Type ;
1 type SuperKind = Type ;
+