import Maybes ( maybeToBool )
import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
isLocallyDefinedName, isPreludeDefinedName,
- nameOrigName,
+ nameOrigName, mkTupleDataConName,
isAvarop, isAconop, getLocalName,
isLocallyDefined, isPreludeDefined,
getOrigName, getOccName,
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,
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
mkImplicitName, isImplicitName,
mkBuiltinName,
+ mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
+
NamedThing(..), -- class
ExportFlag(..), isExported,
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}
%************************************************************************
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 ???
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
= 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],
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
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}
%************************************************************************
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)
---------------------------------------
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.
\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) ->
\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
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
(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
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)
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
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)
= 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)
-- 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)
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-} ]
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)
exitMn 0
} ) }
-LATER -}
+{- LATER -}
}
where
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)
%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
;
-valdef : opatk
+valdef : vallhs
{
tree fn = function($1);
PREVPATT = $1;
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)); }
;
* *
**********************************************************************/
-/*
- 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
;
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); }
| 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); }
;
;
+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); }
+ ;
+
/**********************************************************************
* *
* *
}
;
-minuskey: MINUS { setstartlineno(); }
- ;
-
modulekey: MODULE { setstartlineno();
if(etags)
#if 1/*etags*/
lazykey : LAZY { setstartlineno(); }
;
+minuskey: MINUS { setstartlineno(); }
+ ;
+
/**********************************************************************
* *
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
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}
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
-- 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)
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}
import RdrHsSyn
import RnHsSyn
import RnMonad
-import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat )
+import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecInfixBind )
import CmdLineOpts ( opt_SigsRequired )
import Digraph ( stronglyConnComp )
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 $
)]
)
-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
[(uniq,
unitUniqSet name',
fvs `unionUniqSets` sigs_fvs,
- FunMonoBind name' new_matches locn,
+ FunMonoBind name' inf new_matches locn,
sigs_for_me
)]
)
#include "HsVersions.h"
module RnExpr (
- rnMatch, rnGRHSsAndBinds, rnPat
+ rnMatch, rnGRHSsAndBinds, rnPat,
+ checkPrecInfixBind
) where
import Ubiq
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' ->
where
fv_set vname@(RnName n)
| isLocallyDefinedName n = unitUniqSet vname
- | otherwise = emptyUniqSet
+ fv_set _ = emptyUniqSet
rnExpr (HsLit lit)
= returnRn (HsLit lit, emptyUniqSet)
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
\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)
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 )
import TyCon ( TyCon )
import TyVar ( GenTyVar )
import Unique ( Unique )
-import Util ( panic, pprPanic )
+import Util ( panic, pprPanic, pprTrace{-ToDo:rm-} )
\end{code}
\begin{code}
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
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)
= 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 ->
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 ->
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,
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}
%*********************************************************
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
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}
%************************************************************************
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(..) )
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
%************************************************************************
\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)
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcGenDeriv]{Generating derived instance declarations}
-> 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
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
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}
%************************************************************************
-- 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
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)
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}
%************************************************************************
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)
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)
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)
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 )
[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
\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
spec kind (Nothing : tys) =
argKind kind `mkArrowKind` spec (resultKind kind) tys
-tyConKind (TupleTyCon n)
+tyConKind (TupleTyCon _ _ n)
= mkArrow n
where
mkArrow 0 = mkBoxedTypeKind
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"
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
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"
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}
\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
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 }
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)
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:
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 )
= case maybeAppDataTyCon ty of
Just stuff -> stuff
#ifdef DEBUG
- Nothing -> panic "Type.getAppDataTyCon" -- (ppr PprShowAll ty)
+ Nothing -> panic "Type.getAppDataTyCon: " -- (pprGenType PprShowAll ty)
#endif
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
projects / ghc-hetmet.git / commitdiff