-
Notifications
You must be signed in to change notification settings - Fork 7
Expand file tree
/
Copy pathRelativePaths.hs
More file actions
119 lines (109 loc) · 4.74 KB
/
RelativePaths.hs
File metadata and controls
119 lines (109 loc) · 4.74 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
{-# 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 fp = do
fp' <- pathRelativeToCabalPackage 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 fp = do
fp' <- pathRelativeToCabalPackage 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 fp = do
fp' <- pathRelativeToCabalPackage 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 fp = do
fp' <- pathRelativeToCabalPackage 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 fp = do
fp' <- pathRelativeToCabalPackage 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 f = do
cwd' <- pathRelativeToCabalPackage "."
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 fp = do
loc <- location
parent <-
if loc_filename loc == "<interactive>"
then runIO getCurrentDirectory
else do
mcanonical <- runIO $ fmap Just (canonicalizePath (loc_filename loc))
`catch` \(_err :: IOException) -> return Nothing
mcabalFile <- runIO $ maybe (return Nothing) findCabalFile mcanonical
case mcabalFile of
Just cabalFile -> return (takeDirectory cabalFile)
Nothing -> do
reportWarning "Failed to find cabal file, in order to resolve relative paths in TH. Using current working directory instead."
runIO 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 dir = do
let parent = takeDirectory dir
contents <- getDirectoryContents parent
case find (\fp -> takeExtension fp == ".cabal") contents of
Nothing
| parent == dir -> return Nothing
| otherwise -> findCabalFile parent
Just fp -> return (Just (parent </> fp))