module System.FilePath.TH where
import Prelude
import Control.Monad ((<=<))
import Data.FileEmbed (makeRelativeToProject)
import Language.Haskell.TH (Loc(Loc), Exp, Q, loc_filename, location, runIO, stringE)
import System.Directory (canonicalizePath, getCurrentDirectory)
import System.FilePath ((</>), takeDirectory)
fileRelativeToAbsolute :: String -> Q Exp
fileRelativeToAbsolute :: String -> Q Exp
fileRelativeToAbsolute = String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> (String -> Q String) -> String -> Q Exp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q String
fileRelativeToAbsoluteStr
fileRelativeToAbsoluteStr :: String -> Q String
fileRelativeToAbsoluteStr :: String -> Q String
fileRelativeToAbsoluteStr absoluteFilePath :: String
absoluteFilePath@(Char
'/':String
_) =
IO String -> Q String
forall a. IO a -> Q a
runIO (IO String -> Q String)
-> (String -> IO String) -> String -> Q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
canonicalizePath (String -> Q String) -> String -> Q String
forall a b. (a -> b) -> a -> b
$ String
absoluteFilePath
fileRelativeToAbsoluteStr String
relativeFilePath = do
Loc {String
loc_filename :: Loc -> String
loc_filename :: String
..} <- Q Loc
location
String
currentDir <- IO String -> Q String
forall a. IO a -> Q a
runIO IO String
getCurrentDirectory
let baseDir :: String
baseDir = String -> String
takeDirectory String
loc_filename
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
canonicalizePath (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
currentDir String -> String -> String
</> String
baseDir String -> String -> String
</> String
relativeFilePath
fileRelativeToProject :: FilePath -> Q Exp
fileRelativeToProject :: String -> Q Exp
fileRelativeToProject = String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> (String -> Q String) -> String -> Q Exp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q String
makeRelativeToProject