{-# 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'
    forall a. IO a -> Q a
runIO 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'
    forall a. IO a -> Q a
runIO 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'
    forall a. IO a -> Q a
runIO 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'
    forall a. IO a -> Q a
runIO 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'
    forall a. IO a -> Q a
runIO 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 <- forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ IO String
getCurrentDirectory
    forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
cwd'
    a
x <- Q a
f
    forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
cwd
    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 forall a. Eq a => a -> a -> Bool
== String
"<interactive>"
            then forall a. IO a -> Q a
runIO IO String
getCurrentDirectory
            else do
                Maybe String
mcanonical <- forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (String -> IO String
canonicalizePath (Loc -> String
loc_filename Loc
loc))
                   forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_err :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                Maybe String
mcabalFile <- forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) String -> IO (Maybe String)
findCabalFile Maybe String
mcanonical
                case Maybe String
mcabalFile of
                    Just String
cabalFile -> 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."
                        forall a. IO a -> Q a
runIO IO String
getCurrentDirectory
    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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\String
fp -> String -> String
takeExtension String
fp forall a. Eq a => a -> a -> Bool
== String
".cabal") [String]
contents of
        Maybe String
Nothing
            | String
parent forall a. Eq a => a -> a -> Bool
== String
dir -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            | Bool
otherwise -> String -> IO (Maybe String)
findCabalFile String
parent
        Just String
fp -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (String
parent String -> String -> String
</> String
fp))