ghc/lib/hbc/Printf.hs

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