HsBinds(..), StmtCtxt(..), HsType(..),
unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList
)
-import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
-import RdrName ( RdrName, mkSrcUnqual )
-import RnMonad ( FixityEnv, lookupFixity )
+import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
+import RdrName ( RdrName, mkUnqual )
import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
, maxPrecedence, defaultFixity
, Boxity(..)
import FieldLabel ( fieldLabelName )
import DataCon ( isNullaryDataCon, dataConTag,
dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
- DataCon, ConTag,
+ DataCon,
dataConFieldLabels )
import Name ( getOccString, getOccName, getSrcLoc, occNameString,
occNameUserString, nameRdrName, varName,
- OccName, Name, NamedThing(..), NameSpace,
+ Name, NamedThing(..),
isDataSymOcc, isSymOcc
)
import PrelInfo -- Lots of RdrNames
-import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
+import SrcLoc ( generatedSrcLoc, SrcLoc )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
maybeTyConSingleCon, tyConFamilySize
)
floatPrimTy, doublePrimTy
)
import Util ( mapAccumL, zipEqual, zipWithEqual,
- zipWith3Equal, nOfThem, assocDefault )
+ zipWith3Equal, nOfThem )
import Panic ( panic, assertPanic )
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, orElse )
import Constants
import List ( partition, intersperse )
+import Outputable ( pprPanic, ppr, pprTrace )
#if __GLASGOW_HASKELL__ >= 404
import GlaExts ( fromInt )
defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
-lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
+lt = mk_easy_FunMonoBind generatedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
-le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
+le = mk_easy_FunMonoBind generatedSrcLoc le_RDR [a_Pat, b_Pat] [] (
compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
-ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
+ge = mk_easy_FunMonoBind generatedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
-gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
+gt = mk_easy_FunMonoBind generatedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
-max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
+max_ = mk_easy_FunMonoBind generatedSrcLoc max_RDR [a_Pat, b_Pat] [] (
compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
-min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
+min_ = mk_easy_FunMonoBind generatedSrcLoc min_RDR [a_Pat, b_Pat] [] (
compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
-}
\end{code}
%************************************************************************
\begin{code}
-gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
+gen_Read_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds
-gen_Read_binds fixity_env tycon
+gen_Read_binds get_fixity tycon
= reads_prec `AndMonoBinds` read_list
where
tycon_loc = getSrcLoc tycon
then d_Expr
else HsVar (last bs_needed)] Boxed
- [lp,rp] = getLRPrecs is_infix fixity_env dc_nm
+ [lp,rp] = getLRPrecs is_infix get_fixity dc_nm
quals
| is_infix = let (h:t) = field_quals in (h:con_qual:t)
c.f. Figure 18 in Haskell 1.1 report.
-}
paren_prec_limit
- | not is_infix = fromInt maxPrecedence
- | otherwise = getFixity fixity_env dc_nm
+ | not is_infix = defaultPrecedence
+ | otherwise = getPrecedence get_fixity dc_nm
read_paren_arg -- parens depend on precedence...
| nullary_con = false_Expr -- it's optional.
%************************************************************************
\begin{code}
-gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
+gen_Show_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds
-gen_Show_binds fixity_env tycon
+gen_Show_binds get_fixity tycon
= shows_prec `AndMonoBinds` show_list
where
tycon_loc = getSrcLoc tycon
mk_showString_app str = HsApp (HsVar showString_RDR)
(HsLit (mkHsString str))
- prec_cons = getLRPrecs is_infix fixity_env dc_nm
+ prec_cons = getLRPrecs is_infix get_fixity dc_nm
real_show_thingies
| is_infix =
c.f. Figure 16 and 17 in Haskell 1.1 report
-}
paren_prec_limit
- | not is_infix = fromInt maxPrecedence + 1
- | otherwise = getFixity fixity_env dc_nm + 1
+ | not is_infix = defaultPrecedence + 1
+ | otherwise = getPrecedence get_fixity dc_nm + 1
\end{code}
\begin{code}
-getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer]
-getLRPrecs is_infix fixity_env nm = [lp, rp]
+getLRPrecs :: Bool -> (Name -> Maybe Fixity) -> Name -> [Integer]
+getLRPrecs is_infix get_fixity nm = [lp, rp]
where
{-
Figuring out the fixities of the arguments to a constructor,
cf. Figures 16-18 in Haskell 1.1 report.
-}
- (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env nm
- paren_con_prec = getFixity fixity_env nm
- maxPrec = fromInt maxPrecedence
+ (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm
+ paren_con_prec = getPrecedence get_fixity nm
lp
- | not is_infix = maxPrec + 1
+ | not is_infix = defaultPrecedence + 1
| con_left_assoc = paren_con_prec
| otherwise = paren_con_prec + 1
rp
- | not is_infix = maxPrec + 1
+ | not is_infix = defaultPrecedence + 1
| con_right_assoc = paren_con_prec
| otherwise = paren_con_prec + 1
-getFixity :: FixityEnv -> Name -> Integer
-getFixity fixity_env nm = case lookupFixity fixity_env nm of
- Fixity x _ -> fromInt x
-
-isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
-isLRAssoc fixs_assoc nm =
- case lookupFixity fixs_assoc nm of
+defaultPrecedence :: Integer
+defaultPrecedence = fromInt maxPrecedence
+
+getPrecedence :: (Name -> Maybe Fixity) -> Name -> Integer
+getPrecedence get_fixity nm
+ = case get_fixity nm of
+ Just (Fixity x _) -> fromInt x
+ other -> defaultPrecedence
+
+isLRAssoc :: (Name -> Maybe Fixity) -> Name -> (Bool, Bool)
+isLRAssoc get_fixity nm =
+ case get_fixity nm `orElse` defaultFixity of
Fixity _ InfixN -> (False, False)
Fixity _ InfixR -> (False, True)
Fixity _ InfixL -> (True, False)
compare_gen_Case fun lt eq gt a b
= HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
- [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc,
- mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc,
- mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc]
- mkGeneratedSrcLoc
+ [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing generatedSrcLoc,
+ mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing generatedSrcLoc,
+ mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing generatedSrcLoc]
+ generatedSrcLoc
careful_compare_Case ty lt eq gt a b
= if not (isUnboxedType ty) then
else -- we have to do something special for primitive things...
HsIf (genOpApp a relevant_eq_op b)
eq
- (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
- mkGeneratedSrcLoc
+ (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc)
+ generatedSrcLoc
where
relevant_eq_op = assoc_ty_id eq_op_tbl ty
relevant_lt_op = assoc_ty_id lt_op_tbl ty
untag_Expr tycon [] expr = expr
untag_Expr tycon ((untag_this, put_tag_here) : more) expr
= HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
- [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc]
- mkGeneratedSrcLoc
+ [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing generatedSrcLoc]
+ generatedSrcLoc
cmp_tags_Expr :: RdrName -- Comparison op
-> RdrName -> RdrName -- Things to compare
-> RdrNameHsExpr
cmp_tags_Expr op a b true_case false_case
- = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
+ = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
enum_from_to_Expr
:: RdrNameHsExpr -> RdrNameHsExpr
-- For some reason the renamer doesn't reassociate it right, and I can't
-- be bothered to find out why just now.
-genOpApp e1 op e2 = mkOpApp e1 op e2
+genOpApp e1 op e2 = mkHsOpApp e1 op e2
\end{code}
\begin{code}
qual_orig_name n = nameRdrName (getName n)
-varUnqual n = mkSrcUnqual varName n
+varUnqual n = mkUnqual varName n
zz_a_RDR = varUnqual SLIT("_a")
a_RDR = varUnqual SLIT("a")
projects / ghc-hetmet.git / blobdiff