[project @ 2001-10-18 08:53:03 by simonmar]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcGenDeriv.lhs

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 2422b42..273572b 100644 (file)
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -28,8 +28,8 @@ module TcGenDeriv (
 
 import HsSyn           ( InPat(..), HsExpr(..), MonoBinds(..),
                          Match(..), GRHSs(..), Stmt(..), HsLit(..),
-                         HsBinds(..), HsType(..), HsMatchContext(..),
-                         unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList
+                         HsBinds(..), HsType(..), HsDoContext(..),
+                         unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
                        )
 import RdrHsSyn                ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
 import RdrName         ( RdrName, mkUnqual )
@@ -53,7 +53,7 @@ import SrcLoc         ( generatedSrcLoc, SrcLoc )
 import TyCon           ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
                          maybeTyConSingleCon, tyConFamilySize
                        )
-import Type            ( isUnLiftedType, Type )
+import TcType          ( isUnLiftedType, tcEqType, Type )
 import TysPrim         ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
                          floatPrimTy, doublePrimTy
                        )
@@ -392,26 +392,6 @@ gen_Ord_binds tycon
                                                                -- inexhaustive patterns
                    | otherwise         = eqTag_Expr            -- Some nullary constructors;
                                                                -- Tags are equal, no args => return EQ
-    --------------------------------------------------------------------
-
-{- Not necessary: the default decls in PrelBase handle these 
-
-defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
-
-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 generatedSrcLoc le_RDR [a_Pat, b_Pat] [] (
-           compare_Case true_Expr  true_Expr  false_Expr a_Expr b_Expr)
-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 generatedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
-           compare_Case false_Expr false_Expr true_Expr  a_Expr b_Expr)
-
-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 generatedSrcLoc min_RDR [a_Pat, b_Pat] [] (
-           compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
--}
 \end{code}
 
 %************************************************************************
@@ -666,7 +646,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-} (
@@ -718,7 +698,7 @@ gen_Ix_binds tycon
       where
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
                ++
-               [ExprStmt con_expr tycon_loc]
+               [ResultStmt con_expr tycon_loc]
 
        mk_qual a b c = BindStmt (VarPatIn c)
                                 (HsApp (HsVar range_RDR) 
@@ -907,7 +887,7 @@ 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 ++ [ExprStmt result_expr tycon_loc]
+          stmts = quals ++ [ResultStmt result_expr tycon_loc]
                
            {-
              c.f. Figure 18 in Haskell 1.1 report.
@@ -1067,12 +1047,6 @@ isLRAssoc get_fixity nm =
        Fixity _ InfixN -> (False, False)
        Fixity _ InfixR -> (False, True)
        Fixity _ InfixL -> (True,  False)
-
-isInfixOccName :: String -> Bool
-isInfixOccName str = 
-   case str of
-     (':':_) -> True
-     _       -> False
 \end{code}
 
 
@@ -1182,7 +1156,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
@@ -1195,10 +1169,6 @@ mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
 ToDo: Better SrcLocs.
 
 \begin{code}
-compare_Case ::
-         RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
-         -> RdrNameHsExpr -> RdrNameHsExpr
-         -> RdrNameHsExpr
 compare_gen_Case ::
          RdrName
          -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
@@ -1210,15 +1180,14 @@ careful_compare_Case :: -- checks for primitive types...
          -> RdrNameHsExpr -> RdrNameHsExpr
          -> RdrNameHsExpr
 
-compare_Case = compare_gen_Case compare_RDR
 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
        -- Was: compare_gen_Case cmp_eq_RDR
 
 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
@@ -1238,7 +1207,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)
@@ -1282,7 +1251,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