diff --git a/MissingH.cabal b/MissingH.cabal --- a/MissingH.cabal +++ b/MissingH.cabal @@ -1,10 +1,9 @@ --- arch-tag: MissingH main description file Name: MissingH -Version: 0.18.6 +Version: 1.0.0 License: GPL Maintainer: John Goerzen Author: John Goerzen -Copyright: Copyright (c) 2004-2007 John Goerzen +Copyright: Copyright (c) 2004-2008 John Goerzen license-file: COPYRIGHT extra-source-files: COPYING homepage: http://software.complete.org/missingh @@ -14,8 +13,16 @@ Haskell programmers. It is written in pure Haskell and thus should be extremely portable and easy to use. Stability: Beta -Hs-Source-Dirs: src -Exposed-Modules: Data.String, System.IO.Utils, System.IO.Binary, Data.List.Utils, +Build-Type: Simple +Cabal-Version: >=1.2 + +Flag splitBase + description: Choose the new smaller, split-up base package. + +Library + Hs-Source-Dirs: src + Exposed-Modules: + Data.String.Utils, System.IO.Utils, System.IO.Binary, Data.List.Utils, System.Daemon, Text.ParserCombinators.Parsec.Utils, Test.HUnit.Utils, @@ -34,6 +41,7 @@ Network.SocketServer, Data.Either.Utils, Data.Maybe.Utils, + Data.Tuple.Utils, Data.Bits.Utils, Data.Hash.CRC32.Posix, Data.Hash.CRC32.GZip, Data.Hash.MD5, Data.Hash.MD5.Zord64_HARD, @@ -48,17 +56,31 @@ System.Debian, System.Debian.ControlParser, Data.MIME.Types, System.Console.GetOpt.Utils -Extensions: ExistentialQuantification, OverlappingInstances, - UndecidableInstances, CPP -Build-Depends: network, parsec, base, + + Extensions: ExistentialQuantification, OverlappingInstances, + UndecidableInstances, CPP, Rank2Types, + MultiParamTypeClasses, FlexibleInstances, FlexibleContexts + -- Hack because ghc-6.6 and the Cabal the comes with ghc-6.8.1 + -- does not understand the PatternSignatures extension. + -- The Cabal that comes with ghc-6.8.2 does understand it, so + -- this hack can be dropped if we require Cabal-Version: >=1.2.3 + If impl(ghc >= 6.8) + GHC-Options: -XPatternSignatures + + Build-Depends: network, parsec, base, haskell98, mtl, HUnit, regex-compat, QuickCheck, filepath, hslogger --- Cabal will automatically add unix here on non-Windows platforms -GHC-Options: -O2 + If flag(splitBase) + Build-Depends: base >= 3, directory, random, process, old-time, + containers, old-locale, array + Else + Build-Depends: base < 3 + If ! os(windows) + Build-Depends: unix -Executable: runtests -Buildable: False -Main-Is: runtests.hs -HS-Source-Dirs: testsrc, . -Extensions: ExistentialQuantification, OverlappingInstances, +Executable runtests + Buildable: False + Main-Is: runtests.hs + HS-Source-Dirs: testsrc, . + Extensions: ExistentialQuantification, OverlappingInstances, UndecidableInstances, CPP diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,22 +1,5 @@ #!/usr/bin/env runhugs import Distribution.Simple -import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo -import Distribution.Version -import System.Info -import Data.Maybe -import System.Cmd -missingHooks = defaultUserHooks {confHook = customConfHook} - -customConfHook descrip flags = - let mydescrip = case System.Info.os of - "mingw32" -> descrip - _ -> descrip {buildDepends = - (Dependency "unix" AnyVersion) : - buildDepends descrip} - in (confHook defaultUserHooks) mydescrip flags - -main = defaultMainWithHooks missingHooks - +main = defaultMain diff --git a/src/Data/CSV.hs b/src/Data/CSV.hs --- a/src/Data/CSV.hs +++ b/src/Data/CSV.hs @@ -30,14 +30,19 @@ Written by John Goerzen, jgoerzen\@complete.org -} -module Data.CSV(csvFile, genCsvFile) where +module Data.CSV (csvFile, genCsvFile) where import Text.ParserCombinators.Parsec -import Data.List +import Data.List (intersperse) +eol :: forall st. GenParser Char st String eol = (try $ string "\n\r") <|> (try $ string "\r\n") <|> string "\n" <|> string "\r" "End of line" + +cell :: GenParser Char st String cell = quotedcell <|> many (noneOf ",\n\r") -quotedchar = noneOf "\"" + +quotedchar :: GenParser Char st Char +quotedchar = noneOf "\"" <|> (try $ do string "\"\"" return '"' ) @@ -46,6 +51,8 @@ content <- many quotedchar char '"' return content + +line :: GenParser Char st [String] line = sepBy cell (char ',') {- | Parse a Comma-Separated Value (CSV) file. The return value is a list of diff --git a/src/Data/Either/Utils.hs b/src/Data/Either/Utils.hs --- a/src/Data/Either/Utils.hs +++ b/src/Data/Either/Utils.hs @@ -34,7 +34,8 @@ maybeToEither, forceEither, forceEitherMsg, - eitherToMonadError + eitherToMonadError, + fromLeft, fromRight, fromEither ) where import Control.Monad.Error @@ -71,3 +72,20 @@ eitherToMonadError :: MonadError e m => Either e a -> m a eitherToMonadError (Left x) = throwError x eitherToMonadError (Right x) = return x + + +-- | Take a Left to a value, crashes on a Right +fromLeft :: Either a b -> a +fromLeft (Left a) = a +fromLeft _ = error "Data.Either.Utils.fromLeft: Right" + +-- | Take a Right to a value, crashes on a Left +fromRight :: Either a b -> b +fromRight (Right a) = a +fromRight _ = error "Data.Either.Utils.fromRight: Left" + +-- | Take an Either, and return the value inside it +fromEither :: Either a a -> a +fromEither (Left a) = a +fromEither (Right a) = a + diff --git a/src/Data/List/Utils.hs b/src/Data/List/Utils.hs --- a/src/Data/List/Utils.hs +++ b/src/Data/List/Utils.hs @@ -59,9 +59,7 @@ -- sub, ) where import Data.List(intersperse, concat, isPrefixOf, isSuffixOf, elemIndices, - elemIndex, elemIndices, tails, find, findIndex) -import IO -import System.IO.Unsafe + elemIndex, elemIndices, tails, find, findIndex, isInfixOf) import Control.Monad.State(State, get, put) import Data.Maybe(isJust) @@ -229,6 +227,7 @@ genericJoin :: Show a => String -> [a] -> String genericJoin delim l = join delim (map show l) +{-# DEPRECATED contains "Use Data.List.isInfixOf, will be removed in MissingH 1.1.0" #-} {- | Returns true if the given parameter is a sublist of the given list; false otherwise. @@ -236,10 +235,14 @@ > contains "Haskell" "I really like Haskell." -> True > contains "Haskell" "OCaml is great." -> False + +This function was submitted to GHC and was applied as +'Data.List.isInfixOf'. This function therefore is deprecated and will +be removed in future versions. -} contains :: Eq a => [a] -> [a] -> Bool -contains substr str = isJust $ find (isPrefixOf substr) (tails str) +contains = isInfixOf -- above function submitted to GHC as Data.List.isInfixOf on 8/31/2006 @@ -473,7 +476,7 @@ This function is not compatible with infinite lists. -} uniq :: Eq a => [a] -> [a] uniq [] = [] -uniq (x:xs) = x : filter (/= x) (uniq xs) +uniq (x:xs) = x : uniq (filter (/= x) xs) ----- same as --uniq (x:xs) = x : [y | y <- uniq xs, y /= x] diff --git a/src/Data/MIME/Types.hs b/src/Data/MIME/Types.hs --- a/src/Data/MIME/Types.hs +++ b/src/Data/MIME/Types.hs @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2004-2005 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -45,7 +45,6 @@ where import qualified Data.Map as Map -import qualified System.Directory import Monad import System.IO import System.IO.Error @@ -55,10 +54,10 @@ import Data.Char ---------------------------------------------------------------------- --- Basic type decl +-- Basic type declarations ---------------------------------------------------------------------- -data MIMETypeData = MIMETypeData +data MIMETypeData = MIMETypeData { -- | A mapping used to expand common suffixes into equivolent, -- better-parsed versions. For instance, ".tgz" would expand @@ -88,8 +87,6 @@ {- | Read the given mime.types file and add it to an existing object. Returns new object. -} - - readMIMETypes :: MIMETypeData -- ^ Data to work with -> Bool -- ^ Whether to work on strict data -> FilePath -- ^ File to read @@ -103,10 +100,10 @@ -> Bool -- ^ Whether to work on strict data -> Handle -- ^ Handle to read from -> IO MIMETypeData -- ^ New object -hReadMIMETypes mtd strict h = +hReadMIMETypes mtd strict h = let parseline :: MIMETypeData -> String -> MIMETypeData parseline obj line = - let l1 = words line + let l1 = words line procwords [] = [] procwords (('#':_) :_) = [] procwords (x:xs) = x : procwords xs @@ -119,29 +116,28 @@ foldl (\o suff -> addType o strict thetype ('.' : suff)) obj suffixlist else obj in - do - lines <- hGetLines h - return (foldl parseline mtd lines) + do + lines <- hGetLines h + return (foldl parseline mtd lines) {- | Guess the type of a file given a filename or URL. The file is not opened; only the name is considered. -} - guessType :: MIMETypeData -- ^ Source data for guessing -> Bool -- ^ Whether to limit to strict data -> String -- ^ File or URL name to consider -> MIMEResults -- ^ Result of guessing (see 'MIMEResults' for details on interpreting it) -guessType mtd strict fn = - let mapext (base, ext) = - case Map.lookup ext (suffixMap mtd) of - Nothing -> (base, ext) +guessType mtd strict fn = + let mapext (base, ex) = + case Map.lookup ex (suffixMap mtd) of + Nothing -> (base, ex) Just x -> mapext (splitExt (base ++ x)) - checkencodings (base, ext) = - case Map.lookup ext (encodingsMap mtd) of - Nothing -> (base, ext, Nothing) + checkencodings (base, ex) = + case Map.lookup ex (encodingsMap mtd) of + Nothing -> (base, ex, Nothing) Just x -> (fst (splitExt base), snd (splitExt base), Just x) - (base, ext, enc) = checkencodings . mapext $ splitExt fn + (_, ext, enc) = checkencodings . mapext $ splitExt fn typemap = getStrict mtd strict in case Map.lookup ext typemap of @@ -160,7 +156,7 @@ -> Bool -- ^ Whether to limit to strict data -> String -- ^ MIME type to consider -> Maybe String -- ^ Result of guessing, or Nothing if no match possible -guessExtension mtd strict fn = +guessExtension mtd strict fn = case guessAllExtensions mtd strict fn of [] -> Nothing (x:_) -> Just x @@ -176,22 +172,21 @@ themap = getStrict mtd strict in flippedLookupM mimetype themap - + {- | Adds a new type to the data structures, replacing whatever data may exist about it already. That is, it overrides existing information about the given extension, but the same type may occur more than once. -} - addType :: MIMETypeData -- ^ Source data -> Bool -- ^ Whether to add to strict data set -> String -- ^ MIME type to add -> String -- ^ Extension to add -> MIMETypeData -- ^ Result of addition -addType mtd strict thetype theext = +addType mtd strict thetype theext = setStrict mtd strict (\m -> Map.insert theext thetype m) {- | Default MIME type data to use -} defaultmtd :: MIMETypeData -defaultmtd = +defaultmtd = MIMETypeData {suffixMap = default_suffix_map, encodingsMap = default_encodings_map, typesMap = default_types_map, @@ -202,7 +197,7 @@ readSystemMIMETypes :: MIMETypeData -> IO MIMETypeData readSystemMIMETypes mtd = let tryread :: MIMETypeData -> String -> IO MIMETypeData - tryread inputobj filename = + tryread inputobj filename = do fn <- try (openFile filename ReadMode) case fn of @@ -213,12 +208,11 @@ return x in do - foldM tryread mtd defaultfilelocations + foldM tryread mtd defaultfilelocations ---------------------------------------------------------------------- -- Internal utilities ---------------------------------------------------------------------- - getStrict :: MIMETypeData -> Bool -> Map.Map String String getStrict mtd True = typesMap mtd getStrict mtd False = Map.union (typesMap mtd) (commonTypesMap mtd) @@ -230,7 +224,7 @@ ---------------------------------------------------------------------- -- Default data structures ---------------------------------------------------------------------- - +defaultfilelocations :: [String] defaultfilelocations = [ "/etc/mime.types", @@ -240,13 +234,13 @@ "/usr/local/etc/mime.types" -- Apache 1.3 ] - +default_encodings_map, default_suffix_map, default_types_map, default_common_types :: Map.Map String String default_encodings_map = Map.fromList [ (".Z", "compress"), (".gz", "gzip"), (".bz2", "bzip2") ] - + default_suffix_map = Map.fromList [ (".tgz", ".tar.gz"), (".tz", ".tar.gz"), diff --git a/src/Data/Progress/Meter.hs b/src/Data/Progress/Meter.hs --- a/src/Data/Progress/Meter.hs +++ b/src/Data/Progress/Meter.hs @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2006 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -39,7 +39,7 @@ addComponent, removeComponent, setWidth, - + -- * Rendering and Output renderMeter, displayMeter, @@ -50,17 +50,16 @@ ) where import Data.Progress.Tracker -import Control.Concurrent.MVar import Control.Concurrent -import Control.Monad(when) -import Data.String -import System.Time.Utils -import Data.Quantity +import Control.Monad (when) +import Data.String.Utils (join) +import System.Time.Utils (renderSecs) +import Data.Quantity (renderNums, binaryOpts) import System.IO -import Control.Monad(filterM) +import Control.Monad (filterM) {- | The main data type for the progress meter. -} -data ProgressMeterR = +data ProgressMeterR = ProgressMeterR {masterP :: Progress, -- ^ The master 'Progress' object for overall status components :: [Progress], -- ^ Individual component statuses width :: Int, -- ^ Width of the meter @@ -91,7 +90,7 @@ -> Int -- ^ Width of the terminal -- usually 80 -> ([Integer] -> [String])-- ^ A function to render sizes -> IO ProgressMeter -newMeter tracker u w rfunc = +newMeter tracker u w rfunc = newMVar $ ProgressMeterR {masterP = tracker, components = [], width = w, renderer = rfunc, autoDisplayers = [], unit = u} @@ -102,7 +101,7 @@ {- | Add a new component to the list of components. -} addComponent :: ProgressMeter -> Progress -> IO () -addComponent meter component = +addComponent meter component = modifyMVar_ meter (\m -> return $ m {components = component : components m}) {- | Remove a component by name. -} @@ -116,9 +115,9 @@ setWidth :: ProgressMeter -> Int -> IO () setWidth meter w = modifyMVar_ meter (\m -> return $ m {width = w}) -{- | Like renderMeter, but prints it to the screen instead of returning it. +{- | Like renderMeter, but prints it to the screen instead of returning it. -This function will output CR, then the meter. +This function will output CR, then the meter. Pass stdout as the handle for regular display to the screen. -} displayMeter :: Handle -> ProgressMeter -> IO () @@ -130,15 +129,15 @@ -- lock the IO and prevent IO from stomping on each other. {- | Clears the meter -- outputs CR, spaces equal to the width - 1, -then another CR. +then another CR. Pass stdout as the handle for regular display to the screen. -} clearMeter :: Handle -> ProgressMeter -> IO () -clearMeter h pm = withMVar pm $ \m -> +clearMeter h pm = withMVar pm $ \m -> do hPutStr h (clearmeterstr m) hFlush h -{- | Clears the meter, writes the given string, then restores the meter. +{- | Clears the meter, writes the given string, then restores the meter. The string is assumed to contain a trailing newline. Pass stdout as the handle for regular display to the screen. -} @@ -150,11 +149,11 @@ hPutStr h s hFlush h +clearmeterstr :: ProgressMeterR -> String clearmeterstr m = "\r" ++ replicate (width m - 1) ' ' ++ "\r" - {- | Starts a thread that updates the meter every n seconds by calling -the specified function. Note: @displayMeter stdout@ +the specified function. Note: @displayMeter stdout@ is an ideal function here. Save this threadID and use it later to call 'stopAutoDisplayMeter'. @@ -185,7 +184,7 @@ You should probably call 'clearMeter' after a call to this. -} killAutoDisplayMeter :: ProgressMeter -> ThreadId -> IO () -killAutoDisplayMeter pm t = +killAutoDisplayMeter pm t = modifyMVar_ pm (\p -> return $ p {autoDisplayers = filter (/= t) (autoDisplayers p)}) {- | Render the current status. -} @@ -194,10 +193,10 @@ renderMeterR :: ProgressMeterR -> IO String renderMeterR meter = - do overallpct <- renderpct (masterP meter) - components <- mapM (rendercomponent (renderer meter)) + do overallpct <- renderpct $ masterP meter + compnnts <- mapM (rendercomponent $ renderer meter) (components meter) - let componentstr = case join " " components of + let componentstr = case join " " compnnts of [] -> "" x -> x ++ " " rightpart <- renderoverall (renderer meter) (masterP meter) @@ -206,25 +205,28 @@ if padwidth < 1 then return $ take (width meter - 1) $ leftpart ++ rightpart else return $ leftpart ++ replicate padwidth ' ' ++ rightpart - - where renderpct pt = + + where + u = unit meter + renderpct pt = withStatus pt renderpctpts - renderpctpts pts = + renderpctpts pts = if (totalUnits pts == 0) then return "0%" else return $ show (((completedUnits pts) * 100) `div` (totalUnits pts)) ++ "%" - rendercomponent :: ([Integer] -> [String]) -> Progress -> IO String - rendercomponent rfunc pt = withStatus pt $ \pts -> + rendercomponent :: ([Integer] -> [String]) -> Progress -> IO String + rendercomponent rfunc pt = withStatus pt $ \pts -> do pct <- renderpctpts pts - let u = unit meter let renders = rfunc [totalUnits pts, completedUnits pts] return $ "[" ++ trackerName pts ++ " " ++ (renders !! 1) ++ u ++ "/" ++ head renders ++ u ++ " " ++ pct ++ "]" - renderoverall rfunc pt = withStatus pt $ \pts -> - do etr <- getETR pts - speed <- getSpeed pts - return $ head (rfunc [floor speed]) ++ (unit meter) ++ - "/s " ++ renderSecs etr + + renderoverall :: (ProgressStatuses a (IO [Char])) => ([Integer] -> [[Char]]) -> a -> IO [Char] + renderoverall rfunc pt = withStatus pt $ \pts -> + do etr <- getETR pts + speed <- getSpeed pts + return $ head (rfunc [floor (speed :: Double)]) ++ u ++ + "/s " ++ renderSecs etr diff --git a/src/Data/String.hs b/src/Data/String.hs deleted file mode 100644 --- a/src/Data/String.hs +++ /dev/null @@ -1,100 +0,0 @@ -{- arch-tag: String utilities main file -Copyright (C) 2004-2006 John Goerzen - -This program is free software; you can redistribute it and\/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- | - Module : Data.String - Copyright : Copyright (C) 2004-2006 John Goerzen - License : GNU GPL, version 2 or above - - Maintainer : John Goerzen - Stability : provisional - Portability: portable - -This module provides various helpful utilities for dealing with strings. - -Written by John Goerzen, jgoerzen\@complete.org --} - -module Data.String - (-- * Whitespace Removal - strip, lstrip, rstrip, - -- * Tests - -- | Note: These functions are aliases for functions - -- in "Data.List.Utils". - startswith, endswith, - -- * Conversions - -- | Note: Some of these functions are aliases for functions - -- in "Data.List.Utils". - join, split, splitWs, replace, escapeRe - ) where -import Data.List.Utils(startswith, endswith, join, split, replace) -import Data.Char -import Text.Regex - -wschars = " \t\r\n" - -{- | Removes any whitespace characters that are present at the start -or end of a string. Does not alter the internal contents of a -string. If no whitespace characters are present at the start or end -of a string, returns the original string unmodified. Safe to use on -any string. - -Note that this may differ from some other similar -functions from other authors in that: - -1. If multiple whitespace -characters are present all in a row, they are all removed; - -2. If no -whitespace characters are present, nothing is done. --} - -strip :: String -> String -strip = lstrip . rstrip - --- | Same as 'strip', but applies only to the left side of the string. -lstrip :: String -> String -lstrip s = case s of - [] -> [] - (x:xs) -> if elem x wschars - then lstrip xs - else s - --- | Same as 'strip', but applies only to the right side of the string. -rstrip :: String -> String -rstrip = reverse . lstrip . reverse - -{- | Splits a string around whitespace. Empty elements in the result -list are automatically removed. -} -splitWs :: String -> [String] -splitWs = filter (\x -> x /= []) . splitRegex (mkRegex "[ \t\n\r\v\f]+") - -{- | Escape all characters in the input pattern that are not alphanumeric. - -Does not make special allowances for NULL, which isn't valid in a -Haskell regular expression pattern. -} -escapeRe :: String -> String -escapeRe [] = [] -escapeRe (x:xs) - -- Chars that we never escape - | x `elem` ['\'', '`'] = x : escapeRe xs - -- General rules for chars we never escape - | isDigit x || (isAscii x && isAlpha x) || x `elem` ['<', '>'] - = x : escapeRe xs - -- Escape everything else - | otherwise = '\\' : x : escapeRe xs diff --git a/src/Data/String/Utils.hs b/src/Data/String/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/String/Utils.hs @@ -0,0 +1,101 @@ +{- arch-tag: String utilities main file +Copyright (C) 2004-2006 John Goerzen + +This program is free software; you can redistribute it and\/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Data.String.Utils + Copyright : Copyright (C) 2004-2008 John Goerzen + License : GNU GPL, version 2 or above + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +This module provides various helpful utilities for dealing with strings. + +Written by John Goerzen, jgoerzen\@complete.org +-} + +module Data.String.Utils + (-- * Whitespace Removal + strip, lstrip, rstrip, + -- * Tests + -- | Note: These functions are aliases for functions + -- in "Data.List.Utils". + startswith, endswith, + -- * Conversions + -- | Note: Some of these functions are aliases for functions + -- in "Data.List.Utils". + join, split, splitWs, replace, escapeRe + ) where + +import Data.List.Utils (startswith, endswith, join, split, replace) +import Data.Char (isAlpha, isAscii, isDigit) +import Text.Regex (mkRegex, splitRegex) + +wschars :: String +wschars = " \t\r\n" + +{- | Removes any whitespace characters that are present at the start +or end of a string. Does not alter the internal contents of a +string. If no whitespace characters are present at the start or end +of a string, returns the original string unmodified. Safe to use on +any string. + +Note that this may differ from some other similar +functions from other authors in that: + +1. If multiple whitespace +characters are present all in a row, they are all removed; + +2. If no +whitespace characters are present, nothing is done. +-} +strip :: String -> String +strip = lstrip . rstrip + +-- | Same as 'strip', but applies only to the left side of the string. +lstrip :: String -> String +lstrip s = case s of + [] -> [] + (x:xs) -> if elem x wschars + then lstrip xs + else s + +-- | Same as 'strip', but applies only to the right side of the string. +rstrip :: String -> String +rstrip = reverse . lstrip . reverse + +{- | Splits a string around whitespace. Empty elements in the result +list are automatically removed. -} +splitWs :: String -> [String] +splitWs = filter (\x -> x /= []) . splitRegex (mkRegex "[ \t\n\r\v\f]+") + +{- | Escape all characters in the input pattern that are not alphanumeric. + +Does not make special allowances for NULL, which isn't valid in a +Haskell regular expression pattern. -} +escapeRe :: String -> String +escapeRe [] = [] +escapeRe (x:xs) + -- Chars that we never escape + | x `elem` ['\'', '`'] = x : escapeRe xs + -- General rules for chars we never escape + | isDigit x || (isAscii x && isAlpha x) || x `elem` ['<', '>'] + = x : escapeRe xs + -- Escape everything else + | otherwise = '\\' : x : escapeRe xs diff --git a/src/Data/Tuple/Utils.hs b/src/Data/Tuple/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tuple/Utils.hs @@ -0,0 +1,49 @@ +{- arch-tag: Tuple utilities main file +Copyright (C) 2004-2006 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Data.Tuple.Utils + Copyright : Copyright (C) 2004-2008 John Goerzen + License : GNU GPL, version 2 or above + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +This module provides various helpful utilities for dealing with lists. + +Written by Neil Mitchell, +-} + +module Data.Tuple.Utils( + -- * Extraction + fst3, snd3, thd3 + ) where + + +-- | Take the first item out of a 3 element tuple +fst3 :: (a,b,c) -> a +fst3 (a,b,c) = a + +-- | Take the second item out of a 3 element tuple +snd3 :: (a,b,c) -> b +snd3 (a,b,c) = b + +-- | Take the third item out of a 3 element tuple +thd3 :: (a,b,c) -> c +thd3 (a,b,c) = c diff --git a/src/Network/Email/Sendmail.hs b/src/Network/Email/Sendmail.hs --- a/src/Network/Email/Sendmail.hs +++ b/src/Network/Email/Sendmail.hs @@ -22,7 +22,7 @@ Copyright : Copyright (C) 2004-2005 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -45,6 +45,7 @@ import System.IO import System.IO.Error +sendmails :: [String] sendmails = ["/usr/sbin/sendmail", "/usr/local/sbin/sendmail", "/usr/local/bin/sendmail", @@ -90,12 +91,12 @@ -> IO () sendmail _ [] _ = fail "sendmail: no recipients specified" sendmail Nothing recipients msg = sendmail_worker recipients msg -sendmail (Just from) recipients msg = +sendmail (Just from) recipients msg = sendmail_worker (("-f" ++ from) : recipients) msg - + sendmail_worker :: [String] -> String -> IO () sendmail_worker args msg = - let func h = hPutStr h msg + let func h = hPutStr h msg in do --pOpen WriteToPipe "/usr/sbin/sendmail" args func @@ -104,8 +105,8 @@ Right x -> return x Left _ -> do sn <- findsendmail - rv <- pOpen WriteToPipe sn args func - return $! rv - + r <- pOpen WriteToPipe sn args func + return $! r + #endif diff --git a/src/Network/Utils.hs b/src/Network/Utils.hs --- a/src/Network/Utils.hs +++ b/src/Network/Utils.hs @@ -15,13 +15,12 @@ along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} - {- | Module : Network.Utils Copyright : Copyright (C) 2004-2005 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: systems with networking @@ -31,10 +30,10 @@ -} -module Network.Utils(niceSocketsDo, connectTCP, connectTCPAddr, - listenTCPAddr, showSockAddr - ) -where +module Network.Utils (niceSocketsDo, connectTCP, connectTCPAddr, + listenTCPAddr, showSockAddr) + where + import Network import Network.Socket import Network.BSD @@ -43,11 +42,11 @@ {- | Sets up the system for networking. Similar to the built-in withSocketsDo (and actually, calls it), but also sets the SIGPIPE -handler so that signal is ignored. +handler so that signal is ignored. Example: -> main = niceSocketsDo $ do { ... } +> main = niceSocketsDo $ do { ... } -} -- FIXME integrate with WebCont.Util.UDP @@ -56,7 +55,7 @@ niceSocketsDo func = do #ifndef mingw32_HOST_OS -- No signals on Windows anyway - System.Posix.Signals.installHandler + System.Posix.Signals.installHandler System.Posix.Signals.sigPIPE System.Posix.Signals.Ignore Nothing @@ -74,7 +73,7 @@ s <- socket AF_INET Stream proto connect s addr return s - + listenTCPAddr :: SockAddr -> Int -> IO Socket listenTCPAddr addr queuelen = do proto <- getProtocolNumber "tcp" diff --git a/src/System/Cmd/Utils.hs b/src/System/Cmd/Utils.hs --- a/src/System/Cmd/Utils.hs +++ b/src/System/Cmd/Utils.hs @@ -23,7 +23,7 @@ Copyright : Copyright (C) 2004-2006 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable to platforms with POSIX process\/signal tools @@ -99,7 +99,7 @@ pOpen, pOpen3, pOpen3Raw #endif #endif - ) + ) where -- FIXME - largely obsoleted by 6.4 - convert to wrappers. @@ -122,6 +122,7 @@ data PipeMode = ReadFromPipe | WriteToPipe +logbase :: String logbase = "System.Cmd.Utils" {- | Return value from 'pipeFrom', 'pipeLinesFrom', 'pipeTo', or @@ -129,7 +130,7 @@ executed. If you prefer not to use 'forceSuccess' on the result of one of these pipe calls, you can use (processID ph), assuming ph is your 'PipeHandle', as a parameter to 'System.Posix.Process.getProcessStatus'. -} -data PipeHandle = +data PipeHandle = PipeHandle { processID :: ProcessID, phCommand :: FilePath, phArgs :: [String], @@ -152,7 +153,10 @@ #endif #endif +logRunning :: String -> FilePath -> [String] -> IO () logRunning func fp args = debugM (logbase ++ "." ++ func) (showCmd fp args) + +warnFail :: [Char] -> FilePath -> [String] -> [Char] -> IO t warnFail funcname fp args msg = let m = showCmd fp args ++ ": " ++ msg in do warningM (logbase ++ "." ++ funcname) m @@ -170,7 +174,7 @@ Not available on Windows or with Hugs. -} hPipeFrom :: FilePath -> [String] -> IO (PipeHandle, Handle) -hPipeFrom fp args = +hPipeFrom fp args = do pipepair <- createPipe logRunning "pipeFrom" fp args let childstuff = do dupTo (snd pipepair) stdOutput @@ -180,7 +184,7 @@ -- parent pid <- case p of Right x -> return x - Left e -> warnFail "pipeFrom" fp args $ + Left e -> warnFail "pipeFrom" fp args $ "Error in fork: " ++ show e closeFd (snd pipepair) h <- fdToHandle (fst pipepair) @@ -229,7 +233,7 @@ -- parent pid <- case p of Right x -> return x - Left e -> warnFail "pipeTo" fp args $ + Left e -> warnFail "pipeTo" fp args $ "Error in fork: " ++ show e closeFd (fst pipepair) h <- fdToHandle (snd pipepair) @@ -319,7 +323,7 @@ of the given process ID. If the process terminated normally, does nothing. Otherwise, raises an exception with an appropriate error message. -This call will block waiting for the given pid to terminate. +This call will block waiting for the given pid to terminate. Not available on Windows. -} forceSuccess :: PipeHandle -> IO () @@ -329,12 +333,12 @@ case status of Nothing -> warnfail fp args $ "Got no process status" Just (Exited (ExitSuccess)) -> return () - Just (Exited (ExitFailure fc)) -> + Just (Exited (ExitFailure fc)) -> cmdfailed funcname fp args fc - Just (Terminated sig) -> + Just (Terminated sig) -> warnfail fp args $ "Terminated by signal " ++ show sig - Just (Stopped sig) -> - warnfail fp args $ "Stopped by signal " ++ show sig + Just (Stopped sig) -> + warnfail fp args $ "Stopped by signal " ++ show sig #endif {- | Invokes the specified command in a subprocess, waiting for the result. @@ -344,7 +348,7 @@ Implemented in terms of 'posixRawSystem' where supported, and System.Posix.rawSystem otherwise. -} safeSystem :: FilePath -> [String] -> IO () -safeSystem command args = +safeSystem command args = do debugM (logbase ++ ".safeSystem") ("Running: " ++ command ++ " " ++ (show args)) #if defined(__HUGS__) || defined(mingw32_HOST_OS) @@ -381,7 +385,7 @@ oldset <- getSignalMask blockSignals sigset childpid <- forkProcess (childaction oldint oldquit oldset) - + mps <- getProcessStatus True False childpid restoresignals oldint oldquit oldset let retval = case mps of @@ -392,9 +396,9 @@ (program ++ ": exited with " ++ show retval) return retval - where childaction oldint oldquit oldset = + where childaction oldint oldquit oldset = do restoresignals oldint oldquit oldset - executeFile program True args Nothing + executeFile program True args Nothing restoresignals oldint oldquit oldset = do installHandler sigINT oldint Nothing installHandler sigQUIT oldquit Nothing @@ -418,14 +422,12 @@ do debugM (logbase ++ ".forkRawSystem") ("Running: " ++ program ++ " " ++ (show args)) forkProcess childaction - - where childaction = - executeFile program True args Nothing + where + childaction = executeFile program True args Nothing #endif #endif - cmdfailed :: String -> FilePath -> [String] -> Int -> IO a cmdfailed funcname command args failcode = do let errormsg = "Command " ++ command ++ " " ++ (show args) ++ @@ -452,12 +454,12 @@ Passes the handle on to the specified function. -The 'PipeMode' specifies what you will be doing. That is, specifing 'ReadFromPipe' +The 'PipeMode' specifies what you will be doing. That is, specifing 'ReadFromPipe' sets up a pipe from stdin, and 'WriteToPipe' sets up a pipe from stdout. Not available on Windows. -} -pOpen :: PipeMode -> FilePath -> [String] -> +pOpen :: PipeMode -> FilePath -> [String] -> (Handle -> IO a) -> IO a pOpen pm fp args func = do @@ -474,7 +476,7 @@ return $! x pOpen3 Nothing (Just (snd pipepair)) Nothing fp args callfunc (closeFd (fst pipepair)) - WriteToPipe -> do + WriteToPipe -> do let callfunc _ = do closeFd (fst pipepair) h <- fdToHandle (snd pipepair) @@ -488,7 +490,7 @@ #ifndef mingw32_HOST_OS #ifndef __HUGS__ -{- | Runs a command, redirecting things to pipes. +{- | Runs a command, redirecting things to pipes. Not available on Windows. @@ -503,7 +505,7 @@ -> (ProcessID -> IO a) -- ^ Action to run in parent -> IO () -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS -> IO a -pOpen3 pin pout perr fp args func childfunc = +pOpen3 pin pout perr fp args func childfunc = do pid <- pOpen3Raw pin pout perr fp args childfunc retval <- func $! pid let rv = seq retval retval @@ -514,7 +516,7 @@ #ifndef mingw32_HOST_OS #ifndef __HUGS__ -{- | Runs a command, redirecting things to pipes. +{- | Runs a command, redirecting things to pipes. Not available on Windows. @@ -554,7 +556,7 @@ func p -} in - do + do p <- try (forkProcess childstuff) pid <- case p of Right x -> return x @@ -564,7 +566,5 @@ #endif #endif - showCmd :: FilePath -> [String] -> String -showCmd fp args = - fp ++ " " ++ show args +showCmd fp args = fp ++ " " ++ show args diff --git a/src/System/Daemon.hs b/src/System/Daemon.hs --- a/src/System/Daemon.hs +++ b/src/System/Daemon.hs @@ -22,7 +22,7 @@ Copyright : Copyright (C) 2005 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable to platforms with POSIX process\/signal tools @@ -47,8 +47,8 @@ #ifndef mingw32_HOST_OS detachDaemon #endif - ) -where + ) + where #ifndef mingw32_HOST_OS import System.Posix.Process @@ -58,6 +58,7 @@ import System.Exit +trap :: IO a -> IO a trap = traplogging "System.Daemon" ERROR "detachDaemon" {- | Detach the process from a controlling terminal and run it in the @@ -67,7 +68,7 @@ * The PID of the running process will change - * stdin, stdout, and stderr will not work (they'll be set to + * stdin, stdout, and stderr will not work (they'll be set to \/dev\/null) * CWD will be changed to \/ @@ -76,10 +77,9 @@ Note that this is not intended for a daemon invoked from inetd(1). -} - detachDaemon :: IO () -detachDaemon = trap $ - do forkProcess child1 +detachDaemon = trap $ + do forkProcess child1 exitImmediately ExitSuccess child1 :: IO () @@ -95,6 +95,4 @@ nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError] closeFd nullFd - - #endif diff --git a/src/System/Debian.hs b/src/System/Debian.hs --- a/src/System/Debian.hs +++ b/src/System/Debian.hs @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2004 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -36,11 +36,9 @@ -- * Version Number Utilities DebVersion, compareDebVersion, checkDebVersion ) -where + where + import System.Cmd -import System.Debian.ControlParser -import System.Cmd.Utils -import Data.String import System.IO.Unsafe import System.Exit @@ -48,9 +46,6 @@ or any control-like file (such as the output from apt-cache show, etc.) -} type ControlFile = [(String, String)] -splitComma :: String -> [String] -splitComma = map strip . split "," - ---------------------------------------------------------------------- -- VERSION NUMBERS ---------------------------------------------------------------------- @@ -60,7 +55,7 @@ data DebVersion = DebVersion String deriving (Eq) instance Ord DebVersion where - compare (DebVersion v1) (DebVersion v2) = + compare (DebVersion v1) (DebVersion v2) = {- This is OK since compareDebVersion should always be the same. -} unsafePerformIO $ compareDebVersion v1 v2 @@ -82,6 +77,6 @@ -> IO Bool checkDebVersion v1 op v2 = do ec <- rawSystem "dpkg" ["--compare-versions", v1, op, v2] - case ec of + case ec of ExitSuccess -> return True ExitFailure _ -> return False diff --git a/src/System/Debian/ControlParser.hs b/src/System/Debian/ControlParser.hs --- a/src/System/Debian/ControlParser.hs +++ b/src/System/Debian/ControlParser.hs @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2004 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -33,18 +33,20 @@ module System.Debian.ControlParser(control, depPart) where + import Text.ParserCombinators.Parsec -import Data.String +import Data.String.Utils (split) +eol, extline :: GenParser Char st String eol = (try (string "\r\n")) <|> string "\n" "EOL" extline = try (do char ' ' content <- many (noneOf "\r\n") eol - return content - ) + return content ) +entry :: GenParser Char st (String, String) entry = do key <- many1 (noneOf ":\r\n") char ':' val <- many (noneOf "\r\n") @@ -58,6 +60,7 @@ retval <- many entry return retval +headerPGP, blankLine, header, headerHash :: GenParser Char st () headerPGP = do string "-----BEGIN PGP" manyTill (noneOf "\r\n") eol return () @@ -69,9 +72,9 @@ return () header = (try headerPGP) <|> (try blankLine) <|> (try headerHash) -{- | Dependency parser. +{- | Dependency parser. -Returns (package name, Maybe version, arch list +Returns (package name, Maybe version, arch list) version is (operator, operand) -} depPart :: CharParser a (String, (Maybe (String, String)), [String]) diff --git a/src/System/FileArchive/GZip.hs b/src/System/FileArchive/GZip.hs --- a/src/System/FileArchive/GZip.hs +++ b/src/System/FileArchive/GZip.hs @@ -46,17 +46,16 @@ read_header, read_section ) -where + where -import Data.Compression.Inflate -import Data.Hash.CRC32.GZip -import Data.List -import Data.Bits -import Control.Monad.Error -import Data.Char -import Data.Word -import Data.Bits.Utils -import System.IO +import Data.Compression.Inflate (inflate_string_remainder) +import Data.Hash.CRC32.GZip (update_crc) +import Data.Bits ((.&.)) +import Control.Monad.Error -- (Error(), strMsg, throwError) +import Data.Char (ord) +import Data.Word (Word32()) +import Data.Bits.Utils (fromBytes) +import System.IO (hGetContents, hPutStr, Handle()) data GZipError = CRCError -- ^ CRC-32 check failed | NotGZIPFile -- ^ Couldn't find a GZip header @@ -69,14 +68,16 @@ strMsg = UnknownError -- | First two bytes of file +magic :: String magic = "\x1f\x8b" -- | Flags -fFTEXT = 1::Int -fFHCRC = 2::Int -fFEXTRA = 4::Int -fFNAME = 8::Int -fFCOMMENT = 16::Int +fFHCRC, fFEXTRA, fFNAME, fFCOMMENT :: Int +-- fFTEXT = 1 :: Int +fFHCRC = 2 +fFEXTRA = 4 +fFNAME = 8 +fFCOMMENT = 16 {- | The data structure representing the GZip header. This occurs at the beginning of each 'Section' on disk. -} @@ -117,7 +118,7 @@ hDecompress :: Handle -- ^ Input handle -> Handle -- ^ Output handle -> IO (Maybe GZipError) -hDecompress infd outfd = +hDecompress infd outfd = do inc <- hGetContents infd let (outstr, err) = decompress inc hPutStr outfd outstr @@ -131,15 +132,15 @@ -} decompress :: String -> (String, Maybe GZipError) {- -decompress s = +decompress s = do x <- read_header s let rem = snd x return $ inflate_string rem -} -decompress s = +decompress s = let procs :: [Section] -> (String, Bool) procs [] = ([], True) - procs ((_, content, foot):xs) = + procs ((_, content, foot):xs) = let (nexth, nextb) = procs xs in (content ++ nexth, (crc32valid foot) && nextb) in case read_sections s of @@ -152,7 +153,7 @@ return $ concatMap (\(_, x, _) -> x) x -} --- | Read all sections. +-- | Read all sections. read_sections :: String -> Either GZipError [Section] read_sections [] = Right [] read_sections s = @@ -170,34 +171,34 @@ read_section s = do x <- read_header s let headerrem = snd x - let (decompressed, crc32, remainder) = read_data headerrem - let (crc32str, rem) = splitAt 4 remainder - let (sizestr, rem2) = splitAt 4 rem + let (decompressed, crc, remainder) = read_data headerrem + let (crc32str, rm) = splitAt 4 remainder + let (sizestr, rem2) = splitAt 4 rm let filecrc32 = parseword crc32str let filesize = parseword sizestr return ((fst x, decompressed, Footer {size = filesize, crc32 = filecrc32, - crc32valid = filecrc32 == crc32}) + crc32valid = filecrc32 == crc}) ,rem2) -- | Read the file's compressed data, returning -- (Decompressed, Calculated CRC32, Remainder) read_data :: String -> (String, Word32, String) -read_data x = +read_data x = let (decompressed1, remainder) = inflate_string_remainder x (decompressed, crc32) = read_data_internal decompressed1 0 in - (decompressed, crc32, remainder) + (decompressed, crc32, remainder) where - read_data_internal [] ck = ([], ck) - read_data_internal (x:xs) ck = - let newcrc = update_crc ck x - n = newcrc `seq` read_data_internal xs newcrc + read_data_internal [] ck = ([], ck) + read_data_internal (y:ys) ck = + let newcrc = update_crc ck y + n = newcrc `seq` read_data_internal ys newcrc in - (x : fst n, snd n) - + (y : fst n, snd n) + {- | Read the GZip header. Return (Header, Remainder). -} read_header :: String -> Either GZipError (Header, String) @@ -217,22 +218,22 @@ let mtime = parseword mtimea let (xfla, rem3b) = split1 rem3a let xfl = ord xfla - let (osa, rem3c) = split1 rem3b + let (osa, _) = split1 rem3b let os = ord osa -- skip modtime (4), extraflag (1), and os (1) let rem4 = drop 6 rem3 - - let (extra, rem5) = + + let (extra, rem5) = if (flag .&. fFEXTRA /= 0) -- Skip past the extra field if we have it. - then let (xlen_S, rem4a) = split1 rem4 + then let (xlen_S, _) = split1 rem4 (xlen2_S, rem4b) = split1 rem4 xlen = (ord xlen_S) + 256 * (ord xlen2_S) (ex, rrem) = splitAt xlen rem4b in (Just ex, rrem) else (Nothing, rem4) - - let (filename, rem6) = + + let (filename, rem6) = if (flag .&. fFNAME /= 0) -- Skip past the null-terminated filename then let fn = takeWhile (/= '\x00') rem5 @@ -245,12 +246,12 @@ then let cm = takeWhile (/= '\x00') rem6 in (Just cm, drop ((length cm) + 1) rem6) else (Nothing, rem6) - + rem8 <- if (flag .&. fFHCRC /= 0) -- Skip past the header CRC then return $ drop 2 rem7 else return rem7 - + return (Header {method = ord method, flags = flag, extra = extra, diff --git a/src/System/IO/Binary.hs b/src/System/IO/Binary.hs --- a/src/System/IO/Binary.hs +++ b/src/System/IO/Binary.hs @@ -21,14 +21,14 @@ Copyright : Copyright (C) 2004-2005 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable to platforms supporting binary I\/O This module provides various helpful utilities for dealing with binary input and output. -You can use this module to deal with binary blocks of data as either Strings +You can use this module to deal with binary blocks of data as either Strings or lists of Word8. The BinaryConvertible class provides this abstraction. Wherever you see HVIO, you can transparently substite a regular Handle. @@ -44,7 +44,7 @@ is the support status: * GHC 6.2 and above: yes - + * GHC 6.x, earlier versions: unknown * GHC 5.x: no @@ -80,17 +80,16 @@ hFullBlockInteract, fullBlockInteract ) where -import Foreign.Ptr +import Data.Word (Word8()) +import Foreign.C.String (peekCStringLen, withCString) +import Foreign.C.Types (CChar()) import Foreign.ForeignPtr -import Foreign.C.String -import Foreign.C.Types -import Foreign.Storable -import Foreign.Marshal.Array -import Data.Word -import System.IO.Unsafe +import Foreign.Marshal.Array (peekArray, withArray) +import Foreign.Ptr import System.IO -import System.IO.HVIO import System.IO.HVFS +import System.IO.HVIO +import System.IO.Unsafe (unsafeInterleaveIO) {- | Provides support for handling binary blocks with convenient types. @@ -103,7 +102,7 @@ instance BinaryConvertible Char where toBuf = withCString - fromBuf len func = + fromBuf len func = do fbuf <- mallocForeignPtrArray (len + 1) withForeignPtr fbuf handler where handler ptr = @@ -120,19 +119,18 @@ peekArray bytesread ptr --- . ************************************************** --- . Binary Files --- . ************************************************** - +-- ************************************************** +-- Binary Files +-- ************************************************** {- | As a wrapper around the standard function 'System.IO.hPutBuf', this function takes a standard Haskell 'String' instead of the far less -convenient 'Ptr a'. The entire contents of the string will be written +convenient @Ptr a@. The entire contents of the string will be written as a binary buffer using 'hPutBuf'. The length of the output will be -the length of the passed String or list.. +the length of the passed String or list. If it helps, you can thing of this function as being of type -@Handle -> String -> IO ()@. -} +@Handle -> String -> IO ()@ -} hPutBufStr :: (HVIO a, BinaryConvertible b) => a -> [b] -> IO () hPutBufStr f s = toBuf s (\cs -> vPutBuf f cs (length s)) @@ -159,7 +157,7 @@ {- | Like 'hGetBufStr', but guarantees that it will only return fewer than the requested number of bytes when EOF is encountered. -} hFullGetBufStr :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [b] -hFullGetBufStr f 0 = return [] +hFullGetBufStr _ 0 = return [] hFullGetBufStr f count = do thisstr <- hGetBufStr f count if thisstr == [] @@ -186,9 +184,9 @@ hPutBufStr h x hPutBlocks h xs --- | An alias for 'hPutBlocks' 'stdout' +{- | An alias for 'hPutBlocks' 'stdout' putBlocks :: (BinaryConvertible b) => [[b]] -> IO () -putBlocks = hPutBlocks stdout +putBlocks = hPutBlocks stdout -} {- | Returns a lazily-evaluated list of all blocks in the input file, as read by 'hGetBufStr'. There will be no 0-length block in this list. @@ -210,14 +208,13 @@ hGetBlocksUtil :: (HVIO a, BinaryConvertible b) => (a -> Int -> IO [b]) -> a -> Int -> IO [[b]] hGetBlocksUtil readfunc h count = - unsafeInterleaveIO (do + unsafeInterleaveIO $ do block <- readfunc h count if block == [] then return [] else do remainder <- hGetBlocksUtil readfunc h count return (block : remainder) - ) {- | Binary block-based interaction. This is useful for scenarios that take binary blocks, manipulate them in some way, and then write them @@ -240,11 +237,11 @@ hFullBlockInteract = hBlockInteractUtil hFullGetBlocks -- | An alias for 'hFullBlockInteract' over 'stdin' and 'stdout' -fullBlockInteract :: (BinaryConvertible b, BinaryConvertible c) => +fullBlockInteract :: (BinaryConvertible b, BinaryConvertible c) => Int -> ([[b]] -> [[c]]) -> IO () fullBlockInteract x = hFullBlockInteract x stdin stdout -hBlockInteractUtil :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) => +hBlockInteractUtil :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) => (a -> Int -> IO [[b]]) -> Int -> a -> d -> ([[b]] -> [[c]]) -> IO () hBlockInteractUtil blockreader blocksize hin hout func = @@ -253,7 +250,7 @@ hPutBlocks hout (func blocks) {- | Copies everything from the input handle to the output handle using binary -blocks of the given size. This was once the following +blocks of the given size. This was once the following beautiful implementation: > hBlockCopy bs hin hout = hBlockInteract bs hin hout id @@ -264,9 +261,8 @@ In more recent versions of MissingH, it uses a more optimized routine that avoids ever having to convert the binary buffer at all. -} - hBlockCopy :: (HVIO a, HVIO b) => Int -> a -> b -> IO () -hBlockCopy bs hin hout = +hBlockCopy bs hin hout = do (fbuf::ForeignPtr CChar) <- mallocForeignPtrArray (bs + 1) withForeignPtr fbuf handler where handler ptr = diff --git a/src/System/IO/HVFS/Combinators.hs b/src/System/IO/HVFS/Combinators.hs --- a/src/System/IO/HVFS/Combinators.hs +++ b/src/System/IO/HVFS/Combinators.hs @@ -16,13 +16,12 @@ along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} - {- | Module : System.IO.HVFS.Combinators Copyright : Copyright (C) 2004-2005 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -32,31 +31,25 @@ -} -module System.IO.HVFS.Combinators( - -- * Restrictions +module System.IO.HVFS.Combinators ( -- * Restrictions HVFSReadOnly(..), - HVFSChroot, newHVFSChroot - ) -where + HVFSChroot, newHVFSChroot) + where -import System.IO.HVFS -import System.IO.HVIO -import System.IO.HVFS.InstanceHelpers import System.IO import System.IO.Error +import System.IO.HVFS +import System.IO.HVFS.InstanceHelpers (getFullPath) #ifndef mingw32_HOST_OS -import System.Posix.Files +import System.Posix.Files -- This actually needed? -Wall doesn't seem to think + -- so, but I'm not sure... #endif -import System.Posix.Types -import System.Time -import System.Directory -import System.Path -import System.Path.NameManip +import System.Path (secureAbsNormPath) +import System.Path.NameManip (normalise_path) ---------------------------------------------------------------------- -- Providing read-only access ---------------------------------------------------------------------- - {- | Restrict access to the underlying filesystem to be strictly read-only. Any write-type operations will cause an error. @@ -68,7 +61,8 @@ withro :: HVFS a => (a -> b) -> HVFSReadOnly a -> b withro f (HVFSReadOnly x) = f x -roerror h = +roerror :: (HVFS a) => HVFSReadOnly a -> IO c +roerror h = let err x = vRaiseError x permissionErrorType "Read-only virtual filesystem" Nothing in withro err h @@ -92,14 +86,13 @@ vCreateLink h _ _ = roerror h instance HVFSOpenable a => HVFSOpenable (HVFSReadOnly a) where - vOpen fh fp mode = + vOpen fh fp mode = case mode of ReadMode -> withro (\h -> vOpen h fp mode) fh _ -> roerror fh ---------------------------------------------------------------------- -- Restricting to a subdirectory ---------------------------------------------------------------------- - {- | Access a subdirectory of a real filesystem as if it was the root of that filesystem. -} data HVFS a => HVFSChroot a = HVFSChroot String a @@ -121,16 +114,18 @@ (Just full) {- | Get the embedded object -} +dch :: (HVFS t) => HVFSChroot t -> t dch (HVFSChroot _ a) = a {- | Convert a local (chroot) path to a full path. -} -dch2fp mainh@(HVFSChroot fp h) locfp = +dch2fp, fp2dch :: (HVFS t) => HVFSChroot t -> String -> IO String +dch2fp mainh@(HVFSChroot fp h) locfp = do full <- case (head locfp) of '/' -> return (fp ++ locfp) - x -> do y <- getFullPath mainh locfp + _ -> do y <- getFullPath mainh locfp return $ fp ++ y case secureAbsNormPath fp full of - Nothing -> vRaiseError h doesNotExistErrorType + Nothing -> vRaiseError h doesNotExistErrorType ("Trouble normalizing path in chroot") (Just (fp ++ "," ++ full)) Just x -> return x @@ -149,9 +144,11 @@ else let newpath2 = drop (length fp) newpath in return $ normalise_path ("/" ++ newpath2) -dch2fph func fh@(HVFSChroot fp h) locfp = +dch2fph :: (HVFS t) => (t -> String -> IO t1) -> HVFSChroot t -> [Char] -> IO t1 +dch2fph func fh@(HVFSChroot _ h) locfp = do newfp <- dch2fp fh locfp func h newfp + instance HVFS a => HVFS (HVFSChroot a) where vGetCurrentDirectory x = do fp <- vGetCurrentDirectory (dch x) fp2dch x fp diff --git a/src/System/IO/HVFS/InstanceHelpers.hs b/src/System/IO/HVFS/InstanceHelpers.hs --- a/src/System/IO/HVFS/InstanceHelpers.hs +++ b/src/System/IO/HVFS/InstanceHelpers.hs @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2004 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -41,20 +41,19 @@ MemoryEntry(..), -- * Utilities nice_slice, getFullPath, - getFullSlice - ) -where + getFullSlice) + where + +import Data.IORef (newIORef, readIORef, writeIORef, IORef()) +import Data.List (genericLength) +import System.IO -- (ReadMode) +import System.IO.Error (doesNotExistErrorType, illegalOperationErrorType, permissionErrorType) import System.IO.HVFS -import Data.IORef -import Data.List -import System.Path -import System.Path.NameManip -import Control.Monad.Error -import System.IO.Error -import System.IO -import System.IO.HVIO +import System.IO.HVIO (newStreamReader) +import System.Path (absNormPath) +import System.Path.NameManip (slice_path) -{- | A simple "System.IO.HVFS.HVFSStat" +{- | A simple "System.IO.HVFS.HVFSStat" class that assumes that everything is either a file or a directory. -} data SimpleStat = SimpleStat { @@ -69,7 +68,6 @@ ---------------------------------------------------------------------- -- In-Memory Tree Types ---------------------------------------------------------------------- - {- | The basic node of a 'MemoryVFS'. The String corresponds to the filename, and the entry to the contents. -} type MemoryNode = (String, MemoryEntry) @@ -81,8 +79,7 @@ {- | An in-memory read\/write filesystem. Think of it as a dynamically resizable ramdisk written in Haskell. -} - -data MemoryVFS = MemoryVFS +data MemoryVFS = MemoryVFS { content :: IORef [MemoryNode], cwd :: IORef FilePath } @@ -124,7 +121,7 @@ getFullPath :: HVFS a => a -> String -> IO String getFullPath fs path = do cwd <- vGetCurrentDirectory fs - case absNormPath cwd path of + case (absNormPath cwd path) of Nothing -> vRaiseError fs doesNotExistErrorType ("Trouble normalizing path " ++ path) (Just (cwd ++ "/" ++ path)) Just newpath -> return newpath @@ -145,7 +142,7 @@ t = tail sliced1 newh = if (h /= "/") && head h == '/' then tail h else h sliced2 = newh : t - + -- Walk the tree walk :: MemoryEntry -> [String] -> Either String MemoryEntry -- Empty list -- return the item we have @@ -153,14 +150,14 @@ -- Root directory -- return the item we have walk y ["/"] = Right y -- File but stuff: error - walk (MemoryFile _) (x : _) = - Left $ "Attempt to look up name " ++ x ++ " in file" - walk (MemoryDirectory y) (x : xs) = - let newentry = case lookup x y of - Nothing -> Left $ "Couldn't find entry " ++ x - Just z -> Right z + walk (MemoryFile _) (z : _) = + Left $ "Attempt to look up name " ++ z ++ " in file" + walk (MemoryDirectory y) (z : zs) = + let newentry = case lookup z y of + Nothing -> Left $ "Couldn't find entry " ++ z + Just a -> Right a in do newobj <- newentry - walk newobj xs + walk newobj zs in do c <- readIORef $ content x case walk (MemoryDirectory c) (sliced2) of @@ -169,7 +166,7 @@ -- | Find an element on the tree, normalizing the path first getMelem :: MemoryVFS -> String -> IO MemoryEntry -getMelem x s = +getMelem x s = do base <- readIORef $ cwd x case absNormPath base s of Nothing -> vRaiseError x doesNotExistErrorType @@ -182,17 +179,17 @@ do curpath <- vGetCurrentDirectory x -- Make sure new dir is valid newdir <- getMelem x fp - case newdir of - (MemoryFile _) -> vRaiseError x doesNotExistErrorType + case newdir of + (MemoryFile _) -> vRaiseError x doesNotExistErrorType ("Attempt to cwd to non-directory " ++ fp) (Just fp) - (MemoryDirectory _) -> + (MemoryDirectory _) -> case absNormPath curpath fp of Nothing -> -- should never happen due to above getMelem call vRaiseError x illegalOperationErrorType "Bad internal error" (Just fp) Just y -> writeIORef (cwd x) y - vGetFileStatus x fp = + vGetFileStatus x fp = do elem <- getMelem x fp case elem of (MemoryFile y) -> return $ HVFSStatEncap $ @@ -210,9 +207,9 @@ MemoryDirectory c -> return $ map fst c instance HVFSOpenable MemoryVFS where - vOpen x fp (ReadMode) = + vOpen x fp (ReadMode) = do elem <- getMelem x fp - case elem of + case elem of MemoryDirectory _ -> vRaiseError x doesNotExistErrorType "Can't open a directory" (Just fp) diff --git a/src/System/IO/HVIO.hs b/src/System/IO/HVIO.hs --- a/src/System/IO/HVIO.hs +++ b/src/System/IO/HVIO.hs @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2004-2006 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -87,7 +87,7 @@ 'MemoryBuffer' is a similar class, but with a different purpose. It provides a full interface like Handle (it implements 'HVIOReader', 'HVIOWriter', -and 'HVIOSeeker'). However, it maintains an in-memory buffer with the +and 'HVIOSeeker'). However, it maintains an in-memory buffer with the contents of the file, rather than an actual on-disk file. You can access the entire contents of this buffer at any time. This can be quite useful for testing I\/O code, or for cases where existing APIs use I\/O, but you @@ -111,7 +111,7 @@ -} module System.IO.HVIO(-- * Implementation Classes - HVIO(..), + HVIO(..), -- * Standard HVIO Implementations -- ** Handle @@ -121,7 +121,7 @@ StreamReader, newStreamReader, -- ** Memory Buffer - MemoryBuffer, newMemoryBuffer, + MemoryBuffer, newMemoryBuffer, mbDefaultCloseFunc, getMemoryBuffer, -- ** Haskell Pipe @@ -155,9 +155,8 @@ Implementators of writable objects must provide at least 'vPutChar' and 'vIsWritable'. -Implementators of seekable objects must provide at least +Implementators of seekable objects must provide at least 'vIsSeekable', 'vTell', and 'vSeek'. - -} class (Show a) => HVIO a where -- | Close a file @@ -201,12 +200,12 @@ a 'vGetChar' after a 'vGetContents' may return some undefined result instead of the error you would normally get. You should use caution to make sure your code doesn't fall into that trap, - or make sure to test your code with Handle or one of the + or make sure to test your code with Handle or one of the default instances defined in this module. Also, some implementations may essentially provide a complete close after a call to 'vGetContents'. The bottom line: after a call to 'vGetContents', you should do nothing else with the object save closing it with 'vClose'. - + For implementators, you are highly encouraged to provide a correct implementation. -} vGetContents :: a -> IO String @@ -225,7 +224,7 @@ -- | Write a string representation of the argument, plus a newline. vPrint :: Show b => a -> b -> IO () -- | Flush any output buffers. - -- Note: implementations should assure that a vFlush is automatically + -- Note: implementations should assure that a vFlush is automatically -- performed -- on file close, if necessary to ensure all data sent is written. vFlush :: a -> IO () @@ -290,8 +289,8 @@ vIsReadable _ = return False - vGetLine h = - let loop accum = + vGetLine h = + let loop accum = let func = do c <- vGetChar h case c of '\n' -> return accum @@ -306,7 +305,7 @@ x -> loop [x] vGetContents h = - let loop = + let loop = let func = do c <- vGetChar h next <- loop c `seq` return (c : next) @@ -315,7 +314,7 @@ in catch func handler in do loop - + vReady h = do vTestEOF h return True @@ -329,7 +328,7 @@ vPutStrLn h s = vPutStr h (s ++ "\n") vPrint h s = vPutStrLn h (show s) - + vFlush = vTestOpen @@ -341,13 +340,13 @@ vSeek h _ _ = vThrow h illegalOperationErrorType vTell h = vThrow h illegalOperationErrorType vGetChar h = vThrow h illegalOperationErrorType - + vPutBuf h buf len = do str <- peekCStringLen (castPtr buf, len) vPutStr h str - vGetBuf h b l = + vGetBuf h b l = worker b l 0 where worker _ 0 accum = return accum worker buf len accum = @@ -363,7 +362,6 @@ ---------------------------------------------------------------------- -- Handle instances ---------------------------------------------------------------------- - instance HVIO Handle where vClose = hClose vIsEOF = hIsEOF @@ -393,7 +391,6 @@ vIsOpen = hIsOpen vIsClosed = hIsClosed - ---------------------------------------------------------------------- -- VIO Support ---------------------------------------------------------------------- @@ -414,7 +411,6 @@ ---------------------------------------------------------------------- -- Stream Readers ---------------------------------------------------------------------- - {- | Simulate I\/O based on a string buffer. When a 'StreamReader' is created, it is initialized based on the contents of @@ -434,7 +430,9 @@ newStreamReader s = do ref <- newIORef (True, s) return (StreamReader ref) +srv :: StreamReader -> VIOCloseSupport String srv (StreamReader x) = x + instance Show StreamReader where show _ = "" @@ -451,7 +449,7 @@ let retval = head c vioc_set (srv h) (tail c) return retval - + vGetContents h = do vTestEOF h c <- vioc_get (srv h) vClose h @@ -461,13 +459,12 @@ ---------------------------------------------------------------------- -- Buffers ---------------------------------------------------------------------- - {- | A 'MemoryBuffer' simulates true I\/O, but uses an in-memory buffer instead of on-disk storage. It provides a full interface like Handle (it implements 'HVIOReader', 'HVIOWriter', -and 'HVIOSeeker'). However, it maintains an in-memory buffer with the +and 'HVIOSeeker'). However, it maintains an in-memory buffer with the contents of the file, rather than an actual on-disk file. You can access the entire contents of this buffer at any time. This can be quite useful for testing I\/O code, or for cases where existing APIs use I\/O, but you @@ -501,9 +498,10 @@ mbDefaultCloseFunc :: String -> IO () mbDefaultCloseFunc _ = return () +vrv :: MemoryBuffer -> VIOCloseSupport (Int, String) vrv (MemoryBuffer _ x) = x -{- | Grab the entire contents of the buffer as a string. +{- | Grab the entire contents of the buffer as a string. Unlike 'vGetContents', this has no effect on the open status of the item, the EOF status, or the current position of the file pointer. -} getMemoryBuffer :: MemoryBuffer -> IO String @@ -546,9 +544,9 @@ vIsWritable _ = return True vTell h = do v <- vioc_get (vrv h) return . fromIntegral $ (fst v) - vSeek h seekmode seekposp = + vSeek h seekmode seekposp = do (pos, buf) <- vioc_get (vrv h) - let seekpos = fromInteger seekposp + let seekpos = fromInteger seekposp let newpos = case seekmode of AbsoluteSeek -> seekpos RelativeSeek -> pos + seekpos @@ -562,7 +560,6 @@ ---------------------------------------------------------------------- -- Pipes ---------------------------------------------------------------------- - {- | Create a Haskell pipe. These pipes are analogous to the Unix @@ -574,9 +571,7 @@ pipes are implemented completely with existing Haskell threading primitives, and require no special operating system support. Unlike Unix pipes, these pipes cannot be used across a fork(). Also unlike Unix pipes, these pipes -are portable and interact well with Haskell threads. --} - +are portable and interact well with Haskell threads. -} newHVIOPipe :: IO (PipeReader, PipeWriter) newHVIOPipe = do mv <- newEmptyMVar readerref <- newIORef (True, mv) @@ -584,7 +579,7 @@ writerref <- newIORef (True, reader) return (reader, PipeWriter writerref) -data PipeBit = PipeBit Char +data PipeBit = PipeBit Char | PipeEOF deriving (Eq, Show) @@ -599,12 +594,13 @@ ------------------------------ -- Pipe Reader ------------------------------ - +prv :: PipeReader -> VIOCloseSupport (MVar PipeBit) prv (PipeReader x) = x instance Show PipeReader where - show x = "" + show _ = "" +pr_getc :: PipeReader -> IO PipeBit pr_getc h = do mv <- vioc_get (prv h) takeMVar mv @@ -618,11 +614,11 @@ vGetChar h = do vTestEOF h c <- pr_getc h - case c of + case c of PipeBit x -> return x -- vTestEOF should eliminate this case _ -> fail "Internal error in HVIOReader vGetChar" - vGetContents h = + vGetContents h = let loop = do c <- pr_getc h case c of PipeEOF -> return [] @@ -631,16 +627,17 @@ in do vTestEOF h loop vIsReadable _ = return True - + ------------------------------ -- Pipe Writer ------------------------------ - +pwv :: PipeWriter -> VIOCloseSupport PipeReader pwv (PipeWriter x) = x + +pwmv :: PipeWriter -> IO (MVar PipeBit) pwmv (PipeWriter x) = do mv1 <- vioc_get x vioc_get (prv mv1) - instance Show PipeWriter where show _ = "" @@ -659,7 +656,7 @@ vPutChar h c = do vTestOpen h child <- vioc_get (pwv h) copen <- vIsOpen child - if copen + if copen then do mv <- pwmv h putMVar mv (PipeBit c) else fail "PipeWriter: Couldn't write to pipe because child end is closed" diff --git a/src/System/IO/StatCompat.hs b/src/System/IO/StatCompat.hs --- a/src/System/IO/StatCompat.hs +++ b/src/System/IO/StatCompat.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -{- +{- Copyright (C) 2005,2006 John Goerzen This program is free software; you can redistribute it and/or modify @@ -22,7 +22,7 @@ Copyright : Copyright (C) 2005-2006 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -32,24 +32,22 @@ Copyright (c) 2005-2006 John Goerzen, jgoerzen\@complete.org -} -module System.IO.StatCompat +module System.IO.StatCompat where import System.Posix.Types import System.Posix.Consts #ifndef mingw32_HOST_OS import System.Posix.Files(intersectFileModes) #endif -import Data.Bits +import Data.Bits ((.&.)) #ifdef mingw32_HOST_OS type LinkCount = Int type UserID = Int type GroupID = Int - #endif - -data FileStatusCompat = +data FileStatusCompat = FileStatusCompat {deviceID :: DeviceID, fileID :: FileID, fileMode :: FileMode, @@ -62,10 +60,12 @@ modificationTime :: EpochTime, statusChangeTime :: EpochTime } - -sc_helper comp stat = + +sc_helper :: FileMode -> FileStatusCompat -> Bool +sc_helper comp stat = (fileMode stat `intersectFileModes` fileTypeModes) == comp - + +isBlockDevice,isCharacterDevice,isNamedPipe,isRegularFile,isDirectory,isSymbolicLink,isSocket :: FileStatusCompat -> Bool isBlockDevice = sc_helper blockSpecialMode isCharacterDevice = sc_helper characterSpecialMode isNamedPipe = sc_helper namedPipeMode diff --git a/src/System/IO/Utils.hs b/src/System/IO/Utils.hs --- a/src/System/IO/Utils.hs +++ b/src/System/IO/Utils.hs @@ -21,11 +21,9 @@ Copyright : Copyright (C) 2004-2006 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable - -asdf. -} module System.IO.Utils(-- * Entire File Handle Utilities @@ -46,15 +44,14 @@ optimizeForBatch, optimizeForInteraction ) where -import System.IO.Unsafe +import System.IO.Unsafe (unsafeInterleaveIO) import System.IO -import Data.List +import Data.List (genericLength) import System.IO.HVIO {- | Given a list of strings, output a line containing each item, adding newlines as appropriate. The list is not expected to have newlines already. -} - hPutStrLns :: HVIO a => a -> [String] -> IO () hPutStrLns h = mapM_ $ vPutStrLn h @@ -72,17 +69,16 @@ -} --- FIXME does hGetContents h >>= return.lines not work? +-- FIXME: does hGetContents h >>= return . lines not work? hGetLines :: HVIO a => a -> IO [String] hGetLines h = unsafeInterleaveIO (do ieof <- vIsEOF h - if (ieof) + if (ieof) then return [] else do line <- vGetLine h remainder <- hGetLines h - return (line : remainder) - ) + return (line : remainder)) {- | This is similar to the built-in 'System.IO.interact', but works @@ -117,7 +113,7 @@ One could view this function like this: -> hLineInteract finput foutput func = +> hLineInteract finput foutput func = > let newf = unlines . func . lines in > hInteract finput foutput newf @@ -128,7 +124,6 @@ > lines <- hGetLines finput > hPutStrLns foutput (func lines) -} - hLineInteract :: (HVIO a, HVIO b) => a -> b -> ([String] -> [String]) -> IO () hLineInteract finput foutput func = do @@ -146,8 +141,7 @@ {- | Copies from one handle to another in raw mode (using hGetContents). Takes a function to provide progress updates to the user. -} - -hCopyProgress :: (HVIO b, HVIO c, Integral a) => +hCopyProgress :: (HVIO b, HVIO c, Integral a) => b -- ^ Input handle -> c -- ^ Output handle -> (Maybe a -> Integer -> Bool -> IO ()) -- ^ Progress function -- the bool is always False unless this is the final call @@ -178,13 +172,11 @@ > hLineCopy hin hout = hLineInteract hin hout id -} - hLineCopy :: (HVIO a, HVIO b) => a -> b -> IO() hLineCopy hin hout = hLineInteract hin hout id {- | Copies from 'stdin' to 'stdout' using lines. An alias for 'hLineCopy' over 'stdin' and 'stdout'. -} - lineCopy :: IO () lineCopy = hLineCopy stdin stdout @@ -194,7 +186,6 @@ need to adjust them after the copy yourself. This function is implemented using 'hLineCopy' internally. -} - copyFileLinesToFile :: FilePath -> FilePath -> IO () copyFileLinesToFile infn outfn = do hin <- openFile infn ReadMode @@ -213,8 +204,7 @@ hSetBuffering stdout (BlockBuffering (Just 4096)) {- | Sets stdin and stdout to be line-buffered. This saves resources -on stdout, but not many on stdin, since it it still looking for newlines. --} +on stdout, but not many on stdin, since it it still looking for newlines. -} optimizeForInteraction :: IO () optimizeForInteraction = do hSetBuffering stdin LineBuffering diff --git a/src/System/Path.hs b/src/System/Path.hs --- a/src/System/Path.hs +++ b/src/System/Path.hs @@ -22,7 +22,7 @@ Copyright : Copyright (C) 2004-2005 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -59,11 +59,9 @@ {- | Splits a pathname into a tuple representing the root of the name and the extension. The extension is considered to be all characters from the last dot after the last slash to the end. Either returned string may be empty. -} - --- FIXME - See 6.4 API when released. - +-- FIXME: See 6.4 API when released. splitExt :: String -> (String, String) -splitExt path = +splitExt path = let dotindex = alwaysElemRIndex '.' path slashindex = alwaysElemRIndex '/' path in @@ -140,7 +138,7 @@ an exception. -} brackettmpdir :: String -> (String -> IO a) -> IO a brackettmpdir x action = do tmpdir <- mktmpdir x - finally (action tmpdir) + finally (action tmpdir) (recursiveRemove SystemFS tmpdir) {- | Changes the current working directory to the given path, diff --git a/src/System/Path/Glob.hs b/src/System/Path/Glob.hs --- a/src/System/Path/Glob.hs +++ b/src/System/Path/Glob.hs @@ -20,7 +20,7 @@ Copyright : Copyright (C) 2006 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -31,15 +31,16 @@ -} -module System.Path.Glob(glob, vGlob) where -import Data.List.Utils -import System.IO +module System.Path.Glob (glob, vGlob) + where +import Data.List.Utils (hasAny) import System.IO.HVFS -import System.FilePath -import Control.Exception -import System.Path.WildMatch -import Data.List +import System.FilePath (splitFileName) +import Control.Exception (tryJust, ioErrors) +import System.Path.WildMatch (wildCheckCase) +import Data.List (isSuffixOf) +hasWild :: String -> Bool hasWild = hasAny "*?[" {- | Takes a pattern. Returns a list of names that match that pattern. @@ -59,7 +60,7 @@ {- | Like 'glob', but works on both the system ("real") and HVFS virtual filesystems. -} vGlob :: HVFS a => a -> FilePath -> IO [FilePath] -vGlob fs fn = +vGlob fs fn = if not (hasWild fn) -- Don't try globbing if there are no wilds then do de <- vDoesExist fs fn if de @@ -79,17 +80,19 @@ return $ concat r else do r <- mapM expandNormalBase dirlist return $ concat r - + where (dirnameslash, basename) = splitFileName fn dirname = case dirnameslash of "/" -> "/" x -> if isSuffixOf "/" x then take (length x - 1) x else x + expandWildBase :: FilePath -> IO [FilePath] expandWildBase dname = do dirglobs <- runGlob fs dname basename return $ map (\globfn -> dname ++ "/" ++ globfn) dirglobs + expandNormalBase :: FilePath -> IO [FilePath] expandNormalBase dname = do isdir <- vDoesDirectoryExist fs dname @@ -103,7 +106,7 @@ runGlob fs "" patt = runGlob fs "." patt runGlob fs dirname patt = do r <- tryJust ioErrors (vGetDirectoryContents fs dirname) - case r of + case r of Left _ -> return [] Right names -> let matches = filter (wildCheckCase patt) $ names in if head patt == '.' diff --git a/src/System/Path/NameManip.hs b/src/System/Path/NameManip.hs --- a/src/System/Path/NameManip.hs +++ b/src/System/Path/NameManip.hs @@ -7,7 +7,7 @@ Copyright : Copyright (C) 2004 Volker Wysk License : GNU LGPL, version 2.1 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -18,8 +18,8 @@ module System.Path.NameManip where -import Data.List -import System.Directory +import Data.List (intersperse) +import System.Directory (getCurrentDirectory) {- | Split a path in components. Repeated \"@\/@\" characters don\'t lead to empty components. \"@.@\" path components are removed. If the path is absolute, the first component @@ -48,10 +48,10 @@ (c:cs) -> (('/':c):cs) _ -> slice_path' p where - slice_path' p = filter (\c -> c /= "" && c /= ".") (split p) + slice_path' o = filter (\c -> c /= "" && c /= ".") (split o) split "" = [] - split ('/':p) = "" : split p + split ('/':o) = "" : split o split (x:xs) = case split xs of [] -> [[x]] (y:ys) -> ((x:y):ys) @@ -371,7 +371,7 @@ -} absolute_path :: String -- ^ The path to be made absolute -> IO String -- ^ Absulte path -absolute_path path@('/':p) = return path +absolute_path path@('/':_) = return path absolute_path path = do cwd <- getCurrentDirectory return (cwd ++ "/" ++ path) @@ -385,7 +385,7 @@ absolute_path_by :: String -- ^ The directory relative to which the path is made absolute -> String -- ^ The path to be made absolute -> String -- ^ Absolute path -absolute_path_by dir path@('/':p) = path +absolute_path_by _ path@('/':_) = path absolute_path_by dir path = dir ++ "/" ++ path @@ -399,7 +399,7 @@ absolute_path' :: String -- ^ The path to be made absolute -> String -- ^ The directory relative to which the path is made absolute -> String -- ^ Absolute path -absolute_path' path@('/':p) dir = path +absolute_path' path@('/':_) _ = path absolute_path' path dir = dir ++ "/" ++ path @@ -427,5 +427,5 @@ -} guess_dotdot :: String -- ^ Path to be normalised -> Maybe String -- ^ In case the path could be transformed, the normalised, @\"..\"@-component free form of the path. -guess_dotdot = +guess_dotdot = fmap unslice_path . guess_dotdot_comps . slice_path diff --git a/src/System/Path/WildMatch.hs b/src/System/Path/WildMatch.hs --- a/src/System/Path/WildMatch.hs +++ b/src/System/Path/WildMatch.hs @@ -20,7 +20,7 @@ Copyright : Copyright (C) 2006 John Goerzen License : GNU GPL, version 2 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -61,15 +61,13 @@ module System.Path.WildMatch (-- * Wildcard matching wildCheckCase, - wildToRegex - ) - -where + wildToRegex) + where import Text.Regex -import Data.String +import Data.String.Utils -{- | Convert a wildcard to an (uncompiled) regular expression. +{- | Convert a wildcard to an (uncompiled) regular expression. -} wildToRegex :: String -> String @@ -88,7 +86,6 @@ Just _ -> True -- This is SO MUCH CLEANER than the python implementation! - convwild :: String -> String convwild [] = [] convwild ('*':xs) = ".*" ++ convwild xs @@ -102,3 +99,4 @@ convpat ('\\':xs) = "\\\\" ++ convpat xs convpat (']':xs) = ']' : convwild xs convpat (x:xs) = x : convpat xs +convpat [] = [] diff --git a/src/System/Time/ParseDate.hs b/src/System/Time/ParseDate.hs --- a/src/System/Time/ParseDate.hs +++ b/src/System/Time/ParseDate.hs @@ -11,130 +11,126 @@ -} module System.Time.ParseDate (parseCalendarTime) where -import Control.Monad +import Control.Monad (liftM) import Data.Char (isSpace) -import Data.List (elemIndex) -import Data.Maybe (fromJust) import System.Locale import System.Time import Text.ParserCombinators.Parsec +{- | Parse a date string as formatted by 'formatCalendarTime'. --- | Parse a date string as formatted by 'formatCalendarTime'. --- --- The resulting 'CalendarTime' will only have those fields set that --- are represented by a format specifier in the format string, and those --- fields will be set to the values given in the date string. --- If the same field is specified multiple times, the rightmost --- occurence takes precedence. --- --- The resulting date is not neccessarily a valid date. For example, --- if there is no day of the week specifier in the format string, --- the value of 'ctWDay' will most likely be invalid. --- --- Format specifiers are % followed by some character. All other --- characters are treated literally. Whitespace in the format string --- matches zero or more arbitrary whitespace characters. --- --- Format specifiers marked with * are matched, but do not set any --- field in the output. --- --- Some of the format specifiers are marked as space-padded or --- zero-padded. Regardless of this, space-padded, zero-padded --- or unpadded inputs are accepted. Note that strings using --- unpadded fields without separating the fields may cause --- strange parsing. --- --- Supported format specfiers: --- --- [%%] a % character. --- --- [%a] locale's abbreviated weekday name (Sun ... Sat) --- --- [%A] locale's full weekday name (Sunday .. Saturday) --- --- [%b] locale's abbreviated month name (Jan..Dec) --- --- [%B] locale's full month name (January..December) --- --- [%c] locale's date and time format (Thu Mar 25 17:47:03 CET 2004) --- --- [%C] century [00-99] --- --- [%d] day of month, zero padded (01..31) --- --- [%D] date (%m\/%d\/%y) --- --- [%e] day of month, space padded ( 1..31) --- --- [%h] same as %b --- --- [%H] hour, 24-hour clock, zero padded (00..23) --- --- [%I] hour, 12-hour clock, zero padded (01..12) --- --- [%j] day of the year, zero padded (001..366) --- --- [%k] hour, 24-hour clock, space padded ( 0..23) --- --- [%l] hour, 12-hour clock, space padded ( 1..12) --- --- [%m] month, zero padded (01..12) --- --- [%M] minute, zero padded (00..59) --- --- [%n] a newline character --- --- [%p] locale's AM or PM indicator --- --- [%r] locale's 12-hour time format (hh:mm:ss AM\/PM) --- --- [%R] hours and minutes, 24-hour clock (hh:mm) --- --- [%s] * seconds since '00:00:00 1970-01-01 UTC' --- --- [%S] seconds, zero padded (00..59) --- --- [%t] a horizontal tab character --- --- [%T] time, 24-hour clock (hh:mm:ss) --- --- [%u] numeric day of the week (1=Monday, 7=Sunday) --- --- [%U] * week number, weeks starting on Sunday, zero padded (01-53) --- --- [%V] * week number (as per ISO-8601), --- week 1 is the first week with a Thursday, --- zero padded, (01-53) --- --- [%w] numeric day of the week, (0=Sunday, 6=Monday) --- --- [%W] * week number, weeks starting on Monday, zero padded (01-53) --- --- [%x] locale's preferred way of printing dates (%m\/%d\/%y) --- --- [%X] locale's preferred way of printing time. (%H:%M:%S) --- --- [%y] year, within century, zero padded (00..99) --- --- [%Y] year, including century. Not padded --- (this is probably a bug, but formatCalendarTime does --- it this way). (0-9999) --- --- [%Z] time zone abbreviation (e.g. CET) or RFC-822 style numeric --- timezone (-0500) -parseCalendarTime :: + The resulting 'CalendarTime' will only have those fields set that + are represented by a format specifier in the format string, and those + fields will be set to the values given in the date string. + If the same field is specified multiple times, the rightmost + occurence takes precedence. + + The resulting date is not neccessarily a valid date. For example, + if there is no day of the week specifier in the format string, + the value of 'ctWDay' will most likely be invalid. + + Format specifiers are % followed by some character. All other + characters are treated literally. Whitespace in the format string + matches zero or more arbitrary whitespace characters. + + Format specifiers marked with * are matched, but do not set any + field in the output. + + Some of the format specifiers are marked as space-padded or + zero-padded. Regardless of this, space-padded, zero-padded + or unpadded inputs are accepted. Note that strings using + unpadded fields without separating the fields may cause + strange parsing. + + Supported format specfiers: + + [%%] a % character. + + [%a] locale's abbreviated weekday name (Sun ... Sat) + + [%A] locale's full weekday name (Sunday .. Saturday) + + [%b] locale's abbreviated month name (Jan..Dec) + + [%B] locale's full month name (January..December) + + [%c] locale's date and time format (Thu Mar 25 17:47:03 CET 2004) + + [%C] century [00-99] + + [%d] day of month, zero padded (01..31) + + [%D] date (%m\/%d\/%y) + + [%e] day of month, space padded ( 1..31) + + [%h] same as %b + + [%H] hour, 24-hour clock, zero padded (00..23) + + [%I] hour, 12-hour clock, zero padded (01..12) + + [%j] day of the year, zero padded (001..366) + + [%k] hour, 24-hour clock, space padded ( 0..23) + + [%l] hour, 12-hour clock, space padded ( 1..12) + + [%m] month, zero padded (01..12) + + [%M] minute, zero padded (00..59) + + [%n] a newline character + + [%p] locale's AM or PM indicator + + [%r] locale's 12-hour time format (hh:mm:ss AM\/PM) + + [%R] hours and minutes, 24-hour clock (hh:mm) + + [%s] * seconds since '00:00:00 1970-01-01 UTC' + + [%S] seconds, zero padded (00..59) + + [%t] a horizontal tab character + + [%T] time, 24-hour clock (hh:mm:ss) + + [%u] numeric day of the week (1=Monday, 7=Sunday) + + [%U] * week number, weeks starting on Sunday, zero padded (01-53) + + [%V] * week number (as per ISO-8601), + week 1 is the first week with a Thursday, + zero padded, (01-53) + + [%w] numeric day of the week, (0=Sunday, 6=Monday) + + [%W] * week number, weeks starting on Monday, zero padded (01-53) + + [%x] locale's preferred way of printing dates (%m\/%d\/%y) + + [%X] locale's preferred way of printing time. (%H:%M:%S) + + [%y] year, within century, zero padded (00..99) + + [%Y] year, including century. Not padded + (this is probably a bug, but formatCalendarTime does + it this way). (0-9999) + + [%Z] time zone abbreviation (e.g. CET) or RFC-822 style numeric + timezone (-0500) -} +parseCalendarTime :: TimeLocale -- ^ Time locale -> String -- ^ Date format -> String -- ^ String to parse -> Maybe CalendarTime -- ^ 'Nothing' if parsing failed. -parseCalendarTime l fmt s = +parseCalendarTime l fmt s = case runParser parser epoch "" s of - Left err -> Nothing - Right p -> Just p + Left _ -> Nothing + Right p -> Just p where parser = pCalendarTime l fmt >> getState - -- FIXME: verify input -- FIXME: years outside 1000-9999 probably don't work -- FIXME: what about extra whitespace in input? @@ -159,7 +155,7 @@ doFmt ('%':c:cs) = decode c >> doFmt cs doFmt (c:cs) = char c >> doFmt cs doFmt "" = return () - + decode '%' = char '%' >> return () decode 'a' = (parseEnum $ map snd $ wDays l) >>= setWDay decode 'A' = (parseEnum $ map fst $ wDays l) >>= setWDay @@ -185,12 +181,12 @@ -- FIXME: strptime(3) accepts "arbitrary whitespace" for %n decode 'n' = char '\n' >> return () decode 'p' = do - x <- (string am >> return 0) <|> (string pm >> return 12) - updateHour (\h -> x + h `rem` 12) - where (am,pm) = amPm l + x <- (string am >> return 0) <|> (string pm >> return 12) + updateHour (\h -> x + h `rem` 12) + where (am,pm) = amPm l decode 'r' = doFmt (time12Fmt l) decode 'R' = doFmt "%H:%M" - -- FIXME: implement %s. + -- FIXME: implement %s. -- FIXME: implement %s in formatCalendarTime decode 's' = int >> return () decode 'S' = read2 >>= setSec @@ -198,16 +194,16 @@ decode 't' = char '\t' >> return () decode 'T' = doFmt "%H:%M:%S" decode 'u' = readN 1 >>= setWDay . toEnum . (\w -> if w == 7 then 0 else w) - -- FIXME: implement %U. + -- FIXME: implement %U. decode 'U' = read2 >> return () - -- FIXME: implement %V. + -- FIXME: implement %V. decode 'V' = read2 >> return () decode 'w' = readN 1 >>= setWDay . toEnum -- FIXME: implement %W. decode 'W' = read2 >> return () decode 'x' = doFmt (dateFmt l) decode 'X' = doFmt (timeFmt l) - -- FIXME: should probably be zero padded, + -- FIXME: should probably be zero padded, -- need to change formatCalendarTime too decode 'Y' = int >>= setYear -- FIXME: maybe 04 should be 2004, not 1904? @@ -216,53 +212,56 @@ -- FIXME: set ctTZ when parsing timezone name and -- ctTZName when parsing offset decode 'Z' = tzname <|> tzoffset - where tzname = many1 (oneOf ['A'..'Z']) >>= setTZName - tzoffset = do - s <- sign - h <- read2 - m <- read2 - setTZ (s * (h * 3600 + m * 60)) + where tzname = many1 (oneOf ['A'..'Z']) >>= setTZName + tzoffset = do + s <- sign + h <- read2 + m <- read2 + setTZ (s * (h * 3600 + m * 60)) -- following the example of strptime(3), -- whitespace matches zero or more whitespace -- characters in the input string decode c | isSpace c = spaces >> return () decode c = char c >> return () - - epoch :: CalendarTime epoch = CalendarTime { - ctYear = 1970, - ctMonth = January, - ctDay = 1, - ctHour = 0, - ctMin = 0, - ctSec = 0, - ctPicosec = 0, - ctWDay = Thursday, - ctYDay = 1, - ctTZName = "UTC", - ctTZ = 0, - ctIsDST = False - } + ctYear = 1970, + ctMonth = January, + ctDay = 1, + ctHour = 0, + ctMin = 0, + ctSec = 0, + ctPicosec = 0, + ctWDay = Thursday, + ctYDay = 1, + ctTZName = "UTC", + ctTZ = 0, + ctIsDST = False + } parseEnum :: Enum a => [String] -> CharParser st a parseEnum ss = choice (zipWith tryString ss (enumFrom (toEnum 0))) where tryString s x = try (string s) >> return x - +setYear,setDay,setHour,setHour12,setMin,setSec,setYDay,setTZ :: Int -> GenParser tok CalendarTime () setYear x = updateState (\t -> t{ ctYear = x }) +setMonth :: Month -> GenParser tok CalendarTime () setMonth x = updateState (\t -> t{ ctMonth = x }) setDay x = updateState (\t -> t{ ctDay = x }) setHour x = updateState (\t -> t{ ctHour = x }) setMin x = updateState (\t -> t{ ctMin = x }) setSec x = updateState (\t -> t{ ctSec = x }) +setWDay :: Day -> GenParser tok CalendarTime () setWDay x = updateState (\t -> t{ ctWDay = x }) setYDay x = updateState (\t -> t{ ctYDay = x }) +setTZName :: String -> GenParser tok CalendarTime () setTZName x = updateState (\t -> t{ ctTZName = x }) setTZ x = updateState (\t -> t{ ctTZ = x }) +updateYear :: (Int -> Int) -> GenParser tok CalendarTime () updateYear f = updateState (\t -> t{ ctYear = f (ctYear t) }) +updateHour :: (Int -> Int) -> GenParser tok CalendarTime () updateHour f = updateState (\t -> t{ ctHour = f (ctHour t) }) setHour12 x = updateHour (\h -> (h `quot` 12) * 12 + from12 x) @@ -272,10 +271,10 @@ read2 = readN 2 read3 = readN 3 --- | Read up to a given number of digits, optionally left-padded +-- | Read up to a given number of digits, optionally left-padded -- with whitespace and interpret them as an 'Int'. readN :: Int -> GenParser Char st Int -readN n = +readN n = liftM read (spaces >> choice [try (count m digit) | m <- [n,n-1..1]]) int :: GenParser Char st Int diff --git a/src/Test/HUnit/Utils.hs b/src/Test/HUnit/Utils.hs --- a/src/Test/HUnit/Utils.hs +++ b/src/Test/HUnit/Utils.hs @@ -30,16 +30,14 @@ Written by John Goerzen, jgoerzen\@complete.org -} - - -module Test.HUnit.Utils(assertRaises, mapassertEqual, qccheck, qctest) where +module Test.HUnit.Utils (assertRaises, mapassertEqual, qccheck, qctest) + where import Test.HUnit import Test.QuickCheck as QC import qualified Control.Exception import System.Random {- | Asserts that a specific exception is raised by a given action. -} - assertRaises :: Show a => String -> Control.Exception.Exception -> IO a -> IO () assertRaises msg selector action = let thetest e = if e == selector then return () @@ -49,18 +47,17 @@ r <- Control.Exception.try action case r of Left e -> thetest e - Right x -> assertFailure $ msg ++ "\nReceived no exception, but was expecting exception: " ++ (show selector) + Right _ -> assertFailure $ msg ++ "\nReceived no exception, but was expecting exception: " ++ (show selector) mapassertEqual :: (Show b, Eq b) => String -> (a -> b) -> [(a, b)] -> [Test] -mapassertEqual descrip func [] = [] +mapassertEqual _ _ [] = [] mapassertEqual descrip func ((inp,result):xs) = (TestCase $ assertEqual descrip result (func inp)) : mapassertEqual descrip func xs -- * Turn QuickCheck tests into HUnit tests - --- |qccheck turns the quickcheck test into an hunit test -qccheck :: (QC.Testable a) => - Config -- ^ quickcheck config +-- | qccheck turns the quickcheck test into an hunit test +qccheck :: (QC.Testable a) => + QC.Config -- ^ quickcheck config -> String -- ^ label for the property -> a -- ^ quickcheck property -> Test @@ -69,14 +66,14 @@ do rnd <- newStdGen tests config (evaluate property) rnd 0 0 [] --- |qctest is equivalent to 'qccheck defaultConfig' +-- | qctest is equivalent to 'qccheck defaultConfig' qctest :: (QC.Testable a) => String -> a -> Test -qctest lbl property = qccheck defaultConfig lbl property +qctest lbl = qccheck defaultConfig lbl --- |modified version of the tests function from Test.QuickCheck -tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () +-- | modified version of the tests function from Test.QuickCheck +tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () tests config gen rnd0 ntest nfail stamps - | ntest == configMaxTest config = return () + | ntest == configMaxTest config = return () | nfail == configMaxFail config = assertFailure $ "Arguments exhausted after " ++ show ntest ++ " tests." | otherwise = do putStr (configEvery config ntest (arguments result)) diff --git a/testsrc/runtests.hs b/testsrc/runtests.hs deleted file mode 100644 --- a/testsrc/runtests.hs +++ /dev/null @@ -1,25 +0,0 @@ -{- arch-tag: Test runner -Copyright (C) 2004 John Goerzen - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module Main where - -import Test.HUnit -import Tests - -main = runTestTT tests -