{-# LANGUAGE CPP, ScopedTypeVariables #-}
--
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
-- USA
--

module System.Plugins.Utils (
    Arg,

    hWrite,

    mkUnique,
    hMkUnique,
    mkUniqueIn,
    hMkUniqueIn,

    findFile,

    mkTemp, mkTempIn, {- internal -}

    replaceSuffix,
    outFilePath,
    dropSuffix,
    mkModid,
    changeFileExt,
    joinFileExt,
    splitFileExt,

    isSublistOf,                -- :: Eq a => [a] -> [a] -> Bool

    dirname,
    basename,

    (</>), (<.>), (<+>), (<>),

    newer,

    encode,
    decode,
    EncodedString,

    panic

  ) where


#include "config.h"

import System.Plugins.Env              ( isLoaded )
import System.Plugins.Consts           ( objSuf, hiSuf, tmpDir )

import Foreign.C (CInt(..), CString, withCString)
import Foreign.C.Error (Errno, eEXIST, getErrno, errnoToIOError)
import System.Posix.Internals
import System.Posix.Types (CMode)

import Control.Exception               (IOException, catch)
import Data.Bits
import Data.Char
import Data.List
import Prelude hiding (catch)

import System.IO hiding (openBinaryTempFile, openTempFile)
import System.Random (randomRIO)

import GHC.IO.Encoding (getLocaleEncoding)
import GHC.IO.Handle.FD
import qualified GHC.IO.FD as FD
import System.Environment           ( getEnv )
import System.Directory             ( doesFileExist, getModificationTime, removeFile )
import System.FilePath (pathSeparator)


-- ---------------------------------------------------------------------
-- some misc types we use

type Arg = String

-- ---------------------------------------------------------------------
-- | useful
--
panic :: String -> IO a
panic String
s = IOError -> IO a
forall a. IOError -> IO a
ioError ( String -> IOError
userError String
s )

-- ---------------------------------------------------------------------
-- | writeFile for Handles
--
hWrite :: Handle -> String -> IO ()
hWrite :: Handle -> String -> IO ()
hWrite Handle
hdl String
src = Handle -> String -> IO ()
hPutStr Handle
hdl String
src IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
hdl IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- ---------------------------------------------------------------------
-- | openTempFile.
--
-- System.IO.openTempFile uses undesirable characters in its filenames, which
-- breaks e.g. merge and other functions that try to compile Haskell source.
-- Sadly, this means we must provide our own secure temporary file facility.
--

openTempFile :: FilePath   -- ^ Directory in which to create the file
             -> String     -- ^ File name prefix. If the prefix is \"fooie\",
                           -- the full name will be \"fooie\" followed by six
                           -- random alphanumeric characters followed by, if
                           -- given, the suffix.  Should not contain any path
                           -- separator characters.
             -> String     -- ^ File name suffix.  Should not contain any path
                           -- separator characters.
             -> IO (FilePath, Handle)
openTempFile :: String -> String -> String -> IO (String, Handle)
openTempFile String
tmp_dir String
pfx String
sfx
    = String
-> String
-> String
-> String
-> Bool
-> CMode
-> IO (String, Handle)
openTempFile' String
"openTempFile" String
tmp_dir String
pfx String
sfx Bool
False CMode
0o600

-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
openBinaryTempFile :: FilePath -> String -> String -> IO (FilePath, Handle)
openBinaryTempFile :: String -> String -> String -> IO (String, Handle)
openBinaryTempFile String
tmp_dir String
pfx String
sfx
    = String
-> String
-> String
-> String
-> Bool
-> CMode
-> IO (String, Handle)
openTempFile' String
"openBinaryTempFile" String
tmp_dir String
pfx String
sfx Bool
True CMode
0o600

-- | Like 'openTempFile', but uses the default file permissions
openTempFileWithDefaultPermissions :: FilePath -> String -> String
                                   -> IO (FilePath, Handle)
openTempFileWithDefaultPermissions :: String -> String -> String -> IO (String, Handle)
openTempFileWithDefaultPermissions String
tmp_dir String
pfx String
sfx
    = String
-> String
-> String
-> String
-> Bool
-> CMode
-> IO (String, Handle)
openTempFile' String
"openTempFileWithDefaultPermissions" String
tmp_dir String
pfx String
sfx Bool
False CMode
0o666

-- | Like 'openBinaryTempFile', but uses the default file permissions
openBinaryTempFileWithDefaultPermissions :: FilePath -> String -> String
                                         -> IO (FilePath, Handle)
openBinaryTempFileWithDefaultPermissions :: String -> String -> String -> IO (String, Handle)
openBinaryTempFileWithDefaultPermissions String
tmp_dir String
pfx String
sfx
    = String
-> String
-> String
-> String
-> Bool
-> CMode
-> IO (String, Handle)
openTempFile' String
"openBinaryTempFileWithDefaultPermissions" String
tmp_dir String
pfx String
sfx Bool
True CMode
0o666

badfnmsg :: String
badfnmsg :: String
badfnmsg = String
"openTempFile': Template string must not contain path separator characters: "

openTempFile' :: String -> FilePath -> String -> String -> Bool -> CMode
              -> IO (FilePath, Handle)
openTempFile' :: String
-> String
-> String
-> String
-> Bool
-> CMode
-> IO (String, Handle)
openTempFile' String
loc String
tmp_dir String
pfx String
sfx Bool
binary CMode
mode
    | Char
pathSeparator Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
pfx
    = String -> IO (String, Handle)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (String, Handle)) -> String -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ String
badfnmsgString -> String -> String
forall a. [a] -> [a] -> [a]
++String
pfx
    | Char
pathSeparator Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
sfx
    = String -> IO (String, Handle)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (String, Handle)) -> String -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ String
badfnmsgString -> String -> String
forall a. [a] -> [a] -> [a]
++String
sfx
    | Bool
otherwise = IO (String, Handle)
findTempName
  where
    findTempName :: IO (String, Handle)
findTempName = do
      String
filename <- String -> String -> String -> IO String
mkTempFileName String
tmp_dir String
pfx String
sfx
      OpenNewFileResult
r <- String -> Bool -> CMode -> IO OpenNewFileResult
openNewFile String
filename Bool
binary CMode
mode
      case OpenNewFileResult
r of
        OpenNewFileResult
FileExists -> IO (String, Handle)
findTempName
        OpenNewError Errno
errno -> IOError -> IO (String, Handle)
forall a. IOError -> IO a
ioError (String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
loc Errno
errno Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
tmp_dir))
        NewFileCreated CInt
fd -> do
          (FD
fD,IODeviceType
fd_type) <- CInt
-> IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Bool
-> Bool
-> IO (FD, IODeviceType)
FD.mkFD CInt
fd IOMode
ReadWriteMode Maybe (IODeviceType, CDev, CIno)
forall a. Maybe a
Nothing{-no stat-}
                          Bool
False{-is_socket-}
                          Bool
True{-is_nonblock-}

          TextEncoding
enc <- IO TextEncoding
getLocaleEncoding
          Handle
h <- FD
-> IODeviceType
-> String
-> IOMode
-> Bool
-> Maybe TextEncoding
-> IO Handle
mkHandleFromFD FD
fD IODeviceType
fd_type String
filename IOMode
ReadWriteMode Bool
False{-set non-block-} (TextEncoding -> Maybe TextEncoding
forall a. a -> Maybe a
Just TextEncoding
enc)

          (String, Handle) -> IO (String, Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
filename, Handle
h)

mkTempFileName :: FilePath -> String -> String -> IO String
mkTempFileName :: String -> String -> String -> IO String
mkTempFileName String
dir String
pfx String
sfx = do
  let rs :: String
rs = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAlphaNum [Char
'0'..Char
'z']
      maxInd :: Int
maxInd = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
rs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      rchoose :: IO Char
rchoose = do
        Int
i <- (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0, Int
maxInd)
        Char -> IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return (String
rs String -> Int -> Char
forall a. [a] -> Int -> a
!! Int
i)
  String
rnd <- [IO Char] -> IO String
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([IO Char] -> IO String) -> [IO Char] -> IO String
forall a b. (a -> b) -> a -> b
$ Int -> IO Char -> [IO Char]
forall a. Int -> a -> [a]
replicate Int
6 IO Char
rchoose
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
pfx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rnd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sfx

data OpenNewFileResult
  = NewFileCreated CInt
  | FileExists
  | OpenNewError Errno

openNewFile :: FilePath -> Bool -> CMode -> IO OpenNewFileResult
openNewFile :: String -> Bool -> CMode -> IO OpenNewFileResult
openNewFile String
filepath Bool
binary CMode
mode = do
  let oflags1 :: CInt
oflags1 = CInt
rw_flags CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
o_EXCL

      binary_flags :: CInt
binary_flags
        | Bool
binary    = CInt
o_BINARY
        | Bool
otherwise = CInt
0

      oflags :: CInt
oflags = CInt
oflags1 CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
binary_flags
  CInt
fd <- String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withFilePath String
filepath ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \ CString
f ->
          CString -> CInt -> CMode -> IO CInt
c_open CString
f CInt
oflags CMode
mode
  if CInt
fd CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0
    then do
      Errno
errno <- IO Errno
getErrno
      case Errno
errno of
        Errno
_ | Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eEXIST -> OpenNewFileResult -> IO OpenNewFileResult
forall (m :: * -> *) a. Monad m => a -> m a
return OpenNewFileResult
FileExists
#ifdef mingw32_HOST_OS
        -- If c_open throws EACCES on windows, it could mean that filepath is a
        -- directory. In this case, we want to return FileExists so that the
        -- enclosing openTempFile can try again instead of failing outright.
        -- See bug #4968.
        _ | errno == eACCES -> do
          withCString filepath $ \path -> do
            -- There is a race here: the directory might have been moved or
            -- deleted between the c_open call and the next line, but there
            -- doesn't seem to be any direct way to detect that the c_open call
            -- failed because of an existing directory.
            exists <- c_fileExists path
            return $ if exists
              then FileExists
              else OpenNewError errno
#endif
        Errno
_ -> OpenNewFileResult -> IO OpenNewFileResult
forall (m :: * -> *) a. Monad m => a -> m a
return (Errno -> OpenNewFileResult
OpenNewError Errno
errno)
    else OpenNewFileResult -> IO OpenNewFileResult
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> OpenNewFileResult
NewFileCreated CInt
fd)

#ifdef mingw32_HOST_OS
foreign import ccall "file_exists" c_fileExists :: CString -> IO Bool
#endif

-- XXX Copied from GHC.Handle
std_flags, output_flags, rw_flags :: CInt
std_flags :: CInt
std_flags    = CInt
o_NONBLOCK   CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
o_NOCTTY
output_flags :: CInt
output_flags = CInt
std_flags    CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
o_CREAT
rw_flags :: CInt
rw_flags     = CInt
output_flags CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
o_RDWR

-- ---------------------------------------------------------------------
-- | create a new temp file, returning name and handle.
-- bit like the mktemp shell utility
--
mkTemp :: IO (String,Handle)
mkTemp :: IO (String, Handle)
mkTemp = do String
tmpd  <- IO String -> (IOError -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (String -> IO String
getEnv String
"TMPDIR") (\ (IOError
_ :: IOException) -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
tmpDir)
            String -> IO (String, Handle)
mkTempIn String
tmpd

mkTempIn :: String -> IO (String, Handle)
mkTempIn :: String -> IO (String, Handle)
mkTempIn String
tmpd = do
        (String
tmpf, Handle
hdl) <- String -> String -> String -> IO (String, Handle)
openTempFile String
tmpd String
"Hsplugins" String
".hs"
        let modname :: String
modname = String -> String
mkModid String
tmpf
        if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') String
modname
                then (String, Handle) -> IO (String, Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
tmpf,Handle
hdl)
                else String -> IO (String, Handle)
forall a. String -> IO a
panic (String -> IO (String, Handle)) -> String -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ String
"Illegal characters in temp file: `"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
tmpfString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

-- ---------------------------------------------------------------------
-- | Get a new temp file, unique from those in /tmp, and from those
-- modules already loaded. Very nice for merge/eval uses.
--
-- Will run for a long time if we can't create a temp file, luckily
-- mkstemps gives us a pretty big search space
--
mkUnique :: IO FilePath
mkUnique :: IO String
mkUnique = do (String
t,Handle
h) <- IO (String, Handle)
hMkUnique
              Handle -> IO ()
hClose Handle
h IO () -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
t

hMkUnique :: IO (FilePath,Handle)
hMkUnique :: IO (String, Handle)
hMkUnique = do (String
t,Handle
h) <- IO (String, Handle)
mkTemp
               Bool
alreadyLoaded <- String -> IO Bool
isLoaded String
t -- not unique!
               if Bool
alreadyLoaded
                        then Handle -> IO ()
hClose Handle
h IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
removeFile String
t IO () -> IO (String, Handle) -> IO (String, Handle)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (String, Handle)
hMkUnique
                        else (String, Handle) -> IO (String, Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
t,Handle
h)

mkUniqueIn :: FilePath -> IO FilePath
mkUniqueIn :: String -> IO String
mkUniqueIn String
dir = do (String
t,Handle
h) <- String -> IO (String, Handle)
hMkUniqueIn String
dir
                    Handle -> IO ()
hClose Handle
h IO () -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
t

hMkUniqueIn :: FilePath -> IO (FilePath,Handle)
hMkUniqueIn :: String -> IO (String, Handle)
hMkUniqueIn String
dir = do (String
t,Handle
h) <- String -> IO (String, Handle)
mkTempIn String
dir
                     Bool
alreadyLoaded <- String -> IO Bool
isLoaded String
t -- not unique!
                     if Bool
alreadyLoaded
                        then Handle -> IO ()
hClose Handle
h IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
removeFile String
t IO () -> IO (String, Handle) -> IO (String, Handle)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO (String, Handle)
hMkUniqueIn String
dir
                        else (String, Handle) -> IO (String, Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
t,Handle
h)

findFile :: [String] -> FilePath -> IO (Maybe FilePath)
findFile :: [String] -> String -> IO (Maybe String)
findFile [] String
_  = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
findFile (String
ext:[String]
exts) String
file
    = do let l :: String
l = String -> String -> String
changeFileExt String
file String
ext
         Bool
b <- String -> IO Bool
doesFileExist String
l
         if Bool
b then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
l
              else [String] -> String -> IO (Maybe String)
findFile [String]
exts String
file

-- ---------------------------------------------------------------------
-- some filename manipulation stuff

--
-- | </>, <.> : join two path components
--
infixr 6 </>
infixr 6 <.>

(</>), (<.>), (<+>) :: FilePath -> FilePath -> FilePath
[] </> :: String -> String -> String
</> String
b = String
b
String
a  </> String
b = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b

[] <.> :: String -> String -> String
<.> String
b = String
b
String
a  <.> String
b = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b

[] <+> :: String -> String -> String
<+> String
b = String
b
String
a  <+> String
b = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b

--
-- | dirname : return the directory portion of a file path
-- if null, return "."
--
dirname :: FilePath -> FilePath
dirname :: String -> String
dirname String
p  =
    let x :: [Int]
x = (Char -> Bool) -> String -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\') String
p
        y :: [Int]
y = (Char -> Bool) -> String -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') String
p
    in
    if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
x
      then if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
y
          then if ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
x) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
y) then Char -> String -> String
dirname' Char
'\\' String
p else Char -> String -> String
dirname' Char
'/' String
p
          else Char -> String -> String
dirname' Char
'\\' String
p
      else Char -> String -> String
dirname' Char
'/' String
p
    where
        dirname' :: Char -> String -> String
dirname' Char
chara String
pa =
            case String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
chara) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
pa of
                [] -> String
"."
                String
pa' -> String
pa'

--
-- | basename : return the filename portion of a path
--
basename :: FilePath -> FilePath
basename :: String -> String
basename String
p =
    let x :: [Int]
x = (Char -> Bool) -> String -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\') String
p
        y :: [Int]
y = (Char -> Bool) -> String -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') String
p
    in
    if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
x
      then if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
y
          then if ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
x) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
y) then Char -> String -> String
forall a. Eq a => a -> [a] -> [a]
basename' Char
'\\' String
p else Char -> String -> String
forall a. Eq a => a -> [a] -> [a]
basename' Char
'/' String
p
          else Char -> String -> String
forall a. Eq a => a -> [a] -> [a]
basename' Char
'\\' String
p
      else Char -> String -> String
forall a. Eq a => a -> [a] -> [a]
basename' Char
'/' String
p
    where
        basename' :: a -> [a] -> [a]
basename' a
chara [a]
pa = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
chara) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
pa

--
-- drop suffix
--
dropSuffix :: FilePath -> FilePath
dropSuffix :: String -> String
dropSuffix String
f = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
tail (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
f

--
-- | work out the mod name from a filepath
mkModid :: String -> String
mkModid :: String -> String
mkModid = ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.')) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
x -> (Char
'/'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
x) Bool -> Bool -> Bool
&& (Char
'\\' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
x))) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse


-----------------------------------------------------------
-- Code from Cabal ----------------------------------------

-- | Changes the extension of a file path.
changeFileExt :: FilePath           -- ^ The path information to modify.
              -> String             -- ^ The new extension (without a leading period).
                                    -- Specify an empty string to remove an existing
                                    -- extension from path.
              -> FilePath           -- ^ A string containing the modified path information.
changeFileExt :: String -> String -> String
changeFileExt String
fpath String
ext = String -> String -> String
joinFileExt String
name String
ext
  where
    (String
name,String
_) = String -> (String, String)
splitFileExt String
fpath

-- | The 'joinFileExt' function is the opposite of 'splitFileExt'.
-- It joins a file name and an extension to form a complete file path.
--
-- The general rule is:
--
-- > filename `joinFileExt` ext == path
-- >   where
-- >     (filename,ext) = splitFileExt path
joinFileExt :: String -> String -> FilePath
joinFileExt :: String -> String -> String
joinFileExt String
fpath String
""  = String
fpath
joinFileExt String
fpath String
ext = String
fpath String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'.'Char -> String -> String
forall a. a -> [a] -> [a]
:String
ext

-- | Split the path into file name and extension. If the file doesn\'t have extension,
-- the function will return empty string. The extension doesn\'t include a leading period.
--
-- Examples:
--
-- > splitFileExt "foo.ext" == ("foo", "ext")
-- > splitFileExt "foo"     == ("foo", "")
-- > splitFileExt "."       == (".",   "")
-- > splitFileExt ".."      == ("..",  "")
-- > splitFileExt "foo.bar."== ("foo.bar.", "")
splitFileExt :: FilePath -> (String, String)
splitFileExt :: String -> (String, String)
splitFileExt String
p =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') String
fname of
        (suf :: String
suf@(Char
_:String
_),Char
_:String
pre) -> (String -> String
forall a. [a] -> [a]
reverse (String
preString -> String -> String
forall a. [a] -> [a] -> [a]
++String
fpath), String -> String
forall a. [a] -> [a]
reverse String
suf)
        (String, String)
_                 -> (String
p, [])
  where
    (String
fname,String
fpath) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isPathSeparator (String -> String
forall a. [a] -> [a]
reverse String
p)

-- | Checks whether the character is a valid path separator for the host
-- platform. The valid character is a 'pathSeparator' but since the Windows
-- operating system also accepts a slash (\"\/\") since DOS 2, the function
-- checks for it on this platform, too.
isPathSeparator :: Char -> Bool
isPathSeparator :: Char -> Bool
isPathSeparator Char
ch =
#if defined(CYGWIN) || defined(__MINGW32__)
  ch == '/' || ch == '\\'
#else
  Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'
#endif

-- Code from Cabal end ------------------------------------
-----------------------------------------------------------


-- | return the object file, given the .conf file
-- i.e. /home/dons/foo.rc -> /home/dons/foo.o
--
-- we depend on the suffix we are given having a lead '.'
--
replaceSuffix :: FilePath -> String -> FilePath
replaceSuffix :: String -> String -> String
replaceSuffix [] String
_ = [] -- ?
replaceSuffix String
f String
suf =
    case String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
f of
        [] -> String
f  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suf                 -- no '.' in file name
        String
f' -> String
f' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
tail String
suf

--
-- Normally we create the .hi and .o files next to the .hs files.
-- For some uses this is annoying (i.e. true EDSL users don't actually
-- want to know that their code is compiled at all), and for hmake-like
-- applications.
--
-- This code checks if "-o foo" or "-odir foodir" are supplied as args
-- to make(), and if so returns a modified file path, otherwise it
-- uses the source file to determing the path to where the object and
-- .hi file will be put.
--
outFilePath :: FilePath -> [Arg] -> (FilePath,FilePath)
outFilePath :: String -> [String] -> (String, String)
outFilePath String
src [String]
args =
    let objs :: [String]
objs  = [String] -> [String]
find_o [String]
args -- user sets explicit object path
        paths :: [String]
paths = [String] -> [String]
find_p [String]
args -- user sets a directory to put stuff in
    in case () of { ()
_
        | Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
objs)
        -> let obj :: String
obj = [String] -> String
forall a. [a] -> a
last [String]
objs in (String
obj, String -> String
mk_hi String
obj)

        | Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
paths)
        -> let obj :: String
obj = [String] -> String
forall a. [a] -> a
last [String]
paths String -> String -> String
</> String -> String
mk_o (String -> String
basename String
src) in (String
obj, String -> String
mk_hi String
obj)

        | Bool
otherwise
        -> (String -> String
mk_o String
src, String -> String
mk_hi String
src)
    }
    where
          outpath :: String
outpath = String
"-o"
          outdir :: String
outdir  = String
"-odir"

          mk_hi :: String -> String
mk_hi String
s = String -> String -> String
replaceSuffix String
s String
hiSuf
          mk_o :: String -> String
mk_o  String
s = String -> String -> String
replaceSuffix String
s String
objSuf

          find_o :: [String] -> [String]
find_o [] = []
          find_o (String
f:String
f':[String]
fs) | String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
outpath = [String
f']
                           | Bool
otherwise    = [String] -> [String]
find_o ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$! String
f'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fs
          find_o [String]
_ = []

          find_p :: [String] -> [String]
find_p [] = []
          find_p (String
f:String
f':[String]
fs) | String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
outdir  = [String
f']
                           | Bool
otherwise    = [String] -> [String]
find_p ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$! String
f'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fs
          find_p [String]
_ = []

------------------------------------------------------------------------

--
-- | is file1 newer than file2?
--
-- needs some fixing to work with 6.0.x series. (is this true?)
--
-- fileExist still seems to throw exceptions on some platforms: ia64 in
-- particular.
--
-- invarient : we already assume the first file, 'a', exists
--
newer :: FilePath -> FilePath -> IO Bool
newer :: String -> String -> IO Bool
newer String
a String
b = do
    UTCTime
a_t      <- String -> IO UTCTime
getModificationTime String
a
    Bool
b_exists <- String -> IO Bool
doesFileExist String
b
    if Bool -> Bool
not Bool
b_exists
        then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True                -- needs compiling
        else do UTCTime
b_t <- String -> IO UTCTime
getModificationTime String
b
                Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return ( UTCTime
a_t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
b_t )    -- maybe need recompiling

------------------------------------------------------------------------
--
-- | return the Z-Encoding of the string.
--
-- Stolen from GHC. Use -package ghc as soon as possible
--
type EncodedString = String

encode :: String -> EncodedString
encode :: String -> String
encode []     = []
encode (Char
c:String
cs) = Char -> String
encode_ch Char
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
encode String
cs

unencodedChar :: Char -> Bool   -- True for chars that don't need encoding
unencodedChar :: Char -> Bool
unencodedChar Char
'Z' = Bool
False
unencodedChar Char
'z' = Bool
False
unencodedChar Char
c   =  Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z'
                  Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z'
                  Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9'

--
-- Decode is used for user printing.
--
decode :: EncodedString -> String
decode :: String -> String
decode [] = []
decode (Char
'Z' : Char
d : String
rest) | Char -> Bool
isDigit Char
d = Char -> String -> String
decode_tuple   Char
d String
rest
                        | Bool
otherwise = Char -> Char
decode_upper   Char
d Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
decode String
rest
decode (Char
'z' : Char
d : String
rest) | Char -> Bool
isDigit Char
d = Char -> String -> String
decode_num_esc Char
d String
rest
                        | Bool
otherwise = Char -> Char
decode_lower   Char
d Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
decode String
rest
decode (Char
c  : String
rest) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
decode String
rest

decode_upper, decode_lower :: Char -> Char

decode_upper :: Char -> Char
decode_upper Char
'L' = Char
'('
decode_upper Char
'R' = Char
')'
decode_upper Char
'M' = Char
'['
decode_upper Char
'N' = Char
']'
decode_upper Char
'C' = Char
':'
decode_upper Char
'Z' = Char
'Z'
decode_upper Char
ch  = String -> Char
forall a. HasCallStack => String -> a
error (String -> Char) -> String -> Char
forall a b. (a -> b) -> a -> b
$ String
"decode_upper can't handle this char `"String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
ch]String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

decode_lower :: Char -> Char
decode_lower Char
'z' = Char
'z'
decode_lower Char
'a' = Char
'&'
decode_lower Char
'b' = Char
'|'
decode_lower Char
'c' = Char
'^'
decode_lower Char
'd' = Char
'$'
decode_lower Char
'e' = Char
'='
decode_lower Char
'g' = Char
'>'
decode_lower Char
'h' = Char
'#'
decode_lower Char
'i' = Char
'.'
decode_lower Char
'l' = Char
'<'
decode_lower Char
'm' = Char
'-'
decode_lower Char
'n' = Char
'!'
decode_lower Char
'p' = Char
'+'
decode_lower Char
'q' = Char
'\''
decode_lower Char
'r' = Char
'\\'
decode_lower Char
's' = Char
'/'
decode_lower Char
't' = Char
'*'
decode_lower Char
'u' = Char
'_'
decode_lower Char
'v' = Char
'%'
decode_lower Char
ch  = String -> Char
forall a. HasCallStack => String -> a
error (String -> Char) -> String -> Char
forall a b. (a -> b) -> a -> b
$ String
"decode_lower can't handle this char `"String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
ch]String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

-- Characters not having a specific code are coded as z224U
decode_num_esc :: Char -> [Char] -> String
decode_num_esc :: Char -> String -> String
decode_num_esc Char
d String
cs
  = Int -> String -> String
go (Char -> Int
digitToInt Char
d) String
cs
  where
    go :: Int -> String -> String
go Int
n (Char
c : String
rest) | Char -> Bool
isDigit Char
c = Int -> String -> String
go (Int
10Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
c) String
rest
    go Int
n (Char
'U' : String
rest)           = Int -> Char
chr Int
n Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
decode String
rest
    go Int
_ String
other = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
        String
"decode_num_esc can't handle this: \""String -> String -> String
forall a. [a] -> [a] -> [a]
++String
otherString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\""


encode_ch :: Char -> EncodedString
encode_ch :: Char -> String
encode_ch Char
c | Char -> Bool
unencodedChar Char
c = [Char
c]     -- Common case first

-- Constructors
encode_ch Char
'('  = String
"ZL"   -- Needed for things like (,), and (->)
encode_ch Char
')'  = String
"ZR"   -- For symmetry with (
encode_ch Char
'['  = String
"ZM"
encode_ch Char
']'  = String
"ZN"
encode_ch Char
':'  = String
"ZC"
encode_ch Char
'Z'  = String
"ZZ"

-- Variables
encode_ch Char
'z'  = String
"zz"
encode_ch Char
'&'  = String
"za"
encode_ch Char
'|'  = String
"zb"
encode_ch Char
'^'  = String
"zc"
encode_ch Char
'$'  = String
"zd"
encode_ch Char
'='  = String
"ze"
encode_ch Char
'>'  = String
"zg"
encode_ch Char
'#'  = String
"zh"
encode_ch Char
'.'  = String
"zi"
encode_ch Char
'<'  = String
"zl"
encode_ch Char
'-'  = String
"zm"
encode_ch Char
'!'  = String
"zn"
encode_ch Char
'+'  = String
"zp"
encode_ch Char
'\'' = String
"zq"
encode_ch Char
'\\' = String
"zr"
encode_ch Char
'/'  = String
"zs"
encode_ch Char
'*'  = String
"zt"
encode_ch Char
'_'  = String
"zu"
encode_ch Char
'%'  = String
"zv"
encode_ch Char
c    = Char
'z' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String -> String
forall a. Show a => a -> String -> String
shows (Char -> Int
ord Char
c) String
"U"

decode_tuple :: Char -> EncodedString -> String
decode_tuple :: Char -> String -> String
decode_tuple Char
d String
cs
  = Int -> String -> String
go (Char -> Int
digitToInt Char
d) String
cs
  where
    go :: Int -> String -> String
go Int
n (Char
c : String
rest) | Char -> Bool
isDigit Char
c = Int -> String -> String
go (Int
10Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
c) String
rest
    go Int
0 [Char
'T']          = String
"()"
    go Int
n [Char
'T']          = Char
'(' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
',' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    go Int
1 [Char
'H']          = String
"(# #)"
    go Int
n [Char
'H']          = Char
'(' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'#' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
',' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"#)"
    go Int
_ String
other = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"decode_tuple \'"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
otherString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

-- ---------------------------------------------------------------------

--
-- 'isSublistOf' takes two arguments and returns 'True' iff the first
-- list is a sublist of the second list. This means that the first list
-- is wholly contained within the second list. Both lists must be
-- finite.

isSublistOf :: Eq a => [a] -> [a] -> Bool
isSublistOf :: [a] -> [a] -> Bool
isSublistOf [] [a]
_ = Bool
True
isSublistOf [a]
_ [] = Bool
False
isSublistOf [a]
x y :: [a]
y@(a
_:[a]
ys)
    | [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
x [a]
y = Bool
True
    | Bool
otherwise      = [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSublistOf [a]
x [a]
ys