--- /dev/null
+--
+-- A C printf like formatter.
+-- Conversion specs:
+-- - left adjust
+-- num field width
+-- * as num, but taken from argument list
+-- . separates width from precision
+-- Formatting characters:
+-- c Char, Int, Integer
+-- d Char, Int, Integer
+-- o Char, Int, Integer
+-- x Char, Int, Integer
+-- u Char, Int, Integer
+-- f Float, Double
+-- g Float, Double
+-- e Float, Double
+-- s String
+--
+module Printf(UPrintf(..), printf) where
+
+#if defined(__HBC__)
+import LMLfmtf
+#endif
+
+#if defined(__YALE_HASKELL__)
+import PrintfPrims
+#endif
+
+#if defined(__GLASGOW_HASKELL__)
+import PreludeGlaST
+import TyArray ( _ByteArray(..) )
+#endif
+
+data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double
+
+printf :: String -> [UPrintf] -> String
+printf "" [] = ""
+printf "" (_:_) = fmterr
+printf ('%':'%':cs) us = '%':printf cs us
+printf ('%':_) [] = argerr
+printf ('%':cs) us@(_:_) = fmt cs us
+printf (c:cs) us = c:printf 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 ("", [chr (toint u)])
+ 'd' -> adjust (fmti u)
+ 'x' -> adjust ("", fmtu 16 u)
+ 'o' -> adjust ("", fmtu 8 u)
+ 'u' -> adjust ("", fmtu 10 u)
+#if defined __YALE_HASKELL__
+ 'e' -> adjust (fmte prec (todbl u))
+ 'f' -> adjust (fmtf prec (todbl u))
+ 'g' -> adjust (fmtg prec (todbl u))
+#else
+ 'e' -> adjust (dfmt c prec (todbl u))
+ 'f' -> adjust (dfmt c prec (todbl u))
+ 'g' -> adjust (dfmt c prec (todbl u))
+#endif
+ 's' -> adjust ("", tostr u)
+ c -> perror ("bad formatting char " ++ [c])
+ ) ++ printf 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 (ord 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 (ord c))
+fmtu b u = baderr
+
+maxi :: Integer
+maxi = (toInteger maxInt + 1) * 2
+
+toint (UInt i) = i
+toint (UInteger i) = toInt i
+toint (UChar c) = ord c
+toint u = baderr
+
+tostr (UString s) = s
+tostr u = baderr
+
+todbl (UDouble d) = d
+#if defined(__GLASGOW_HASKELL__)
+todbl (UFloat (F# f)) = D# (float2Double# f) -- What a great system(TM) !
+#else
+todbl (UFloat f) = fromRational (toRational f)
+#endif
+todbl u = baderr
+
+itos n =
+ if n < 10 then
+ [chr (ord '0' + toInt n)]
+ else
+ let (q, r) = quotRem n 10 in
+ itos q ++ [chr (ord '0' + toInt r)]
+
+chars :: Array Int Char
+#if __HASKELL1__ < 3
+chars = array (0,15) (zipWith (:=) [0..] "0123456789abcdef")
+#else
+chars = array (0,15) (zipWith (\x y -> (x,y)) [0..] "0123456789abcdef")
+#endif
+
+itosb :: Integer -> Integer -> String
+itosb b n =
+ if n < b then
+ [chars ! fromInteger n]
+ else
+ let (q, r) = quotRem n b in
+ itosb b q ++ [chars ! fromInteger r]
+
+stoi :: Int -> String -> (Int, String)
+stoi a (c:cs) | isDigit c = stoi (a*10 + ord c - ord '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@(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)
+
+#if !defined(__YALE_HASKELL__)
+dfmt :: Char -> Int -> Double -> (String, String)
+#endif
+
+#if defined(__GLASGOW_HASKELL__)
+dfmt c{-e,f, or g-} prec d
+ = unsafePerformPrimIO (
+ newCharArray (0 :: Int, 511){-pathetic malloc-} `thenStrictlyST` \ sprintf_here ->
+ let
+ sprintf_fmt = "%1" ++ (if prec < 0 then "" else '.':itos prec) ++ [c]
+ in
+ _ccall_ sprintf sprintf_here sprintf_fmt d `seqPrimIO`
+ freezeCharArray sprintf_here `thenST` \ (_ByteArray _ arr#) ->
+ let
+ unpack :: Int# -> [Char]
+ unpack nh = case (ord# (indexCharArray# arr# nh)) of
+ 0# -> []
+ ch -> case (nh +# 1#) of
+ mh -> C# (chr# ch) : unpack mh
+ in
+ returnPrimIO (
+ case (indexCharArray# arr# 0#) of
+ '-'# -> ("-", unpack 1#)
+ _ -> ("" , unpack 0#)
+ )
+ )
+#endif
+
+#if defined(__HBC__)
+dfmt c p d =
+ case fmtf ("1" ++ (if p < 0 then "" else '.':itos p) ++ [c]) d of
+ '-':cs -> ("-", cs)
+ cs -> ("" , cs)
+#endif
+
+#if defined(__YALE_HASKELL__)
+fmte p d =
+ case (primFmte p d) of
+ '-':cs -> ("-",cs)
+ cs -> ("",cs)
+fmtf p d =
+ case (primFmtf p d) of
+ '-':cs -> ("-",cs)
+ cs -> ("",cs)
+fmtg p d =
+ case (primFmtg p d) of
+ '-':cs -> ("-",cs)
+ cs -> ("",cs)
+#endif
+
+perror s = error ("Printf.printf: "++s)
+fmterr = perror "formatting string ended prematurely"
+argerr = perror "argument list ended prematurely"
+baderr = perror "bad argument"
+
+#if defined(__YALE_HASKELL__)
+-- This is needed because standard Haskell does not have toInt
+
+toInt :: Integral a => a -> Int
+toInt x = fromIntegral x
+#endif
projects / ghc-hetmet.git / blobdiff