--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+\section[Pretty]{Pretty-printing data type}
+
+\begin{code}
+#if defined(COMPILING_GHC)
+# include "HsVersions.h"
+#else
+# define FAST_STRING String
+# define _LENGTH_ length
+#endif
+
+module Pretty (
+ Pretty(..),
+
+#if defined(COMPILING_GHC)
+ PprStyle(..),
+ prettyToUn,
+ codeStyle, -- UNUSED: stySwitch,
+#endif
+ ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger,
+ ppFloat, ppDouble,
+#if __GLASGOW_HASKELL__ >= 23
+ -- may be able to *replace* ppDouble
+ ppRational,
+#endif
+ ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen,
+ ppSemi, ppComma, ppEquals,
+
+ ppCat, ppBeside, ppBesides, ppAbove, ppAboves,
+ ppNest, ppSep, ppHang, ppInterleave, ppIntersperse,
+ ppShow,
+#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+ ppAppendFile,
+#endif
+
+ -- abstract type, to complete the interface...
+ PrettyRep(..), CSeq, Delay
+#if defined(COMPILING_GHC)
+ , GlobalSwitch, Unpretty(..)
+#endif
+ ) where
+
+import CharSeq
+#if defined(COMPILING_GHC)
+import Unpretty ( Unpretty(..) )
+import CmdLineOpts ( GlobalSwitch )
+#endif
+\end{code}
+
+Based on John Hughes's pretty-printing library. For now, that code
+and notes for it are in files \tr{pp-rjmh*} (ToDo: rm).
+
+%************************************************
+%* *
+ \subsection{The interface}
+%* *
+%************************************************
+
+\begin{code}
+ppNil :: Pretty
+ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals :: Pretty
+
+ppStr :: [Char] -> Pretty
+ppPStr :: FAST_STRING -> Pretty
+ppChar :: Char -> Pretty
+ppInt :: Int -> Pretty
+ppInteger :: Integer -> Pretty
+ppDouble :: Double -> Pretty
+ppFloat :: Float -> Pretty
+#if __GLASGOW_HASKELL__ >= 23
+ppRational :: Rational -> Pretty
+#endif
+
+ppBeside :: Pretty -> Pretty -> Pretty
+ppBesides :: [Pretty] -> Pretty
+ppBesideSP :: Pretty -> Pretty -> Pretty
+ppCat :: [Pretty] -> Pretty -- i.e., ppBesidesSP
+
+ppAbove :: Pretty -> Pretty -> Pretty
+ppAboves :: [Pretty] -> Pretty
+
+ppInterleave :: Pretty -> [Pretty] -> Pretty
+ppIntersperse :: Pretty -> [Pretty] -> Pretty -- no spaces between, no ppSep
+ppSep :: [Pretty] -> Pretty
+ppHang :: Pretty -> Int -> Pretty -> Pretty
+ppNest :: Int -> Pretty -> Pretty
+
+ppShow :: Int -> Pretty -> [Char]
+
+#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+# if __GLASGOW_HASKELL__ < 23
+# define _FILE _Addr
+# endif
+ppAppendFile :: _FILE -> Int -> Pretty -> PrimIO ()
+#endif
+\end{code}
+
+%************************************************
+%* *
+ \subsection{The representation}
+%* *
+%************************************************
+
+\begin{code}
+type Pretty = Int -- The width to print in
+ -> Bool -- True => vertical context
+ -> PrettyRep
+
+data PrettyRep
+ = MkPrettyRep CSeq -- The text
+ (Delay Int) -- No of chars in last line
+ Bool -- True if empty object
+ Bool -- Fits on a single line in specified width
+
+data Delay a = MkDelay a
+
+forceDel (MkDelay _) r = r
+
+forceBool True r = r
+forceBool False r = r
+
+forceInfo ll emp sl r = forceDel ll (forceBool emp (forceBool sl r))
+
+ppShow width p
+ = case (p width False) of
+ MkPrettyRep seq ll emp sl -> cShow seq
+
+#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+ppAppendFile f width p
+ = case (p width False) of
+ MkPrettyRep seq ll emp sl -> cAppendFile f seq
+#endif
+
+ppNil width is_vert = MkPrettyRep cNil (MkDelay 0) True (width >= 0)
+ -- Doesn't fit if width < 0, otherwise, ppNil
+ -- will make ppBesides always return True.
+
+ppStr s width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
+ where ls = length s
+ppPStr s width is_vert = MkPrettyRep (cPStr s) (MkDelay ls) False (width >= ls)
+ where ls = _LENGTH_ s
+ppChar c width is_vert = MkPrettyRep (cCh c) (MkDelay 1) False (width >= 1)
+
+ppInt n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
+ where s = show n; ls = length s
+
+ppInteger n = ppStr (show n)
+ppDouble n = ppStr (show n)
+ppFloat n = ppStr (show n)
+#if __GLASGOW_HASKELL__ >= 23
+--ppRational n = ppStr (_showRational 30 n)
+ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n)
+#endif
+
+ppSP = ppChar ' '
+pp'SP = ppStr ", "
+ppLbrack = ppChar '['
+ppRbrack = ppChar ']'
+ppLparen = ppChar '('
+ppRparen = ppChar ')'
+ppSemi = ppChar ';'
+ppComma = ppChar ','
+ppEquals = ppChar '='
+
+ppInterleave sep ps = ppSep (pi ps)
+ where
+ pi [] = []
+ pi [x] = [x]
+ pi (x:xs) = (ppBeside x sep) : pi xs
+\end{code}
+
+ToDo: this could be better: main pt is: no extra spaces in between.
+
+\begin{code}
+ppIntersperse sep ps = ppBesides (pi ps)
+ where
+ pi [] = []
+ pi [x] = [x]
+ pi (x:xs) = (ppBeside x sep) : pi xs
+\end{code}
+
+Laziness is important in @ppBeside@. If the first thing is not a
+single line it will return @False@ for the single-line boolean without
+laying out the second.
+
+\begin{code}
+ppBeside p1 p2 width is_vert
+ = case (p1 width False) of
+ MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
+ MkPrettyRep (seq1 `cAppend` (cIndent ll1 seq2))
+ (MkDelay (ll1 + ll2))
+ (emp1 && emp2)
+ ((width >= 0) && (sl1 && sl2))
+ -- This sequence of (&&)'s ensures that ppBeside
+ -- returns a False for sl as soon as possible.
+ where -- NB: for case alt
+ seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
+ MkDelay ll2 = x_ll2
+ MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-ll1) False
+ -- ToDo: if emp{1,2} then we really
+ -- should be passing on "is_vert" to p{2,1}.
+
+ppBesides [] = ppNil
+ppBesides ps = foldr1 ppBeside ps
+\end{code}
+
+@ppBesideSP@ puts two things beside each other separated by a space.
+
+\begin{code}
+ppBesideSP p1 p2 width is_vert
+ = case (p1 width False) of
+ MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
+ MkPrettyRep (seq1 `cAppend` (sp `cAppend` (cIndent li seq2)))
+ (MkDelay (li + ll2))
+ (emp1 && emp2)
+ ((width >= wi) && (sl1 && sl2))
+ where -- NB: for case alt
+ seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
+ MkDelay ll2 = x_ll2
+ MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False
+ li, wi :: Int
+ li = if emp1 then 0 else ll1+1
+ wi = if emp1 then 0 else 1
+ sp = if emp1 || emp2 then cNil else (cCh ' ')
+\end{code}
+
+@ppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@.
+
+\begin{code}
+ppCat [] = ppNil
+ppCat ps = foldr1 ppBesideSP ps
+\end{code}
+
+\begin{code}
+ppAbove p1 p2 width is_vert
+ = case (p1 width True) of
+ MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
+ MkPrettyRep (seq1 `cAppend` (nl `cAppend` seq2))
+ (MkDelay ll2)
+ -- ToDo: make ll depend on empties?
+ (emp1 && emp2)
+ False
+ where -- NB: for case alt
+ nl = if emp1 || emp2 then cNil else cNL
+ seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
+ MkDelay ll2 = x_ll2 -- Don't "optimise" this away!
+ MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 width True
+ -- ToDo: ditto about passing is_vert if empties
+
+ppAboves [] = ppNil
+ppAboves ps = foldr1 ppAbove ps
+\end{code}
+
+\begin{code}
+ppNest n p width False = p width False
+ppNest n p width True
+ = case (p (width-n) True) of
+ MkPrettyRep seq (MkDelay ll) emp sl ->
+ MkPrettyRep (cIndent n seq) (MkDelay (ll+n)) emp sl
+\end{code}
+
+The length-check below \tr{(ll1+ll2+1) <= width} should really check for
+max widths not the width of the last line.
+
+\begin{code}
+ppHang p1 n p2 width is_vert -- This is a little bit stricter than it could
+ -- be made with a little more effort.
+ -- Eg the output always starts with seq1
+ = case (p1 width False) of
+ MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
+ if emp1 then
+ p2 width is_vert
+ else
+ if (ll1 <= n) || sl2 then -- very ppBesideSP'ish
+ -- Hang it if p1 shorter than indent or if it doesn't fit
+ MkPrettyRep (seq1 `cAppend` ((cCh ' ') `cAppend` (cIndent (ll1+1) seq2)))
+ (MkDelay (ll1 + 1 + ll2))
+ False
+ (sl1 && sl2)
+ else
+ -- Nest it (pretty ppAbove-ish)
+ MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2')))
+ (MkDelay ll2') -- ToDo: depend on empties
+ False
+ False
+ where -- NB: for case alt
+ seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
+ MkDelay ll2 = x_ll2
+ MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False
+ -- ToDo: more "is_vert if empty" stuff
+
+ seq2' = forceInfo x_ll2' emp2' sl2' x_seq2'
+ MkDelay ll2' = x_ll2' -- Don't "optimise" this away!
+ MkPrettyRep x_seq2' x_ll2' emp2' sl2' = p2 (width-n) False -- ToDo: True?
+\end{code}
+
+\begin{code}
+ppSep [] width is_vert = ppNil width is_vert
+ppSep [p] width is_vert = p width is_vert
+
+-- CURRENT, but BAD. Quadratic behaviour on the perfectly reasonable
+-- ppSep [a, ppSep[b, ppSep [c, ... ]]]
+
+ppSep ps width is_vert
+ = case (ppCat ps width is_vert) of
+ MkPrettyRep seq x_ll emp sl ->
+ if sl then -- Fits on one line
+ MkPrettyRep seq x_ll emp sl
+ else
+ ppAboves ps width is_vert -- Takes several lines
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Outputable-print]{Pretty-printing stuff}
+%* *
+%************************************************************************
+
+ToDo: this is here for no-original-name reasons (mv?).
+
+There is no clearly definitive list of @PprStyles@; I suggest the
+following:
+
+\begin{code}
+#if defined(COMPILING_GHC)
+ -- to the end of file
+
+data PprStyle
+ = PprForUser -- Pretty-print in a way that will
+ -- make sense to the ordinary user;
+ -- must be very close to Haskell
+ -- syntax, etc. ToDo: how diff is
+ -- this from what pprInterface must
+ -- do?
+ | PprDebug -- Standard debugging output
+ | PprShowAll -- Debugging output which leaves
+ -- nothing to the imagination
+ | PprInterface -- Interface generation
+ (GlobalSwitch -> Bool) -- (we can look at cmd-line flags)
+ | PprForC -- must print out C-acceptable names
+ (GlobalSwitch -> Bool) -- (ditto)
+ | PprUnfolding -- for non-interface intermodule info
+ (GlobalSwitch -> Bool) -- the compiler writes/reads
+ | PprForAsm -- must print out assembler-acceptable names
+ (GlobalSwitch -> Bool) -- (ditto)
+ Bool -- prefix CLabel with underscore?
+ (String -> String) -- format AsmTempLabel
+\end{code}
+
+The following test decides whether or not we are actually generating
+code (either C or assembly).
+\begin{code}
+codeStyle :: PprStyle -> Bool
+codeStyle (PprForC _) = True
+codeStyle (PprForAsm _ _ _) = True
+codeStyle _ = False
+
+{- UNUSED:
+stySwitch :: PprStyle -> GlobalSwitch -> Bool
+stySwitch (PprInterface sw) = sw
+stySwitch (PprForC sw) = sw
+stySwitch (PprForAsm sw _ _) = sw
+-}
+\end{code}
+
+Orthogonal to these printing styles are (possibly) some command-line
+flags that affect printing (often carried with the style). The most
+likely ones are variations on how much type info is shown.
+
+\begin{code}
+prettyToUn :: Pretty -> Unpretty
+
+prettyToUn p
+ = case (p 999999{-totally bogus width-} False{-also invented-}) of
+ MkPrettyRep seq ll emp sl -> seq
+
+#endif {-COMPILING_GHC-}
+\end{code}
+
+-----------------------------------
+\begin{code}
+-- from Lennart
+fromRationalX :: (RealFloat a) => Rational -> a
+
+fromRationalX r =
+ let
+ h = ceiling (huge `asTypeOf` x)
+ b = toInteger (floatRadix x)
+ x = fromRat 0 r
+ fromRat e0 r' =
+ let d = denominator r'
+ n = numerator r'
+ in if d > h then
+ let e = integerLogBase b (d `div` h) + 1
+ in fromRat (e0-e) (n % (d `div` (b^e)))
+ else if abs n > h then
+ let e = integerLogBase b (abs n `div` h) + 1
+ in fromRat (e0+e) ((n `div` (b^e)) % d)
+ else
+ scaleFloat e0 (fromRational r')
+ in x
+
+-- Compute the discrete log of i in base b.
+-- Simplest way would be just divide i by b until it's smaller then b, but that would
+-- be very slow! We are just slightly more clever.
+integerLogBase :: Integer -> Integer -> Int
+integerLogBase b i =
+ if i < b then
+ 0
+ else
+ -- Try squaring the base first to cut down the number of divisions.
+ let l = 2 * integerLogBase (b*b) i
+
+ doDiv :: Integer -> Int -> Int
+ doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
+ in
+ doDiv (i `div` (b^l)) l
+
+
+------------
+
+-- Compute smallest and largest floating point values.
+{-
+tiny :: (RealFloat a) => a
+tiny =
+ let (l, _) = floatRange x
+ x = encodeFloat 1 (l-1)
+ in x
+-}
+
+huge :: (RealFloat a) => a
+huge =
+ let (_, u) = floatRange x
+ d = floatDigits x
+ x = encodeFloat (floatRadix x ^ d - 1) (u - d)
+ in x
+\end{code}
projects / ghc-hetmet.git / blobdiff