[project @ 1999-01-15 14:06:50 by simonm]

[ghc-hetmet.git] / ghc / compiler / basicTypes / Demand.lhs

diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs
index bd9c7c3..f034216 100644 (file)
--- a/ghc/compiler/basicTypes/Demand.lhs
+++ b/ghc/compiler/basicTypes/Demand.lhs
@@ -1,24 +1,22 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[Demand]{@Demand@: the amount of demand on a value}
 
 \begin{code}
-#include "HsVersions.h"
-
 module Demand(
        Demand(..),
 
        wwLazy, wwStrict, wwUnpackData, wwUnpackNew, wwPrim, wwEnum, 
-       isStrict,
+       isStrict, isLazy, 
 
-       showDemands
+       pprDemands
      ) where
 
+#include "HsVersions.h"
+
 import BasicTypes      ( NewOrData(..) )
 import Outputable
-import Pretty          ( Doc, text )
-import Util            ( panic )
 \end{code}
 
 
@@ -76,13 +74,18 @@ wwEnum          = WwEnum
 
 \begin{code}
 isStrict :: Demand -> Bool
-
-isStrict WwStrict      = True
-isStrict (WwUnpack DataType _ _) = True
 isStrict (WwUnpack NewType _ ds) = isStrict (head ds)
-isStrict WwPrim                = True
-isStrict WwEnum                = True
-isStrict _             = False
+isStrict (WwUnpack other _ _)    = True
+isStrict WwStrict = True
+isStrict WwEnum          = True
+isStrict WwPrim          = True
+isStrict _       = False
+\end{code}
+
+\begin{code}
+isLazy :: Demand -> Bool
+isLazy (WwLazy False) = True   -- NB "Absent" args do *not* count!
+isLazy _             = False   -- (as they imply a worker)
 \end{code}
 
 
@@ -92,27 +95,59 @@ isStrict _          = False
 %*                                                                     *
 %************************************************************************
 
+
 \begin{code}
-showDemands :: [Demand] -> String
-showDemands wrap_args = show_demands wrap_args ""
+pprDemands demands bot = hcat (map pprDemand demands) <> pp_bot
+                      where
+                        pp_bot | bot       = ptext SLIT("B")
+                               | otherwise = empty
+
+
+pprDemand (WwLazy False)        = char 'L'
+pprDemand (WwLazy True)         = char 'A'
+pprDemand WwStrict              = char 'S'
+pprDemand WwPrim                = char 'P'
+pprDemand WwEnum                = char 'E'
+pprDemand (WwUnpack nd wu args)  = char ch <> parens (hcat (map pprDemand args))
+                                     where
+                                       ch = case nd of
+                                               DataType | wu        -> 'U'
+                                                        | otherwise -> 'u'
+                                               NewType  | wu        -> 'N'
+                                                        | otherwise -> 'n'
+
+instance Outputable Demand where
+    ppr (WwLazy False) = empty
+    ppr other_demand   = ptext SLIT("__D") <+> pprDemand other_demand
+
+instance Show Demand where
+    showsPrec p d = showsPrecSDoc p (ppr d)
+\end{code}
 
 
+\begin{code}
+{-     ------------------- OMITTED NOW -------------------------------
+       -- Reading demands is done in Lex.lhs
+       -- Also note that the (old) code here doesn't take proper
+       -- account of the 'B' suffix for bottoming functions
+
 #ifdef REALLY_HASKELL_1_3
 
 instance Read Demand where
     readList str = read_em [] str
+
 instance Show Demand where
-    showsPrec prec wrap rest = show_demand wrap rest
-    showList wrap_args rest  = show_demands wrap_args rest
+    showsPrec p d = showsPrecSDoc p (ppr d)
 
 #else
 
 instance Text Demand where
-    readList str = read_em [] str
-    showList wrap_args rest = show_demands wrap_args rest
-
+    readList str  = read_em [] str
+    showsPrec p d = showsPrecSDoc p (ppr d)
 #endif
 
+readDemands :: String -> 
+
 read_em acc ('L' : xs) = read_em (WwLazy   False : acc) xs
 read_em acc ('A' : xs) = read_em (WwLazy   True  : acc) xs
 read_em acc ('S' : xs) = read_em (WwStrict : acc) xs
@@ -128,24 +163,8 @@ read_em acc rest   = [(reverse acc, rest)]
 do_unpack new_or_data wrapper_unpacks acc xs
          = case (read_em [] xs) of
              [(stuff, rest)] -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
-             _ -> panic ("Demand.do_unpack:"++show acc++"::"++xs)
-
-show_demands wrap_args rest
-  = foldr show_demand rest wrap_args
+             _ -> pprPanic "Demand.do_unpack:" (ppr acc <+> dcolon <> text xs)
 
-show_demand (WwLazy False)       rest = 'L' : rest
-show_demand (WwLazy True)        rest = 'A' : rest
-show_demand WwStrict             rest = 'S' : rest
-show_demand WwPrim               rest = 'P' : rest
-show_demand WwEnum               rest = 'E' : rest
-show_demand (WwUnpack nd wu args) rest = ch:'(':showList args (')' : rest)
-                                     where
-                                       ch = case nd of
-                                               DataType | wu        -> 'U'
-                                                        | otherwise -> 'u'
-                                               NewType  | wu        -> 'N'
-                                                        | otherwise -> 'n'
-
-instance Outputable Demand where
-    ppr sty si = text (showList [si] "")
+-------------------- END OF OMISSION ------------------------------  -}
 \end{code}
+