X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGenDeriv.lhs;h=f449cca0532ba267f2378ada9491b50b7f673125;hb=26741ec416bae2c502ef00a2ba0e79050a32cb67;hp=743851770d5793b8d22e286f4b6030f5197dcec5;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 7438517..f449cca 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -63,21 +63,22 @@ module TcGenDeriv (
     ) where
 
 IMP_Ubiq()
+IMPORT_1_3(List(partition))
 
 import HsSyn		( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
-			  GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qual(..), Stmt,
+			  GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt,
 			  ArithSeqInfo, Sig, PolyType, FixityDecl, Fake )
-import RdrHsSyn		( RdrNameMonoBinds(..), RdrNameHsExpr(..), RdrNamePat(..) )
+import RdrHsSyn		( SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat) )
 import RnHsSyn		( RenamedFixityDecl(..) )
 --import RnUtils
 
-import Id		( GenId, dataConArity, isNullaryDataCon, dataConTag,
+import Id		( GenId, dataConNumFields, isNullaryDataCon, dataConTag,
 			  dataConRawArgTys, fIRST_TAG,
-			  isDataCon, DataCon(..), ConTag(..) )
+			  isDataCon, SYN_IE(DataCon), SYN_IE(ConTag) )
 import IdUtils		( primOpId )
 import Maybes		( maybeToBool )
-import Name		( moduleNamePair, origName, RdrName(..) )
-import PrelMods		( fromPrelude, pRELUDE, pRELUDE_BUILTIN, pRELUDE_LIST, pRELUDE_TEXT )
+import Name		( origName, preludeQual, nameOf, RdrName(..), OrigName(..) )
+import PrelMods		( pRELUDE, gHC__, iX )
 import PrelVals		( eRROR_ID )
 
 import PrimOp		( PrimOp(..) )
@@ -199,8 +200,8 @@ gen_Eq_binds tycon
 	    con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
 	    con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
 
-	    data_con_PN = origName data_con
-	    con_arity   = dataConArity data_con
+	    data_con_PN = qual_orig_name data_con
+	    con_arity   = length tys_needed
 	    as_needed   = take con_arity as_PNs
 	    bs_needed   = take con_arity bs_PNs
 	    tys_needed  = dataConRawArgTys data_con
@@ -212,15 +213,6 @@ gen_Eq_binds tycon
 	  = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
 	  where
 	    nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
-{-OLD:
-	nested_eq_expr []     []     []  = true_Expr
-	nested_eq_expr [ty]   [a]    [b] = 
-	nested_eq_expr (t:ts) (a:as) (b:bs)
-	  = let
-		rest_expr = nested_eq_expr ts as bs
-	    in
-	    and_Expr (eq_Expr t (HsVar a) (HsVar b)) rest_expr
--}
 
 boring_ne_method
   = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] $
@@ -347,7 +339,7 @@ gen_Ord_binds tycon
 		    (cmp_tags_Expr ltH_Int_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
 
     (nullary_cons, nonnullary_cons)
-      = partition (\ con -> dataConArity con == 0) (tyConDataCons tycon)
+      = partition isNullaryDataCon (tyConDataCons tycon)
 
     cmp_eq
       = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc)
@@ -359,8 +351,8 @@ gen_Ord_binds tycon
 	    con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
 	    con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
 
-	    data_con_PN = origName data_con
-	    con_arity   = dataConArity data_con
+	    data_con_PN = qual_orig_name data_con
+	    con_arity   = length tys_needed
 	    as_needed   = take con_arity as_PNs
 	    bs_needed   = take con_arity bs_PNs
 	    tys_needed  = dataConRawArgTys data_con
@@ -487,11 +479,11 @@ gen_Bounded_binds tycon
 
     data_con_1	  = head data_cons
     data_con_N	  = last data_cons
-    data_con_1_PN = origName data_con_1
-    data_con_N_PN = origName data_con_N
+    data_con_1_PN = qual_orig_name data_con_1
+    data_con_N_PN = qual_orig_name data_con_N
 
     ----- single-constructor-flavored: -------------
-    arity	   = dataConArity data_con_1
+    arity	   = dataConNumFields data_con_1
 
     min_bound_1con = mk_easy_FunMonoBind minBound_PN [] [] $
 		     mk_easy_App data_con_1_PN (nOfThem arity minBound_PN)
@@ -565,7 +557,7 @@ gen_Ix_binds tycon
     then enum_ixes
     else single_con_ixes
   where
-    tycon_str = _UNPK_ (snd (moduleNamePair tycon))
+    tycon_str = _UNPK_ (nameOf (origName "gen_Ix_binds" tycon))
 
     --------------------------------------------------------------
     enum_ixes = enum_range `AndMonoBinds`
@@ -622,8 +614,8 @@ gen_Ix_binds tycon
 		     else
 			 dc
 
-    con_arity   = dataConArity data_con
-    data_con_PN = origName data_con
+    con_arity   = dataConNumFields data_con
+    data_con_PN = qual_orig_name data_con
     con_pat  xs = ConPatIn data_con_PN (map VarPatIn xs)
     con_expr xs = mk_easy_App data_con_PN xs
 
@@ -684,7 +676,7 @@ gen_Read_binds fixities tycon
   where
     -----------------------------------------------------------------------
     read_list = mk_easy_FunMonoBind readList_PN [] []
-		  (HsApp (HsVar _readList_PN) (HsPar (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0)))))
+		  (HsApp (HsVar readList___PN) (HsPar (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0)))))
     -----------------------------------------------------------------------
     reads_prec
       = let
@@ -697,9 +689,9 @@ gen_Read_binds fixities tycon
       where
 	read_con data_con   -- note: "b" is the string being "read"
 	  = let
-		data_con_PN = origName data_con
-		data_con_str= snd  (moduleNamePair data_con)
-		con_arity   = dataConArity data_con
+		data_con_PN = qual_orig_name data_con
+		data_con_str= nameOf (origName "gen_Read_binds" data_con)
+		con_arity   = dataConNumFields data_con
 		as_needed   = take con_arity as_PNs
 		bs_needed   = take con_arity bs_PNs
 		con_expr    = mk_easy_App data_con_PN as_needed
@@ -749,21 +741,21 @@ gen_Show_binds fixities tycon
   where
     -----------------------------------------------------------------------
     show_list = mk_easy_FunMonoBind showList_PN [] []
-		  (HsApp (HsVar _showList_PN) (HsPar (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0)))))
+		  (HsApp (HsVar showList___PN) (HsPar (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0)))))
     -----------------------------------------------------------------------
     shows_prec
       = mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon))
       where
 	pats_etc data_con
 	  = let
-		data_con_PN = origName data_con
-		con_arity   = dataConArity data_con
+		data_con_PN = qual_orig_name data_con
+		con_arity   = dataConNumFields data_con
 		bs_needed   = take con_arity bs_PNs
 		con_pat     = ConPatIn data_con_PN (map VarPatIn bs_needed)
 		nullary_con = isNullaryDataCon data_con
 
 		show_con
-		  = let (mod, nm)   = moduleNamePair data_con
+		  = let (OrigName mod nm) = origName "gen_Show_binds" data_con
 			space_maybe = if nullary_con then _NIL_ else SLIT(" ")
 		    in
 			HsApp (HsVar showString_PN) (HsLit (HsString (nm _APPEND_ space_maybe)))
@@ -823,8 +815,8 @@ gen_tag_n_con_monobind (pn, tycon, GenCon2Tag)
       = ASSERT(isDataCon var)
 	([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
       where
-	pat    = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn)
-	var_PN = origName var
+	pat    = ConPatIn var_PN (nOfThem (dataConNumFields var) WildPatIn)
+	var_PN = qual_orig_name var
 
 gen_tag_n_con_monobind (pn, tycon, GenTag2Con)
   = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
@@ -836,7 +828,7 @@ gen_tag_n_con_monobind (pn, tycon, GenTag2Con)
 	([lit_pat], HsVar var_PN)
       where
 	lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
-	var_PN  = origName var
+	var_PN  = qual_orig_name var
 
 gen_tag_n_con_monobind (pn, tycon, GenMaxTag)
   = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
@@ -1040,6 +1032,8 @@ parenify e	     = HsPar e
 \end{code}
 
 \begin{code}
+qual_orig_name n = case (origName "qual_orig_name" n) of { OrigName m n -> Qual m n }
+
 a_PN		= Unqual SLIT("a")
 b_PN		= Unqual SLIT("b")
 c_PN		= Unqual SLIT("c")
@@ -1049,42 +1043,40 @@ bh_PN		= Unqual SLIT("b#")
 ch_PN		= Unqual SLIT("c#")
 dh_PN		= Unqual SLIT("d#")
 cmp_eq_PN	= Unqual SLIT("cmp_eq")
-rangeSize_PN	= Unqual SLIT("rangeSize")
+rangeSize_PN	= Qual iX SLIT("rangeSize")
 
 as_PNs		= [ Unqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
 bs_PNs		= [ Unqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
 cs_PNs		= [ Unqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
 
-eq_PN		= prelude_method SLIT("Eq")  SLIT("==")
-ne_PN		= prelude_method SLIT("Eq")  SLIT("/=")
-le_PN		= prelude_method SLIT("Ord") SLIT("<=")
-lt_PN		= prelude_method SLIT("Ord") SLIT("<")
-ge_PN		= prelude_method SLIT("Ord") SLIT(">=")
-gt_PN		= prelude_method SLIT("Ord") SLIT(">")
-max_PN		= prelude_method SLIT("Ord") SLIT("max")
-min_PN		= prelude_method SLIT("Ord") SLIT("min")
-compare_PN	= prelude_method SLIT("Ord") SLIT("compare")
-minBound_PN	= prelude_method SLIT("Bounded") SLIT("minBound")
-maxBound_PN	= prelude_method SLIT("Bounded") SLIT("maxBound")
-ltTag_PN	= Unqual SLIT("LT")
-eqTag_PN	= Unqual SLIT("EQ")
-gtTag_PN	= Unqual SLIT("GT")
-enumFrom_PN	 = prelude_method SLIT("Enum") SLIT("enumFrom")
-enumFromTo_PN	 = prelude_method SLIT("Enum") SLIT("enumFromTo")
-enumFromThen_PN	 = prelude_method SLIT("Enum") SLIT("enumFromThen")
-enumFromThenTo_PN= prelude_method SLIT("Enum") SLIT("enumFromThenTo")
-range_PN	 = prelude_method SLIT("Ix")   SLIT("range")
-index_PN	 = prelude_method SLIT("Ix")   SLIT("index")
-inRange_PN	 = prelude_method SLIT("Ix")   SLIT("inRange")
-readsPrec_PN	 = prelude_method SLIT("Read") SLIT("readsPrec")
-readList_PN	 = prelude_method SLIT("Read") SLIT("readList")
-showsPrec_PN	 = prelude_method SLIT("Show") SLIT("showsPrec")
-showList_PN	 = prelude_method SLIT("Show") SLIT("showList")
-plus_PN		 = prelude_method SLIT("Num")  SLIT("+")
-times_PN	 = prelude_method SLIT("Num")  SLIT("*")
-
-false_PN	= prelude_val pRELUDE SLIT("False")
-true_PN		= prelude_val pRELUDE SLIT("True")
+eq_PN		 = preludeQual {-SLIT("Eq")-}  SLIT("==")
+ne_PN		 = preludeQual {-SLIT("Eq")-}  SLIT("/=")
+le_PN		 = preludeQual {-SLIT("Ord")-} SLIT("<=")
+lt_PN		 = preludeQual {-SLIT("Ord")-} SLIT("<")
+ge_PN		 = preludeQual {-SLIT("Ord")-} SLIT(">=")
+gt_PN		 = preludeQual {-SLIT("Ord")-} SLIT(">")
+max_PN		 = preludeQual {-SLIT("Ord")-} SLIT("max")
+min_PN		 = preludeQual {-SLIT("Ord")-} SLIT("min")
+compare_PN	 = preludeQual {-SLIT("Ord")-} SLIT("compare")
+minBound_PN	 = preludeQual {-SLIT("Bounded")-} SLIT("minBound")
+maxBound_PN	 = preludeQual {-SLIT("Bounded")-} SLIT("maxBound")
+enumFrom_PN	 = preludeQual {-SLIT("Enum")-} SLIT("enumFrom")
+enumFromTo_PN	 = preludeQual {-SLIT("Enum")-} SLIT("enumFromTo")
+enumFromThen_PN	 = preludeQual {-SLIT("Enum")-} SLIT("enumFromThen")
+enumFromThenTo_PN= preludeQual {-SLIT("Enum")-} SLIT("enumFromThenTo")
+range_PN	 = Qual iX   SLIT("range")
+index_PN	 = Qual iX   SLIT("index")
+inRange_PN	 = Qual iX   SLIT("inRange")
+readsPrec_PN	 = preludeQual {-SLIT("Read")-} SLIT("readsPrec")
+readList_PN	 = preludeQual {-SLIT("Read")-} SLIT("readList")
+showsPrec_PN	 = preludeQual {-SLIT("Show")-} SLIT("showsPrec")
+showList_PN	 = preludeQual {-SLIT("Show")-} SLIT("showList")
+plus_PN		 = preludeQual {-SLIT("Num")-}  SLIT("+")
+times_PN	 = preludeQual {-SLIT("Num")-}  SLIT("*")
+ltTag_PN	 = preludeQual SLIT("LT")
+eqTag_PN	 = preludeQual SLIT("EQ")
+gtTag_PN	 = preludeQual SLIT("GT")
+
 eqH_Char_PN	= prelude_primop CharEqOp
 ltH_Char_PN	= prelude_primop CharLtOp
 eqH_Word_PN	= prelude_primop WordEqOp
@@ -1100,24 +1092,25 @@ ltH_Int_PN	= prelude_primop IntLtOp
 geH_PN		= prelude_primop IntGeOp
 leH_PN		= prelude_primop IntLeOp
 minusH_PN	= prelude_primop IntSubOp
-and_PN		= prelude_val pRELUDE     SLIT("&&")
-not_PN		= prelude_val pRELUDE     SLIT("not")
-append_PN	= prelude_val pRELUDE_LIST SLIT("++")
-map_PN		= prelude_val pRELUDE_LIST SLIT("map")
-compose_PN	= prelude_val pRELUDE     SLIT(".")
-mkInt_PN	= prelude_val pRELUDE_BUILTIN SLIT("I#")
-error_PN	= prelude_val pRELUDE SLIT("error")
-showString_PN	= prelude_val pRELUDE_TEXT SLIT("showString")
-showParen_PN	= prelude_val pRELUDE_TEXT SLIT("showParen")
-readParen_PN	= prelude_val pRELUDE_TEXT SLIT("readParen")
-lex_PN		= prelude_val pRELUDE_TEXT SLIT("lex")
-showSpace_PN	= prelude_val pRELUDE_TEXT SLIT("__showSpace")
-_showList_PN    = prelude_val pRELUDE SLIT("__showList")
-_readList_PN    = prelude_val pRELUDE SLIT("__readList")
-
-prelude_val    m s = Unqual s
-prelude_method c o = Unqual o
-prelude_primop   o = origName (primOpId o)
+
+prelude_primop   o = case (origName "prelude_primop" (primOpId o)) of { OrigName m n -> Qual m n }
+
+false_PN	= preludeQual SLIT("False")
+true_PN		= preludeQual SLIT("True")
+and_PN		= preludeQual SLIT("&&")
+not_PN		= preludeQual SLIT("not")
+append_PN	= preludeQual SLIT("++")
+map_PN		= preludeQual SLIT("map")
+compose_PN	= preludeQual SLIT(".")
+mkInt_PN	= preludeQual SLIT("I#")
+error_PN	= preludeQual SLIT("error")
+showString_PN	= preludeQual SLIT("showString")
+showParen_PN	= preludeQual SLIT("showParen")
+readParen_PN	= preludeQual SLIT("readParen")
+lex_PN		= Qual gHC__  SLIT("lex")
+showSpace_PN	= Qual gHC__  SLIT("showSpace")
+showList___PN   = Qual gHC__  SLIT("showList__")
+readList___PN   = Qual gHC__  SLIT("readList__")
 
 a_Expr		= HsVar a_PN
 b_Expr		= HsVar b_PN
@@ -1139,20 +1132,20 @@ d_Pat		= VarPatIn d_PN
 con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName
 
 con2tag_PN tycon
-  = let	(mod, nm) = moduleNamePair tycon
+  = let	(OrigName mod nm) = origName "con2tag_PN" tycon
 	con2tag	  = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
     in
-    (if fromPrelude mod then Unqual else Qual mod) con2tag
+    Qual mod con2tag
 
 tag2con_PN tycon
-  = let	(mod, nm) = moduleNamePair tycon
+  = let	(OrigName mod nm) = origName "tag2con_PN" tycon
 	tag2con	  = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
     in
-    (if fromPrelude mod then Unqual else Qual mod) tag2con
+    Qual mod tag2con
 
 maxtag_PN tycon
-  = let	(mod, nm) = moduleNamePair tycon
+  = let	(OrigName mod nm) = origName "maxtag_PN" tycon
 	maxtag	  = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
     in
-    (if fromPrelude mod then Unqual else Qual mod) maxtag
+    Qual mod maxtag
 \end{code}