module System.Plugins.Utils (
Arg,
hWrite,
mkUnique,
hMkUnique,
mkUniqueIn,
hMkUniqueIn,
findFile,
mkTemp, mkTempIn,
replaceSuffix,
outFilePath,
dropSuffix,
mkModid,
changeFileExt,
joinFileExt,
splitFileExt,
isSublistOf,
dirname,
basename,
(</>), (<.>), (<+>), (<>),
newer,
encode,
decode,
EncodedString,
panic
) where
#include "../../../config.h"
import System.Plugins.Env ( isLoaded )
import System.Plugins.Consts ( objSuf, hiSuf, tmpDir )
import Data.Char
import Data.List
import System.IO
import System.Environment ( getEnv )
import System.Directory
type Arg = String
panic s = ioError ( userError s )
hWrite :: Handle -> String -> IO ()
hWrite hdl src = hPutStr hdl src >> hClose hdl >> return ()
mkTemp :: IO (String,Handle)
mkTemp = do tmpd <- catch (getEnv "TMPDIR") (\_ -> return tmpDir)
mkTempIn tmpd
mkTempIn :: String -> IO (String, Handle)
mkTempIn tmpd = do
(tmpf, hdl) <- openTempFile tmpd "MXXXXX.hs"
let modname = mkModid $ dropSuffix tmpf
if and $ map (\c -> isAlphaNum c && c /= '_') modname
then return (tmpf,hdl)
else panic $ "Illegal characters in temp file: `"++tmpf++"'"
mkUnique :: IO FilePath
mkUnique = do (t,h) <- hMkUnique
hClose h >> return t
hMkUnique :: IO (FilePath,Handle)
hMkUnique = do (t,h) <- mkTemp
alreadyLoaded <- isLoaded t
if alreadyLoaded
then hClose h >> removeFile t >> hMkUnique
else return (t,h)
mkUniqueIn :: FilePath -> IO FilePath
mkUniqueIn dir = do (t,h) <- hMkUniqueIn dir
hClose h >> return t
hMkUniqueIn :: FilePath -> IO (FilePath,Handle)
hMkUniqueIn dir = do (t,h) <- mkTempIn dir
alreadyLoaded <- isLoaded t
if alreadyLoaded
then hClose h >> removeFile t >> hMkUniqueIn dir
else return (t,h)
findFile :: [String] -> FilePath -> IO (Maybe FilePath)
findFile [] _ = return Nothing
findFile (ext:exts) file
= do let l = changeFileExt file ext
b <- doesFileExist l
if b then return $ Just l
else findFile exts file
infixr 6 </>
infixr 6 <.>
(</>), (<.>), (<+>), (<>) :: FilePath -> FilePath -> FilePath
[] </> b = b
a </> b = a ++ "/" ++ b
[] <.> b = b
a <.> b = a ++ "." ++ b
[] <+> b = b
a <+> b = a ++ " " ++ b
[] <> b = b
a <> b = a ++ b
dirname :: FilePath -> FilePath
dirname p =
let x = findIndices (== '\\') p
y = findIndices (== '/') p
in
if not $ null x
then if not $ null y
then if (maximum x) > (maximum y) then dirname' '\\' p else dirname' '/' p
else dirname' '\\' p
else dirname' '/' p
where
dirname' chara pa =
case reverse $ dropWhile (/= chara) $ reverse pa of
[] -> "."
pa' -> pa'
basename :: FilePath -> FilePath
basename p =
let x = findIndices (== '\\') p
y = findIndices (== '/') p
in
if not $ null x
then if not $ null y
then if (maximum x) > (maximum y) then basename' '\\' p else basename' '/' p
else basename' '\\' p
else basename' '/' p
where
basename' chara pa = reverse $ takeWhile (/= chara) $ reverse pa
dropSuffix :: FilePath -> FilePath
dropSuffix f = reverse . tail . dropWhile (/= '.') $ reverse f
mkModid :: String -> String
mkModid = (takeWhile (/= '.')) . reverse . (takeWhile (\x -> ('/'/= x) && ('\\' /= x))) . reverse
changeFileExt :: FilePath
-> String
-> FilePath
changeFileExt fpath ext = joinFileExt name ext
where
(name,_) = splitFileExt fpath
joinFileExt :: String -> String -> FilePath
joinFileExt fpath "" = fpath
joinFileExt fpath ext = fpath ++ '.':ext
splitFileExt :: FilePath -> (String, String)
splitFileExt p =
case break (== '.') fname of
(suf@(_:_),_:pre) -> (reverse (pre++fpath), reverse suf)
_ -> (p, [])
where
(fname,fpath) = break isPathSeparator (reverse p)
isPathSeparator :: Char -> Bool
isPathSeparator ch =
#if defined(CYGWIN) || defined(__MINGW32__)
ch == '/' || ch == '\\'
#else
ch == '/'
#endif
replaceSuffix :: FilePath -> String -> FilePath
replaceSuffix [] _ = []
replaceSuffix f suf =
case reverse $ dropWhile (/= '.') $ reverse f of
[] -> f ++ suf
f' -> f' ++ tail suf
outFilePath :: FilePath -> [Arg] -> (FilePath,FilePath)
outFilePath src args =
let objs = find_o args
paths = find_p args
in case () of { _
| not (null objs)
-> let obj = last objs in (obj, mk_hi obj)
| not (null paths)
-> let obj = last paths </> mk_o (basename src) in (obj, mk_hi obj)
| otherwise
-> (mk_o src, mk_hi src)
}
where
outpath = "-o"
outdir = "-odir"
mk_hi s = replaceSuffix s hiSuf
mk_o s = replaceSuffix s objSuf
find_o [] = []
find_o (f:f':fs) | f == outpath = [f']
| otherwise = find_o $! f':fs
find_o _ = []
find_p [] = []
find_p (f:f':fs) | f == outdir = [f']
| otherwise = find_p $! f':fs
find_p _ = []
newer :: FilePath -> FilePath -> IO Bool
newer a b = do
a_t <- getModificationTime a
b_exists <- doesFileExist b
if not b_exists
then return True
else do b_t <- getModificationTime b
return ( a_t > b_t )
type EncodedString = String
encode :: String -> EncodedString
encode [] = []
encode (c:cs) = encode_ch c ++ encode cs
unencodedChar :: Char -> Bool
unencodedChar 'Z' = False
unencodedChar 'z' = False
unencodedChar c = c >= 'a' && c <= 'z'
|| c >= 'A' && c <= 'Z'
|| c >= '0' && c <= '9'
decode :: EncodedString -> String
decode [] = []
decode ('Z' : d : rest) | isDigit d = decode_tuple d rest
| otherwise = decode_upper d : decode rest
decode ('z' : d : rest) | isDigit d = decode_num_esc d rest
| otherwise = decode_lower d : decode rest
decode (c : rest) = c : decode rest
decode_upper, decode_lower :: Char -> Char
decode_upper 'L' = '('
decode_upper 'R' = ')'
decode_upper 'M' = '['
decode_upper 'N' = ']'
decode_upper 'C' = ':'
decode_upper 'Z' = 'Z'
decode_upper ch = error $ "decode_upper can't handle this char `"++[ch]++"'"
decode_lower 'z' = 'z'
decode_lower 'a' = '&'
decode_lower 'b' = '|'
decode_lower 'c' = '^'
decode_lower 'd' = '$'
decode_lower 'e' = '='
decode_lower 'g' = '>'
decode_lower 'h' = '#'
decode_lower 'i' = '.'
decode_lower 'l' = '<'
decode_lower 'm' = '-'
decode_lower 'n' = '!'
decode_lower 'p' = '+'
decode_lower 'q' = '\''
decode_lower 'r' = '\\'
decode_lower 's' = '/'
decode_lower 't' = '*'
decode_lower 'u' = '_'
decode_lower 'v' = '%'
decode_lower ch = error $ "decode_lower can't handle this char `"++[ch]++"'"
decode_num_esc :: Char -> [Char] -> String
decode_num_esc d cs
= go (digitToInt d) cs
where
go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest
go n ('U' : rest) = chr n : decode rest
go _ other = error $
"decode_num_esc can't handle this: \""++other++"\""
encode_ch :: Char -> EncodedString
encode_ch c | unencodedChar c = [c]
encode_ch '(' = "ZL"
encode_ch ')' = "ZR"
encode_ch '[' = "ZM"
encode_ch ']' = "ZN"
encode_ch ':' = "ZC"
encode_ch 'Z' = "ZZ"
encode_ch 'z' = "zz"
encode_ch '&' = "za"
encode_ch '|' = "zb"
encode_ch '^' = "zc"
encode_ch '$' = "zd"
encode_ch '=' = "ze"
encode_ch '>' = "zg"
encode_ch '#' = "zh"
encode_ch '.' = "zi"
encode_ch '<' = "zl"
encode_ch '-' = "zm"
encode_ch '!' = "zn"
encode_ch '+' = "zp"
encode_ch '\'' = "zq"
encode_ch '\\' = "zr"
encode_ch '/' = "zs"
encode_ch '*' = "zt"
encode_ch '_' = "zu"
encode_ch '%' = "zv"
encode_ch c = 'z' : shows (ord c) "U"
decode_tuple :: Char -> EncodedString -> String
decode_tuple d cs
= go (digitToInt d) cs
where
go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest
go 0 ['T'] = "()"
go n ['T'] = '(' : replicate (n1) ',' ++ ")"
go 1 ['H'] = "(# #)"
go n ['H'] = '(' : '#' : replicate (n1) ',' ++ "#)"
go _ other = error $ "decode_tuple \'"++other++"'"
isSublistOf :: Eq a => [a] -> [a] -> Bool
isSublistOf [] _ = True
isSublistOf _ [] = False
isSublistOf x y@(_:ys)
| isPrefixOf x y = True
| otherwise = isSublistOf x ys