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