1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
-- This code used a function in the lml library (fmtf) that I don't have.
-- If someone makes this work for floats let me know -- jcp
--
-- A C printf like formatter.
-- Conversion specs:
-- - left adjust
-- num field width
-- . 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
-- import LMLfmtf
data UPrintf = UChar Char |
UString String |
UInt Int |
UInteger Integer |
UFloat Float |
UDouble Double
printf :: String -> [UPrintf] -> String
printf "" [] = ""
printf "" (_:_) = fmterr
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 pre ++ fill ++ 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)
'%' -> "%"
'e' -> adjust (dfmt c prec (todbl u))
'f' -> adjust (dfmt c prec (todbl u))
'g' -> adjust (dfmt c prec (todbl u))
's' -> adjust ("", tostr u)
c -> perror ("bad formatting char " ++ [c])
) ++ printf cs'' us''
unimpl = perror "unimplemented"
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
todbl (UFloat f) = fromRational (toRational f)
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 (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 + 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 = unimpl
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)
-- jcp: I don't know what the lml function fmtf does. Someone needs to
-- rewrite this.
{-
dfmt c p d =
case fmtf ("1" ++ (if p < 0 then "" else '.':itos p) ++ [c]) d of
'-':cs -> ("-", cs)
cs -> ("" , cs)
-}
dfmt = error "fmtf not implemented"
perror s = error ("Printf.printf: "++s)
fmterr = perror "formatting string ended prematurely"
argerr = perror "argument list ended prematurely"
baderr = perror "bad argument"
-- This is needed because standard Haskell does not have toInt
toInt :: Integral a => a -> Int
toInt x = fromIntegral x
|
