[project @ 2001-10-19 10:04:37 by sewardj]

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

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 758dbaa..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(..), StmtCtxt(..), HsType(..),
-                         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, isUnboxedType, Type )
+import TcType          ( isUnLiftedType, tcEqType, Type )
 import TysPrim         ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
                          floatPrimTy, doublePrimTy
                        )
@@ -63,7 +63,6 @@ import Panic          ( panic, assertPanic )
 import Maybes          ( maybeToBool, orElse )
 import Constants
 import List            ( partition, intersperse )
-import Outputable      ( pprPanic, ppr, pprTrace )
 
 #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
@@ -393,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}
 
 %************************************************************************
@@ -621,7 +600,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 +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-} (
@@ -719,7 +698,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,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 ++ [ReturnStmt result_expr]
+          stmts = quals ++ [ResultStmt result_expr tycon_loc]
                
            {-
              c.f. Figure 18 in Haskell 1.1 report.
@@ -1068,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}
 
 
@@ -1088,7 +1061,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)
@@ -1183,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
@@ -1196,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
@@ -1211,19 +1180,18 @@ 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
-  = 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...
@@ -1239,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)
@@ -1270,7 +1238,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
@@ -1283,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