diff --git a/Data/BinEmbed.hs b/Data/BinEmbed.hs new file mode 100644 --- /dev/null +++ b/Data/BinEmbed.hs @@ -0,0 +1,63 @@ +------------------------------------------------------------------------ +-- | +-- Module : Data.BinEmbed +-- Copyright : Claude Heiland-Allen 2010 +-- Maintainer : claudiusmaximus@goto10.org +-- +-- Support code used by the output of @binembed --output-hs=@. +-- +-- For example, given @MyData.binembed@ listing some files, you might +-- get at the contents embedded into your executable using: +-- +-- > import MyData -- which re-exports this module +-- > main = do +-- > myData' <- unBinEmbed myData +-- > ... +-- +-- See the 'binembed-example' package for a more detailed example. + +module Data.BinEmbed + ( Node(File, Dir) + , unBinEmbed + , unBinEmbedFile + ) where + +import Prelude hiding (sequence) + +import Foreign.Ptr (Ptr, castPtr, minusPtr) +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe (unsafePackCStringLen) +import Data.Foldable (Foldable, foldMap) +import Data.Traversable (Traversable, traverse, sequence) +import Data.Map (Map) + +-- | A directory tree +data Node a + = File a -- ^ A file has contents. + | Dir (Map String (Node a)) -- ^ A directory has named @Node@s. + deriving (Show, Read, Eq, Ord) + +instance Functor Node where + fmap f (File a) = File ( f a) + fmap f (Dir a) = Dir (fmap (fmap f) a) + +instance Foldable Node where + foldMap f (File a) = f a + foldMap f (Dir a) = foldMap (foldMap f) a + +instance Traversable Node where + traverse f (File a) = File `fmap` f a + traverse f (Dir a) = Dir `fmap` traverse (traverse f) a + +-- | Unpack embedded data. +unBinEmbed :: Node (IO ByteString) -> IO (Node ByteString) +unBinEmbed = sequence + +-- | Repack the contents between two pointers. Your code probably +-- doesn't need to call this, but it's needed in generated code. +{- The usage in the code output by @binembed --output-hs=@ is safe, +-- because the embedded file data is in a .rodata section (ie, it is +-- immutable). +-} +unBinEmbedFile :: Ptr () -> Ptr () -> IO ByteString +unBinEmbedFile s e = unsafePackCStringLen (castPtr s, e `minusPtr` s) diff --git a/Distribution/Simple/BinEmbed.hs b/Distribution/Simple/BinEmbed.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/BinEmbed.hs @@ -0,0 +1,107 @@ +------------------------------------------------------------------------ +-- | +-- Module : Distribution.Simple.BinEmbed +-- Copyright : Claude Heiland-Allen 2010 +-- Maintainer : claudiusmaximus@goto10.org +-- +-- Support code to use @binembed@ as a pre-processor in Cabal. For +-- example, your @Setup.hs@ might look like: +-- +-- > import Distribution.Simple +-- > import Distribution.Simple.BinEmbed +-- > main = defaultMainWithHooks (withBinEmbed simpleUserHooks) +-- +-- See the 'binembed-example' package for a more detailed example. + +module Distribution.Simple.BinEmbed (withBinEmbed) where + +import Distribution.Simple +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Setup +import Distribution.PackageDescription +import Data.Maybe (maybeToList) +import System.FilePath ((), dropExtension) + +-- | Add hooks to use @binembed@ as a pre-processor, with input files +-- having the file name extension @.binembed@. These hooks also +-- handle building the assembly output of @binembed@, as well as +-- cleaning it up afterwards. +withBinEmbed :: UserHooks -> UserHooks +withBinEmbed hooks = hooks + { hookedPreProcessors = ("binembed", binembedPreProcessor) : + hookedPreProcessors hooks + , hookedPrograms = binembedProgram : hookedPrograms hooks + , buildHook = binembedBuild (buildHook hooks) + , cleanHook = binembedClean (cleanHook hooks) + } + +-- @binembed@ executable. +binembedProgram :: Program +binembedProgram = simpleProgram "binembed" + +-- The pre-processor invokes @binembed@ with sensible options, in +-- particular the output assembler source needs to be next to the data +-- files that it references. +binembedPreProcessor :: BuildInfo -> LocalBuildInfo -> PreProcessor +binembedPreProcessor _bi lbi = PreProcessor + { platformIndependent = False + , runPreProcessor = \(inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) + verbosity -> do + runDbProgram verbosity binembedProgram (withPrograms lbi) $ + [ "--output-hs=" ++ outBaseDir outRelativeFile + , "--output-s=" ++ inBaseDir sfile (dropExtension outRelativeFile) + , inBaseDir inRelativeFile + ] + } + +-- Build by adding the output assembler to the C sources (this assumes +-- that the compiler used for C can also handle assembler sources; this +-- is true of GHC and GCC). +binembedBuild :: (PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()) + -> PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () +binembedBuild buildHook0 pd lbi hooks flags = do + let pd' = pd{ executables = map (\e -> e{ buildInfo = f $ buildInfo e }) + $ executables pd + , library = fmap (\l -> l{ libBuildInfo = f $ libBuildInfo l }) + $ library pd + } + buildHook0 pd' lbi hooks flags + where + f bi = case lookup binembedX $ customFieldsBI bi of + Nothing -> bi + Just be -> bi{ cSources = sfiles be ++ cSources bi } + +-- Clean up the intermediary assembler files. +binembedClean :: (PackageDescription -> () -> UserHooks -> CleanFlags -> IO ()) + -> PackageDescription -> () -> UserHooks -> CleanFlags -> IO () +binembedClean cleanHook0 pd x hooks flags = do + let pd' = pd{ extraTmpFiles = concat . concat $ + [ map (f . buildInfo) (executables pd) + , map (f . libBuildInfo) (maybeToList $ library pd) + , [extraTmpFiles pd] + ] + } + cleanHook0 pd' x hooks flags + where + f bi = case lookup binembedX $ customFieldsBI bi of + Nothing -> [] + Just be -> sfiles be + +-- The 'build' and 'clean' hooks need to know which modules are really +-- generated by @binembed@ - use the 'x-binembed: ModuleName' field in +-- the @pkgname.cabal@ file to accomplish this. +binembedX :: String +binembedX = "x-binembed" + +-- Munge a module name to assembler source file name; don't just add +-- an extension or the generated @.o@ file will clash with the @.o@ +-- file generated from the Haskell output. +sfile :: String -> String +sfile = (++ "_be.s") + +-- The same, but for more than one module. +sfiles :: String -> [String] +sfiles be = map sfile (words be) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Claude Heiland-Allen + +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. + + * Neither the name of Claude Heiland-Allen nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 +OWNER OR CONTRIBUTORS 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/binembed.cabal b/binembed.cabal new file mode 100644 --- /dev/null +++ b/binembed.cabal @@ -0,0 +1,50 @@ +Name: binembed +Version: 0.1 +Synopsis: Embed data into object files. +Description: Given a list of files and directories to include, + binembed generates assembly source to include the data + into an object file that can be linked to a library or + executable, along with interface modules for higher + level access from languages such as C, Haskell, ... + . + See the package 'binembed-example' for a concrete + example. +Homepage: http://gitorious.org/binembed +License: BSD3 +License-file: LICENSE +Author: Claude Heiland-Allen +Maintainer: claudiusmaximus@goto10.org +Category: Distribution +Build-type: Simple +Cabal-version: >=1.6 +Extra-source-files: include/binembed.h + +Library + Build-depends: base >= 4 && < 5, + bytestring >= 0.9 && < 0.10, + Cabal >= 1.8 && < 1.9 + Exposed-modules: Data.BinEmbed + Distribution.Simple.BinEmbed + include-dirs: include + install-includes: binembed.h + GHC-options: -Wall + GHC-prof-options: -prof -auto-all + +Executable binembed + Build-depends: base >= 4 && < 5, + containers >= 0 && < 1, + directory >= 1 && < 2, + dlist >= 0.4 && < 0.5, + filepath >= 1 && < 2 + Main-is: src/binembed.hs + GHC-options: -Wall + GHC-prof-options: -prof -auto-all + +Source-repository head + type: git + location: git://gitorious.org/binembed/binembed.git + +Source-repository this + type: git + location: git://gitorious.org/binembed/binembed.git + tag: v0.1 diff --git a/include/binembed.h b/include/binembed.h new file mode 100644 --- /dev/null +++ b/include/binembed.h @@ -0,0 +1,17 @@ +#ifndef BINEMBED_H +#define BINEMBED_H 1 +#include +struct binembed_file { + char const * const data; + intptr_t const size; +}; +struct binembed_node { + char const * const name; + enum { binembed_none = 0, binembed_file, binembed_dir } const type; + union { + void const * const none; + struct binembed_file const * const file; + struct binembed_node const * const dir; + } const content; +}; +#endif diff --git a/src/binembed.hs b/src/binembed.hs new file mode 100644 --- /dev/null +++ b/src/binembed.hs @@ -0,0 +1,249 @@ +import Data.Char (ord, toUpper, toLower) +import Data.DList (DList, fromList, toList) +import Data.List (intercalate, isSuffixOf) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (listToMaybe) +import Data.Monoid (Monoid, mempty, mappend, mconcat) +import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents) +import System.Environment (getArgs) +import System.FilePath ((), (<.>), joinPath, splitDirectories, splitExtension) + +import Paths_binembed (getLibDir) + +{- file path -} + +type Name = String +type Dir = Map Name Node +data Node = File | Dir Dir + +listRec :: FilePath -> FilePath -> IO (Name, Node) +listRec t f = do + let tf = t f + isDir <- doesDirectoryExist tf + isFile <- doesFileExist tf + case (isDir, isFile) of + (True, False) -> do + cs <- mapM (listRec tf) =<< filter (not . hidden) `fmap` getDirectoryContents tf + return $ (f, Dir (M.fromList cs)) + (False, True) -> do + return $ (f, File) + where + hidden ('.':_) = True + hidden _ = False + +depthFirstPostOrder :: Monad m => ([Name] -> m a) -> ([Name] -> [a] -> m a) -> [Name] -> Node -> m a +depthFirstPostOrder fact _dact path File = fact path +depthFirstPostOrder fact dact path (Dir dir) = + mapM (\(name, node) -> depthFirstPostOrder fact dact (path ++ [name]) node) (M.toAscList dir) >>= dact path + +textMode :: [String] -> String -> Bool +textMode exts file = any (`isSuffixOf` file) exts + +{- code output monoid -} + +type Code = DList Char +data Output = Output{ oAS, oCH, oCC, oHS1, oHS2 :: Code } + +instance Monoid Output where + mempty = Output mempty mempty mempty mempty mempty + Output as ch cc hs1 hs2 `mappend` Output as' ch' cc' hs1' hs2' = + Output (as `mappend` as') (ch `mappend` ch') (cc `mappend` cc') (hs1 `mappend` hs1') (hs2 `mappend` hs2') + +{- code output monad -} + +data Env = Env{ eCHName, eCCName, eCInclude, eHSName :: String, eAlignment :: Int, eTextExts :: [String] } +data CodeGen a = CodeGen{ runCodeGen :: Env -> (a, Output) } + +instance Monad CodeGen where + return a = CodeGen $ \_e -> (a, mempty) + CodeGen a >>= b = CodeGen $ \e -> let (aa, ao) = a e + (bb, bo) = runCodeGen (b aa) e + in (bb, ao `mappend` bo) + +execCodeGen :: Env -> CodeGen () -> Output +execCodeGen e (CodeGen f) = snd (f e) + +tell :: Output -> CodeGen () +tell out = CodeGen $ \_e -> ((), out) + +asks :: (Env -> a) -> CodeGen a +asks x = CodeGen $ \e -> (x e, mempty) + +{- symbol munging -} + +symbols :: String -> String +symbols (s:ss) = symbol0 s ++ concatMap symbol ss + +isSymbol0, isSymbol :: Char -> Bool +isSymbol0 c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') +isSymbol c = isSymbol0 c || ('0' <= c && c <= '9') + +escape, symbol0, symbol :: Char -> String +escape c = "_u" ++ show (ord c) ++ "_" +symbol0 c | isSymbol0 c = [c] + | otherwise = escape c +symbol c | isSymbol c = [c] + | otherwise = escape c + +{- code generation -} + +initialEnv :: [Char] -> Int -> [String] -> String -> Env +initialEnv name@(n:ame) alignment textExts include = + Env + { eCHName = map toUpper name + , eCCName = name + , eCInclude = include + , eHSName = toUpper n : ame + , eAlignment = alignment + , eTextExts = textExts + } + +initialCode :: CodeGen () +initialCode = do + chName <- asks eCHName + ccName <- asks eCCName + cInc <- asks eCInclude + hsName <- asks eHSName + tell Output + { oAS = fromList $ "/*" ++ warning ++ "*/\n.section .rodata\n" + , oCH = fromList $ "/*" ++ warning ++ "*/\n\ + \#ifndef " ++ chName ++ "_H\n\ + \#define " ++ chName ++ "_H 1\n\ + \#include <" ++ cInc ++ ">\n" + , oCC = fromList $ "/*" ++ warning ++ "*/\n\ + \#include \"" ++ ccName <.> "h" ++ "\"\n" + , oHS1 = fromList $ "{-# LANGUAGE ForeignFunctionInterface #-}\n\ + \--" ++ warning ++ "\n\ + \module " ++ hsName ++ "(\n module Data.BinEmbed\n" + , oHS2 = fromList $ ") where\n\ + \import Foreign.Ptr (Ptr)\n\ + \import Data.ByteString (ByteString)\n\ + \import Data.Map (fromList)\n\ + \import Data.BinEmbed\n" + } + where + warning = " autogenerated file; do not edit " + +finalCode :: CodeGen () +finalCode = do + tell Output + { oAS = fromList $ "" + , oCH = fromList $ "#endif\n" + , oCC = fromList $ "" + , oHS1 = fromList $ "" + , oHS2 = fromList $ "" + } + +fileCode :: [String] -> CodeGen (Either (String, String) (String, String)) +fileCode path = do + align <- asks eAlignment + exts <- asks eTextExts + let f = joinPath . tail . splitDirectories . joinPath $ path + s@(s0:ss) = symbols . intercalate "/" . splitDirectories . joinPath $ path + e@(e0:es) = s ++ "_end" + z = s ++ "_size" + fs@(fs0:fss) = s ++ "_file" + hs = toLower s0 : ss + he = toLower e0 : es + hfs = toLower fs0 : fss + text = textMode exts (last path) + tell Output + { oAS = fromList . unlines . map concat $ + [ [".align ", show align] + , [".global ", s], [s, ":"] + , [".incbin ", show f] + , if text then [".byte 0"] else [] + , [".global ", e], [e, ":"] + , [".global ", z], [".set ", z, ", ", e, " - ", s] + ] + , oCH = fromList $ "extern char const " ++ s ++ "[];\n\ + \extern void const " ++ z ++ ";\n" + , oCC = fromList $ "static struct binembed_file const " ++ fs ++ " = {\n\ + \ " ++ s ++ ", (intptr_t) &" ++ z ++ "\n};\n" + , oHS1 = fromList $ " , " ++ hfs ++ "\n" + , oHS2 = fromList $ "foreign import stdcall \"&" ++ s ++ "\" " ++ hs ++ " :: Ptr ()\n\ + \foreign import stdcall \"&" ++ e ++ "\" " ++ he ++ " :: Ptr ()\n" ++ + hfs ++ " :: IO ByteString\n" ++ + hfs ++ " = unBinEmbedFile " ++ hs ++ " " ++ he ++ "\n" + } + return $ Left (last path, fs) + +dirCode :: Bool -> [String] -> [Either (String, String) (String, String)] -> CodeGen (Either (String, String) (String, String)) +dirCode extern path contents = do + let dc@(dc0:dcs) = symbols . intercalate "/" . splitDirectories . joinPath $ path + hdc = toLower dc0 : dcs + tell Output + { oAS = fromList $ "" + , oCH = fromList $ if extern then "extern\ \ struct binembed_node const " ++ dc ++ "[];\n" else "" + , oCC = fromList ( (if extern then "" else "static") ++ " struct binembed_node const " ++ dc ++ "[] = {\n" ) `mappend` + mconcat ( map (\edf -> fromList $ case edf of + Left (f, fs) -> " { " ++ show f ++ ", binembed_file, { .file = &" ++ fs ++ " } },\n" + Right (d, ds) -> " { " ++ show d ++ ", binembed_dir, { .dir = " ++ ds ++ " } },\n" + ) contents ) + `mappend` fromList " { 0, binembed_none, { .none = 0 } }\n};\n" + , oHS1 = fromList $ if extern then " , " ++ hdc ++ "\n" else "" + , oHS2 = fromList ( hdc ++ " :: Node (IO ByteString)\n" ++ hdc ++ " = Dir . fromList . tail $\n [ undefined\n" ) `mappend` + mconcat ( map (\edf -> fromList $ case edf of + Left (f, h:fs) -> " , (" ++ show f ++ ", File " ++ (toLower h : fs) ++ ")\n" + Right (d, h:ds) -> " , (" ++ show d ++ ", " ++ (toLower h : ds) ++ ")\n" + ) contents ) + `mappend` fromList " ]\n" + } + return $ Right (last path, dc) + +{- main program -} + +main :: IO () +main = do + args <- getArgs + main' args + +data Args = Args{ outputS, outputH, outputC, outputHS, infile :: [FilePath] } + +instance Monoid Args where + mempty = Args mempty mempty mempty mempty mempty + Args a b c d e `mappend` Args x y z u v = Args (a`mappend`x) (b`mappend`y) (c`mappend`z) (d`mappend`u) (e`mappend`v) + +toArg :: String -> Args +toArg ('-':'-':'o':'u':'t':'p':'u':'t':'-':'s':'=' :xs) = mempty{ outputS = [xs] } +toArg ('-':'-':'o':'u':'t':'p':'u':'t':'-':'h':'=' :xs) = mempty{ outputH = [xs] } +toArg ('-':'-':'o':'u':'t':'p':'u':'t':'-':'c':'=' :xs) = mempty{ outputC = [xs] } +toArg ('-':'-':'o':'u':'t':'p':'u':'t':'-':'h':'s':'=':xs) = mempty{ outputHS = [xs] } +toArg a@('-':_) = error $ "binembed: bad argument: " ++ a +toArg xs = mempty{ infile = [xs] } + +main' :: [String] -> IO () +main' args = do + let args' = mconcat . map toArg $ args + infile' = listToMaybe . reverse . infile $ args' + outs = listToMaybe . reverse . outputS $ args' + outh = listToMaybe . reverse . outputH $ args' + outc = listToMaybe . reverse . outputC $ args' + ouths = listToMaybe . reverse . outputHS $ args' + Just infile'' = infile' + dirs = splitDirectories infile'' + top = init dirs + name = last dirs + (stem, _ext) = splitExtension name + textExts = [] + libDir <- getLibDir + let include = libDir "include" "binembed.h" + ins <- mapM (listRec (joinPath top)) =<< lines `fmap` readFile infile'' + let out = execCodeGen (initialEnv stem 64 textExts include) $ do + initialCode + tops <- mapM (\(name', node) -> depthFirstPostOrder fileCode (dirCode False) [stem, name'] node) ins + _ <- dirCode True [stem] tops + finalCode + case outs of + Just outs' -> writeFile outs' (toList $ oAS out) + Nothing -> return () + case ouths of + Just ouths' -> writeFile ouths' (toList $ oHS1 out `mappend` oHS2 out) + Nothing -> return () + case outc of + Just outc' -> writeFile outc' (toList $ oCC out) + Nothing -> return () + case outh of + Just outh' -> writeFile outh' (toList $ oCH out) + Nothing -> return ()