X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGenDeriv.lhs;h=00089214dcaf92fabd4eb93602b2f704d104916e;hb=b0604aad2c311d8713c2497afa6373bd938d501b;hp=670db8eac4fbe7e478b0b4953cd0f5ba7b3edbe2;hpb=0499865e0ff47ce970030a4d65897a5e2f592605;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 670db8e..0008921 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -28,13 +28,13 @@ module TcGenDeriv ( import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), Match(..), GRHSs(..), Stmt(..), HsLit(..), - HsBinds(..), StmtCtxt(..), HsType(..), - unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList + HsBinds(..), HsType(..), HsDoContext(..), + unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType ) import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) import RdrName ( RdrName, mkUnqual ) import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) - , maxPrecedence + , maxPrecedence, defaultFixity , Boxity(..) ) import FieldLabel ( fieldLabelName ) @@ -53,17 +53,16 @@ import SrcLoc ( generatedSrcLoc, SrcLoc ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon, tyConFamilySize ) -import Type ( isUnLiftedType, isUnboxedType, Type ) +import TcType ( isUnLiftedType, tcEqType, Type ) import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy ) import Util ( mapAccumL, zipEqual, zipWithEqual, zipWith3Equal, nOfThem ) import Panic ( panic, assertPanic ) -import Maybes ( maybeToBool ) +import Maybes ( maybeToBool, orElse ) import Constants import List ( partition, intersperse ) -import Outputable ( pprPanic, ppr ) #if __GLASGOW_HASKELL__ >= 404 import GlaExts ( fromInt ) @@ -103,7 +102,7 @@ data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 \end{verbatim} - Note: if we're comparing unboxed things, e.g., if \tr{a1} and + Note: if we're comparing unlifted things, e.g., if \tr{a1} and \tr{a2} are \tr{Float#}s, then we have to generate \begin{verbatim} case (a1 `eqFloat#` a2) of @@ -288,7 +287,7 @@ cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2) } \end{verbatim} - Again, we must be careful about unboxed comparisons. For example, + Again, we must be careful about unlifted comparisons. For example, if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to generate: @@ -324,7 +323,7 @@ gen_Ord_binds tycon (if maybeToBool (maybeTyConSingleCon tycon) then -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr --- Wierd. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT } +-- Weird. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT } cmp_eq_Expr a_Expr b_Expr else @@ -621,7 +620,7 @@ instance ... Ix (Foo ...) where False }}} \end{verbatim} -(modulo suitable case-ification to handle the unboxed tags) +(modulo suitable case-ification to handle the unlifted tags) For a single-constructor type (NB: this includes all tuples), e.g., \begin{verbatim} @@ -667,7 +666,7 @@ gen_Ix_binds tycon in HsCase (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR)) - [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc] + [mkSimpleMatch [VarPatIn c_RDR] rhs placeHolderType tycon_loc] tycon_loc )) ) {-else-} ( @@ -719,7 +718,7 @@ gen_Ix_binds tycon where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed ++ - [ReturnStmt con_expr] + [ResultStmt con_expr tycon_loc] mk_qual a b c = BindStmt (VarPatIn c) (HsApp (HsVar range_RDR) @@ -908,14 +907,14 @@ gen_Read_binds get_fixity tycon | is_infix = let (h:t) = field_quals in (h:con_qual:t) | otherwise = con_qual:field_quals - stmts = quals ++ [ReturnStmt result_expr] + stmts = quals ++ [ResultStmt result_expr tycon_loc] {- c.f. Figure 18 in Haskell 1.1 report. -} paren_prec_limit - | not is_infix = fromInt maxPrecedence - | otherwise = getFixity get_fixity 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. @@ -1027,8 +1026,8 @@ gen_Show_binds get_fixity tycon c.f. Figure 16 and 17 in Haskell 1.1 report -} paren_prec_limit - | not is_infix = fromInt maxPrecedence + 1 - | otherwise = getFixity get_fixity dc_nm + 1 + | not is_infix = defaultPrecedence + 1 + | otherwise = getPrecedence get_fixity dc_nm + 1 \end{code} @@ -1041,32 +1040,33 @@ getLRPrecs is_infix get_fixity nm = [lp, rp] cf. Figures 16-18 in Haskell 1.1 report. -} (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm - paren_con_prec = getFixity get_fixity nm - maxPrec = fromInt maxPrecedence + 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 :: (Name -> Maybe Fixity) -> Name -> Integer -getFixity get_fixity nm +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 -> pprPanic "TcGenDeriv.getFixity" (ppr nm) + other -> defaultPrecedence isLRAssoc :: (Name -> Maybe Fixity) -> Name -> (Bool, Bool) isLRAssoc get_fixity nm = - case get_fixity nm of - Just (Fixity _ InfixN) -> (False, False) - Just (Fixity _ InfixR) -> (False, True) - Just (Fixity _ InfixL) -> (True, False) - other -> pprPanic "TcGenDeriv.isLRAssoc" (ppr nm) + case get_fixity nm `orElse` defaultFixity of + Fixity _ InfixN -> (False, False) + Fixity _ InfixR -> (False, True) + Fixity _ InfixL -> (True, False) isInfixOccName :: String -> Bool isInfixOccName str = @@ -1087,7 +1087,7 @@ data Foo ... = ... con2tag_Foo :: Foo ... -> Int# tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# -maxtag_Foo :: Int -- ditto (NB: not unboxed) +maxtag_Foo :: Int -- ditto (NB: not unlifted) \end{verbatim} The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) @@ -1182,7 +1182,7 @@ mk_FunMonoBind loc fun pats_and_exprs mk_match loc pats expr binds = Match [] (map paren pats) Nothing - (GRHSs (unguardedRHS expr loc) binds Nothing) + (GRHSs (unguardedRHS expr loc) binds placeHolderType) where paren p@(VarPatIn _) = p paren other_p = ParPatIn other_p @@ -1216,13 +1216,13 @@ cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b compare_gen_Case fun lt eq gt a b = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-} - [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing generatedSrcLoc, - mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing generatedSrcLoc, - mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing generatedSrcLoc] + [mkSimpleMatch [ConPatIn ltTag_RDR []] lt placeHolderType generatedSrcLoc, + mkSimpleMatch [ConPatIn eqTag_RDR []] eq placeHolderType generatedSrcLoc, + mkSimpleMatch [ConPatIn gtTag_RDR []] gt placeHolderType generatedSrcLoc] generatedSrcLoc careful_compare_Case ty lt eq gt a b - = if not (isUnboxedType ty) then + = if not (isUnLiftedType ty) then compare_gen_Case compare_RDR lt eq gt a b else -- we have to do something special for primitive things... @@ -1238,7 +1238,7 @@ assoc_ty_id tyids ty = if null res then panic "assoc_ty" else head res where - res = [id | (ty',id) <- tyids, ty == ty'] + res = [id | (ty',id) <- tyids, ty `tcEqType` ty'] eq_op_tbl = [(charPrimTy, eqH_Char_RDR) @@ -1269,7 +1269,7 @@ append_Expr a b = genOpApp a append_RDR b eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr eq_Expr ty a b - = if not (isUnboxedType ty) then + = if not (isUnLiftedType ty) then genOpApp a eq_RDR b else -- we have to do something special for primitive things... genOpApp a relevant_eq_op b @@ -1282,7 +1282,7 @@ untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr 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 generatedSrcLoc] + [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc] generatedSrcLoc cmp_tags_Expr :: RdrName -- Comparison op