Commit b4255f2c authored by partain's avatar partain
Browse files

[project @ 1996-04-09 10:27:46 by partain]

Sansom 1.3 changes through 960408
parent 7b018191
......@@ -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
......
......@@ -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 ???
......
......@@ -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],
......
......@@ -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
......
......@@ -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)
---------------------------------------
......
......@@ -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) ->
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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)
......
......@@ -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-} ]
......
......@@ -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)
......
......@@ -245,9 +245,9 @@ BOOLEAN inpat;
%type <utree> 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 <uid> 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(); }
;
/**********************************************************************
* *
......
......@@ -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
......
......@@ -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}
......
......@@ -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)