    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Text.Printf
    -- Copyright   :  (c) Lennart Augustsson, 2004-2008
    -- License     :  BSD-style (see the file libraries/base/LICENSE)
    --
    -- Maintainer  :  lennart@augustsson.net
    -- Stability   :  provisional
    -- Portability :  portable
    --
    -- A C printf like formatter.
    --
    -----------------------------------------------------------------------------

    {-# Language CPP #-}

    module Text.Printf(
       printf, hPrintf,
       PrintfType, HPrintfType, PrintfArg, IsChar
    ) where

    import Prelude
    import Data.Char
    import Data.Int
    import Data.Word
    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)
    -- >    +      always use a sign (+ or -) for signed conversions
    -- >    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, ...
    -- >    X      hexadecimal             Char, Int, Integer, ...
    -- >    u      unsigned decimal        Char, Int, Integer, ...
    -- >    f      floating point          Float, Double
    -- >    g      general format float    Float, Double
    -- >    G      general format float    Float, Double
    -- >    e      exponent format float   Float, Double
    -- >    E      exponent format float   Float, Double
    -- >    s      string                  String
    --
    -- 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 fmts = spr fmts []

    -- | 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 fmts = hspr hdl fmts []

    -- |The 'PrintfType' class provides the variable argument magic for
    -- 'printf'.  Its implementation is intentionally not visible from
    -- this module. If you attempt to pass an argument of a type which
    -- is not an instance of this class to 'printf' or 'hPrintf', then
    -- the compiler will report it as a missing instance of 'PrintfArg'.
    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 fmts args = map fromChar (uprintf fmts (reverse args))

    instance PrintfType (IO a) where
        spr fmts args = do
    	putStr (uprintf fmts (reverse args))
    	return undefined

    instance HPrintfType (IO a) where
        hspr hdl fmts args = do
    	hPutStr hdl (uprintf fmts (reverse args))
    	return undefined

    instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
        spr fmts args = \ a -> spr fmts (toUPrintf a : args)

    instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
        hspr hdl fmts args = \ a -> hspr hdl fmts (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 = UString . map toChar

    instance PrintfArg Int where
        toUPrintf = uInteger

    instance PrintfArg Int8 where
        toUPrintf = uInteger

    instance PrintfArg Int16 where
        toUPrintf = uInteger

    instance PrintfArg Int32 where
        toUPrintf = uInteger

    instance PrintfArg Int64 where
        toUPrintf = uInteger

    #ifndef __NHC__
    instance PrintfArg Word where
        toUPrintf = uInteger
    #endif

    instance PrintfArg Word8 where
        toUPrintf = uInteger

    instance PrintfArg Word16 where
        toUPrintf = uInteger

    instance PrintfArg Word32 where
        toUPrintf = uInteger

    instance PrintfArg Word64 where
        toUPrintf = uInteger

    instance PrintfArg Integer where
        toUPrintf = UInteger 0

    instance PrintfArg Float where
        toUPrintf = UFloat

    instance PrintfArg Double where
        toUPrintf = UDouble

    uInteger :: (Integral a, Bounded a) => a -> UPrintf
    uInteger x = UInteger (toInteger $ minBound `asTypeOf` x) (toInteger x)

    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 | UInteger Integer 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, plus, cs', us') = getSpecs False 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
                adjust' ("", str) | plus = adjust ("+", str)
                adjust' ps = adjust ps
            in
    	case cs' of
    	[]     -> fmterr
    	c:cs'' ->
    	    case us' of
    	    []     -> argerr
    	    u:us'' ->
    		(case c of
    		'c' -> adjust  ("", [toEnum (toint u)])
    		'd' -> adjust' (fmti prec u)
    		'i' -> adjust' (fmti prec u)
    		'x' -> adjust  ("", fmtu 16 prec u)
    		'X' -> adjust  ("", map toUpper $ fmtu 16 prec u)
    		'o' -> adjust  ("", fmtu 8  prec u)
    		'u' -> adjust  ("", fmtu 10 prec u)
    		'e' -> adjust' (dfmt' c prec u)
    		'E' -> adjust' (dfmt' c prec u)
    		'f' -> adjust' (dfmt' c prec u)
    		'g' -> adjust' (dfmt' c prec u)
    		'G' -> adjust' (dfmt' c prec u)
    		's' -> adjust  ("", tostr prec u)
    		_   -> perror ("bad formatting char " ++ [c])
    		 ) ++ uprintf cs'' us''

    fmti :: Int -> UPrintf -> (String, String)
    fmti prec (UInteger _ i) = if i < 0 then ("-", integral_prec prec (show (-i))) else ("", integral_prec prec (show i))
    fmti _ (UChar c)         = fmti 0 (uInteger (fromEnum c))
    fmti _ _                 = baderr

    fmtu :: Integer -> Int -> UPrintf -> String
    fmtu b prec (UInteger l i) = integral_prec prec (itosb b (if i < 0 then -2*l + i else i))
    fmtu b _    (UChar c)      = itosb b (toInteger (fromEnum c))
    fmtu _ _ _                 = baderr

    integral_prec :: Int -> String -> String
    integral_prec prec integral = (replicate (prec - (length integral)) '0') ++ integral

    toint :: UPrintf -> Int
    toint (UInteger _ i) = fromInteger i
    toint (UChar c)      = fromEnum c
    toint _		     = baderr

    tostr :: Int -> UPrintf -> String
    tostr n (UString s) = if n >= 0 then take n s else s
    tostr _ _		  = baderr

    itosb :: Integer -> Integer -> String
    itosb b n =
    	if n < b then
    	    [intToDigit $ fromInteger n]
    	else
    	    let (q, r) = quotRem n b in
    	    itosb b q ++ [intToDigit $ fromInteger r]

    stoi :: Int -> String -> (Int, String)
    stoi a (c:cs) | isDigit c = stoi (a*10 + digitToInt c) cs
    stoi a cs                 = (a, cs)

    getSpecs :: Bool -> Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, Bool, String, [UPrintf])
    getSpecs _ z s ('-':cs) us = getSpecs True z s cs us
    getSpecs l z _ ('+':cs) us = getSpecs l z True cs us
    getSpecs l _ s ('0':cs) us = getSpecs l True s cs us
    getSpecs l z s ('*':cs) us =
    	let (us', n) = getStar us
    	    ((p, cs''), us'') =
    		    case cs of
                        '.':'*':r -> let (us''', p') = getStar us'
    		    	      	 in  ((p', r), us''')
    		    '.':r     -> (stoi 0 r, us')
    		    _         -> ((-1, cs), us')
    	in  (n, p, l, z, s, cs'', us'')
    getSpecs l z s ('.':cs) us =
    	let ((p, cs'), us') =
    	        case cs of
    		'*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'')
                    _ ->        (stoi 0 cs, us)
    	in  (0, p, l, z, s, cs', us')
    getSpecs l z s cs@(c:_) us | isDigit c =
    	let (n, cs') = stoi 0 cs
    	    ((p, cs''), us') = case cs' of
    	    	 	       '.':'*':r -> let (us'', p') = getStar us in ((p', r), us'')
    		               '.':r -> (stoi 0 r, us)
    			       _     -> ((-1, cs'), us)
    	in  (n, p, l, z, s, cs'', us')
    getSpecs l z s cs       us = (0, -1, l, z, s, cs, us)

    getStar :: [UPrintf] -> ([UPrintf], Int)
    getStar us =
        case us of
        [] -> argerr
        nu : us' -> (us', toint nu)

    dfmt' :: Char -> Int -> UPrintf -> (String, String)
    dfmt' c p (UDouble d) = dfmt c p d
    dfmt' c p (UFloat f)  = dfmt c p f
    dfmt' _ _ _           = baderr

    dfmt :: (RealFloat a) => Char -> Int -> a -> (String, String)
    dfmt c p d =
    	case (if isUpper c then map toUpper else id) $
                 (case toLower c of
                      'e' -> showEFloat
                      'f' -> showFFloat
                      'g' -> showGFloat
                      _   -> error "Printf.dfmt: impossible"
                 )
                   (if p < 0 then Nothing else Just p) d "" of
    	'-':cs -> ("-", cs)
    	cs     -> ("" , cs)

    perror :: String -> a
    perror s = error ("Printf.printf: "++s)
    fmterr, argerr, baderr :: a
    fmterr = perror "formatting string ended prematurely"
    argerr = perror "argument list ended prematurely"
    baderr = perror "bad argument"