Text/Printf.hs

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