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