%
% @(#) $Docid: Mar. 31th 2003 08:33 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
\begin{code}
module Utils
( showOct
, showHex
, mapFromMb
, mapMb
, mapMbM
, concMaybe
, toMaybe
, split
, splitLast
, splitLastBy
, prefix
, traceIf
, elemBy
, mapUnzip
, diff
, deEscapeString
, ( # )
--,UNUSED: catMapMaybes
, dropSuffix
-- re-exported
, trace
, tryOpen
, basename
, splitdir
, prefixDir
, hdirect_root
, bailIf
, decons
, safe_init
, snoc
, mapAccumLM
, notNull -- :: [a] -> Bool
) where
import Char (chr, ord, readLitChar)
import System.IO
import IO
import Int
{- BEGIN_GHC_ONLY
import Directory
END_GHC_ONLY -}
import Monad ( when )
import List ( mapAccumL, isPrefixOf )
import Debug.Trace
infixl 1 #
\end{code}
A convenience operator for invoking methods on objects:
\begin{code}
( # ) :: a -> (a -> b) -> b
obj # meth = meth obj
\end{code}
Until NumExts is commonly available, we define the following show functions here:
\begin{code}
showIntAtBase :: Integral a => a -> (a -> Char) -> a -> ShowS
showIntAtBase base toChr n r
| n < 0 = '-':showIntAtBase 10 toChr (negate n) r
| otherwise =
case quotRem n base of { (n', d) ->
case toChr d of { ch ->
let
r' = ch : r
in
if n' == 0 then r' else showIntAtBase base toChr n' r'
}}
showHex :: Integral a => a -> ShowS
showHex n r =
showString "0x" $
showIntAtBase 16 (toChrHex) n r
where
toChrHex d
| d < 10 = chr (ord_0 + fromIntegral d)
| otherwise = chr (ord 'a' + fromIntegral (d - 10))
showOct :: Integral a => a -> ShowS
showOct n r =
showString "0o" $
showIntAtBase 8 (toChrOct) n r
where toChrOct d = chr (ord_0 + fromIntegral d)
ord_0 :: Num a => a
ord_0 = fromIntegral (ord '0')
\end{code}
Mapping from a Maybe:
\begin{code}
mapFromMb :: b -> (a -> b) -> Maybe a -> b
mapFromMb d f mb = case mb of Nothing -> d ; Just v -> f v
\end{code}
\begin{code}
split :: Eq a => a -> [a] -> [[a]]
split _ [] = []
split a as =
case break (==a) as of
(xs,[]) -> [xs]
(xs,_:ys) -> xs:split a ys
\end{code}
Split at last occurrence of substring.
\begin{code}
splitLast :: Eq a => [a] -> [a] -> ([a],[a])
splitLast [] ls = (ls,[])
splitLast sep@(_:ss) ls = splitLastBy (sep `isPrefixOf`) (drop (length ss)) ls
splitLastBy :: ([a] -> Bool) -- True => current suffix satisifies
-> ([a] -> [a]) -- for the last match, transform the result coming back.
-> [a]
-> ([a],[a])
splitLastBy predic munge ls =
case (chomp (-1) (0::Int) ls) of
(_,bef,aft) -> (bef,aft)
where
chomp lst _ [] = (lst, [], [])
chomp lst n as@(x:xs) =
case chomp new_last_pos (n+1) xs of
(last_found, bef, aft) ->
case (compare last_found n) of
GT -> (last_found, x:bef, aft)
LT -> (last_found, bef , x:aft)
EQ -> (last_found, bef , munge aft)
where
new_last_pos
| predic as = n
| otherwise = lst
\end{code}
\begin{code}
prefix :: Eq a => [a] -> [a] -> Maybe [a] -- what's left
prefix [] ls = Just ls
prefix _ [] = Nothing
prefix (x:xs) (y:ys)
| x == y = prefix xs ys
| otherwise = Nothing
\end{code}
\begin{code}
traceIf :: Bool -> String -> a -> a
traceIf True str v = trace str v
traceIf _ _ v = v
elemBy :: (a -> Bool) -> [a] -> Bool
elemBy _ [] = False
elemBy isEqual (y:ys) = isEqual y || elemBy isEqual ys
mapUnzip :: (a -> (b,c)) -> [a] -> ([b],[c])
mapUnzip _ [] = ([],[])
mapUnzip f (x:xs) =
let
(a, b) = f x
(as,bs) = mapUnzip f xs
in
(a:as,b:bs)
\end{code}
Returns list of deltas, i.e,
@
diff [x0,x1..xp,xn] = [x0, x1-x0, .., xp - xn]
@
\begin{code}
diff :: Num a => [a] -> [a]
diff ls = snd (mapAccumL ( \ acc v -> (v, v - acc)) 0 ls)
\end{code}
begin{code}
catMapMaybes :: (a -> b) -> [Maybe a] -> [b]
catMapMaybes f ls = [f x | Just x <- ls]
end{code}
Dropping the extension off of a filename:
\begin{code}
dropSuffix :: String -> String
dropSuffix str =
case dropWhile (\ch -> ch /= '.' && ch /= '/' && ch /= '\\' )
(reverse str) of
('.':rs) -> reverse rs
_ -> str
-- give up if we reach a separator (/ or \) or end of list.
{- UNUSED:
dropPrefix :: Eq a => [a] -> [a] -> [a]
dropPrefix [] ys = ys
dropPrefix _ [] = []
dropPrefix (x:xs) (y:ys)
| x == y = dropPrefix xs ys
| otherwise = y:ys
-}
\end{code}
Slightly generalised version of code found in GreenCard's front end:
\begin{code}
tryOpen :: Bool
-> [FilePath]
-> [String]
-> FilePath
-> IO (Maybe FilePath)
tryOpen verbose path exts name =
doUntil (mbOpenFile verbose) (allFileNames path name exts)
doUntil :: (a -> IO (Maybe b)) -> [a] -> IO (Maybe b)
doUntil _ [] = return Nothing
doUntil f (a:as) = do
v <- f a
case v of
Nothing -> doUntil f as
_ -> return v
allFileNames :: [String] -> String -> [String] -> [String]
allFileNames path file exts
= [addSuffix '/' d ++ file ++ (prefixWith '.' ext) | d <- path, ext <- exts]
where
addSuffix _ [] = []
addSuffix ch ls =
case (decons ls) of
(_,x)
| x == ch -> ls
| otherwise -> ls++[ch]
prefixWith _ [] = []
prefixWith ch ls@(x:_)
| ch == x = ls
| otherwise = ch:ls
\end{code}
Combining last and init into one (pass
over the list):
\begin{code}
decons :: [a] -> ([a],a)
decons ds = trundle ds
where
trundle [] = error "decons: empty list"
trundle [x] = ([], x)
trundle (x:xs) = let (ls, l) = trundle xs in (x:ls, l)
\end{code}
Try reading a file:
\begin{code}
mbOpenFile :: Bool -> FilePath -> IO (Maybe FilePath)
mbOpenFile verbose fpath = do
-- I seem to remember that Hugs doesn't support Directory...
{- BEGIN_GHC_ONLY
flg <- doesFileExist fpath
END_GHC_ONLY -}
{- BEGIN_NOT_FOR_GHC -}
flg <- (openFile fpath ReadMode >>= \ h -> hClose h >> return True)
`catch` (\ _ -> return False)
{- END_NOT_FOR_GHC -}
if not flg
then return Nothing
else do
when verbose (hPutStrLn stderr ("Reading file: " ++ show fpath))
return (Just fpath)
\end{code}
\begin{code}
basename :: String -> String
basename str = snd $
splitLastBy (\ (x:_) -> x == '/' || x == '\\')
id
str
-- bi-lingual, the upshot of which is that
-- / isn't allowed in DOS-style paths (and vice
-- versa \ isn't allowed in POSIX(?) style pathnames).
splitdir :: String -> (String, String)
splitdir =
splitLastBy (\ (x:_) -> x == '/' || x == '\\')
id
prefixDir :: String -> String -> String
prefixDir [] rest = rest
prefixDir ['/'] rest = '/':rest
prefixDir ['\\'] rest = '/':rest
prefixDir [x] rest = x:'/':rest
prefixDir (x:xs) rest = x : prefixDir xs rest
\end{code}
Removing escape char from double quotes:
\begin{code}
deEscapeString :: String -> String
deEscapeString [] = []
deEscapeString ls@('\\':x:xs) =
case x of
'"' -> x : deEscapeString xs -- "
_ ->
case readLitChar ls of
((ch,rs):_) -> ch : deEscapeString rs
_ -> '\\':x: deEscapeString xs
deEscapeString (x:xs) = x: deEscapeString xs
\end{code}
The top of the HaskellDirect Registry tree:
\begin{code}
hdirect_root :: String
hdirect_root = "Software\\Haskell\\HaskellDirect"
-- sporadically handy in a monadic context.
bailIf :: Bool -> a -> a -> a
bailIf True a _ = a
bailIf _ _ b = b
\end{code}
Avoids Haskell version trouble:
\begin{code}
mapMb :: (a -> b) -> Maybe a -> Maybe b
mapMb _ Nothing = Nothing
mapMb f (Just c) = Just (f c)
mapMbM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b)
mapMbM _ Nothing = return Nothing
mapMbM f (Just c) = f c >>= return.Just
concMaybe :: Maybe a -> Maybe a -> Maybe a
concMaybe v@(Just _) _ = v
concMaybe _ v = v
-- If predicate is false, represent it as Nothing.
toMaybe :: (a -> Bool) -> a -> Maybe a
toMaybe predic x | predic x = Nothing
| otherwise = Just x
\end{code}
\begin{code}
safe_init :: [a] -> [a]
safe_init [] = []
safe_init ls = init ls
\end{code}
\begin{code}
snoc :: [a] -> a -> [a]
snoc [] y = [y]
snoc (x:xs) y = x : snoc xs y
\end{code}
\begin{code}
mapAccumLM :: (Monad m)
=> (acc -> x -> m (acc, y)) -- Function of elt of input list
-- and accumulator, returning new
-- accumulator and elt of result list
-> acc -- Initial accumulator
-> [x] -- Input list
-> m (acc, [y]) -- Final accumulator and result list
mapAccumLM _ s [] = return (s, [])
mapAccumLM f s (x:xs) = do
(s', y) <- f s x
(s'',ys) <- mapAccumLM f s' xs
return (s'',y:ys)
\end{code}
The simplest of defns; usefule, but not provided as standard:
\begin{code}
notNull :: [a] -> Bool
notNull [] = False
notNull _ = True
\end{code}