[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
John Goerzen
jgoerzen at complete.org
Fri Apr 23 15:23:56 UTC 2010
The following commit has been merged in the master branch:
commit 0deaa14b15bb299dcde5bdb756b13d0e9d12e19d
Author: John Goerzen <jgoerzen at complete.org>
Date: Fri Jan 23 10:14:25 2009 -0600
Starting removal of MissingH stuff
diff --git a/src/Control/Concurrent/Thread/Utils.hs b/src/Control/Concurrent/Thread/Utils.hs
deleted file mode 100644
index 5764606..0000000
--- a/src/Control/Concurrent/Thread/Utils.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-{- arch-tag: Thread utilities main file
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-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 : Control.Concurrent.Thread.Utils
- Copyright : Copyright (C) 2004 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-This module provides various helpful utilities for dealing with threads.
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module Control.Concurrent.Thread.Utils(-- * I\/O utilities
- runInThread
- )
-where
-
-import Control.Concurrent
-
-{- | Takes a IO action and a function. The IO action will be called in a
-separate thread. When it is completed, the specified function is called with
-its result. This is a simple way of doing callbacks. -}
-
-runInThread :: IO a -> (a -> IO b) -> IO ThreadId
-runInThread action callback = forkIO $ action >>= callback >> return ()
diff --git a/src/Data/BinPacking.hs b/src/Data/BinPacking.hs
deleted file mode 100644
index d356dff..0000000
--- a/src/Data/BinPacking.hs
+++ /dev/null
@@ -1,126 +0,0 @@
-{-
-Copyright (C) 2008 John Goerzen <jgoerzen at complete.org>
-
-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.BinPacking
- Copyright : Copyright (C) 2008 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Tools for packing into bins
-
-Written by John Goerzen, jgoerzen\@complete.org
-
-This module is designed to solve this type of problem: Given a bunch of
-objects of varying sizes, what is the best possible way to pack them into
-fixed-size bins? This can be used, for instance, by the datapacker program
-to pack files onto CDs or DVDs; by manufacturing environments to pack
-physical items into physicl bins; etc.
-
-A description of bin packing algorithms can be found at
-<http://en.wikipedia.org/wiki/Bin_packing_problem>.
--}
-
-module Data.BinPacking (BinPacker,
- BinPackerError(..),
- packByOrder,
- packLargeFirst
- )
-
-where
-import Data.List
-import Control.Monad.Error
-
-{- | Potential errors returned as Left values by 'BinPacker' functions.
-Calling 'show' on this value will produce a nice error message suitable for
-display. -}
-data (Num size, Ord size, Show size, Show obj) => BinPackerError size obj =
- BPTooFewBins [(size, obj)] -- ^ Ran out of bins; attached value is the list of objects that don't fit
- | BPSizeTooLarge size (size, obj) -- ^ Bin size1 exceeded by at least the given object and size
- | BPOther String -- ^ Other error
- deriving (Eq, Read)
-
-instance (Num size, Ord size, Show size, Show obj) => Show (BinPackerError size obj) where
- show (BPTooFewBins _) = "Too few bins"
- show (BPSizeTooLarge binsize (objsize, obj)) =
- "Size " ++ show objsize ++ " greater than bin size " ++ show binsize
- ++ " at " ++ show obj
- show (BPOther x) = x
-
-{- | Let us use this as part of the Either monad -}
-instance (Num size, Ord size, Show size, Show obj) => Error (BinPackerError size obj) where
- strMsg = BPOther
-
-{- | The primary type for bin-packing functions.
-
-These functions take a list of size of bins. If every bin is the same size,
-you can pass @(repeat binSize)@ to pass an infinite list of bins if the
-same size. Any surplus bins will simply be ignored. -}
-type BinPacker = (Num size, Ord size, Show size, Show obj) =>
- [size] -- ^ The sizes of bins
- -> [(size, obj)] -- ^ The sizes and objects
- -> Either (BinPackerError size obj) [[(size, obj)]] -- ^ Either error or results
-
-
-{- | Pack objects into bins, preserving order. Objects will be taken from the
-input list one by one, and added to each bin until the bin is full. Work will
-then proceed on the next bin. No attempt is made to optimize allocations to
-bins. This is the simplest and most naive bin-packing algorithm, but
-may not make very good use of bin space. -}
-packByOrder :: BinPacker
-packByOrder _ [] = Right [] -- Ran out of sizes
-packByOrder [] remainder = Left (BPTooFewBins remainder)
-packByOrder (thisbinsize:otherbins) sizes =
- let fillBin _ [] = Right []
- fillBin accumsize ((s, o):xs)
- | s > thisbinsize = Left $ BPSizeTooLarge thisbinsize (s, o)
- | s + accumsize > thisbinsize = Right []
- | otherwise = do next <- fillBin (accumsize + s) xs
- return $ (s, o) : next
- in do thisset <- fillBin 0 sizes
- next <- packByOrder otherbins (drop (length thisset) sizes)
- return (thisset : next)
-
-{- | Pack objects into bins. For each bin, start with the largest objects,
-and keep packing the largest object from the remainder until no object can
-be found to put in the bin. This is substantially more efficient than
-'packByOrder', but requires sorting the input. -}
-packLargeFirst :: BinPacker
-packLargeFirst bins sizes = packLargeFirst' bins (sortBy fstSort sizes)
- where fstSort a b = compare (fst a) (fst b)
-
-packLargeFirst' :: BinPacker
-packLargeFirst' _ [] = Right [] -- Ran out of sizes
-packLargeFirst' [] remainder = Left (BPTooFewBins remainder)
-packLargeFirst' (thisbinsize:otherbins) sizes =
- let fillBin _ [] = Right []
- fillBin accumsize sizelist =
- case break (\x -> (fst x) + accumsize <= thisbinsize) sizelist of
- (_, []) ->
- if accumsize == 0
- then Left $ BPSizeTooLarge thisbinsize (head sizelist)
- else Right []
- (nonmatches, ((s, o):matchxs)) ->
- do next <- fillBin (accumsize + s) (nonmatches ++ matchxs)
- return $ (s, o) : next
- in do thisset <- fillBin 0 sizes
- next <- packLargeFirst' otherbins (drop (length thisset) sizes)
- return (thisset : next)
diff --git a/src/Data/Bits/Utils.hs b/src/Data/Bits/Utils.hs
deleted file mode 100644
index 30adfbb..0000000
--- a/src/Data/Bits/Utils.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-{- arch-tag: Bit utilities main file
-Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
-
-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.Bits.Utils
- Copyright : Copyright (C) 2004-2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable to platforms with rawSystem
-
- Bit-related utilities
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module Data.Bits.Utils(getBytes, fromBytes,
- c2w8, s2w8, w82c, w82s)
-where
-import Data.Bits
-import Data.Word
-
-{- | Returns a list representing the bytes that comprise a data type.
-
-Example:
-
-> getBytes (0x12345678::Int) -> [0x12, 0x34, 0x56, 0x78]
--}
-getBytes :: (Integral a, Bounded a, Bits a) => a -> [a]
-getBytes input =
- let getByte _ 0 = []
- getByte x remaining = (x .&. 0xff) : getByte (shiftR x 8) (remaining - 1)
- in
- if (bitSize input `mod` 8) /= 0
- then error "Input data bit size must be a multiple of 8"
- else reverse $ getByte input (bitSize input `div` 8)
-
-{- | The opposite of 'getBytes', this function builds a number based on
-its component bytes.
-
-Results are undefined if any components of the input list are > 0xff!
-
--}
-
-fromBytes :: (Bits a) => [a] -> a
-fromBytes input =
- let dofb accum [] = accum
- dofb accum (x:xs) = dofb ((shiftL accum 8) .|. x) xs
- in
- dofb 0 input
-
-{- | Converts a Char to a Word8. -}
-c2w8 :: Char -> Word8
-c2w8 = fromIntegral . fromEnum
-
-{- | Converts a String to a [Word8]. -}
-s2w8 :: String -> [Word8]
-s2w8 = map c2w8
-
-{- | Converts a Word8 to a Char. -}
-w82c :: Word8 -> Char
-w82c = toEnum . fromIntegral
-
-{- | Converts a [Word8] to a String. -}
-w82s :: [Word8] -> String
-w82s = map w82c
diff --git a/src/Data/CSV.hs b/src/Data/CSV.hs
deleted file mode 100644
index a040d38..0000000
--- a/src/Data/CSV.hs
+++ /dev/null
@@ -1,112 +0,0 @@
-{- arch-tag: CSV and TSV utilities
-Copyright (C) 2005 John Goerzen <jgoerzen at complete.org>
-
-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.CSV
- Copyright : Copyright (C) 2005-2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Haskell Parsec parsers for comma-separated value (CSV) files.
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module Data.CSV (csvFile, genCsvFile) where
-import Text.ParserCombinators.Parsec
-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 :: GenParser Char st Char
-quotedchar = noneOf "\""
- <|> (try $ do string "\"\""
- return '"'
- )
-quotedcell :: CharParser st String
-quotedcell = do char '"'
- 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
-lines; each line is a list of cells; and each cell is a String.
-
-Please note that CSV files may have a different number of cells on each line.
-Also, it is impossible to distinguish a CSV line that has a call with no data
-from a CSV line that has no cells.
-
-Here are some examples:
-
->Input (literal strings) Parses As (Haskell String syntax)
->-------------------------------- ---------------------------------
->1,2,3 [["1", "2", "3"]]
->
->l1 [["l1"], ["l2"]]
->l2
->
-> (empty line) [[""]]
->
->NQ,"Quoted" [["NQ", "Quoted"]]
->
->NQ,"Embedded""Quote" [["NQ", "Embedded\"Quote"]]
-
-To parse a String, you might use:
-
->import Text.ParserCombinators.Parsec
->import Data.String.CSV
->....
->parse csvFile "" mystring
-
-To parse a file, you might instead use:
-
->do result <- parseFromFile csvFile "/path/to/file"
-
-Please note that the result of parsing will be of type
-(Either ParseError [[String]]). A Left result indicates an error.
-For more details, see the Parsec information.
--}
-
-csvFile :: CharParser st [[String]]
-csvFile = endBy line eol
-
-{- | Generate CSV data for a file. The resulting string can be
-written out to disk directly. -}
-genCsvFile :: [[String]] -> String
-genCsvFile inp =
- unlines . map csvline $ inp
- where csvline :: [String] -> String
- csvline l = concat . intersperse "," . map csvcells $ l
- csvcells :: String -> String
- csvcells "" = ""
- csvcells c = '"' : convcell c ++ "\""
- convcell :: String -> String
- convcell c = concatMap convchar c
- convchar '"' = "\"\""
- convchar x = [x]
diff --git a/src/Data/Compression/Inflate.hs b/src/Data/Compression/Inflate.hs
deleted file mode 100644
index 2b3579b..0000000
--- a/src/Data/Compression/Inflate.hs
+++ /dev/null
@@ -1,354 +0,0 @@
--- arch-tag: Inflate implementation for Haskell
-
-{-
-Inflate implementation for Haskell
-
-Copyright 2004 Ian Lynagh <igloo at earth.li>
-Licence: 3 clause BSD.
-
-\section{Inflate}
-
-This module provides a Haskell implementation of the inflate function,
-as described by RFC 1951.
-
--}
-
-{- |
- Module : Data.Compression.Inflate
- Copyright : Copyright (C) 2004 Ian Lynagh
- License : 3-clause BSD
-
- Maintainer : Ian Lynagh,
- Maintainer : <igloo at earth.li>
- Stability : provisional
- Portability: portable
-
-Inflate algorithm implementation
-
-Copyright (C) 2004 Ian Lynagh
--}
-
-module Data.Compression.Inflate (inflate_string,
- inflate_string_remainder,
- inflate, Output, Bit,
- bits_to_word32) where
-
-import Data.Array
-import Data.List
-import Data.Maybe
-import qualified Data.Char
-import Control.Monad
-
-import Data.Bits
-import Data.Word
-
-inflate_string :: String -> String
-inflate_string = fst . inflate_string_remainder
--- map (Data.Char.chr . fromIntegral) $ fst $ inflate $ map Data.Char.ord s
-
--- | Returns (Data, Remainder)
-inflate_string_remainder :: String -> (String, String)
-inflate_string_remainder s =
- let res = inflate $ map Data.Char.ord s
- convw32l l = map (Data.Char.chr . fromIntegral) l
- output = convw32l $ fst res
- b2w32 [] = []
- b2w32 b = let (this, next) = splitAt 8 b
- in
- bits_to_word32 this : b2w32 next
- remainder = convw32l $ b2w32 $ snd res
- in
- (output, remainder)
-
-{-
-\section{Types}
-
-Type synonyms are your friend.
-
--}
-type Output = [Word32] -- The final output
-
-type Code = Word32 -- A generic code
-type Dist = Code -- A distance code
-type LitLen = Code -- A literal/length code
-type Length = Word32 -- Number of bits needed to identify a code
-
-type Table = InfM Code -- A Huffman table
-type Tables = (Table, Table) -- lit/len and dist Huffman tables
-
-{-
-
-The \verb!Bit! datatype is used for the input. We can show values and
-convert from the input we are given and to \verb!Word32!s which we us to
-represent most values.
-
--}
-newtype Bit = Bit Bool
- deriving Eq
-instance Show Bit where
- show = (\x -> [x]) . show_b
- showList bs = showString $ "'" ++ map show_b bs ++ "'"
-
-show_b :: Bit -> Char
-show_b (Bit True) = '1'
-show_b (Bit False) = '0'
-
-int_to_bits :: Int -> [Bit]
-int_to_bits = word8_to_bits . fromIntegral
-
-word8_to_bits :: Word8 -> [Bit]
-word8_to_bits n = map (\i -> Bit (testBit n i)) [0..7]
-
-bits_to_word32 :: [Bit] -> Word32
-bits_to_word32 = foldr (\(Bit b) i -> 2 * i + (if b then 1 else 0)) 0
-
-{-
-
-\section{Monad}
-
-offset is rarely used, so make it strict to avoid building huge closures.
-
--}
-data State = State { bits :: [Bit], -- remaining input bits
- offset :: !Word32, -- num bits consumed mod 8
- history :: Array Word32 Word32, -- last 32768 output words
- loc :: Word32 -- where in history we are
- }
-data InfM a = InfM (State -> (a, State))
-
-instance Monad InfM where
- -- (>>=) :: InfM a -> (a -> InfM b) -> InfM b
- InfM v >>= f = InfM $ \s -> let (x, s') = v s
- InfM y = f x
- in y s'
- -- return :: a -> InfM a
- return x = InfM $ \s -> (x, s)
-
-set_bits :: [Bit] -> InfM ()
-set_bits bs = InfM $ const ((), State bs 0 (array (0, 32767) []) 0)
-
-{-
-no_bits :: InfM Bool
-no_bits = InfM $ \s -> (null (bits s), s)
--}
-
-align_8_bits :: InfM ()
-align_8_bits
- = InfM $ \s -> ((), s { bits = genericDrop ((8 - offset s) `mod` 8) (bits s),
- offset = 0 })
-
-get_bits :: Word32 -> InfM [Bit]
-get_bits n = InfM $ \s -> case need n (bits s) of
- (ys, zs) ->
- (ys, s { bits = zs,
- offset = (n + offset s) `mod` 8 } )
- where need 0 xs = ([], xs)
- need _ [] = error "get_bits: Don't have enough!"
- need i (x:xs) = let (ys, zs) = need (i-1) xs in (x:ys, zs)
-
-extract_InfM :: InfM a -> (a, [Bit])
-extract_InfM (InfM f) = let (x, s) = f undefined in (x, bits s)
-
-output_w32 :: Word32 -> InfM ()
-output_w32 w = InfM $ \s -> let l = loc s
- in ((), s { history = history s // [(l, w)],
- loc = l + 1 })
-
-repeat_w32s :: Word32 -> Word32 -> InfM [Word32]
-repeat_w32s len dist
- = InfM $ \s -> let l = loc s
- h = history s
- new = map (h!) $ genericTake dist ([(l - dist) `mod` 32768..32767] ++ [0..])
- new_bit = genericTake len (cycle new)
- h' = h // zip (map (`mod` 32768) [l..]) new_bit
- in (new_bit, s { history = h', loc = (l + len) `mod` 32768 })
-
------------------------------------
-
-get_word32s :: Word32 -> Word32 -> InfM [Word32]
-get_word32s _ 0 = return []
-get_word32s b n = do w <- get_w32 b
- ws <- get_word32s b (n-1)
- return (w:ws)
-
-get_w32 :: Word32 -> InfM Word32
-get_w32 i = do bs <- get_bits i
- return (bits_to_word32 bs)
-
-get_bit :: InfM Bit
-get_bit = do [x] <- get_bits 1
- return x
-
-{-
-\section{Inflate itself}
-
-The hardcore stuff!
-
--}
-inflate :: [Int] -> (Output, [Bit])
-inflate is = extract_InfM $ do set_bits $ concatMap int_to_bits is
- x <- inflate_blocks False
- align_8_bits
- return x
-
--- Bool is true if we have seen the "last" block
-inflate_blocks :: Bool -> InfM Output
-inflate_blocks True = return []
-inflate_blocks False
- = do [Bit is_last, Bit t1, Bit t2] <- get_bits 3
- case (t1, t2) of
- (False, False) ->
- do align_8_bits
- len <- get_w32 16
- nlen <- get_w32 16
- unless (len + nlen == 2^(32 :: Int) - 1)
- $ error "inflate_blocks: Mismatched lengths"
- ws <- get_word32s 8 len
- mapM_ output_w32 ws
- return ws
- (True, False) ->
- inflate_codes is_last inflate_trees_fixed
- (False, True) ->
- do tables <- inflate_tables
- inflate_codes is_last tables
- (True, True) ->
- error ("inflate_blocks: case 11 reserved")
-
-inflate_tables :: InfM Tables
-inflate_tables
- = do hlit <- get_w32 5
- hdist <- get_w32 5
- hclen <- get_w32 4
- llc_bs <- get_bits ((hclen + 4) * 3)
- let llc_bs' = zip (map bits_to_word32 $ triple llc_bs)
- [16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15]
- tab = make_table llc_bs'
- lit_dist_lengths <- make_lit_dist_lengths tab
- (258 + hlit + hdist)
- (error "inflate_tables dummy")
- let (lit_lengths, dist_lengths) = genericSplitAt (257 + hlit)
- lit_dist_lengths
- lit_table = make_table (zip lit_lengths [0..])
- dist_table = make_table (zip dist_lengths [0..])
- return (lit_table, dist_table)
-
-triple :: [a] -> [[a]]
-triple (a:b:c:xs) = [a,b,c]:triple xs
-triple [] = []
-triple _ = error "triple: can't happen"
-
-make_lit_dist_lengths :: Table -> Word32 -> Word32 -> InfM [Word32]
-make_lit_dist_lengths _ i _ | i < 0 = error "make_lit_dist_lengths i < 0"
-make_lit_dist_lengths _ 0 _ = return []
-make_lit_dist_lengths tab i last_thing
- = do c <- tab
- (ls, i', last_thing') <- meta_code i c last_thing
- ws <- make_lit_dist_lengths tab i' last_thing'
- return (ls ++ ws)
-
-meta_code :: Word32 -> Code -> Word32 -> InfM ([Word32], Word32, Word32)
-meta_code c i _ | i < 16 = return ([i], c - 1, i)
-meta_code c 16 last_thing
- = do xs <- get_bits 2
- let l = 3 + bits_to_word32 xs
- return (genericReplicate l last_thing, c - l, last_thing)
-meta_code c 17 _ = do xs <- get_bits 3
- let l = 3 + bits_to_word32 xs
- return (genericReplicate l 0, c - l, 0)
-meta_code c 18 _ = do xs <- get_bits 7
- let l = 11 + bits_to_word32 xs
- return (genericReplicate l 0, c - l, 0)
-meta_code _ i _ = error $ "meta_code: " ++ show i
-
-inflate_codes :: Bool -> Tables -> InfM Output
-inflate_codes seen_last tabs@(tab_litlen, tab_dist)
- =
- {- do done <- no_bits
- if done
- then return [] -- XXX Is this right?
- else -}
- do i <- tab_litlen;
- if i == 256
- then inflate_blocks seen_last
- else
- do pref <- if i < 256
- then do output_w32 i
- return [i]
- else case lookup i litlens of
- Nothing -> error "do_code_litlen"
- Just (base, num_bits) ->
- do extra <- get_w32 num_bits
- let l = base + extra
- dist <- dist_code tab_dist
- repeat_w32s l dist
- o <- inflate_codes seen_last tabs
- return (pref ++ o)
-
-litlens :: [(Code, (LitLen, Word32))]
-litlens = zip [257..285] $ mk_bases 3 litlen_counts ++ [(258, 0)]
- where litlen_counts = [(8,0),(4,1),(4,2),(4,3),(4,4),(4,5)]
-
-dist_code :: Table -> InfM Dist
-dist_code tab
- = do code <- tab
- case lookup code dists of
- Nothing -> error "dist_code"
- Just (base, num_bits) -> do extra <- get_w32 num_bits
- return (base + extra)
-
-dists :: [(Code, (Dist, Word32))]
-dists = zip [0..29] $ mk_bases 1 dist_counts
- where dist_counts = (4,0):map ((,) 2) [1..13]
-
-mk_bases :: Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
-mk_bases base counts = snd $ mapAccumL next_base base incs
- where next_base current bs = (current + 2^bs, (current, bs))
- incs = concat $ map (uncurry replicate) counts
-
-{-
-\section{Fixed tables}
-
-The fixed tables. Not much to say really.
-
--}
-inflate_trees_fixed :: Tables
-inflate_trees_fixed = (make_table $ [(8, c) | c <- [0..143]]
- ++ [(9, c) | c <- [144..255]]
- ++ [(7, c) | c <- [256..279]]
- ++ [(8, c) | c <- [280..287]],
- make_table [(5, c) | c <- [0..29]])
-
-{-
-\section{The Huffman Tree}
-
-As the name suggests, the obvious way to store Huffman trees is in a
-tree datastructure. Externally we want to view them as functions though,
-so we wrap the tree with \verb!get_code! which takes a list of bits and
-returns the corresponding code and the remaining bits. To make a tree
-from a list of length code pairs is a simple recursive process.
-
--}
-data Tree = Branch Tree Tree | Leaf Word32 | Null
-
-make_table :: [(Length, Code)] -> Table
-make_table lcs = case make_tree 0 $ sort $ filter ((/= 0) . fst) lcs of
- (tree, []) -> get_code tree
- _ -> error $ "make_table: Left-over lcs from"
-
-get_code :: Tree -> InfM Code
-get_code (Branch zero_tree one_tree)
- = do Bit b <- get_bit
- if b then get_code one_tree else get_code zero_tree
-get_code (Leaf w) = return w
-get_code Null = error "get_code Null"
-
-make_tree :: Word32 -> [(Length, Code)] -> (Tree, [(Length, Code)])
-make_tree _ [] = (Null, [])
-make_tree i lcs@((l, c):lcs')
- | i == l = (Leaf c, lcs')
- | i < l = let (zero_tree, lcs_z) = make_tree (i+1) lcs
- (one_tree, lcs_o) = make_tree (i+1) lcs_z
- in (Branch zero_tree one_tree, lcs_o)
- | otherwise = error "make_tree: can't happen"
-
-
diff --git a/src/Data/Either/Utils.hs b/src/Data/Either/Utils.hs
deleted file mode 100644
index 0bcb398..0000000
--- a/src/Data/Either/Utils.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-{- arch-tag: Euither utilities
-Copyright (C) 2004-2006 John Goerzen <jgoerzen at complete.org>
-
-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.Either.Utils
- Copyright : Copyright (C) 2004-2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Utilities for working with the Either data type
-
-Copyright (c) 2004 John Goerzen, jgoerzen\@complete.org
--}
-module Data.Either.Utils
- (
- maybeToEither,
- forceEither,
- forceEitherMsg,
- eitherToMonadError,
- fromLeft, fromRight, fromEither
-) where
-import Control.Monad.Error
-
-{- | Converts a Maybe value to an Either value, using the supplied parameter
-as the Left value if the Maybe is Nothing.
-
-This function can be interpreted as:
-
- at maybeToEither :: e -> Maybe a -> Either e a@
-
-Its definition is given as it is so that it can be used in the Error and related monads.
-
--}
-maybeToEither :: MonadError e m =>
- e -- ^ (Left e) will be returned if the Maybe value is Nothing
- -> Maybe a -- ^ (Right a) will be returned if this is (Just a)
- -> m a
-maybeToEither errorval Nothing = throwError errorval
-maybeToEither _ (Just normalval) = return normalval
-
-{- | Pulls a "Right" value out of an Either value. If the Either value is
-Left, raises an exception with "error". -}
-forceEither :: Show e => Either e a -> a
-forceEither (Left x) = error (show x)
-forceEither (Right x) = x
-
-{- | Like 'forceEither', but can raise a specific message with the error. -}
-forceEitherMsg :: Show e => String -> Either e a -> a
-forceEitherMsg msg (Left x) = error $ msg ++ ": " ++ show x
-forceEitherMsg _ (Right x) = x
-
-{- | Takes an either and transforms it into something of the more generic
-MonadError class. -}
-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/Hash/CRC32/GZip.hs b/src/Data/Hash/CRC32/GZip.hs
deleted file mode 100644
index edea625..0000000
--- a/src/Data/Hash/CRC32/GZip.hs
+++ /dev/null
@@ -1,111 +0,0 @@
-{- arch-tag: GZIP CRC32 implementation in pure Haskell
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-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.Hash.CRC32.GZip
- Copyright : Copyright (C) 2004 John Goerzen
- License : GNU GPL, version 2 or later
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-CRC32 checksumming using the GZIP\/PKZIP algorithm as used in both
-ISO 3309 and section 8.1.1.6.2 of ITU-T V.42 and referenced in
-RFC1952.
-
-Copyright (c) 2004 John Goerzen, jgoerzen\@complete.org
--}
-
-module Data.Hash.CRC32.GZip where
-
-import Data.Array
-import Data.Bits
-import Data.Word
-import Data.List
-import Data.Char
-
-update_crc :: Word32 -> Char -> Word32
-update_crc crc ch =
- let c = crc `xor` 0xFFFFFFFF
- newval = (gzipcrctab ! fromIntegral ((c `xor` fromIntegral (ord ch)) .&. 0xff))
- `xor` (c `shiftR` 8)
- in
- newval `xor` 0xFFFFFFFF
-
-update_crc_list :: Word32 -> [Char] -> Word32
-update_crc_list start list = foldl update_crc start list
-
-calc_crc32 :: [Char] -> Word32
-calc_crc32 s = update_crc_list 0 s
-
-gzipcrctab :: Array Int Word32
-gzipcrctab = array (0,255) (zip [0..255]
- [
- 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419,
- 0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4,
- 0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07,
- 0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de,
- 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856,
- 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
- 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4,
- 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b,
- 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3,
- 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a,
- 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599,
- 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
- 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190,
- 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f,
- 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e,
- 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01,
- 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed,
- 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
- 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3,
- 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2,
- 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a,
- 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5,
- 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010,
- 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
- 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17,
- 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6,
- 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615,
- 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8,
- 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344,
- 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
- 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a,
- 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5,
- 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1,
- 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c,
- 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef,
- 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
- 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe,
- 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31,
- 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c,
- 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713,
- 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b,
- 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
- 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1,
- 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c,
- 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278,
- 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7,
- 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66,
- 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
- 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605,
- 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8,
- 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b,
- 0x2d02ef8d ])
diff --git a/src/Data/Hash/CRC32/Posix.hs b/src/Data/Hash/CRC32/Posix.hs
deleted file mode 100644
index d2ad906..0000000
--- a/src/Data/Hash/CRC32/Posix.hs
+++ /dev/null
@@ -1,122 +0,0 @@
--- arch-tag: CRC32 implementation in pure Haskell
--- from http://cvs.sourceforge.net/viewcvs.py/haskell-libs/libs/crypto/crc32.hs
---
--- crc32.hs (C) 2002 HardCore SoftWare, Doug Hoyte
---
--- This program is distributed under the terms of the GNU GPL.
--- See www.gnu.org for more information.
---
--- Haskell implementation of the 32-bit Cyclic Redundancy Check.
--- This code was modeled after the cksum utility distributed with
--- OpenBSD - the lookup table was in fact lifted from the OpenBSD
--- implementation.
---
--- Once compiled, this program is almost a drop-in replacement for
--- the OpenBSD cksum utility.
-
--- $Id: crc32.hs,v 1.2 2003/03/24 00:08:55 eris Exp $
-
-{- |
- Module : Data.Hash.CRC32.Posix
- Copyright : Copyright (C) 2002 HardCore SoftWare, Doug Hoyte
- License : GNU GPL
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-CRC32 checksumming using POSIX 1003.2-1992 algorithm for the polynomial { 32 26
-23 22 16 12 11 10 8 7 5 4 2 1 }, also defined in ISO 8802-3: 1989.
-
-Copyright (c) 2002 HardCore SoftWare, Doug Hoyte
--}
-
-{-
-Modified December, 2004 by John Goerzen:
- * Integrate with MissingH
- * Removed code we don't need in a library
- * Updated things that didn't compile any more
--}
-
-module Data.Hash.CRC32.Posix where
-
-import Data.Array
-import Data.Bits
-import Data.Word
-
-iter_crc32 :: Word32 -> Char -> Word32
-iter_crc32 sumval ch = (sumval `shiftL` 8) `xor`
- crctab ! fromIntegral ((sumval `shiftR` 24) `xor`
- (fromIntegral (fromEnum ch)))
-
-
-calc_crc32 :: [Char] -> Word32 -> Word32 -> Word32
-calc_crc32 [] ck 0 = ck `xor` 0xFFFFFFFF
-calc_crc32 [] ck l = calc_crc32
- []
- (iter_crc32 ck (toEnum $ fromIntegral (l .&. 0xFF)))
- (l `shiftR` 8)
-calc_crc32 (x:xs) ck l = calc_crc32 xs (iter_crc32 ck x) (l+1)
-
-
-crc32 :: [Char] -> Word32
-crc32 x = calc_crc32 x 0 0
-
-
-crctab :: Array Int Word32
-crctab = array (0,255) (zip [0..255]
- [
- 0x0,
- 0x04c11db7, 0x09823b6e, 0x0d4326d9, 0x130476dc, 0x17c56b6b,
- 0x1a864db2, 0x1e475005, 0x2608edb8, 0x22c9f00f, 0x2f8ad6d6,
- 0x2b4bcb61, 0x350c9b64, 0x31cd86d3, 0x3c8ea00a, 0x384fbdbd,
- 0x4c11db70, 0x48d0c6c7, 0x4593e01e, 0x4152fda9, 0x5f15adac,
- 0x5bd4b01b, 0x569796c2, 0x52568b75, 0x6a1936c8, 0x6ed82b7f,
- 0x639b0da6, 0x675a1011, 0x791d4014, 0x7ddc5da3, 0x709f7b7a,
- 0x745e66cd, 0x9823b6e0, 0x9ce2ab57, 0x91a18d8e, 0x95609039,
- 0x8b27c03c, 0x8fe6dd8b, 0x82a5fb52, 0x8664e6e5, 0xbe2b5b58,
- 0xbaea46ef, 0xb7a96036, 0xb3687d81, 0xad2f2d84, 0xa9ee3033,
- 0xa4ad16ea, 0xa06c0b5d, 0xd4326d90, 0xd0f37027, 0xddb056fe,
- 0xd9714b49, 0xc7361b4c, 0xc3f706fb, 0xceb42022, 0xca753d95,
- 0xf23a8028, 0xf6fb9d9f, 0xfbb8bb46, 0xff79a6f1, 0xe13ef6f4,
- 0xe5ffeb43, 0xe8bccd9a, 0xec7dd02d, 0x34867077, 0x30476dc0,
- 0x3d044b19, 0x39c556ae, 0x278206ab, 0x23431b1c, 0x2e003dc5,
- 0x2ac12072, 0x128e9dcf, 0x164f8078, 0x1b0ca6a1, 0x1fcdbb16,
- 0x018aeb13, 0x054bf6a4, 0x0808d07d, 0x0cc9cdca, 0x7897ab07,
- 0x7c56b6b0, 0x71159069, 0x75d48dde, 0x6b93dddb, 0x6f52c06c,
- 0x6211e6b5, 0x66d0fb02, 0x5e9f46bf, 0x5a5e5b08, 0x571d7dd1,
- 0x53dc6066, 0x4d9b3063, 0x495a2dd4, 0x44190b0d, 0x40d816ba,
- 0xaca5c697, 0xa864db20, 0xa527fdf9, 0xa1e6e04e, 0xbfa1b04b,
- 0xbb60adfc, 0xb6238b25, 0xb2e29692, 0x8aad2b2f, 0x8e6c3698,
- 0x832f1041, 0x87ee0df6, 0x99a95df3, 0x9d684044, 0x902b669d,
- 0x94ea7b2a, 0xe0b41de7, 0xe4750050, 0xe9362689, 0xedf73b3e,
- 0xf3b06b3b, 0xf771768c, 0xfa325055, 0xfef34de2, 0xc6bcf05f,
- 0xc27dede8, 0xcf3ecb31, 0xcbffd686, 0xd5b88683, 0xd1799b34,
- 0xdc3abded, 0xd8fba05a, 0x690ce0ee, 0x6dcdfd59, 0x608edb80,
- 0x644fc637, 0x7a089632, 0x7ec98b85, 0x738aad5c, 0x774bb0eb,
- 0x4f040d56, 0x4bc510e1, 0x46863638, 0x42472b8f, 0x5c007b8a,
- 0x58c1663d, 0x558240e4, 0x51435d53, 0x251d3b9e, 0x21dc2629,
- 0x2c9f00f0, 0x285e1d47, 0x36194d42, 0x32d850f5, 0x3f9b762c,
- 0x3b5a6b9b, 0x0315d626, 0x07d4cb91, 0x0a97ed48, 0x0e56f0ff,
- 0x1011a0fa, 0x14d0bd4d, 0x19939b94, 0x1d528623, 0xf12f560e,
- 0xf5ee4bb9, 0xf8ad6d60, 0xfc6c70d7, 0xe22b20d2, 0xe6ea3d65,
- 0xeba91bbc, 0xef68060b, 0xd727bbb6, 0xd3e6a601, 0xdea580d8,
- 0xda649d6f, 0xc423cd6a, 0xc0e2d0dd, 0xcda1f604, 0xc960ebb3,
- 0xbd3e8d7e, 0xb9ff90c9, 0xb4bcb610, 0xb07daba7, 0xae3afba2,
- 0xaafbe615, 0xa7b8c0cc, 0xa379dd7b, 0x9b3660c6, 0x9ff77d71,
- 0x92b45ba8, 0x9675461f, 0x8832161a, 0x8cf30bad, 0x81b02d74,
- 0x857130c3, 0x5d8a9099, 0x594b8d2e, 0x5408abf7, 0x50c9b640,
- 0x4e8ee645, 0x4a4ffbf2, 0x470cdd2b, 0x43cdc09c, 0x7b827d21,
- 0x7f436096, 0x7200464f, 0x76c15bf8, 0x68860bfd, 0x6c47164a,
- 0x61043093, 0x65c52d24, 0x119b4be9, 0x155a565e, 0x18197087,
- 0x1cd86d30, 0x029f3d35, 0x065e2082, 0x0b1d065b, 0x0fdc1bec,
- 0x3793a651, 0x3352bbe6, 0x3e119d3f, 0x3ad08088, 0x2497d08d,
- 0x2056cd3a, 0x2d15ebe3, 0x29d4f654, 0xc5a92679, 0xc1683bce,
- 0xcc2b1d17, 0xc8ea00a0, 0xd6ad50a5, 0xd26c4d12, 0xdf2f6bcb,
- 0xdbee767c, 0xe3a1cbc1, 0xe760d676, 0xea23f0af, 0xeee2ed18,
- 0xf0a5bd1d, 0xf464a0aa, 0xf9278673, 0xfde69bc4, 0x89b8fd09,
- 0x8d79e0be, 0x803ac667, 0x84fbdbd0, 0x9abc8bd5, 0x9e7d9662,
- 0x933eb0bb, 0x97ffad0c, 0xafb010b1, 0xab710d06, 0xa6322bdf,
- 0xa2f33668, 0xbcb4666d, 0xb8757bda, 0xb5365d03, 0xb1f740b4
- ])
-
diff --git a/src/Data/Hash/MD5.lhs b/src/Data/Hash/MD5.lhs
deleted file mode 100644
index 44a5ef2..0000000
--- a/src/Data/Hash/MD5.lhs
+++ /dev/null
@@ -1,359 +0,0 @@
->{- |
-> Module : Data.Hash.MD5
-> Copyright : Copyright (C) 2001 Ian Lynagh
-> License : Either BSD or GPL
->
-> Maintainer : Ian Lynagh <igloo at earth.li>
-> Stability : provisional
-> Portability: portable
->
->Generation of MD5sums
->
->Written by Ian Lynagh, igloo\@earth.li
->-}
-
-> module Data.Hash.MD5 (md5, md5s, md5i,
-> MD5(..), ABCD(..), Zord64, Str(..), BoolList(..), WordList(..)) where
-
-> import Char
-> import Bits
-> import Word
-
-
-Nasty kludge to create a type Zord64 which is really a Word64 but works
-how we want in hugs ands nhc98 too...
-Also need a rotate left function that actually works.
-
-#ifdef __GLASGOW_HASKELL__
-#define rotL rotateL
-> type Zord64 = Word64
-#else
-
-> import Data.Hash.MD5.Zord64_HARD
-
-> rotL :: Word32 -> Rotation -> Word32
-> rotL a s = shiftL a s .|. shiftL a (s-32)
-
-#endif
-
-======================== TYPES AND CLASS DEFINTIONS ========================
-
-
-> type XYZ = (Word32, Word32, Word32)
-> type Rotation = Int
-> newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show)
-> newtype Str = Str String
-> newtype BoolList = BoolList [Bool]
-> newtype WordList = WordList ([Word32], Zord64)
-
-> -- | Anything we want to work out the MD5 of must be an instance of class MD5
-> class MD5 a where
-> get_next :: a -> ([Word32], Int, a) -- get the next blocks worth
-> -- \ \ \------ the rest of the input
-> -- \ \--------- the number of bits returned
-> -- \--------------- the bits returned in 32bit words
-> len_pad :: Zord64 -> a -> a -- append the padding and length
-> finished :: a -> Bool -- Have we run out of input yet?
-
-
-Mainly exists because it's fairly easy to do MD5s on input where the
-length is not a multiple of 8
-
-> instance MD5 BoolList where
-> get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs)
-> where (ys, zs) = splitAt 512 s
-> len_pad l (BoolList bs)
-> = BoolList (bs ++ [True]
-> ++ replicate (fromIntegral $ (447 - l) .&. 511) False
-> ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])]
-> )
-> where mangle [] = []
-> mangle xs = reverse ys ++ mangle zs
-> where (ys, zs) = splitAt 8 xs
-> finished (BoolList s) = s == []
-
-
-The string instance is fairly straightforward
-
-> instance MD5 Str where
-> get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs)
-> where (ys, zs) = splitAt 64 s
-> len_pad c64 (Str s) = Str (s ++ padding ++ l)
-> where padding = '\128':replicate (fromIntegral zeros) '\000'
-> zeros = shiftR ((440 - c64) .&. 511) 3
-> l = length_to_chars 8 c64
-> finished (Str s) = s == ""
-
-
-YA instance that is believed will be useful
-
-> instance MD5 WordList where
-> get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken))
-> where (xs, ys) = splitAt 16 ws
-> taken = if l > 511 then 512 else l .&. 511
-> len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen)
-> where beginning = if length ws > 0 then start ++ lastone' else []
-> start = init ws
-> lastone = last ws
-> offset = c64 .&. 31
-> lastone' = [if offset > 0 then lastone + theone else lastone]
-> theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7))
-> (fromIntegral $ offset .&. (31 - 7))
-> nextish = if offset == 0 then [128] else []
-> c64' = c64 + (32 - offset)
-> num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5)
-> blanks = replicate num_blanks 0
-> lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1)
-> topsize = fromIntegral $ shiftR c64 32
-> size = [lowsize, topsize]
-> newlen = l .&. (complement 511)
-> + if c64 .&. 511 >= 448 then 1024 else 512
-> finished (WordList (_, z)) = z == 0
-
-
-> instance Num ABCD where
-> ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2)
-
-
-======================== EXPORTED FUNCTIONS ========================
-
-
-> {- | The simplest function, gives you the MD5 of a string as 4-tuple of
-> 32bit words. -}
-> md5 :: (MD5 a) => a -> ABCD
-> md5 m = md5_main False 0 magic_numbers m
-
-
-> {- | Returns a hex number ala the md5sum program. -}
-> md5s :: (MD5 a) => a -> String
-> md5s = abcd_to_string . md5
-
-
-> {- | Returns an integer equivalent to hex number from 'md5s'. -}
-> md5i :: (MD5 a) => a -> Integer
-> md5i = abcd_to_integer . md5
-
-
-======================== THE CORE ALGORITHM ========================
-
-
-Decides what to do. The first argument indicates if padding has been
-added. The second is the length mod 2^64 so far. Then we have the
-starting state, the rest of the string and the final state.
-
-> md5_main :: (MD5 a) =>
-> Bool -- Have we added padding yet?
-> -> Zord64 -- The length so far mod 2^64
-> -> ABCD -- The initial state
-> -> a -- The non-processed portion of the message
-> -> ABCD -- The resulting state
-> md5_main padded ilen abcd m
-> = if finished m && padded
-> then abcd
-> else md5_main padded' (ilen + 512) (abcd + abcd') m''
-> where (m16, l, m') = get_next m
-> len' = ilen + fromIntegral l
-> ((m16', _, m''), padded') = if not padded && l < 512
-> then (get_next $ len_pad len' m, True)
-> else ((m16, l, m'), padded)
-> abcd' = md5_do_block abcd m16'
-
-
-md5_do_block processes a 512 bit block by calling md5_round 4 times to
-apply each round with the correct constants and permutations of the
-block
-
-> md5_do_block :: ABCD -- Initial state
-> -> [Word32] -- The block to be processed - 16 32bit words
-> -> ABCD -- Resulting state
-> md5_do_block abcd0 w = abcd4
-> where (r1, r2, r3, r4) = rounds
-> {-
-> map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12]
-> -- [(5 * x + 1) `mod` 16 | x <- [0..15]]
-> map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2]
-> -- [(3 * x + 5) `mod` 16 | x <- [0..15]]
-> map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9]
-> -- [(7 * x) `mod` 16 | x <- [0..15]]
-> -}
-> perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15]
-> = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12]
-> perm5 _ = error "broke at perm5"
-> perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15]
-> = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2]
-> perm3 _ = error "broke at perm3"
-> perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15]
-> = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9]
-> perm7 _ = error "broke at perm7"
-> abcd1 = md5_round md5_f abcd0 w r1
-> abcd2 = md5_round md5_g abcd1 (perm5 w) r2
-> abcd3 = md5_round md5_h abcd2 (perm3 w) r3
-> abcd4 = md5_round md5_i abcd3 (perm7 w) r4
-
-
-md5_round does one of the rounds. It takes an auxiliary function and foldls
-(md5_inner_function f) to repeatedly apply it to the initial state with the
-correct constants
-
-> md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I
-> -- for those of you with a copy of
-> -- the prayer book^W^WRFC)
-> -> ABCD -- Initial state
-> -> [Word32] -- The 16 32bit words of input
-> -> [(Rotation, Word32)] -- The list of 16 rotations and
-> -- additive constants
-> -> ABCD -- Resulting state
-> md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns'
-> where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns
-
-
-Apply one of the functions md5_[fghi] and put the new ABCD together
-
-> md5_inner_function :: (XYZ -> Word32) -- Auxiliary function
-> -> ABCD -- Initial state
-> -> (Rotation, Word32) -- The rotation and additive
-> -- constant (X[i] + T[j])
-> -> ABCD -- Resulting state
-> md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c)
-> where mid_a = a + f(b,c,d) + ki
-> rot_a = rotL mid_a s
-> a' = b + rot_a
-
-
-The 4 auxiliary functions
-
-> md5_f :: XYZ -> Word32
-> md5_f (x, y, z) = z `xor` (x .&. (y `xor` z))
-> {- optimised version of: (x .&. y) .|. ((complement x) .&. z) -}
-
-> md5_g :: XYZ -> Word32
-> md5_g (x, y, z) = md5_f (z, x, y)
-> {- was: (x .&. z) .|. (y .&. (complement z)) -}
-
-> md5_h :: XYZ -> Word32
-> md5_h (x, y, z) = x `xor` y `xor` z
-
-> md5_i :: XYZ -> Word32
-> md5_i (x, y, z) = y `xor` (x .|. (complement z))
-
-
-The magic numbers from the RFC.
-
-> magic_numbers :: ABCD
-> magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476)
-
-
-The 4 lists of (rotation, additive constant) tuples, one for each round
-
-> rounds :: ([(Rotation, Word32)],
-> [(Rotation, Word32)],
-> [(Rotation, Word32)],
-> [(Rotation, Word32)])
-> rounds = (r1, r2, r3, r4)
-> where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db),
-> (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a),
-> (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8),
-> (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be),
-> (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e),
-> (s14, 0x49b40821)]
-> r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51),
-> (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453),
-> (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6),
-> (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed),
-> (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9),
-> (s24, 0x8d2a4c8a)]
-> r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122),
-> (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9),
-> (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6),
-> (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05),
-> (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8),
-> (s34, 0xc4ac5665)]
-> r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7),
-> (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92),
-> (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f),
-> (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1),
-> (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb),
-> (s44, 0xeb86d391)]
-> s11 = 7
-> s12 = 12
-> s13 = 17
-> s14 = 22
-> s21 = 5
-> s22 = 9
-> s23 = 14
-> s24 = 20
-> s31 = 4
-> s32 = 11
-> s33 = 16
-> s34 = 23
-> s41 = 6
-> s42 = 10
-> s43 = 15
-> s44 = 21
-
-
-======================== CONVERSION FUNCTIONS ========================
-
-
-Turn the 4 32 bit words into a string representing the hex number they
-represent.
-
-> abcd_to_string :: ABCD -> String
-> abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d]
-
-
-Split the 32 bit word up, swap the chunks over and convert the numbers
-to their hex equivalents.
-
-> display_32bits_as_hex :: Word32 -> String
-> display_32bits_as_hex w = swap_pairs cs
-> where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7]
-> getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n)
-> swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs
-> swap_pairs _ = []
-
-Convert to an integer, performing endianness magic as we go
-
-> abcd_to_integer :: ABCD -> Integer
-> abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int)
-> + rev_num b * 2^(64 :: Int)
-> + rev_num c * 2^(32 :: Int)
-> + rev_num d
-
-> rev_num :: Word32 -> Integer
-> rev_num i = toInteger j `mod` (2^(32 :: Int))
-> -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~
-> where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255))
-> 0 [0,8,16,24]
-
-Used to convert a 64 byte string to 16 32bit words
-
-> string_to_word32s :: String -> [Word32]
-> string_to_word32s "" = []
-> string_to_word32s ss = this:string_to_word32s ss'
-> where (s, ss') = splitAt 4 ss
-> this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s
-
-
-Used to convert a list of 512 bools to 16 32bit words
-
-> bools_to_word32s :: [Bool] -> [Word32]
-> bools_to_word32s [] = []
-> bools_to_word32s bs = this:bools_to_word32s rest
-> where (bs1, bs1') = splitAt 8 bs
-> (bs2, bs2') = splitAt 8 bs1'
-> (bs3, bs3') = splitAt 8 bs2'
-> (bs4, rest) = splitAt 8 bs3'
-> this = boolss_to_word32 [bs1, bs2, bs3, bs4]
-> bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0
-> boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0
-
-
-Convert the size into a list of characters used by the len_pad function
-for strings
-
-> length_to_chars :: Int -> Zord64 -> String
-> length_to_chars 0 _ = []
-> length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8)
-> where this = chr $ fromIntegral $ n .&. 255
-
diff --git a/src/Data/Hash/MD5/Zord64_HARD.lhs b/src/Data/Hash/MD5/Zord64_HARD.lhs
deleted file mode 100644
index bb300c2..0000000
--- a/src/Data/Hash/MD5/Zord64_HARD.lhs
+++ /dev/null
@@ -1,48 +0,0 @@
->-- #hide
-> module Data.Hash.MD5.Zord64_HARD (Zord64) where
-
-> import Word
-> import Bits
-
-> data Zord64 = W64 {lo,hi::Word32} deriving (Eq, Ord, Bounded)
-
-> w64ToInteger W64{lo=lo,hi=hi} = toInteger lo + 0x100000000 * toInteger hi
-> integerToW64 x = case x `quotRem` 0x100000000 of
-> (h,l) -> W64{lo=fromInteger l, hi=fromInteger h}
-
-> instance Show Zord64
-
-> instance Read Zord64
-
-> instance Num Zord64 where
-> W64{lo=lo_a,hi=hi_a} + W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'}
-> where lo' = lo_a + lo_b
-> hi' = hi_a + hi_b + if lo' < lo_a then 1 else 0
-> W64{lo=lo_a,hi=hi_a} - W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'}
-> where lo' = lo_a - lo_b
-> hi' = hi_a - hi_b + if lo' > lo_a then 1 else 0
-> fromInteger = integerToW64
-
-> instance Bits Zord64 where
-> W64{lo=lo_a,hi=hi_a} .&. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'}
-> where lo' = lo_a .&. lo_b
-> hi' = hi_a .&. hi_b
-> W64{lo=lo_a,hi=hi_a} .|. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'}
-> where lo' = lo_a .|. lo_b
-> hi' = hi_a .|. hi_b
-> shift w 0 = w
-> shift W64{lo=lo,hi=hi} x
-> | x > 63 = W64{lo=0,hi=0}
-> | x > 31 = W64{lo = 0, hi = shift lo (x-32)}
-> | x > 0 = W64{lo = shift lo x, hi = shift hi x .|. shift lo (x-32)}
-> | x < -63 = W64{lo=0,hi=0}
-> | x < -31 = W64{lo = shift hi (x+32), hi = 0}
-> | x < 0 = W64{lo = shift lo x .|. shift hi (x+32), hi = shift hi x}
-> complement W64{lo=lo,hi=hi} = W64{lo=complement lo,hi=complement hi}
-
-> instance Integral Zord64 where
-> toInteger = w64ToInteger
-
-> instance Real Zord64
-> instance Enum Zord64
-
diff --git a/src/Data/List/Utils.hs b/src/Data/List/Utils.hs
deleted file mode 100644
index 4c03f07..0000000
--- a/src/Data/List/Utils.hs
+++ /dev/null
@@ -1,485 +0,0 @@
-{- arch-tag: List utilities main file
-Copyright (C) 2004-2006 John Goerzen <jgoerzen at complete.org>
-
-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.List.Utils
- Copyright : Copyright (C) 2004-2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-This module provides various helpful utilities for dealing with lists.
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module Data.List.Utils(-- * Merging
- merge, mergeBy,
- -- * Tests
- startswith, endswith, contains, hasAny,
- -- * Association List Utilities
- {- | These functions are designed to augment the
- association list functions in "Data.List" and
- provide an interface similar to "Data.FiniteMap" or
- "Data.Map"
- for association lists. -}
- addToAL, delFromAL, flipAL, keysAL, valuesAL,
- hasKeyAL,
- -- ** Association List Conversions
- strFromAL,
- strToAL,
- -- * Conversions
- split, join, replace, genericJoin, takeWhileList,
- dropWhileList, spanList, breakList,
- -- ** Advanced Conversions
- WholeFunc(..), wholeMap, fixedWidth,
- -- * Fixed-Width and State Monad Utilities
- grab,
- -- * Miscellaneous
- countElem, elemRIndex, alwaysElemRIndex, seqList,
- subIndex, uniq
- -- -- * Sub-List Selection
- -- sub,
- ) where
-import Data.List(intersperse, concat, isPrefixOf, isSuffixOf, elemIndices,
- elemIndex, elemIndices, tails, find, findIndex, isInfixOf)
-import Control.Monad.State(State, get, put)
-import Data.Maybe(isJust)
-
-
-{- | Merge two sorted lists into a single, sorted whole.
-
-Example:
-
-> merge [1,3,5] [1,2,4,6] -> [1,1,2,3,4,5,6]
-
-QuickCheck test property:
-
-prop_merge xs ys =
- merge (sort xs) (sort ys) == sort (xs ++ ys)
- where types = xs :: [Int]
--}
-merge :: (Ord a) => [a] -> [a] -> [a]
-merge = mergeBy (compare)
-
-{- | Merge two sorted lists using into a single, sorted whole,
-allowing the programmer to specify the comparison function.
-
-QuickCheck test property:
-
-prop_mergeBy xs ys =
- mergeBy cmp (sortBy cmp xs) (sortBy cmp ys) == sortBy cmp (xs ++ ys)
- where types = xs :: [ (Int, Int) ]
- cmp (x1,_) (x2,_) = compare x1 x2
--}
-mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
-mergeBy cmp [] ys = ys
-mergeBy cmp xs [] = xs
-mergeBy cmp (allx@(x:xs)) (ally@(y:ys))
- -- Ordering derives Eq, Ord, so the comparison below is valid.
- -- Explanation left as an exercise for the reader.
- -- Someone please put this code out of its misery.
- | (x `cmp` y) <= EQ = x : mergeBy cmp xs ally
- | otherwise = y : mergeBy cmp allx ys
-
-{- | Returns true if the given list starts with the specified elements;
-false otherwise. (This is an alias for "Data.List.isPrefixOf".)
-
-Example:
-
-> startswith "He" "Hello" -> True
-
--}
-
-startswith :: Eq a => [a] -> [a] -> Bool
-startswith = isPrefixOf
-
-{- | Returns true if the given list ends with the specified elements;
-false otherwise. (This is an alias for "Data.List.isSuffixOf".)
-
-Example:
-
-> endswith "lo" "Hello" -> True
-
--}
-endswith :: Eq a => [a] -> [a] -> Bool
-endswith = isSuffixOf
-
-{- | Returns true if the given list contains any of the elements in the search
-list. -}
-hasAny :: Eq a => [a] -- ^ List of elements to look for
- -> [a] -- ^ List to search
- -> Bool -- ^ Result
-hasAny [] _ = False -- An empty search list: always false
-hasAny _ [] = False -- An empty list to scan: always false
-hasAny search (x:xs) = if x `elem` search then True else hasAny search xs
-
-{- | Similar to Data.List.takeWhile, takes elements while the func is true.
-The function is given the remainder of the list to examine. -}
-takeWhileList :: ([a] -> Bool) -> [a] -> [a]
-takeWhileList _ [] = []
-takeWhileList func list@(x:xs) =
- if func list
- then x : takeWhileList func xs
- else []
-
-{- | Similar to Data.List.dropWhile, drops elements while the func is true.
-The function is given the remainder of the list to examine. -}
-dropWhileList :: ([a] -> Bool) -> [a] -> [a]
-dropWhileList _ [] = []
-dropWhileList func list@(x:xs) =
- if func list
- then dropWhileList func xs
- else list
-
-{- | Similar to Data.List.span, but performs the test on the entire remaining
-list instead of just one element.
-
- at spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@
--}
-spanList :: ([a] -> Bool) -> [a] -> ([a], [a])
-
-spanList _ [] = ([],[])
-spanList func list@(x:xs) =
- if func list
- then (x:ys,zs)
- else ([],list)
- where (ys,zs) = spanList func xs
-
-{- | Similar to Data.List.break, but performs the test on the entire remaining
-list instead of just one element.
--}
-breakList :: ([a] -> Bool) -> [a] -> ([a], [a])
-breakList func = spanList (not . func)
-
-{- | Given a delimiter and a list (or string), split into components.
-
-Example:
-
-> split "," "foo,bar,,baz," -> ["foo", "bar", "", "baz", ""]
-
-> split "ba" ",foo,bar,,baz," -> [",foo,","r,,","z,"]
--}
-split :: Eq a => [a] -> [a] -> [[a]]
-split _ [] = []
-split delim str =
- let (firstline, remainder) = breakList (startswith delim) str
- in
- firstline : case remainder of
- [] -> []
- x -> if x == delim
- then [] : []
- else split delim
- (drop (length delim) x)
-
-
-{- | Given a list and a replacement list, replaces each occurance of the search
-list with the replacement list in the operation list.
-
-Example:
-
->replace "," "." "127,0,0,1" -> "127.0.0.1"
-
-This could logically be thought of as:
-
->replace old new l = join new . split old $ l
--}
-
-replace :: Eq a => [a] -> [a] -> [a] -> [a]
-replace old new l = join new . split old $ l
-
-{- | Given a delimiter and a list of items (or strings), join the items
-by using the delimiter.
-
-Example:
-
-> join "|" ["foo", "bar", "baz"] -> "foo|bar|baz"
--}
-join :: [a] -> [[a]] -> [a]
-join delim l = concat (intersperse delim l)
-
-{- | Like 'join', but works with a list of anything showable, converting
-it to a String.
-
-Examples:
-
-> genericJoin ", " [1, 2, 3, 4] -> "1, 2, 3, 4"
-> genericJoin "|" ["foo", "bar", "baz"] -> "\"foo\"|\"bar\"|\"baz\""
-
--}
-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.
-
-Example:
-
-> 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 = isInfixOf
-
--- above function submitted to GHC as Data.List.isInfixOf on 8/31/2006
-
-{- | Adds the specified (key, value) pair to the given list, removing any
-existing pair with the same key already present. -}
-addToAL :: Eq key => [(key, elt)] -> key -> elt -> [(key, elt)]
-addToAL l key value = (key, value) : delFromAL l key
-
-{- | Removes all (key, value) pairs from the given list where the key
-matches the given one. -}
-delFromAL :: Eq key => [(key, a)] -> key -> [(key, a)]
-delFromAL l key = filter (\a -> (fst a) /= key) l
-
-{- | Returns the keys that comprise the (key, value) pairs of the given AL.
-
-Same as:
-
->map fst
--}
-keysAL :: [(key, a)] -> [key]
-keysAL = map fst
-
-{- | Returns the values the comprise the (key, value) pairs of the given
-AL.
-
-Same as:
-
->map snd
--}
-valuesAL :: [(a, value)] -> [value]
-valuesAL = map snd
-
-{- | Indicates whether or not the given key is in the AL. -}
-hasKeyAL :: Eq a => a -> [(a, b)] -> Bool
-hasKeyAL key list =
- elem key (keysAL list)
-
-{- | Flips an association list. Converts (key1, val), (key2, val) pairs
-to (val, [key1, key2]). -}
-flipAL :: (Eq key, Eq val) => [(key, val)] -> [(val, [key])]
-flipAL oldl =
- let worker :: (Eq key, Eq val) => [(key, val)] -> [(val, [key])] -> [(val, [key])]
- worker [] accum = accum
- worker ((k, v):xs) accum =
- case lookup v accum of
- Nothing -> worker xs ((v, [k]) : accum)
- Just y -> worker xs (addToAL accum v (k:y))
- in
- worker oldl []
-
-{- | Converts an association list to a string. The string will have
-one pair per line, with the key and value both represented as a Haskell string.
-
-This function is designed to work with [(String, String)] association lists,
-but may work with other types as well. -}
-
-strFromAL :: (Show a, Show b) => [(a, b)] -> String
-strFromAL inp =
- let worker (key, val) = show key ++ "," ++ show val
- in unlines . map worker $ inp
-
-{- | The inverse of 'strFromAL', this function reads a string and outputs the
-appropriate association list.
-
-Like 'strFromAL', this is designed to work with [(String, String)] association
-lists but may also work with other objects with simple representations.
--}
-strToAL :: (Read a, Read b) => String -> [(a, b)]
-strToAL inp =
- let worker line =
- case reads line of
- [(key, remainder)] -> case remainder of
- ',':valstr -> (key, read valstr)
- _ -> error "Data.List.Utils.strToAL: Parse error on value"
- _ -> error "Data.List.Utils.strToAL: Parse error on key"
- in map worker (lines inp)
-
-
-{- FIXME TODO: sub -}
-
-{- | Returns a count of the number of times the given element occured in the
-given list. -}
-countElem :: Eq a => a -> [a] -> Int
-countElem i = length . filter (i==)
-
-{- | Returns the rightmost index of the given element in the
-given list. -}
-elemRIndex :: Eq a => a -> [a] -> Maybe Int
-elemRIndex item l =
- case reverse $ elemIndices item l of
- [] -> Nothing
- (x:_) -> Just x
-{- | Like elemRIndex, but returns -1 if there is nothing
-found. -}
-alwaysElemRIndex :: Eq a => a -> [a] -> Int
-alwaysElemRIndex item list =
- case elemRIndex item list of
- Nothing -> -1
- Just x -> x
-
-{- | Forces the evaluation of the entire list. -}
-seqList :: [a] -> [a]
-seqList [] = []
-seqList list@(x:xs) = seq (seqList xs) list
-
---------------------------------------------------
--- Advanced Conversions
---------------------------------------------------
-
-{- | The type used for functions for 'wholeMap'. See 'wholeMap' for details.
--}
-newtype WholeFunc a b = WholeFunc ([a] -> (WholeFunc a b, [a], [b]))
-
-{- | This is an enhanced version of the concatMap or map functions in
-Data.List.
-
-Unlike those functions, this one:
-
- * Can consume a varying number of elements from the input list during
- each iteration
-
- * Can arbitrarily decide when to stop processing data
-
- * Can return a varying number of elements to insert into the output list
-
- * Can actually switch processing functions mid-stream
-
- * Is not even restricted to processing the input list intact
-
-The function used by wholeMap, of type 'WholeFunc', is repeatedly called
-with the input list. The function returns three things: the function
-to call for the next iteration (if any), what remains of the input list,
-and the list of output elements generated during this iteration. The return
-value of 'wholeMap' is the concatenation of the output element lists from
-all iterations.
-
-Processing stops when the remaining input list is empty. An example
-of a 'WholeFunc' is 'fixedWidth'. -}
-wholeMap :: WholeFunc a b -> [a] -> [b]
-wholeMap _ [] = [] -- Empty input, empty output.
-wholeMap (WholeFunc func) inplist =
- let (nextfunc, nextlist, output) = func inplist
- in
- output ++ wholeMap nextfunc nextlist
-
-{- | A parser designed to process fixed-width input fields. Use it with
-'wholeMap'.
-
-The Int list passed to this function is the list of the field widths desired
-from the input. The result is a list of those widths, if possible. If any
-of the input remains after processing this list, it is added on as the final
-element in the result list. If the input is less than the sum of the requested
-widths, then the result list will be short the appropriate number of elements,
-and its final element may be shorter than requested.
-
-Examples:
-
->wholeMap (fixedWidth [1, 2, 3]) "1234567890"
-> --> ["1","23","456","7890"]
->wholeMap (fixedWidth (repeat 2)) "123456789"
-> --> ["12","34","56","78","9"]
->wholeMap (fixedWidth []) "123456789"
-> --> ["123456789"]
->wholeMap (fixedWidth [5, 3, 6, 1]) "Hello, This is a test."
-> --> ["Hello",", T","his is"," ","a test."]
--}
-fixedWidth :: [Int] -> WholeFunc a [a]
-fixedWidth len =
- WholeFunc (fixedWidthFunc len)
- where -- Empty input: Empty output, stop
- fixedWidthFunc _ [] = ((fixedWidth []), [], [])
- -- Empty length: Stop here.
- fixedWidthFunc [] x = ((fixedWidth []), [], [x])
- -- Stuff to process: Do it.
- fixedWidthFunc (len:lenxs) input =
- (fixedWidth lenxs, next, [this])
- where (this, next) = splitAt len input
-
-{- | Helps you pick out fixed-width components from a list.
-
-Example:
-
->conv :: String -> (String,String)
->conv = runState $
-> do f3 <- grab 3
-> n2 <- grab 2
-> return $ f3 ++ "," ++ n2
->
->main = print $ conv "TestIng"
-
-Prints:
-
->("Tes,tI","ng")
--}
-
-grab :: Int -> State [a] [a]
-grab count =
- do g <- get
- (x, g') <- return $ splitAt count g
- put g'
- return x
-
-{- | Similar to Data.List.elemIndex. Instead of looking for one element in a
-list, this function looks for the first occurance of a sublist in the list,
-and returns the index of the first element of that occurance. If there is no
-such list, returns Nothing.
-
-If the list to look for is the empty list, will return Just 0 regardless
-of the content of the list to search.
-
-Examples:
-
->subIndex "foo" "asdfoobar" -> Just 3
->subIndex "foo" [] -> Nothing
->subIndex "" [] -> Just 0
->subIndex "" "asdf" -> Just 0
->subIndex "test" "asdftestbartest" -> Just 4
->subIndex [(1::Int), 2] [0, 5, 3, 2, 1, 2, 4] -> Just 4
- -}
-subIndex :: Eq a => [a] -> [a] -> Maybe Int
-subIndex substr str = findIndex (isPrefixOf substr) (tails str)
-
-{- | Given a list, returns a new list with all duplicate elements removed.
-For example:
-
->uniq "Mississippi" -> "Misp"
-
-You should not rely on this function necessarily preserving order, though
-the current implementation happens to.
-
-This function is not compatible with infinite lists. -}
-uniq :: Eq a => [a] -> [a]
-uniq [] = []
-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
deleted file mode 100644
index a75740f..0000000
--- a/src/Data/MIME/Types.hs
+++ /dev/null
@@ -1,379 +0,0 @@
-{- arch-tag: MIME Types main file
-Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
-
-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.MIME.Types
- Copyright : Copyright (C) 2004-2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Utilities for guessing MIME types of files.
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module Data.MIME.Types (-- * Creating Lookup Objects
- defaultmtd,
- readMIMETypes,
- hReadMIMETypes,
- readSystemMIMETypes,
- -- * Basic Access
- MIMEResults,
- MIMETypeData(..),
- guessType,
- guessExtension,
- guessAllExtensions
- )
-where
-
-import qualified Data.Map as Map
-import Monad
-import System.IO
-import System.IO.Error
-import System.IO.Utils
-import System.Path
-import Data.Map.Utils
-import Data.Char
-
-----------------------------------------------------------------------
--- Basic type declarations
-----------------------------------------------------------------------
-
-data MIMETypeData = MIMETypeData
- {
- -- | A mapping used to expand common suffixes into equivolent,
- -- better-parsed versions. For instance, ".tgz" would expand
- -- into ".tar.gz".
- suffixMap :: Map.Map String String,
- -- | A mapping used to determine the encoding of a file.
- -- This is used, for instance, to map ".gz" to "gzip".
- encodingsMap :: Map.Map String String,
- -- | A mapping used to map extensions to MIME types.
- typesMap :: Map.Map String String,
- -- | A mapping used to augment the 'typesMap' when non-strict
- -- lookups are used.
- commonTypesMap :: Map.Map String String
- }
-
-{- | Return value from guessing a file's type.
-
-The first element of the tuple gives the MIME type. It is Nothing if no
-suitable type could be found.
-
-The second element gives the encoding. It is Nothing if there was no particular
-encoding for the file, or if no encoding could be found.
--}
-type MIMEResults = (Maybe String, -- The MIME type
- Maybe String -- Encoding
- )
-
-{- | 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
- -> IO MIMETypeData -- ^ New object
-readMIMETypes mtd strict fn = do
- h <- openFile fn ReadMode
- hReadMIMETypes mtd strict h
-
-{- | Load a mime.types file from an already-open handle. -}
-hReadMIMETypes :: MIMETypeData -- ^ Data to work with
- -> Bool -- ^ Whether to work on strict data
- -> Handle -- ^ Handle to read from
- -> IO MIMETypeData -- ^ New object
-hReadMIMETypes mtd strict h =
- let parseline :: MIMETypeData -> String -> MIMETypeData
- parseline obj line =
- let l1 = words line
- procwords [] = []
- procwords (('#':_) :_) = []
- procwords (x:xs) = x : procwords xs
- l2 = procwords l1
- in
- if (length l2) >= 2 then
- let thetype = head l2
- suffixlist = tail l2
- in
- foldl (\o suff -> addType o strict thetype ('.' : suff)) obj suffixlist
- else obj
- in
- 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, ex) =
- case Map.lookup ex (suffixMap mtd) of
- Nothing -> (base, ex)
- Just x -> mapext (splitExt (base ++ x))
- checkencodings (base, ex) =
- case Map.lookup ex (encodingsMap mtd) of
- Nothing -> (base, ex, Nothing)
- Just x -> (fst (splitExt base),
- snd (splitExt base),
- Just x)
- (_, ext, enc) = checkencodings . mapext $ splitExt fn
- typemap = getStrict mtd strict
- in
- case Map.lookup ext typemap of
- Nothing -> (Map.lookup (map toLower ext) typemap, enc)
- Just x -> (Just x, enc)
-
-{- | Guess the extension of a file based on its MIME type.
- The return value includes the leading dot.
-
- Returns Nothing if no extension could be found.
-
- In the event that multiple possible extensions are available,
- one of them will be picked and returned. The logic to select one
- of these should be considered undefined. -}
-guessExtension :: MIMETypeData -- ^ Source data for guessing
- -> 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 =
- case guessAllExtensions mtd strict fn of
- [] -> Nothing
- (x:_) -> Just x
-
-{- | Similar to 'guessExtension', but returns a list of all possible matching
-extensions, or the empty list if there are no matches. -}
-guessAllExtensions :: MIMETypeData -- ^ Source data for guessing
- -> Bool -- ^ Whether to limit to strict data
- -> String -- ^ MIME type to consider
- -> [String] -- ^ Result of guessing
-guessAllExtensions mtd strict fn =
- let mimetype = map toLower fn
- 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 =
- setStrict mtd strict (\m -> Map.insert theext thetype m)
-
-{- | Default MIME type data to use -}
-defaultmtd :: MIMETypeData
-defaultmtd =
- MIMETypeData {suffixMap = default_suffix_map,
- encodingsMap = default_encodings_map,
- typesMap = default_types_map,
- commonTypesMap = default_common_types}
-
-{- | Read the system's default mime.types files, and add the data contained
-therein to the passed object, then return the new one. -}
-readSystemMIMETypes :: MIMETypeData -> IO MIMETypeData
-readSystemMIMETypes mtd =
- let tryread :: MIMETypeData -> String -> IO MIMETypeData
- tryread inputobj filename =
- do
- fn <- try (openFile filename ReadMode)
- case fn of
- Left _ -> return inputobj
- Right h -> do
- x <- hReadMIMETypes inputobj True h
- hClose h
- return x
- in
- do
- 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)
-
-setStrict :: MIMETypeData -> Bool -> (Map.Map String String -> Map.Map String String) -> MIMETypeData
-setStrict mtd True func = mtd{typesMap = func (typesMap mtd)}
-setStrict mtd False func = mtd{commonTypesMap = func (commonTypesMap mtd)}
-
-----------------------------------------------------------------------
--- Default data structures
-----------------------------------------------------------------------
-defaultfilelocations :: [String]
-defaultfilelocations =
- [
- "/etc/mime.types",
- "/usr/local/etc/httpd/conf/mime.types",
- "/usr/local/lib/netscape/mime.types",
- "/usr/local/etc/httpd/conf/mime.types", -- Apache 1.2
- "/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"),
- (".taz", ".tar.gz")
- ]
-
-default_types_map = Map.fromList [
- (".a", "application/octet-stream"),
- (".ai", "application/postscript"),
- (".aif", "audio/x-aiff"),
- (".aifc", "audio/x-aiff"),
- (".aiff", "audio/x-aiff"),
- (".au", "audio/basic"),
- (".avi", "video/x-msvideo"),
- (".bat", "text/plain"),
- (".bcpio", "application/x-bcpio"),
- (".bin", "application/octet-stream"),
- (".bmp", "image/x-ms-bmp"),
- (".c", "text/plain"),
- (".cdf", "application/x-netcdf"),
- (".cpio", "application/x-cpio"),
- (".csh", "application/x-csh"),
- (".css", "text/css"),
- (".dll", "application/octet-stream"),
- (".doc", "application/msword"),
- (".dot", "application/msword"),
- (".dvi", "application/x-dvi"),
- (".eml", "message/rfc822"),
- (".eps", "application/postscript"),
- (".etx", "text/x-setext"),
- (".exe", "application/octet-stream"),
- (".gif", "image/gif"),
- (".gtar", "application/x-gtar"),
- (".h", "text/plain"),
- (".hdf", "application/x-hdf"),
- (".htm", "text/html"),
- (".html", "text/html"),
- (".ief", "image/ief"),
- (".jpe", "image/jpeg"),
- (".jpeg", "image/jpeg"),
- (".jpg", "image/jpeg"),
- (".js", "application/x-javascript"),
- (".ksh", "text/plain"),
- (".latex", "application/x-latex"),
- (".m1v", "video/mpeg"),
- (".man", "application/x-troff-man"),
- (".me", "application/x-troff-me"),
- (".mht", "message/rfc822"),
- (".mhtml", "message/rfc822"),
- (".mif", "application/x-mif"),
- (".mov", "video/quicktime"),
- (".movie", "video/x-sgi-movie"),
- (".mp2", "audio/mpeg"),
- (".mp3", "audio/mpeg"),
- (".mpa", "video/mpeg"),
- (".mpe", "video/mpeg"),
- (".mpeg", "video/mpeg"),
- (".mpg", "video/mpeg"),
- (".ms", "application/x-troff-ms"),
- (".nc", "application/x-netcdf"),
- (".nws", "message/rfc822"),
- (".o", "application/octet-stream"),
- (".obj", "application/octet-stream"),
- (".oda", "application/oda"),
- (".p12", "application/x-pkcs12"),
- (".p7c", "application/pkcs7-mime"),
- (".pbm", "image/x-portable-bitmap"),
- (".pdf", "application/pdf"),
- (".pfx", "application/x-pkcs12"),
- (".pgm", "image/x-portable-graymap"),
- (".pl", "text/plain"),
- (".png", "image/png"),
- (".pnm", "image/x-portable-anymap"),
- (".pot", "application/vnd.ms-powerpoint"),
- (".ppa", "application/vnd.ms-powerpoint"),
- (".ppm", "image/x-portable-pixmap"),
- (".pps", "application/vnd.ms-powerpoint"),
- (".ppt", "application/vnd.ms-powerpoint"),
- (".ps", "application/postscript"),
- (".pwz", "application/vnd.ms-powerpoint"),
- (".py", "text/x-python"),
- (".pyc", "application/x-python-code"),
- (".pyo", "application/x-python-code"),
- (".qt", "video/quicktime"),
- (".ra", "audio/x-pn-realaudio"),
- (".ram", "application/x-pn-realaudio"),
- (".ras", "image/x-cmu-raster"),
- (".rdf", "application/xml"),
- (".rgb", "image/x-rgb"),
- (".roff", "application/x-troff"),
- (".rtx", "text/richtext"),
- (".sgm", "text/x-sgml"),
- (".sgml", "text/x-sgml"),
- (".sh", "application/x-sh"),
- (".shar", "application/x-shar"),
- (".snd", "audio/basic"),
- (".so", "application/octet-stream"),
- (".src", "application/x-wais-source"),
- (".sv4cpio", "application/x-sv4cpio"),
- (".sv4crc", "application/x-sv4crc"),
- (".swf", "application/x-shockwave-flash"),
- (".t", "application/x-troff"),
- (".tar", "application/x-tar"),
- (".tcl", "application/x-tcl"),
- (".tex", "application/x-tex"),
- (".texi", "application/x-texinfo"),
- (".texinfo", "application/x-texinfo"),
- (".tif", "image/tiff"),
- (".tiff", "image/tiff"),
- (".tr", "application/x-troff"),
- (".tsv", "text/tab-separated-values"),
- (".txt", "text/plain"),
- (".ustar", "application/x-ustar"),
- (".vcf", "text/x-vcard"),
- (".wav", "audio/x-wav"),
- (".wiz", "application/msword"),
- (".xbm", "image/x-xbitmap"),
- (".xlb", "application/vnd.ms-excel"),
- (".xls", "application/vnd.ms-excel"),
- (".xml", "text/xml"),
- (".xpm", "image/x-xpixmap"),
- (".xsl", "application/xml"),
- (".xwd", "image/x-xwindowdump"),
- (".zip", "application/zip")
- ]
-
-default_common_types = Map.fromList [
- (".jpg", "image/jpg"),
- (".mid", "audio/midi"),
- (".midi", "audio/midi"),
- (".pct", "image/pict"),
- (".pic", "image/pict"),
- (".pict", "image/pict"),
- (".rtf", "application/rtf"),
- (".xul", "text/xul")
- ]
diff --git a/src/Data/Map/Utils.hs b/src/Data/Map/Utils.hs
deleted file mode 100644
index 29f9f13..0000000
--- a/src/Data/Map/Utils.hs
+++ /dev/null
@@ -1,92 +0,0 @@
-{- Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
-
-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.Map.Utils
- Copyright : Copyright (C) 2004-2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-This module provides various helpful utilities for dealing with Data.Maps.
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module Data.Map.Utils (-- * Basic Utilities
- flipM, flippedLookupM, forceLookupM,
- -- * Conversions
- strToM,
- strFromM
- )
-where
-
-import qualified Data.Map
-import Data.List.Utils(flipAL, strToAL, strFromAL)
-
-{- | Converts a String, String Map into a string representation.
-See 'Data.List.Utils.strFromAL' for more on the similar function for
-association lists. This implementation is simple:
-
->strFromM = strFromAL . Data.Map.toList
-
-This function is designed to work with Map String String objects,
-but may also work with other objects with simple representations. -}
-strFromM :: (Show a, Show b, Ord a) => Data.Map.Map a b -> String
-strFromM = strFromAL . Data.Map.toList
-
-{- | Converts a String into a String, String Map. See
-'Data.List.Utils.strToAL' for more on the similar function for association
-lists.
-
-This implementation is simple:
-
->strToM = Data.Map.fromList . strToAL
-
-This function is designed to work with Map String String objects,
-but may work with other key\/value combinations if they have simple
-representations. -}
-strToM :: (Read a, Read b, Ord a) => String -> Data.Map.Map a b
-strToM = Data.Map.fromList . strToAL
-
-{- | Flips a Map. See 'Data.List.Utils.flipAL' for more on the similar
-function for lists. -}
-
-flipM :: (Ord key, Ord val) => Data.Map.Map key val -> Data.Map.Map val [key]
-flipM = Data.Map.fromList . flipAL . Data.Map.toList
-
-{- | Returns a list of all keys in the Map whose value matches the
-parameter. If the value does not occur in the Map, the empty
-list is returned. -}
-
-flippedLookupM :: (Ord val, Ord key) => val -> Data.Map.Map key val -> [key]
-flippedLookupM v fm =
- case Data.Map.lookup v (flipM fm) of
- Nothing -> []
- Just x -> x
-
-{- | Performs a lookup, and raises an exception (with an error message
-prepended with the given string) if the key could not be found.
--}
-forceLookupM :: (Show key, Ord key) => String -> key ->
- Data.Map.Map key elt -> elt
-forceLookupM msg k fm =
- case Data.Map.lookup k fm of
- Just x -> x
- Nothing -> error $ msg ++ ": could not find key " ++ (show k)
diff --git a/src/Data/Maybe/Utils.hs b/src/Data/Maybe/Utils.hs
deleted file mode 100644
index f520477..0000000
--- a/src/Data/Maybe/Utils.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-{- arch-tag: Maybe utilities
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-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.Maybe.Utils
- Copyright : Copyright (C) 2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Utilities for working with the Either data type
-
-Copyright (c) 2004 John Goerzen, jgoerzen\@complete.org
--}
-module Data.Maybe.Utils
- (
- forceMaybe, forceMaybeMsg
-) where
-
-{- | Pulls a Just value out of a Maybe value. If the Maybe value is
-Nothing, raises an exception with error. -}
-forceMaybe :: Maybe a -> a
-forceMaybe = forceMaybeMsg "forceMaybe: Got Nothing"
-
-{- | Like 'forceMaybe', but lets you customize the error message raised if
-Nothing is supplied. -}
-forceMaybeMsg :: String -> Maybe a -> a
-forceMaybeMsg msg Nothing = error msg
-forceMaybeMsg _ (Just x) = x
diff --git a/src/Data/Progress/Meter.hs b/src/Data/Progress/Meter.hs
deleted file mode 100644
index a2d828b..0000000
--- a/src/Data/Progress/Meter.hs
+++ /dev/null
@@ -1,232 +0,0 @@
-{-
-Copyright (C) 2006 John Goerzen <jgoerzen at complete.org>
-
-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.Progress.Meter
- Copyright : Copyright (C) 2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Tool for maintaining a status bar, supporting multiple simultaneous tasks,
-as a layer atop "Data.Progress.Tracker".
-
-Written by John Goerzen, jgoerzen\@complete.org -}
-
-module Data.Progress.Meter (-- * Types
- ProgressMeter,
- -- * Creation and Configuration
- simpleNewMeter,
- newMeter,
- setComponents,
- addComponent,
- removeComponent,
- setWidth,
-
- -- * Rendering and Output
- renderMeter,
- displayMeter,
- clearMeter,
- writeMeterString,
- autoDisplayMeter,
- killAutoDisplayMeter
- ) where
-
-import Data.Progress.Tracker
-import Control.Concurrent
-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)
-
-{- | The main data type for the progress meter. -}
-data ProgressMeterR =
- ProgressMeterR {masterP :: Progress, -- ^ The master 'Progress' object for overall status
- components :: [Progress], -- ^ Individual component statuses
- width :: Int, -- ^ Width of the meter
- unit :: String, -- ^ Units of display
- renderer :: [Integer] -> [String], -- ^ Function to render numbers
- autoDisplayers :: [ThreadId] -- ^ Auto-updating display
- }
-
-type ProgressMeter = MVar ProgressMeterR
-
-{- | Set up a new status bar using defaults:
-
-* The given tracker
-
-* Width 80
-
-* Data.Quantity.renderNums binaryOpts 1
-
-* Unit inticator @"B"@
-
--}
-simpleNewMeter :: Progress -> IO ProgressMeter
-simpleNewMeter pt = newMeter pt "B" 80 (renderNums binaryOpts 1)
-
-{- | Set up a new status bar. -}
-newMeter :: Progress -- ^ The top-level 'Progress'
- -> String -- ^ Unit indicator string
- -> Int -- ^ Width of the terminal -- usually 80
- -> ([Integer] -> [String])-- ^ A function to render sizes
- -> IO ProgressMeter
-newMeter tracker u w rfunc =
- newMVar $ ProgressMeterR {masterP = tracker, components = [],
- width = w, renderer = rfunc, autoDisplayers = [],
- unit = u}
-
-{- | Adjust the list of components of this 'ProgressMeter'. -}
-setComponents :: ProgressMeter -> [Progress] -> IO ()
-setComponents meter componentlist = modifyMVar_ meter (\m -> return $ m {components = componentlist})
-
-{- | Add a new component to the list of components. -}
-addComponent :: ProgressMeter -> Progress -> IO ()
-addComponent meter component =
- modifyMVar_ meter (\m -> return $ m {components = component : components m})
-
-{- | Remove a component by name. -}
-removeComponent :: ProgressMeter -> String -> IO ()
-removeComponent meter componentname = modifyMVar_ meter $ \m ->
- do newc <- filterM (\x -> withStatus x (\y -> return $ trackerName y /= componentname))
- (components m)
- return $ m {components = newc}
-
-{- | Adjusts the width of this 'ProgressMeter'. -}
-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.
-
-This function will output CR, then the meter.
-
-Pass stdout as the handle for regular display to the screen. -}
-displayMeter :: Handle -> ProgressMeter -> IO ()
-displayMeter h r = withMVar r $ \meter ->
- do s <- renderMeterR meter
- hPutStr h ("\r" ++ s)
- hFlush h
- -- By placing this whole thing under withMVar, we can effectively
- -- 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.
-
-Pass stdout as the handle for regular display to the screen. -}
-clearMeter :: Handle -> ProgressMeter -> IO ()
-clearMeter h pm = withMVar pm $ \m ->
- do hPutStr h (clearmeterstr m)
- hFlush h
-
-{- | 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. -}
-writeMeterString :: Handle -> ProgressMeter -> String -> IO ()
-writeMeterString h pm msg = withMVar pm $ \meter ->
- do s <- renderMeterR meter
- hPutStr h (clearmeterstr meter)
- hPutStr h msg
- 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@
-is an ideal function here.
-
-Save this threadID and use it later to call 'stopAutoDisplayMeter'.
--}
-autoDisplayMeter :: ProgressMeter -- ^ The meter to display
- -> Int -- ^ Update interval in seconds
- -> (ProgressMeter -> IO ()) -- ^ Function to display it
- -> IO ThreadId -- ^ Resulting thread id
-autoDisplayMeter pm delay displayfunc =
- do thread <- forkIO workerthread
- modifyMVar_ pm (\p -> return $ p {autoDisplayers = thread : autoDisplayers p})
- return thread
- where workerthread = do tid <- myThreadId
- -- Help fix a race condition so that the above
- -- modifyMVar can run before a check ever does
- yield
- loop tid
- loop tid = do displayfunc pm
- threadDelay (delay * 1000000)
- c <- doIContinue tid
- when c (loop tid)
- doIContinue tid = withMVar pm $ \p ->
- if tid `elem` autoDisplayers p
- then return True
- else return False
-
-{- | Stops the specified meter from displaying.
-
-You should probably call 'clearMeter' after a call to this. -}
-killAutoDisplayMeter :: ProgressMeter -> ThreadId -> IO ()
-killAutoDisplayMeter pm t =
- modifyMVar_ pm (\p -> return $ p {autoDisplayers = filter (/= t) (autoDisplayers p)})
-
-{- | Render the current status. -}
-renderMeter :: ProgressMeter -> IO String
-renderMeter r = withMVar r $ renderMeterR
-
-renderMeterR :: ProgressMeterR -> IO String
-renderMeterR meter =
- do overallpct <- renderpct $ masterP meter
- compnnts <- mapM (rendercomponent $ renderer meter)
- (components meter)
- let componentstr = case join " " compnnts of
- [] -> ""
- x -> x ++ " "
- rightpart <- renderoverall (renderer meter) (masterP meter)
- let leftpart = overallpct ++ " " ++ componentstr
- let padwidth = (width meter) - 1 - (length leftpart) - (length rightpart)
- if padwidth < 1
- then return $ take (width meter - 1) $ leftpart ++ rightpart
- else return $ leftpart ++ replicate padwidth ' ' ++ rightpart
-
- where
- u = unit meter
- renderpct pt =
- withStatus pt renderpctpts
- 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 ->
- do pct <- renderpctpts pts
- let renders = rfunc [totalUnits pts, completedUnits pts]
- return $ "[" ++ trackerName pts ++ " " ++
- (renders !! 1) ++ u ++ "/" ++
- head renders ++ u ++ " " ++ pct ++ "]"
-
- 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/Progress/Tracker.hs b/src/Data/Progress/Tracker.hs
deleted file mode 100644
index 9b403cc..0000000
--- a/src/Data/Progress/Tracker.hs
+++ /dev/null
@@ -1,407 +0,0 @@
-{-
-Copyright (C) 2006 John Goerzen <jgoerzen at complete.org>
-
-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.Progress.Tracker
- Copyright : Copyright (C) 2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Tools for tracking the status of a long operation.
-
-Written by John Goerzen, jgoerzen\@complete.org
-
-See also "Data.Progress.Meter" -}
-
-module Data.Progress.Tracker (
- -- * Introduction
- -- $introduction
- -- ** Examples
- -- $examples
- -- * Creation and Options
- newProgress, newProgress',
- addCallback, addParent,
- -- * Updating
- incrP, incrP', setP, setP', incrTotal,
- setTotal, finishP,
- -- * Reading and Processing
- getSpeed,
- withStatus,
- getETR,
- getETA,
- -- * Types
- ProgressStatus(..),
- Progress, ProgressTimeSource,
- ProgressCallback,
- ProgressStatuses,
- -- * Utilities
- defaultTimeSource
- )
-
-where
-import Control.Concurrent.MVar
-import System.Time
-import System.Time.Utils
-import Data.Ratio
-
-{- $introduction
-
-ProgressTracker is a module for tracking the progress on long-running
-operations. It can be thought of as the back end engine behind
-a status bar. ProgressTracker can do things such as track how far along
-a task is, provide an estimated time of completion, estimated time remaining,
-current speed, etc. It is designed to be as generic as possible; it can even
-base its speed calculations on something other than the system clock.
-
-ProgressTracker also supports a notion of a parent tracker. This is used when
-a large task is composed of several individual tasks which may also be
-long-running. Downloading many large files over the Internet is a common
-example of this.
-
-Any given ProgressTracker can be told about one or more parent trackers.
-When the child tracker's status is updated, the parent tracker's status is
-also updated in the same manner. Therefore, the progress on each individual
-component, as well as the overall progress, can all be kept in sync
-automatically.
-
-Finally, you can register callbacks. Callbacks are functions that are called
-whenever the status of a tracker changes. They'll be passed the old and new
-status and are intended to do things like update on-screen status displays.
-
-The cousin module 'Data.Progress.Meter' can be used to nicely render
-these trackers on a console.
--}
-
-{- $examples
-
-Here is an example use:
-
->do prog <- newProgress "mytracker" 1024
-> incrP prog 10
-> getETR prog >>= print -- prints number of seconds remaining
-> incrP prog 500
-> finishP prog
--}
-
-----------------------------------------------------------------------
--- TYPES
-----------------------------------------------------------------------
-
-{- | A function that, when called, yields the current time.
-The default is 'defaultTimeSource'. -}
-type ProgressTimeSource = IO Integer
-
-{- | The type for a callback function for the progress tracker.
-When given at creation time to 'newProgress\'' or when added via 'addCallback',
-these functions get called every time the status of the tracker changes.
-
-This function is passed two 'ProgressStatus' records: the first
-reflects the status prior to the update, and the second reflects
-the status after the update.
-
-Please note that the owning 'Progress' object will be locked while the
-callback is running, so the callback will not be able to make changes to it. -}
-type ProgressCallback = ProgressStatus -> ProgressStatus -> IO ()
-
-{- | The main progress status record. -}
-data ProgressStatus =
- ProgressStatus {completedUnits :: Integer,
- totalUnits :: Integer,
- startTime :: Integer,
- trackerName :: String, -- ^ An identifying string
- timeSource :: ProgressTimeSource
- }
-
-data ProgressRecord =
- ProgressRecord {parents :: [Progress],
- callbacks :: [ProgressCallback],
- status :: ProgressStatus}
-
-{- | The main Progress object. -}
-newtype Progress = Progress (MVar ProgressRecord)
-
-class ProgressStatuses a b where
- {- | Lets you examine the 'ProgressStatus' that is contained
- within a 'Progress' object. You can simply pass
- a 'Progress' object and a function to 'withStatus', and
- 'withStatus' will lock the 'Progress' object (blocking any
- modifications while you are reading it), then pass the object
- to your function. If you happen to already have a 'ProgressStatus'
- object, withStatus will also accept it and simply pass it unmodified
- to the function. -}
- withStatus :: a -> (ProgressStatus -> b) -> b
-
-class ProgressRecords a b where
- withRecord :: a -> (ProgressRecord -> b) -> b
-
-{-
-instance ProgressStatuses ProgressRecord b where
- withStatus x func = func (status x)
-instance ProgressRecords ProgressRecord b where
- withRecord x func = func x
--}
-
-instance ProgressStatuses Progress (IO b) where
- withStatus (Progress x) func = withMVar x (\y -> func (status y))
-instance ProgressRecords Progress (IO b) where
- withRecord (Progress x) func = withMVar x func
-
-instance ProgressStatuses ProgressStatus b where
- withStatus x func = func x
-
-----------------------------------------------------------------------
--- Creation
-----------------------------------------------------------------------
-
-{- | Create a new 'Progress' object with the given name and number
-of total units initialized as given. The start time will be initialized
-with the current time at the present moment according to the system clock.
-The units completed will be set to 0, the time source will be set to the
-system clock, and the parents and callbacks will be empty.
-
-If you need more control, see 'newProgress\''.
-
-Example:
-
-> prog <- newProgress "mytracker" 1024
-
--}
-newProgress :: String -- ^ Name of this tracker
- -> Integer -- ^ Total units expected
- -> IO Progress
-newProgress name total =
- do t <- defaultTimeSource
- newProgress' (ProgressStatus {completedUnits = 0, totalUnits = total,
- startTime = t, trackerName = name,
- timeSource = defaultTimeSource})
- []
-
-{- | Create a new 'Progress' object initialized with the given status and
-callbacks.
-No adjustment to the 'startTime' will be made. If you
-want to use the system clock, you can initialize 'startTime' with
-the return value of 'defaultTimeSource' and also pass 'defaultTimeSource'
-as the timing source. -}
-newProgress' :: ProgressStatus
- -> [ProgressCallback] -> IO Progress
-newProgress' news newcb =
- do r <- newMVar $ ProgressRecord {parents = [],
- callbacks = newcb, status = news}
- return (Progress r)
-
-{- | Adds an new callback to an existing 'Progress'. The callback will be
-called whenever the object's status is updated, except by the call to finishP.
-
-Please note that the Progress object will be locked while the callback is
-running, so the callback will not be able to make any modifications to it.
--}
-addCallback :: Progress -> ProgressCallback -> IO ()
-addCallback (Progress mpo) cb = modifyMVar_ mpo $ \po ->
- return $ po {callbacks = cb : callbacks po}
-
-{- | Adds a new parent to an existing 'Progress'. The parent
-will automatically have its completed and total counters incremented
-by the value of those counters in the existing 'Progress'. -}
-addParent :: Progress -- ^ The child object
- -> Progress -- ^ The parent to add to this child
- -> IO ()
-addParent (Progress mcpo) ppo = modifyMVar_ mcpo $ \cpo ->
- do incrP' ppo (completedUnits . status $ cpo)
- incrTotal ppo (totalUnits . status $ cpo)
- return $ cpo {parents = ppo : parents cpo}
-
-{- | Call this when you are finished with the object. It is especially
-important to do this when parent objects are involved.
-
-This will simply set the totalUnits to the current completedUnits count,
-but will not call the callbacks. It will additionally propogate
-any adjustment in totalUnits to the parents, whose callbacks /will/ be
-called.
-
-This ensures that the total expected counts on the parent are always correct.
-Without doing this, if, say, a transfer ended earlier than expected, ETA
-values on the parent would be off since it would be expecting more data than
-actually arrived. -}
-finishP :: Progress -> IO ()
-finishP (Progress mp) =
- modifyMVar_ mp modfunc
- where modfunc :: ProgressRecord -> IO ProgressRecord
- modfunc oldpr =
- do let adjustment = (completedUnits . status $ oldpr)
- - (totalUnits . status $ oldpr)
- callParents oldpr (\x -> incrTotal x adjustment)
- return $ oldpr {status = (status oldpr)
- {totalUnits = completedUnits . status $ oldpr}}
-
-----------------------------------------------------------------------
--- Updating
-----------------------------------------------------------------------
-{- | Increment the completed unit count in the 'Progress' object
-by the amount given. If the value as given exceeds the total, then
-the total will also be raised to match this value so that the
-completed count never exceeds the total.
-
-You can decrease the completed unit count by supplying a negative number
-here. -}
-incrP :: Progress -> Integer -> IO ()
-incrP po count = modStatus po statusfunc
- where statusfunc s =
- s {completedUnits = newcu s,
- totalUnits = if newcu s > totalUnits s
- then newcu s
- else totalUnits s}
- newcu s = completedUnits s + count
-
-{- | Like 'incrP', but never modify the total. -}
-incrP' :: Progress -> Integer -> IO ()
-incrP' po count =
- modStatus po (\s -> s {completedUnits = completedUnits s + count})
-
-{- | Set the completed unit count in the 'Progress' object to the specified
-value. Unlike 'incrP', this function sets the count to a specific value,
-rather than adding to the existing value. If this value exceeds the total,
-then the total will also be raised to match this value so that the completed
-count never exceeds teh total. -}
-setP :: Progress -> Integer -> IO ()
-setP po count = modStatus po statusfunc
- where statusfunc s =
- s {completedUnits = count,
- totalUnits = if count > totalUnits s
- then count
- else totalUnits s}
-
-{- | Like 'setP', but never modify the total. -}
-setP' :: Progress -> Integer -> IO ()
-setP' po count = modStatus po (\s -> s {completedUnits = count})
-
-{- | Increment the total unit count in the 'Progress' object by the amount
-given. This would rarely be needed, but could be needed in some special cases
-when the total number of units is not known in advance. -}
-incrTotal :: Progress -> Integer -> IO ()
-incrTotal po count =
- modStatus po (\s -> s {totalUnits = totalUnits s + count})
-
-{- | Set the total unit count in the 'Progress' object to the specified
-value. Like 'incrTotal', this would rarely be needed. -}
-setTotal :: Progress -> Integer -> IO ()
-setTotal po count =
- modStatus po (\s -> s {totalUnits = count})
-
-----------------------------------------------------------------------
--- Reading and Processing
-----------------------------------------------------------------------
-
-{- | Returns the speed in units processed per time unit. (If you are
-using the default time source, this would be units processed per second).
-This obtains the current speed solely from analyzing the 'Progress' object.
-
-If no time has elapsed yet, returns 0.
-
-You can use this against either a 'Progress' object or a 'ProgressStatus'
-object. This is in the IO monad because the speed is based on the current
-time.
-
-Example:
-
-> getSpeed progressobj >>= print
-
-Don't let the type of this function confuse you. It is a fancy way of saying
-that it can take either a 'Progress' or a 'ProgressStatus' object, and returns
-a number that is valid as any Fractional type, such as a Double, Float, or
-Rational. -}
-getSpeed :: (ProgressStatuses a (IO b), Fractional b) => a -> IO b
-getSpeed po = withStatus po $ \status ->
- do t <- timeSource status
- let elapsed = t - (startTime status)
- return $ if elapsed == 0
- then fromRational 0
- else fromRational ((completedUnits status) % elapsed)
-
-{- | Returns the estimated time remaining, in standard time units.
-
-Returns 0 whenever 'getSpeed' would return 0.
-
-See the comments under 'getSpeed' for information about this function's type
-and result. -}
-getETR :: (ProgressStatuses a (IO Integer),
- ProgressStatuses a (IO Rational)) => a -> IO Integer
-getETR po =
- do speed <- ((getSpeed po)::IO Rational)
- if speed == 0
- then return 0
- else
- -- FIXME: potential for a race condition here, but it should
- -- be negligible
- withStatus po $ \status ->
- do let remaining = totalUnits status - completedUnits status
- return $ round $ (toRational remaining) / speed
-
-{- | Returns the estimated system clock time of completion, in standard
-time units. Returns the current time whenever 'getETR' would return 0.
-
-See the comments under 'getSpeed' for information about this function's type
-and result. -}
-getETA :: (ProgressStatuses a (IO Integer),
- ProgressStatuses a (IO Rational)) => a -> IO Integer
-getETA po =
- do etr <- getETR po
- -- FIXME: similar race potential here
- withStatus po $ \status ->
- do timenow <- timeSource status
- return $ timenow + etr
-
-----------------------------------------------------------------------
--- Utilities
-----------------------------------------------------------------------
-{- | The default time source for the system. This is defined as:
-
->getClockTime >>= (return . clockTimeToEpoch)
--}
-defaultTimeSource :: ProgressTimeSource
-defaultTimeSource = getClockTime >>= (return . clockTimeToEpoch)
-
-now :: ProgressRecords a ProgressTimeSource => a -> ProgressTimeSource
-now x = withRecord x (timeSource . status)
-
-modStatus :: Progress -> (ProgressStatus -> ProgressStatus) -> IO ()
--- FIXME/TODO: handle parents
-modStatus (Progress mp) func =
- modifyMVar_ mp modfunc
- where modfunc :: ProgressRecord -> IO ProgressRecord
- modfunc oldpr =
- do let newpr = oldpr {status = func (status oldpr)}
- mapM_ (\x -> x (status oldpr) (status newpr))
- (callbacks oldpr)
-
- -- Kick it up to the parents.
- case (completedUnits . status $ newpr) -
- (completedUnits . status $ oldpr) of
- 0 -> return ()
- x -> callParents newpr (\y -> incrP' y x)
- case (totalUnits . status $ newpr) -
- (totalUnits . status $ oldpr) of
- 0 -> return ()
- x -> callParents newpr (\y -> incrTotal y x)
- return newpr
-
-callParents :: ProgressRecord -> (Progress -> IO ()) -> IO ()
-callParents pr func = mapM_ func (parents pr)
-
diff --git a/src/Data/Quantity.hs b/src/Data/Quantity.hs
deleted file mode 100644
index 86f00b0..0000000
--- a/src/Data/Quantity.hs
+++ /dev/null
@@ -1,221 +0,0 @@
-{-
-Copyright (C) 2006-2008 John Goerzen <jgoerzen at complete.org>
-
-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.Quantity
- Copyright : Copyright (C) 2006-2008 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Tools for rendering sizes
-
-Written by John Goerzen, jgoerzen\@complete.org -}
-
-module Data.Quantity (
- renderNum,
- renderNums,
- parseNum,
- parseNumInt,
- quantifyNum,
- quantifyNums,
- SizeOpts(..),
- binaryOpts,
- siOpts
- )
-
-where
-import Data.List
-import Text.Printf
-import Data.Char
-
-{- | The options for 'quantifyNum' and 'renderNum' -}
-data SizeOpts = SizeOpts { base :: Int, -- ^ The base from which calculations are made
- powerIncr :: Int, -- ^ The increment to the power for each new suffix
- firstPower :: Int, -- ^ The first power for which suffixes are given
- suffixes :: String -- ^ The suffixes themselves
- }
-
-{- | Predefined definitions for byte measurement in groups of 1024, from 0 to
-2**80 -}
-binaryOpts :: SizeOpts
-binaryOpts = SizeOpts {base = 2,
- firstPower = 0,
- suffixes = " KMGTPEZY",
- powerIncr = 10}
-
-{- | Predefined definitions for SI measurement, from 10**-24 to 10**24. -}
-siOpts :: SizeOpts
-siOpts = SizeOpts {base = 10,
- firstPower = -24,
- suffixes = "yzafpnum kMGTPEZY",
- powerIncr = 3}
-
-{- | Takes a number and returns a new (quantity, suffix) combination.
-The space character is used as the suffix for items around 0. -}
-quantifyNum :: (Ord a, Real a, Floating b, Ord b) => SizeOpts -> a -> (b, Char)
-quantifyNum opts n = (\(x, s) -> (head x, s)) $ quantifyNums opts [n]
-
-{- | Like 'quantifyNum', but takes a list of numbers. The first number in
-the list will be evaluated for the suffix. The same suffix and scale will
-be used for the remaining items in the list. Please see 'renderNums' for
-an example of how this works.
-
-It is invalid to use this function on an empty list. -}
-quantifyNums :: (Ord a, Real a, Floating b, Ord b) => SizeOpts -> [a] -> ([b], Char)
-quantifyNums _ [] = error "Attempt to use quantifyNums on an empty list"
-quantifyNums opts (headnum:xs) =
- (map (\n -> procnum n) (headnum:xs), suffix)
- where number = case fromRational . toRational $ headnum of
- 0 -> 1
- x -> x
- incrList = map idx2pwr [0..length (suffixes opts) - 1]
- incrIdxList = zip incrList [0..]
- idx2pwr i = i * powerIncr opts + firstPower opts
- finderfunc (x, _) = (fromIntegral $ base opts) ** (fromIntegral x)
- <= (abs number)
- -- Find the largest item that does not exceed the number given.
- -- If the number is larger than the larger item in the list,
- -- that's fine; we'll just write it in terms of what we have.
-
- (usedexp, expidx) =
- case find finderfunc (reverse incrIdxList) of
- Just x -> x
- Nothing -> head incrIdxList -- If not found, it's smaller than the first
- suffix = (suffixes opts !! (fromIntegral expidx))
- procnum n = (fromRational . toRational $ n) /
- ((fromIntegral (base opts) ** (fromIntegral usedexp)))
- --(posres, possuf) = quantifyNum opts (headnum * (-1))
-
-{- | Render a number into a string, based on the given quantities. This is
-useful for displaying quantities in terms of bytes or in SI units. Give this
-function the 'SizeOpts' for the desired output, and a precision (number of
-digits to the right of the decimal point), and you get a string output.
-
-Here are some examples:
-
-> Data.Quantity> renderNum binaryOpts 0 1048576
-> "1M"
-> Data.Quantity> renderNum binaryOpts 2 10485760
-> "10.00M"
-> Data.Quantity> renderNum binaryOpts 3 1048576
-> "1.000M"
-> Data.Quantity> renderNum binaryOpts 3 1500000
-> "1.431M"
-> Data.Quantity> renderNum binaryOpts 2 (1500 ** 3)
-> "3.14G"
-
-> Data.Quantity> renderNum siOpts 2 1024
-> "1.02k"
-> Data.Quantity> renderNum siOpts 2 1048576
-> "1.05M"
-> Data.Quantity> renderNum siOpts 2 0.001
-> "1.00m"
-> Data.Quantity> renderNum siOpts 2 0.0001
-> "100.00u"
-
-If you want more control over the output, see 'quantifyNum'. -}
-renderNum :: (Ord a, Real a) =>
- SizeOpts
- -> Int -- ^ Precision of the result
- -> a -- ^ The number to examine
- -> String
-renderNum opts prec number =
- (printf ("%." ++ show prec ++ "g") num) ++ [suffix]
- where (num, suffix) = (quantifyNum opts number)::(Double, Char)
-
-{- | Like 'renderNum', but operates on a list of numbers. The first number
-in the list will be evaluated for the suffix. The same suffix and scale will
-be used for the remaining items in the list. See 'renderNum' for more
-examples.
-
-Also, unlike 'renderNum', the %f instead of %g printf format is used so that
-\"scientific\" notation is avoided in the output.
-
-Examples:
-
-> *Data.Quantity> renderNums binaryOpts 3 [1500000, 10240, 104857600]
-> ["1.431M","0.010M","100.000M"]
-> *Data.Quantity> renderNums binaryOpts 3 [1500, 10240, 104857600]
-> ["1.465K","10.000K","102400.000K"]
-
--}
-renderNums :: (Ord a, Real a) =>
- SizeOpts
- -> Int -- ^ Prevision of the result
- -> [a] -- ^ The numbers to examine
- -> [String] -- ^ Result
-renderNums opts prec numbers =
- map printit convnums
- where printit num =
- (printf ("%." ++ show prec ++ "f") num) ++ [suffix]
- (convnums, suffix) =
- (quantifyNums opts numbers)::([Double], Char)
-
-{- | Parses a String, possibly generated by 'renderNum'. Parses the suffix
-and applies it to the number, which is read via the Read class.
-
-Returns Left "error message" on error, or Right number on successful parse.
-
-If you want an Integral result, the convenience function 'parseNumInt' is for
-you.
--}
-parseNum :: (Read a, Fractional a) =>
- SizeOpts -- ^ Information on how to parse this data
- -> Bool -- ^ Whether to perform a case-insensitive match
- -> String -- ^ The string to parse
- -> Either String a
-parseNum opts insensitive inp =
- case reads inp of
- [] -> Left "Couldn't parse numeric component of input"
- [(num, "")] -> Right num -- No suffix; pass number unhindered
- [(num, [suffix])] ->
- case lookup (caseTransformer suffix) suffixMap of
- Nothing -> Left $ "Unrecognized suffix " ++ show suffix
- Just power -> Right $ num * multiplier power
- [(_, suffix)] -> Left $ "Multi-character suffix " ++ show suffix
- _ -> Left "Multiple parses for input"
- where suffixMap = zip (map caseTransformer . suffixes $ opts)
- (iterate (+ (powerIncr opts)) (firstPower opts))
- caseTransformer x
- | insensitive = toLower x
- | otherwise = x
- multiplier :: (Read a, Fractional a) => Int -> a
- multiplier power =
- fromRational . toRational $
- fromIntegral (base opts) ** fromIntegral power
-{- | Parse a number as with 'parseNum', but return the result as
-an 'Integral'. Any type such as Integer, Int, etc. can be used for the
-result type.
-
-This function simply calls 'round' on the result of 'parseNum'. A
-'Double' is used internally for the parsing of the numeric component.
-
-By using this function, a user can still say something like 1.5M and get an
-integral result. -}
-parseNumInt :: (Read a, Integral a) =>
- SizeOpts -- ^ Information on how to parse this data
- -> Bool -- ^ Whether to perform a case-insensitive match
- -> String -- ^ The string to parse
- -> Either String a
-parseNumInt opts insensitive inp =
- case (parseNum opts insensitive inp)::Either String Double of
- Left x -> Left x
- Right n -> Right (round n)
\ No newline at end of file
diff --git a/src/Data/String/Utils.hs b/src/Data/String/Utils.hs
deleted file mode 100644
index b709f87..0000000
--- a/src/Data/String/Utils.hs
+++ /dev/null
@@ -1,101 +0,0 @@
-{- arch-tag: String utilities main file
-Copyright (C) 2004-2006 John Goerzen <jgoerzen at complete.org>
-
-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 <jgoerzen at complete.org>
- 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
deleted file mode 100644
index e2ad0aa..0000000
--- a/src/Data/Tuple/Utils.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-{- arch-tag: Tuple utilities main file
-Copyright (C) 2004-2006 John Goerzen <jgoerzen at complete.org>
-
-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 <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-This module provides various helpful utilities for dealing with lists.
-
-Written by Neil Mitchell, <http://www.cs.york.ac.uk/~ndm/>
--}
-
-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/Mailbox.hs b/src/Network/Email/Mailbox.hs
deleted file mode 100644
index 689e107..0000000
--- a/src/Network/Email/Mailbox.hs
+++ /dev/null
@@ -1,89 +0,0 @@
-{-
-Copyright (C) 2005 John Goerzen <jgoerzen at complete.org>
-
-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 : Network.Email.Mailbox
- Copyright : Copyright (C) 2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-General support for e-mail mailboxes
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module Network.Email.Mailbox(Flag(..), Flags, Message,
- MailboxReader(..),
- MailboxWriter(..))
-where
-
-{- | The flags which may be assigned to a message. -}
-data Flag =
- SEEN
- | ANSWERED
- | FLAGGED
- | DELETED
- | DRAFT
- | FORWARDED
- | OTHERFLAG String
- deriving (Eq, Show)
-
-{- | Convenience shortcut -}
-type Flags = [Flag]
-
-{- | A Message is represented as a simple String. -}
-type Message = String
-
-{- | Main class for readable mailboxes.
-
-The mailbox object /a/ represents zero or more 'Message's. Each message
-has a unique identifier /b/ in a format specific to each given mailbox.
-This identifier may or may not be persistent.
-
-Functions which return a list are encouraged -- but not guaranteed -- to
-do so lazily.
-
-Implementing classes must provide, at minimum, 'getAll'.
--}
-class (Show a, Show b, Eq b) => MailboxReader a b where
- {- | Returns a list of all unique identifiers. -}
- listIDs :: a -> IO [b]
- {- | Returns a list of all unique identifiers as well as all flags. -}
- listMessageFlags :: a -> IO [(b, Flags)]
- {- | Returns a list of all messages, including their content,
- flags, and unique identifiers. -}
- getAll :: a -> IO [(b, Flags, Message)]
- {- | Returns information about specific messages. -}
- getMessages :: a -> [b] -> IO [(b, Flags, Message)]
-
- listIDs mb = listMessageFlags mb >>= return . map fst
- listMessageFlags mb = getAll mb >>= return .
- map (\(i, f, _) -> (i, f))
- getMessages mb list =
- do messages <- getAll mb
- return $ filter (\(id, f, m) -> id `elem` list) messages
-
-class (MailboxReader a b) => MailboxWriter a b where
- appendMessages :: a -> [(Flags, Message)] -> IO [b]
- deleteMessages :: a -> [b] -> IO ()
- addFlags :: a -> [b] -> Flags -> IO ()
- removeFlags :: a -> [b] -> Flags -> IO ()
- setFlags :: a -> [b] -> Flags -> IO ()
diff --git a/src/Network/Email/Sendmail.hs b/src/Network/Email/Sendmail.hs
deleted file mode 100644
index b08ba97..0000000
--- a/src/Network/Email/Sendmail.hs
+++ /dev/null
@@ -1,112 +0,0 @@
-{-# LANGUAGE CPP #-}
-{- arch-tag: Sendmail utility
-Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
-
-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 : Network.Email.Sendmail
- Copyright : Copyright (C) 2004-2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-This Haskell module provides an interface to transmitting a mail message.
-
-This is not compatible with Windows at this time.
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-#if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-module Network.Email.Sendmail
-where
-#else
-module Network.Email.Sendmail(sendmail)
-where
-
-import System.Cmd.Utils
-import System.Directory
-import System.IO
-import System.IO.Error
-
-sendmails :: [String]
-sendmails = ["/usr/sbin/sendmail",
- "/usr/local/sbin/sendmail",
- "/usr/local/bin/sendmail",
- "/usr/bin/sendmail",
- "/etc/sendmail",
- "/usr/etc/sendmail"]
-
-findsendmail :: IO String
-findsendmail =
- let worker [] = return "sendmail"
- worker (this:next) =
- do
- e <- doesFileExist this
- if e then
- do
- p <- getPermissions this
- if executable p then
- return this
- else worker next
- else worker next
- in
- worker sendmails
-
-{- | Transmits an e-mail message using the system's mail transport agent.
-
-This function takes a message, a list of recipients, and an optional sender,
-and transmits it using the system's MTA, sendmail.
-
-If @sendmail@ is on the @PATH@, it will be used; otherwise, a list of system
-default locations will be searched.
-
-A failure will be logged, since this function uses 'System.Cmd.Utils.safeSystem'
-internally.
-
-This function will first try @sendmail at . If it does not exist, an error is
-logged under @System.Cmd.Utils.pOpen3@ and various default @sendmail@ locations
-are tried. If that still fails, an error is logged and an exception raised.
-
- -}
-sendmail :: Maybe String -- ^ The envelope from address. If not specified, takes the system's default, which is usually based on the effective userid of the current process. This is not necessarily what you want, so I recommend specifying it.
- -> [String] -- ^ A list of recipients for your message. An empty list is an error.
- -> String -- ^ The message itself.
- -> IO ()
-sendmail _ [] _ = fail "sendmail: no recipients specified"
-sendmail Nothing recipients msg = sendmail_worker 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
- in
- do
- --pOpen WriteToPipe "/usr/sbin/sendmail" args func
- rv <- try (pOpen WriteToPipe "sendmail" args func)
- case rv of
- Right x -> return x
- Left _ -> do
- sn <- findsendmail
- r <- pOpen WriteToPipe sn args func
- return $! r
-
-#endif
-
diff --git a/src/Network/SocketServer.hs b/src/Network/SocketServer.hs
deleted file mode 100644
index 85c0498..0000000
--- a/src/Network/SocketServer.hs
+++ /dev/null
@@ -1,199 +0,0 @@
-{- arch-tag: Generic Server Support
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-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 : Network.SocketServer
- Copyright : Copyright (C) 2004-2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : experimental
- Portability: systems with networking
-
-This module provides an infrastructure to simplify server design.
-
-Written by John Goerzen, jgoerzen\@complete.org
-
-Please note: this module is designed to work with TCP, UDP, and Unix domain
-sockets, but only TCP sockets have been tested to date.
-
-This module is presently under-documented. For an example of usage, please
-see the description of "Network.FTP.Server".
--}
-
-module Network.SocketServer(-- * Generic Options and Types
- InetServerOptions(..),
- simpleTCPOptions,
- SocketServer(..),
- HandlerT,
- -- * TCP server convenient setup
- serveTCPforever,
- -- * Lower-Level Processing
- setupSocketServer,
- handleOne,
- serveForever,
- closeSocketServer,
- -- * Combinators
- loggingHandler,
- threadedHandler,
- handleHandler
- )
-where
-import Network.Socket
-import Network.BSD
-import Network.Utils
-import Control.Concurrent
-import System.IO
-import qualified System.Log.Logger
-
-{- | Options for your server. -}
-data InetServerOptions = InetServerOptions {listenQueueSize :: Int,
- portNumber :: PortNumber,
- interface :: HostAddress,
- reuse :: Bool,
- family :: Family,
- sockType :: SocketType,
- protoStr :: String
- }
- deriving (Eq, Show)
-
-{- | The main handler type.
-
-The first parameter is the socket itself.
-
-The second is the address of the remote endpoint.
-
-The third is the address of the local endpoint.
--}
-type HandlerT = Socket -> SockAddr -> SockAddr -> IO ()
-
-{- | Get Default options. You can always modify it later. -}
-simpleTCPOptions :: Int -- ^ Port Number
- -> InetServerOptions
-simpleTCPOptions p = InetServerOptions {listenQueueSize = 5,
- portNumber = (fromIntegral p),
- interface = iNADDR_ANY,
- reuse = False,
- family = AF_INET,
- sockType = Stream,
- protoStr = "tcp"
- }
-
-data SocketServer = SocketServer {optionsSS :: InetServerOptions,
- sockSS :: Socket}
- deriving (Eq, Show)
-
-{- | Takes some options and sets up the 'SocketServer'. I will bind
-and begin listening, but will not accept any connections itself. -}
-setupSocketServer :: InetServerOptions -> IO SocketServer
-setupSocketServer opts =
- do proto <- getProtocolNumber (protoStr opts)
- s <- socket (family opts) (sockType opts) proto
- setSocketOption s ReuseAddr (case (reuse opts) of
- True -> 1
- False -> 0)
- bindSocket s (SockAddrInet (portNumber opts)
- (interface opts))
- listen s (listenQueueSize opts)
- return $ SocketServer {optionsSS = opts, sockSS = s}
-
-{- | Close the socket server. Does not terminate active
-handlers, if any. -}
-closeSocketServer :: SocketServer -> IO ()
-closeSocketServer ss =
- sClose (sockSS ss)
-
-{- | Handle one incoming request from the given 'SocketServer'. -}
-handleOne :: SocketServer -> HandlerT -> IO ()
-handleOne ss func =
- let opts = (optionsSS ss)
- in do a <- accept (sockSS ss)
- localaddr <- getSocketName (fst a)
- func (fst a) (snd a) localaddr
-
-{- | Handle all incoming requests from the given 'SocketServer'. -}
-serveForever :: SocketServer -> HandlerT -> IO ()
-serveForever ss func =
- sequence_ (repeat (handleOne ss func))
-
-{- | Convenience function to completely set up a TCP
-'SocketServer' and handle all incoming requests.
-
-This function is literally this:
-
->serveTCPforever options func =
-> do sockserv <- setupSocketServer options
-> serveForever sockserv func
- -}
-serveTCPforever :: InetServerOptions -- ^ Server options
- -> HandlerT -- ^ Handler function
- -> IO ()
-serveTCPforever options func =
- do sockserv <- setupSocketServer options
- serveForever sockserv func
-
-----------------------------------------------------------------------
--- Combinators
-----------------------------------------------------------------------
-
-{- | Log each incoming connection using the interface in
-"System.Log.Logger".
-
-Log when the incoming connection disconnects.
-
-Also, log any failures that may occur in the child handler. -}
-
-loggingHandler :: String -- ^ Name of logger to use
- -> System.Log.Logger.Priority -- ^ Priority of logged messages
- -> HandlerT -- ^ Handler to call after logging
- -> HandlerT -- ^ Resulting handler
-loggingHandler hname prio nexth socket r_sockaddr l_sockaddr =
- do sockStr <- showSockAddr r_sockaddr
- System.Log.Logger.logM hname prio
- ("Received connection from " ++ sockStr)
- System.Log.Logger.traplogging hname
- System.Log.Logger.WARNING "" (nexth socket r_sockaddr
- l_sockaddr)
- System.Log.Logger.logM hname prio
- ("Connection " ++ sockStr ++ " disconnected")
-
-
--- | Handle each incoming connection in its own thread to
--- make the server multi-tasking.
-threadedHandler :: HandlerT -- ^ Handler to call in the new thread
- -> HandlerT -- ^ Resulting handler
-threadedHandler nexth socket r_sockaddr l_sockaddr=
- do forkIO (nexth socket r_sockaddr l_sockaddr)
- return ()
-
-{- | Give your handler function a Handle instead of a Socket.
-
-The Handle will be opened with ReadWriteMode (you use one handle for both
-directions of the Socket). Also, it will be initialized with LineBuffering.
-
-Unlike other handlers, the handle will be closed when the function returns.
-Therefore, if you are doing threading, you should to it before you call this
-handler.
--}
-handleHandler :: (Handle -> SockAddr -> SockAddr -> IO ()) -- ^ Handler to call
- -> HandlerT
-handleHandler func socket r_sockaddr l_sockaddr =
- do h <- socketToHandle socket ReadWriteMode
- hSetBuffering h LineBuffering
- func h r_sockaddr l_sockaddr
- hClose h
diff --git a/src/Network/Utils.hs b/src/Network/Utils.hs
deleted file mode 100644
index 3706514..0000000
--- a/src/Network/Utils.hs
+++ /dev/null
@@ -1,93 +0,0 @@
-{- arch-tag: Network utilities main file
-Copyright (C) 2004-2008 John Goerzen <jgoerzen at complete.org>
-
-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 : Network.Utils
- Copyright : Copyright (C) 2004-2008 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: systems with networking
-
-This module provides various helpful utilities for dealing with networking
-
-Written by John Goerzen, jgoerzen\@complete.org
-
--}
-
-module Network.Utils (niceSocketsDo, connectTCP, connectTCPAddr,
- listenTCPAddr, showSockAddr)
- where
-
-import Network
-import Network.Socket
-import Network.BSD
-import System.IO
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-import qualified System.Posix.Signals
-#endif
-
-{- | 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.
-
-Example:
-
-> main = niceSocketsDo $ do { ... }
--}
-
--- FIXME integrate with WebCont.Util.UDP
-
-niceSocketsDo :: IO a -> IO a
-niceSocketsDo func = do
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
- -- No signals on Windows anyway
- System.Posix.Signals.installHandler
- System.Posix.Signals.sigPIPE
- System.Posix.Signals.Ignore
- Nothing
-#endif
- withSocketsDo func
-
-connectTCP :: HostName -> PortNumber -> IO Socket
-connectTCP host port = do
- he <- getHostByName host
- connectTCPAddr (SockAddrInet port (hostAddress he))
-
-connectTCPAddr :: SockAddr -> IO Socket
-connectTCPAddr addr = do
- proto <- getProtocolNumber "tcp"
- s <- socket AF_INET Stream proto
- connect s addr
- return s
-
-listenTCPAddr :: SockAddr -> Int -> IO Socket
-listenTCPAddr addr queuelen = do
- proto <- getProtocolNumber "tcp"
- s <- socket AF_INET Stream proto
- bindSocket s addr
- listen s queuelen
- return s
-
-showSockAddr :: SockAddr -> IO String
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-showSockAddr (SockAddrUnix x) = return $ "UNIX socket at " ++ x
-#endif
-showSockAddr (SockAddrInet port host) =
- do h <- inet_ntoa host
- return $ "IPv4 host " ++ h ++ ", port " ++ (show port)
diff --git a/src/System/Cmd/Utils.hs b/src/System/Cmd/Utils.hs
deleted file mode 100644
index d6d303f..0000000
--- a/src/System/Cmd/Utils.hs
+++ /dev/null
@@ -1,569 +0,0 @@
--- arch-tag: Command utilities main file
-{-# LANGUAGE CPP #-}
-{-
-Copyright (C) 2004-2006 John Goerzen <jgoerzen at complete.org>
-
-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 : System.Cmd.Utils
- Copyright : Copyright (C) 2004-2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable to platforms with POSIX process\/signal tools
-
-Command invocation utilities.
-
-Written by John Goerzen, jgoerzen\@complete.org
-
-Please note: Most of this module is not compatible with Hugs.
-
-Command lines executed will be logged using "System.Log.Logger" at the
-DEBUG level. Failure messages will be logged at the WARNING level in addition
-to being raised as an exception. Both are logged under
-\"System.Cmd.Utils.funcname\" -- for instance,
-\"System.Cmd.Utils.safeSystem\". If you wish to suppress these messages
-globally, you can simply run:
-
-> updateGlobalLogger "System.Cmd.Utils.safeSystem"
-> (setLevel CRITICAL)
-
-See also: 'System.Log.Logger.updateGlobalLogger',
-"System.Log.Logger".
-
-It is possible to set up pipelines with these utilities. Example:
-
-> (pid1, x1) <- pipeFrom "ls" ["/etc"]
-> (pid2, x2) <- pipeBoth "grep" ["x"] x1
-> putStr x2
-> ... the grep output is displayed ...
-> forceSuccess pid2
-> forceSuccess pid1
-
-Remember, when you use the functions that return a String, you must not call
-'forceSuccess' until after all data from the String has been consumed. Failure
-to wait will cause your program to appear to hang.
-
-Here is an example of the wrong way to do it:
-
-> (pid, x) <- pipeFrom "ls" ["/etc"]
-> forceSuccess pid -- Hangs; the called program hasn't terminated yet
-> processTheData x
-
-You must instead process the data before calling 'forceSuccess'.
-
-When using the hPipe family of functions, this is probably more obvious.
-
-Most of this module will be incompatible with Windows.
--}
-
-
-module System.Cmd.Utils(-- * High-Level Tools
- PipeHandle(..),
- safeSystem,
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
- forceSuccess,
-#ifndef __HUGS__
- posixRawSystem,
- forkRawSystem,
- -- ** Piping with lazy strings
- pipeFrom,
- pipeLinesFrom,
- pipeTo,
- pipeBoth,
- -- ** Piping with handles
- hPipeFrom,
- hPipeTo,
- hPipeBoth,
-#endif
-#endif
- -- * Low-Level Tools
- PipeMode(..),
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
- pOpen, pOpen3, pOpen3Raw
-#endif
-#endif
- )
-where
-
--- FIXME - largely obsoleted by 6.4 - convert to wrappers.
-
-import System.Exit
-import System.Cmd
-import System.Log.Logger
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-import System.Posix.IO
-import System.Posix.Process
-import System.Posix.Signals
-import qualified System.Posix.Signals
-#endif
-import System.Posix.Types
-import System.IO
-import System.IO.Error
-import Control.Concurrent(forkIO)
-import Control.Exception(finally)
-
-data PipeMode = ReadFromPipe | WriteToPipe
-
-logbase :: String
-logbase = "System.Cmd.Utils"
-
-{- | Return value from 'pipeFrom', 'pipeLinesFrom', 'pipeTo', or
-'pipeBoth'. Contains both a ProcessID and the original command that was
-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 =
- PipeHandle { processID :: ProcessID,
- phCommand :: FilePath,
- phArgs :: [String],
- phCreator :: String -- ^ Function that created it
- }
- deriving (Eq, Show)
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Like 'pipeFrom', but returns data in lines instead of just a String.
-Shortcut for calling lines on the result from 'pipeFrom'.
-
-Note: this function logs as pipeFrom.
-
-Not available on Windows. -}
-pipeLinesFrom :: FilePath -> [String] -> IO (PipeHandle, [String])
-pipeLinesFrom fp args =
- do (pid, c) <- pipeFrom fp args
- return $ (pid, lines c)
-#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
- fail m
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Read data from a pipe. Returns a Handle and a 'PipeHandle'.
-
-When done, you must hClose the handle, and then use either 'forceSuccess' or
-getProcessStatus on the 'PipeHandle'. Zomeibes will result otherwise.
-
-This function logs as pipeFrom.
-
-Not available on Windows or with Hugs.
--}
-hPipeFrom :: FilePath -> [String] -> IO (PipeHandle, Handle)
-hPipeFrom fp args =
- do pipepair <- createPipe
- logRunning "pipeFrom" fp args
- let childstuff = do dupTo (snd pipepair) stdOutput
- closeFd (fst pipepair)
- executeFile fp True args Nothing
- p <- try (forkProcess childstuff)
- -- parent
- pid <- case p of
- Right x -> return x
- Left e -> warnFail "pipeFrom" fp args $
- "Error in fork: " ++ show e
- closeFd (snd pipepair)
- h <- fdToHandle (fst pipepair)
- return (PipeHandle pid fp args "pipeFrom", h)
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Read data from a pipe. Returns a lazy string and a 'PipeHandle'.
-
-ONLY AFTER the string has been read completely, You must call either
-'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the 'PipeHandle'.
-Zombies will result otherwise.
-
-Not available on Windows.
--}
-pipeFrom :: FilePath -> [String] -> IO (PipeHandle, String)
-pipeFrom fp args =
- do (pid, h) <- hPipeFrom fp args
- c <- hGetContents h
- return (pid, c)
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Write data to a pipe. Returns a 'PipeHandle' and a new Handle to write
-to.
-
-When done, you must hClose the handle, and then use either 'forceSuccess' or
-getProcessStatus on the 'PipeHandle'. Zomeibes will result otherwise.
-
-This function logs as pipeTo.
-
-Not available on Windows.
--}
-hPipeTo :: FilePath -> [String] -> IO (PipeHandle, Handle)
-hPipeTo fp args =
- do pipepair <- createPipe
- logRunning "pipeTo" fp args
- let childstuff = do dupTo (fst pipepair) stdInput
- closeFd (snd pipepair)
- executeFile fp True args Nothing
- p <- try (forkProcess childstuff)
- -- parent
- pid <- case p of
- Right x -> return x
- Left e -> warnFail "pipeTo" fp args $
- "Error in fork: " ++ show e
- closeFd (fst pipepair)
- h <- fdToHandle (snd pipepair)
- return (PipeHandle pid fp args "pipeTo", h)
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Write data to a pipe. Returns a ProcessID.
-
-You must call either
-'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the ProcessID.
-Zombies will result otherwise.
-
-Not available on Windows.
--}
-pipeTo :: FilePath -> [String] -> String -> IO PipeHandle
-pipeTo fp args message =
- do (pid, h) <- hPipeTo fp args
- finally (hPutStr h message)
- (hClose h)
- return pid
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Like a combination of 'hPipeTo' and 'hPipeFrom'; returns
-a 3-tuple of ('PipeHandle', Data From Pipe, Data To Pipe).
-
-When done, you must hClose both handles, and then use either 'forceSuccess' or
-getProcessStatus on the 'PipeHandle'. Zomeibes will result otherwise.
-
-Hint: you will usually need to ForkIO a thread to handle one of the Handles;
-otherwise, deadlock can result.
-
-This function logs as pipeBoth.
-
-Not available on Windows.
--}
-hPipeBoth :: FilePath -> [String] -> IO (PipeHandle, Handle, Handle)
-hPipeBoth fp args =
- do frompair <- createPipe
- topair <- createPipe
- logRunning "pipeBoth" fp args
- let childstuff = do dupTo (snd frompair) stdOutput
- closeFd (fst frompair)
- dupTo (fst topair) stdInput
- closeFd (snd topair)
- executeFile fp True args Nothing
- p <- try (forkProcess childstuff)
- -- parent
- pid <- case p of
- Right x -> return x
- Left e -> warnFail "pipeBoth" fp args $
- "Error in fork: " ++ show e
- closeFd (snd frompair)
- closeFd (fst topair)
- fromh <- fdToHandle (fst frompair)
- toh <- fdToHandle (snd topair)
- return (PipeHandle pid fp args "pipeBoth", fromh, toh)
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Like a combination of 'pipeTo' and 'pipeFrom'; forks an IO thread
-to send data to the piped program, and simultaneously returns its output
-stream.
-
-The same note about checking the return status applies here as with 'pipeFrom'.
-
-Not available on Windows. -}
-pipeBoth :: FilePath -> [String] -> String -> IO (PipeHandle, String)
-pipeBoth fp args message =
- do (pid, fromh, toh) <- hPipeBoth fp args
- forkIO $ finally (hPutStr toh message)
- (hClose toh)
- c <- hGetContents fromh
- return (pid, c)
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-{- | Uses 'System.Posix.Process.getProcessStatus' to obtain the exit status
-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.
-
-Not available on Windows. -}
-forceSuccess :: PipeHandle -> IO ()
-forceSuccess (PipeHandle pid fp args funcname) =
- let warnfail = warnFail funcname
- in do status <- getProcessStatus True False pid
- case status of
- Nothing -> warnfail fp args $ "Got no process status"
- Just (Exited (ExitSuccess)) -> return ()
- Just (Exited (ExitFailure fc)) ->
- cmdfailed funcname fp args fc
- Just (Terminated sig) ->
- warnfail fp args $ "Terminated 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.
-If the command terminated successfully, return normally. Otherwise,
-raises a userError with the problem.
-
-Implemented in terms of 'posixRawSystem' where supported, and System.Posix.rawSystem otherwise.
--}
-safeSystem :: FilePath -> [String] -> IO ()
-safeSystem command args =
- do debugM (logbase ++ ".safeSystem")
- ("Running: " ++ command ++ " " ++ (show args))
-#if defined(__HUGS__) || defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)
- ec <- rawSystem command args
- case ec of
- ExitSuccess -> return ()
- ExitFailure fc -> cmdfailed "safeSystem" command args fc
-#else
- ec <- posixRawSystem command args
- case ec of
- Exited ExitSuccess -> return ()
- Exited (ExitFailure fc) -> cmdfailed "safeSystem" command args fc
- Terminated s -> cmdsignalled "safeSystem" command args s
- Stopped s -> cmdsignalled "safeSystem" command args s
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Invokes the specified command in a subprocess, waiting for the result.
-Return the result status. Never raises an exception. Only available
-on POSIX platforms.
-
-Like system(3), this command ignores SIGINT and SIGQUIT and blocks SIGCHLD
-during its execution.
-
-Logs as System.Cmd.Utils.posixRawSystem -}
-posixRawSystem :: FilePath -> [String] -> IO ProcessStatus
-posixRawSystem program args =
- do debugM (logbase ++ ".posixRawSystem")
- ("Running: " ++ program ++ " " ++ (show args))
- oldint <- installHandler sigINT Ignore Nothing
- oldquit <- installHandler sigQUIT Ignore Nothing
- let sigset = addSignal sigCHLD emptySignalSet
- oldset <- getSignalMask
- blockSignals sigset
- childpid <- forkProcess (childaction oldint oldquit oldset)
-
- mps <- getProcessStatus True False childpid
- restoresignals oldint oldquit oldset
- let retval = case mps of
- Just x -> x
- Nothing -> error "Nothing returned from getProcessStatus"
-
- debugM (logbase ++ ".posixRawSystem")
- (program ++ ": exited with " ++ show retval)
- return retval
-
- where childaction oldint oldquit oldset =
- do restoresignals oldint oldquit oldset
- executeFile program True args Nothing
- restoresignals oldint oldquit oldset =
- do installHandler sigINT oldint Nothing
- installHandler sigQUIT oldquit Nothing
- setSignalMask oldset
-
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Invokes the specified command in a subprocess, without waiting for
-the result. Returns the PID of the subprocess -- it is YOUR responsibility
-to use getProcessStatus or getAnyProcessStatus on that at some point. Failure
-to do so will lead to resource leakage (zombie processes).
-
-This function does nothing with signals. That too is up to you.
-
-Logs as System.Cmd.Utils.forkRawSystem -}
-forkRawSystem :: FilePath -> [String] -> IO ProcessID
-forkRawSystem program args =
- do debugM (logbase ++ ".forkRawSystem")
- ("Running: " ++ program ++ " " ++ (show args))
- forkProcess childaction
- 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) ++
- " failed; exit code " ++ (show failcode)
- let e = userError (errormsg)
- warningM (logbase ++ "." ++ funcname) errormsg
- ioError e
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-cmdsignalled :: String -> FilePath -> [String] -> Signal -> IO a
-cmdsignalled funcname command args failcode = do
- let errormsg = "Command " ++ command ++ " " ++ (show args) ++
- " failed due to signal " ++ (show failcode)
- let e = userError (errormsg)
- warningM (logbase ++ "." ++ funcname) errormsg
- ioError e
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Open a pipe to the specified command.
-
-Passes the handle on to the specified function.
-
-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] ->
- (Handle -> IO a) -> IO a
-pOpen pm fp args func =
- do
- pipepair <- createPipe
- debugM (logbase ++ ".pOpen")
- ("Running: " ++ fp ++ " " ++ (show args))
- case pm of
- ReadFromPipe -> do
- let callfunc _ = do
- closeFd (snd pipepair)
- h <- fdToHandle (fst pipepair)
- x <- func h
- hClose h
- return $! x
- pOpen3 Nothing (Just (snd pipepair)) Nothing fp args
- callfunc (closeFd (fst pipepair))
- WriteToPipe -> do
- let callfunc _ = do
- closeFd (fst pipepair)
- h <- fdToHandle (snd pipepair)
- x <- func h
- hClose h
- return $! x
- pOpen3 (Just (fst pipepair)) Nothing Nothing fp args
- callfunc (closeFd (snd pipepair))
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Runs a command, redirecting things to pipes.
-
-Not available on Windows.
-
-Note that you may not use the same fd on more than one item. If you
-want to redirect stdout and stderr, dup it first.
--}
-pOpen3 :: Maybe Fd -- ^ Send stdin to this fd
- -> Maybe Fd -- ^ Get stdout from this fd
- -> Maybe Fd -- ^ Get stderr from this fd
- -> FilePath -- ^ Command to run
- -> [String] -- ^ Command args
- -> (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 =
- do pid <- pOpen3Raw pin pout perr fp args childfunc
- retval <- func $! pid
- let rv = seq retval retval
- forceSuccess (PipeHandle (seq retval pid) fp args "pOpen3")
- return rv
-#endif
-#endif
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-#ifndef __HUGS__
-{- | Runs a command, redirecting things to pipes.
-
-Not available on Windows.
-
-Returns immediately with the PID of the child. Using 'waitProcess' on it
-is YOUR responsibility!
-
-Note that you may not use the same fd on more than one item. If you
-want to redirect stdout and stderr, dup it first.
--}
-pOpen3Raw :: Maybe Fd -- ^ Send stdin to this fd
- -> Maybe Fd -- ^ Get stdout from this fd
- -> Maybe Fd -- ^ Get stderr from this fd
- -> FilePath -- ^ Command to run
- -> [String] -- ^ Command args
- -> IO () -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS
- -> IO ProcessID
-pOpen3Raw pin pout perr fp args childfunc =
- let mayberedir Nothing _ = return ()
- mayberedir (Just fromfd) tofd = do
- dupTo fromfd tofd
- closeFd fromfd
- return ()
- childstuff = do
- mayberedir pin stdInput
- mayberedir pout stdOutput
- mayberedir perr stdError
- childfunc
- debugM (logbase ++ ".pOpen3")
- ("Running: " ++ fp ++ " " ++ (show args))
- executeFile fp True args Nothing
-{-
- realfunc p = do
- System.Posix.Signals.installHandler
- System.Posix.Signals.sigPIPE
- System.Posix.Signals.Ignore
- Nothing
- func p
--}
- in
- do
- p <- try (forkProcess childstuff)
- pid <- case p of
- Right x -> return x
- Left e -> fail ("Error in fork: " ++ (show e))
- return pid
-
-#endif
-#endif
-
-showCmd :: FilePath -> [String] -> String
-showCmd fp args = fp ++ " " ++ show args
diff --git a/src/System/Console/GetOpt/Utils.hs b/src/System/Console/GetOpt/Utils.hs
deleted file mode 100644
index 20f2431..0000000
--- a/src/System/Console/GetOpt/Utils.hs
+++ /dev/null
@@ -1,93 +0,0 @@
-{-
-Copyright (C) 2005 John Goerzen <jgoerzen at complete.org>
-
-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 : MissingH.getOpt
- Copyright : Copyright (C) 2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Written by John Goerzen, jgoerzen\@complete.org
-
-Utilities for command-line parsing, including wrappers around
-the standard System.Console.GetOpt module.
--}
-module System.Console.GetOpt.Utils (parseCmdLine,
- validateCmdLine,
- StdOption,
- stdRequired,
- stdOptional
- )
-where
-import System.Console.GetOpt
-import System.Environment
-
-{- | Simple command line parser -- a basic wrapper around the system's
-default getOpt. See the System.Console.GetOpt manual for a description of the
-first two parameters.
-
-The third parameter is a usage information header.
-
-The return value consists of the list of parsed flags and a list of
-non-option arguments. -}
-parseCmdLine :: ArgOrder a -> [OptDescr a] -> String -> IO ([a], [String])
-parseCmdLine order options header =
- do argv <- getArgs
- case getOpt order options argv of
- (o, n, []) -> return (o, n)
- (_, _, errors) -> ioError (userError (concat errors ++
- usageInfo header options))
-
-{- | Similar to 'parseCmdLine', but takes an additional function that validates
-the post-parse command-line arguments. This is useful, for example, in
-situations where there are two arguments that are mutually-exclusive and only
-one may legitimately be given at a time.
-
-The return value of the function indicates whether or not it detected an
-error condition. If it returns Nothing, there is no error. If it returns
-Just String, there was an error, described by the String.
--}
-validateCmdLine :: ArgOrder a -> [OptDescr a] -> String ->
- (([a],[String]) -> Maybe String) -> IO ([a], [String])
-validateCmdLine order options header func =
- do res <- parseCmdLine order options header
- case func res of
- Nothing -> return res
- Just errormsg -> ioError (userError (errormsg ++ "\n" ++
- usageInfo header options))
-
-{- | A type to standardize some common uses of GetOpt.
-
-The first component of the tuple is the long name of the option.
-
-The second component is empty if there is no arg, or has the arg otherwise. -}
-type StdOption = (String, String)
-
-{- | Handle a required argument. -}
-stdRequired :: String -- ^ Name of arg
- -> String -> StdOption
-stdRequired name value = (name, value)
-
-{- | Handle an optional argument. -}
-stdOptional :: String -- ^ Name of arg
- -> Maybe String -> StdOption
-stdOptional name Nothing = (name, "")
-stdOptional name (Just x) = (name, x)
diff --git a/src/System/Daemon.hs b/src/System/Daemon.hs
deleted file mode 100644
index 4e6732a..0000000
--- a/src/System/Daemon.hs
+++ /dev/null
@@ -1,98 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-
-Copyright (C) 2005 John Goerzen <jgoerzen at complete.org>
-
-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 : System.Daemon
- Copyright : Copyright (C) 2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable to platforms with POSIX process\/signal tools
-
-Tools for writing daemons\/server processes
-
-Written by John Goerzen, jgoerzen\@complete.org
-
-Please note: Most of this module is not compatible with Hugs.
-
-Messages from this module are logged under @System.Daemon at . See
-'System.Log.Logger' for details.
-
-Based on background
-from <http://www.erlenstar.demon.co.uk/unix/faq_2.html#SEC16> and
-<http://www.haskell.org/hawiki/HaskellUnixDaemon>.
-
-This module is not available on Windows.
--}
-
-module System.Daemon (
-
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
- detachDaemon
-#endif
- )
- where
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-
-import System.Posix.Process
-import System.Posix.IO
-import System.Directory
-import System.Log.Logger
-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
-background, handling it with standard Unix deamon semantics.
-
-After running this, please note the following side-effects:
-
- * The PID of the running process will change
-
- * stdin, stdout, and stderr will not work (they'll be set to
- \/dev\/null)
-
- * CWD will be changed to \/
-
-I /highly/ suggest running this function before starting any threads.
-
-Note that this is not intended for a daemon invoked from inetd(1).
--}
-detachDaemon :: IO ()
-detachDaemon = trap $
- do forkProcess child1
- exitImmediately ExitSuccess
-
-child1 :: IO ()
-child1 = trap $
- do createSession
- forkProcess child2
- exitImmediately ExitSuccess
-
-child2 :: IO ()
-child2 = trap $
- do setCurrentDirectory "/"
- mapM_ closeFd [stdInput, stdOutput, stdError]
- 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
deleted file mode 100644
index b018bae..0000000
--- a/src/System/Debian.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-{- arch-tag: Debian Package utilities main file
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-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 : System.Debian
- Copyright : Copyright (C) 2004 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-This module provides various helpful utilities for dealing with Debian
-files and programs.
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module System.Debian (-- * Control or Similar File Utilities
- ControlFile,
- -- * Version Number Utilities
- DebVersion, compareDebVersion, checkDebVersion
- )
- where
-
-import System.Cmd
-import System.IO.Unsafe
-import System.Exit
-
-{- | The type representing the contents of a Debian control file,
-or any control-like file (such as the output from apt-cache show, etc.) -}
-type ControlFile = [(String, String)]
-
-----------------------------------------------------------------------
--- VERSION NUMBERS
-----------------------------------------------------------------------
-
-{- | The type representing a Debian version number. This type is an instance
-of 'Prelude.Ord', but you can also use 'compareDebVersion' if you prefer. -}
-data DebVersion = DebVersion String
- deriving (Eq)
-instance Ord DebVersion where
- compare (DebVersion v1) (DebVersion v2) =
- {- This is OK since compareDebVersion should always be the same. -}
- unsafePerformIO $ compareDebVersion v1 v2
-
-{- | Compare the versions of two packages. -}
-compareDebVersion :: String -> String -> IO Ordering
-compareDebVersion v1 v2 =
- let runit op = checkDebVersion v1 op v2
- in do islt <- runit "lt"
- if islt
- then return LT
- else do isgt <- runit "gt"
- if isgt
- then return GT
- else return EQ
-
-checkDebVersion :: String -- ^ Version 1
- -> String -- ^ Operator
- -> String -- ^ Version 2
- -> IO Bool
-checkDebVersion v1 op v2 =
- do ec <- rawSystem "dpkg" ["--compare-versions", v1, op, v2]
- case ec of
- ExitSuccess -> return True
- ExitFailure _ -> return False
diff --git a/src/System/Debian/ControlParser.hs b/src/System/Debian/ControlParser.hs
deleted file mode 100644
index 596f4e9..0000000
--- a/src/System/Debian/ControlParser.hs
+++ /dev/null
@@ -1,98 +0,0 @@
-{- arch-tag: Parser for Debian control file
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-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 : System.Debian.ControlParser
- Copyright : Copyright (C) 2004 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-This module provides various helpful utilities for dealing with Debian
-files and programs.
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module System.Debian.ControlParser(control, depPart)
- where
-
-import Text.ParserCombinators.Parsec
-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 )
-
-entry :: GenParser Char st (String, String)
-entry = do key <- many1 (noneOf ":\r\n")
- char ':'
- val <- many (noneOf "\r\n")
- eol
- exts <- many extline
- return (key, unlines ([val] ++ exts))
-
-{- | Main parser for the control file -}
-control :: CharParser a [(String, String)]
-control = do many header
- retval <- many entry
- return retval
-
-headerPGP, blankLine, header, headerHash :: GenParser Char st ()
-headerPGP = do string "-----BEGIN PGP"
- manyTill (noneOf "\r\n") eol
- return ()
-blankLine = do many (oneOf " \t")
- eol
- return ()
-headerHash = do string "Hash: "
- manyTill (noneOf "\r\n") eol
- return ()
-header = (try headerPGP) <|> (try blankLine) <|> (try headerHash)
-
-{- | Dependency parser.
-
-Returns (package name, Maybe version, arch list)
-
-version is (operator, operand) -}
-depPart :: CharParser a (String, (Maybe (String, String)), [String])
-depPart = do packagename <- many1 (noneOf " (")
- many (char ' ')
- version <- (do char '('
- op <- many1 (oneOf "<>=")
- many (char ' ')
- vers <- many1 (noneOf ") ")
- many (char ' ')
- char ')'
- return $ Just (op, vers)
- ) <|> return Nothing
- many (char ' ')
- archs <- (do char '['
- t <- many1 (noneOf "]")
- many (char ' ')
- char ']'
- return (split " " t)
- ) <|> return []
- return (packagename, version, archs)
diff --git a/src/System/FileArchive/GZip.hs b/src/System/FileArchive/GZip.hs
deleted file mode 100644
index bfd2b05..0000000
--- a/src/System/FileArchive/GZip.hs
+++ /dev/null
@@ -1,296 +0,0 @@
-{- arch-tag: GZip file support in Haskell
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-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 : System.FileArchive.GZip
- Copyright : Copyright (C) 2004 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-GZip file decompression
-
-Copyright (c) 2004 John Goerzen, jgoerzen\@complete.org
-
-The GZip format is described in RFC1952.
--}
-module System.FileArchive.GZip (
- -- * GZip Files
- -- $gzipfiles
-
- -- * Types
- Header(..), Section, GZipError(..),
- Footer(..),
- -- * Whole-File Processing
- decompress,
- hDecompress,
- read_sections,
- -- * Section Processing
- read_header,
- read_section
- )
- where
-
-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
- | UnknownMethod -- ^ Compressed with something other than method 8 (deflate)
- | UnknownError String -- ^ Other problem arose
- deriving (Eq, Show)
-
-instance Error GZipError where
- noMsg = UnknownError ""
- strMsg = UnknownError
-
--- | First two bytes of file
-magic :: String
-magic = "\x1f\x8b"
-
--- | Flags
-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. -}
-data Header = Header {
- method :: Int, -- ^ Compression method. Only 8 is defined at present.
- flags :: Int,
- extra :: Maybe String,
- filename :: Maybe String,
- comment :: Maybe String,
- mtime :: Word32, -- ^ Modification time of the original file
- xfl :: Int, -- ^ Extra flags
- os :: Int -- ^ Creating operating system
- } deriving (Eq, Show)
-
-{- | Stored on-disk at the end of each section. -}
-data Footer = Footer {
- size :: Word32, -- ^ The size of the original, decompressed data
- crc32 :: Word32, -- ^ The stored GZip CRC-32 of the original, decompressed data
- crc32valid :: Bool -- ^ Whether or not the stored CRC-32 matches the calculated CRC-32 of the data
- }
-
-{- | A section represents a compressed component in a GZip file.
-Every GZip file has at least one. -}
-type Section = (Header, String, Footer)
-
-split1 :: String -> (Char, String)
-split1 s = (head s, tail s)
-
-{- | Read a GZip file, decompressing all sections found.
-
-Writes the decompressed data stream to the given output handle.
-
-Returns Nothing if the action was successful, or Just GZipError if there
-was a problem. If there was a problem, the data written to the output
-handle should be discarded.
--}
-
-hDecompress :: Handle -- ^ Input handle
- -> Handle -- ^ Output handle
- -> IO (Maybe GZipError)
-hDecompress infd outfd =
- do inc <- hGetContents infd
- let (outstr, err) = decompress inc
- hPutStr outfd outstr
- return err
-
-{- | Read a GZip file, decompressing all sections that are found.
-
-Returns a decompresed data stream and Nothing, or an unreliable string
-and Just (error). If you get anything other than Nothing, the String
-returned should be discarded.
--}
-decompress :: String -> (String, Maybe GZipError)
-{-
-decompress s =
- do x <- read_header s
- let rem = snd x
- return $ inflate_string rem
--}
-decompress s =
- let procs :: [Section] -> (String, Bool)
- procs [] = ([], True)
- procs ((_, content, foot):xs) =
- let (nexth, nextb) = procs xs in
- (content ++ nexth, (crc32valid foot) && nextb)
- in case read_sections s of
- Left x -> ("", Just x)
- Right x -> let (decomp, iscrcok) = procs x
- in (decomp, if iscrcok then Nothing else Just CRCError)
-
-{-
-decompress s = do x <- read_sections s
- return $ concatMap (\(_, x, _) -> x) x
--}
-
--- | Read all sections.
-read_sections :: String -> Either GZipError [Section]
-read_sections [] = Right []
-read_sections s =
- do x <- read_section s
- case x of
- (sect, remain) ->
- do next <- read_sections remain
- return $ sect : next
-
-parseword :: String -> Word32
-parseword s = fromBytes $ map (fromIntegral . ord) $ reverse s
-
--- | Read one section, returning (ThisSection, Remainder)
-read_section :: String -> Either GZipError (Section, String)
-read_section s =
- do x <- read_header s
- let headerrem = snd x
- 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 == crc})
- ,rem2)
-
--- | Read the file's compressed data, returning
--- (Decompressed, Calculated CRC32, Remainder)
-read_data :: String -> (String, Word32, String)
-read_data x =
- let (decompressed1, remainder) = inflate_string_remainder x
- (decompressed, crc32) = read_data_internal decompressed1 0
- in
- (decompressed, crc32, remainder)
- where
- 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
- (y : fst n, snd n)
-
-
-
-{- | Read the GZip header. Return (Header, Remainder).
--}
-read_header :: String -> Either GZipError (Header, String)
-read_header s =
- let ok = Right "ok" in
- do let (mag, rem) = splitAt 2 s
- if mag /= magic
- then throwError NotGZIPFile
- else ok
- let (method, rem2) = split1 rem
- if (ord(method) /= 8)
- then throwError UnknownMethod
- else ok
- let (flag_S, rem3) = split1 rem2
- let flag = ord flag_S
- let (mtimea, rem3a) = splitAt 4 rem3
- let mtime = parseword mtimea
- let (xfla, rem3b) = split1 rem3a
- let xfl = ord xfla
- let (osa, _) = split1 rem3b
- let os = ord osa
- -- skip modtime (4), extraflag (1), and os (1)
- let rem4 = drop 6 rem3
-
- let (extra, rem5) =
- if (flag .&. fFEXTRA /= 0)
- -- Skip past the extra field if we have it.
- 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) =
- if (flag .&. fFNAME /= 0)
- -- Skip past the null-terminated filename
- then let fn = takeWhile (/= '\x00') rem5
- in (Just fn, drop ((length fn) + 1) rem5)
- else (Nothing, rem5)
-
- let (comment, rem7) =
- if (flag .&. fFCOMMENT /= 0)
- -- Skip past the null-terminated comment
- 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,
- filename = filename,
- comment = comment,
- mtime = mtime,
- xfl = xfl,
- os = os}, rem8)
-
-----------------------------------------------------------------------
--- Documentation
-----------------------------------------------------------------------
-
-{- $gzipfiles
-
-GZip files contain one or more 'Section's. Each 'Section', on disk, begins
-with a GZip 'Header', then stores the compressed data itself, and finally
-stores a GZip 'Footer'.
-
-The 'Header' identifies the file as a GZip file, records the original
-modification date and time, and, in some cases, also records the original
-filename and comments.
-
-The 'Footer' contains a GZip CRC32 checksum over the decompressed data as
-well as a 32-bit length of the decompressed data. The module
-'Data.Hash.CRC32.GZip' is used to validate stored CRC32 values.
-
-The vast majority of GZip files contain only one 'Section'. Standard tools
-that work with GZip files create single-section files by default.
-
-Multi-section files can be created by simply concatenating two existing
-GZip files together. The standard gunzip and zcat tools will simply
-concatenate the decompressed data when reading these files back. The
-'decompress' function in this module will do the same.
-
-When reading data from this module, please use caution regarding how you access
-it. For instance, if you are wanting to write the decompressed stream
-to disk and validate its CRC32 value, you could use the 'decompress'
-function. However, you should process the entire stream before you check
-the value of the Bool it returns. Otherwise, you will force Haskell to buffer
-the entire file in memory just so it can check the CRC32.
--}
diff --git a/src/System/IO/Binary.hs b/src/System/IO/Binary.hs
deleted file mode 100644
index e986110..0000000
--- a/src/System/IO/Binary.hs
+++ /dev/null
@@ -1,319 +0,0 @@
-{- arch-tag: I/O utilities, binary tools
-Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
-
-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 : System.IO.Binary
- Copyright : Copyright (C) 2004-2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- 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
-or lists of Word8. The BinaryConvertible class provides this abstraction.
-
-Wherever you see HVIO, you can transparently substite a regular Handle.
-This module can work with any HVIO object, however. See
-"System.IO.HVIO" for more details.
-
-Versions of MissingH prior 0.11.6 lacked the 'BinaryConvertible' class
-and worked only with Strings and Handles.
-
-Important note: /binary functions are not supported in all Haskell
-implementations/. Do not import or use this module unless you know you
-are using an implementation that supports them. At this time, here
-is the support status:
-
- * GHC 6.2 and above: yes
-
- * GHC 6.x, earlier versions: unknown
-
- * GHC 5.x: no
-
- * nhc98: no
-
- * Hugs: partial (maybe complete; needs more testing)
-
-Non-binary functions may be found in "System.IO".
-
-See also: "System.IO.BlockIO"
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module System.IO.Binary(
- -- * Support for different types of blocks
- BinaryConvertible(..),
- -- * Entire File\/Handle Utilities
- -- ** Opened Handle Data Copying
- hBlockCopy, blockCopy,
- -- ** Disk File Data Copying
- copyFileBlocksToFile,
- -- * Binary Single-Block I\/O
- hPutBufStr, putBufStr, hGetBufStr, getBufStr,
- hFullGetBufStr, fullGetBufStr,
- -- * Binary Multi-Block I\/O
- hGetBlocks, getBlocks, hFullGetBlocks, fullGetBlocks,
- -- * Lazy Interaction
- readBinaryFile, writeBinaryFile,
- -- ** Binary Block-based
- hBlockInteract, blockInteract,
- hFullBlockInteract, fullBlockInteract
- ) where
-
-import Data.Word (Word8())
-import Foreign.C.String (peekCStringLen, withCString)
-import Foreign.C.Types (CChar())
-import Foreign.ForeignPtr
-import Foreign.Marshal.Array (peekArray, withArray)
-import Foreign.Ptr
-import System.IO
-import System.IO.HVFS
-import System.IO.HVIO
-import System.IO.Unsafe (unsafeInterleaveIO)
-
-{- | Provides support for handling binary blocks with convenient
-types.
-
-This module provides implementations for Strings and for [Word8] (lists of
-Word8s). -}
-class (Eq a, Show a) => BinaryConvertible a where
- toBuf :: [a] -> (Ptr CChar -> IO c) -> IO c
- fromBuf :: Int -> (Ptr CChar -> IO Int) -> IO [a]
-
-instance BinaryConvertible Char where
- toBuf = withCString
- fromBuf len func =
- do fbuf <- mallocForeignPtrArray (len + 1)
- withForeignPtr fbuf handler
- where handler ptr =
- do bytesread <- func ptr
- peekCStringLen (ptr, bytesread)
-
-instance BinaryConvertible Word8 where
- toBuf hslist func = withArray hslist (\ptr -> func (castPtr ptr))
- fromBuf len func =
- do (fbuf::(ForeignPtr Word8)) <- mallocForeignPtrArray (len + 1)
- withForeignPtr fbuf handler
- where handler ptr =
- do bytesread <- func (castPtr ptr)
- peekArray bytesread ptr
-
-
--- **************************************************
--- 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 at . 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.
-
-If it helps, you can thing of this function as being of type
- at Handle -> String -> IO ()@ -}
-hPutBufStr :: (HVIO a, BinaryConvertible b) => a -> [b] -> IO ()
-hPutBufStr f s = toBuf s (\cs -> vPutBuf f cs (length s))
-
--- | An alias for 'hPutBufStr' 'stdout'
-putBufStr :: (BinaryConvertible b) => [b] -> IO ()
-putBufStr = hPutBufStr stdout
-
-{- | Acts a wrapper around the standard function 'System.IO.hGetBuf',
-this function returns a standard Haskell String (or [Word8]) instead of
-modifying
-a 'Ptr a' buffer. The length is the maximum length to read and the
-semantice are the same as with 'hGetBuf'; namely, the empty string
-is returned with EOF is reached, and any given read may read fewer
-bytes than the given length.
-
-(Actually, it's a wrapper around 'System.IO.HVIO.vGetBuf') -}
-hGetBufStr :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
-hGetBufStr f count = fromBuf count (\buf -> vGetBuf f buf count)
-
--- | An alias for 'hGetBufStr' 'stdin'
-getBufStr :: (BinaryConvertible b) => Int -> IO [b]
-getBufStr = hGetBufStr stdin
-
-{- | 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 _ 0 = return []
-hFullGetBufStr f count = do
- thisstr <- hGetBufStr f count
- if thisstr == []
- then return []
- else do
- remainder <- hFullGetBufStr f (count - (length thisstr))
- return (thisstr ++ remainder)
-
--- | An alias for 'hFullGetBufStr' 'stdin'
-fullGetBufStr :: BinaryConvertible b => Int -> IO [b]
-fullGetBufStr = hFullGetBufStr stdin
-
-{- | Writes the list of blocks to the given file handle -- a wrapper around
-'hPutBufStr'.
-
-Think of this function as:
-
->Handle -> [String] -> IO ()
-
-(You can use it that way) -}
-hPutBlocks :: (HVIO a, BinaryConvertible b) => a -> [[b]] -> IO ()
-hPutBlocks _ [] = return ()
-hPutBlocks h (x:xs) = do
- hPutBufStr h x
- hPutBlocks h xs
-
-{- | An alias for 'hPutBlocks' 'stdout'
-putBlocks :: (BinaryConvertible b) => [[b]] -> IO ()
-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.
-The list simply ends at EOF. -}
-hGetBlocks :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
-hGetBlocks = hGetBlocksUtil hGetBufStr
-
--- | An alias for 'hGetBlocks' 'stdin'
-getBlocks :: BinaryConvertible b => Int -> IO [[b]]
-getBlocks = hGetBlocks stdin
-
-{- | Same as 'hGetBlocks', but using 'hFullGetBufStr' underneath. -}
-hFullGetBlocks :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
-hFullGetBlocks = hGetBlocksUtil hFullGetBufStr
-
--- | An alias for 'hFullGetBlocks' 'stdin'
-fullGetBlocks :: BinaryConvertible b => Int -> IO [[b]]
-fullGetBlocks = hFullGetBlocks stdin
-
-hGetBlocksUtil :: (HVIO a, BinaryConvertible b) => (a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
-hGetBlocksUtil readfunc h count =
- 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
-out. Take a look at 'hBlockCopy' for an example. The integer argument
-is the size of input binary blocks. This function uses 'hGetBlocks'
-internally.
--}
-hBlockInteract :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
- Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
-hBlockInteract = hBlockInteractUtil hGetBlocks
-
--- | An alias for 'hBlockInteract' over 'stdin' and 'stdout'
-blockInteract :: (BinaryConvertible b, BinaryConvertible c) => Int -> ([[b]] -> [[c]]) -> IO ()
-blockInteract x = hBlockInteract x stdin stdout
-
-{- | Same as 'hBlockInteract', but uses 'hFullGetBlocks' instead of
-'hGetBlocks' internally. -}
-hFullBlockInteract :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
- Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
-hFullBlockInteract = hBlockInteractUtil hFullGetBlocks
-
--- | An alias for 'hFullBlockInteract' over 'stdin' and 'stdout'
-fullBlockInteract :: (BinaryConvertible b, BinaryConvertible c) =>
- Int -> ([[b]] -> [[c]]) -> IO ()
-fullBlockInteract x = hFullBlockInteract x stdin stdout
-
-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 =
- do
- blocks <- blockreader hin blocksize
- 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
-beautiful implementation:
-
-> hBlockCopy bs hin hout = hBlockInteract bs hin hout id
-
-('id' is the built-in Haskell function that just returns whatever is given
-to it)
-
-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 =
- do (fbuf::ForeignPtr CChar) <- mallocForeignPtrArray (bs + 1)
- withForeignPtr fbuf handler
- where handler ptr =
- do bytesread <- vGetBuf hin ptr bs
- if bytesread > 0
- then do vPutBuf hout ptr bytesread
- handler ptr
- else return ()
-
-{- | Copies from 'stdin' to 'stdout' using binary blocks of the given size.
-An alias for 'hBlockCopy' over 'stdin' and 'stdout'
--}
-blockCopy :: Int -> IO ()
-blockCopy bs = hBlockCopy bs stdin stdout
-
-{- | Copies one filename to another in binary mode.
-
-Please note that the Unix permission bits on the output file cannot
-be set due to a limitation of the Haskell 'System.IO.openBinaryFile'
-function. Therefore, you may need to adjust those bits after the copy
-yourself.
-
-This function is implemented using 'hBlockCopy' internally. -}
-copyFileBlocksToFile :: Int -> FilePath -> FilePath -> IO ()
-copyFileBlocksToFile bs infn outfn = do
- hin <- openBinaryFile infn ReadMode
- hout <- openBinaryFile outfn WriteMode
- hBlockCopy bs hin hout
- hClose hin
- hClose hout
- return ()
-
-{- | Like the built-in 'readFile', but opens the file in binary instead
-of text mode. -}
-readBinaryFile :: FilePath -> IO String
-readBinaryFile = vReadBinaryFile SystemFS
-
-{- | Same as 'readBinaryFile', but works with HVFS objects. -}
-vReadBinaryFile :: (HVFSOpenable a) => a -> FilePath -> IO String
-vReadBinaryFile fs fp =
- vOpenBinaryFile fs fp ReadMode >>= (\(HVFSOpenEncap h) -> vGetContents h)
-
-{- | Like the built-in 'writeFile', but opens the file in binary instead
-of text mode. -}
-writeBinaryFile :: FilePath -> String -> IO ()
-writeBinaryFile = vWriteBinaryFile SystemFS
-
-{- | Like 'writeBinaryFile', but works on HVFS objects. -}
-vWriteBinaryFile :: (HVFSOpenable a) => a -> FilePath -> String -> IO ()
-vWriteBinaryFile fs name str =
- do h <- vOpenBinaryFile fs name WriteMode
- case h of
- HVFSOpenEncap x -> do vPutStr x str
- vClose x
diff --git a/src/System/IO/HVFS.hs b/src/System/IO/HVFS.hs
deleted file mode 100644
index 0df96dc..0000000
--- a/src/System/IO/HVFS.hs
+++ /dev/null
@@ -1,331 +0,0 @@
-{-# LANGUAGE CPP, TypeSynonymInstances #-}
-{- arch-tag: HVFS main file
-Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
-
-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 : System.IO.HVFS
- Copyright : Copyright (C) 2004-2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Haskell Virtual FS -- generic support for real or virtual filesystem in Haskell
-
-Copyright (c) 2004-2005 John Goerzen, jgoerzen\@complete.org
-
-The idea of this module is to provide virtualization of filesystem calls.
-In addition to the \"real\" system filesystem, you can also provide access
-to other, virtual, filesystems using the same set of calls. Examples of
-such virtual filesystems might include a remote FTP server, WebDAV server,
-a local Hashtable, a ConfigParser object, or any other data structure
-you can represent as a tree of named nodes containing strings.
-
-Each 'HVFS' function takes a 'HVFS' \"handle\" ('HVFS' instance) as its
-first parameter. If you wish to operate on the standard system filesystem,
-you can just use 'SystemFS'.
-
-The "MissingH.HVFS.IO.InstanceHelpers" module contains some code to help
-you make your own HVFS instances.
-
-The 'HVFSOpenable' class works together with the "System.IO.HVIO" module
-to provide a complete virtual filesystem and I\/O model that allows you
-to open up virtual filesystem files and act upon them in a manner similar
-to standard Handles.
--}
-
-module System.IO.HVFS(-- * Implementation Classes \/ Types
- HVFS(..), HVFSStat(..),
- HVFSOpenable(..), HVFSOpenEncap(..),HVFSStatEncap(..),
- withStat, withOpen,
- SystemFS(..),
- -- * Re-exported types from other modules
- FilePath, DeviceID, FileID, FileMode, LinkCount,
- UserID, GroupID, FileOffset, EpochTime,
- IOMode
- )
-where
-
-import System.IO.HVIO
-import System.Time.Utils
-import System.IO
-import System.IO.Error
-import System.IO.PlafCompat
-import System.Posix.Types
-import System.Time
-import System.Directory
-
-{- | Encapsulate a 'HVFSStat' result. This is required due to Haskell
-typing restrictions. You can get at it with:
-
-> case encap of
-> HVFSStatEncap x -> -- now use x
--}
-data HVFSStatEncap = forall a. HVFSStat a => HVFSStatEncap a
-
-{- | Convenience function for working with stat -- takes a stat result
-and a function that uses it, and returns the result.
-
-Here is an example from the HVFS source:
-
-> vGetModificationTime fs fp =
-> do s <- vGetFileStatus fs fp
-> return $ epochToClockTime (withStat s vModificationTime)
-
-See 'System.Time.Utils.epochToClockTime' for more information.
--}
-withStat :: forall b. HVFSStatEncap -> (forall a. HVFSStat a => a -> b) -> b
-withStat s f =
- case s of
- HVFSStatEncap x -> f x
-
-{- | Similar to 'HVFSStatEncap', but for 'vOpen' result.
--}
-data HVFSOpenEncap = forall a. HVIO a => HVFSOpenEncap a
-
-{- | Similar to 'withStat', but for the 'vOpen' result. -}
-withOpen :: forall b. HVFSOpenEncap -> (forall a. HVIO a => a -> b) -> b
-withOpen s f =
- case s of
- HVFSOpenEncap x -> f x
-
-{- | Evaluating types of files and information about them.
-
-This corresponds to the System.Posix.Types.FileStatus type, and indeed,
-that is one instance of this class.
-
-Inplementators must, at minimum, implement 'vIsDirectory' and
-'vIsRegularFile'.
-
-Default implementations of everything else are provided, returning
-reasonable values.
-
-A default implementation of this is not currently present on Windows.
--}
-
-class (Show a) => HVFSStat a where
- vDeviceID :: a -> DeviceID
- vFileID :: a -> FileID
-
- {- | Refers to file permissions, NOT the st_mode field from stat(2) -}
- vFileMode :: a -> FileMode
-
- vLinkCount :: a -> LinkCount
- vFileOwner :: a -> UserID
- vFileGroup :: a -> GroupID
-
- vSpecialDeviceID :: a -> DeviceID
- vFileSize :: a -> FileOffset
- vAccessTime :: a -> EpochTime
- vModificationTime :: a -> EpochTime
- vStatusChangeTime :: a -> EpochTime
- vIsBlockDevice :: a -> Bool
- vIsCharacterDevice :: a -> Bool
- vIsNamedPipe :: a -> Bool
- vIsRegularFile :: a -> Bool
- vIsDirectory :: a -> Bool
- vIsSymbolicLink :: a -> Bool
- vIsSocket :: a -> Bool
-
- vDeviceID _ = 0
- vFileID _ = 0
- vFileMode x = if vIsDirectory x then 0x755 else 0o0644
- vLinkCount _ = 1
- vFileOwner _ = 0
- vFileGroup _ = 0
- vSpecialDeviceID _ = 0
- vFileSize _ = 0
- vAccessTime _ = 0
- vModificationTime _ = 0
- vStatusChangeTime _ = 0
- vIsBlockDevice _ = False
- vIsCharacterDevice _ = False
- vIsNamedPipe _ = False
- vIsSymbolicLink _ = False
- vIsSocket _ = False
-
-{- | The main HVFS class.
-
-Default implementations of these functions are provided:
-
- * 'vGetModificationTime' -- implemented in terms of 'vGetFileStatus'
-
- * 'vRaiseError'
-
- * 'vDoesFileExist' -- implemented in terms of 'vGetFileStatus'
-
- * 'vDoesDirectoryExist' -- implemented in terms of 'vGetFileStatus'
-
- * 'vDoesExist' -- implemented in terms of 'vGetSymbolicLinkStatus'
-
- * 'vGetSymbolicLinkStatus' -- set to call 'vGetFileStatus'.
-
-Default implementations of all other functions
-will generate an isIllegalOperation error, since they are assumed to be
-un-implemented.
-
-You should always provide at least a 'vGetFileStatus' call, and almost
-certainly several of the others.
-
-Most of these functions correspond to functions in System.Directory or
-System.Posix.Files. Please see detailed documentation on them there.
- -}
-class (Show a) => HVFS a where
- vGetCurrentDirectory :: a -> IO FilePath
- vSetCurrentDirectory :: a -> FilePath -> IO ()
- vGetDirectoryContents :: a -> FilePath -> IO [FilePath]
- vDoesFileExist :: a -> FilePath -> IO Bool
- vDoesDirectoryExist :: a -> FilePath -> IO Bool
- {- | True if the file exists, regardless of what type it is.
- This is even True if the given path is a broken symlink. -}
- vDoesExist :: a -> FilePath -> IO Bool
- vCreateDirectory :: a -> FilePath -> IO ()
- vRemoveDirectory :: a -> FilePath -> IO ()
- vRenameDirectory :: a -> FilePath -> FilePath -> IO ()
- vRemoveFile :: a -> FilePath -> IO ()
- vRenameFile :: a -> FilePath -> FilePath -> IO ()
- vGetFileStatus :: a -> FilePath -> IO HVFSStatEncap
- vGetSymbolicLinkStatus :: a -> FilePath -> IO HVFSStatEncap
- vGetModificationTime :: a -> FilePath -> IO ClockTime
- {- | Raise an error relating to actions on this class. -}
- vRaiseError :: a -> IOErrorType -> String -> Maybe FilePath -> IO c
- vCreateSymbolicLink :: a -> FilePath -> FilePath -> IO ()
- vReadSymbolicLink :: a -> FilePath -> IO FilePath
- vCreateLink :: a -> FilePath -> FilePath -> IO ()
-
- vGetModificationTime fs fp =
- do s <- vGetFileStatus fs fp
- return $ epochToClockTime (withStat s vModificationTime)
- vRaiseError _ et desc mfp =
- ioError $ mkIOError et desc Nothing mfp
-
- vGetCurrentDirectory fs = eh fs "vGetCurrentDirectory"
- vSetCurrentDirectory fs _ = eh fs "vSetCurrentDirectory"
- vGetDirectoryContents fs _ = eh fs "vGetDirectoryContents"
- vDoesFileExist fs fp =
- catch (do s <- vGetFileStatus fs fp
- return $ withStat s vIsRegularFile
- ) (\_ -> return False)
- vDoesDirectoryExist fs fp =
- catch (do s <- vGetFileStatus fs fp
- return $ withStat s vIsDirectory
- ) (\_ -> return False)
- vDoesExist fs fp =
- catch (do s <- vGetSymbolicLinkStatus fs fp
- return True
- ) (\_ -> return False)
- vCreateDirectory fs _ = eh fs "vCreateDirectory"
- vRemoveDirectory fs _ = eh fs "vRemoveDirectory"
- vRemoveFile fs _ = eh fs "vRemoveFile"
- vRenameFile fs _ _ = eh fs "vRenameFile"
- vRenameDirectory fs _ _ = eh fs "vRenameDirectory"
- vCreateSymbolicLink fs _ _ = eh fs "vCreateSymbolicLink"
- vReadSymbolicLink fs _ = eh fs "vReadSymbolicLink"
- vCreateLink fs _ _ = eh fs "vCreateLink"
- vGetSymbolicLinkStatus = vGetFileStatus
-
--- | Error handler helper
-eh :: HVFS a => a -> String -> IO c
-eh fs desc = vRaiseError fs illegalOperationErrorType
- (desc ++ " is not implemented in this HVFS class") Nothing
-
-{- | Types that can open a HVIO object should be instances of this class.
-You need only implement 'vOpen'. -}
-
-class HVFS a => HVFSOpenable a where
- vOpen :: a -> FilePath -> IOMode -> IO HVFSOpenEncap
- vReadFile :: a -> FilePath -> IO String
- vWriteFile :: a -> FilePath -> String -> IO ()
- vOpenBinaryFile :: a -> FilePath -> IOMode -> IO HVFSOpenEncap
-
- vReadFile h fp =
- do oe <- vOpen h fp ReadMode
- withOpen oe (\fh -> vGetContents fh)
-
- vWriteFile h fp s =
- do oe <- vOpen h fp WriteMode
- withOpen oe (\fh -> do vPutStr fh s
- vClose fh)
-
- -- | Open a file in binary mode.
- vOpenBinaryFile = vOpen
-
-instance Show FileStatus where
- show _ = "<FileStatus>"
-
-----------------------------------------------------------------------
--- Standard implementations
-----------------------------------------------------------------------
-instance HVFSStat FileStatus where
- vDeviceID = deviceID
- vFileID = fileID
- vFileMode = fileMode
- vLinkCount = linkCount
- vFileOwner = fileOwner
- vFileGroup = fileGroup
- vSpecialDeviceID = specialDeviceID
- vFileSize = fileSize
- vAccessTime = accessTime
- vModificationTime = modificationTime
- vStatusChangeTime = statusChangeTime
- vIsBlockDevice = isBlockDevice
- vIsCharacterDevice = isCharacterDevice
- vIsNamedPipe = isNamedPipe
- vIsRegularFile = isRegularFile
- vIsDirectory = isDirectory
- vIsSymbolicLink = isSymbolicLink
- vIsSocket = isSocket
-
-data SystemFS = SystemFS
- deriving (Eq, Show)
-
-instance HVFS SystemFS where
- vGetCurrentDirectory _ = getCurrentDirectory
- vSetCurrentDirectory _ = setCurrentDirectory
- vGetDirectoryContents _ = getDirectoryContents
- vDoesFileExist _ = doesFileExist
- vDoesDirectoryExist _ = doesDirectoryExist
- vCreateDirectory _ = createDirectory
- vRemoveDirectory _ = removeDirectory
- vRenameDirectory _ = renameDirectory
- vRemoveFile _ = removeFile
- vRenameFile _ = renameFile
- vGetFileStatus _ fp = getFileStatus fp >>= return . HVFSStatEncap
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
- vGetSymbolicLinkStatus _ fp = getSymbolicLinkStatus fp >>= return . HVFSStatEncap
-#else
- -- No symlinks on Windows; just get the file status directly
- vGetSymbolicLinkStatus = vGetFileStatus
-#endif
-
- vGetModificationTime _ = getModificationTime
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
- vCreateSymbolicLink _ = createSymbolicLink
- vReadSymbolicLink _ = readSymbolicLink
- vCreateLink _ = createLink
-#else
- vCreateSymbolicLink _ _ _ = fail "Symbolic link creation not supported by Windows"
- vReadSymbolicLink _ _ = fail "Symbolic link reading not supported by Widnows"
- vCreateLink _ _ _ = fail "Hard link creation not supported by Windows"
-#endif
-
-instance HVFSOpenable SystemFS where
- vOpen _ fp iomode = openFile fp iomode >>= return . HVFSOpenEncap
- vOpenBinaryFile _ fp iomode = openBinaryFile fp iomode >>= return . HVFSOpenEncap
-
diff --git a/src/System/IO/HVFS/Combinators.hs b/src/System/IO/HVFS/Combinators.hs
deleted file mode 100644
index 64877b6..0000000
--- a/src/System/IO/HVFS/Combinators.hs
+++ /dev/null
@@ -1,183 +0,0 @@
-{-# LANGUAGE CPP #-}
-{- arch-tag: HVFS Combinators
-Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
-
-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 : System.IO.HVFS.Combinators
- Copyright : Copyright (C) 2004-2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Support for combining different HVFS modules together
-
-Copyright (c) 2004-2005 John Goerzen, jgoerzen\@complete.org
-
--}
-
-module System.IO.HVFS.Combinators ( -- * Restrictions
- HVFSReadOnly(..),
- HVFSChroot, newHVFSChroot)
- where
-
-import System.IO
-import System.IO.Error
-import System.IO.HVFS
-import System.IO.HVFS.InstanceHelpers (getFullPath)
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-import System.Posix.Files -- This actually needed? -Wall doesn't seem to think
- -- so, but I'm not sure...
-#endif
-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.
-
-No constructor is required; just say @HVFSReadOnly fs@ to make a
-new read-only wrapper around the 'HVFS' instance @fs at .
--}
-data HVFS a => HVFSReadOnly a = HVFSReadOnly a
- deriving (Eq, Show)
-withro :: HVFS a => (a -> b) -> HVFSReadOnly a -> b
-withro f (HVFSReadOnly x) = f x
-
-roerror :: (HVFS a) => HVFSReadOnly a -> IO c
-roerror h =
- let err x = vRaiseError x permissionErrorType "Read-only virtual filesystem"
- Nothing
- in withro err h
-
-instance HVFS a => HVFS (HVFSReadOnly a) where
- vGetCurrentDirectory = withro vGetCurrentDirectory
- vSetCurrentDirectory = withro vSetCurrentDirectory
- vGetDirectoryContents = withro vGetDirectoryContents
- vDoesFileExist = withro vDoesFileExist
- vDoesDirectoryExist = withro vDoesDirectoryExist
- vCreateDirectory h _ = roerror h
- vRemoveDirectory h _ = roerror h
- vRenameDirectory h _ _ = roerror h
- vRenameFile h _ _ = roerror h
- vGetFileStatus = withro vGetFileStatus
- vGetSymbolicLinkStatus = withro vGetSymbolicLinkStatus
- vGetModificationTime = withro vGetModificationTime
- vRaiseError = withro vRaiseError
- vCreateSymbolicLink h _ _ = roerror h
- vReadSymbolicLink = withro vReadSymbolicLink
- vCreateLink h _ _ = roerror h
-
-instance HVFSOpenable a => HVFSOpenable (HVFSReadOnly a) where
- 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
- deriving (Eq, Show)
-
-{- | Create a new 'HVFSChroot' object. -}
-newHVFSChroot :: HVFS a => a -- ^ The object to pass requests on to
- -> FilePath -- ^ The path of the directory to make root
- -> IO (HVFSChroot a) -- ^ The resulting new object
-newHVFSChroot fh fp =
- do full <- getFullPath fh fp
- isdir <- vDoesDirectoryExist fh full
- if isdir
- then do let newobj = (HVFSChroot full fh)
- vSetCurrentDirectory newobj "/"
- return newobj
- else vRaiseError fh doesNotExistErrorType
- ("Attempt to instantiate HVFSChroot over non-directory " ++ full)
- (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, fp2dch :: (HVFS t) => HVFSChroot t -> String -> IO String
-dch2fp mainh@(HVFSChroot fp h) locfp =
- do full <- case (head locfp) of
- '/' -> return (fp ++ locfp)
- _ -> do y <- getFullPath mainh locfp
- return $ fp ++ y
- case secureAbsNormPath fp full of
- Nothing -> vRaiseError h doesNotExistErrorType
- ("Trouble normalizing path in chroot")
- (Just (fp ++ "," ++ full))
- Just x -> return x
-
-{- | Convert a full path to a local (chroot) path. -}
-fp2dch (HVFSChroot fp h) locfp =
- do newpath <- case secureAbsNormPath fp locfp of
- Nothing -> vRaiseError h doesNotExistErrorType
- ("Unable to securely normalize path")
- (Just (fp ++ "/" ++ locfp))
- Just x -> return x
- if (take (length fp) newpath /= fp)
- then vRaiseError h doesNotExistErrorType
- ("Local path is not subdirectory of parent path")
- (Just newpath)
- else let newpath2 = drop (length fp) newpath
- in return $ normalise_path ("/" ++ newpath2)
-
-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
- vSetCurrentDirectory = dch2fph vSetCurrentDirectory
- vGetDirectoryContents = dch2fph vGetDirectoryContents
- vDoesFileExist = dch2fph vDoesFileExist
- vDoesDirectoryExist = dch2fph vDoesDirectoryExist
- vCreateDirectory = dch2fph vCreateDirectory
- vRemoveDirectory = dch2fph vRemoveDirectory
- vRenameDirectory fh old new = do old' <- dch2fp fh old
- new' <- dch2fp fh new
- vRenameDirectory (dch fh) old' new'
- vRemoveFile = dch2fph vRemoveFile
- vRenameFile fh old new = do old' <- dch2fp fh old
- new' <- dch2fp fh new
- vRenameFile (dch fh) old' new'
- vGetFileStatus = dch2fph vGetFileStatus
- vGetSymbolicLinkStatus = dch2fph vGetSymbolicLinkStatus
- vGetModificationTime = dch2fph vGetModificationTime
- -- vRaiseError
- vCreateSymbolicLink fh old new = do old' <- dch2fp fh old
- new' <- dch2fp fh new
- vCreateSymbolicLink (dch fh) old' new'
- vReadSymbolicLink fh fp = do result <- dch2fph vReadSymbolicLink fh fp
- fp2dch fh result
- vCreateLink fh old new = do old' <- dch2fp fh old
- new' <- dch2fp fh new
- vCreateLink (dch fh) old' new'
-
-instance HVFSOpenable a => HVFSOpenable (HVFSChroot a) where
- vOpen fh fp mode = do newfile <- dch2fp fh fp
- vOpen (dch fh) newfile mode
diff --git a/src/System/IO/HVFS/InstanceHelpers.hs b/src/System/IO/HVFS/InstanceHelpers.hs
deleted file mode 100644
index 3c7182b..0000000
--- a/src/System/IO/HVFS/InstanceHelpers.hs
+++ /dev/null
@@ -1,220 +0,0 @@
-{- arch-tag: HVFS instance helpers
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-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 : System.IO.HVFS.InstanceHelpers
- Copyright : Copyright (C) 2004 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Utilities for creating instances of the items defined in
-"System.IO.HVFS".
-
-Copyright (c) 2004 John Goerzen, jgoerzen\@complete.org
--}
-
-module System.IO.HVFS.InstanceHelpers(-- * HVFSStat objects
- SimpleStat(..),
- -- * HVFS objects & types
- -- ** MemoryVFS
- MemoryVFS,
- newMemoryVFS, newMemoryVFSRef,
- MemoryNode,
- MemoryEntry(..),
- -- * Utilities
- nice_slice, getFullPath,
- 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 System.IO.HVIO (newStreamReader)
-import System.Path (absNormPath)
-import System.Path.NameManip (slice_path)
-
-{- | A simple "System.IO.HVFS.HVFSStat"
-class that assumes that everything is either a file
-or a directory. -}
-data SimpleStat = SimpleStat {
- isFile :: Bool, -- ^ True if file, False if directory
- fileSize :: FileOffset -- ^ Set to 0 if unknown or a directory
- } deriving (Show, Eq)
-instance HVFSStat SimpleStat where
- vIsRegularFile x = isFile x
- vIsDirectory x = not (isFile x)
- vFileSize x = fileSize x
-
-----------------------------------------------------------------------
--- 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)
-
-{- | The content of a file or directory in a 'MemoryVFS'. -}
-data MemoryEntry = MemoryDirectory [MemoryNode]
- | MemoryFile String
- deriving (Eq, Show)
-
-{- | An in-memory read\/write filesystem. Think of it as a dynamically
-resizable ramdisk written in Haskell. -}
-data MemoryVFS = MemoryVFS
- { content :: IORef [MemoryNode],
- cwd :: IORef FilePath
- }
-
-instance Show MemoryVFS where
- show _ = "<MemoryVFS>"
-
--- | Create a new 'MemoryVFS' object from an existing tree.
--- An empty filesystem may be created by using @[]@ for the parameter.
-newMemoryVFS :: [MemoryNode] -> IO MemoryVFS
-newMemoryVFS s = do r <- newIORef s
- newMemoryVFSRef r
-
--- | Create a new 'MemoryVFS' object using an IORef to an
--- existing tree.
-newMemoryVFSRef :: IORef [MemoryNode] -> IO MemoryVFS
-newMemoryVFSRef r = do
- c <- newIORef "/"
- return (MemoryVFS {content = r, cwd = c})
-
-{- | Similar to 'System.Path.NameManip' but the first element
-won't be @\/@.
-
->nice_slice "/" -> []
->nice_slice "/foo/bar" -> ["foo", "bar"]
--}
-nice_slice :: String -> [String]
-nice_slice "/" = []
-nice_slice path =
- let sliced1 = slice_path path
- h = head sliced1
- t = tail sliced1
- newh = if head h == '/' then tail h else h
- sliced2 = newh : t
- in sliced2
-
-{- | Gets a full path, after investigating the cwd.
--}
-getFullPath :: HVFS a => a -> String -> IO String
-getFullPath fs path =
- do cwd <- vGetCurrentDirectory fs
- case (absNormPath cwd path) of
- Nothing -> vRaiseError fs doesNotExistErrorType
- ("Trouble normalizing path " ++ path) (Just (cwd ++ "/" ++ path))
- Just newpath -> return newpath
-
-{- | Gets the full path via 'getFullPath', then splits it via 'nice_slice'.
--}
-getFullSlice :: HVFS a => a -> String -> IO [String]
-getFullSlice fs fp =
- do newpath <- getFullPath fs fp
- return (nice_slice newpath)
-
--- | Find an element on the tree, assuming a normalized path
-findMelem :: MemoryVFS -> String -> IO MemoryEntry
-findMelem x "/" = readIORef (content x) >>= return . MemoryDirectory
-findMelem x path =
- let sliced1 = slice_path path
- h = head sliced1
- 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
- walk y [] = Right y
- -- Root directory -- return the item we have
- walk y ["/"] = Right y
- -- File but stuff: error
- 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 zs
- in do
- c <- readIORef $ content x
- case walk (MemoryDirectory c) (sliced2) of
- Left err -> vRaiseError x doesNotExistErrorType err Nothing
- Right result -> return result
-
--- | Find an element on the tree, normalizing the path first
-getMelem :: MemoryVFS -> String -> IO MemoryEntry
-getMelem x s =
- do base <- readIORef $ cwd x
- case absNormPath base s of
- Nothing -> vRaiseError x doesNotExistErrorType
- ("Trouble normalizing path " ++ s) (Just s)
- Just newpath -> findMelem x newpath
-
-instance HVFS MemoryVFS where
- vGetCurrentDirectory x = readIORef $ cwd x
- vSetCurrentDirectory x fp =
- do curpath <- vGetCurrentDirectory x
- -- Make sure new dir is valid
- newdir <- getMelem x fp
- case newdir of
- (MemoryFile _) -> vRaiseError x doesNotExistErrorType
- ("Attempt to cwd to non-directory " ++ fp)
- (Just fp)
- (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 =
- do elem <- getMelem x fp
- case elem of
- (MemoryFile y) -> return $ HVFSStatEncap $
- SimpleStat {isFile = True,
- fileSize = (genericLength y)}
- (MemoryDirectory _) -> return $ HVFSStatEncap $
- SimpleStat {isFile = False,
- fileSize = 0}
- vGetDirectoryContents x fp =
- do elem <- getMelem x fp
- case elem of
- MemoryFile _ -> vRaiseError x doesNotExistErrorType
- "Can't list contents of a file"
- (Just fp)
- MemoryDirectory c -> return $ map fst c
-
-instance HVFSOpenable MemoryVFS where
- vOpen x fp (ReadMode) =
- do elem <- getMelem x fp
- case elem of
- MemoryDirectory _ -> vRaiseError x doesNotExistErrorType
- "Can't open a directory"
- (Just fp)
- MemoryFile y -> newStreamReader y >>= return . HVFSOpenEncap
- vOpen x fp _ = vRaiseError x permissionErrorType
- "Only ReadMode is supported with MemoryVFS files"
- (Just fp)
-
diff --git a/src/System/IO/HVFS/Utils.hs b/src/System/IO/HVFS/Utils.hs
deleted file mode 100644
index 02a944a..0000000
--- a/src/System/IO/HVFS/Utils.hs
+++ /dev/null
@@ -1,158 +0,0 @@
-{-# LANGUAGE CPP #-}
-{- arch-tag: HVFS utilities main file
-Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
-
-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 : System.IO.HVFS.Utils
- Copyright : Copyright (C) 2004-2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-This module provides various helpful utilities for dealing
-filesystems.
-
-Written by John Goerzen, jgoerzen\@complete.org
-
-To operate on your system's main filesystem, just pass SystemFS as the
-first parameter to these functions.
--}
-
-module System.IO.HVFS.Utils (recurseDir,
- recurseDirStat,
- recursiveRemove,
- lsl,
- SystemFS(..)
- )
-where
-
-import System.IO.HVFS
-import System.Time.Utils
-import System.IO.PlafCompat
-import Text.Printf
-import System.Time
-import System.Locale
-import System.IO.Unsafe
-
-{- | Obtain a recursive listing of all files\/directories beneath
-the specified directory. The traversal is depth-first
-and the original
-item is always present in the returned list.
-
-If the passed value is not a directory, the return value
-be only that value.
-
-The \".\" and \"..\" entries are removed from the data returned.
--}
-recurseDir :: HVFS a => a -> FilePath -> IO [FilePath]
-recurseDir fs x = recurseDirStat fs x >>= return . map fst
-
-{- | Like 'recurseDir', but return the stat() (System.Posix.Files.FileStatus)
-information with them. This is an optimization if you will be statting files
-yourself later.
-
-The items are returned lazily.
-
-WARNING: do not change your current working directory until you have consumed
-all the items. Doing so could cause strange effects.
-
-Alternatively, you may wish to pass an absolute path to this function.
--}
-
-recurseDirStat :: HVFS a => a -> FilePath -> IO [(FilePath, HVFSStatEncap)]
-recurseDirStat h fn =
- do fs <- vGetSymbolicLinkStatus h fn
- if withStat fs vIsDirectory
- then do
- dirc <- vGetDirectoryContents h fn
- let contents = map ((++) (fn ++ "/")) $
- filter (\x -> x /= "." && x /= "..") dirc
- subdirs <- unsafeInterleaveIO $ mapM (recurseDirStat h) contents
- return $ (concat subdirs) ++ [(fn, fs)]
- else return [(fn, fs)]
-
-{- | Removes a file or a directory. If a directory, also removes all its
-child files\/directories.
--}
-recursiveRemove :: HVFS a => a -> FilePath -> IO ()
-recursiveRemove h fn =
- recurseDirStat h fn >>= (mapM_ $
- \(fn, fs) -> if withStat fs vIsDirectory
- then vRemoveDirectory h fn
- else vRemoveFile h fn
- )
-
-{- | Provide a result similar to the command ls -l over a directory.
-
-Known bug: setuid bit semantics are inexact compared with standard ls.
--}
-lsl :: HVFS a => a -> FilePath -> IO String
-lsl fs fp =
- let showmodes mode =
- let i m = (intersectFileModes mode m /= 0)
- in
- (if i ownerReadMode then 'r' else '-') :
- (if i ownerWriteMode then 'w' else '-') :
- (if i setUserIDMode then 's' else
- if i ownerExecuteMode then 'x' else '-') :
- (if i groupReadMode then 'r' else '-') :
- (if i groupWriteMode then 'w' else '-') :
- (if i setGroupIDMode then 's' else
- if i groupExecuteMode then 'x' else '-') :
- (if i otherReadMode then 'r' else '-') :
- (if i otherWriteMode then 'w' else '-') :
- (if i otherExecuteMode then 'x' else '-') : []
- showentry origdir fh (state, fp) =
- case state of
- HVFSStatEncap se ->
- let typechar =
- if vIsDirectory se then 'd'
- else if vIsSymbolicLink se then 'l'
- else if vIsBlockDevice se then 'b'
- else if vIsCharacterDevice se then 'c'
- else if vIsSocket se then 's'
- else if vIsNamedPipe se then 's'
- else '-'
- clocktime = epochToClockTime (vModificationTime se)
- datestr c= formatCalendarTime defaultTimeLocale "%b %e %Y"
- c
- in do c <- toCalendarTime clocktime
- linkstr <- case vIsSymbolicLink se of
- False -> return ""
- True -> do sl <- vReadSymbolicLink fh
- (origdir ++ "/" ++ fp)
- return $ " -> " ++ sl
- return $ printf "%c%s 1 %-8d %-8d %-9d %s %s%s"
- typechar
- (showmodes (vFileMode se))
- (toInteger $ vFileOwner se)
- (toInteger $ vFileGroup se)
- (toInteger $ vFileSize se)
- (datestr c)
- fp
- linkstr
- in do c <- vGetDirectoryContents fs fp
- pairs <- mapM (\x -> do ss <- vGetSymbolicLinkStatus fs (fp ++ "/" ++ x)
- return (ss, x)
- ) c
- linedata <- mapM (showentry fp fs) pairs
- return $ unlines $ ["total 1"] ++ linedata
-
-
diff --git a/src/System/IO/HVIO.hs b/src/System/IO/HVIO.hs
deleted file mode 100644
index a2a6d89..0000000
--- a/src/System/IO/HVIO.hs
+++ /dev/null
@@ -1,663 +0,0 @@
-{- arch-tag: HVIO main file
-Copyright (C) 2004-2006 John Goerzen <jgoerzen at complete.org>
-
-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 : System.IO.HVIO
- Copyright : Copyright (C) 2004-2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Haskell Virtual I\/O -- a system to increase the flexibility of input and
-output in Haskell
-
-Copyright (c) 2004-2005 John Goerzen, jgoerzen\@complete.org
-
-HVIO provides the following general features:
-
- * The ability to use a single set of functions on various different
- types of objects, including standard Handles, in-memory buffers,
- compressed files, network data streams, etc.
-
- * The ability to transparently add filters to the I\/O process.
- These filters could include things such as character set conversions,
- compression or decompression of a data stream, and more.
-
- * The ability to define new objects that have the properties
- of I\/O objects and can be used interchangably with them.
-
- * Specification compatibility with, and complete support for,
- existing I\/O on Handles.
-
- * Provide easier unit testing capabilities for I\/O actions
-
-HVIO defines several basic type classes that you can use. You will mostly
-be interested in 'HVIO'.
-
-It's trivial to adapt old code to work with HVIO. For instance, consider
-this example of old and new code:
-
->printMsg :: Handle -> String -> IO ()
->printMsg h msg = hPutStr h ("msg: " ++ msg)
-
-And now, the new way:
-
->printMsg :: HVIO h => h -> String -> IO ()
->printMsg h msg = vPutStr h ("msg: " ++ msg)
-
-There are several points to note about this conversion:
-
- * The new method can still accept a Handle in exactly the same way as
- the old method. Changing your functions to use HVIO will require no
- changes from functions that call them with Handles.
-
- * Most \"h\" functions have equivolent \"v\" functions that operate
- on HVIO classes instead of the more specific Handle. The \"v\" functions
- behave identically to the \"h\" functions whenever possible.
-
- * There is no equivolent of \"openFile\" in any HVIO class. You must
- create your Handle (or other HVIO object) using normal means.
- This is because the creation is so different that it cannot be standardized.
-
-In addition to Handle, there are several pre-defined classes for your use.
-'StreamReader' is a particularly interesting one. At creation time, you pass
-it a String. Its contents are read lazily whenever a read call is made. It
-can be used, therefore, to implement filters (simply initialize it with the
-result from, say, a map over hGetContents from another HVIO object), codecs,
-and simple I\/O testing. Because it is lazy, it need not hold the entire
-string in memory. You can create a 'StreamReader' with a call to
-'newStreamReader'.
-
-'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
-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
-prefer a String representation. You can create a 'MemoryBuffer' with a call
-to 'newMemoryBuffer'.
-
-Finally, there are pipes. These pipes are analogous to the Unix
-pipes that are available from System.Posix, but don't require Unix and work
-only in Haskell. When you create a pipe, you actually get two HVIO objects:
-a 'PipeReader' and a 'PipeWriter'. You must use the 'PipeWriter' in one
-thread and the 'PipeReader' in another thread. Data that's written to the
-'PipeWriter' will then be available for reading with the 'PipeReader'. The
-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. A new pipe can be created
-with a call to 'newHVIOPipe'.
-
-Together with "System.IO.HVFS", this module is part of a complete
-virtual filesystem solution.
--}
-
-module System.IO.HVIO(-- * Implementation Classes
- HVIO(..),
- -- * Standard HVIO Implementations
-
- -- ** Handle
- -- | Handle is a member of 'HVIO'.
-
- -- ** Stream Reader
- StreamReader, newStreamReader,
-
- -- ** Memory Buffer
- MemoryBuffer, newMemoryBuffer,
- mbDefaultCloseFunc, getMemoryBuffer,
-
- -- ** Haskell Pipe
- PipeReader, PipeWriter, newHVIOPipe
- )
-where
-
-import System.IO
-import System.IO.Error
-import Control.Concurrent.MVar
-import Data.IORef
-import Foreign.Ptr
-import Foreign.C
-import Foreign.Storable
-
-{- | This is the generic I\/O support class. All objects that are to be used
-in the HVIO system must provide an instance of 'HVIO'.
-
-Functions in this class provide an interface with the same specification as
-the similar functions in System.IO. Please refer to that documentation
-for a more complete specification than is provided here.
-
-Instances of 'HVIO' must provide 'vClose', 'vIsEOF', and either
-'vIsOpen' or 'vIsClosed'.
-
-Implementators of readable objects must provide at least 'vGetChar'
-and 'vIsReadable'.
-An implementation of 'vGetContents' is also highly suggested, since
-the default cannot implement proper partial closing semantics.
-
-Implementators of writable objects must provide at least 'vPutChar' and
-'vIsWritable'.
-
-Implementators of seekable objects must provide at least
-'vIsSeekable', 'vTell', and 'vSeek'.
--}
-class (Show a) => HVIO a where
- -- | Close a file
- vClose :: a -> IO ()
- -- | Test if a file is open
- vIsOpen :: a -> IO Bool
- -- | Test if a file is closed
- vIsClosed :: a -> IO Bool
- -- | Raise an error if the file is not open.
- -- This is a new HVIO function and is implemented in terms of
- -- 'vIsOpen'.
- vTestOpen :: a -> IO ()
- -- | Whether or not we're at EOF. This may raise on exception
- -- on some items, most notably write-only Handles such as stdout.
- -- In general, this is most reliable on items opened for reading.
- -- vIsEOF implementations must implicitly call vTestOpen.
- vIsEOF :: a -> IO Bool
- -- | Detailed show output.
- vShow :: a -> IO String
- -- | Make an IOError.
- vMkIOError :: a -> IOErrorType -> String -> Maybe FilePath -> IOError
- -- | Throw an IOError.
- vThrow :: a -> IOErrorType -> IO b
- -- | Get the filename\/object\/whatever that this corresponds to.
- -- May be Nothing.
- vGetFP :: a -> IO (Maybe FilePath)
- -- | Throw an isEOFError if we're at EOF; returns nothing otherwise.
- -- If an implementation overrides the default, make sure that it
- -- calls vTestOpen at some point. The default implementation is
- -- a wrapper around a call to 'vIsEOF'.
- vTestEOF :: a -> IO ()
-
- -- | Read one character
- vGetChar :: a -> IO Char
- -- | Read one line
- vGetLine :: a -> IO String
- {- | Get the remaining contents. Please note that as a user of this
- function, the same partial-closing semantics as are used in the
- standard 'hGetContents' are /encouraged/ from implementators,
- but are not /required/. That means that, for instance,
- 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
- 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
- -- | Indicate whether at least one item is ready for reading.
- -- This will always be True for a great many implementations.
- vReady :: a -> IO Bool
- -- | Indicate whether a particular item is available for reading.
- vIsReadable :: a -> IO Bool
-
- -- | Write one character
- vPutChar :: a -> Char -> IO ()
- -- | Write a string
- vPutStr :: a -> String -> IO ()
- -- | Write a string with newline character after it
- vPutStrLn :: a -> String -> IO ()
- -- | 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
- -- performed
- -- on file close, if necessary to ensure all data sent is written.
- vFlush :: a -> IO ()
- -- | Indicate whether or not this particular object supports writing.
- vIsWritable :: a -> IO Bool
-
- -- | Seek to a specific location.
- vSeek :: a -> SeekMode -> Integer -> IO ()
-
- -- | Get the current position.
- vTell :: a -> IO Integer
-
- -- | Convenience function to reset the file pointer to the beginning
- -- of the file. A call to @vRewind h@ is the
- -- same as @'vSeek' h AbsoluteSeek 0 at .
- vRewind :: a -> IO ()
-
- -- | Indicate whether this instance supports seeking.
- vIsSeekable :: a -> IO Bool
-
- -- | Set buffering; the default action is a no-op.
- vSetBuffering :: a -> BufferMode -> IO ()
-
- -- | Get buffering; the default action always returns NoBuffering.
- vGetBuffering :: a -> IO BufferMode
-
- -- | Binary output: write the specified number of octets from the specified
- -- buffer location.
- vPutBuf :: a -> Ptr b -> Int -> IO ()
-
- -- | Binary input: read the specified number of octets from the
- -- specified buffer location, continuing to read
- -- until it either consumes that much data or EOF is encountered.
- -- Returns the number of octets actually read. EOF errors are never
- -- raised; fewer bytes than requested are returned on EOF.
- vGetBuf :: a -> Ptr b -> Int -> IO Int
-
- vSetBuffering _ _ = return ()
- vGetBuffering _ = return NoBuffering
-
- vShow x = return (show x)
-
- vMkIOError _ et desc mfp =
- mkIOError et desc Nothing mfp
-
- vGetFP _ = return Nothing
-
- vThrow h et = do
- fp <- vGetFP h
- ioError (vMkIOError h et "" fp)
-
- vTestEOF h = do e <- vIsEOF h
- if e then vThrow h eofErrorType
- else return ()
-
- vIsOpen h = vIsClosed h >>= return . not
- vIsClosed h = vIsOpen h >>= return . not
- vTestOpen h = do e <- vIsClosed h
- if e then vThrow h illegalOperationErrorType
- else return ()
-
-
- vIsReadable _ = return False
-
- vGetLine h =
- let loop accum =
- let func = do c <- vGetChar h
- case c of
- '\n' -> return accum
- x -> accum `seq` loop (accum ++ [x])
- handler e = if isEOFError e then return accum
- else ioError e
- in catch func handler
- in
- do firstchar <- vGetChar h
- case firstchar of
- '\n' -> return []
- x -> loop [x]
-
- vGetContents h =
- let loop =
- let func = do c <- vGetChar h
- next <- loop
- c `seq` return (c : next)
- handler e = if isEOFError e then return []
- else ioError e
- in catch func handler
- in
- do loop
-
- vReady h = do vTestEOF h
- return True
-
-
- vIsWritable _ = return False
-
- vPutStr _ [] = return ()
- vPutStr h (x:xs) = do vPutChar h x
- vPutStr h xs
-
- vPutStrLn h s = vPutStr h (s ++ "\n")
-
- vPrint h s = vPutStrLn h (show s)
-
- vFlush = vTestOpen
-
-
- vIsSeekable _ = return False
-
- vRewind h = vSeek h AbsoluteSeek 0
-
- vPutChar h _ = vThrow h illegalOperationErrorType
- 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 =
- worker b l 0
- where worker _ 0 accum = return accum
- worker buf len accum =
- do iseof <- vIsEOF h
- if iseof
- then return accum
- else do c <- vGetChar h
- let cc = castCharToCChar c
- poke (castPtr buf) cc
- let newptr = plusPtr buf 1
- worker newptr (len - 1) (accum + 1)
-
-----------------------------------------------------------------------
--- Handle instances
-----------------------------------------------------------------------
-instance HVIO Handle where
- vClose = hClose
- vIsEOF = hIsEOF
-#ifdef __GLASGOW_HASKELL__
- vShow = hShow
-#endif
- vMkIOError h et desc mfp =
- mkIOError et desc (Just h) mfp
- vGetChar = hGetChar
- vGetLine = hGetLine
- vGetContents = hGetContents
- vReady = hReady
- vIsReadable = hIsReadable
- vPutChar = hPutChar
- vPutStr = hPutStr
- vPutStrLn = hPutStrLn
- vPrint = hPrint
- vFlush = hFlush
- vIsWritable = hIsWritable
- vSeek = hSeek
- vTell = hTell
- vIsSeekable = hIsSeekable
- vSetBuffering = hSetBuffering
- vGetBuffering = hGetBuffering
- vGetBuf = hGetBuf
- vPutBuf = hPutBuf
- vIsOpen = hIsOpen
- vIsClosed = hIsClosed
-
-----------------------------------------------------------------------
--- VIO Support
-----------------------------------------------------------------------
-type VIOCloseSupport a = IORef (Bool, a)
-
-vioc_isopen :: VIOCloseSupport a -> IO Bool
-vioc_isopen x = readIORef x >>= return . fst
-
-vioc_get :: VIOCloseSupport a -> IO a
-vioc_get x = readIORef x >>= return . snd
-
-vioc_close :: VIOCloseSupport a -> IO ()
-vioc_close x = modifyIORef x (\ (_, dat) -> (False, dat))
-
-vioc_set :: VIOCloseSupport a -> a -> IO ()
-vioc_set x newdat = modifyIORef x (\ (stat, _) -> (stat, newdat))
-
-----------------------------------------------------------------------
--- Stream Readers
-----------------------------------------------------------------------
-{- | Simulate I\/O based on a string buffer.
-
-When a 'StreamReader' is created, it is initialized based on the contents of
-a 'String'. Its contents are read lazily whenever a request is made to read
-something from the 'StreamReader'. It
-can be used, therefore, to implement filters (simply initialize it with the
-result from, say, a map over hGetContents from another HVIO object), codecs,
-and simple I\/O testing. Because it is lazy, it need not hold the entire
-string in memory. You can create a 'StreamReader' with a call to
-'newStreamReader'.
- -}
-newtype StreamReader = StreamReader (VIOCloseSupport String)
-
-{- | Create a new 'StreamReader' object. -}
-newStreamReader :: String -- ^ Initial contents of the 'StreamReader'
- -> IO StreamReader
-newStreamReader s = do ref <- newIORef (True, s)
- return (StreamReader ref)
-
-srv :: StreamReader -> VIOCloseSupport String
-srv (StreamReader x) = x
-
-instance Show StreamReader where
- show _ = "<StreamReader>"
-
-instance HVIO StreamReader where
- vClose = vioc_close . srv
- vIsEOF h = do vTestOpen h
- d <- vioc_get (srv h)
- return $ case d of
- [] -> True
- _ -> False
- vIsOpen = vioc_isopen . srv
- vGetChar h = do vTestEOF h
- c <- vioc_get (srv h)
- let retval = head c
- vioc_set (srv h) (tail c)
- return retval
-
- vGetContents h = do vTestEOF h
- c <- vioc_get (srv h)
- vClose h
- return c
- vIsReadable _ = return True
-
-----------------------------------------------------------------------
--- 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
-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
-prefer a String representation. You can create a 'MemoryBuffer' with a call
-to 'newMemoryBuffer'.
-
-The present 'MemoryBuffer' implementation is rather inefficient, particularly
-when reading towards the end of large files. It's best used for smallish
-data storage. This problem will be fixed eventually.
--}
-data MemoryBuffer = MemoryBuffer (String -> IO ()) (VIOCloseSupport (Int, String))
-
-{- | Create a new 'MemoryBuffer' instance. The buffer is initialized
-to the value passed, and the pointer is placed at the beginning of the file.
-
-You can put things in it by using the normal 'vPutStr' calls, and reset to
-the beginning by using the normal 'vRewind' call.
-
-The function is called when 'vClose' is called, and is passed the contents of
-the buffer at close time. You can use 'mbDefaultCloseFunc' if you don't want to
-do anything.
-
-To create an empty buffer, pass the initial value @\"\"@. -}
-newMemoryBuffer :: String -- ^ Initial Contents
- -> (String -> IO ()) -- ^ close func
- -> IO MemoryBuffer
-newMemoryBuffer initval closefunc = do ref <- newIORef (True, (0, initval))
- return (MemoryBuffer closefunc ref)
-
-{- | Default (no-op) memory buf close function. -}
-mbDefaultCloseFunc :: String -> IO ()
-mbDefaultCloseFunc _ = return ()
-
-vrv :: MemoryBuffer -> VIOCloseSupport (Int, String)
-vrv (MemoryBuffer _ x) = x
-
-{- | 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
-getMemoryBuffer h = do c <- vioc_get (vrv h)
- return (snd c)
-
-instance Show MemoryBuffer where
- show _ = "<MemoryBuffer>"
-
-instance HVIO MemoryBuffer where
- vClose x = do wasopen <- vIsOpen x
- vioc_close (vrv x)
- if wasopen
- then do c <- getMemoryBuffer x
- case x of
- MemoryBuffer cf _ -> cf c
- else return ()
- vIsEOF h = do vTestOpen h
- c <- vioc_get (vrv h)
- return ((length (snd c)) == (fst c))
- vIsOpen = vioc_isopen . vrv
- vGetChar h = do vTestEOF h
- c <- vioc_get (vrv h)
- let retval = (snd c) !! (fst c)
- vioc_set (vrv h) (succ (fst c), snd c)
- return retval
- vGetContents h = do vTestEOF h
- v <- vioc_get (vrv h)
- let retval = drop (fst v) (snd v)
- vioc_set (vrv h) (-1, "")
- vClose h
- return retval
- vIsReadable _ = return True
-
- vPutStr h s = do (pos, buf) <- vioc_get (vrv h)
- let (pre, post) = splitAt pos buf
- let newbuf = pre ++ s ++ (drop (length s) post)
- vioc_set (vrv h) (pos + (length s), newbuf)
- vPutChar h c = vPutStr h [c]
- vIsWritable _ = return True
- vTell h = do v <- vioc_get (vrv h)
- return . fromIntegral $ (fst v)
- vSeek h seekmode seekposp =
- do (pos, buf) <- vioc_get (vrv h)
- let seekpos = fromInteger seekposp
- let newpos = case seekmode of
- AbsoluteSeek -> seekpos
- RelativeSeek -> pos + seekpos
- SeekFromEnd -> (length buf) + seekpos
- let buf2 = buf ++ if newpos > (length buf)
- then replicate (newpos - (length buf)) '\0'
- else []
- vioc_set (vrv h) (newpos, buf2)
- vIsSeekable _ = return True
-
-----------------------------------------------------------------------
--- Pipes
-----------------------------------------------------------------------
-{- | Create a Haskell pipe.
-
-These pipes are analogous to the Unix
-pipes that are available from System.Posix, but don't require Unix and work
-only in Haskell. When you create a pipe, you actually get two HVIO objects:
-a 'PipeReader' and a 'PipeWriter'. You must use the 'PipeWriter' in one
-thread and the 'PipeReader' in another thread. Data that's written to the
-'PipeWriter' will then be available for reading with the 'PipeReader'. The
-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. -}
-newHVIOPipe :: IO (PipeReader, PipeWriter)
-newHVIOPipe = do mv <- newEmptyMVar
- readerref <- newIORef (True, mv)
- let reader = PipeReader readerref
- writerref <- newIORef (True, reader)
- return (reader, PipeWriter writerref)
-
-data PipeBit = PipeBit Char
- | PipeEOF
- deriving (Eq, Show)
-
-{- | The reading side of a Haskell pipe. Please see 'newHVIOPipe' for more
-details. -}
-newtype PipeReader = PipeReader (VIOCloseSupport (MVar PipeBit))
-
-{- | The writing side of a Haskell pipe. Please see 'newHVIOPipe' for more
-details. -}
-newtype PipeWriter = PipeWriter (VIOCloseSupport PipeReader)
-
-------------------------------
--- Pipe Reader
-------------------------------
-prv :: PipeReader -> VIOCloseSupport (MVar PipeBit)
-prv (PipeReader x) = x
-
-instance Show PipeReader where
- show _ = "<PipeReader>"
-
-pr_getc :: PipeReader -> IO PipeBit
-pr_getc h = do mv <- vioc_get (prv h)
- takeMVar mv
-
-instance HVIO PipeReader where
- vClose = vioc_close . prv
- vIsOpen = vioc_isopen . prv
- vIsEOF h = do vTestOpen h
- mv <- vioc_get (prv h)
- dat <- readMVar mv
- return (dat == PipeEOF)
-
- vGetChar h = do vTestEOF h
- c <- pr_getc h
- case c of
- PipeBit x -> return x
- -- vTestEOF should eliminate this case
- _ -> fail "Internal error in HVIOReader vGetChar"
- vGetContents h =
- let loop = do c <- pr_getc h
- case c of
- PipeEOF -> return []
- PipeBit x -> do next <- loop
- return (x : next)
- 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 _ = "<PipeWriter>"
-
-instance HVIO PipeWriter where
- vClose h = do o <- vIsOpen h
- if o then do
- mv <- pwmv h
- putMVar mv PipeEOF
- vioc_close (pwv h)
- else return ()
- vIsOpen = vioc_isopen . pwv
- vIsEOF h = do vTestOpen h
- return False
-
- -- FIXME: race condition below (could be closed after testing)
- vPutChar h c = do vTestOpen h
- child <- vioc_get (pwv h)
- copen <- vIsOpen child
- if copen
- then do mv <- pwmv h
- putMVar mv (PipeBit c)
- else fail "PipeWriter: Couldn't write to pipe because child end is closed"
- vIsWritable _ = return True
diff --git a/src/System/IO/PlafCompat.hs b/src/System/IO/PlafCompat.hs
deleted file mode 100644
index f27591f..0000000
--- a/src/System/IO/PlafCompat.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-{-# LANGUAGE CPP #-}
-{- Platform Compatibility Layer
-Copyright (C) 2005 John Goerzen <jgoerzen at complete.org>
-
-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 : System.IO.PlafCompat
- Copyright : Copyright (C) 2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-On Unix, exports System.Posix.Types and System.Posix.Files.
-
-On Windows, exports System.Posix.Types and "System.IO.WindowsCompat".
-
-The result should be roughly the same set of defined variables and types.
-
--}
-
-module System.IO.PlafCompat
- (nullFileName,
-#if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
- module System.IO.WindowsCompat,
-#else
- module System.Posix.Files,
-#endif
- module System.Posix.Types)
-where
-
-import System.Posix.Types
-#if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-import System.IO.WindowsCompat
-#else
-import System.Posix.Files
-#endif
-
-{- | The name of the null device. NUL: on Windows, \/dev\/null everywhere else.
--}
-
-nullFileName :: String
-#if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-nullFileName = "NUL:"
-#else
-nullFileName = "/dev/null"
-#endif
diff --git a/src/System/IO/StatCompat.hs b/src/System/IO/StatCompat.hs
deleted file mode 100644
index ec381d0..0000000
--- a/src/System/IO/StatCompat.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-
-Copyright (C) 2005,2006 John Goerzen <jgoerzen at complete.org>
-
-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 : System.IO.StatCompat
- Copyright : Copyright (C) 2005-2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Provide a stat-like structure for use in MissingH. Especially
-useful with HVFS and on Windows. See also "System.IO.WindowsCompat".
-
-Copyright (c) 2005-2006 John Goerzen, jgoerzen\@complete.org
--}
-
-module System.IO.StatCompat
-where
-import System.Posix.Types
-import System.Posix.Consts
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-import System.Posix.Files(intersectFileModes)
-#endif
-import Data.Bits ((.&.))
-
-#if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-type LinkCount = Int
-type UserID = Int
-type GroupID = Int
-#endif
-
-data FileStatusCompat =
- FileStatusCompat {deviceID :: DeviceID,
- fileID :: FileID,
- fileMode :: FileMode,
- linkCount :: LinkCount,
- fileOwner :: UserID,
- fileGroup :: GroupID,
- specialDeviceID :: DeviceID,
- fileSize :: FileOffset,
- accessTime :: EpochTime,
- modificationTime :: EpochTime,
- statusChangeTime :: EpochTime
- }
-
-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
-isRegularFile = sc_helper regularFileMode
-isDirectory = sc_helper directoryMode
-isSymbolicLink = sc_helper symbolicLinkMode
-isSocket = sc_helper socketMode
-
-#if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-intersectFileModes :: FileMode -> FileMode -> FileMode
-intersectFileModes m1 m2 = m1 .&. m2
-#endif
diff --git a/src/System/IO/Utils.hs b/src/System/IO/Utils.hs
deleted file mode 100644
index 93fc58f..0000000
--- a/src/System/IO/Utils.hs
+++ /dev/null
@@ -1,220 +0,0 @@
-{-
-Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
-
-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 : System.IO.Utils
- Copyright : Copyright (C) 2004-2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
--}
-
-module System.IO.Utils(-- * Entire File Handle Utilities
- -- ** Opened Handle Data Copying
- hCopy, hCopyProgress, hLineCopy, lineCopy,
- -- ** Disk File Data Copying
- copyFileLinesToFile,
- -- * Line Processing Utilities
- hPutStrLns, hGetLines,
- -- * Lazy Interaction
- -- ** Character-based
- hInteract,
- -- ** Line-based
- hLineInteract, lineInteract,
- -- ** Misc. Lazy
- lazyMapM,
- -- * Optimizations
- optimizeForBatch, optimizeForInteraction
- ) where
-
-import System.IO.Unsafe (unsafeInterleaveIO)
-import System.IO
-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
-
-{- | Given a handle, returns a list of all the lines in that handle.
-Thanks to lazy evaluation, this list does not have to be read all at once.
-
-Combined with 'hPutStrLns', this can make a powerful way to develop
-filters. See the 'lineInteract' function for more on that concept.
-
-Example:
-
-> main = do
-> l <- hGetLines stdin
-> hPutStrLns stdout $ filter (startswith "1") l
-
--}
-
--- FIXME: does hGetContents h >>= return . lines not work?
-hGetLines :: HVIO a => a -> IO [String]
-hGetLines h = unsafeInterleaveIO (do
- ieof <- vIsEOF h
- if (ieof)
- then return []
- else do
- line <- vGetLine h
- remainder <- hGetLines h
- return (line : remainder))
-
-
-{- | This is similar to the built-in 'System.IO.interact', but works
-on any handle, not just stdin and stdout.
-
-In other words:
-
-> interact = hInteract stdin stdout
--}
-hInteract :: (HVIO a, HVIO b) => a -> b -> (String -> String) -> IO ()
-hInteract finput foutput func = do
- content <- vGetContents finput
- vPutStr foutput (func content)
-
-{- | Line-based interaction. This is similar to wrapping your
-interact functions with 'lines' and 'unlines'. This equality holds:
-
-> lineInteract = hLineInteract stdin stdout
-
-Here's an example:
-
-> main = lineInteract (filter (startswith "1"))
-
-This will act as a simple version of grep -- all lines that start with 1
-will be displayed; all others will be ignored.
--}
-lineInteract :: ([String] -> [String]) -> IO ()
-lineInteract = hLineInteract stdin stdout
-
-{- | Line-based interaction over arbitrary handles. This is similar
-to wrapping hInteract with 'lines' and 'unlines'.
-
-One could view this function like this:
-
-> hLineInteract finput foutput func =
-> let newf = unlines . func . lines in
-> hInteract finput foutput newf
-
-Though the actual implementation is this for efficiency:
-
-> hLineInteract finput foutput func =
-> do
-> lines <- hGetLines finput
-> hPutStrLns foutput (func lines)
--}
-hLineInteract :: (HVIO a, HVIO b) => a -> b -> ([String] -> [String]) -> IO ()
-hLineInteract finput foutput func =
- do
- lines <- hGetLines finput
- hPutStrLns foutput (func lines)
-
-{- | Copies from one handle to another in raw mode (using
-hGetContents).
--}
-hCopy :: (HVIO a, HVIO b) => a -> b -> IO ()
-hCopy hin hout = do
- c <- vGetContents hin
- vPutStr hout c
-
-{- | 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) =>
- b -- ^ Input handle
- -> c -- ^ Output handle
- -> (Maybe a -> Integer -> Bool -> IO ()) -- ^ Progress function -- the bool is always False unless this is the final call
- -> Int -- Block size
- -> Maybe a -- Estimated file size (passed to func)
- -> IO Integer -- Number of bytes copied
-hCopyProgress hin hout func bsize estsize =
- let copyFunc :: String -> Integer -> IO Integer
- copyFunc [] count = return count
- copyFunc indata count =
- let block = take bsize indata
- remainder = drop bsize indata
- newcount = count + (genericLength block)
- in
- do
- vPutStr hout block
- func estsize count False
- copyFunc remainder newcount
- in
- do
- c <- vGetContents hin
- bytes <- copyFunc c 0
- func estsize bytes True
- return bytes
-
-{- | Copies from one handle to another in text mode (with lines).
-Like 'hBlockCopy', this implementation is nice:
-
-> 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
-
-{- | Copies one filename to another in text mode.
-
-Please note that the Unix permission bits are set at a default; you may
-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
- hout <- openFile outfn WriteMode
- hLineCopy hin hout
- hClose hin
- hClose hout
- return ()
-
-{- | Sets stdin and stdout to be block-buffered. This can save a huge amount
-of system resources since far fewer syscalls are made, and can make programs
-run much faster. -}
-optimizeForBatch :: IO ()
-optimizeForBatch = do
- hSetBuffering stdin (BlockBuffering (Just 4096))
- 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. -}
-optimizeForInteraction :: IO ()
-optimizeForInteraction = do
- hSetBuffering stdin LineBuffering
- hSetBuffering stdout LineBuffering
-
-{- | Applies a given function to every item in a list, and returns
-the new list. Unlike the system\'s mapM, items are evaluated lazily. -}
-lazyMapM :: (a -> IO b) -> [a] -> IO [b]
-lazyMapM _ [] = return []
-lazyMapM conv (x:xs) =
- do this <- conv x
- next <- unsafeInterleaveIO $ lazyMapM conv xs
- return (this:next)
diff --git a/src/System/IO/WindowsCompat.hs b/src/System/IO/WindowsCompat.hs
deleted file mode 100644
index 3f838d3..0000000
--- a/src/System/IO/WindowsCompat.hs
+++ /dev/null
@@ -1,149 +0,0 @@
-{-# LANGUAGE CPP #-}
-{- Windows compatibility layer
-Copyright (C) 2005 John Goerzen <jgoerzen at complete.org>
-
-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 : System.IO.WindowsCompat
- Copyright : Copyright (C) 2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Provides some types and related items on Windows to be compatible with
-the System.Posix.* libraries
-
-See also "System.IO.StatCompat", which this module re-exports.
-
-Copyright (c) 2005 John Goerzen, jgoerzen\@complete.org
-
-On non-Windows platforms, this module does nothing.
-
-On Windows, it re-exports "System.IO.StatCompat". It also provides various
-file type information modes that are otherwise in "System.Posix.Types" or
-"System.Posix.Files". It also provides
-a rudimentary implemention of getFileStatus that emulates the Posix call
-to stat(2).
-
-Common usage might be like this:
-
->import System.Posix.Types
->#if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
->import System.IO.WindowsCompat
->#else
->import System.Posix.Files
->#endif
-
-Or, to avoid having to use CPP and make things even easier, just import
-"System.IO.PlafCompat", which essentially does the above.
-
--}
-
-module System.IO.WindowsCompat
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-where
-#else
- (module System.IO.StatCompat, module System.IO.WindowsCompat)
-where
-
-import System.Posix.Types
-import Data.Bits
-import System.IO.StatCompat
-import System.Posix.Consts
-import System.Time.Utils
-import System.Directory
-
--- these types aren't defined here
-
-nullFileMode :: FileMode
-nullFileMode = 0
-
-ownerReadMode :: FileMode
-ownerReadMode = 0o00400
-
-ownerWriteMode :: FileMode
-ownerWriteMode = 0o00200
-
-ownerExecuteMode :: FileMode
-ownerExecuteMode = 0o00100
-
-groupReadMode :: FileMode
-groupReadMode = 0o00040
-
-groupWriteMode :: FileMode
-groupWriteMode = 0o00020
-
-groupExecuteMode :: FileMode
-groupExecuteMode = 0o00010
-
-otherReadMode :: FileMode
-otherReadMode = 0o00004
-
-otherWriteMode :: FileMode
-otherWriteMode = 0o00002
-
-otherExecuteMode :: FileMode
-otherExecuteMode = 0o00001
-
-setUserIDMode :: FileMode
-setUserIDMode = 0o0004000
-
-setGroupIDMode :: FileMode
-setGroupIDMode = 0o0002000
-
-stdFileMode :: FileMode
-stdFileMode = ownerReadMode .|. ownerWriteMode .|.
- groupReadMode .|. groupWriteMode .|.
- otherReadMode .|. otherWriteMode
-
-ownerModes :: FileMode
-ownerModes = 0o00700
-
-groupModes :: FileMode
-groupModes = 0o00070
-
-otherModes :: FileMode
-otherModes = 0o00007
-
-accessModes :: FileMode
-accessModes = ownerModes .|. groupModes .|. otherModes
-
------------ stat
-type FileStatus = FileStatusCompat
-getFileStatus :: FilePath -> IO FileStatus
-getFileStatus fp =
- do isfile <- doesFileExist fp
- isdir <- doesDirectoryExist fp
- perms <- getPermissions fp
- modct <- getModificationTime fp
- let epochtime = clockTimeToEpoch modct
- return $ FileStatusCompat {deviceID = -1,
- fileID = -1,
- fileMode = if isfile then regularFileMode
- else directoryMode,
- linkCount = 1,
- fileOwner = 0,
- fileGroup = 0,
- specialDeviceID = -1,
- fileSize = 0, -- fixme: hFileSize?
- accessTime = fromInteger epochtime,
- modificationTime = fromInteger epochtime,
- statusChangeTime = fromInteger epochtime
- }
-#endif
diff --git a/src/System/Path.hs b/src/System/Path.hs
deleted file mode 100644
index b128e41..0000000
--- a/src/System/Path.hs
+++ /dev/null
@@ -1,158 +0,0 @@
-{-# LANGUAGE CPP #-}
-{- arch-tag: Path utilities main file
-Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
-
-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 : System.Path
- Copyright : Copyright (C) 2004-2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-This module provides various helpful utilities for dealing with path and
-file names, directories, and related support.
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module System.Path(-- * Name processing
- splitExt, absNormPath, secureAbsNormPath,
- -- * Directory Processing
- recurseDir, recurseDirStat, recursiveRemove,
- bracketCWD,
- -- * Temporary Directories
- mktmpdir, brackettmpdir, brackettmpdirCWD
- )
-where
-import Data.List
-import Data.List.Utils
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-import System.Posix.Files
-import System.Posix.Directory (createDirectory)
-import System.Posix.Temp
-import System.Directory hiding (createDirectory)
-#else
-import System.Directory
-#endif
-import Control.Exception
-import System.IO
-import System.Path.NameManip
-import System.IO.HVFS.Utils
-
-{- | 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.
-splitExt :: String -> (String, String)
-splitExt path =
- let dotindex = alwaysElemRIndex '.' path
- slashindex = alwaysElemRIndex '/' path
- in
- if dotindex <= slashindex
- then (path, "")
- else ((take dotindex path), (drop dotindex path))
-
-{- | Make an absolute, normalized version of a path with all double slashes,
-dot, and dotdot entries removed.
-
-The first parameter is the base for the absolut calculation; in many cases,
-it would correspond to the current working directory.
-
-The second parameter is the pathname to transform. If it is already absolute,
-the first parameter is ignored.
-
-Nothing may be returned if there's an error; for instance, too many @..@ entries
-for the given path.
--}
-absNormPath :: String -- ^ Absolute path for use with starting directory
- -> String -- ^ The path name to make absolute
- -> Maybe String -- ^ Result
-absNormPath base thepath =
- let abs = absolute_path_by base thepath
- in case guess_dotdot (normalise_path abs) of
- Just "." -> Just "/"
- x -> x
-
-{- | Like absNormPath, but returns Nothing if the generated result is not
-the passed base path or a subdirectory thereof. -}
-secureAbsNormPath :: String -- ^ Absolute path for use with starting directory
- -> String -- ^ The path to make absolute
- -> Maybe String
-secureAbsNormPath base s = do p <- absNormPath base s
- if startswith base p
- then return p
- else fail ""
-
-{- | Creates a temporary directory for your use.
-
-The passed string should be a template suitable for mkstemp; that is, end with
-@\"XXXXXX\"@.
-
-Your string should probably start with the value returned from
-System.Directory.getTemporaryDirectory.
-
-The name of the directory created will be returned.
--}
-mktmpdir :: String -> IO String
-#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
-mktmpdir x =
- do y <- mkstemp x
- let (dirname, h) = y
- hClose h
- removeFile dirname
- createDirectory dirname 0o700
- return dirname
-#else
-#ifdef __GLASGOW_HASKELL__
-mktmpdir x =
- do (fp, h) <- openTempFile "" x
- hClose h
- removeFile fp
- createDirectory fp
- return fp
-#else
-mktmpdir _ = fail "mktmpdir not supported on Windows unless you have GHC"
-#endif
-#endif
-
-{- | Creates a temporary directory for your use via 'mktmpdir',
-runs the specified action (passing in the directory name), then
-removes the directory and all its contents when the action completes (or raises
-an exception. -}
-brackettmpdir :: String -> (String -> IO a) -> IO a
-brackettmpdir x action = do tmpdir <- mktmpdir x
- finally (action tmpdir)
- (recursiveRemove SystemFS tmpdir)
-
-{- | Changes the current working directory to the given path,
-executes the given I\/O action, then changes back to the original directory,
-even if the I\/O action raised an exception. -}
-bracketCWD :: FilePath -> IO a -> IO a
-bracketCWD fp action =
- do oldcwd <- getCurrentDirectory
- setCurrentDirectory fp
- finally action (setCurrentDirectory oldcwd)
-
-{- | Runs the given I\/O action with the CWD set to the given tmp dir,
-removing the tmp dir and changing CWD back afterwards, even if there
-was an exception. -}
-brackettmpdirCWD :: String -> IO a -> IO a
-brackettmpdirCWD template action =
- brackettmpdir template (\newdir -> bracketCWD newdir action)
diff --git a/src/System/Path/Glob.hs b/src/System/Path/Glob.hs
deleted file mode 100644
index a5ee12d..0000000
--- a/src/System/Path/Glob.hs
+++ /dev/null
@@ -1,120 +0,0 @@
-{- Copyright (C) 2006 John Goerzen <jgoerzen at complete.org>
-
-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 : System.Path.Glob
- Copyright : Copyright (C) 2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Functions for expanding wildcards, filenames, and pathnames.
-
-For information on the metacharacters recognized, please see the notes
-in "System.Path.WildMatch".
-
--}
-
-module System.Path.Glob (glob, vGlob)
- where
-import Data.List.Utils (hasAny)
-import System.IO.HVFS
-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.
-The pattern is evaluated by "System.Path.WildMatch". This function
-does not perform tilde or environment variable expansion.
-
-Filenames that begin with a dot are not included in the result set unless
-that component of the pattern also begins with a dot.
-
-In MissingH, this function is defined as:
-
->glob = vGlob SystemFS
--}
-glob :: FilePath -> IO [FilePath]
-glob = vGlob SystemFS
-
-{- | Like 'glob', but works on both the system ("real") and HVFS virtual
-filesystems. -}
-vGlob :: HVFS a => a -> FilePath -> IO [FilePath]
-vGlob fs fn =
- if not (hasWild fn) -- Don't try globbing if there are no wilds
- then do de <- vDoesExist fs fn
- if de
- then return [fn]
- else return []
- else expandGlob fs fn -- It's there
-
-expandGlob :: HVFS a => a -> FilePath -> IO [FilePath]
-expandGlob fs fn =
- case dirnameslash of
- "./" -> runGlob fs "." basename
- "/" -> do
- rgs <- runGlob fs "/" basename
- return $ map ('/' :) rgs
- _ -> do dirlist <- if hasWild dirname
- then expandGlob fs dirname
- else return [dirname]
- if hasWild basename
- then do r <- mapM expandWildBase dirlist
- 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 withD dirglobs
- where withD = case dname of
- "" -> id
- _ -> \globfn -> dname ++ "/" ++ globfn
-
- expandNormalBase :: FilePath -> IO [FilePath]
- expandNormalBase dname =
- do isdir <- vDoesDirectoryExist fs dname
- let newname = dname ++ "/" ++ basename
- isexists <- vDoesExist fs newname
- if isexists && ((basename /= "." && basename /= "") || isdir)
- then return [dname ++ "/" ++ basename]
- else return []
-
-runGlob :: HVFS a => a -> FilePath -> FilePath -> IO [FilePath]
-runGlob fs "" patt = runGlob fs "." patt
-runGlob fs dirname patt =
- do r <- tryJust ioErrors (vGetDirectoryContents fs dirname)
- case r of
- Left _ -> return []
- Right names -> let matches = filter (wildCheckCase patt) $ names
- in if head patt == '.'
- then return matches
- else return $ filter (\x -> head x /= '.') matches
diff --git a/src/System/Path/NameManip.hs b/src/System/Path/NameManip.hs
deleted file mode 100644
index 861808e..0000000
--- a/src/System/Path/NameManip.hs
+++ /dev/null
@@ -1,431 +0,0 @@
-{- arch-tag: Path utilities name manipulation code
-
--}
-
-{- |
- Module : System.Path.NameManip
- Copyright : Copyright (C) 2004 Volker Wysk
- License : GNU LGPL, version 2.1 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Low-level path name manipulations.
-
-Written by Volker Wysk
--}
-
-module System.Path.NameManip where
-
-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
-will start with \"@\/@\". \"@..@\" components are left intact. They can't be simply
-removed, because the preceding component might be a symlink. In this case,
-'realpath' is probably what you need.
-
-The case that the path is empty, is probably an error. However, it is
-treated like \"@.@\", yielding an empty path components list.
-
-Examples:
-
->slice_path "/" = ["/"]
->slice_path "/foo/bar" = ["/foo","bar"]
->slice_path "..//./" = [".."]
->slice_path "." = []
-
-See 'unslice_path', 'realpath', 'realpath_s'.
--}
-slice_path :: String -- ^ The path to be broken to components.
- -> [String] -- ^ List of path components.
-slice_path p =
- case p of
- ('/':p') -> case slice_path' p' of
- [] -> ["/"]
- (c:cs) -> (('/':c):cs)
- _ -> slice_path' p
- where
- slice_path' o = filter (\c -> c /= "" && c /= ".") (split o)
-
- split "" = []
- split ('/':o) = "" : split o
- split (x:xs) = case split xs of
- [] -> [[x]]
- (y:ys) -> ((x:y):ys)
-
-{- | Form a path from path components. This isn't the inverse
-of 'slice_path', since @'unslice_path' . 'slice_path'@
-normalises the path.
-
-See 'slice_path'.
--}
-unslice_path :: [String] -- ^ List of path components
- -> String -- ^ The path which consists of the supplied path components
-unslice_path [] = "."
-unslice_path cs = concat (intersperse "/" cs)
-
-
-{- | Normalise a path. This is done by reducing repeated @\/@ characters to one, and removing
- at .@ path components. @..@ path components are left intact, because of possible symlinks.
-
-@'normalise_path' = 'unslice_path' . 'slice_path'@
--}
-normalise_path :: String -- ^ Path to be normalised
- -> String -- ^ Path in normalised form
-normalise_path = unslice_path . slice_path
-
-
-{- | Split a file name in components. This are the base file name and the
-suffixes, which are separated by dots. If the name starts with a dot, it is
-regarded as part of the base name. The result is a list of file name
-components. The filename may be a path. In this case, everything up to the
-last path component will be returned as part of the base file name. The
-path gets normalised thereby.
-
-No empty suffixes are returned. If the file name contains several
-consecutive dots, they are regared as part of the preceding file name
-component.
-
-Concateneting the name components and adding dots, reproduces the
-original name, with a normalised path:
- at concat . intersperse \".\" . 'slice_filename' == 'normalise'@.
-
-Note that the last path component might be \"@..@\". Then it is not
-possible to deduce the refered directory's name from the path. An IO
-action for getting the real path is then necessary.
-
-Examples:
-
-@
-'slice_filename' \"a.b\/\/.\/.foo.tar.gz\" == [\"a.b\/.foo\",\"tar\",\"gz\"]
-'slice_filename' \".x..y.\" == [\".x.\", \"y.\"]
-@
-
-See 'unslice_filename', @slice_filename\'@.
--}
-slice_filename :: String -- ^ Path
- -> [String] -- ^ List of components the file name is made up of
-slice_filename path =
- let comps = slice_path path
- in if comps == []
- then []
- else -- slice_filename' result not empty, because comps not empty
- let (base:suffixes) = slice_filename' (last comps)
- in (unslice_path (init comps ++ [base]) : suffixes)
-
-
-{- | This is a variant of 'slice_filename'. It is like 'slice_filename', except for
-being more efficient, and the filename must not contain any preceding path,
-since this case isn't considered.
-
-See 'slice_filename', 'unslice_filename'.
--}
-slice_filename' :: String -- ^ File name without path
- -> [String] -- ^ List of components the file name is made up of
-slice_filename' filename =
- case filename of
- ('.':filename') -> case slice_filename'' filename' of
- [] -> ["."]
- (t:ts) -> ('.':t) : ts
- filename -> slice_filename'' filename
- where
- slice_filename'' :: String -> [String]
- slice_filename'' "" = []
- slice_filename'' fn =
- let (beg,rest) = split1 fn
- in (beg : slice_filename'' rest)
-
- split1 :: String -> (String, String)
- split1 (x:y:r) =
- if x == '.' && y /= '.' then ("", y:r)
- else let (beg,rest) = split1 (y:r)
- in (x:beg,rest)
- split1 str = (str, "")
-
-
-
-{- | Form file name from file name components, interspersing dots. This is
-the inverse of 'slice_filename', except for normalisation of any path.
-
-> unslice_filename = concat . intersperse "."
-
-See 'slice_filename'.
--}
-unslice_filename :: [String] -- ^ List of file name components
- -> String -- ^ Name of the file which consists of the supplied components
-unslice_filename = concat . intersperse "."
-
-
-{- | Split a path in directory and file name. Only in the case that the
-supplied path is empty, both parts are empty strings. Otherwise, @\".\"@ is filled in
-for the corresponding part, if necessary. Unless the path is empty,
-concatenating the returned path and file name components with a slash in
-between, makes a valid path to the file.
-
- at split_path@ splits off the last path component. This
-isn't the same as the text after the last @\/@.
-
-Note that the last path component might be @\"..\"@. Then it is not
-possible to deduce the refered directory's name from the path. Then an IO
-action for getting the real path is necessary.
-
-Examples:
-
->split_path "/a/b/c" == ("/a/b", "c")
->split_path "foo" == (".", "foo")
->split_path "foo/bar" == ("foo", "bar")
->split_path "foo/.." == ("foo", "..")
->split_path "." == (".", ".")
->split_path "" == ("", "")
->split_path "/foo" == ("/", "foo")
->split_path "foo/" == (".", "foo")
->split_path "foo/." == (".", "foo")
->split_path "foo///./bar" == ("foo", "bar")
-
-See 'slice_path'.
--}
-split_path :: String -- ^ Path to be split
- -> (String, String) -- ^ Directory and file name components of the path. The directory path is normalized.
-split_path "" = ("","")
-split_path path =
- case slice_path path of
- [] -> (".",".")
- ["/"] -> ("/", ".")
- ['/':p] -> ("/", p)
- [fn] -> (".", fn)
- parts -> ( unslice_path (init parts)
- , last parts
- )
-
-{- | Get the directory part of a path.
-
->dir_part = fst . split_path
-
-See 'split_path'.
--}
-dir_part :: String -> String
-dir_part = fst . split_path
-
-
-{- | Get the last path component of a path.
-
->filename_part = snd . split_path
-
-Examples:
-
->filename_part "foo/bar" == "bar"
->filename_part "." == "."
-
-See 'split_path'.
--}
-filename_part :: String -> String
-filename_part = snd . split_path
-
-
-{- | Inverse of 'split_path', except for normalisation.
-
-This concatenates two paths, and takes care of @\".\"@ and empty paths. When the two components are the result of @split_path@, then @unsplit_path@
-creates a normalised path. It is best documented by its definition:
-
->unsplit_path (".", "") = "."
->unsplit_path ("", ".") = "."
->unsplit_path (".", q) = q
->unsplit_path ("", q) = q
->unsplit_path (p, "") = p
->unsplit_path (p, ".") = p
->unsplit_path (p, q) = p ++ "/" ++ q
-
-Examples:
-
->unsplit_path ("", "") == ""
->unsplit_path (".", "") == "."
->unsplit_path (".", ".") == "."
->unsplit_path ("foo", ".") == "foo"
-
-See 'split_path'.
--}
-unsplit_path :: ( String, String ) -- ^ Directory and file name
- -> String -- ^ Path formed from the directory and file name parts
-unsplit_path (".", "") = "."
-unsplit_path ("", ".") = "."
-unsplit_path (".", q) = q
-unsplit_path ("", q) = q
-unsplit_path (p, "") = p
-unsplit_path (p, ".") = p
-unsplit_path (p, q) = p ++ "/" ++ q
-
-
-{- | Split a file name in prefix and suffix. If there isn't any suffix in
-the file name, then return an empty suffix. A dot at the beginning or at
-the end is not regarded as introducing a suffix.
-
-The last path component is what is being split. This isn't the same as
-splitting the string at the last dot. For instance, if the file name
-doesn't contain any dot, dots in previous path component's aren't mistaken
-as introducing suffixes.
-
-The path part is returned in normalised form. This means, @\".\"@ components
-are removed, and multiple \"@\/@\"s are reduced to one.
-
-Note that there isn't any plausibility check performed on the suffix. If the file name doesn't have a suffix, but happens to contain a dot, then this
-dot is mistaken as introducing a suffix.
-
-Examples:
-
->split_filename "path/to/foo.bar" = ("path/to/foo","bar")
->split_filename "path/to/foo" = ("path/to/foo","")
->split_filename "/path.to/foo" = ("/path.to/foo","")
->split_filename "a///./x" = ("a/x","")
->split_filename "dir.suffix/./" = ("dir","suffix")
->split_filename "Photographie, Das 20. Jahrhundert (300 dpi)" = ("Photographie, Das 20", " Jahrhundert (300 dpi)")
-
-See 'slice_path', 'split_filename\''
--}
-split_filename :: String -- ^ Path including the file name to be split
- -> (String, String) -- ^ The normalised path with the file prefix, and the file suffix.
-split_filename "" = ("", "")
-split_filename path =
- case slice_path path of
- [] -> (".","")
- comps -> let (pref_fn, suff_fn) = split_filename' (last comps)
- in ( concat (intersperse "/" (init comps ++ [pref_fn]))
- , suff_fn
- )
-
-
-{- | Variant of 'split_filename'. This is a more efficient version
-of 'split_filename', for the case that you know the string is
-is a pure file name without any slashes.
-
-See 'split_filename'.
--}
-split_filename' :: String -- ^ Filename to be split
- -> (String, String) -- ^ Base name and the last suffix
-split_filename' "" = ("", "")
-split_filename' fn =
- let parts = slice_filename' fn
- in case parts of
- [] -> (".", "")
- [base] -> (base, "")
- p -> (unslice_filename (init p), last p)
-
-
-{- | Inverse of 'split_filename'. Concatenate prefix and suffix, adding
-a dot in between, iff the suffix is not empty. The path part of the prefix is
-normalised.
-
-See 'split_filename'.
--}
-unsplit_filename :: (String, String) -- ^ File name prefix and suffix
- -> String -- ^ Path
-unsplit_filename (prefix, suffix) =
- if suffix == "" then prefix else prefix ++ "." ++ suffix
-
-
-{- | Split a path in directory, base file name and suffix.
--}
-split3 :: String -- ^ Path to split
- -> (String, String, String) -- ^ Directory part, base file name part and suffix part
-split3 "" = ("","","")
-split3 path =
- let comps = slice_path path
- (base, suffix) = split_filename' (last comps)
- in (unslice_path (init comps), base, suffix)
-
-
-{- |
-Form path from directory, base file name and suffix parts.
--}
-unsplit3 :: (String, String, String) -- ^ Directory part, base file name part and suffix part
- -> String -- ^ Path consisting of dir, base and suffix
-unsplit3 (dir, base, suffix) =
- unsplit_path (dir, (unsplit_filename (base,suffix)))
-
-
-{- | Test a path for a specific suffix and split it off.
-
-If the path ends with the suffix, then the result is @Just
-prefix@, where @prefix@ is the normalised path
-without the suffix. Otherwise it's @Nothing at .
--}
-test_suffix :: String -- ^ Suffix to split off
- -> String -- ^ Path to test
- -> Maybe String -- ^ Prefix without the suffix or @Nothing@
-test_suffix suffix path =
- let (prefix, suff) = split_filename path
- in if suff == suffix then Just prefix
- else Nothing
-
-
-{- | Make a path absolute, using the current working directory.
-
-This makes a relative path absolute with respect to the current
-working directory. An absolute path is returned unmodified.
-
-The current working directory is determined with @getCurrentDirectory@
-which means that symbolic links in it are expanded and the path is
-normalised. This is different from @pwd at .
--}
-absolute_path :: String -- ^ The path to be made absolute
- -> IO String -- ^ Absulte path
-absolute_path path@('/':_) = return path
-absolute_path path = do
- cwd <- getCurrentDirectory
- return (cwd ++ "/" ++ path)
-
-
-{- | Make a path absolute.
-
-This makes a relative path absolute with respect to a specified
-directory. An absolute path is returned unmodified.
--}
-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 _ path@('/':_) = path
-absolute_path_by dir path = dir ++ "/" ++ path
-
-
-{- | Make a path absolute.
-
-This makes a relative path absolute with respect to a specified
-directory. An absolute path is returned unmodified.
-
-The order of the arguments can be confusing. You should rather use 'absolute_path_by'. @absolute_path\'@ is included for backwards compatibility.
--}
-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@('/':_) _ = path
-absolute_path' path dir = dir ++ "/" ++ path
-
-
-{- | Guess the @\"..\"@-component free form of a path, specified as a list of path components, by syntactically removing them, along with the preceding
- path components. This will produce
- erroneous results when the path contains symlinks. If the path contains leading @\"..\"@ components, or more @\"..\"@ components than preceeding normal
- components, then the @\"..\"@ components can't be normalised away. In this case, the result is @Nothing at .
--}
-guess_dotdot_comps :: [String] -- ^ List of path components
- -> Maybe [String] -- ^ In case the path could be transformed, the @\"..\"@-component free list of path components.
-guess_dotdot_comps = guess_dotdot_comps' []
- where
- guess_dotdot_comps' schon [] = Just schon
- guess_dotdot_comps' [] ("..":_) = Nothing
- guess_dotdot_comps' schon ("..":teile) = guess_dotdot_comps' (reverse . tail . reverse $ schon) teile
- guess_dotdot_comps' schon (teil:teile) = guess_dotdot_comps' (schon ++ [teil]) teile
-
-
-{- | Guess the @\"..\"@-component free, normalised form of a path. The transformation is purely syntactic. @\"..\"@ path components will be removed, along
- with their preceding path components. This will produce
- erroneous results when the path contains symlinks. If the path contains leading @\"..\"@ components, or more @\"..\"@ components than preceeding normal
- components, then the @\"..\"@ components can't be normalised away. In this case, the result is @Nothing at .
-
->guess_dotdot = fmap unslice_path . guess_dotdot_comps . slice_path
--}
-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 =
- fmap unslice_path . guess_dotdot_comps . slice_path
diff --git a/src/System/Path/WildMatch.hs b/src/System/Path/WildMatch.hs
deleted file mode 100644
index cdb15de..0000000
--- a/src/System/Path/WildMatch.hs
+++ /dev/null
@@ -1,102 +0,0 @@
-{- Copyright (C) 2006 John Goerzen <jgoerzen at complete.org>
-
-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 : System.Path.WildMatch
- Copyright : Copyright (C) 2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Matching filenames with wildcards. See also "System.Path.Glob" for
-support for generating lists of files based on wildcards.
-
-Inspired by fnmatch.py, part of the Python standard library.
-
-Written by John Goerzen, jgoerzen\@complete.org
-
-The input wildcard for functions in this module is expected to be in
-the standard style of Posix shells.
-
-That is:
-
->? matches exactly one character
->\* matches zero or more characters
->[list] matches any character in list
->[!list] matches any character not in the list
-
-The returned regular expression will always end in \$ but never begins
-with ^, making it suitable for appending to the end of paths. If you want to
-match a given filename directly, you should prepend the ^ character to the
-returned value from this function.
-
-Please note:
-
-* Neither the path separator (the slash or backslash) nor the period carry
-any special meaning for the functions in this module. That is, @*@ will
-match @\/@ in a filename. If this is not the behavior you want, you probably
-want "System.Path.Glob" instead of this module.
-
-* Unlike the Unix shell, filenames that begin with a period are not ignored
-by this module. That is, @*.txt@ will match @.test.txt at .
-
-* This module does not current permit escaping of special characters.
--}
-
-module System.Path.WildMatch (-- * Wildcard matching
- wildCheckCase,
- wildToRegex)
- where
-
-import Text.Regex
-import Data.String.Utils
-
-{- | Convert a wildcard to an (uncompiled) regular expression.
-
--}
-wildToRegex :: String -> String
-wildToRegex i = convwild i ++ "$"
-
-{- | Check the given name against the given pattern, being case-sensitive.
-
-The given pattern is forced to match the given name starting at the beginning.
- -}
-wildCheckCase :: String -- ^ The wildcard pattern to use as the base
- -> String -- ^ The filename to check against it
- -> Bool -- ^ Result
-wildCheckCase patt name =
- case matchRegex (mkRegex $ "^" ++ wildToRegex patt) name of
- Nothing -> False
- Just _ -> True
-
--- This is SO MUCH CLEANER than the python implementation!
-convwild :: String -> String
-convwild [] = []
-convwild ('*':xs) = ".*" ++ convwild xs
-convwild ('?':xs) = "." ++ convwild xs
-convwild ('[':'!':xs) = "[^" ++ convpat xs
-convwild ('[':xs) = '[' : convpat xs
-convwild ('.':xs) = "\\." ++ convwild xs
-convwild (x:xs) = escapeRe [x] ++ convwild xs
-
-convpat :: String -> String
-convpat ('\\':xs) = "\\\\" ++ convpat xs
-convpat (']':xs) = ']' : convwild xs
-convpat (x:xs) = x : convpat xs
-convpat [] = []
diff --git a/src/System/Posix/Consts.hs b/src/System/Posix/Consts.hs
deleted file mode 100644
index 0e5559d..0000000
--- a/src/System/Posix/Consts.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# LANGUAGE CPP #-}
-{- Posix consts not included with Haskell
-Copyright (C) 2005 John Goerzen <jgoerzen at complete.org>
-
-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 : System.Posix.Consts
- Copyright : Copyright (C) 2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Exports some POSIX constants and functions that are not exported in fptools
-by default.
-
--}
-
-module System.Posix.Consts where
-import System.Posix.Types
-
-blockSpecialMode :: FileMode
-blockSpecialMode = 0o0060000
-
-characterSpecialMode :: FileMode
-characterSpecialMode = 0o0020000
-
-namedPipeMode :: FileMode
-namedPipeMode = 0o0010000
-
-regularFileMode :: FileMode
-regularFileMode = 0o0100000
-
-directoryMode :: FileMode
-directoryMode = 0o0040000
-
-fileTypeModes :: FileMode
-fileTypeModes = 0o00170000
-
-socketMode :: FileMode
-socketMode = 0o0140000
-
-symbolicLinkMode :: FileMode
-symbolicLinkMode = 0o0120000
-
-
diff --git a/src/System/Time/ParseDate.hs b/src/System/Time/ParseDate.hs
deleted file mode 100644
index 354b7c0..0000000
--- a/src/System/Time/ParseDate.hs
+++ /dev/null
@@ -1,284 +0,0 @@
-{- |
- Module : System.Time.ParseDate
- Copyright : (c) by Björn Bringert
- License : GPL2
-
- Maintainer : Björn Bringert
- Stability : provisional
- Portability : portable
-
-Utility for parsing dates.
--}
-module System.Time.ParseDate (parseCalendarTime) where
-
-import Control.Monad (liftM)
-import Data.Char (isSpace)
-import System.Locale
-import System.Time
-import Text.ParserCombinators.Parsec
-
-{- | 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 ::
- TimeLocale -- ^ Time locale
- -> String -- ^ Date format
- -> String -- ^ String to parse
- -> Maybe CalendarTime -- ^ 'Nothing' if parsing failed.
-parseCalendarTime l fmt s =
- case runParser parser epoch "<date string>" s of
- 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?
--- FIXME: set ctYDay
--- FIXME: set ctIsDST
--- FIXME: missing formats from GNU date(1):
--- %F same as %Y-%m-%d
--- %g the 2-digit year corresponding to the %V week number
--- %G the 4-digit year corresponding to the %V week number
--- %N nanoseconds (000000000..999999999)
--- %P locale's lower case am or pm indicator (blank in many locales)
--- %z RFC-822 style numeric timezone (-0500) (a nonstandard extension)
-pCalendarTime :: TimeLocale -> String -> GenParser Char CalendarTime ()
-pCalendarTime l fmt = doFmt fmt
- where
- -- not padded
- -- FIXME: implement
- doFmt ('%':'-':cs) = doFmt ('%':cs)
- -- space padded
- -- FIXME: implement
- doFmt ('%':'_':cs) = doFmt ('%':cs)
- 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
- decode 'b' = (parseEnum $ map snd $ months l) >>= setMonth
- decode 'B' = (parseEnum $ map fst $ months l) >>= setMonth
- decode 'c' = doFmt (dateTimeFmt l)
- decode 'C' = read2 >>= \c -> updateYear (\y -> c * 100 + y `rem` 100)
- decode 'd' = read2 >>= \day -> if day > 31 || day < 1
- then fail $ "Invalid day " ++ (show day)
- else setDay day
- decode 'D' = doFmt "%m/%d/%y"
- decode 'e' = read2 >>= setDay
- decode 'h' = decode 'b'
- decode 'H' = read2 >>= setHour
- decode 'I' = read2 >>= setHour12
- decode 'j' = read3 >>= setYDay
- decode 'k' = read2 >>= setHour
- decode 'l' = read2 >>= setHour12
- decode 'm' = read2 >>= \mon -> if (mon-1) > fromEnum (maxBound :: Month)
- then fail $ "Invalid month " ++ (show mon)
- else setMonth (toEnum (mon-1))
- decode 'M' = read2 >>= setMin
- -- 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
- decode 'r' = doFmt (time12Fmt l)
- decode 'R' = doFmt "%H:%M"
- -- FIXME: implement %s.
- -- FIXME: implement %s in formatCalendarTime
- decode 's' = int >> return ()
- decode 'S' = read2 >>= setSec
- -- FIXME: strptime(3) accepts "arbitrary whitespace" for %t
- 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.
- decode 'U' = read2 >> return ()
- -- 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,
- -- need to change formatCalendarTime too
- decode 'Y' = int >>= setYear
- -- FIXME: maybe 04 should be 2004, not 1904?
- decode 'y' = read2 >>= \c -> updateYear (\y -> (y `quot` 100) * 100 + c)
- -- FIXME: are timezone names always [A-Z]+ ?
- -- 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))
- -- 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
- }
-
-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)
- where from12 h = if h == 12 then 0 else h
-
-read2, read3 :: GenParser Char st Int
-read2 = readN 2
-read3 = readN 3
-
--- | 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 =
- liftM read (spaces >> choice [try (count m digit) | m <- [n,n-1..1]])
-
-int :: GenParser Char st Int
-int = liftM read (many1 digit)
-
-sign :: GenParser Char st Int
-sign = (char '+' >> return 1) <|> (char '-' >> return (-1))
diff --git a/src/System/Time/Utils.hs b/src/System/Time/Utils.hs
deleted file mode 100644
index 2b4e271..0000000
--- a/src/System/Time/Utils.hs
+++ /dev/null
@@ -1,144 +0,0 @@
-{- arch-tag: Time utilities main file
-Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
-
-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 : System.Time.Utils
- Copyright : Copyright (C) 2004-2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-This module provides various Haskell utilities for dealing with times and
-dates.
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module System.Time.Utils(
- timelocal,
- timegm,
- timeDiffToSecs,
- epoch,
- epochToClockTime,
- clockTimeToEpoch,
- renderSecs, renderTD
- )
-where
-import System.Time
-import Data.Ratio
-
-{- | January 1, 1970, midnight, UTC, represented as a CalendarTime. -}
-epoch :: CalendarTime
-epoch = CalendarTime { ctYear = 1970, ctMonth = January,
- ctDay = 1, ctHour = 0, ctMin = 0, ctSec = 0,
- ctPicosec = 0, ctWDay = Thursday, ctYDay = 0,
- ctTZName = "UTC", ctTZ = 0, ctIsDST = False}
-
-{- | Converts the specified CalendarTime (see System.Time) to seconds-since-epoch time.
-
-This conversion does respect the timezone specified on the input object.
-If you want a conversion from UTC, specify ctTZ = 0 and ctIsDST = False.
-
-When called like that, the behavior is equivolent to the GNU C function
-timegm(). Unlike the C library, Haskell's CalendarTime supports
-timezone information, so if such information is specified, it will impact
-the result.
--}
-
-timegm :: CalendarTime -> Integer
-timegm ct =
- timeDiffToSecs (diffClockTimes (toClockTime ct) (toClockTime epoch))
-
-{- | Converts the specified CalendarTime (see System.Time) to
-seconds-since-epoch format.
-
-The input CalendarTime is assumed to be the time as given in your local
-timezone. All timezone and DST fields in the object are ignored.
-
-This behavior is equivolent to the timelocal() and mktime() functions that
-C programmers are accustomed to.
-
-Please note that the behavior for this function during the hour immediately
-before or after a DST switchover may produce a result with a different hour
-than you expect.
--}
-
-timelocal :: CalendarTime -> IO Integer
-timelocal ct =
- do guessct <- toCalendarTime guesscl
- let newct = ct {ctTZ = ctTZ guessct}
- return $ timegm newct
- where guesscl = toClockTime ct
-
-{- | Converts the given timeDiff to the number of seconds it represents.
-
-Uses the same algorithm as normalizeTimeDiff in GHC. -}
-timeDiffToSecs :: TimeDiff -> Integer
-timeDiffToSecs td =
- (fromIntegral $ tdSec td) +
- 60 * ((fromIntegral $ tdMin td) +
- 60 * ((fromIntegral $ tdHour td) +
- 24 * ((fromIntegral $ tdDay td) +
- 30 * ((fromIntegral $ tdMonth td) +
- 365 * (fromIntegral $ tdYear td)))))
-
-{- | Converts an Epoch time represented with an arbitrary Real to a ClockTime.
-This input could be a CTime from Foreign.C.Types or an EpochTime from
-System.Posix.Types. -}
-epochToClockTime :: Real a => a -> ClockTime
-epochToClockTime x =
- TOD seconds secfrac
- where ratval = toRational x
- seconds = floor ratval
- secfrac = floor $ (ratval - (seconds % 1) ) * picosecondfactor
- picosecondfactor = 10 ^ 12
-
-{- | Converts a ClockTime to something represented with an arbitrary Real.
-The result could be treated as a CTime from Foreign.C.Types or EpochTime from
-System.Posix.Types. The inverse of 'epochToClockTime'.
-
-Fractions of a second are not preserved by this function. -}
-clockTimeToEpoch :: Num a => ClockTime -> a
-clockTimeToEpoch (TOD sec _) = fromInteger sec
-
-{- | Render a number of seconds as a human-readable amount. Shows the two
-most significant places. For instance:
-
->renderSecs 121 = "2m1s"
-
-See also 'renderTD' for a function that works on a TimeDiff.
--}
-renderSecs :: Integer -> String
-renderSecs i = renderTD $ diffClockTimes (TOD i 0) (TOD 0 0)
-
-{- | Like 'renderSecs', but takes a TimeDiff instead of an integer second
-count. -}
-renderTD :: TimeDiff -> String
-renderTD itd =
- case workinglist of
- [] -> "0s"
- _ -> concat . map (\(q, s) -> show q ++ [s]) $ workinglist
- where td = normalizeTimeDiff itd
- suffixlist = "yMdhms"
- quantlist = (\(TimeDiff y mo d h m s _) -> [y, mo, d, h, m, s]) td
- zippedlist = zip quantlist suffixlist
- -- Drop all leading elements that are 0, then take at most 2
- workinglist = take 2 . dropWhile (\(q, _) -> q == 0) $ zippedlist
-
diff --git a/src/Text/ParserCombinators/Parsec/Utils.hs b/src/Text/ParserCombinators/Parsec/Utils.hs
deleted file mode 100644
index 35a7113..0000000
--- a/src/Text/ParserCombinators/Parsec/Utils.hs
+++ /dev/null
@@ -1,111 +0,0 @@
-{- arch-tag: Parsec utilities
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-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 : Text.ParserCombinators.Parsec.Utils
- Copyright : Copyright (C) 2004 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Written by John Goerzen, jgoerzen\@complete.org
-
--}
-
-module Text.ParserCombinators.Parsec.Utils(-- * Generalized Utilities
- -- | These functions are generalized versions of
- -- ones you might see in the Char parser.
- GeneralizedToken, GeneralizedTokenParser,
- togtok, tokeng, satisfyg, oneOfg, noneOfg,
- specificg, allg,
- -- * Other Utilities
- notMatching
- ) where
-
-import Text.ParserCombinators.Parsec
-
-type GeneralizedToken a = (SourcePos, a)
-type GeneralizedTokenParser a st b = GenParser (GeneralizedToken a) st b
-
-{- | Generate (return) a 'GeneralizedToken'. -}
-togtok :: a -> GenParser b st (GeneralizedToken a)
-togtok tok = do
- x <- getPosition
- return (x, tok)
-
-{- | Retrieve the next token from a 'GeneralizedToken' stream.
- The given function should return the value to use, or Nothing
- to cause an error. -}
-tokeng :: (Show a) => (a -> Maybe b) -> GeneralizedTokenParser a st b
-tokeng test =
- token (show . snd) (fst) (test . snd)
-
-{- | A shortcut to 'tokeng'; the test here is just a function that returns
-a Bool. If the result is true; return that value -- otherwise, an error.
--}
-satisfyg :: (Show a) => (a -> Bool) -> GeneralizedTokenParser a st a
-satisfyg test = tokeng (\t -> if test t then Just t else Nothing)
-
-{- | Matches one item in a list and returns it. -}
-oneOfg :: (Eq a, Show a) => [a] -> GeneralizedTokenParser a st a
-oneOfg i = satisfyg (\x -> elem x i)
-
-{- | Matches all items and returns them -}
-allg :: (Show a) => GeneralizedTokenParser a st [a]
-allg = many $ satisfyg (\_ -> True)
-
-{- | Matches one item not in a list and returns it. -}
-noneOfg :: (Eq a, Show a) => [a] -> GeneralizedTokenParser a st a
-noneOfg l = satisfyg (\x -> not (elem x l))
-
-{- | Matches one specific token and returns it. -}
-specificg :: (Eq a, Show a) => a -> GeneralizedTokenParser a st a
-specificg i = satisfyg (== i) <?> show i
-
-{- Matches a list of tokens and returns it. -}
-{-
-listg :: (Eq a, Show a) => [GeneralizedToken a] -> GeneralizedTokenParser a st [GeneralizedToken a]
-listg l = tokens (show . map fst) nextpos l
- where
- tokpos = fst
- nextpos
- nextposs _ _ (tok:toks) = tokpos tok
- nextposs _ tok [] = tokpos tok
- nextpos pos x = nextposs pos [x]
--}
-
-{- | Running @notMatching p msg@ will try to apply parser p.
-If it fails, returns (). If it succeds, cause a failure and raise
-the given error message. It will not consume input in either case. -}
-notMatching :: GenParser a b c -> String -> GenParser a b ()
-notMatching p errormsg =
- let maybeRead = try (do
- x <- p
- return (Just x)
- )
- <|> return Nothing
- workerFunc = do
- x <- maybeRead
- case x of
- Nothing -> return ()
- Just _ -> unexpected errormsg
- in
- try workerFunc
-
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list