{-# 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
    fp' <- String -> Q String
pathRelativeToCabalPackage String
fp
    addDependentFile fp'
    runIO $ BS.readFile 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
    fp' <- String -> Q String
pathRelativeToCabalPackage String
fp
    addDependentFile fp'
    runIO $ LBS.readFile 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
    fp' <- String -> Q String
pathRelativeToCabalPackage String
fp
    addDependentFile fp'
    runIO $ T.readFile 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
    fp' <- String -> Q String
pathRelativeToCabalPackage String
fp
    addDependentFile fp'
    runIO $ LT.readFile 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
    fp' <- String -> Q String
pathRelativeToCabalPackage String
fp
    addDependentFile fp'
    runIO $ readFile 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
    cwd' <- String -> Q String
pathRelativeToCabalPackage String
"."
    cwd <- runIO $ getCurrentDirectory
    runIO $ setCurrentDirectory cwd'
    x <- f
    runIO $ setCurrentDirectory cwd
    return 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 <- Q Loc
location
    parent <-
        if loc_filename loc == "<interactive>"
            then runIO getCurrentDirectory
            else do
                mcanonical <- runIO $ fmap Just (canonicalizePath (loc_filename loc))
                   `catch` \(IOException
_err :: IOException) -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                mcabalFile <- runIO $ maybe (return Nothing) findCabalFile mcanonical
                case mcabalFile of
                    Just String
cabalFile -> String -> Q String
forall a. a -> Q a
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
    return (parent </> 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
    contents <- String -> IO [String]
getDirectoryContents String
parent
    case find (\String
fp -> String -> String
takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".cabal") 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 a. a -> IO a
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 a. a -> IO a
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))