"Fossies" - the Fresh Open Source Software Archive

Member "pp-2.14.3/tools/blob.hs" (24 Nov 2021, 3994 Bytes) of package /linux/privat/pp-2.14.3.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Haskell source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "blob.hs": 2.14.2_vs_2.14.3.

    1 #!/usr/bin/env stack
    2 {- stack
    3   script
    4   --package bytestring
    5   --package filepath
    6   --package split
    7 -}
    8 
    9 {- PP
   10 
   11 Copyright (C) 2015-2021 Christophe Delord
   12 
   13 http://cdelord.fr/pp
   14 
   15 This file is part of PP.
   16 
   17 PP is free software: you can redistribute it and/or modify
   18 it under the terms of the GNU General Public License as published by
   19 the Free Software Foundation, either version 3 of the License, or
   20 (at your option) any later version.
   21 
   22 PP is distributed in the hope that it will be useful,
   23 but WITHOUT ANY WARRANTY; without even the implied warranty of
   24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   25 GNU General Public License for more details.
   26 
   27 You should have received a copy of the GNU General Public License
   28 along with PP.  If not, see <http://www.gnu.org/licenses/>.
   29 -}
   30 
   31 {- This script reimplements xxd to remove a dependency.
   32  - It creates a C array with the content of the input file.
   33  -}
   34 
   35 import Data.Char
   36 import Data.List.Split
   37 import System.Environment
   38 import System.Exit
   39 import System.FilePath
   40 
   41 import qualified Data.ByteString as B
   42 
   43 main :: IO ()
   44 main = do
   45     args <- getArgs
   46     case args of
   47         [blobName] -> do
   48             let cvar = cVarname blobName
   49             let hsvar = hsVarname blobName
   50             let cmod = cFilename blobName
   51             let hsmod = hsFilename blobName
   52 
   53             putStrLn $ "Blob file: " ++ blobName
   54             blob <- B.readFile blobName
   55             let blobLen = B.length blob
   56             putStrLn $ "size     : " ++ show blobLen ++ " bytes"
   57 
   58             putStrLn $ "output   : " ++ cmod
   59             writeFile cmod $ unlines
   60                 [   "/* generated from " ++ takeFileName blobName ++ ". Do not modify. */"
   61                 ,   ""
   62                 ,   "unsigned char " ++ cvar ++ "[] = {"
   63                 ,   mkBlob blob
   64                 ,   "};"
   65                 ,   ""
   66                 ,   "unsigned int " ++ cvar ++ "_len = " ++ show blobLen ++ ";"
   67                 ]
   68 
   69             putStrLn $ "output   : " ++ hsmod
   70             writeFile hsmod $ unlines
   71                 [   "{- generated from " ++ takeFileName blobName ++ ". Do not modify. -}"
   72                 ,   ""
   73                 ,   "module " ++ dropExtension (takeFileName hsmod)
   74                 ,   "where"
   75                 ,   ""
   76                 ,   "import Foreign.C.Types"
   77                 ,   "import Foreign.Ptr"
   78                 ,   ""
   79                 ,   "foreign import ccall \"&" ++ cvar ++ "\"     _" ++ cvar ++ "     :: Ptr CChar"
   80                 ,   "foreign import ccall \"&" ++ cvar ++ "_len\" _" ++ cvar ++ "_len :: Ptr CInt"
   81                 ,   ""
   82                 ,   hsvar ++ " :: (Ptr CChar, Ptr CInt)"
   83                 ,   hsvar ++ " = (_" ++ cvar ++ ", _" ++ cvar ++ "_len)"
   84                 ]
   85 
   86         _ -> putStrLn "usage: hsblob <blob filename>" >> exitFailure
   87 
   88 cVarname :: FilePath -> String
   89 cVarname = map tr . takeFileName
   90     where
   91         tr c | isAlphaNum c = toLower c
   92              | otherwise = '_'
   93 
   94 hsVarname :: FilePath -> String
   95 hsVarname = lowerCamelCase . takeFileName
   96 
   97 filename :: FilePath -> FilePath
   98 filename name = dirname </> upperCamelCase basename
   99     where
  100         (dirname, basename) = splitFileName name
  101 
  102 cFilename :: FilePath -> FilePath
  103 cFilename = (<.> "c") . (++ "_c") . filename
  104 
  105 hsFilename :: FilePath -> FilePath
  106 hsFilename = (<.> "hs") . filename
  107 
  108 lowerCamelCase :: String -> String
  109 lowerCamelCase = lower . dropNonLetters
  110 
  111 upperCamelCase :: String -> String
  112 upperCamelCase = capitalize . dropNonLetters
  113 
  114 dropNonLetters :: String -> String
  115 dropNonLetters = dropWhile (not . isLetter)
  116 
  117 capitalize :: String -> String
  118 capitalize (c:cs) = toUpper c : lower cs
  119 capitalize [] = []
  120 
  121 lower :: String -> String
  122 lower (c:cs) | isAlphaNum c = toLower c : lower cs
  123              | otherwise    = capitalize $ dropNonLetters cs
  124 lower [] = []
  125 
  126 mkBlob :: B.ByteString -> String
  127 mkBlob blob = unlines $ map concat bytes
  128     where
  129         bytes = map (join ",") $ chunksOf 32 $ B.unpack blob
  130         join sep = map $ (++ sep) . show