From c6f5fc348fedf6cd1121e60e5f8049569fbefd69 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Jul 2009 21:42:43 +0300 Subject: [PATCH] Initial working version with sample, undocumented --- .gitignore | 2 ++ Data/FileEmbed.hs | 61 +++++++++++++++++++++++++++++++++++++++++++++++ LICENSE | 25 +++++++++++++++++++ README | 1 + Setup.lhs | 7 ++++++ file-embed.cabal | 18 ++++++++++++++ sample/bar | 1 + sample/baz | 1 + sample/bin | 1 + test.hs | 15 ++++++++++++ 10 files changed, 132 insertions(+) create mode 100644 .gitignore create mode 100644 Data/FileEmbed.hs create mode 100644 LICENSE create mode 100755 Setup.lhs create mode 100644 file-embed.cabal create mode 100644 sample/bar create mode 100644 sample/baz create mode 100644 sample/bin create mode 100644 test.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..39b806f --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +dist +*.swp diff --git a/Data/FileEmbed.hs b/Data/FileEmbed.hs new file mode 100644 index 0000000..55c49cb --- /dev/null +++ b/Data/FileEmbed.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell #-} +module Data.FileEmbed + ( embedFile + , embedDir + ) where + +import Language.Haskell.TH (runQ, + Exp(AppE, ListE, LitE, TupE), + Lit(IntegerL, StringL), + Q, + runIO) +import System.Directory (doesDirectoryExist, doesFileExist, + getDirectoryContents) +import Control.Monad (filterM) +import qualified Data.ByteString as B +import Control.Arrow ((&&&), second, first) +import Control.Applicative ((<$>)) +import Data.Monoid (mappend) + +embedFile :: FilePath -> Q Exp +embedFile fp = (runIO $ B.readFile fp) >>= bsToExp + +embedDir :: FilePath -> Q Exp +embedDir fp = ListE <$> ((runIO $ fileList fp) >>= mapM pairToExp) + +pairToExp :: (FilePath, B.ByteString) -> Q Exp +pairToExp (path, bs) = do + exp' <- bsToExp bs + return $! TupE [LitE $ StringL path, exp'] + +bsToExp :: B.ByteString -> Q Exp +bsToExp bs = do + pack <- runQ [| B.pack |] + return $! + AppE pack . + ListE . + map (LitE . IntegerL . fromIntegral) . + B.unpack $ + bs + +notHidden :: FilePath -> Bool +notHidden ('.':_) = False +notHidden _ = True + +fileList :: FilePath -> IO [(FilePath, B.ByteString)] +fileList top = map (first tail) <$> fileList' top "" + +fileList' :: FilePath -> FilePath -> IO [(FilePath, B.ByteString)] +fileList' realTop top = do + let prefix1 = top ++ "/" + prefix2 = realTop ++ prefix1 + allContents <- filter notHidden <$> getDirectoryContents prefix2 + let all' = map (mappend prefix1 &&& mappend prefix2) allContents + files <- filterM (doesFileExist . snd) all' >>= + mapM (liftPair2 . second B.readFile) + dirs <- filterM (doesDirectoryExist . snd) all' >>= + mapM (fileList' realTop . fst) + return $ concat $ files : dirs + +liftPair2 :: Monad m => (a, m b) -> m (a, b) +liftPair2 (a, b) = b >>= \b' -> return (a, b') diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..11dc17a --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2008, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README index e69de29..e7235ab 100644 --- a/README +++ b/README @@ -0,0 +1 @@ +Use Template Haskell to embed file contents directly. diff --git a/Setup.lhs b/Setup.lhs new file mode 100755 index 0000000..06e2708 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/file-embed.cabal b/file-embed.cabal new file mode 100644 index 0000000..945c259 --- /dev/null +++ b/file-embed.cabal @@ -0,0 +1,18 @@ +name: file-embed +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: Use Template Haskell to embed file contents directly. +description: FIXME +category: Data +stability: unstable +cabal-version: >= 1.2 +build-type: Simple +homepage: http://github.com/snoyberg/file-embed/tree/master + +library + build-depends: base + exposed-modules: + ghc-options: -Wall diff --git a/sample/bar b/sample/bar new file mode 100644 index 0000000..8e739cc --- /dev/null +++ b/sample/bar @@ -0,0 +1 @@ +bar bar bar diff --git a/sample/baz b/sample/baz new file mode 100644 index 0000000..280beb2 --- /dev/null +++ b/sample/baz @@ -0,0 +1 @@ +baz baz baz diff --git a/sample/bin b/sample/bin new file mode 100644 index 0000000..85c695c --- /dev/null +++ b/sample/bin @@ -0,0 +1 @@ +bin bin bin diff --git a/test.hs b/test.hs new file mode 100644 index 0000000..34df351 --- /dev/null +++ b/test.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Data.FileEmbed +import qualified Data.ByteString as B + +plainfile :: B.ByteString +plainfile = $(embedFile "sample/bar") + +plaindir :: [(FilePath, B.ByteString)] +plaindir = $(embedDir "sample") + +main :: IO () +main = do + print plainfile + print plaindir