Util.lhs 26.2 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The University of Glasgow 1992-2002
4
5
6
7
8
%
\section[Util]{Highly random utility functions}

\begin{code}
module Util (
sof's avatar
sof committed
9

10
	-- general list processing
11
	zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
12
        zipLazy, stretchZipWith,
13
	mapFst, mapSnd,
14
	mapAndUnzip, mapAndUnzip3,
15
	nOfThem, filterOut, partitionWith, splitEithers,
16
17
18
19

	lengthExceeds, lengthIs, lengthAtLeast, 
	listLengthCmp, atLength, equalLength, compareLength,

20
	isSingleton, only, singleton,
21
	notNull, snocView,
sof's avatar
sof committed
22

23
24
	isIn, isn'tIn,

25
26
27
	-- for-loop
	nTimes,

28
	-- sorting
29
	sortLe, sortWith,
30
31
32
33
34

	-- transitive closures
	transitiveClosure,

	-- accumulating
35
	foldl2, count, all2,
sof's avatar
sof committed
36
	
37
	takeList, dropList, splitAtList, split,
38
39

	-- comparisons
40
	isEqual, eqListBy, 
41
	thenCmp, cmpList, maybePrefixMatch,
42
	removeSpaces,
43

44
	-- strictness
45
	seqList,
46

47
	-- pairs
48
	unzipWith,
49

50
	global, consIORef,
51
52
53

	-- module names
	looksLikeModuleName,
sof's avatar
sof committed
54
	
55
56
57
58
	toArgs,

	-- Floating point stuff
	readRational,
59
60
61
62

	-- IO-ish utilities
	createDirectoryHierarchy,
	doesDirNameExist,
63
	modificationTimeIfExists,
64
65
66
67
68

	later, handleDyn, handle,

	-- Filename utils
	Suffix,
69
	splitFilename, suffixOf, basenameOf, joinFileExt,
70
	splitFilenameDir, joinFileName,
71
72
	splitFilename3,
	splitLongestPrefix,
73
74
75
	replaceFilenameSuffix, directoryOf, filenameOf,
	replaceFilenameDirectory,
	escapeSpaces, isPathSeparator,
76
	parseSearchPath,
77
	normalisePath, platformPath, pgmPath,
78
79
    ) where

80
81
#include "HsVersions.h"

82
import Panic		( panic, trace )
83
import FastTypes
84

Simon Marlow's avatar
Simon Marlow committed
85
86
87
88
89
90
import Control.Exception ( Exception(..), finally, catchDyn, throw )
import qualified Control.Exception as Exception
import Data.Dynamic	( Typeable )
import Data.IORef	( IORef, newIORef )
import System.IO.Unsafe	( unsafePerformIO )
import Data.IORef	( readIORef, writeIORef )
91

Simon Marlow's avatar
Simon Marlow committed
92
import qualified Data.List as List ( elem, notElem )
93
94

#ifndef DEBUG
Simon Marlow's avatar
Simon Marlow committed
95
import Data.List		( zipWith4 )
96
#endif
sof's avatar
sof committed
97

Simon Marlow's avatar
Simon Marlow committed
98
99
100
101
102
103
104
import Control.Monad	( when )
import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
import System.Directory	( doesDirectoryExist, createDirectory,
                          getModificationTime )
import Data.Char	( isUpper, isAlphaNum, isSpace, ord, isDigit )
import Data.Ratio	( (%) )
import System.Time	( ClockTime )
105

106
infixr 9 `thenCmp`
107
108
\end{code}

109
110
111
112
113
114
115
116
117
118
119
120
121
122
%************************************************************************
%*									*
\subsection{A for loop}
%*									*
%************************************************************************

\begin{code}
-- Compose a function with itself n times.  (nth rather than twice)
nTimes :: Int -> (a -> a) -> (a -> a)
nTimes 0 _ = id
nTimes 1 f = f
nTimes n f = f . nTimes (n-1) f
\end{code}

123
124
125
126
127
128
%************************************************************************
%*									*
\subsection[Utils-lists]{General list processing}
%*									*
%************************************************************************

129
130
131
132
133
134
\begin{code}
filterOut :: (a->Bool) -> [a] -> [a]
-- Like filter, only reverses the sense of the test
filterOut p [] = []
filterOut p (x:xs) | p x       = filterOut p xs
		   | otherwise = x : filterOut p xs
135
136
137
138
139
140
141
142
143

partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
partitionWith f [] = ([],[])
partitionWith f (x:xs) = case f x of
			   Left  b -> (b:bs, cs)
			   Right c -> (bs, c:cs)
		       where
			 (bs,cs) = partitionWith f xs

144
145
146
147
148
149
150
splitEithers :: [Either a b] -> ([a], [b])
splitEithers [] = ([],[])
splitEithers (e : es) = case e of
			  Left x -> (x:xs, ys)
			  Right y -> (xs, y:ys)
		      where
			(xs,ys) = splitEithers es
151
152
\end{code}

153
154
155
A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
are of equal length.  Alastair Reid thinks this should only happen if
DEBUGging on; hey, why not?
156
157

\begin{code}
158
159
160
161
zipEqual	:: String -> [a] -> [b] -> [(a,b)]
zipWithEqual	:: String -> (a->b->c) -> [a]->[b]->[c]
zipWith3Equal	:: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
zipWith4Equal	:: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
162
163

#ifndef DEBUG
164
165
166
167
zipEqual      _ = zip
zipWithEqual  _ = zipWith
zipWith3Equal _ = zipWith3
zipWith4Equal _ = zipWith4
168
#else
169
170
zipEqual msg []     []     = []
zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
171
zipEqual msg as     bs     = panic ("zipEqual: unequal lists:"++msg)
172
173
174

zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
zipWithEqual msg _ [] []	=  []
175
zipWithEqual msg _ _ _		=  panic ("zipWithEqual: unequal lists:"++msg)
176
177
178
179

zipWith3Equal msg z (a:as) (b:bs) (c:cs)
				=  z a b c : zipWith3Equal msg z as bs cs
zipWith3Equal msg _ [] []  []	=  []
180
zipWith3Equal msg _ _  _   _	=  panic ("zipWith3Equal: unequal lists:"++msg)
181
182
183
184

zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
				=  z a b c d : zipWith4Equal msg z as bs cs ds
zipWith4Equal msg _ [] [] [] []	=  []
185
zipWith4Equal msg _ _  _  _  _	=  panic ("zipWith4Equal: unequal lists:"++msg)
186
187
188
#endif
\end{code}

189
190
191
192
193
194
195
196
\begin{code}
-- zipLazy is lazy in the second list (observe the ~)

zipLazy :: [a] -> [b] -> [(a,b)]
zipLazy [] ys = []
zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
\end{code}

197
198

\begin{code}
199
200
201
202
203
204
205
206
207
208
stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
-- (stretchZipWith p z f xs ys) stretches ys by inserting z in 
-- the places where p returns *True*

stretchZipWith p z f [] ys = []
stretchZipWith p z f (x:xs) ys
  | p x       = f x z : stretchZipWith p z f xs ys
  | otherwise = case ys of
		  []     -> []
		  (y:ys) -> f x y : stretchZipWith p z f xs ys
209
210
211
\end{code}


212
\begin{code}
213
214
215
216
217
218
mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]

mapFst f xys = [(f x, y) | (x,y) <- xys]
mapSnd f xys = [(x, f y) | (x,y) <- xys]

219
220
221
222
223
224
225
226
227
mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])

mapAndUnzip f [] = ([],[])
mapAndUnzip f (x:xs)
  = let
	(r1,  r2)  = f x
	(rs1, rs2) = mapAndUnzip f xs
    in
    (r1:rs1, r2:rs2)
228
229
230
231
232
233
234
235
236
237

mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])

mapAndUnzip3 f [] = ([],[],[])
mapAndUnzip3 f (x:xs)
  = let
	(r1,  r2,  r3)  = f x
	(rs1, rs2, rs3) = mapAndUnzip3 f xs
    in
    (r1:rs1, r2:rs2, r3:rs3)
238
239
\end{code}

240
241
\begin{code}
nOfThem :: Int -> a -> [a]
sof's avatar
sof committed
242
nOfThem n thing = replicate n thing
243

sof's avatar
sof committed
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
-- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
-- specification:
--
--  atLength atLenPred atEndPred ls n
--   | n < 0         = atLenPred n
--   | length ls < n = atEndPred (n - length ls)
--   | otherwise     = atLenPred (drop n ls)
--
atLength :: ([a] -> b)
         -> (Int -> b)
         -> [a]
         -> Int
         -> b
atLength atLenPred atEndPred ls n 
  | n < 0     = atEndPred n 
  | otherwise = go n ls
  where
    go n [] = atEndPred n
    go 0 ls = atLenPred ls
    go n (_:xs) = go (n-1) xs

-- special cases.
266
lengthExceeds :: [a] -> Int -> Bool
267
-- (lengthExceeds xs n) = (length xs > n)
sof's avatar
sof committed
268
lengthExceeds = atLength notNull (const False)
sof's avatar
sof committed
269
270

lengthAtLeast :: [a] -> Int -> Bool
sof's avatar
sof committed
271
lengthAtLeast = atLength notNull (== 0)
sof's avatar
sof committed
272
273
274
275
276
277
278
279
280
281
282
283
284
285

lengthIs :: [a] -> Int -> Bool
lengthIs = atLength null (==0)

listLengthCmp :: [a] -> Int -> Ordering 
listLengthCmp = atLength atLen atEnd 
 where
  atEnd 0      = EQ
  atEnd x
   | x > 0     = LT -- not yet seen 'n' elts, so list length is < n.
   | otherwise = GT

  atLen []     = EQ
  atLen _      = GT
286

287
288
289
290
291
292
293
294
295
296
297
298
equalLength :: [a] -> [b] -> Bool
equalLength [] []         = True
equalLength (_:xs) (_:ys) = equalLength xs ys
equalLength xs    ys      = False

compareLength :: [a] -> [b] -> Ordering
compareLength [] []         = EQ
compareLength (_:xs) (_:ys) = compareLength xs ys
compareLength [] _ys        = LT
compareLength _xs []        = GT

----------------------------
299
300
301
singleton :: a -> [a]
singleton x = [x]

302
303
304
isSingleton :: [a] -> Bool
isSingleton [x] = True
isSingleton  _  = False
305

sof's avatar
sof committed
306
307
308
309
notNull :: [a] -> Bool
notNull [] = False
notNull _  = True

310
311
312
313
314
315
only :: [a] -> a
#ifdef DEBUG
only [a] = a
#else
only (a:_) = a
#endif
316
317
318
\end{code}

Debugging/specialising versions of \tr{elem} and \tr{notElem}
319

320
321
322
323
324
325
326
327
328
329
330
331
332
333
\begin{code}
isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool

# ifndef DEBUG
isIn    msg x ys = elem__    x ys
isn'tIn msg x ys = notElem__ x ys

--these are here to be SPECIALIZEd (automagically)
elem__ _ []	= False
elem__ x (y:ys)	= x==y || elem__ x ys

notElem__ x []	   =  True
notElem__ x (y:ys) =  x /= y && notElem__ x ys

ross's avatar
ross committed
334
# else /* DEBUG */
335
isIn msg x ys
336
  = elem (_ILIT 0) x ys
337
338
339
  where
    elem i _ []	    = False
    elem i x (y:ys)
340
341
342
      | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
			 x `List.elem` (y:ys)
      | otherwise      = x == y || elem (i +# _ILIT(1)) x ys
343
344

isn'tIn msg x ys
345
  = notElem (_ILIT 0) x ys
346
347
348
  where
    notElem i x [] =  True
    notElem i x (y:ys)
349
350
351
      | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
		         x `List.notElem` (y:ys)
      | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
ross's avatar
ross committed
352
# endif /* DEBUG */
353
354
355
356
357
358
359
360
361
362
363
364
365
366
\end{code}

%************************************************************************
%*									*
\subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
%*									*
%************************************************************************

\begin{display}
Date: Mon, 3 May 93 20:45:23 +0200
From: Carsten Kehler Holst <kehler@cs.chalmers.se>
To: partain@dcs.gla.ac.uk
Subject: natural merge sort beats quick sort [ and it is prettier ]

367
Here is a piece of Haskell code that I'm rather fond of. See it as an
368
369
attempt to get rid of the ridiculous quick-sort routine. group is
quite useful by itself I think it was John's idea originally though I
370
believe the lazy version is due to me [surprisingly complicated].
371
372
gamma [used to be called] is called gamma because I got inspired by
the Gamma calculus. It is not very close to the calculus but does
373
374
375
behave less sequentially than both foldr and foldl. One could imagine
a version of gamma that took a unit element as well thereby avoiding
the problem with empty lists.
376
377
378
379
380
381

I've tried this code against

   1) insertion sort - as provided by haskell
   2) the normal implementation of quick sort
   3) a deforested version of quick sort due to Jan Sparud
382
   4) a super-optimized-quick-sort of Lennart's
383
384
385
386

If the list is partially sorted both merge sort and in particular
natural merge sort wins. If the list is random [ average length of
rising subsequences = approx 2 ] mergesort still wins and natural
387
merge sort is marginally beaten by Lennart's soqs. The space
388
consumption of merge sort is a bit worse than Lennart's quick sort
389
390
391
approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
fpca article ] isn't used because of group.

392
have fun
393
394
395
396
397
Carsten
\end{display}

\begin{code}
group :: (a -> a -> Bool) -> [a] -> [[a]]
398
399
400
401
402
403
404
-- Given a <= function, group finds maximal contiguous up-runs 
-- or down-runs in the input list.
-- It's stable, in the sense that it never re-orders equal elements
--
-- Date: Mon, 12 Feb 1996 15:09:41 +0000
-- From: Andy Gill <andy@dcs.gla.ac.uk>
-- Here is a `better' definition of group.
405

406
407
408
409
410
group p []     = []
group p (x:xs) = group' xs x x (x :)
  where
    group' []     _     _     s  = [s []]
    group' (x:xs) x_min x_max s 
411
412
	|      x_max `p` x  = group' xs x_min x (s . (x :)) 
	| not (x_min `p` x) = group' xs x x_max ((x :) . s) 
413
	| otherwise         = s [] : group' xs x x (x :) 
414
415
	-- NB: the 'not' is essential for stablity
	--	x `p` x_min would reverse equal elements
416
417
418
419

generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
generalMerge p xs [] = xs
generalMerge p [] ys = ys
420
generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs (y:ys)
421
			     | otherwise = y : generalMerge p (x:xs) ys
422
423
424
425
426
427
428
429
430
431
432
433

-- gamma is now called balancedFold

balancedFold :: (a -> a -> a) -> [a] -> a
balancedFold f [] = error "can't reduce an empty list using balancedFold"
balancedFold f [x] = x
balancedFold f l  = balancedFold f (balancedFold' f l)

balancedFold' :: (a -> a -> a) -> [a] -> [a]
balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
balancedFold' f xs = xs

434
435
generalNaturalMergeSort p [] = []
generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
436

437
#if NOT_USED
438
439
440
generalMergeSort p [] = []
generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs

441
442
443
444
445
446
mergeSort, naturalMergeSort :: Ord a => [a] -> [a]

mergeSort = generalMergeSort (<=)
naturalMergeSort = generalNaturalMergeSort (<=)

mergeSortLe le = generalMergeSort le
447
448
#endif

449
450
sortLe :: (a->a->Bool) -> [a] -> [a]
sortLe le = generalNaturalMergeSort le
451
452
453
454
455

sortWith :: Ord b => (a->b) -> [a] -> [a]
sortWith get_key xs = sortLe le xs
  where
    x `le` y = get_key x < get_key y	
456
457
458
459
460
461
462
463
464
465
466
467
468
\end{code}

%************************************************************************
%*									*
\subsection[Utils-transitive-closure]{Transitive closure}
%*									*
%************************************************************************

This algorithm for transitive closure is straightforward, albeit quadratic.

\begin{code}
transitiveClosure :: (a -> [a])		-- Successor function
		  -> (a -> a -> Bool)	-- Equality predicate
469
		  -> [a]
470
471
472
		  -> [a]		-- The transitive closure

transitiveClosure succ eq xs
473
 = go [] xs
474
 where
475
476
477
   go done [] 			   = done
   go done (x:xs) | x `is_in` done = go done xs
   		  | otherwise      = go (x:done) (succ x ++ xs)
478
479
480
481
482
483
484
485
486
487
488
489

   x `is_in` []                 = False
   x `is_in` (y:ys) | eq x y    = True
  		    | otherwise = x `is_in` ys
\end{code}

%************************************************************************
%*									*
\subsection[Utils-accum]{Accumulating}
%*									*
%************************************************************************

490
491
492
493
494
495
A combination of foldl with zip.  It works with equal length lists.

\begin{code}
foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
foldl2 k z [] [] = z
foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
496
497
498
499
500
501
502

all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
-- True if the lists are the same length, and 
-- all corresponding elements satisfy the predicate
all2 p []     []     = True
all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
all2 p xs     ys     = False
503
504
505
506
507
508
509
510
511
512
513
\end{code}

Count the number of times a predicate is true

\begin{code}
count :: (a -> Bool) -> [a] -> Int
count p [] = 0
count p (x:xs) | p x       = 1 + count p xs
	       | otherwise = count p xs
\end{code}

sof's avatar
sof committed
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
@splitAt@, @take@, and @drop@ but with length of another
list giving the break-off point:

\begin{code}
takeList :: [b] -> [a] -> [a]
takeList [] _ = []
takeList (_:xs) ls = 
   case ls of
     [] -> []
     (y:ys) -> y : takeList xs ys

dropList :: [b] -> [a] -> [a]
dropList [] xs    = xs
dropList _  xs@[] = xs
dropList (_:xs) (_:ys) = dropList xs ys


splitAtList :: [b] -> [a] -> ([a], [a])
splitAtList [] xs     = ([], xs)
splitAtList _ xs@[]   = (xs, xs)
splitAtList (_:xs) (y:ys) = (y:ys', ys'')
    where
      (ys', ys'') = splitAtList xs ys

538
539
540
541
542
543
544
545
546
snocView :: [a] -> Maybe ([a],a)
	-- Split off the last element
snocView [] = Nothing
snocView xs = go [] xs
	    where
		-- Invariant: second arg is non-empty
	      go acc [x]    = Just (reverse acc, x)
	      go acc (x:xs) = go (x:acc) xs

547
548
549
550
551
split :: Char -> String -> [String]
split c s = case rest of
		[]     -> [chunk] 
		_:rest -> chunk : split c rest
  where (chunk, rest) = break (==c) s
sof's avatar
sof committed
552
553
\end{code}

554

555
556
557
558
559
560
%************************************************************************
%*									*
\subsection[Utils-comparison]{Comparisons}
%*									*
%************************************************************************

561
\begin{code}
562
563
564
565
566
567
568
569
570
571
572
isEqual :: Ordering -> Bool
-- Often used in (isEqual (a `compare` b))
isEqual GT = False
isEqual EQ = True
isEqual LT = False

thenCmp :: Ordering -> Ordering -> Ordering
{-# INLINE thenCmp #-}
thenCmp EQ   any = any
thenCmp other any = other

573
574
575
576
577
eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
eqListBy eq []     []     = True
eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
eqListBy eq xs     ys     = False

578
cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
579
580
    -- `cmpList' uses a user-specified comparer

581
582
583
cmpList cmp []     [] = EQ
cmpList cmp []     _  = LT
cmpList cmp _      [] = GT
584
cmpList cmp (a:as) (b:bs)
585
  = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
586
587
\end{code}

588
\begin{code}
589
590
591
592
593
594
595
maybePrefixMatch :: String -> String -> Maybe String
maybePrefixMatch []    rest = Just rest
maybePrefixMatch (_:_) []   = Nothing
maybePrefixMatch (p:pat) (r:rest)
  | p == r    = maybePrefixMatch pat rest
  | otherwise = Nothing

596
597
removeSpaces :: String -> String
removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
598
599
600
601
602
603
604
605
606
607
608
609
610
\end{code}

%************************************************************************
%*									*
\subsection[Utils-pairs]{Pairs}
%*									*
%************************************************************************

\begin{code}
unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
\end{code}

611
612
613
614
\begin{code}
seqList :: [a] -> b -> b
seqList [] b = b
seqList (x:xs) b = x `seq` seqList xs b
615
\end{code}
616
617
618
619
620
621
622

Global variables:

\begin{code}
global :: a -> IORef a
global a = unsafePerformIO (newIORef a)
\end{code}
623

624
625
626
627
628
629
630
\begin{code}
consIORef :: IORef [a] -> a -> IO ()
consIORef var x = do
  xs <- readIORef var
  writeIORef var (x:xs)
\end{code}

631
632
633
Module names:

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
634
looksLikeModuleName :: String -> Bool
635
looksLikeModuleName [] = False
636
637
638
639
looksLikeModuleName (c:cs) = isUpper c && go cs
  where go [] = True
	go ('.':cs) = looksLikeModuleName cs
	go (c:cs)   = (isAlphaNum c || c == '_') && go cs
640
\end{code}
sof's avatar
sof committed
641

642
643
644
645
Akin to @Prelude.words@, but acts like the Bourne shell, treating
quoted strings and escaped characters within the input as solid blocks
of characters.  Doesn't raise any exceptions on malformed escapes or
quoting.
sof's avatar
sof committed
646
647
648
649
650

\begin{code}
toArgs :: String -> [String]
toArgs "" = []
toArgs s  =
651
652
653
  case dropWhile isSpace s of  -- drop initial spacing
    [] -> []  -- empty, so no more tokens
    rem -> let (tok,aft) = token rem [] in tok : toArgs aft
sof's avatar
sof committed
654
 where
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
   -- Grab a token off the string, given that the first character exists and
   -- isn't whitespace.  The second argument is an accumulator which has to be
   -- reversed at the end.
  token [] acc = (reverse acc,[])            -- out of characters
  token ('\\':c:aft) acc                     -- escapes
               = token aft ((escape c) : acc)
  token (q:aft) acc | q == '"' || q == '\''  -- open quotes
               = let (aft',acc') = quote q aft acc in token aft' acc'
  token (c:aft) acc | isSpace c              -- unescaped, unquoted spacing
               = (reverse acc,aft)
  token (c:aft) acc                          -- anything else goes in the token
               = token aft (c:acc)

   -- Get the appropriate character for a single-character escape.
  escape 'n' = '\n'
  escape 't' = '\t'
  escape 'r' = '\r'
  escape c   = c

   -- Read into accumulator until a quote character is found.
  quote qc =
    let quote' [] acc                  = ([],acc)
        quote' ('\\':c:aft) acc        = quote' aft ((escape c) : acc)
        quote' (c:aft) acc | c == qc   = (aft,acc)
        quote' (c:aft) acc             = quote' aft (c:acc)
    in quote'
sof's avatar
sof committed
681
\end{code}
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730

-- -----------------------------------------------------------------------------
-- Floats

\begin{code}
readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
readRational__ r = do 
     (n,d,s) <- readFix r
     (k,t)   <- readExp s
     return ((n%1)*10^^(k-d), t)
 where
     readFix r = do
	(ds,s)  <- lexDecDigits r
	(ds',t) <- lexDotDigits s
	return (read (ds++ds'), length ds', t)

     readExp (e:s) | e `elem` "eE" = readExp' s
     readExp s			   = return (0,s)

     readExp' ('+':s) = readDec s
     readExp' ('-':s) = do
			(k,t) <- readDec s
			return (-k,t)
     readExp' s	      = readDec s

     readDec s = do
        (ds,r) <- nonnull isDigit s
        return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
                r)

     lexDecDigits = nonnull isDigit

     lexDotDigits ('.':s) = return (span isDigit s)
     lexDotDigits s       = return ("",s)

     nonnull p s = do (cs@(_:_),t) <- return (span p s)
                      return (cs,t)

readRational :: String -> Rational -- NB: *does* handle a leading "-"
readRational top_s
  = case top_s of
      '-' : xs -> - (read_me xs)
      xs       -> read_me xs
  where
    read_me s
      = case (do { (x,"") <- readRational__ s ; return x }) of
	  [x] -> x
	  []  -> error ("readRational: no parse:"        ++ top_s)
	  _   -> error ("readRational: ambiguous parse:" ++ top_s)
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761


-----------------------------------------------------------------------------
-- Create a hierarchy of directories

createDirectoryHierarchy :: FilePath -> IO ()
createDirectoryHierarchy dir = do
  b <- doesDirectoryExist dir
  when (not b) $ do
	createDirectoryHierarchy (directoryOf dir)
	createDirectory dir

-----------------------------------------------------------------------------
-- Verify that the 'dirname' portion of a FilePath exists.
-- 
doesDirNameExist :: FilePath -> IO Bool
doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)

-- -----------------------------------------------------------------------------
-- Exception utils

later = flip finally

handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
handleDyn = flip catchDyn

handle :: (Exception -> IO a) -> IO a -> IO a
handle h f = f `Exception.catch` \e -> case e of
    ExitException _ -> throw e
    _               -> h e

762
763
764
765
766
767
768
769
770
771
-- --------------------------------------------------------------
-- check existence & modification time at the same time

modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
modificationTimeIfExists f = do
  (do t <- getModificationTime f; return (Just t))
	`IO.catch` \e -> if isDoesNotExistError e 
			then return Nothing 
			else ioError e

772
773
774
-- --------------------------------------------------------------
-- Filename manipulation
		
775
776
777
778
-- Filenames are kept "normalised" inside GHC, using '/' as the path
-- separator.  On Windows these functions will also recognise '\\' as
-- the path separator, but will generally construct paths using '/'.

779
780
781
782
783
type Suffix = String

splitFilename :: String -> (String,Suffix)
splitFilename f = splitLongestPrefix f (=='.')

784
785
786
787
788
basenameOf :: FilePath -> String
basenameOf = fst . splitFilename

suffixOf :: FilePath -> Suffix
suffixOf = snd . splitFilename
789

790
791
792
793
joinFileExt :: String -> String -> FilePath
joinFileExt path ""  = path
joinFileExt path ext = path ++ '.':ext

794
795
796
-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
splitFilenameDir :: String -> (String,String)
splitFilenameDir str
797
798
799
800
   = let (dir, rest) = splitLongestPrefix str isPathSeparator
	 (dir', rest') | null rest = (".", dir)
		       | otherwise = (dir, rest)
     in  (dir', rest')
801
802
803
804

-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
splitFilename3 :: String -> (String,String,Suffix)
splitFilename3 str
805
806
807
808
809
810
811
812
813
   = let (dir, rest) = splitFilenameDir str
	 (name, ext) = splitFilename rest
     in  (dir, name, ext)

joinFileName :: String -> String -> FilePath
joinFileName ""  fname = fname
joinFileName "." fname = fname
joinFileName dir ""    = dir
joinFileName dir fname = dir ++ '/':fname
814
815
816
817
818
819
820
821

-- split a string at the last character where 'pred' is True,
-- returning a pair of strings. The first component holds the string
-- up (but not including) the last character for which 'pred' returned
-- True, the second whatever comes after (but also not including the
-- last character).
--
-- If 'pred' returns False for all characters in the string, the original
822
-- string is returned in the first component (and the second one is just
823
824
-- empty).
splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
825
826
827
828
829
830
splitLongestPrefix str pred
  | null r_pre = (str,           [])
  | otherwise  = (reverse (tail r_pre), reverse r_suf)
	-- 'tail' drops the char satisfying 'pred'
  where 
    (r_suf, r_pre) = break pred (reverse str)
831
832

replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
833
replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
834
835
836
837
838
839
840
841
842
843
844
845

-- directoryOf strips the filename off the input string, returning
-- the directory.
directoryOf :: FilePath -> String
directoryOf = fst . splitFilenameDir

-- filenameOf strips the directory off the input string, returning
-- the filename.
filenameOf :: FilePath -> String
filenameOf = snd . splitFilenameDir

replaceFilenameDirectory :: FilePath -> String -> FilePath
846
replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
847
848
849
850
851
852
853
854
855
856
857

escapeSpaces :: String -> String
escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""

isPathSeparator :: Char -> Bool
isPathSeparator ch =
#ifdef mingw32_TARGET_OS
  ch == '/' || ch == '\\'
#else
  ch == '/'
#endif
858

859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
--------------------------------------------------------------
-- * Search path
--------------------------------------------------------------

-- | The function splits the given string to substrings
-- using the 'searchPathSeparator'.
parseSearchPath :: String -> [FilePath]
parseSearchPath path = split path
  where
    split :: String -> [String]
    split s =
      case rest' of
        []     -> [chunk] 
        _:rest -> chunk : split rest
      where
        chunk = 
          case chunk' of
#ifdef mingw32_HOST_OS
            ('\"':xs@(_:_)) | last xs == '\"' -> init xs
#endif
            _                                 -> chunk'

        (chunk', rest') = break (==searchPathSeparator) s

-- | A platform-specific character used to separate search path strings in 
-- environment variables. The separator is a colon (\":\") on Unix and Macintosh, 
-- and a semicolon (\";\") on the Windows operating system.
searchPathSeparator :: Char
#if mingw32_HOST_OS || mingw32_TARGET_OS
searchPathSeparator = ';'
#else
searchPathSeparator = ':'
#endif

893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
-----------------------------------------------------------------------------
-- Convert filepath into platform / MSDOS form.

-- We maintain path names in Unix form ('/'-separated) right until 
-- the last moment.  On Windows we dos-ify them just before passing them
-- to the Windows command.
-- 
-- The alternative, of using '/' consistently on Unix and '\' on Windows,
-- proved quite awkward.  There were a lot more calls to platformPath,
-- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
-- interpreted a command line 'foo\baz' as 'foobaz'.

normalisePath :: String -> String
-- Just changes '\' to '/'

pgmPath :: String		-- Directory string in Unix format
	-> String		-- Program name with no directory separators
				--	(e.g. copy /y)
	-> String		-- Program invocation string in native format

#if defined(mingw32_HOST_OS)
--------------------- Windows version ------------------
normalisePath xs = subst '\\' '/' xs
pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
platformPath p   = subst '/' '\\' p

subst a b ls = map (\ x -> if x == a then b else x) ls
#else
--------------------- Non-Windows version --------------
normalisePath xs   = xs
pgmPath dir pgm    = dir ++ '/' : pgm
platformPath stuff = stuff
--------------------------------------------------------
#endif
927
\end{code}