{-# 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 :: 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'

-- | 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 :: 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'

-- | 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 :: 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'

-- | 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 :: 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'

-- | 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 :: 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'

-- | Runs the 'Q' action, temporarily setting the current working
-- directory to the root of the cabal package.
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

-- | 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 :: 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)

-- | Given the path to a file or directory, search parent directories
-- for a .cabal file.
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))