    {-# 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))