module Data.FileEmbed
(
embedFile
, embedOneFileOf
, embedDir
, makeRelativeToProject
) where
import Language.Haskell.TH.Syntax
( Exp (AppE, ListE, LitE, TupE, SigE, VarE)
, Lit (StringL)
, Q
, runIO
, qLocation, loc_filename
#if MIN_VERSION_template_haskell(2, 7, 0)
, Quasi(qAddDependentFile)
#endif
)
import System.Directory (doesDirectoryExist, doesFileExist,
getDirectoryContents, canonicalizePath)
import Control.Applicative ((<|>), (<$>))
import Control.Exception (throw, ErrorCall(..))
import Control.Monad (filterM)
import Control.Arrow ((&&&), second)
import System.FilePath ((</>), takeDirectory, takeExtension)
import Data.String (IsString, fromString)
import Prelude as P
embedFile :: FilePath -> Q Exp
embedFile fp =
#if MIN_VERSION_template_haskell(2, 7, 0)
qAddDependentFile fp >>
#endif
(runIO $ readFile fp) >>= toExp
embedOneFileOf :: [FilePath] -> Q Exp
embedOneFileOf ps =
(runIO $ readExistingFile ps) >>= \ ( path, content ) -> do
#if MIN_VERSION_template_haskell(2, 7, 0)
qAddDependentFile path
#endif
toExp content
where
readExistingFile :: [FilePath] -> IO (FilePath, String)
readExistingFile xs = do
ys <- filterM doesFileExist xs
case ys of
(p:_) -> readFile p >>= \ c -> return ( p, c )
_ -> throw $ ErrorCall "Cannot find file to embed as resource"
embedDir :: FilePath -> Q Exp
embedDir fp = do
typ <- [t| forall a. IsString a => [(FilePath, a)] |]
e <- ListE <$> ((runIO $ getDir) >>= mapM (pairToExp fp))
return $ SigE e typ
where
getDir = fileList fp ""
pairToExp :: FilePath -> (FilePath, String) -> Q Exp
pairToExp _root (path, bs) = do
#if MIN_VERSION_template_haskell(2, 7, 0)
qAddDependentFile $ _root ++ '/' : path
#endif
exp' <- toExp bs
return $! TupE [LitE $ StringL path, exp']
fileList :: FilePath -> FilePath -> IO [(FilePath, String)]
fileList realTop top = do
allContents <- filter notHidden <$> getDirectoryContents (realTop </> top)
let all' = map ((top </>) &&& (\x -> realTop </> top </> x)) allContents
files <- filterM (doesFileExist . snd) all' >>=
mapM (liftPair2 . second readFile)
dirs <- filterM (doesDirectoryExist . snd) all' >>=
mapM (fileList realTop . fst)
return $ concat $ files : dirs
where
notHidden :: FilePath -> Bool
notHidden ('.':_) = False
notHidden _ = True
liftPair2 :: Monad m => (a, m b) -> m (a, b)
liftPair2 (a, b) = b >>= \b' -> return (a, b')
toExp :: String -> Q Exp
toExp s =
return $ VarE 'fromString
`AppE` LitE (StringL s)
makeRelativeToProject :: FilePath -> Q FilePath
makeRelativeToProject rel = do
loc <- qLocation
runIO $ do
srcFP <- canonicalizePath $ loc_filename loc
mdir <- findProjectDir srcFP
case mdir of
Nothing -> error $ "Could not find .cabal file for path: " ++ srcFP
Just dir -> return $ dir </> rel
where
findProjectDir x = do
let dir = takeDirectory x
if dir == x
then return Nothing
else do
contents <- getDirectoryContents dir
if any isCabalFile contents
then return (Just dir)
else findProjectDir dir
isCabalFile fp = takeExtension fp == ".cabal"