content: -----------------------------------------------------------------------------
  -- |
  -- 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,
     PrintfType, HPrintfType, PrintfArg, IsChar
  ) where
  
  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
  --
  -- 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 []
  
  -- |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 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)]
  
  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 + 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)
  