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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
{-# OPTIONS -fglasgow-exts #-}
-- We need an instance String
module Stringalike (Stringalike(..)) where
import Numeric ( readHex )
import Data.Char ( chr, isHexDigit )
import FileName ( FileName, ps2fn, fp2fn )
import FastPackedString ( PackedString, packString, unpackPS,
nilPS, nullPS, lengthPS, reversePS, indexPS,
appendPS, concatPS, headPS, tailPS, initPS, lastPS,
takePS, dropPS, dropWhilePS, dropWhitePS,
breakPS, breakFirstPS, breakLastPS, breakOnPS,
breakWhitePS, readIntPS, fromHex2PS, )
class Stringalike s where
sal_empty :: s
sal_null :: s -> Bool
sal_head :: s -> Char
sal_last :: s -> Char
sal_tail :: s -> s
sal_take :: Int -> s -> s
sal_drop :: Int -> s -> s
sal_reverse :: s -> s
sal_concat :: [s] -> s
sal_length :: s -> Int
sal_index :: s -> Int -> Char
sal_dropWhile :: (Char -> Bool) -> s -> s
sal_dropWhite :: s -> s
sal_breakWhite :: s -> (s, s)
sal_readInt :: s -> Maybe (Int, s)
sal_break :: (Char -> Bool) -> s -> (s, s)
sal_breakFirst :: Char -> s -> Maybe (s, s)
sal_breakFirst c xs = case sal_breakOn c xs of
(ys, zs)
| sal_null zs -> Nothing
| otherwise -> Just (ys, sal_tail zs)
sal_breakLast :: Char -> s -> Maybe (s, s)
sal_breakLast c xs = case sal_breakFirst c (sal_reverse xs) of
Nothing -> Nothing
Just (ys, zs) ->
Just (sal_reverse zs, sal_reverse ys)
sal_breakOn :: Char -> s -> (s, s)
sal_breakOn c = sal_break (c ==)
sal_to_string :: s -> String
sal_to_PS :: s -> PackedString
sal_fromHex :: s -> s
sal_to_fn :: s -> FileName
instance Stringalike String where
sal_empty = ""
sal_null = null
sal_head = head
sal_last = last
sal_tail = tail
sal_take = take
sal_drop = drop
sal_reverse = reverse
sal_concat = concat
sal_length = length
sal_index = (!!)
sal_dropWhile = dropWhile
sal_dropWhite = dropWhile (`elem` " \n\t\r")
sal_breakWhite = break (`elem` " \n\t\r")
sal_readInt xs = case reads xs of
[(n, s')] -> Just (n, s')
_ -> Nothing
sal_break = break
sal_to_string = id
sal_to_PS = packString
sal_fromHex "" = ""
sal_fromHex [_] = "" -- Should this be an error?
sal_fromHex all_cs@(c1:c2:cs)
= case readHex [c1, c2] of
[(n, "")] -> chr n:sal_fromHex cs
_ -> error ("Bad hex characters: " ++ all_cs)
sal_to_fn = fp2fn
instance Stringalike PackedString where
sal_empty = nilPS
sal_null = nullPS
sal_head = headPS
sal_last = lastPS
sal_tail = tailPS
sal_take = takePS
sal_drop = dropPS
sal_reverse = reversePS
sal_concat = concatPS
sal_length = lengthPS
sal_index = indexPS
sal_dropWhile = dropWhilePS
sal_dropWhite = dropWhitePS
sal_breakWhite = breakWhitePS
sal_readInt = readIntPS
sal_break = breakPS
sal_breakFirst = breakFirstPS
sal_breakLast = breakLastPS
sal_breakOn = breakOnPS
sal_to_string = unpackPS
sal_to_PS = id
sal_fromHex = fromHex2PS
sal_to_fn = ps2fn
-- Invariant: nullPS `notElem`
instance Stringalike [PackedString] where
sal_empty = []
sal_null = null
sal_head (ps:_) = headPS ps
sal_head [] = error "sal_head []"
sal_last (ps:pss)
| null pss = lastPS ps
| otherwise = sal_last pss
sal_last [] = error "sal_last []"
sal_tail (ps:pss)
| lengthPS ps == 1 = pss
| otherwise = tailPS ps:pss
sal_tail [] = error "sal_tail []"
sal_take _ [] = []
sal_take 0 _ = []
sal_take n (ps:pss)
| n <= lengthPS ps = [takePS n ps]
| otherwise = ps:sal_take (n - lengthPS ps) pss
sal_drop _ [] = []
sal_drop n (ps:pss)
| n == lengthPS ps = pss
| n < lengthPS ps = dropPS n ps:pss
| otherwise = sal_drop (n - lengthPS ps) pss
sal_reverse = reverse . map reversePS
sal_concat = concat
sal_length = sum . map lengthPS
sal_index [] _ = error "sal_index []"
sal_index (ps:pss) n
| n < lengthPS ps = indexPS ps n
| otherwise = sal_index pss (n - lengthPS ps)
sal_dropWhile _ [] = []
sal_dropWhile f (ps:pss) = let ps' = dropWhilePS f ps
in if nullPS ps'
then sal_dropWhile f pss
else ps':pss
sal_dropWhite [] = []
sal_dropWhite (ps:pss) = let ps' = dropWhitePS ps
in if nullPS ps'
then sal_dropWhite pss
else ps':pss
sal_breakWhite [] = ([], [])
sal_breakWhite (ps:pss) = case breakWhitePS ps of
(xs, ys)
| nullPS ys -> case sal_breakWhite pss of
(xs', ys') -> (xs:xs', ys')
| nullPS xs -> ([], ys:pss)
| otherwise -> ([xs], ys:pss)
sal_readInt pss = case sal_break f $ sal_dropWhite pss of
(xs, ys) -> case readIntPS (concatPS (xs ++ [nulPS])) of
Just (n, ys')
| len == 0 -> error "readIntPS lost NUL!"
| len == 1 -> Just (n, ys)
| otherwise -> Just (n, initPS ys':ys)
where len = lengthPS ys'
Nothing -> Nothing
where f c | isHexDigit c = False
f '+' = False
f '-' = False
f 'x' = False
f _ = True
nulPS = packString "\NUL"
sal_break _ [] = ([], [])
sal_break f (ps:pss) = case breakPS f ps of
(xs, ys)
| nullPS ys -> case sal_break f pss of
(xs', ys') -> (xs:xs', ys')
| nullPS xs -> ([], ys:pss)
| otherwise -> ([xs], ys:pss)
sal_to_string = concat . map unpackPS
sal_to_PS = concatPS
sal_fromHex [] = []
sal_fromHex [ps]
| lengthPS ps == 1 = [] -- Should this be an error?
sal_fromHex (ps1:ps2:pss)
| lengthPS ps1 == 1 = sal_fromHex (appendPS ps1 ps2):pss
sal_fromHex (ps:pss)
| odd (lengthPS ps) = sal_fromHex (initPS ps:packString [lastPS ps]:pss)
| otherwise = fromHex2PS ps:sal_fromHex pss
sal_to_fn = ps2fn . concatPS
|
