From 62b33ad9cff84d38b8debee1600dcb465f696afa Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 14 Dec 2004 12:37:28 +0000 Subject: [PATCH] [project @ 2004-12-14 12:37:28 by simonmar] Add Lennart's Printf module, extended by me to include hPrintf. --- Text/Printf.hs | 275 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 275 insertions(+) create mode 100644 Text/Printf.hs diff --git a/Text/Printf.hs b/Text/Printf.hs new file mode 100644 index 0000000..ec370f7 --- /dev/null +++ b/Text/Printf.hs @@ -0,0 +1,275 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Printf +-- Copyright : (c) Lennart Augustsson, 2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : lennart@augustsson.net +-- Stability : provisional +-- Portability : portable +-- +-- A C printf like formatter. +-- +----------------------------------------------------------------------------- + +module Text.Printf(printf, hPrintf) where +import Data.Array +import Data.Char +import Numeric(showEFloat, showFFloat, showGFloat) +import System.IO + +------------------- + +-- | Format a variable number of arguments with the C-style formatting string. +-- The return value is either 'String' or @(IO a)@. +-- +-- The format string consists of ordinary characters and /conversion +-- specifications/, which specify how to format one of the arguments +-- to printf in the output string. A conversion specification begins with the +-- character @%@, followed by one or more of the following flags: +-- +-- > - left adjust (default is right adjust) +-- > 0 pad with zeroes rather than spaces +-- +-- followed optionally by a field width: +-- +-- > num field width +-- > * as num, but taken from argument list +-- +-- followed optionally by a precision: +-- +-- > .num precision (number of decimal places) +-- +-- and finally, a format character: +-- +-- > c character Char, Int, Integer +-- > d decimal Char, Int, Integer +-- > o octal Char, Int, Integer +-- > x hexadecimal Char, Int, Integer +-- > u unsigned decimal Char, Int, Integer +-- > f floating point Float, Double +-- > g general format float Float, Double +-- > e exponent format float Float, Double +-- > s string String +-- +-- The @PrintfType@ class provides the variable argument magic for +-- 'printf'. Its implementation is intentionally not visible from +-- this module. The following argument types are supported: Char, String, +-- Int, Integer, Float, Double. If you attempt to pass an argument of a +-- different type to 'printf', then the compiler will report it as a +-- missing instance of @PrintfArg@. +-- +-- Mismatch between the argument types and the format string will cause +-- an exception to be thrown at runtime. +-- +-- Examples: +-- +-- > > printf "%d\n" (23::Int) +-- > 23 +-- > > printf "%s %s\n" "Hello" "World" +-- > Hello World +-- > > printf "%.2f\n" pi +-- > 3.14 +-- +printf :: (PrintfType r) => String -> r +printf fmt = spr fmt [] + +-- | Similar to 'printf', except that output is via the specified +-- 'Handle'. The return type is restricted to @(IO a)@. +hPrintf :: (HPrintfType r) => Handle -> String -> r +hPrintf hdl fmt = hspr hdl fmt [] + +class PrintfType t where + spr :: String -> [UPrintf] -> t + +-- | The @HPrintfType@ class provides the variable argument magic for +-- 'hPrintf'. Its implementation is intentionally not visible from +-- this module. +class HPrintfType t where + hspr :: Handle -> String -> [UPrintf] -> t + +{- not allowed in Haskell 98 +instance PrintfType String where + spr fmt args = uprintf fmt (reverse args) +-} +instance (IsChar c) => PrintfType [c] where + spr fmt args = map fromChar (uprintf fmt (reverse args)) + +instance PrintfType (IO a) where + spr fmt args = do + putStr (uprintf fmt (reverse args)) + return undefined + +instance HPrintfType (IO a) where + hspr hdl fmt args = do + hPutStr hdl (uprintf fmt (reverse args)) + return undefined + +instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where + spr fmt args = \ a -> spr fmt (toUPrintf a : args) + +instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where + hspr hdl fmt args = \ a -> hspr hdl fmt (toUPrintf a : args) + +class PrintfArg a where + toUPrintf :: a -> UPrintf + +instance PrintfArg Char where + toUPrintf c = UChar c + +{- not allowed in Haskell 98 +instance PrintfArg String where + toUPrintf s = UString s +-} +instance (IsChar c) => PrintfArg [c] where + toUPrintf s = UString (map toChar s) + +instance PrintfArg Int where + toUPrintf i = UInt i + +instance PrintfArg Integer where + toUPrintf i = UInteger i + +instance PrintfArg Float where + toUPrintf f = UFloat f + +instance PrintfArg Double where + toUPrintf d = UDouble d + +class IsChar c where + toChar :: c -> Char + fromChar :: Char -> c + +instance IsChar Char where + toChar c = c + fromChar c = c + +------------------- + +data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double + +uprintf :: String -> [UPrintf] -> String +uprintf "" [] = "" +uprintf "" (_:_) = fmterr +uprintf ('%':'%':cs) us = '%':uprintf cs us +uprintf ('%':_) [] = argerr +uprintf ('%':cs) us@(_:_) = fmt cs us +uprintf (c:cs) us = c:uprintf cs us + +fmt :: String -> [UPrintf] -> String +fmt cs us = + let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us + adjust (pre, str) = + let lstr = length str + lpre = length pre + fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else "" + in if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str + in + case cs' of + [] -> fmterr + c:cs'' -> + case us' of + [] -> argerr + u:us'' -> + (case c of + 'c' -> adjust ("", [toEnum (toint u)]) + 'd' -> adjust (fmti u) + 'x' -> adjust ("", fmtu 16 u) + 'o' -> adjust ("", fmtu 8 u) + 'u' -> adjust ("", fmtu 10 u) + 'e' -> adjust (dfmt' c prec u) + 'f' -> adjust (dfmt' c prec u) + 'g' -> adjust (dfmt' c prec u) + 's' -> adjust ("", tostr u) + c -> perror ("bad formatting char " ++ [c]) + ) ++ uprintf cs'' us'' + +fmti (UInt i) = if i < 0 then + if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i)) + else + ("", itos i) +fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i) +fmti (UChar c) = fmti (UInt (fromEnum c)) +fmti u = baderr + +fmtu b (UInt i) = if i < 0 then + if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i)) + else + itosb b (toInteger i) +fmtu b (UInteger i) = itosb b i +fmtu b (UChar c) = itosb b (toInteger (fromEnum c)) +fmtu b u = baderr + +maxi :: Integer +maxi = (toInteger (maxBound::Int) + 1) * 2 + +toint (UInt i) = i +toint (UInteger i) = toInt i +toint (UChar c) = fromEnum c +toint u = baderr + +tostr (UString s) = s +tostr u = baderr + +itos n = + if n < 10 then + [toEnum (fromEnum '0' + toInt n)] + else + let (q, r) = quotRem n 10 in + itos q ++ [toEnum (fromEnum '0' + toInt r)] + +chars = array (0,15) (zipWith (,) [0..] "0123456789abcdef") +itosb :: Integer -> Integer -> String +itosb b n = + if n < b then + [chars!n] + else + let (q, r) = quotRem n b in + itosb b q ++ [chars!r] + +stoi :: Int -> String -> (Int, String) +stoi a (c:cs) | isDigit c = stoi (a*10 + fromEnum c - fromEnum '0') cs +stoi a cs = (a, cs) + +getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf]) +getSpecs l z ('-':cs) us = getSpecs True z cs us +getSpecs l z ('0':cs) us = getSpecs l True cs us +getSpecs l z ('*':cs) us = + case us of + [] -> argerr + nu : us' -> + let n = toint nu + (p, cs'', us'') = + case cs of + '.':'*':r -> case us' of { [] -> argerr; pu:us'' -> (toint pu, r, us'') } + '.':r -> let (n, cs') = stoi 0 r in (n, cs', us') + _ -> (-1, cs, us') + in (n, p, l, z, cs'', us'') +getSpecs l z ('.':cs) us = + let (p, cs') = stoi 0 cs + in (0, p, l, z, cs', us) +getSpecs l z cs@(c:_) us | isDigit c = + let (n, cs') = stoi 0 cs + (p, cs'') = case cs' of + '.':r -> stoi 0 r + _ -> (-1, cs') + in (n, p, l, z, cs'', us) +getSpecs l z cs us = (0, -1, l, z, cs, us) + +dfmt' c p (UDouble d) = dfmt c p d +dfmt' c p (UFloat f) = dfmt c p f +dfmt' c p u = baderr + +dfmt c p d = + case (case c of 'e' -> showEFloat; 'f' -> showFFloat; 'g' -> showGFloat) + (if p < 0 then Nothing else Just p) d "" of + '-':cs -> ("-", cs) + cs -> ("" , cs) + +perror s = error ("Printf.printf: "++s) +fmterr = perror "formatting string ended prematurely" +argerr = perror "argument list ended prematurely" +baderr = perror "bad argument" + +toInt :: (Integral a) => a -> Int +toInt x = fromInteger (toInteger x) -- 1.7.10.4