From b4255f2c320f852d7dfb0afc0bc9f64765aece0c Mon Sep 17 00:00:00 2001 From: partain Date: Tue, 9 Apr 1996 10:28:48 +0000 Subject: [PATCH] [project @ 1996-04-09 10:27:46 by partain] Sansom 1.3 changes through 960408 --- ghc/compiler/basicTypes/Id.lhs | 8 +- ghc/compiler/basicTypes/Name.lhs | 25 ++++- ghc/compiler/codeGen/CodeGen.lhs | 4 +- ghc/compiler/coreSyn/CoreLint.lhs | 7 +- ghc/compiler/coreSyn/CoreSyn.lhs | 11 ++- ghc/compiler/coreSyn/CoreUtils.lhs | 20 ++-- ghc/compiler/deSugar/DsBinds.lhs | 2 +- ghc/compiler/deSugar/DsHsSyn.lhs | 2 +- ghc/compiler/hsSyn/HsBinds.lhs | 8 +- ghc/compiler/hsSyn/HsExpr.lhs | 2 +- ghc/compiler/hsSyn/HsPat.lhs | 12 ++- ghc/compiler/main/Main.lhs | 19 ++-- ghc/compiler/parser/hsparser.y | 162 ++++++++++++++------------------- ghc/compiler/prelude/PrelInfo.lhs | 2 +- ghc/compiler/reader/PrefixToHs.lhs | 40 ++++---- ghc/compiler/rename/RnBinds.lhs | 26 +++--- ghc/compiler/rename/RnExpr.lhs | 50 ++++++++-- ghc/compiler/rename/RnHsSyn.lhs | 13 ++- ghc/compiler/rename/RnNames.lhs | 5 +- ghc/compiler/rename/RnSource.lhs | 15 ++- ghc/compiler/typecheck/GenSpecEtc.lhs | 2 +- ghc/compiler/typecheck/TcBinds.lhs | 4 +- ghc/compiler/typecheck/TcDeriv.lhs | 6 +- ghc/compiler/typecheck/TcExpr.lhs | 4 + ghc/compiler/typecheck/TcGenDeriv.lhs | 6 +- ghc/compiler/typecheck/TcHsSyn.lhs | 4 +- ghc/compiler/typecheck/TcInstDcls.lhs | 6 +- ghc/compiler/typecheck/TcPat.lhs | 5 +- ghc/compiler/types/PprType.lhs | 11 ++- ghc/compiler/types/TyCon.lhs | 43 +++++---- ghc/compiler/types/Type.lhs | 7 +- ghc/compiler/utils/Outputable.lhs | 2 +- 32 files changed, 306 insertions(+), 227 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index adbd61f..8018ad2 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -103,7 +103,7 @@ import IdInfo import Maybes ( maybeToBool ) import Name ( appendRdr, nameUnique, mkLocalName, isLocalName, isLocallyDefinedName, isPreludeDefinedName, - nameOrigName, + nameOrigName, mkTupleDataConName, isAvarop, isAconop, getLocalName, isLocallyDefined, isPreludeDefined, getOrigName, getOccName, @@ -129,7 +129,7 @@ import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) ) import UniqFM import UniqSet -- practically all of it import UniqSupply ( getBuiltinUniques ) -import Unique ( mkTupleDataConUnique, pprUnique, showUnique, +import Unique ( pprUnique, showUnique, Unique{-instance Ord3-} ) import Util ( mapAccumL, nOfThem, zipEqual, @@ -1409,8 +1409,8 @@ mkTupleCon :: Arity -> Id mkTupleCon arity = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info where - n = panic "mkTupleCon: its Name (Id)" - unique = mkTupleDataConUnique arity + n = mkTupleDataConName arity + unique = uniqueOf n ty = mkSigmaTy tyvars [] (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys)) tycon = mkTupleTyCon arity diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 14691d6..2c176ec 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -25,6 +25,8 @@ module Name ( mkImplicitName, isImplicitName, mkBuiltinName, + mkFunTyConName, mkTupleDataConName, mkTupleTyConName, + NamedThing(..), -- class ExportFlag(..), isExported, @@ -49,11 +51,13 @@ import Ubiq import CStrings ( identToC, cSEP ) import Outputable ( Outputable(..) ) import PprStyle ( PprStyle(..), codeStyle ) +import PrelMods ( pRELUDE, pRELUDE_BUILTIN ) import Pretty -import PrelMods ( pRELUDE ) import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc ) -import Unique ( pprUnique, Unique ) -import Util ( thenCmp, _CMP_STRING_, panic ) +import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique, + pprUnique, Unique + ) +import Util ( thenCmp, _CMP_STRING_, nOfThem, panic ) \end{code} %************************************************************************ @@ -167,6 +171,21 @@ mkImplicitName u o = Global u o Implicit NotExported [] mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported [] +mkFunTyConName + = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->") +mkTupleDataConName arity + = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mk_tup_name arity) +mkTupleTyConName arity + = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mk_tup_name arity) + +mk_tup_name 0 = SLIT("()") +mk_tup_name 1 = panic "Name.mk_tup_name: 1 ???" +mk_tup_name 2 = SLIT("(,)") -- not strictly necessary +mk_tup_name 3 = SLIT("(,,)") -- ditto +mk_tup_name 4 = SLIT("(,,,)") -- ditto +mk_tup_name n + = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")") + -- ToDo: what about module ??? -- ToDo: exported when compiling builtin ??? diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 2b193da..f1a0d30 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -44,7 +44,7 @@ import Util ( panic, assertPanic ) codeGen :: FAST_STRING -- module name -> ([CostCentre], -- local cost-centres needing declaring/registering [CostCentre]) -- "extern" cost-centres needing declaring - -> Bag FAST_STRING -- import names + -> [Module] -- import names -> [TyCon] -- tycons with data constructors to convert -> FiniteMap TyCon [(Bool, [Maybe Type])] -- tycon specialisation info @@ -98,7 +98,7 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg = let register_ccs = mkAbstractCs (map mk_register ccs) register_imports - = foldBag mkAbsCStmts mk_import_register AbsCNop import_names + = foldr (mkAbsCStmts . mk_import_register) AbsCNop import_names in mkAbstractCs [ CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrRep], diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 3aa5c62..dc2b61a 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -570,13 +570,10 @@ mkAppMsg fun arg expr sty mkTyAppMsg :: Type -> Type -> CoreExpr -> ErrMsg mkTyAppMsg ty arg expr sty - = panic "mkTyAppMsg" -{- = ppAboves [ppStr "Illegal type application:", - ppHang (ppStr "Exp type:") 4 (ppr sty exp), - ppHang (ppStr "Arg type:") 4 (ppr sty arg), + ppHang (ppStr "Exp type:") 4 (ppr sty ty), + ppHang (ppStr "Arg type:") 4 (ppr sty arg), ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] --} mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg mkUsageAppMsg ty u expr sty diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 2e017b8..4d8284d 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -56,11 +56,15 @@ module CoreSyn ( import Ubiq{-uitous-} +-- ToDo:rm: +--import PprCore ( GenCoreExpr{-instance-} ) +--import PprStyle ( PprStyle(..) ) + import CostCentre ( showCostCentre, CostCentre ) import Id ( idType, GenId{-instance Eq-} ) import Type ( isUnboxedType ) import Usage ( UVar(..) ) -import Util ( panic, assertPanic ) +import Util ( panic, assertPanic {-pprTrace:ToDo:rm-} ) \end{code} %************************************************************************ @@ -495,8 +499,9 @@ collectArgs expr valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc) valvars fun vacc - = ASSERT(not (usage_app fun)) - ASSERT(not (ty_app fun)) + = --ASSERT(not (usage_app fun)) + --ASSERT(not (ty_app fun)) + (if (usage_app fun || ty_app fun) then trace "CoreSyn:valvars" {-(ppr PprDebug fun)-} else id) $ (fun, vacc) --------------------------------------- diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 2fc8a3b..e737450 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -170,9 +170,7 @@ escErrorMsg (x:xs) = x : escErrorMsg xs For making @Apps@ and @Lets@, we must take appropriate evasive action if the thing being bound has unboxed type. @mkCoApp@ requires -a name supply to do its work. Other-monad code will call @mkCoApp@ -through its own interface function (e.g., the desugarer uses -@mkCoAppDs@). +a name supply to do its work. @mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the arguments-must-be-atoms constraint. @@ -199,12 +197,18 @@ mkCoApp e1 e2 \end{code} \begin{code} -{-LATER -mkCoCon :: Id -> [CoreExpr] -> UniqSM CoreExpr -mkCoPrim :: PrimOp -> [CoreExpr] -> UniqSM CoreExpr +{- +data CoreArgOrExpr + = AnArg CoreArg + | AnExpr CoreExpr + +mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr +mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr +mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr -mkCoCon con args = mkCoThing (Con con) args -mkCoPrim op args = mkCoThing (Prim op) args +mkCoApps fun args = mkCoThing (Con con) args +mkCoCon con args = mkCoThing (Con con) args +mkCoPrim op args = mkCoThing (Prim op) args mkCoThing thing arg_exprs = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) -> diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index c2c23ae..e45e7bc 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -470,7 +470,7 @@ dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr) \end{code} \begin{code} -dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn) +dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn) = putSrcLocDs locn $ let new_fun = binder_subst fun diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index 91601a1..3adfab1 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -57,7 +57,7 @@ collectTypedBinders (RecBind bs) = collectTypedMonoBinders bs collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id] collectTypedMonoBinders EmptyMonoBinds = [] collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat -collectTypedMonoBinders (FunMonoBind f _ _) = [f] +collectTypedMonoBinders (FunMonoBind f _ _ _) = [f] collectTypedMonoBinders (VarMonoBind v _) = [v] collectTypedMonoBinders (AndMonoBinds bs1 bs2) = collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2 diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 15dafc9..d8908f1 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -237,6 +237,7 @@ data MonoBinds tyvar uvar id pat (GRHSsAndBinds tyvar uvar id pat) SrcLoc | FunMonoBind id + Bool -- True => infix declaration [Match tyvar uvar id pat] -- must have at least one Match SrcLoc | VarMonoBind id -- TRANSLATION @@ -262,8 +263,9 @@ instance (NamedThing id, Outputable id, Outputable pat, ppr sty (PatMonoBind pat grhss_n_binds locn) = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds) - ppr sty (FunMonoBind fun matches locn) + ppr sty (FunMonoBind fun inf matches locn) = pprMatches sty (False, pprNonOp sty fun) matches + -- ToDo: print infix if appropriate ppr sty (VarMonoBind name expr) = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr) @@ -302,7 +304,7 @@ collectBinders (RecBind monobinds) = collectMonoBinders monobinds collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name] collectMonoBinders EmptyMonoBinds = [] collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat -collectMonoBinders (FunMonoBind f matches _) = [f] +collectMonoBinders (FunMonoBind f _ matches _) = [f] collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders" collectMonoBinders (AndMonoBinds bs1 bs2) = collectMonoBinders bs1 ++ collectMonoBinders bs2 @@ -321,7 +323,7 @@ collectMonoBindersAndLocs (AndMonoBinds bs1 bs2) collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn) = collectPatBinders pat `zip` repeat locn -collectMonoBindersAndLocs (FunMonoBind f matches locn) = [(f, locn)] +collectMonoBindersAndLocs (FunMonoBind f _ matches locn) = [(f, locn)] #ifdef DEBUG collectMonoBindersAndLocs (VarMonoBind v expr) diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 0a0397e..5b74a4d 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -227,7 +227,7 @@ pprExpr sty (OpApp e1 op e2) = ppSep [pp_e1, ppCat [pprOp sty v, pp_e2]] pprExpr sty (NegApp e) - = ppBeside (ppChar '-') (ppParens (pprExpr sty e)) + = ppBeside (ppChar '-') (pprParendExpr sty e) pprExpr sty (HsPar e) = ppParens (pprExpr sty e) diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index d96e8ec..99fda06 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -135,12 +135,18 @@ pprInPat sty (ConOpPatIn pat1 op pat2) -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) pprInPat sty (NegPatIn pat) - = ppBeside (ppChar '-') (ppParens (pprInPat sty pat)) + = let + pp_pat = pprInPat sty pat + in + ppBeside (ppChar '-') ( + case pat of + LitPatIn _ -> pp_pat + _ -> ppParens pp_pat + ) pprInPat sty (ParPatIn pat) = ppParens (pprInPat sty pat) - pprInPat sty (ListPatIn pats) = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] pprInPat sty (TuplePatIn pats) @@ -292,6 +298,8 @@ collectPatBinders (LazyPatIn pat) = collectPatBinders pat collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats) collectPatBinders (ConOpPatIn p1 c p2)= collectPatBinders p1 ++ collectPatBinders p2 +collectPatBinders (NegPatIn pat) = collectPatBinders pat +collectPatBinders (ParPatIn pat) = collectPatBinders pat collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats) collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats) collectPatBinders any_other_pat = [ {-no binders-} ] diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 9d20713..3507b79 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -132,12 +132,15 @@ doIt (core_cmds, stg_cmds) input_pgm doDump opt_D_dump_rn "Renamer:" (pp_show (ppr pprStyle rn_mod)) `thenMn_` - exitMn 0 -{- LATER ... +-- exitMn 0 +{- LATER ... -} -- ******* TYPECHECKER show_pass "TypeCheck" `thenMn_` - case (case (typecheckModule tc_uniqs idinfo_fm rn_info rn_mod) of + let + rn_info = trace "Main.rn_info" (\ x -> Nothing, \ x -> Nothing) + in + case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_info rn_mod) of Succeeded (stuff, warns) -> (emptyBag, warns, stuff) Failed (errs, warns) @@ -300,7 +303,7 @@ doIt (core_cmds, stg_cmds) input_pgm exitMn 0 } ) } -LATER -} +{- LATER -} } where @@ -433,11 +436,11 @@ ppSourceStats (HsModule name version exports imports fixities typedecls typesigs count_bind (NonRecBind b) = count_monobinds b count_bind (RecBind b) = count_monobinds b - count_monobinds EmptyMonoBinds = (0,0) - count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2 + count_monobinds EmptyMonoBinds = (0,0) + count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2 count_monobinds (PatMonoBind (VarPatIn n) r _) = (1,0) - count_monobinds (PatMonoBind p r _) = (0,1) - count_monobinds (FunMonoBind f m _) = (0,1) + count_monobinds (PatMonoBind p r _) = (0,1) + count_monobinds (FunMonoBind f _ m _) = (0,1) count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 907e08a..5e9018b 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -245,9 +245,9 @@ BOOLEAN inpat; %type exp oexp dexp kexp fexp aexp rbind texps expL oexpL kexpL expLno oexpLno dexpLno kexpLno - qual gd leftexp - apat bpat pat apatc conpat dpat fpat opat aapat - dpatk fpatk opatk aapatk rpat + vallhs funlhs qual gd leftexp + pat bpat apat apatc conpat rpat + patk bpatk apatck conpatk %type MINUS DARROW AS LAZY @@ -835,7 +835,7 @@ instdef : ; -valdef : opatk +valdef : vallhs { tree fn = function($1); PREVPATT = $1; @@ -869,13 +869,23 @@ valdef : opatk FN = NULL; SAMEFN = 0; } - else /* lhs is function */ + else $$ = mkfbind($3,startlineno); PREVPATT = NULL; } ; +vallhs : patk { $$ = $1; } + | patk qvarop pat { $$ = mkinfixap($2,$1,$3); } + | funlhs { $$ = $1; } + ; + +funlhs : qvark apat { $$ = mkap(mkident($1),$2); } + | funlhs apat { $$ = mkap($1,$2); } + ; + + valrhs : valrhs1 maybe_where { $$ = lsing(createpat($1, $2)); } ; @@ -1154,90 +1164,6 @@ leftexp : LARROW exp { $$ = $2; } * * **********************************************************************/ -/* - The xpatk business is to do with accurately recording - the starting line for definitions. -*/ - -opatk : dpatk - | opatk qop opat %prec MINUS { $$ = mkinfixap($2,$1,$3); } - ; - -opat : dpat - | opat qop opat %prec MINUS { $$ = mkinfixap($2,$1,$3); } - ; - -/* - This comes here because of the funny precedence rules concerning - prefix minus. -*/ - - -dpat : MINUS fpat { $$ = mknegate($2); } - | fpat - ; - - /* Function application */ -fpat : fpat aapat { $$ = mkap($1,$2); } - | aapat - ; - -dpatk : minuskey fpat { $$ = mknegate($2); } - | fpatk - ; - - /* Function application */ -fpatk : fpatk aapat { $$ = mkap($1,$2); } - | aapatk - ; - -aapat : qvar { $$ = mkident($1); } - | qvar AT apat { $$ = mkas($1,$3); } - | gcon { $$ = mkident($1); } - | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); } - | lit_constant { $$ = mklit($1); } - | WILDCARD { $$ = mkwildp(); } - | OPAREN opat CPAREN { $$ = mkpar($2); } - | OPAREN opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); } - | OBRACK pats CBRACK { $$ = mkllist($2); } - | LAZY apat { $$ = mklazyp($2); } - ; - - -aapatk : qvark { $$ = mkident($1); } - | qvark AT apat { $$ = mkas($1,$3); } - | gconk { $$ = mkident($1); } - | qconk OCURLY rpats CCURLY { $$ = mkrecord($1,$3); } - | lit_constant { $$ = mklit($1); setstartlineno(); } - | WILDCARD { $$ = mkwildp(); setstartlineno(); } - | oparenkey opat CPAREN { $$ = mkpar($2); } - | oparenkey opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); } - | obrackkey pats CBRACK { $$ = mkllist($2); } - | lazykey apat { $$ = mklazyp($2); } - ; - -gcon : qcon - | OBRACK CBRACK { $$ = creategid(-1); } - | OPAREN CPAREN { $$ = creategid(0); } - | OPAREN commas CPAREN { $$ = creategid($2); } - ; - -gconk : qconk - | obrackkey CBRACK { $$ = creategid(-1); } - | oparenkey CPAREN { $$ = creategid(0); } - | oparenkey commas CPAREN { $$ = creategid($2); } - ; - -lampats : apat lampats { $$ = mklcons($1,$2); } - | apat { $$ = lsing($1); } - /* right recursion? (WDP) */ - ; - -pats : pat COMMA pats { $$ = mklcons($1, $3); } - | pat { $$ = lsing($1); } - /* right recursion? (WDP) */ - ; - pat : pat qconop bpat { $$ = mkinfixap($2,$1,$3); } | bpat ; @@ -1245,8 +1171,8 @@ pat : pat qconop bpat { $$ = mkinfixap($2,$1,$3); } bpat : apatc | conpat | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); } - | MINUS INTEGER { $$ = mklit(mkinteger(ineg($2))); } - | MINUS FLOAT { $$ = mklit(mkfloatr(ineg($2))); } + | MINUS INTEGER { $$ = mknegate(mklit(mkinteger($2))); } + | MINUS FLOAT { $$ = mknegate(mklit(mkfloatr($2))); } ; conpat : gcon { $$ = mkident($1); } @@ -1281,6 +1207,16 @@ lit_constant: | CLITLIT /* yurble yurble */ { $$ = mkclitlit($1); } ; +lampats : apat lampats { $$ = mklcons($1,$2); } + | apat { $$ = lsing($1); } + /* right recursion? (WDP) */ + ; + +pats : pat COMMA pats { $$ = mklcons($1, $3); } + | pat { $$ = lsing($1); } + /* right recursion? (WDP) */ + ; + rpats : rpat { $$ = lsing($1); } | rpats COMMA rpat { $$ = lapp($1,$3); } ; @@ -1290,6 +1226,44 @@ rpat : qvar { $$ = mkrbind($1,mknothing()); } ; +patk : patk qconop bpat { $$ = mkinfixap($2,$1,$3); } + | bpatk + ; + +bpatk : apatck + | conpatk + | qconk OCURLY rpats CCURLY { $$ = mkrecord($1,$3); } + | minuskey INTEGER { $$ = mknegate(mklit(mkinteger($2))); } + | minuskey FLOAT { $$ = mknegate(mklit(mkfloatr($2))); } + ; + +conpatk : gconk { $$ = mkident($1); } + | conpatk apat { $$ = mkap($1,$2); } + ; + +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)); } + | obrackkey pats CBRACK { $$ = mkllist($2); } + | lazykey apat { $$ = mklazyp($2); } + ; + + +gcon : qcon + | OBRACK CBRACK { $$ = creategid(-1); } + | OPAREN CPAREN { $$ = creategid(0); } + | OPAREN commas CPAREN { $$ = creategid($2); } + ; + +gconk : qconk + | obrackkey CBRACK { $$ = creategid(-1); } + | oparenkey CPAREN { $$ = creategid(0); } + | oparenkey commas CPAREN { $$ = creategid($2); } + ; + /********************************************************************** * * * * @@ -1355,9 +1329,6 @@ classkey: CLASS { setstartlineno(); } ; -minuskey: MINUS { setstartlineno(); } - ; - modulekey: MODULE { setstartlineno(); if(etags) #if 1/*etags*/ @@ -1377,6 +1348,9 @@ obrackkey: OBRACK { setstartlineno(); } lazykey : LAZY { setstartlineno(); } ; +minuskey: MINUS { setstartlineno(); } + ; + /********************************************************************** * * diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 901af61..553da13 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -110,7 +110,7 @@ import CmdLineOpts ( opt_HideBuiltinNames, import FiniteMap ( FiniteMap, emptyFM, listToFM ) import Id ( mkTupleCon, GenId, Id(..) ) import Maybes ( catMaybes ) -import Name ( mkBuiltinName, getOrigName ) +import Name ( getOrigName ) import RnHsSyn ( RnName(..) ) import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon ) import Type diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index b24230c..033ed41 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -134,9 +134,9 @@ mkMonoBindsAndSigs sf sig_cvtr fbs mangle_bind (b_acc, s_acc) (RdrFunctionBinding srcline patbindings) -- must be a function binding... - = case (cvFunMonoBind sf patbindings) of { (var, matches) -> + = case (cvFunMonoBind sf patbindings) of { (var, inf, matches) -> (b_acc `AndMonoBinds` - FunMonoBind var matches (mkSrcLoc2 sf srcline), s_acc) + FunMonoBind var inf matches (mkSrcLoc2 sf srcline), s_acc) } \end{code} @@ -149,14 +149,21 @@ cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding) cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding) = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding) -cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, [RdrNameMatch]) +cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, Bool {-InfixDefn-}, [RdrNameMatch]) cvFunMonoBind sf matches - = (srcfun {- cheating ... -}, cvMatches sf False matches) + = (head srcfuns, head infixdefs, cvMatches sf False matches) where - srcfun = case (head matches) of - RdrMatch_NoGuard _ sfun _ _ _ -> sfun - RdrMatch_Guards _ sfun _ _ _ -> sfun + (srcfuns, infixdefs) = unzip (map get_mdef matches) + -- ToDo: Check for consistent srcfun and infixdef + + get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat + get_mdef (RdrMatch_Guards _ sfun pat _ _) = get_pdef pat + + get_pdef (ConPatIn fn _) = (fn, False) + get_pdef (ConOpPatIn _ op _) = (op, True) + get_pdef (ParPatIn pat) = get_pdef pat + cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [RdrNameMatch] cvMatch :: SrcFile -> Bool -> RdrMatch -> RdrNameMatch @@ -173,10 +180,11 @@ cvMatch sf is_case rdr_match -- we most certainly want to keep it! Hence the monkey busines... (if is_case then -- just one pattern: leave it untouched... - [pat'] - else - case pat' of - ConPatIn _ pats -> pats + [pat] + else -- function pattern; extract arg patterns... + case pat of ConPatIn fn pats -> pats + ConOpPatIn p1 op p2 -> [p1,p2] + ParPatIn pat -> panic "PrefixToHs.cvMatch:ParPatIn" ) where (pat, binding, guarded_exprs) @@ -184,17 +192,7 @@ cvMatch sf is_case rdr_match RdrMatch_NoGuard ln b c expr d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc2 sf ln)]) RdrMatch_Guards ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps) - --------------------- - pat' = doctor_pat pat - - -- a ConOpPatIn in the corner may be handled by converting it to - -- ConPatIn... - - doctor_pat (ConOpPatIn p1 op p2) = ConPatIn op [p1, p2] - doctor_pat other_pat = other_pat - cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS - cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl) \end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index d934449..cab11e5 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -27,7 +27,7 @@ import HsPragmas ( isNoGenPragmas, noGenPragmas ) import RdrHsSyn import RnHsSyn import RnMonad -import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat ) +import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecInfixBind ) import CmdLineOpts ( opt_SigsRequired ) import Digraph ( stronglyConnComp ) @@ -169,13 +169,14 @@ rnMethodBinds class_name EmptyMonoBinds = returnRn EmptyMonoBinds rnMethodBinds class_name (AndMonoBinds mb1 mb2) = andRn AndMonoBinds (rnMethodBinds class_name mb1) - (rnMethodBinds class_name mb2) + (rnMethodBinds class_name mb2) -rnMethodBinds class_name (FunMonoBind occname matches locn) - = pushSrcLocRn locn $ - lookupClassOp class_name occname `thenRn` \ op_name -> - mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) -> - returnRn (FunMonoBind op_name new_matches locn) +rnMethodBinds class_name (FunMonoBind occname inf matches locn) + = pushSrcLocRn locn $ + lookupClassOp class_name occname `thenRn` \ op_name -> + mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) -> +-- checkPrecInfixBind inf op_name new_matches `thenRn_` + returnRn (FunMonoBind op_name inf new_matches locn) rnMethodBinds class_name (PatMonoBind (VarPatIn occname) grhss_and_binds locn) = pushSrcLocRn locn $ @@ -346,10 +347,11 @@ flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn) )] ) -flattenMonoBinds uniq sigs (FunMonoBind name matches locn) - = pushSrcLocRn locn $ - lookupValue name `thenRn` \ name' -> - mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) -> +flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn) + = pushSrcLocRn locn $ + lookupValue name `thenRn` \ name' -> + mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) -> +-- checkPrecInfixBind inf name' new_matches `thenRn_` let fvs = unionManyUniqSets fv_lists @@ -362,7 +364,7 @@ flattenMonoBinds uniq sigs (FunMonoBind name matches locn) [(uniq, unitUniqSet name', fvs `unionUniqSets` sigs_fvs, - FunMonoBind name' new_matches locn, + FunMonoBind name' inf new_matches locn, sigs_for_me )] ) diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 04db620..0b024e9 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -13,7 +13,8 @@ free variables. #include "HsVersions.h" module RnExpr ( - rnMatch, rnGRHSsAndBinds, rnPat + rnMatch, rnGRHSsAndBinds, rnPat, + checkPrecInfixBind ) where import Ubiq @@ -74,13 +75,14 @@ rnPat (ConOpPatIn pat1 name pat2) rnPat neg@(NegPatIn pat) = getSrcLocRn `thenRn` \ src_loc -> - addErrIfRn (not (is_lit pat)) (negPatErr neg src_loc) + addErrIfRn (not (valid_neg_pat pat)) (negPatErr neg src_loc) `thenRn_` rnPat pat `thenRn` \ pat' -> returnRn (NegPatIn pat') where - is_lit (LitPatIn _) = True - is_lit _ = False + valid_neg_pat (LitPatIn (HsInt _)) = True + valid_neg_pat (LitPatIn (HsFrac _)) = True + valid_neg_pat _ = False rnPat (ParPatIn pat) = rnPat pat `thenRn` \ pat' -> @@ -200,7 +202,7 @@ rnExpr (HsVar v) where fv_set vname@(RnName n) | isLocallyDefinedName n = unitUniqSet vname - | otherwise = emptyUniqSet + fv_set _ = emptyUniqSet rnExpr (HsLit lit) = returnRn (HsLit lit, emptyUniqSet) @@ -483,7 +485,7 @@ precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2) precParsePat pat = returnRn pat -data INFIX = INFIXL | INFIXR | INFIXN +data INFIX = INFIXL | INFIXR | INFIXN deriving Eq lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int) lookupFixity op @@ -496,6 +498,42 @@ lookupFixity op \end{code} \begin{code} +checkPrecInfixBind :: Bool -> RnName -> [RenamedPat] -> RnM_Fixes s () + +checkPrecInfixBind False fn pats + = returnRn () +checkPrecInfixBind True op [p1,p2] + = checkPrec op p1 False `thenRn_` + checkPrec op p2 True + +checkPrec op (ConOpPatIn _ op1 _) right + = lookupFixity op `thenRn` \ (op_fix, op_prec) -> + lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) -> + getSrcLocRn `thenRn` \ src_loc -> + let + inf_ok = op1_prec > op_prec || + op1_prec == op_prec && + (op1_fix == INFIXR && op_fix == INFIXR && right || + op1_fix == INFIXL && op_fix == INFIXL && not right) + + info = (op,op_fix,op_prec) + info1 = (op1,op1_fix,op1_prec) + (infol, infor) = if right then (info, info1) else (info1, info) + + inf_err = precParseErr infol infor src_loc + in + addErrIfRn (not inf_ok) inf_err + +checkPrec op (NegPatIn _) right + = lookupFixity op `thenRn` \ (op_fix, op_prec) -> + getSrcLocRn `thenRn` \ src_loc -> + addErrIfRn (6 < op_prec) (precParseNegPatErr (op,op_fix,op_prec) src_loc) + +checkPrec op pat right + = returnRn () +\end{code} + +\begin{code} negPatErr pat src_loc = addErrLoc src_loc "prefix `-' not applied to literal in pattern" ( \sty -> ppr sty pat) diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 7f4b74b..432991c 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -13,7 +13,9 @@ import Ubiq import HsSyn import Id ( GenId, Id(..) ) -import Name ( isLocalName, nameUnique, Name, RdrName ) +import Name ( isLocalName, nameUnique, Name, RdrName(..){-ToDo: rm ..-}, + mkLocalName{-ToDo:rm-} + ) import Outputable ( Outputable(..){-instance * []-} ) import PprStyle ( PprStyle(..) ) import PprType ( GenType, GenTyVar, TyCon ) @@ -21,7 +23,7 @@ import Pretty import TyCon ( TyCon ) import TyVar ( GenTyVar ) import Unique ( Unique ) -import Util ( panic, pprPanic ) +import Util ( panic, pprPanic, pprTrace{-ToDo:rm-} ) \end{code} \begin{code} @@ -100,7 +102,12 @@ instance NamedThing RnName where getName (RnClass n _) = n getName (RnClassOp n _) = n getName (RnImplicit n) = n - getName (RnUnbound occ) = pprPanic "getRnName:RnUnbound" (ppr PprDebug occ) + getName (RnUnbound occ) = pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ) + (case occ of + Unqual n -> mkLocalName bottom n bottom2 + Qual m n -> mkLocalName bottom n bottom2) + where bottom = panic "getRnName: unique" + bottom2 = panic "getRnName: srcloc" instance Outputable RnName where #ifdef DEBUG diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index b0ec190..dcbf831 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -189,7 +189,7 @@ doBind (RecBind mbind) = doMBinds mbind doMBinds EmptyMonoBinds = returnRn emptyBag doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat -doMBinds (FunMonoBind p_name _ locn) = doName locn p_name +doMBinds (FunMonoBind p_name _ _ locn) = doName locn p_name doMBinds (AndMonoBinds mbinds1 mbinds2) = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2) @@ -214,8 +214,7 @@ doPat locn (RecPatIn name fields) = mapRn (doField locn) fields `thenRn` \ fields_s -> returnRn (unionManyBags fields_s) -doField locn (field, _, True{-pun-}) = doName locn field -doField locn (field, pat, _) = doPat locn pat +doField locn (_, pat, _) = doPat locn pat doName locn rdr = newGlobalName locn Nothing rdr `thenRn` \ name -> diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 16cd506..edcb5fe 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -66,14 +66,14 @@ rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes rnExports (mod:imp_mods) exports `thenRn` \ exported_fn -> rnFixes fixes `thenRn` \ src_fixes -> let - pair_name (InfixL n i) = (n, i) - pair_name (InfixR n i) = (n, i) - pair_name (InfixN n i) = (n, i) + pair_name inf@(InfixL n _) = (n, inf) + pair_name inf@(InfixR n _) = (n, inf) + pair_name inf@(InfixN n _) = (n, inf) imp_fixes_fm = listToUFM (map pair_name (bagToList imp_fixes)) all_fixes_fm = addListToUFM imp_fixes_fm (map pair_name src_fixes) in - setExtraRn {-all_fixes_fm-}(panic "rnSource:all_fixes_fm") $ + setExtraRn all_fixes_fm $ mapRn rnTyDecl ty_decls `thenRn` \ new_ty_decls -> mapRn rnSpecDataSig specdata_sigs `thenRn` \ new_specdata_sigs -> @@ -87,8 +87,7 @@ rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes returnRn ( HsModule mod version - trashed_exports trashed_imports - {-new_fixes-}(panic "rnSource:new_fixes (Hi, Patrick!)") + trashed_exports trashed_imports src_fixes new_ty_decls new_specdata_sigs new_class_decls new_inst_decls new_specinst_sigs new_defaults new_binds [] src_loc, @@ -96,8 +95,8 @@ rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes occ_info ) where - trashed_exports = panic "rnSource:trashed_exports" - trashed_imports = panic "rnSource:trashed_imports" + trashed_exports = trace "rnSource:trashed_exports" Nothing + trashed_imports = trace "rnSource:trashed_imports" [] \end{code} %********************************************************* diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs index 438e59a..087206a 100644 --- a/ghc/compiler/typecheck/GenSpecEtc.lhs +++ b/ghc/compiler/typecheck/GenSpecEtc.lhs @@ -312,7 +312,7 @@ is_elem v vs = isIn "isUnResMono" v vs isUnResMono sigs (PatMonoBind (VarPat (TcId v)) _ _) = v `is_elem` sigs isUnResMono sigs (PatMonoBind other _ _) = False isUnResMono sigs (VarMonoBind (TcId v) _) = v `is_elem` sigs -isUnResMono sigs (FunMonoBind _ _ _) = True +isUnResMono sigs (FunMonoBind _ _ _ _) = True isUnResMono sigs (AndMonoBinds mb1 mb2) = isUnResMono sigs mb1 && isUnResMono sigs mb2 isUnResMono sigs EmptyMonoBinds = True diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 7bd91f9..2fb8408 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -421,11 +421,11 @@ tcMonoBinds bind@(PatMonoBind pat grhss_and_binds locn) returnTc (PatMonoBind pat2 grhss_and_binds2 locn, plusLIE lie_pat lie) -tcMonoBinds (FunMonoBind name matches locn) +tcMonoBinds (FunMonoBind name inf matches locn) = tcAddSrcLoc locn $ tcLookupLocalValueOK "tcMonoBinds" name `thenNF_Tc` \ id -> tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) -> - returnTc (FunMonoBind (TcId id) matches' locn, lie) + returnTc (FunMonoBind (TcId id) inf matches' locn, lie) \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index ea4828a..b1bbb95 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -33,7 +33,7 @@ import TcSimplify ( tcSimplifyThetas ) import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) --import RnBinds4 ( rnMethodBinds, rnTopBinds ) -import Bag ( Bag, isEmptyBag, unionBags, listToBag ) +import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag ) import Class ( GenClass, getClassKey ) import CmdLineOpts ( opt_CompilingPrelude ) import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) ) @@ -162,7 +162,9 @@ tcDeriving :: Module -- name of module under scrutiny RenamedHsBinds, -- Extra generated bindings PprStyle -> Pretty) -- Printable derived instance decls; -- for debugging via -ddump-derivings. -tcDeriving = panic "tcDeriving: ToDo LATER" + +tcDeriving modname renamer_name_funs inst_decl_infos_in fixities + = returnTc (trace "tcDeriving:ToDo" (emptyBag, EmptyBinds, \ x -> ppNil)) {- LATER: tcDeriving modname renamer_name_funs inst_decl_infos_in fixities diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 809e08f..2cabcf1 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -166,6 +166,10 @@ tcExpr (HsLit lit@(HsString str)) %************************************************************************ \begin{code} +tcExpr (HsPar expr) = tcExpr expr + +tcExpr (NegApp expr) = panic "tcExpr:NegApp" + tcExpr (HsLam match) = tcMatch match `thenTc` \ (match',lie,ty) -> returnTc (HsLam match', lie, ty) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index d414786..0baa230 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[TcGenDeriv]{Generating derived instance declarations} @@ -830,7 +830,7 @@ mk_easy_FunMonoBind :: RdrName -> [RdrNamePat] -> RdrNameMonoBinds mk_easy_FunMonoBind fun pats binds expr - = FunMonoBind fun [mk_easy_Match pats binds expr] mkGeneratedSrcLoc + = FunMonoBind fun False{-not infix-} [mk_easy_Match pats binds expr] mkGeneratedSrcLoc mk_easy_Match pats binds expr = foldr PatMatch @@ -849,7 +849,7 @@ mk_FunMonoBind :: RdrName mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind" mk_FunMonoBind fun pats_and_exprs - = FunMonoBind fun (map mk_match pats_and_exprs) mkGeneratedSrcLoc + = FunMonoBind fun False{-not infix-} (map mk_match pats_and_exprs) mkGeneratedSrcLoc where mk_match (pats, expr) = foldr PatMatch diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 2405421..8369296 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -231,10 +231,10 @@ zonkMonoBinds (VarMonoBind var expr) zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (VarMonoBind new_var new_expr) -zonkMonoBinds (FunMonoBind name ms locn) +zonkMonoBinds (FunMonoBind name inf ms locn) = zonkId name `thenNF_Tc` \ new_name -> mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (FunMonoBind new_name new_ms locn) + returnNF_Tc (FunMonoBind new_name inf new_ms locn) \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 6237984..0d54c22 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -651,7 +651,7 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind -- Renamer has reduced us to these two cases. let (op,locn) = case mbind of - FunMonoBind op _ locn -> (op, locn) + FunMonoBind op _ _ locn -> (op, locn) PatMonoBind (VarPatIn op) _ locn -> (op, locn) occ = getLocalName op @@ -724,9 +724,9 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds -> TcM s (TcMonoBinds s, LIE s) -tcMethodBind meth_id meth_ty (FunMonoBind name matches locn) +tcMethodBind meth_id meth_ty (FunMonoBind name inf matches locn) = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) -> - returnTc (FunMonoBind meth_id rhs' locn, lie) + returnTc (FunMonoBind meth_id inf rhs' locn, lie) tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn) -- pat is sure to be a (VarPatIn op) diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 16b0ca2..9c8d253 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -72,9 +72,12 @@ tcPat pat_in@(AsPatIn name pat) unifyTauTy (idType id) ty `thenTc_` returnTc (AsPat (TcId id) pat', lie, ty) -tcPat (WildPatIn) +tcPat WildPatIn = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty -> returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty) + +tcPat (ParPatIn parend_pat) + = tcPat parend_pat \end{code} %************************************************************************ diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 5ba0463..9597b93 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -178,8 +178,9 @@ ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys where (ty1:ty2:_) = arg_tys -ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon a) usage) arg_tys - = ASSERT(length arg_tys == a) +ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys + = --ASSERT(length arg_tys == a) + (if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $ ppBesides [ppLparen, arg_tys_w_commas, ppRparen] where arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys) @@ -312,7 +313,7 @@ showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon) pprTyCon :: PprStyle -> TyCon -> Pretty pprTyCon sty FunTyCon = ppStr "(->)" -pprTyCon sty (TupleTyCon arity) = ppBeside (ppPStr SLIT("Tuple")) (ppInt arity) +pprTyCon sty (TupleTyCon _ name _) = ppr sty name pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd) @@ -524,9 +525,9 @@ pprTyCon sty@PprInterface this_tycon@(DataTyCon u n k vs ctxt cons derivings dat pp_NONE = ppPStr SLIT("_N_") -pprTyCon PprInterface (TupleTyCon a) specs +pprTyCon PprInterface (TupleTyCon _ name _) specs = ASSERT (null specs) - ppCat [ ppStr "{- Tuple", ppInt a, ppStr "-}" ] + ppCat [ ppStr "{- ", ppr PprForUser name, ppStr "-}" ] pprTyCon PprInterface (PrimTyCon k n a kind_fn) specs = ASSERT (null specs) diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 87dfc62..e0a6ed2 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -51,7 +51,9 @@ import Kind ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind ) import PrelMods ( pRELUDE_BUILTIN ) import Maybes -import Name ( Name, RdrName(..), appendRdr, nameUnique ) +import Name ( Name, RdrName(..), appendRdr, nameUnique, + mkTupleTyConName, mkFunTyConName + ) import Unique ( Unique, funTyConKey, mkTupleTyConUnique ) import Pretty ( Pretty(..), PrettyRep ) import PprStyle ( PprStyle ) @@ -74,7 +76,10 @@ data TyCon [Class] -- Classes which have derived instances NewOrData - | TupleTyCon Arity -- just a special case of DataTyCon + | TupleTyCon Unique -- cached + Name -- again, we could do without this, but + -- it makes life somewhat easier + Arity -- just a special case of DataTyCon -- Kind = BoxedTypeKind -- -> ... (n times) ... -- -> BoxedTypeKind @@ -113,9 +118,14 @@ data NewOrData \begin{code} mkFunTyCon = FunTyCon -mkTupleTyCon = TupleTyCon mkSpecTyCon = SpecTyCon +mkTupleTyCon arity + = TupleTyCon u n arity + where + n = mkTupleTyConName arity + u = uniqueOf n + mkDataTyCon name = DataTyCon (nameUnique name) name mkPrimTyCon name @@ -160,7 +170,7 @@ tyConKind (SpecTyCon tc tys) spec kind (Nothing : tys) = argKind kind `mkArrowKind` spec (resultKind kind) tys -tyConKind (TupleTyCon n) +tyConKind (TupleTyCon _ _ n) = mkArrow n where mkArrow 0 = mkBoxedTypeKind @@ -173,7 +183,7 @@ tyConKind (TupleTyCon n) tyConUnique :: TyCon -> Unique tyConUnique FunTyCon = funTyConKey tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq -tyConUnique (TupleTyCon a) = mkTupleTyConUnique a +tyConUnique (TupleTyCon uniq _ _) = uniq tyConUnique (PrimTyCon uniq _ _) = uniq tyConUnique (SynTyCon uniq _ _ _ _ _) = uniq tyConUnique (SpecTyCon _ _ ) = panic "tyConUnique:SpecTyCon" @@ -181,7 +191,7 @@ tyConUnique (SpecTyCon _ _ ) = panic "tyConUnique:SpecTyCon" tyConArity :: TyCon -> Arity tyConArity FunTyCon = 2 tyConArity (DataTyCon _ _ _ tvs _ _ _ _) = length tvs -tyConArity (TupleTyCon arity) = arity +tyConArity (TupleTyCon _ _ arity) = arity tyConArity (PrimTyCon _ _ _) = 0 -- ?? tyConArity (SpecTyCon _ _) = 0 tyConArity (SynTyCon _ _ _ arity _ _) = arity @@ -195,7 +205,7 @@ synTyConArity _ = Nothing tyConTyVars :: TyCon -> [TyVar] tyConTyVars FunTyCon = [alphaTyVar,betaTyVar] tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs -tyConTyVars (TupleTyCon arity) = take arity alphaTyVars +tyConTyVars (TupleTyCon _ _ arity) = take arity alphaTyVars tyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs tyConTyVars (PrimTyCon _ _ _) = panic "tyConTyVars:PrimTyCon" tyConTyVars (SpecTyCon _ _ ) = panic "tyConTyVars:SpecTyCon" @@ -206,14 +216,14 @@ tyConDataCons :: TyCon -> [Id] tyConFamilySize :: TyCon -> Int tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _) = data_cons -tyConDataCons (TupleTyCon a) = [mkTupleCon a] +tyConDataCons (TupleTyCon _ _ a) = [mkTupleCon a] tyConDataCons other = [] -- You may think this last equation should fail, -- but it's quite convenient to return no constructors for -- a synonym; see for example the call in TcTyClsDecls. tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons -tyConFamilySize (TupleTyCon a) = 1 +tyConFamilySize (TupleTyCon _ _ _) = 1 \end{code} \begin{code} @@ -229,14 +239,15 @@ getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty) \begin{code} maybeTyConSingleCon :: TyCon -> Maybe Id -maybeTyConSingleCon (TupleTyCon arity) = Just (mkTupleCon arity) + +maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (mkTupleCon arity) maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _) = Nothing maybeTyConSingleCon (PrimTyCon _ _ _) = Nothing maybeTyConSingleCon (SpecTyCon tc tys) = panic "maybeTyConSingleCon:SpecTyCon" -- requires DataCons of TyCon -isEnumerationTyCon (TupleTyCon arity) +isEnumerationTyCon (TupleTyCon _ _ arity) = arity == 0 isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _) = not (null data_cons) && all is_nullary data_cons @@ -274,7 +285,7 @@ instance Ord3 TyCon where cmp FunTyCon FunTyCon = EQ_ cmp (DataTyCon a _ _ _ _ _ _ _) (DataTyCon b _ _ _ _ _ _ _) = a `cmp` b cmp (SynTyCon a _ _ _ _ _) (SynTyCon b _ _ _ _ _) = a `cmp` b - cmp (TupleTyCon a) (TupleTyCon b) = a `cmp` b + cmp (TupleTyCon _ _ a) (TupleTyCon _ _ b) = a `cmp` b cmp (PrimTyCon a _ _) (PrimTyCon b _ _) = a `cmp` b cmp (SpecTyCon tc1 mtys1) (SpecTyCon tc2 mtys2) = panic# "cmp on SpecTyCons" -- case (tc1 `cmp` tc2) of { EQ_ -> mtys1 `cmp` mtys2; xxx -> xxx } @@ -288,7 +299,7 @@ instance Ord3 TyCon where tag2 = tag_TyCon other_2 tag_TyCon FunTyCon = ILIT(1) tag_TyCon (DataTyCon _ _ _ _ _ _ _ _) = ILIT(2) - tag_TyCon (TupleTyCon _) = ILIT(3) + tag_TyCon (TupleTyCon _ _ _) = ILIT(3) tag_TyCon (PrimTyCon _ _ _) = ILIT(4) tag_TyCon (SpecTyCon _ _) = ILIT(5) @@ -317,10 +328,8 @@ instance NamedThing TyCon where getName (PrimTyCon _ n _) = n getName (SpecTyCon tc _) = getName tc getName (SynTyCon _ n _ _ _ _) = n -{- LATER: - getName FunTyCon = (pRELUDE_BUILTIN, SLIT("(->)")) - getName (TupleTyCon a) = (pRELUDE_BUILTIN, _PK_ ("Tuple" ++ show a)) --} + getName FunTyCon = mkFunTyConName + getName (TupleTyCon _ n _) = n getName tc = panic "TyCon.getName" {- LATER: diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 0d25048..0fd31ef 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -41,6 +41,11 @@ import IdLoop -- for paranoia checking import TyLoop -- for paranoia checking import PrelLoop -- for paranoia checking +-- ToDo:rm +--import PprType ( pprGenType ) -- ToDo: rm +--import PprStyle ( PprStyle(..) ) +--import Util ( pprPanic ) + -- friends: import Class ( getClassSig, getClassOpLocalType, GenClass{-instances-} ) import Kind ( mkBoxedTypeKind, resultKind ) @@ -368,7 +373,7 @@ getAppDataTyCon ty = case maybeAppDataTyCon ty of Just stuff -> stuff #ifdef DEBUG - Nothing -> panic "Type.getAppDataTyCon" -- (ppr PprShowAll ty) + Nothing -> panic "Type.getAppDataTyCon: " -- (pprGenType PprShowAll ty) #endif diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index aeb06eb..09fcdc7 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -46,7 +46,7 @@ interppSP sty xs = ppIntersperse ppSP (map (ppr sty) xs) interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty interpp'SP sty xs - = ppInterleave sep (map (ppr sty) xs) + = ppIntersperse sep (map (ppr sty) xs) where sep = ppBeside ppComma ppSP -- 1.7.10.4