[project @ 2000-11-21 09:30:16 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 81b6a89..758dbaa 100644 (file)
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -34,7 +34,7 @@ import HsSyn          ( InPat(..), HsExpr(..), MonoBinds(..),
 import RdrHsSyn                ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
 import RdrName         ( RdrName, mkUnqual )
 import BasicTypes      ( RecFlag(..), Fixity(..), FixityDirection(..)
-                       , maxPrecedence
+                       , maxPrecedence, defaultFixity
                        , Boxity(..)
                        )
 import FieldLabel       ( fieldLabelName )
@@ -47,7 +47,6 @@ import Name           ( getOccString, getOccName, getSrcLoc, occNameString,
                          Name, NamedThing(..), 
                          isDataSymOcc, isSymOcc
                        )
-import HscTypes                ( GlobalSymbolTable, lookupFixityEnv )
 
 import PrelInfo                -- Lots of RdrNames
 import SrcLoc          ( generatedSrcLoc, SrcLoc )
@@ -61,10 +60,10 @@ import TysPrim              ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
 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 )
+import Outputable      ( pprPanic, ppr, pprTrace )
 
 #if __GLASGOW_HASKELL__ >= 404
 import GlaExts         ( fromInt )
@@ -773,9 +772,9 @@ gen_Ix_binds tycon
 %************************************************************************
 
 \begin{code}
-gen_Read_binds :: GlobalSymbolTable -> TyCon -> RdrNameMonoBinds
+gen_Read_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds
 
-gen_Read_binds gst tycon
+gen_Read_binds get_fixity tycon
   = reads_prec `AndMonoBinds` read_list
   where
     tycon_loc = getSrcLoc tycon
@@ -903,7 +902,7 @@ gen_Read_binds gst tycon
                                                    then d_Expr 
                                                    else HsVar (last bs_needed)] Boxed
 
-           [lp,rp] = getLRPrecs is_infix gst dc_nm
+           [lp,rp] = getLRPrecs is_infix get_fixity dc_nm
 
            quals
            | is_infix  = let (h:t) = field_quals in (h:con_qual:t)
@@ -915,8 +914,8 @@ gen_Read_binds gst tycon
              c.f. Figure 18 in Haskell 1.1 report.
            -}
           paren_prec_limit
-            | not is_infix  = fromInt maxPrecedence
-            | otherwise     = getFixity gst 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.
@@ -930,9 +929,9 @@ gen_Read_binds gst tycon
 %************************************************************************
 
 \begin{code}
-gen_Show_binds :: GlobalSymbolTable -> TyCon -> RdrNameMonoBinds
+gen_Show_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds
 
-gen_Show_binds gst tycon
+gen_Show_binds get_fixity tycon
   = shows_prec `AndMonoBinds` show_list
   where
     tycon_loc = getSrcLoc tycon
@@ -1003,7 +1002,7 @@ gen_Show_binds gst tycon
              mk_showString_app str = HsApp (HsVar showString_RDR)
                                           (HsLit (mkHsString str))
 
-             prec_cons = getLRPrecs is_infix gst dc_nm
+             prec_cons = getLRPrecs is_infix get_fixity dc_nm
 
              real_show_thingies
                | is_infix  = 
@@ -1028,46 +1027,47 @@ gen_Show_binds gst tycon
                c.f. Figure 16 and 17 in Haskell 1.1 report
              -}  
             paren_prec_limit
-               | not is_infix = fromInt maxPrecedence + 1
-               | otherwise    = getFixity gst dc_nm + 1
+               | not is_infix = defaultPrecedence + 1
+               | otherwise    = getPrecedence get_fixity dc_nm + 1
 
 \end{code}
 
 \begin{code}
-getLRPrecs :: Bool -> GlobalSymbolTable -> Name -> [Integer]
-getLRPrecs is_infix gst 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 gst nm
-     paren_con_prec = getFixity gst 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 :: GlobalSymbolTable -> Name -> Integer
-getFixity gst nm 
-   = case lookupFixityEnv gst 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            -> pprPanic "TcGenDeriv.getFixity" (ppr nm)
-
-isLRAssoc :: GlobalSymbolTable -> Name -> (Bool, Bool)
-isLRAssoc fixs_assoc nm =
-     case lookupFixityEnv fixs_assoc nm of
-       Just (Fixity _ InfixN) -> (False, False)
-       Just (Fixity _ InfixR) -> (False, True)
-       Just (Fixity _ InfixL) -> (True,  False)
-       other -> pprPanic "TcGenDeriv.isLRAssoc" (ppr nm)
+        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)
 
 isInfixOccName :: String -> Bool
 isInfixOccName str =