urembed (empty) → 0.5.0.0
raw patch · 5 files changed
+522/−0 lines, 5 filesdep +basedep +bytestringdep +cake3setup-changed
Dependencies added: base, bytestring, cake3, directory, filepath, language-javascript, mime-types, mtl, optparse-applicative, process, syb, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Help.txt +27/−0
- src/Urembed.hs +412/−0
- urembed.cabal +51/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Sergey Mironov++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 Sergey Mironov 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Help.txt view
@@ -0,0 +1,27 @@++ Converts a set of FILEs into the Ur/Web modules. Each Module will contain+ following functions:++ val binary : unit -> transaction blob+ val blobpage : unit -> transaction page+ val text : unit -> transaction string++ Additionally, FFI signatures will be provided for JavaScript files. In order+ to enable this, you have to name your JS functions using the name__type+ scheme. See README for details. Also, uru project uses this a lot.++ (NOTE: the interface is not stable. Pleas, fork the Urembed sources+ before using)++ The master project (specified with -o FILE.urp) will contain a dictionary+ version of those functions taking the datatype key as an argument, instead of+ unit. In order to actually compile the binaries, you have to call++ make -f FILE.mk CC=.. LD=.. UR_INCLUDE_DIR=.. urp++ Where FILE.mk is the Makefile, generated by urembed.++ Example: urembed -o static/Static.urp Style.css Script.js+ make -C static -f Static.mk CC=gcc LD=ld UR_INCLUDE_DIR=/usr/local/include/urweb urp++ Note: output directory should exist
+ src/Urembed.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ImpredicativeTypes #-}+module Main where++import Control.Monad.Error+import Control.Monad.State+import Control.Monad.Writer+import Language.JavaScript.Parser+import System.Environment+import System.Process+import System.Exit+import System.IO+import System.FilePath+import System.Directory+import System.Info+import Network.Mime+import Text.Printf+import Data.Either+import Data.Generics+import Data.Char+import Data.List+import Data.Data+import Data.Typeable+import Data.Maybe+import Data.String+import qualified Data.Text as T+import qualified Data.ByteString.Char8 as BS++import qualified Development.Cake3 as C3+import Development.Cake3(runMake,makevar,cmd,rule,extvar,File(..),phony,depend)+import qualified Development.Cake3.Rules.UrWeb as C3+import Development.Cake3.Rules.UrWeb (Config(..), urdeps,defaultConfig)++import Options.Applicative++import Paths_urembed++io :: (MonadIO m) => IO a -> m a+io = liftIO++hio :: (MonadIO m) => Handle -> String -> m ()+hio h = io . hPutStrLn h++err,out :: (MonadIO m) => String -> m ()+err = hio stderr+out = hio stdout+++span2 :: String -> String -> Maybe (String,String)+span2 inf s = span' [] s where+ span' _ [] = Nothing+ span' acc (c:cs)+ | isPrefixOf inf (c:cs) = Just (acc, drop (length inf) (c:cs))+ | otherwise = span' (acc++[c]) cs++data JSFunc = JSFunc {+ urdecl :: String+ , urname :: String+ , jsname :: String+ } deriving(Show)++data JSType = JSType {+ urtdecl :: String+ } deriving(Show)++-- | Parse the JavaScript file, extract top-level functions, convert their+-- signatures into Ur/Web format, return them as the list of strings+parse_js :: FilePath -> IO (Either String ([JSType],[JSFunc]))+parse_js file = do+ s <- readFile file+ runErrorT $ do+ c <- either fail return (parse s file)+ f <- concat <$> (forM (findTopLevelFunctions c) $ \f@(fn:_) -> (do+ ts <- mapM extractEmbeddedType (f`zip`(False:repeat True))+ let urdecl_ = urs_line ts+ let urname_ = (fst (head ts))+ let jsname_ = fn+ return [JSFunc urdecl_ urname_ jsname_]+ ) `catchError` (\(e::String) -> do+ err $ printf "ignoring function %s, reason:\n\t%s" fn e+ return []))+ t <- concat <$> (forM (findTopLevelVars c) $ \vn -> (do+ (n,t) <- extractEmbeddedType (vn,False)+ return [JSType $ printf "type %s" t]+ )`catchError` (\(e::String) -> do+ err $ printf "ignoring variable %s, reason:\n\t%s" vn e+ return []))++ return (t,f)++ where+ urs_line :: [(String,String)] -> String+ urs_line [] = error "wrong function signature"+ urs_line ((n,nt):args) = printf "val %s : %s" n (fmtargs args) where+ fmtargs :: [(String,String)] -> String+ fmtargs ((an,at):as) = printf "%s -> %s" at (fmtargs as)+ fmtargs [] = let pf = stripPrefix "pure_" nt in+ case pf of+ Just p -> p+ Nothing -> printf "transaction %s" nt++ extractEmbeddedType :: (Monad m) => (String,Bool) -> m (String,String)+ extractEmbeddedType ([],_) = error "BUG: empty identifier"+ extractEmbeddedType (name,fallback) = check (msum [span2 "__" name , span2 "_as_" name]) where+ check (Just (n,t)) = return (n,t)+ check _ | fallback == True = return (name,name)+ | fallback == False = fail $ printf "Can't extract the type from the identifier '%s'" name++ findTopLevelFunctions :: JSNode -> [[String]]+ findTopLevelFunctions top = map decls $ listify is_func top where+ is_func n@(JSFunction a b c d e f) = True+ is_func _ = False+ decls (JSFunction a b c d e f) = (identifiers b) ++ (identifiers d)++ findTopLevelVars :: JSNode -> [String]+ findTopLevelVars top = map decls $ listify is_var top where+ is_var n@(JSVarDecl a []) = True+ is_var _ = False+ decls (JSVarDecl a _) = (head $ identifiers a);+ + identifiers x = map name $ listify ids x where+ ids i@(JSIdentifier s) = True+ ids _ = False+ name (JSIdentifier n) = n++data Args = A+ { tgtdir :: FilePath+ , version :: Bool+ , files :: [FilePath]+ }++pargs :: Parser Args+pargs = A+ <$> strOption+ ( long "output"+ <> short 'o'+ <> metavar "FILE.urp"+ <> help "Name of the Ur/Web project being generated"+ <> value "")+ <*> flag False True ( long "version" <> help "Show version information" )+ <*> arguments str ( metavar "FILE" <> help "File to embed" )+ where+ osdefgcc | isInfixOf "linux" os = "/usr/bin/gcc"+ | isInfixOf "windows" os = "c:\\cygwin\\usr\\bin\\gcc"+ | otherwise = "/usr/local/bin/gcc"+++replaceExtensions f x = addExtension (dropExtensions f) x+f .= x = replaceExtensions f x++guessMime inf = fixup $ BS.unpack (defaultMimeLookup (fromString inf)) where+ fixup "application/javascript" = "text/javascript"+ fixup m = m++-- readBinaryFile name = BS.openBinaryFile name ReadMode >>= BS.hGetContents++main :: IO ()+main = do+ h <- (getDataFileName >=> readFile) "Help.txt" + main_ =<< execParser (+ info (helper <*> pargs)+ ( fullDesc+ <> progDesc h+ <> header "UrEmebed is the Ur/Web module generator" ))++main_ (A tgturp True ins) = do+ hPutStrLn stderr "urembed version 0.5.0.0"++main_ (A tgturp False ins) = do++ let tgtdir = takeDirectory tgturp++ when (null tgtdir) $ do+ fail "An output directory should be specified, use -o"++ when (null ins) $ do+ fail "At least one file should be specified, see --help"++ exists <- doesDirectoryExist tgtdir+ when (not exists) $ do+ fail "Output is not a directory"++ let indest n = tgtdir </> n+ let write n wr = writeFile (indest n) $ execWriter $ wr++ forM_ ins $ \inf -> do+ hPutStrLn stderr (printf "Processing %s" inf)++ let modname = (mkname inf)+ let modname_c = modname ++ "_c"+ let blobname = modname ++ "_c_blob"+ let modname_js = modname ++ "_js"+ let mime = guessMime inf++ -- Module_c.urp+ let binfunc = printf "uw_%s_binary" modname_c+ let textfunc = printf "uw_%s_text" modname_c++ write (replaceExtension modname_c ".urs") $ do+ line $ "val binary : unit -> transaction blob"+ line $ "val text : unit -> transaction string"++ content <- liftIO $ BS.readFile inf+ let csrc = replaceExtension modname_c ".c"+ write csrc $ do+ line $ "// Thanks, http://stupefydeveloper.blogspot.ru/2008/08/cc-embed-binary-data-into-elf.html"+ line $ "#include <urweb.h>"+ line $ "#include <stdio.h>"+ -- let start = printf "_binary___%s_start" blobname+ -- let size = printf "_binary___%s_size" blobname+ line $ printf "#define BLOBSZ %d" (BS.length content)+ line $ "static char blob[BLOBSZ];"+ line $ "uw_Basis_blob " ++ binfunc ++ " (uw_context ctx, uw_unit unit)"+ line $ "{"+ line $ " uw_Basis_blob uwblob;"+ line $ " uwblob.data = &blob[0];"+ line $ " uwblob.size = BLOBSZ;"+ line $ " return uwblob;"+ line $ "}"+ line $ ""+ line $ "uw_Basis_string " ++ textfunc ++ " (uw_context ctx, uw_unit unit) {"+ line $ " char* data = &blob[0];"+ line $ " size_t size = sizeof(blob);"+ line $ " char * c = uw_malloc(ctx, size+1);"+ line $ " char * write = c;"+ line $ " int i;"+ line $ " for (i = 0; i < size; i++) {"+ line $ " *write = data[i];"+ line $ " if (*write == '\\0')"+ line $ " *write = '\\n';"+ line $ " *write++;"+ line $ " }"+ line $ " *write=0;"+ line $ " return c;"+ line $ " }"+ line $ ""++ let append n wr = BS.appendFile (indest n) $ execWriter $ wr+ append csrc $ do+ let line s = tell ((BS.pack s)`mappend`(BS.pack "\n"))+ line $ ""+ line $ "static char blob[BLOBSZ] = {"+ let buf = reverse $ BS.foldl (\a c -> (BS.pack (printf "0x%02X ," c)) : a) [] content+ tell (BS.concat buf)+ line $ "};"+ line $ ""++ let header = (replaceExtension modname_c ".h")+ write header $ do+ line $ "#include <urweb.h>"+ line $ "uw_Basis_blob " ++ binfunc ++ " (uw_context ctx, uw_unit unit);"+ line $ "uw_Basis_string " ++ textfunc ++ " (uw_context ctx, uw_unit unit);"++ let binobj = replaceExtension modname_c ".o"+ -- let dataobj = replaceExtension modname_c ".data.o"++ write (replaceExtension modname_c ".urp") $ do+ line $ "ffi " ++ modname_c+ line $ "include " ++ header+ line $ "link " ++ binobj+ -- line $ "link " ++ dataobj++ -- Copy the file to the target dir and run linker from there. Thus the names+ -- it places will be correct (see start,size in _c)+ -- copyFile inf (indest blobname)++ -- Module_js.urp+ (jstypes,jsdecls) <- if ((takeExtension inf) == ".js") then do+ e <- parse_js inf+ case e of+ Left e -> do+ err $ printf "Error while parsing %s" (takeFileName inf)+ fail e+ Right decls -> do+ -- err (show decls)+ return decls+ else+ return ([],[])++ write (replaceExtension modname_js ".urs") $ do+ forM_ jstypes $ \decl -> line (urtdecl decl)+ forM_ jsdecls $ \decl -> line (urdecl decl)++ write (replaceExtension modname_js ".urp") $ do+ line $ "ffi " ++ modname_js+ forM_ jsdecls $ \decl -> do+ line $ printf "jsFunc %s.%s = %s" modname_js (urname decl) (jsname decl)+ line $ printf "benignEffectful %s.%s" modname_js (urname decl)+ + -- Module.urp+ write (replaceExtension modname ".urs") $ do+ line $ "val binary : unit -> transaction blob"+ line $ "val text : unit -> transaction string"+ line $ "val blobpage : unit -> transaction page"+ line $ "val geturl : url"+ forM_ jstypes $ \decl -> line (urtdecl decl)+ forM_ jsdecls $ \d -> line (urdecl d)++ write (replaceExtension modname ".ur") $ do+ line $ "val binary = " ++ modname_c ++ ".binary"+ line $ "val text = " ++ modname_c ++ ".text"+ forM_ jsdecls $ \d ->+ line $ printf "val %s = %s.%s" (urname d) modname_js (urname d)+ line $ printf "fun blobpage {} = b <- binary () ; returnBlob b (blessMime \"%s\")" mime+ line $ "val geturl = url(blobpage {})"++ write (replaceExtension modname ".urp") $ do+ line $ "library " ++ modname_c+ line $ "library " ++ modname_js+ line $ printf "safeGet %s/blobpage" modname+ line $ printf "safeGet %s/blob" modname+ line $ ""+ line $ modname++ -- Static.urp+ let tgt_in = replaceExtensions tgturp ".urp.in"++ writeFile tgt_in $ execWriter $ do+ forM_ ins $ \inf -> do+ line $ printf "library %s" (mkname inf)+ line []+ line (takeBaseName tgturp)++ let datatype = execWriter $ do+ tell "datatype content = "+ tell (mkname (head ins))+ forM_ (tail ins) (\f -> tell $ printf " | %s" (mkname f))++ writeFile (replaceExtensions tgt_in "urs") $ execWriter $ do+ line datatype+ line "val binary : content -> transaction blob"+ line "val text : content -> transaction string"+ line "val blobpage : content -> transaction page"+ line "val urls : list url"++ writeFile (replaceExtensions tgt_in "ur") $ execWriter $ do+ line datatype+ line $ "fun binary c = case c of"+ line $ printf " %s => %s.binary ()" (mkname (head ins)) (mkname (head ins))+ forM_ (tail ins) (\f -> line $+ printf " | %s => %s.binary ()" (mkname f) (mkname f))+ line $ "fun blobpage c = case c of"+ line $ printf " %s => %s.blobpage ()" (mkname (head ins)) (mkname (head ins))+ forM_ (tail ins) (\f -> line $+ printf " | %s => %s.blobpage ()" (mkname f) (mkname f))+ line $ "fun text c = case c of"+ line $ printf " %s => %s.text ()" (mkname (head ins)) (mkname (head ins))+ forM_ (tail ins) (\f -> line $+ printf " | %s => %s.text ()" (mkname f) (mkname f))+ line $ "val urls ="+ forM_ ins (\f -> line $+ printf " %s.geturl :: " (mkname f))+ line $ " []"++ -- Build the Makefile+ setCurrentDirectory tgtdir+ writeFile ((takeBaseName tgturp) .= ".mk") =<< (mdo+ let file x = C3.file' tgtdir tgtdir x+ let cc = extvar "CC"+ let ld = extvar "LD"+ let incl = extvar "UR_INCLUDE_DIR"++ let tgt_in = file (takeBaseName tgturp .= ".urp.in") + let tgt = file (takeBaseName tgturp .= ".urp") ++ urp_in <- C3.ruleM tgt_in $ do+ flip urdeps tgt_in (+ defaultConfig {+ urObjRule = \f -> rule f $ do+ case isInfixOf "data" (C3.takeExtensions f) of+ True -> do+ let src = C3.fromFilePath . (++"_blob") . dropExtensions . C3.toFilePath $ f+ C3.shell [cmd| $(ld) -r -b binary -o $f $(src :: File) |]+ False -> do+ let src = C3.fromFilePath . flip replaceExtensions "c" . C3.toFilePath $ f+ C3.shell [cmd| $(cc) -c -I $incl -o $f $(src :: File) |]+ })++ urp <- C3.ruleM tgt $ do+ C3.shell [cmd|cp $(urp_in) $(urp) |]+ C3.shell [cmd|echo $urp|]++ runMake $ do+ C3.place (phony "urp" (depend urp))+ )++ hPutStrLn stderr "Done"++ where++ line s = tell (s++"\n")+ + process = process' Nothing+ process' wd args = do+ (_,hout,herr,ph) <- runInteractiveProcess (head args) (tail args) wd Nothing+ code <- waitForProcess ph+ when (code /= ExitSuccess) $ do+ hGetContents hout >>= hPutStrLn stderr+ hGetContents herr >>= hPutStrLn stderr + fail $ printf "process %s failed to complete with %s" (show args) (show code)+ return ()++ mkname f = upper1 . notnum . map under . takeFileName $ f where+ under c | c`elem`"_-. /" = '_'+ | otherwise = c+ upper1 [] = []+ upper1 (x:xs) = (toUpper x) : xs+ notnum n@(x:xs) | isDigit x = "f" ++ n+ | otherwise = n+
+ urembed.cabal view
@@ -0,0 +1,51 @@+-- Initial urembed.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: urembed+version: 0.5.0.0+synopsis: Ur/Web static content generator+description: Urembed converts a set of FILEs into the Ur/Web modules. Each Module will contain+ following functions:++ val binary : unit -> transaction blob+ val blobpage : unit -> transaction page+ val text : unit -> transaction string++ Additionally, FFI signatures will be provided for JavaScript files. In order+ to enable this, you have to name your JS functions using the name__type+ scheme. See README for details. Also, uru project uses this a lot.++ (NOTE: the interface is not stable. Pleas, fork the Urembed sources+ before using)++ The master project (specified with -o FILE.urp) will contain a dictionary+ version of those functions taking the datatype key as an argument, instead of+ unit. In order to actually compile the binaries, you have to call++ make -f FILE.mk CC=.. LD=.. UR_INCLUDE_DIR=.. urp++ Where FILE.mk is the Makefile, generated by urembed.++ Example: urembed -o static/Static.urp Style.css Script.js+ make -C static -f Static.mk CC=gcc LD=ld UR_INCLUDE_DIR=/usr/local/include/urweb urp++ Note: output directory should exist+homepage: http://github.com/grwlf/urembed+license: BSD3+license-file: LICENSE+author: Sergey Mironov+maintainer: grrwlf@gmail.com+-- copyright: +category: Development+build-type: Simple+cabal-version: >=1.8+data-dir: src+data-files: Help.txt++executable urembed+ main-is: Urembed.hs+ build-depends: base == 4.6.*, mtl, language-javascript ==0.5.*, process,+ filepath, syb, optparse-applicative, directory,+ mime-types, text, bytestring, cake3+ hs-source-dirs: src+