[project @ 2000-02-25 14:55:31 by panne]

[ghc-hetmet.git] / ghc / compiler / hsSyn / HsBinds.lhs

diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index c09ccc3..60a2996 100644 (file)
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -15,6 +15,7 @@ import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
 
 -- friends:
 import HsTypes         ( HsType )
+import HsImpExp                ( IE(..), ieName )
 import CoreSyn         ( CoreExpr )
 import PprCore         ()         -- Instances for Outputable
 
@@ -60,6 +61,10 @@ nullBinds :: HsBinds id pat -> Bool
 nullBinds EmptyBinds           = True
 nullBinds (ThenBinds b1 b2)    = nullBinds b1 && nullBinds b2
 nullBinds (MonoBind b _ _)     = nullMonoBinds b
+
+mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
+mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
+mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
 \end{code}
 
 \begin{code}
@@ -151,10 +156,11 @@ So the desugarer tries to do a better job:
                                      in (fm,gm)
 
 \begin{code}
-nullMonoBinds :: MonoBinds id pat -> Bool
+-- We keep the invariant that a MonoBinds is only empty 
+-- if it is exactly EmptyMonoBinds
 
+nullMonoBinds :: MonoBinds id pat -> Bool
 nullMonoBinds EmptyMonoBinds        = True
-nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
 nullMonoBinds other_monobind        = False
 
 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
@@ -163,7 +169,17 @@ andMonoBinds mb EmptyMonoBinds = mb
 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 
 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
-andMonoBindList binds = foldr AndMonoBinds EmptyMonoBinds binds
+andMonoBindList binds
+  = loop1 binds
+  where
+    loop1 [] = EmptyMonoBinds
+    loop1 (EmptyMonoBinds : binds) = loop1 binds
+    loop1 (b:bs) = loop2 b bs
+
+       -- acc is non-empty
+    loop2 acc [] = acc
+    loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
+    loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
 \end{code}
 
 \begin{code}
@@ -240,10 +256,19 @@ data Sig name
                                -- current instance decl
                SrcLoc
 
-  | FixSig     (FixitySig name)                -- Fixity declaration
+  | FixSig     (FixitySig name)        -- Fixity declaration
+
+  | DeprecSig  (Deprecation name)      -- DEPRECATED
+               SrcLoc
 
 
 data FixitySig name  = FixitySig name Fixity SrcLoc
+
+-- We use exported entities for things to deprecate. Cunning trick (hack?):
+-- `IEModuleContents undefined' is used for module deprecation.
+data Deprecation name = Deprecation (IE name) DeprecTxt
+
+type DeprecTxt = FAST_STRING   -- reason/explanation for deprecation
 \end{code}
 
 \begin{code}
@@ -251,13 +276,17 @@ sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
 sigsForMe f sigs
   = filter sig_for_me sigs
   where
-    sig_for_me (Sig         n _ _)       = f n
-    sig_for_me (ClassOpSig  n _ _ _ _)           = f n
-    sig_for_me (SpecSig     n _ _)       = f n
-    sig_for_me (InlineSig   n _   _)     = f n  
-    sig_for_me (NoInlineSig n _   _)     = f n  
-    sig_for_me (SpecInstSig _ _)         = False
-    sig_for_me (FixSig (FixitySig n _ _)) = f n
+    sig_for_me (Sig         n _ _)                         = f n
+    sig_for_me (ClassOpSig  n _ _ _ _)                     = f n
+    sig_for_me (SpecSig     n _ _)                         = f n
+    sig_for_me (InlineSig   n _   _)                       = f n
+    sig_for_me (NoInlineSig n _   _)                       = f n
+    sig_for_me (SpecInstSig _ _)                           = False
+    sig_for_me (FixSig (FixitySig n _ _))                  = f n
+    sig_for_me
+       (DeprecSig (Deprecation (IEModuleContents _) _) _) = False
+    sig_for_me
+       (DeprecSig (Deprecation d                    _) _) = f (ieName d)
 
 isFixitySig :: Sig name -> Bool
 isFixitySig (FixSig _) = True
@@ -273,6 +302,7 @@ isPragSig (SpecSig _ _ _)     = True
 isPragSig (InlineSig   _ _ _) = True
 isPragSig (NoInlineSig _ _ _) = True
 isPragSig (SpecInstSig _ _)   = True
+isPragSig (DeprecSig _ _)     = True
 isPragSig other                      = False
 \end{code}
 
@@ -280,10 +310,7 @@ isPragSig other                  = False
 instance (Outputable name) => Outputable (Sig name) where
     ppr sig = ppr_sig sig
 
-instance Outputable name => Outputable (FixitySig name) where
-  ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
-
-
+ppr_sig :: Outputable name => Sig name -> SDoc
 ppr_sig (Sig var ty _)
       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 
@@ -296,17 +323,29 @@ ppr_sig (SpecSig var ty _)
        ]
 
 ppr_sig (InlineSig var phase _)
-        = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
+      = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
 
 ppr_sig (NoInlineSig var phase _)
-        = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
+      = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
 
 ppr_sig (SpecInstSig ty _)
       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 
 ppr_sig (FixSig fix_sig) = ppr fix_sig
 
-ppr_phase Nothing = empty
+ppr_sig (DeprecSig deprec _) = ppr deprec
+
+instance Outputable name => Outputable (FixitySig name) where
+  ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
+
+instance Outputable name => Outputable (Deprecation name) where
+   ppr (Deprecation (IEModuleContents _) txt)
+      = hsep [text "{-# DEPRECATED",            doubleQuotes (ppr txt), text "#-}"]
+   ppr (Deprecation thing txt)
+      = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
+
+ppr_phase :: Maybe Int -> SDoc
+ppr_phase Nothing  = empty
 ppr_phase (Just n) = int n
 \end{code}