Text/Printf.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Text.Printf
   4 -- Copyright   :  (c) Lennart Augustsson, 2004
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  lennart@augustsson.net
   8 -- Stability   :  provisional
   9 -- Portability :  portable
  10 --
  11 -- A C printf like formatter.
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Text.Printf(printf, hPrintf) where
  16
  17 import Prelude
  18 import Data.Array
  19 import Data.Char
  20 import Numeric(showEFloat, showFFloat, showGFloat)
  21 import System.IO
  22
  23 -------------------
  24
  25 -- | Format a variable number of arguments with the C-style formatting string.
  26 -- The return value is either 'String' or @(IO a)@.
  27 --
  28 -- The format string consists of ordinary characters and /conversion
  29 -- specifications/, which specify how to format one of the arguments
  30 -- to printf in the output string.  A conversion specification begins with the
  31 -- character @%@, followed by one or more of the following flags:
  32 --
  33 -- >    -      left adjust (default is right adjust)
  34 -- >    0      pad with zeroes rather than spaces
  35 --
  36 -- followed optionally by a field width:
  37 --
  38 -- >    num    field width
  39 -- >    *      as num, but taken from argument list
  40 --
  41 -- followed optionally by a precision:
  42 --
  43 -- >    .num   precision (number of decimal places)
  44 --
  45 -- and finally, a format character:
  46 --
  47 -- >    c      character               Char, Int, Integer
  48 -- >    d      decimal                 Char, Int, Integer
  49 -- >    o      octal                   Char, Int, Integer
  50 -- >    x      hexadecimal             Char, Int, Integer
  51 -- >    u      unsigned decimal        Char, Int, Integer
  52 -- >    f      floating point          Float, Double
  53 -- >    g      general format float    Float, Double
  54 -- >    e      exponent format float   Float, Double
  55 -- >    s      string                  String
  56 --
  57 -- The @PrintfType@ class provides the variable argument magic for
  58 -- 'printf'.  Its implementation is intentionally not visible from
  59 -- this module.  The following argument types are supported: Char, String,
  60 -- Int, Integer, Float, Double.  If you attempt to pass an argument of a
  61 -- different type to 'printf', then the compiler will report it as a
  62 -- missing instance of @PrintfArg@.
  63 --
  64 -- Mismatch between the argument types and the format string will cause
  65 -- an exception to be thrown at runtime.
  66 --
  67 -- Examples:
  68 --
  69 -- >   > printf "%d\n" (23::Int)
  70 -- >   23
  71 -- >   > printf "%s %s\n" "Hello" "World"
  72 -- >   Hello World
  73 -- >   > printf "%.2f\n" pi
  74 -- >   3.14
  75 --
  76 printf :: (PrintfType r) => String -> r
  77 printf fmt = spr fmt []
  78
  79 -- | Similar to 'printf', except that output is via the specified
  80 -- 'Handle'.  The return type is restricted to @(IO a)@.
  81 hPrintf :: (HPrintfType r) => Handle -> String -> r
  82 hPrintf hdl fmt = hspr hdl fmt []
  83
  84 class PrintfType t where
  85     spr :: String -> [UPrintf] -> t
  86
  87 -- | The @HPrintfType@ class provides the variable argument magic for
  88 -- 'hPrintf'.  Its implementation is intentionally not visible from
  89 -- this module.
  90 class HPrintfType t where
  91     hspr :: Handle -> String -> [UPrintf] -> t
  92
  93 {- not allowed in Haskell 98
  94 instance PrintfType String where
  95     spr fmt args = uprintf fmt (reverse args)
  96 -}
  97 instance (IsChar c) => PrintfType [c] where
  98     spr fmt args = map fromChar (uprintf fmt (reverse args))
  99
 100 instance PrintfType (IO a) where
 101     spr fmt args = do
 102         putStr (uprintf fmt (reverse args))
 103         return undefined
 104
 105 instance HPrintfType (IO a) where
 106     hspr hdl fmt args = do
 107         hPutStr hdl (uprintf fmt (reverse args))
 108         return undefined
 109
 110 instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
 111     spr fmt args = \ a -> spr fmt (toUPrintf a : args)
 112
 113 instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
 114     hspr hdl fmt args = \ a -> hspr hdl fmt (toUPrintf a : args)
 115
 116 class PrintfArg a where
 117     toUPrintf :: a -> UPrintf
 118
 119 instance PrintfArg Char where
 120     toUPrintf c = UChar c
 121
 122 {- not allowed in Haskell 98
 123 instance PrintfArg String where
 124     toUPrintf s = UString s
 125 -}
 126 instance (IsChar c) => PrintfArg [c] where
 127     toUPrintf s = UString (map toChar s)
 128
 129 instance PrintfArg Int where
 130     toUPrintf i = UInt i
 131
 132 instance PrintfArg Integer where
 133     toUPrintf i = UInteger i
 134
 135 instance PrintfArg Float where
 136     toUPrintf f = UFloat f
 137
 138 instance PrintfArg Double where
 139     toUPrintf d = UDouble d
 140
 141 class IsChar c where
 142     toChar :: c -> Char
 143     fromChar :: Char -> c
 144
 145 instance IsChar Char where
 146     toChar c = c
 147     fromChar c = c
 148
 149 -------------------
 150
 151 data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double
 152
 153 uprintf :: String -> [UPrintf] -> String
 154 uprintf ""       []       = ""
 155 uprintf ""       (_:_)    = fmterr
 156 uprintf ('%':'%':cs) us   = '%':uprintf cs us
 157 uprintf ('%':_)  []       = argerr
 158 uprintf ('%':cs) us@(_:_) = fmt cs us
 159 uprintf (c:cs)   us       = c:uprintf cs us
 160
 161 fmt :: String -> [UPrintf] -> String
 162 fmt cs us =
 163         let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us
 164             adjust (pre, str) =
 165                 let lstr = length str
 166                     lpre = length pre
 167                     fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
 168                 in  if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str
 169         in
 170         case cs' of
 171         []     -> fmterr
 172         c:cs'' ->
 173             case us' of
 174             []     -> argerr
 175             u:us'' ->
 176                 (case c of
 177                 'c' -> adjust ("", [toEnum (toint u)])
 178                 'd' -> adjust (fmti u)
 179                 'x' -> adjust ("", fmtu 16 u)
 180                 'o' -> adjust ("", fmtu 8  u)
 181                 'u' -> adjust ("", fmtu 10 u)
 182                 'e' -> adjust (dfmt' c prec u)
 183                 'f' -> adjust (dfmt' c prec u)
 184                 'g' -> adjust (dfmt' c prec u)
 185                 's' -> adjust ("", tostr u)
 186                 c   -> perror ("bad formatting char " ++ [c])
 187                  ) ++ uprintf cs'' us''
 188
 189 fmti (UInt i)     = if i < 0 then
 190                         if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))
 191                     else
 192                         ("", itos i)
 193 fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)
 194 fmti (UChar c)    = fmti (UInt (fromEnum c))
 195 fmti u            = baderr
 196
 197 fmtu b (UInt i)     = if i < 0 then
 198                           if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))
 199                       else
 200                           itosb b (toInteger i)
 201 fmtu b (UInteger i) = itosb b i
 202 fmtu b (UChar c)    = itosb b (toInteger (fromEnum c))
 203 fmtu b u            = baderr
 204
 205 maxi :: Integer
 206 maxi = (toInteger (maxBound::Int) + 1) * 2
 207
 208 toint (UInt i)     = i
 209 toint (UInteger i) = toInt i
 210 toint (UChar c)    = fromEnum c
 211 toint u            = baderr
 212
 213 tostr (UString s) = s
 214 tostr u           = baderr
 215
 216 itos n =
 217         if n < 10 then
 218             [toEnum (fromEnum '0' + toInt n)]
 219         else
 220             let (q, r) = quotRem n 10 in
 221             itos q ++ [toEnum (fromEnum '0' + toInt r)]
 222
 223 chars = array (0,15) (zipWith (,) [0..] "0123456789abcdef")
 224 itosb :: Integer -> Integer -> String
 225 itosb b n =
 226         if n < b then
 227             [chars!n]
 228         else
 229             let (q, r) = quotRem n b in
 230             itosb b q ++ [chars!r]
 231
 232 stoi :: Int -> String -> (Int, String)
 233 stoi a (c:cs) | isDigit c = stoi (a*10 + fromEnum c - fromEnum '0') cs
 234 stoi a cs                 = (a, cs)
 235
 236 getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])
 237 getSpecs l z ('-':cs) us = getSpecs True z cs us
 238 getSpecs l z ('0':cs) us = getSpecs l True cs us
 239 getSpecs l z ('*':cs) us =
 240         case us of
 241         [] -> argerr
 242         nu : us' ->
 243             let n = toint nu
 244                 (p, cs'', us'') =
 245                     case cs of
 246                     '.':'*':r -> case us' of { [] -> argerr; pu:us'' -> (toint pu, r, us'') }
 247                     '.':r     -> let (n, cs') = stoi 0 r in (n, cs', us')
 248                     _         -> (-1, cs, us')
 249             in  (n, p, l, z, cs'', us'')
 250 getSpecs l z ('.':cs) us =
 251         let (p, cs') = stoi 0 cs
 252         in  (0, p, l, z, cs', us)
 253 getSpecs l z cs@(c:_) us | isDigit c =
 254         let (n, cs') = stoi 0 cs
 255             (p, cs'') = case cs' of
 256                         '.':r -> stoi 0 r
 257                         _     -> (-1, cs')
 258         in  (n, p, l, z, cs'', us)
 259 getSpecs l z cs       us = (0, -1, l, z, cs, us)
 260
 261 dfmt' c p (UDouble d) = dfmt c p d
 262 dfmt' c p (UFloat f)  = dfmt c p f
 263 dfmt' c p u           = baderr
 264
 265 dfmt c p d =
 266         case (case c of 'e' -> showEFloat; 'f' -> showFFloat; 'g' -> showGFloat)
 267                (if p < 0 then Nothing else Just p) d "" of
 268         '-':cs -> ("-", cs)
 269         cs     -> ("" , cs)
 270
 271 perror s = error ("Printf.printf: "++s)
 272 fmterr = perror "formatting string ended prematurely"
 273 argerr = perror "argument list ended prematurely"
 274 baderr = perror "bad argument"
 275
 276 toInt :: (Integral a) => a -> Int
 277 toInt x = fromInteger (toInteger x)