diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Henning Thielemann + +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 Henning Thielemann 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.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/cutter.cabal b/cutter.cabal new file mode 100644 --- /dev/null +++ b/cutter.cabal @@ -0,0 +1,51 @@ +Name: cutter +Version: 0.0 +Synopsis: Cut files according to a position list +Description: + Cut a file into chunks according to a position list + and concatenate the chunks. + The chunks must not overlap and must be in increasing order. + . + Use it this way: + . + > cutter positions.csv dataout + . + The file @positions.csv@ must be a comma separated spreadsheet file (CSV), + where the first column contains the chunk beginnings + and the second column contains the pause beginnings. + A pause begins one byte after a chunk ends. + The other columns are ignored and may contain annotations of the chunks. + . + The positions file may also contain line numbers. + In this case you run the command this way: + . + > cutter -l positions.csv dataout + . + Example: remove selected attachments from e-mails in mbox file + using the @lsmbox@ command from . +License: BSD3 +License-File: LICENSE +Author: Henning Thielemann +Maintainer: haskell@henning-thielemann.de +Category: Console +Build-Type: Simple +Cabal-Version: >=1.8 + +Source-Repository this + Tag: 0.0 + Type: darcs + Location: http://hub.darcs.net/thielema/cutter/ + +Source-Repository head + Type: darcs + Location: http://hub.darcs.net/thielema/cutter/ + +Executable cutter + Main-Is: src/Main.hs + GHC-Options: -Wall + Build-Depends: + spreadsheet >=0.1.3 && <0.2, + explicit-exception >=0.1.6 && <0.2, + bytestring >=0.9.1 && <0.11, + utility-ht >=0.0.7 && <0.1, + base >=4.2 && <5 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,102 @@ +module Main where + +import qualified Data.Spreadsheet as Spreadsheet +import qualified Control.Monad.Exception.Synchronous as ExcSync +import qualified Control.Monad.Exception.Asynchronous as ExcAsync +import qualified Data.ByteString.Lazy.Char8 as BC +import qualified Data.List as List +import Control.Monad (liftM2, ) +import Data.Foldable (fold, foldMap, forM_, ) +import Data.Monoid (Monoid, mconcat, ) +import Data.Tuple.HT (swap, ) + +import qualified System.Environment as Env +import qualified System.Exit as Exit +import qualified System.IO as IO + +import Prelude hiding (take, drop, splitAt) + + +parseInteger :: String -> ExcSync.Exceptional String Integer +parseInteger str = + case reads str of + [(n, "")] -> return n + _ -> ExcSync.throw (show str ++ " is not an integer") + +parseCSVRow :: [String] -> ExcSync.Exceptional String (Integer, Integer) +parseCSVRow (from:to:_) = liftM2 (,) (parseInteger from) (parseInteger to) +parseCSVRow _ = ExcSync.throw "line contains less than two columns" + +parsePositions :: String -> ExcAsync.Exceptional String [(Integer, Integer)] +parsePositions = + flip ExcAsync.simultaneousBind + (foldMap (ExcAsync.fromSynchronousMonoid . fmap (:[]) . parseCSVRow)) . + Spreadsheet.fromString '"' ',' + +subtractPositions :: + [(Integer, Integer)] -> ExcAsync.Exceptional String [(Integer, Integer)] +subtractPositions xs = + fold $ + zipWith + (\oldStop (start, stop) -> ExcAsync.fromSynchronousMonoid $ do + ExcSync.assert "overlapping chunks or non-increasing positions" (oldStop<=start) + ExcSync.assert "negative chunks size" (start<=stop) + return [(start-oldStop, stop-start)]) + (0 : map snd xs) xs + + +class Monoid a => Cut a where + drop :: Integer -> a -> a + splitAt :: Integer -> a -> (a, a) + +instance Cut [a] where + drop = List.genericDrop + splitAt = List.genericSplitAt + +instance Cut BC.ByteString where + drop n = BC.drop (fromInteger n) + splitAt n = BC.splitAt (fromInteger n) + + +makeCutter :: + (Cut a) => + FilePath -> + IO (a -> ExcAsync.Exceptional String a) +makeCutter posFile = do + posTxt <- readFile posFile + return $ \xs0 -> + flip fmap + (ExcAsync.simultaneousBind (parsePositions posTxt) subtractPositions) + (mconcat . snd . + List.mapAccumL + (\xs (a,b) -> swap $ splitAt b $ drop a xs) + xs0) + + +exitFailureMsg :: String -> IO () +exitFailureMsg msg = do + IO.hPutStrLn IO.stderr msg + Exit.exitFailure + +interactExc :: + (BC.ByteString -> ExcAsync.Exceptional String BC.ByteString) -> IO () +interactExc f = do + x <- fmap f BC.getContents + case x of + ExcAsync.Exceptional e a -> do + BC.putStr a + forM_ e exitFailureMsg + +main :: IO () +main = do + args <- Env.getArgs + case args of + [positions] -> + makeCutter positions >>= interactExc + ["-c", positions] -> + makeCutter positions >>= interactExc + ["-l", positions] -> do + cutter <- makeCutter positions + interactExc (fmap BC.unlines . cutter . BC.lines) + _ -> do + exitFailureMsg "no position file given"