@@ -0,0 +1,61 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+module Data.FileEmbed
3+ ( embedFile
4+ , embedDir
5+ ) where
6+
7+import Language.Haskell.TH (runQ,
8+ Exp(AppE, ListE, LitE, TupE),
9+ Lit(IntegerL, StringL),
10+ Q,
11+ runIO)
12+import System.Directory (doesDirectoryExist, doesFileExist,
13+ getDirectoryContents)
14+import Control.Monad (filterM)
15+import qualified Data.ByteString as B
16+import Control.Arrow ((&&&), second, first)
17+import Control.Applicative ((<$>))
18+import Data.Monoid (mappend)
19+
20+embedFile :: FilePath -> Q Exp
21+embedFile fp = (runIO $ B.readFile fp) >>= bsToExp
22+
23+embedDir :: FilePath -> Q Exp
24+embedDir fp = ListE <$> ((runIO $ fileList fp) >>= mapM pairToExp)
25+
26+pairToExp :: (FilePath, B.ByteString) -> Q Exp
27+pairToExp (path, bs) = do
28+ exp' <- bsToExp bs
29+ return $! TupE [LitE $ StringL path, exp']
30+
31+bsToExp :: B.ByteString -> Q Exp
32+bsToExp bs = do
33+ pack <- runQ [| B.pack |]
34+ return $!
35+ AppE pack .
36+ ListE .
37+ map (LitE . IntegerL . fromIntegral) .
38+ B.unpack $
39+ bs
40+
41+notHidden :: FilePath -> Bool
42+notHidden ('.':_) = False
43+notHidden _ = True
44+
45+fileList :: FilePath -> IO [(FilePath, B.ByteString)]
46+fileList top = map (first tail) <$> fileList' top ""
47+
48+fileList' :: FilePath -> FilePath -> IO [(FilePath, B.ByteString)]
49+fileList' realTop top = do
50+ let prefix1 = top ++ "/"
51+ prefix2 = realTop ++ prefix1
52+ allContents <- filter notHidden <$> getDirectoryContents prefix2
53+ let all' = map (mappend prefix1 &&& mappend prefix2) allContents
54+ files <- filterM (doesFileExist . snd) all' >>=
55+ mapM (liftPair2 . second B.readFile)
56+ dirs <- filterM (doesDirectoryExist . snd) all' >>=
57+ mapM (fileList' realTop . fst)
58+ return $ concat $ files : dirs
59+
60+liftPair2 :: Monad m => (a, m b) -> m (a, b)
61+liftPair2 (a, b) = b >>= \b' -> return (a, b')