ghc/lib/misc/Printf.lhs

   1
   2  A C printf like formatter.
   3  Conversion specs:
   4         -       left adjust
   5         num     field width
   6       *       as num, but taken from argument list
   7         .       separates width from precision
   8  Formatting characters:
   9         c       Char, Int, Integer
  10         d       Char, Int, Integer
  11         o       Char, Int, Integer
  12         x       Char, Int, Integer
  13         u       Char, Int, Integer
  14         f       Float, Double
  15         g       Float, Double
  16         e       Float, Double
  17         s       String
  18
  19 \begin{code}
  20 module Printf(UPrintf(..), printf) where
  21
  22 import Char     ( isDigit )    -- 1.3
  23 import Array    ( array, (!) ) -- 1.3
  24
  25
  26 #if defined(__HBC__)
  27 import LMLfmtf
  28 #endif
  29
  30 #if defined(__YALE_HASKELL__)
  31 import PrintfPrims
  32 #endif
  33
  34 #if defined(__GLASGOW_HASKELL__)
  35 import GlaExts
  36 import PrelArr (Array(..), ByteArray(..))
  37 import PrelBase hiding (itos)
  38 #endif
  39
  40 data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double
  41
  42 printf :: String -> [UPrintf] -> String
  43 printf ""       []       = ""
  44 printf ""       (_:_)    = fmterr
  45 printf ('%':'%':cs) us   = '%':printf cs us
  46 printf ('%':_)  []       = argerr
  47 printf ('%':cs) us@(_:_) = fmt cs us
  48 printf (c:cs)   us       = c:printf cs us
  49
  50 fmt :: String -> [UPrintf] -> String
  51 fmt cs us =
  52         let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us
  53             adjust (pre, str) =
  54                 let lstr = length str
  55                     lpre = length pre
  56                     fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
  57                 in  if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str
  58         in
  59         case cs' of
  60         []     -> fmterr
  61         c:cs'' ->
  62             case us' of
  63             []     -> argerr
  64             u:us'' ->
  65                 (case c of
  66                 'c' -> adjust ("", [chr (toint u)])
  67                 'd' -> adjust (fmti u)
  68                 'x' -> adjust ("", fmtu 16 u)
  69                 'o' -> adjust ("", fmtu 8  u)
  70                 'u' -> adjust ("", fmtu 10 u)
  71 #if defined __YALE_HASKELL__
  72                 'e' -> adjust (fmte prec (todbl u))
  73                 'f' -> adjust (fmtf prec (todbl u))
  74                 'g' -> adjust (fmtg prec (todbl u))
  75 #else
  76                 'e' -> adjust (dfmt c prec (todbl u))
  77                 'f' -> adjust (dfmt c prec (todbl u))
  78                 'g' -> adjust (dfmt c prec (todbl u))
  79 #endif
  80                 's' -> adjust ("", tostr u)
  81                 c   -> perror ("bad formatting char " ++ [c])
  82                 ) ++ printf cs'' us''
  83
  84 fmti (UInt i)     = if i < 0 then
  85                         if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))
  86                     else
  87                         ("", itos i)
  88 fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)
  89 fmti (UChar c)    = fmti (UInt (ord c))
  90 fmti u            = baderr
  91
  92 fmtu b (UInt i)     = if i < 0 then
  93                           if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))
  94                       else
  95                           itosb b (toInteger i)
  96 fmtu b (UInteger i) = itosb b i
  97 fmtu b (UChar c)    = itosb b (toInteger (ord c))
  98 fmtu b u            = baderr
  99
 100 maxi :: Integer
 101 maxi = (toInteger (maxBound::Int) + 1) * 2
 102
 103 toint (UInt i)     = i
 104 toint (UInteger i) = toInt i
 105 toint (UChar c)    = ord c
 106 toint u            = baderr
 107
 108 tostr (UString s) = s
 109 tostr u           = baderr
 110
 111 todbl (UDouble d)     = d
 112 #if defined(__GLASGOW_HASKELL__)
 113 todbl (UFloat (F# f)) = D# (float2Double# f) -- What a great system(TM) !
 114 #else
 115 todbl (UFloat f)      = fromRational (toRational f)
 116 #endif
 117 todbl u               = baderr
 118
 119 itos n =
 120         if n < 10 then
 121             [chr (ord '0' + toInt n)]
 122         else
 123             let (q, r) = quotRem n 10 in
 124             itos q ++ [chr (ord '0' + toInt r)]
 125
 126 chars :: Array Int Char
 127 chars = array (0,15) (zipWith (\x y -> (x,y)) [0..] "0123456789abcdef")
 128
 129 itosb :: Integer -> Integer -> String
 130 itosb b n =
 131         if n < b then
 132             [chars ! fromInteger n]
 133         else
 134             let (q, r) = quotRem n b in
 135             itosb b q ++ [chars ! fromInteger r]
 136
 137 stoi :: Int -> String -> (Int, String)
 138 stoi a (c:cs) | isDigit c = stoi (a*10 + ord c - ord '0') cs
 139 stoi a cs                 = (a, cs)
 140
 141 getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])
 142 getSpecs l z ('-':cs) us = getSpecs True z cs us
 143 getSpecs l z ('0':cs) us = getSpecs l True cs us
 144 getSpecs l z ('*':cs) us =
 145         case us of
 146         [] -> argerr
 147         nu : us' ->
 148             let n = toint nu
 149                 (p, cs'', us'') =
 150                     case cs of
 151                     '.':'*':r -> case us' of { [] -> argerr; pu:us'' -> (toint pu, r, us'') }
 152                     '.':r     -> let (n, cs') = stoi 0 r in (n, cs', us')
 153                     _         -> (-1, cs, us')
 154             in  (n, p, l, z, cs'', us'')
 155 getSpecs l z cs@(c:_) us | isDigit c =
 156         let (n, cs') = stoi 0 cs
 157             (p, cs'') = case cs' of
 158                         '.':r -> stoi 0 r
 159                         _     -> (-1, cs')
 160         in  (n, p, l, z, cs'', us)
 161 getSpecs l z cs       us = (0, -1, l, z, cs, us)
 162
 163 #if !defined(__YALE_HASKELL__)
 164 dfmt :: Char -> Int -> Double -> (String, String)
 165 #endif
 166
 167 #if defined(__GLASGOW_HASKELL__)
 168 dfmt c{-e,f, or g-} prec d
 169   = unsafePerformIO (
 170         stToIO (newCharArray (0 :: Int, 511)){-pathetic malloc-}
 171                                                    >>= \ sprintf_here ->
 172         let
 173             sprintf_fmt  = "%1" ++ (if prec < 0 then "" else '.':itos prec) ++ [c]
 174         in
 175         _ccall_ sprintf sprintf_here sprintf_fmt d >>
 176         stToIO (freezeCharArray sprintf_here)      >>= \ (ByteArray _ arr#) ->
 177         let
 178             unpack :: Int# -> [Char]
 179             unpack nh = case (ord# (indexCharArray# arr# nh)) of
 180                         0# -> []
 181                         ch -> case (nh +# 1#) of
 182                               mh -> C# (chr# ch) : unpack mh
 183         in
 184         return (
 185         case (indexCharArray# arr# 0#) of
 186           '-'# -> ("-", unpack 1#)
 187           _    -> ("" , unpack 0#)
 188         )
 189     )
 190 #endif
 191
 192 #if defined(__HBC__)
 193 dfmt c p d =
 194         case fmtf ("1" ++ (if p < 0 then "" else '.':itos p) ++ [c]) d of
 195         '-':cs -> ("-", cs)
 196         cs     -> ("" , cs)
 197 #endif
 198
 199 #if defined(__YALE_HASKELL__)
 200 fmte p d =
 201   case (primFmte p d) of
 202     '-':cs -> ("-",cs)
 203     cs     -> ("",cs)
 204 fmtf p d =
 205   case (primFmtf p d) of
 206     '-':cs -> ("-",cs)
 207     cs     -> ("",cs)
 208 fmtg p d =
 209   case (primFmtg p d) of
 210     '-':cs -> ("-",cs)
 211     cs     -> ("",cs)
 212 #endif
 213
 214 perror s = error ("Printf.printf: "++s)
 215 fmterr = perror "formatting string ended prematurely"
 216 argerr = perror "argument list ended prematurely"
 217 baderr = perror "bad argument"
 218
 219 #if defined(__YALE_HASKELL__)
 220 -- This is needed because standard Haskell does not have toInt
 221
 222 toInt :: Integral a => a -> Int
 223 toInt x = fromIntegral x
 224 #endif
 225 \end{code}