module Language.Fortran.Util.Files
  ( flexReadFile
  , runCPP
  , getDirContents
  , rGetDirContents
  , expandDirs
  , listFortranFiles
  , listDirectoryRecursively
  ) where

import qualified Data.Text.Encoding         as T
import qualified Data.Text.Encoding.Error   as T
import qualified Data.ByteString.Char8      as B
import           System.Directory (listDirectory, canonicalizePath,
                                   doesDirectoryExist, getDirectoryContents)
import           System.FilePath  ((</>), takeExtension)
import           System.IO.Temp   (withSystemTempDirectory)
import           System.Process   (callProcess)
import           Data.List        ((\\), foldl')
import           Data.Char        (isNumber, toLower)
-- | Obtain a UTF-8 safe 'B.ByteString' representation of a file's contents.
--
-- Invalid UTF-8 is replaced with the space character.
flexReadFile :: FilePath -> IO B.ByteString
flexReadFile :: [Char] -> IO ByteString
flexReadFile = (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> ByteString
T.encodeUtf8 (Text -> ByteString)
-> (ByteString -> Text) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
T.decodeUtf8With (Char -> OnDecodeError
forall b a. b -> OnError a b
T.replace Char
' ')) (IO ByteString -> IO ByteString)
-> ([Char] -> IO ByteString) -> [Char] -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ByteString
B.readFile

-- | List files in directory, with the directory prepended to each entry.
getDirContents :: FilePath -> IO [FilePath]
getDirContents :: [Char] -> IO [[Char]]
getDirContents [Char]
d = do
  [Char]
d' <- [Char] -> IO [Char]
canonicalizePath [Char]
d
  ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
d' [Char] -> [Char] -> [Char]
</>) ([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [Char] -> IO [[Char]]
listDirectory [Char]
d'

-- | List files in directory recursively.
rGetDirContents :: FilePath -> IO [FilePath]
rGetDirContents :: [Char] -> IO [[Char]]
rGetDirContents [Char]
d = [Char] -> IO [Char]
canonicalizePath [Char]
d IO [Char] -> ([Char] -> IO [[Char]]) -> IO [[Char]]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
d' -> [[Char]] -> [Char] -> IO [[Char]]
go [[Char]
d'] [Char]
d'
  where
    go :: [[Char]] -> [Char] -> IO [[Char]]
go [[Char]]
seen [Char]
d'' = do
      [[Char]]
ds <- [Char] -> IO [[Char]]
getDirectoryContents [Char]
d''
      ([[[Char]]] -> [[Char]]) -> IO [[[Char]]] -> IO [[Char]]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[[Char]]] -> IO [[Char]])
-> ([[Char]] -> IO [[[Char]]]) -> [[Char]] -> IO [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> IO [[Char]]) -> [[Char]] -> IO [[[Char]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> IO [[Char]]
f ([[Char]] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]]
ds [[Char]] -> [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [a]
\\ [[Char]
".", [Char]
".."] -- remove '.' and '..' entries
        where
          f :: [Char] -> IO [[Char]]
f [Char]
x = do
            [Char]
path <- [Char] -> IO [Char]
canonicalizePath ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
d [Char] -> [Char] -> [Char]
</> [Char]
x
            Bool
g <- [Char] -> IO Bool
doesDirectoryExist [Char]
path
            if Bool
g Bool -> Bool -> Bool
&& [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem [Char]
path [[Char]]
seen then do
              [[Char]]
x' <- [[Char]] -> [Char] -> IO [[Char]]
go ([Char]
path [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
seen) [Char]
path
              [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\ [Char]
y -> [Char]
x [Char] -> [Char] -> [Char]
</> [Char]
y) [[Char]]
x'
            else [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Char]
x]

-- | Run the C Pre Processor over the file before reading into a bytestring
runCPP :: Maybe String -> FilePath -> IO B.ByteString
runCPP :: Maybe [Char] -> [Char] -> IO ByteString
runCPP Maybe [Char]
Nothing [Char]
path          = [Char] -> IO ByteString
flexReadFile [Char]
path -- Nothing = do not run CPP
runCPP (Just [Char]
cppOpts) [Char]
path   = do
  -- Fold over the lines, skipping CPP pragmas and inserting blank
  -- lines as needed to make the line numbers match up for the current
  -- file. CPP pragmas for other files are just ignored.
  let processCPPLine :: ([B.ByteString], Int) -> B.ByteString -> ([B.ByteString], Int)
      processCPPLine :: ([ByteString], Int) -> ByteString -> ([ByteString], Int)
processCPPLine ([ByteString]
revLs, Int
curLineNo) ByteString
curLine
        | ByteString -> Bool
B.null ByteString
curLine Bool -> Bool -> Bool
|| ByteString -> Char
B.head ByteString
curLine Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#' = (ByteString
curLineByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
revLs, Int
curLineNo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        | [Char]
linePath [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
path                        = ([ByteString]
revLs, Int
curLineNo)
        | Int
newLineNo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
curLineNo                  = ([ByteString]
revLs, Int
curLineNo)
        | Bool
otherwise                               = (Int -> ByteString -> [ByteString]
forall a. Int -> a -> [a]
replicate (Int
newLineNo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
curLineNo) ByteString
B.empty [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString]
revLs,
                                                     Int
newLineNo)
          where
            newLineNo :: Int
newLineNo = [Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int) -> (ByteString -> [Char]) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
B.unpack (ByteString -> [Char])
-> (ByteString -> ByteString) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
B.takeWhile Char -> Bool
isNumber (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
B.drop Int
2 (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ ByteString
curLine
            linePath :: [Char]
linePath = ByteString -> [Char]
B.unpack (ByteString -> [Char])
-> (ByteString -> ByteString) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
B.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'"') (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
B.drop Int
1 (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
B.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'"') (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString
curLine

  [Char] -> ([Char] -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> ([Char] -> m a) -> m a
withSystemTempDirectory [Char]
"fortran-src" (([Char] -> IO ByteString) -> IO ByteString)
-> ([Char] -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ [Char]
tmpdir -> do
    let outfile :: [Char]
outfile = [Char]
tmpdir [Char] -> [Char] -> [Char]
</> [Char]
"cpp.out"
    [Char] -> [[Char]] -> IO ()
callProcess [Char]
"cpp" ([[Char]] -> IO ()) -> [[Char]] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
words [Char]
cppOpts [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"-CC", [Char]
"-nostdinc", [Char]
"-o", [Char]
outfile, [Char]
path]
    ByteString
contents <- [Char] -> IO ByteString
flexReadFile [Char]
outfile
    let ls :: [ByteString]
ls = ByteString -> [ByteString]
B.lines ByteString
contents
    let ls' :: [ByteString]
ls' = [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse ([ByteString] -> [ByteString])
-> (([ByteString], Int) -> [ByteString])
-> ([ByteString], Int)
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ByteString], Int) -> [ByteString]
forall a b. (a, b) -> a
fst (([ByteString], Int) -> [ByteString])
-> ([ByteString], Int) -> [ByteString]
forall a b. (a -> b) -> a -> b
$ (([ByteString], Int) -> ByteString -> ([ByteString], Int))
-> ([ByteString], Int) -> [ByteString] -> ([ByteString], Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([ByteString], Int) -> ByteString -> ([ByteString], Int)
processCPPLine ([], Int
1) [ByteString]
ls
    ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.unlines [ByteString]
ls'

-- | Expand all paths that are directories into a list of Fortran
-- files from a recursive directory listing.
expandDirs :: [FilePath] -> IO [FilePath]
expandDirs :: [[Char]] -> IO [[Char]]
expandDirs = ([[[Char]]] -> [[Char]]) -> IO [[[Char]]] -> IO [[Char]]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[[Char]]] -> IO [[Char]])
-> ([[Char]] -> IO [[[Char]]]) -> [[Char]] -> IO [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> IO [[Char]]) -> [[Char]] -> IO [[[Char]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> IO [[Char]]
each
  where
    each :: [Char] -> IO [[Char]]
each [Char]
path = do
      Bool
isDir <- [Char] -> IO Bool
doesDirectoryExist [Char]
path
      if Bool
isDir
        then [Char] -> IO [[Char]]
listFortranFiles [Char]
path
        else [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
path]

-- | Get a list of Fortran files under the given directory.
listFortranFiles :: FilePath -> IO [FilePath]
listFortranFiles :: [Char] -> IO [[Char]]
listFortranFiles [Char]
dir = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
isFortran ([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [[Char]]
listDirectoryRecursively [Char]
dir
  where
    -- | True if the file has a valid fortran extension.
    isFortran :: FilePath -> Bool
    isFortran :: [Char] -> Bool
isFortran [Char]
x = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]
takeExtension [Char]
x) [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
exts
      where exts :: [[Char]]
exts = [[Char]
".f", [Char]
".f90", [Char]
".f77", [Char]
".f03"]

listDirectoryRecursively :: FilePath -> IO [FilePath]
listDirectoryRecursively :: [Char] -> IO [[Char]]
listDirectoryRecursively [Char]
dir = [Char] -> [Char] -> IO [[Char]]
listDirectoryRec [Char]
dir [Char]
""
  where
    listDirectoryRec :: FilePath -> FilePath -> IO [FilePath]
    listDirectoryRec :: [Char] -> [Char] -> IO [[Char]]
listDirectoryRec [Char]
d [Char]
f = do
      let fullPath :: [Char]
fullPath = [Char]
d [Char] -> [Char] -> [Char]
</> [Char]
f
      Bool
isDir <- [Char] -> IO Bool
doesDirectoryExist [Char]
fullPath
      if Bool
isDir
      then do
        [[Char]]
conts <- [Char] -> IO [[Char]]
listDirectory [Char]
fullPath
        [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [[Char]]) -> IO [[[Char]]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> IO [[Char]]) -> [[Char]] -> IO [[[Char]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Char] -> [Char] -> IO [[Char]]
listDirectoryRec [Char]
fullPath) [[Char]]
conts
      else [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
fullPath]