    -----------------------------------------------------------------------------
    -- |
    -- Module      :  ReadFirst
    -- Copyright   :  2004 Malcolm Wallace
    -- Licence     :  LGPL
    --
    -- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
    -- Stability   :  experimental
    -- Portability :  All
    --
    -- Read the first file that matches in a list of search paths.
    -----------------------------------------------------------------------------

    module Language.Preprocessor.Cpphs.ReadFirst
      ( readFirst
      , readFileUTF8
      , writeFileUTF8
      ) where

    import System.IO
    import System.Directory (doesFileExist)
    import Data.List        (intersperse)
    import Control.Exception as E
    import Control.Monad    (when)
    import Language.Preprocessor.Cpphs.Position  (Posn,directory,cleanPath)

    -- | Attempt to read the given file from any location within the search path.
    --   The first location found is returned, together with the file content.
    --   (The directory of the calling file is always searched first, then
    --    the current directory, finally any specified search path.)
    readFirst :: String             -- ^ filename
            -> Posn                 -- ^ inclusion point
            -> [String]             -- ^ search path
            -> Bool                 -- ^ report warnings?
            -> IO ( FilePath
                  , String
                  )                 -- ^ discovered filepath, and file contents

    readFirst :: String -> Posn -> [String] -> Bool -> IO (String, String)
    readFirst String
    name Posn
    demand [String]
    path Bool
    warn =
        case String
    name of
                           -- Windows drive in absolute path
           Char
    c:Char
    ':':Char
    '\\':String
    nm-> String -> Maybe String -> [String] -> IO (String, String)
    try String
    nm   (String -> Maybe String
    forall a. a -> Maybe a
    Just (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    ':'Char -> String -> String
    forall a. a -> [a] -> [a]
    :[])) [String
    ""]
           Char
    c:Char
    ':':Char
    '/':String
    nm -> String -> Maybe String -> [String] -> IO (String, String)
    try String
    nm   (String -> Maybe String
    forall a. a -> Maybe a
    Just (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    ':'Char -> String -> String
    forall a. a -> [a] -> [a]
    :[])) [String
    ""]
                           -- Windows drive in relative path
           Char
    c:Char
    ':':String
    nm     -> String -> Maybe String -> [String] -> IO (String, String)
    try String
    nm   (String -> Maybe String
    forall a. a -> Maybe a
    Just (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    ':'Char -> String -> String
    forall a. a -> [a] -> [a]
    :[])) (String -> [String] -> [String]
    forall {t :: * -> *} {a}. Foldable t => t a -> [t a] -> [t a]
    cons String
    dd (String
    "."String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :[String]
    path))
                           -- unix-like absolute path
           Char
    '/':String
    nm       -> String -> Maybe String -> [String] -> IO (String, String)
    try String
    nm   Maybe String
    forall a. Maybe a
    Nothing           [String
    ""]
                           -- any relative path
           String
    _            -> String -> Maybe String -> [String] -> IO (String, String)
    try String
    name Maybe String
    forall a. Maybe a
    Nothing           (String -> [String] -> [String]
    forall {t :: * -> *} {a}. Foldable t => t a -> [t a] -> [t a]
    cons String
    dd (String
    "."String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :[String]
    path))
      where
        dd :: String
    dd = Posn -> String
    directory Posn
    demand
        cons :: t a -> [t a] -> [t a]
    cons t a
    x [t a]
    xs = if t a -> Bool
    forall a. t a -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null t a
    x then [t a]
    xs else t a
    xt a -> [t a] -> [t a]
    forall a. a -> [a] -> [a]
    :[t a]
    xs
        try :: String -> Maybe String -> [String] -> IO (String, String)
    try String
    name Maybe String
    _ [] = do
            Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    warn (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
              Handle -> String -> IO ()
    hPutStrLn Handle
    stderr (String
    "Warning: Can't find file \""String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    name
                               String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "\" in directories\n\t"
                               String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++[String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat (String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    intersperse String
    "\n\t" (String -> [String] -> [String]
    forall {t :: * -> *} {a}. Foldable t => t a -> [t a] -> [t a]
    cons String
    dd (String
    "."String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :[String]
    path)))
                               String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "\n  Asked for by: "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++Posn -> String
    forall a. Show a => a -> String
    show Posn
    demand)
            (String, String) -> IO (String, String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String
    "missing file: "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    name,String
    "")
        try String
    name Maybe String
    drive (String
    p:[String]
    ps) = do
            let file :: String
    file = ((String -> String)
    -> (String -> String -> String) -> Maybe String -> String -> String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe String -> String
    forall a. a -> a
    id String -> String -> String
    forall a. [a] -> [a] -> [a]
    (++) Maybe String
    drive) (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String -> String
    cleanPath String
    pString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++Char
    '/'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String -> String
    cleanPath String
    name
            ok <- String -> IO Bool
    doesFileExist String
    file
            if not ok then try name drive ps
              else do content <- readFileUTF8 file
                      return (file,content)

    readFileUTF8 :: FilePath -> IO String
    readFileUTF8 :: String -> IO String
    readFileUTF8 String
    file = do
        h <- String -> IOMode -> IO Handle
    openFile String
    file IOMode
    ReadMode
        (do utf8r <- mkTextEncoding "UTF-8//ROUNDTRIP"
            hSetEncoding h utf8r
            hGetContents h) `E.onException` (hClose h)

    writeFileUTF8 :: FilePath -> String -> IO ()
    writeFileUTF8 :: String -> String -> IO ()
    writeFileUTF8 String
    f String
    txt = String -> IOMode -> (Handle -> IO ()) -> IO ()
    forall r. String -> IOMode -> (Handle -> IO r) -> IO r
    withFile String
    f IOMode
    WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \Handle
    hdl->
                              do utf8r <- String -> IO TextEncoding
    mkTextEncoding String
    "UTF-8//ROUNDTRIP"
                                 hSetEncoding hdl utf8r
                                 hPutStr hdl txt
                              IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO a
    `E.onException` (Handle -> IO ()
    hClose Handle
    hdl)