{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module TH.RelativePaths where
import Control.Exception (IOException, catch)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.List (find)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.IO as LT
import Language.Haskell.TH (Q, Loc(loc_filename), location, runIO, reportWarning)
import Language.Haskell.TH.Syntax (addDependentFile)
import System.Directory (getDirectoryContents, getCurrentDirectory, setCurrentDirectory, canonicalizePath)
import System.FilePath
qReadFileBS :: FilePath -> Q BS.ByteString
qReadFileBS :: String -> Q ByteString
qReadFileBS String
fp = do
String
fp' <- String -> Q String
pathRelativeToCabalPackage String
fp
String -> Q ()
addDependentFile String
fp'
IO ByteString -> Q ByteString
forall a. IO a -> Q a
runIO (IO ByteString -> Q ByteString) -> IO ByteString -> Q ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
fp'
qReadFileLBS :: FilePath -> Q LBS.ByteString
qReadFileLBS :: String -> Q ByteString
qReadFileLBS String
fp = do
String
fp' <- String -> Q String
pathRelativeToCabalPackage String
fp
String -> Q ()
addDependentFile String
fp'
IO ByteString -> Q ByteString
forall a. IO a -> Q a
runIO (IO ByteString -> Q ByteString) -> IO ByteString -> Q ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
LBS.readFile String
fp'
qReadFileText :: FilePath -> Q T.Text
qReadFileText :: String -> Q Text
qReadFileText String
fp = do
String
fp' <- String -> Q String
pathRelativeToCabalPackage String
fp
String -> Q ()
addDependentFile String
fp'
IO Text -> Q Text
forall a. IO a -> Q a
runIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile String
fp'
qReadFileLazyText :: FilePath -> Q LT.Text
qReadFileLazyText :: String -> Q Text
qReadFileLazyText String
fp = do
String
fp' <- String -> Q String
pathRelativeToCabalPackage String
fp
String -> Q ()
addDependentFile String
fp'
IO Text -> Q Text
forall a. IO a -> Q a
runIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
LT.readFile String
fp'
qReadFileString :: FilePath -> Q String
qReadFileString :: String -> Q String
qReadFileString String
fp = do
String
fp' <- String -> Q String
pathRelativeToCabalPackage String
fp
String -> Q ()
addDependentFile String
fp'
IO String -> Q String
forall a. IO a -> Q a
runIO (IO String -> Q String) -> IO String -> Q String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
fp'
withCabalPackageWorkDir :: Q a -> Q a
withCabalPackageWorkDir :: forall a. Q a -> Q a
withCabalPackageWorkDir Q a
f = do
String
cwd' <- String -> Q String
pathRelativeToCabalPackage String
"."
String
cwd <- IO String -> Q String
forall a. IO a -> Q a
runIO (IO String -> Q String) -> IO String -> Q String
forall a b. (a -> b) -> a -> b
$ IO String
getCurrentDirectory
IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
cwd'
a
x <- Q a
f
IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
cwd
a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
pathRelativeToCabalPackage :: FilePath -> Q FilePath
pathRelativeToCabalPackage :: String -> Q String
pathRelativeToCabalPackage String
fp = do
Loc
loc <- Q Loc
location
String
parent <-
if Loc -> String
loc_filename Loc
loc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"<interactive>"
then IO String -> Q String
forall a. IO a -> Q a
runIO IO String
getCurrentDirectory
else do
Maybe String
mcanonical <- IO (Maybe String) -> Q (Maybe String)
forall a. IO a -> Q a
runIO (IO (Maybe String) -> Q (Maybe String))
-> IO (Maybe String) -> Q (Maybe String)
forall a b. (a -> b) -> a -> b
$ (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just (String -> IO String
canonicalizePath (Loc -> String
loc_filename Loc
loc))
IO (Maybe String)
-> (IOException -> IO (Maybe String)) -> IO (Maybe String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_err :: IOException) -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Maybe String
mcabalFile <- IO (Maybe String) -> Q (Maybe String)
forall a. IO a -> Q a
runIO (IO (Maybe String) -> Q (Maybe String))
-> IO (Maybe String) -> Q (Maybe String)
forall a b. (a -> b) -> a -> b
$ IO (Maybe String)
-> (String -> IO (Maybe String))
-> Maybe String
-> IO (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing) String -> IO (Maybe String)
findCabalFile Maybe String
mcanonical
case Maybe String
mcabalFile of
Just String
cabalFile -> String -> Q String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
takeDirectory String
cabalFile)
Maybe String
Nothing -> do
String -> Q ()
reportWarning String
"Failed to find cabal file, in order to resolve relative paths in TH. Using current working directory instead."
IO String -> Q String
forall a. IO a -> Q a
runIO IO String
getCurrentDirectory
String -> Q String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
parent String -> String -> String
</> String
fp)
findCabalFile :: FilePath -> IO (Maybe FilePath)
findCabalFile :: String -> IO (Maybe String)
findCabalFile String
dir = do
let parent :: String
parent = String -> String
takeDirectory String
dir
[String]
contents <- String -> IO [String]
getDirectoryContents String
parent
case (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\String
fp -> String -> String
takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".cabal") [String]
contents of
Maybe String
Nothing
| String
parent String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
dir -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
| Bool
otherwise -> String -> IO (Maybe String)
findCabalFile String
parent
Just String
fp -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (String
parent String -> String -> String
</> String
fp))