Text/Printf.hs

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