mkDataConId,
mkRecordSelId,
+ mkNewTySelId,
mkPrimitiveId
) where
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
Name Name;
_declarations_
1 data Name;
+
mkClassTyConOcc, mkClassDataConOcc,
isTvOcc, isTCOcc, isVarOcc, isConSymOcc, isConOcc, isSymOcc,
+ isWildCardOcc, isAnonOcc,
pprOccName, occNameString, occNameFlavour,
-- The basic form of names
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
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}
arrayPrimTyConKey,
assertIdKey,
augmentIdKey,
+ bindIOIdKey,
boolTyConKey,
boundedClassKey,
boxedConKey,
buildIdKey,
byteArrayPrimTyConKey,
+ byteArrayTyConKey,
cCallableClassKey,
cReturnableClassKey,
charDataConKey,
charTyConKey,
concatIdKey,
consDataConKey,
+ deRefStablePtrIdKey,
doubleDataConKey,
doublePrimTyConKey,
doubleTyConKey,
eqClassOpKey,
errorIdKey,
falseDataConKey,
+ failMClassOpKey,
filterIdKey,
floatDataConKey,
floatPrimTyConKey,
foreignObjDataConKey,
foreignObjPrimTyConKey,
foreignObjTyConKey,
- weakPrimTyConKey,
fractionalClassKey,
fromEnumClassOpKey,
fromIntClassOpKey,
ixClassKey,
listTyConKey,
mainKey,
+ makeStablePtrIdKey,
mapIdKey,
minusClassOpKey,
monadClassKey,
monadPlusClassKey,
- monadZeroClassKey,
mutableArrayPrimTyConKey,
mutableByteArrayPrimTyConKey,
+ mutableByteArrayTyConKey,
mutVarPrimTyConKey,
nilDataConKey,
noMethodBindingErrorIdKey,
toEnumClassOpKey,
traceIdKey,
trueDataConKey,
+ unboundKey,
unboxedConKey,
unpackCString2IdKey,
unpackCStringAppendIdKey,
unpackCStringIdKey,
unsafeCoerceIdKey,
ushowListIdKey,
- voidIdKey,
- voidTyConKey,
+ weakPrimTyConKey,
wordDataConKey,
wordPrimTyConKey,
wordTyConKey,
word64DataConKey,
word64PrimTyConKey,
word64TyConKey,
- zeroClassOpKey,
- zipIdKey,
- bindIOIdKey,
- deRefStablePtrIdKey,
- makeStablePtrIdKey,
- unboundKey,
- byteArrayTyConKey,
- mutableByteArrayTyConKey
+ zipIdKey
) where
#include "HsVersions.h"
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}
%************************************************************************
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}
%************************************************************************
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
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
%
% (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 $
%
%********************************************************
%* *
import StgSyn
import CgMonad
import AbsCSyn
+import AbsCUtils ( mkAbstractCs )
import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
\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}
_declarations_
1 dsExpr _:_ TcHsSyn.TypecheckedHsExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
1 dsLet _:_ TcHsSyn.TypecheckedHsBinds -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
+
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 )
= 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 $
| 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
\begin{code}
-
#ifdef DEBUG
-- HsSyn constructs that just shouldn't be here:
dsExpr (HsDo _ _ _) = panic "dsExpr:HsDo"
-> [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)
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 ->
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) ->
| 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
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
_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 ;;
+
/* constr in simple "newtype" form: */
constrnew : < gconnid : qid;
gconnty : ttype;
+ gconnla : maybe; /* Maybe qvar */
gconnline : long; >;
/* constr with a existential prefixed context C => ... */
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 */
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}*
*/
%}
-<Code,GlaExt,StringEsc>"--"[^\n\r]*{NL}?{WS}* |
<Code,GlaExt,UserPragma,StringEsc>{WS}+ { noGap = FALSE; }
%{
<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); }
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;
<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; }
<Comment>"-}" { if (--nested_comments == 0) POP_STATE; }
<Comment>(.|\n) ;
+
%{
/*
* Illegal characters. This used to be a single rule, but we might as well
forcing insertion of ; or } as appropriate
*/
+#ifdef HSP_DEBUG
+#define LAYOUT_DEBUG
+#endif
+
+
static BOOLEAN
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
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);
}
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
}
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
}
/*
* 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
return (SEMI);
}
}
+
hssttok = -1;
#ifdef HSP_DEBUG
fprintf(stderr, "returning %d (%d:%d)\n", tok, hspcolno, INDENTPT);
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;
+}
+
%token OCURLY CCURLY VCCURLY
%token COMMA SEMI OBRACK CBRACK
-%token WILDCARD BQUOTE OPAREN CPAREN
+%token BQUOTE OPAREN CPAREN
%token OUNBOXPAREN CUNBOXPAREN
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
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
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
| enames COMMA ename { $$ = lapp($1,$3); }
;
ename : qvar
- | qcon
+ | gcon
;
;
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:
* *
**********************************************************************/
-topdecls: topdecl
- | topdecls SEMI topdecl
+topdecls: topdecls1 opt_semi { $$ = $1; }
+
+topdecls1: topdecl
+ | topdecls1 SEMI topdecl
{
if($1 != NULL)
if($3 != NULL)
;
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 */
;
-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); }
;
| /*empty*/ { $$ = 0; }
;
+decls : decls1 opt_semi { $$ = $1; }
-
-decls : decl
- | decls SEMI decl
+decls1 : decl
+ | decls1 SEMI decl
{
if(SAMEFN)
{
}
;
+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
/* end of user-specified pragmas */
| valdef
- | /* empty */ { $$ = mknullbind(); FN = NULL; SAMEFN = 0; }
;
fixdecl : INFIXL INTEGER { Precedence = checkfixity($2); Fixity = INFIXL; }
;
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); }
;
| 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); }
;
| 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); }
;
WHERE ocurly decls ccurly { $$ = $3; }
| WHERE vocurly decls vccurly { $$ = $3; }
/* A where containing no decls is OK */
- | WHERE SEMI { $$ = mknullbind(); }
+ | WHERE { $$ = mknullbind(); }
| /* empty */ { $$ = mknullbind(); }
;
/* 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 */
| 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); }
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)); }
| 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)); }
;
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
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 (,,,)
*/
}
}
-
/* Check that a type is of the form
C a1 a2 .. an
where n>=1, and the ai are all type variables
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:
-- 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,
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
, int64TyCon
, integerTyCon
, listTyCon
- , voidTyCon
, wordTyCon
, word8TyCon
, word16TyCon
\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
, (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
, (eq_RDR, eqClassOpKey)
, (thenM_RDR, thenMClassOpKey)
, (returnM_RDR, returnMClassOpKey)
- , (zeroM_RDR, zeroClassOpKey)
+ , (failM_RDR, failMClassOpKey)
, (fromRational_RDR, fromRationalClassOpKey)
, (deRefStablePtr_RDR, deRefStablePtrIdKey)
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"))
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"))
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"))
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__"))
, (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
| TakeMVarOp
| PutMVarOp
| SameMVarOp
+ | IsEmptyMVarOp
-- exceptions
| CatchOp
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"
TakeMVarOp,
PutMVarOp,
SameMVarOp,
+ IsEmptyMVarOp,
MakeForeignObjOp,
WriteForeignObjOp,
MkWeakOp,
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}
%************************************************************************
isFloatTy,
floatTyCon,
- voidTyCon, voidTy,
-
intDataCon,
intTy,
intTyCon,
int32TyCon,
int64TyCon,
- int64DataCon,
--- int64Ty,
integerTy,
integerTyCon,
stringTy,
trueDataCon,
unitTy,
+ voidTy,
wordDataCon,
wordTy,
wordTyCon,
word8TyCon,
word16TyCon,
word32TyCon,
-
- word64DataCon,
--- word64Ty,
word64TyCon,
isFFIArgumentTy, -- :: Type -> Bool
--
-- ) 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
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}
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}
-- 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))
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) $
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' ->
import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts )
import Name ( OccName, srcTvOcc, srcVarOcc, srcTCOcc,
Module, mkModuleFS,
- isConOcc, isLexConId
+ isConOcc, isLexConId, isWildCardOcc
)
import Outputable
import SrcLoc ( SrcLoc )
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"
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!
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)
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
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 : { ([],[]) }
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
(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 = []
(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_`
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}
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)]
ImportReason(..), getSrcLoc,
mkLocalName, mkGlobalName,
nameOccName,
- pprOccName, isLocalName, isLocallyDefined,
+ pprOccName, isLocalName, isLocallyDefined, isAnonOcc,
setNameProvenance, getNameProvenance, pprNameProvenance
)
import NameSet
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
]
= 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
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
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
)
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)
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,
= 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))
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 []
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_`
SpecEnv SpecEnv ;
_declarations_
1 data SpecEnv a ;
+
import TcMonoType ( tcHsType )
import TcSimplify ( tcSimplifyCheckThetas )
-import TysWiredIn ( intTy, doubleTy )
+import TysWiredIn ( integerTy, doubleTy )
import Type ( Type )
import Unique ( numClassKey )
import ErrUtils ( addShortErrLocLine )
\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
-> TcMonad.TcType
-> TcMonad.TcM s (TcHsSyn.TcExpr, Inst.LIE) ;;
+
#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
import Unique ( cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
- thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
+ thenMClassOpKey, failMClassOpKey, returnMClassOpKey
)
import Outputable
import Maybes ( maybeToBool )
-- 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
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) ->
--
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}
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}
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 )
--- /dev/null
+_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) ;;
+
+
\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]
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] [] $
-- 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
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
import TcTyClsDecls ( tcTyAndClassDecls )
import TcTyDecls ( mkDataBinds )
import TcType ( TcType, typeToTcType,
- TcKind, kindToTcKind
+ TcKind, kindToTcKind,
+ newTyVarTy
)
import RnMonad ( RnNameSupply )
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,
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 $
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
-> 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
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
~~~~~~~~~~~~~~~~~~~
----------------------------------------------------
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)
----------------------------------------------------
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
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,
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
= 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
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_`
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
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}
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) [])
1 isTupleTyCon _:_ TyCon -> PrelBase.Bool ;;
1 isUnboxedTupleTyCon _:_ TyCon -> PrelBase.Bool ;;
1 isFunTyCon _:_ TyCon -> PrelBase.Bool ;;
+
1 type Kind = Type ;
1 type SuperKind = Type ;
+
projects / ghc-hetmet.git / commitdiff