{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

-- | This module provides Template Haskell utilities for loading files
-- based on paths relative to the root of your Cabal package.
--
-- Normally when building a cabal package, GHC is run with its current
-- directory set at the package's root directory. This allows using
-- relative paths to refer to files. However, this becomes problematic
-- when you want to load modules from multiple projects, such as when
-- using "stack ghci".
--
-- This solves the problem by getting the current module's filepath from
-- TH via 'location'. It then searches upwards in the directory tree for
-- a .cabal file, and makes the provided path relative to the folder
-- it's in.
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

-- | Reads a file as a strict ByteString. The path is specified relative
-- to the package's root directory, and 'addDependentfile' is invoked on
-- the target file.
qReadFileBS :: FilePath -> Q BS.ByteString
qReadFileBS :: FilePath -> Q ByteString
qReadFileBS FilePath
fp = do
    FilePath
fp' <- FilePath -> Q FilePath
pathRelativeToCabalPackage FilePath
fp
    FilePath -> Q ()
addDependentFile FilePath
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
$ FilePath -> IO ByteString
BS.readFile FilePath
fp'

-- | Reads a file as a lazy ByteString. The path is specified relative
-- to the package's root directory, and 'addDependentfile' is invoked on
-- the target file.
qReadFileLBS :: FilePath -> Q LBS.ByteString
qReadFileLBS :: FilePath -> Q ByteString
qReadFileLBS FilePath
fp = do
    FilePath
fp' <- FilePath -> Q FilePath
pathRelativeToCabalPackage FilePath
fp
    FilePath -> Q ()
addDependentFile FilePath
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
$ FilePath -> IO ByteString
LBS.readFile FilePath
fp'

-- | Reads a file as a strict Text. The path is specified relative
-- to the package's root directory, and 'addDependentfile' is invoked on
-- the target file.
qReadFileText :: FilePath -> Q T.Text
qReadFileText :: FilePath -> Q Text
qReadFileText FilePath
fp = do
    FilePath
fp' <- FilePath -> Q FilePath
pathRelativeToCabalPackage FilePath
fp
    FilePath -> Q ()
addDependentFile FilePath
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
$ FilePath -> IO Text
T.readFile FilePath
fp'

-- | Reads a file as a lazy Text. The path is specified relative
-- to the package's root directory, and 'addDependentfile' is invoked on
-- the target file.
qReadFileLazyText :: FilePath -> Q LT.Text
qReadFileLazyText :: FilePath -> Q Text
qReadFileLazyText FilePath
fp = do
    FilePath
fp' <- FilePath -> Q FilePath
pathRelativeToCabalPackage FilePath
fp
    FilePath -> Q ()
addDependentFile FilePath
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
$ FilePath -> IO Text
LT.readFile FilePath
fp'

-- | Reads a file as a String. The path is specified relative
-- to the package's root directory, and 'addDependentfile' is invoked on
-- the target file.
qReadFileString :: FilePath -> Q String
qReadFileString :: FilePath -> Q FilePath
qReadFileString FilePath
fp = do
    FilePath
fp' <- FilePath -> Q FilePath
pathRelativeToCabalPackage FilePath
fp
    FilePath -> Q ()
addDependentFile FilePath
fp'
    IO FilePath -> Q FilePath
forall a. IO a -> Q a
runIO (IO FilePath -> Q FilePath) -> IO FilePath -> Q FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile FilePath
fp'

-- | Runs the 'Q' action, temporarily setting the current working
-- directory to the root of the cabal package.
withCabalPackageWorkDir :: Q a -> Q a
withCabalPackageWorkDir :: Q a -> Q a
withCabalPackageWorkDir Q a
f = do
    FilePath
cwd' <- FilePath -> Q FilePath
pathRelativeToCabalPackage FilePath
"."
    FilePath
cwd <- IO FilePath -> Q FilePath
forall a. IO a -> Q a
runIO (IO FilePath -> Q FilePath) -> IO FilePath -> Q FilePath
forall a b. (a -> b) -> a -> b
$ IO FilePath
getCurrentDirectory
    IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
setCurrentDirectory FilePath
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
$ FilePath -> IO ()
setCurrentDirectory FilePath
cwd
    a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | This utility takes a path that's relative to your package's cabal
-- file, and resolves it to an absolute location.
--
-- Note that this utility does _not_ invoke 'qAddDependentFile'.
pathRelativeToCabalPackage :: FilePath -> Q FilePath
pathRelativeToCabalPackage :: FilePath -> Q FilePath
pathRelativeToCabalPackage FilePath
fp = do
    Loc
loc <- Q Loc
location
    FilePath
parent <-
        if Loc -> FilePath
loc_filename Loc
loc FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"<interactive>"
            then IO FilePath -> Q FilePath
forall a. IO a -> Q a
runIO IO FilePath
getCurrentDirectory
            else do
                Maybe FilePath
mcanonical <- IO (Maybe FilePath) -> Q (Maybe FilePath)
forall a. IO a -> Q a
runIO (IO (Maybe FilePath) -> Q (Maybe FilePath))
-> IO (Maybe FilePath) -> Q (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ (FilePath -> Maybe FilePath) -> IO FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> IO FilePath
canonicalizePath (Loc -> FilePath
loc_filename Loc
loc))
                   IO (Maybe FilePath)
-> (IOException -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_err :: IOException) -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
                Maybe FilePath
mcabalFile <- IO (Maybe FilePath) -> Q (Maybe FilePath)
forall a. IO a -> Q a
runIO (IO (Maybe FilePath) -> Q (Maybe FilePath))
-> IO (Maybe FilePath) -> Q (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ IO (Maybe FilePath)
-> (FilePath -> IO (Maybe FilePath))
-> Maybe FilePath
-> IO (Maybe FilePath)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing) FilePath -> IO (Maybe FilePath)
findCabalFile Maybe FilePath
mcanonical
                case Maybe FilePath
mcabalFile of
                    Just FilePath
cabalFile -> FilePath -> Q FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> FilePath
takeDirectory FilePath
cabalFile)
                    Maybe FilePath
Nothing -> do
                        FilePath -> Q ()
reportWarning FilePath
"Failed to find cabal file, in order to resolve relative paths in TH.  Using current working directory instead."
                        IO FilePath -> Q FilePath
forall a. IO a -> Q a
runIO IO FilePath
getCurrentDirectory
    FilePath -> Q FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
parent FilePath -> FilePath -> FilePath
</> FilePath
fp)

-- | Given the path to a file or directory, search parent directories
-- for a .cabal file.
findCabalFile :: FilePath -> IO (Maybe FilePath)
findCabalFile :: FilePath -> IO (Maybe FilePath)
findCabalFile FilePath
dir = do
    let parent :: FilePath
parent = FilePath -> FilePath
takeDirectory FilePath
dir
    [FilePath]
contents <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
parent
    case (FilePath -> Bool) -> [FilePath] -> Maybe FilePath
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\FilePath
fp -> FilePath -> FilePath
takeExtension FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal") [FilePath]
contents of
        Maybe FilePath
Nothing
            | FilePath
parent FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
dir -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
            | Bool
otherwise -> FilePath -> IO (Maybe FilePath)
findCabalFile FilePath
parent
        Just FilePath
fp -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
parent FilePath -> FilePath -> FilePath
</> FilePath
fp))