From 3160f854580e6d8df412c8cd34d93bae27175d67 Mon Sep 17 00:00:00 2001 From: sof Date: Thu, 14 Jan 1999 17:59:25 +0000 Subject: [PATCH] [project @ 1999-01-14 17:58:41 by sof] Assorted minor Haskell 98 changes: * Maximal munch rule for "--" comments * _ as lower-case letter, "_" is a reserved id. Prefixing unused variable names in patterns with '_' causes the renamer not to report such names as being unused. * allow empty decls * comprehensions are now list comprehensions, not monadic. * use Monad.fail to signal pattern matching errors within do expressions. * remove record punning. * empty contexts are now legal (go wild!) * allow records with no fields * allow newtypes with a labelled field * default default is now (Integer, Double) * turn off defaulting mechanism for args & res to a _ccall_. * allow LHSs of the form (a -.- b) x = ... * Main.main can now have type (IO a) * nuked Void (and its use in the compiler sources.) * deriving machinery for Enum now also generate 'succ' and 'pred' method bindings. --- ghc/compiler/basicTypes/MkId.lhs | 35 +++++++++++++ ghc/compiler/basicTypes/Name.hi-boot | 1 + ghc/compiler/basicTypes/OccName.lhs | 7 ++- ghc/compiler/basicTypes/Unique.lhs | 80 ++++++++++++++---------------- ghc/compiler/codeGen/CgExpr.lhs | 37 +++++++++----- ghc/compiler/deSugar/DsExpr.hi-boot | 1 + ghc/compiler/deSugar/DsExpr.lhs | 32 +++++++----- ghc/compiler/hsSyn/HsDecls.lhs | 10 +++- ghc/compiler/hsSyn/HsExpr.hi-boot | 1 + ghc/compiler/parser/constr.ugn | 1 + ghc/compiler/parser/hslexer.flex | 66 ++++++++++++++++++++----- ghc/compiler/parser/hsparser.y | 82 ++++++++++++++----------------- ghc/compiler/parser/id.c | 2 +- ghc/compiler/parser/syntax.c | 1 - ghc/compiler/parser/type2context.c | 12 ++++- ghc/compiler/prelude/PrelInfo.lhs | 37 ++++++++------ ghc/compiler/prelude/PrimOp.lhs | 73 ++++++++++++++++----------- ghc/compiler/prelude/TysWiredIn.lhs | 27 ++++------ ghc/compiler/reader/Lex.lhs | 16 +++++- ghc/compiler/reader/ReadPrefix.lhs | 35 ++++++------- ghc/compiler/rename/ParseIface.y | 4 +- ghc/compiler/rename/Rename.lhs | 5 +- ghc/compiler/rename/RnBinds.lhs | 22 ++++++--- ghc/compiler/rename/RnEnv.lhs | 35 ++++++++----- ghc/compiler/rename/RnExpr.lhs | 4 +- ghc/compiler/rename/RnIfaces.lhs | 17 +++++-- ghc/compiler/rename/RnSource.lhs | 12 +++-- ghc/compiler/specialise/SpecEnv.hi-boot | 1 + ghc/compiler/typecheck/TcDefaults.lhs | 4 +- ghc/compiler/typecheck/TcExpr.hi-boot | 1 + ghc/compiler/typecheck/TcExpr.lhs | 38 ++++++++------ ghc/compiler/typecheck/TcForeign.lhs | 2 +- ghc/compiler/typecheck/TcGRHSs.hi-boot | 11 +++++ ghc/compiler/typecheck/TcGenDeriv.lhs | 64 +++++++++++++++++++++++- ghc/compiler/typecheck/TcInstDcls.lhs | 2 +- ghc/compiler/typecheck/TcModule.lhs | 13 +++-- ghc/compiler/typecheck/TcSimplify.lhs | 38 +++++++++++++- ghc/compiler/typecheck/TcTyClsDecls.lhs | 2 +- ghc/compiler/typecheck/TcTyDecls.lhs | 25 ++++++---- ghc/compiler/typecheck/TcType.lhs | 2 +- ghc/compiler/types/TyCon.hi-boot | 1 + ghc/compiler/types/Type.hi-boot | 1 + 42 files changed, 583 insertions(+), 277 deletions(-) create mode 100644 ghc/compiler/typecheck/TcGRHSs.hi-boot diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index cd0ec9b..669be86 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -20,6 +20,7 @@ module MkId ( mkDataConId, mkRecordSelId, + mkNewTySelId, mkPrimitiveId ) where @@ -242,6 +243,40 @@ mkRecordSelId field_label selector_ty %************************************************************************ %* * +\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 24b358b..8c578f3 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 f17156c..4ecd069 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 d91bf45..f518899 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 3cc58a6..ddf179d 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 55e849c..2a163fa 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 6d49981..afdf166 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 2e10554..2811ee6 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 64b4a2f..dd00309 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 7894455..5d678c8 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 eea945c..02bc1ef 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] */ %} -"--"[^\n\r]*{NL}?{WS}* | {WS}+ { noGap = FALSE; } %{ @@ -430,7 +431,6 @@ NL [\n\r] "," { RETURN(COMMA); } ";" { RETURN(SEMI); } "`" { RETURN(BQUOTE); } -"_" { RETURN(WILDCARD); } "." { RETURN(DOT); } ".." { RETURN(DOTDOT); } @@ -536,8 +536,16 @@ NL [\n\r] RETURN(isconstr(yytext) ? CONID : VARID); } {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); + } } {Mod}"."{Id}"#" { BOOLEAN is_constr; @@ -737,6 +745,19 @@ NL [\n\r] \\ { addchar(*yytext); POP_STATE; } \\ { 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. +*/ +%} +"--"[^\n\r]*{NL}?{WS}* { noGap=FALSE; } + ["'] { addchar(*yytext); POP_STATE; } NUL { addchar('\000'); POP_STATE; } SOH { addchar('\001'); POP_STATE; } @@ -837,6 +858,7 @@ NL [\n\r] "-}" { if (--nested_comments == 0) POP_STATE; } (.|\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 topdecl topdecls letdecls +%type 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 polytype conargatype conapptype @@ -286,7 +286,7 @@ BOOLEAN pat_check=TRUE; atype polyatype simple_con_app simple_con_app1 inst_type -%type constr constr_after_context field +%type constr constr_after_context field constr1 %type 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 053dc44..0ee41f8 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 989ce0c..244e694 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 468df29..fd142cd 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 eca0bd8..6c4049e 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 3b35044..4a6e215 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 3d23433..3a2a16f 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 116f6bd..4699de9 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 df4e61f..d789197 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 007b339..30c1478 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 cea1ee7..91a7b84 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 07e4fa1..31e376b 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 30f5f19..066c991 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 6eaa5ea..6a050db 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 20f8817..543866a 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 b6c6c62..34966a7 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 077a6ef..5f16e24 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 7335631..758258b 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 08fe08e..c0df697 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 466a699..aae7a24 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 253c7bc..cf850f1 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 0000000..a88316f --- /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 2c32c8c..cc3e205 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 2b7b4ad..aa21d98 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 517e8b2..10a07f3 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 fef10a9..ad166c1 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 4f1fa0c..2a27a16 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 181f830..5d54943 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 038789b..7d3a79d 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 27f630b..930f958 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 e9911f6..cc55830 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 ; + -- 1.7.10.4