diff --git a/Atom.hs b/Atom.hs --- a/Atom.hs +++ b/Atom.hs @@ -13,11 +13,13 @@ toPackedString ) where +import System.IO.Unsafe (unsafePerformIO) + import Data.Generics import Data.Monoid import Foreign import Data.List(sort) -import qualified Data.HashTable as HT +import qualified Data.HashTable.IO as HT import Data.Binary import PackedString @@ -29,12 +31,12 @@ mconcat xs = toAtom $ concatPS (map fromAtom xs) {-# NOINLINE table #-} -table :: HT.HashTable PackedString Atom -table = unsafePerformIO (HT.new (==) (fromIntegral . hashPS)) +table :: HT.CuckooHashTable PackedString Atom +table = unsafePerformIO HT.new {-# NOINLINE reverseTable #-} -reverseTable :: HT.HashTable Int PackedString -reverseTable = unsafePerformIO (HT.new (==) (fromIntegral)) +reverseTable :: HT.CuckooHashTable Int PackedString +reverseTable = unsafePerformIO HT.new {-# NOINLINE intPtr #-} intPtr :: Ptr Int @@ -51,8 +53,13 @@ readsPrec _ s = [ (fromString s,"") ] --readsPrec p s = [ (fromString x,y) | (x,y) <- readsPrec p s] -toPackedString atom = atomToPS atom +toPackedString :: Atom -> PackedString +toPackedString = atomToPS + +toString :: Atom -> String toString atom = unpackPS $ toPackedString atom + +atomIndex :: Atom -> Int atomIndex (Atom x) = x instance Binary Atom where diff --git a/Boolean/Boolean.hs b/Boolean/Boolean.hs --- a/Boolean/Boolean.hs +++ b/Boolean/Boolean.hs @@ -18,9 +18,10 @@ import Boolean.Algebra import Prelude hiding((&&),(||),not,and,or,any,all) import qualified Prelude +import Control.Applicative import Control.Monad import Data.List hiding(and,or) -import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec hiding ((<|>)) @@ -43,12 +44,19 @@ fmap f (BoolOr xs) = BoolOr (map (fmap f) xs) fmap f (BoolJust x) = BoolJust (f x) +instance Applicative Boolean where + pure = return + (<*>) = ap instance Monad Boolean where --a >> b = a && b a >>= f = dropBoolean (fmap f a) return x = BoolJust x fail _ = false + +instance Alternative Boolean where + empty = mzero + (<|>) = mplus instance MonadPlus Boolean where a `mplus` b = a || b diff --git a/CacheIO.hs b/CacheIO.hs --- a/CacheIO.hs +++ b/CacheIO.hs @@ -23,6 +23,7 @@ ) where +import Control.Applicative import Control.Monad.Trans import Control.Concurrent import Control.Monad @@ -62,6 +63,10 @@ instance Functor CacheIO where fmap = liftM + +instance Applicative CacheIO where + pure = return + (<*>) = ap instance Monad CacheIO where {-# INLINE (>>=) #-} diff --git a/CircularBuffer.hs b/CircularBuffer.hs --- a/CircularBuffer.hs +++ b/CircularBuffer.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ParallelListComp, PatternGuards #-} +{-# LANGUAGE ParallelListComp, PatternGuards, FlexibleContexts #-} module CircularBuffer( CircularBuffer, new, diff --git a/Doc/DocLike.hs b/Doc/DocLike.hs --- a/Doc/DocLike.hs +++ b/Doc/DocLike.hs @@ -2,6 +2,7 @@ module Doc.DocLike where -- import Data.Monoid hiding ((<>)) +import Prelude hiding ((<$>)) import Control.Monad.Reader() import Data.List import qualified Text.PrettyPrint.HughesPJ as P diff --git a/Gale/Gale.hs b/Gale/Gale.hs --- a/Gale/Gale.hs +++ b/Gale/Gale.hs @@ -33,6 +33,7 @@ import Data.Binary.Put import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString as BS +import Control.Applicative ((<|>)) import Atom import Control.Monad.Error (when, replicateM) diff --git a/Gale/Proto.hs b/Gale/Proto.hs --- a/Gale/Proto.hs +++ b/Gale/Proto.hs @@ -13,6 +13,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Binary.Get import Data.Word +import Control.Applicative ((<|>)) pubkey_magic3 :: [Word8] diff --git a/Gale/Puff.hs b/Gale/Puff.hs --- a/Gale/Puff.hs +++ b/Gale/Puff.hs @@ -170,7 +170,7 @@ _ -> fail $ "fragment not found: " ++ toString s mergeFrags :: FragmentList -> FragmentList -> FragmentList -mergeFrags fla flb = fla ++ [f|f@(s,_) <- flb, s `notElem` fsts fla] +mergeFrags fla flb = fla ++ [f | f@(s,_) <- flb, s `notElem` fsts fla] {- @@ -181,7 +181,7 @@ -} getFragmentStrings :: HasFragmentList fl => fl -> Atom -> [PackedString] -getFragmentStrings fl s = [v|(n,FragmentText v) <- getFragmentList fl, n == s] +getFragmentStrings fl s = [v | (n,FragmentText v) <- getFragmentList fl, n == s] getFragmentForceStrings :: HasFragmentList fl => fl -> Atom -> [PackedString] getFragmentForceStrings fl s = concatMap f [v | (n,v) <- getFragmentList fl, n == s] where diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverlappingInstances, PatternGuards, ScopedTypeVariables #-} +{-# LANGUAGE OverlappingInstances, PatternGuards, ScopedTypeVariables, FlexibleContexts #-} module Main(main) where import Data.Char @@ -14,7 +14,7 @@ import Data.Array.IO import Data.IORef import Data.Unique -import qualified Data.HashTable as Hash +import qualified Data.HashTable.IO as Hash import qualified System.Posix as Posix import qualified System.Posix.IO as PosixIO import System.IO @@ -40,6 +40,7 @@ import Help import KeyName import MyLocale +import qualified OldHash import Options import PackedString import Prelude hiding((&&),(||),not,and,or,any,all) @@ -241,7 +242,7 @@ presenceViewUser :: String -> PresenceData -> Widget presenceViewUser user pl = widgetText pt where - pt = user ++ ":\n" ++ indentLines 2 (unlines $ buildTableLL ([b|(a,b) <- pl, a == user])) + pt = user ++ ":\n" ++ indentLines 2 (unlines $ buildTableLL ([b | (a,b) <- pl, a == user])) @@ -356,8 +357,8 @@ Status.setF "Gale.Presence" (readVal myPresence) - idleHash <- Hash.new (==) Hash.hashString - puffRRHash <- Hash.new (==) Hash.hashString + idleHash <- Hash.new :: IO (Hash.CuckooHashTable String ClockTime) -- (==) OldHash.hashString + puffRRHash <- Hash.new :: IO (Hash.CuckooHashTable String [String]) -- (==) OldHash.hashString presenceWidget <- widgetScroll (newSVarWidget presence_r (presenceView idleHash)) @@ -387,7 +388,7 @@ return [(x,puffHeight p xs)| x@(_,p) <- ps, f p] - buf_size <- newCacheIO $ cacheIO getFilteredPuffs >>= \ps -> return $ sum [x| (_,x) <- ps] + buf_size <- newCacheIO $ cacheIO getFilteredPuffs >>= \ps -> return $ sum [x | (_,x) <- ps] let statusHeight = do fs <- readVal filter_r return $ if length fs == 0 then 1 else 2 @@ -436,7 +437,7 @@ Nothing -> return () Just pn -> do let np@(a',(b',_)) = (author, (maybe "unknown" unpackPS (getFragmentString p (fromString "id/instance")), unpackPS pn)) - mapVal presence_r (\xs -> (np:[x| x@(a,(b,_)) <- xs, a /= a' || b /= b'])) + mapVal presence_r (\xs -> (np:[x | x@(a,(b,_)) <- xs, a /= a' || b /= b'])) case getFragmentTime p (fromString "status.idle") of Nothing -> return () Just pn | pn == epoch -> Hash.delete idleHash author >> getClockTime >>= Hash.insert idleHash author @@ -448,7 +449,7 @@ Just n | [Category (cat,dom)] <- cats p, dom == domain, ("_gale.rr." ++ name) `isPrefixOf` cat -> do mv <- Hash.lookup puffRRHash (drop (10 + length name) cat) Hash.delete puffRRHash (drop (10 + length name) cat) - Hash.insert puffRRHash (drop (10 + length name) cat) (unpackPS n:concat (maybeToMonad mv)) + Hash.insert puffRRHash (drop (10 + length name) cat) (unpackPS n:concat (maybeToMonad mv :: [[String]])) _ -> return () @@ -931,7 +932,7 @@ Posix.setFileCreationMask om return v -noBodyWords fl = [x|x@(n,_) <- fl, n /= f_messageBody, n /= f_messageKeyword] +noBodyWords fl = [x |x@(n,_) <- fl, n /= f_messageBody, n /= f_messageKeyword] withNBRWorkaround f = do System.IO.stdin `seq` return () diff --git a/OldHash.hs b/OldHash.hs new file mode 100644 --- /dev/null +++ b/OldHash.hs @@ -0,0 +1,58 @@ +module OldHash (hashInt, hashString) where + +import Data.Bits (shiftR) +import Data.Char (ord) +import Data.Int (Int32, Int64) +import Data.List (foldl') + +golden :: Int32 +golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 +-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 +-- but that has bad mulHi properties (even adding 2^32 to get its inverse) +-- Whereas the above works well and contains no hash duplications for +-- [-32767..65536] + +hashInt32 :: Int32 -> Int32 +hashInt32 x = mulHi x golden + x + +hashInt :: Int -> Int32 +hashInt x = hashInt32 (fromIntegral x) + +-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply +mulHi :: Int32 -> Int32 -> Int32 +mulHi a b = fromIntegral (r `shiftR` 32) + where r :: Int64 + r = fromIntegral a * fromIntegral b + +-- | A sample hash function for Strings. We keep multiplying by the +-- golden ratio and adding. The implementation is: +-- +-- > hashString = foldl' f golden +-- > where f m c = fromIntegral (ord c) * magic + hashInt32 m +-- > magic = 0xdeadbeef +-- +-- Where hashInt32 works just as hashInt shown above. +-- +-- Knuth argues that repeated multiplication by the golden ratio +-- will minimize gaps in the hash space, and thus it's a good choice +-- for combining together multiple keys to form one. +-- +-- Here we know that individual characters c are often small, and this +-- produces frequent collisions if we use ord c alone. A +-- particular problem are the shorter low ASCII and ISO-8859-1 +-- character strings. We pre-multiply by a magic twiddle factor to +-- obtain a good distribution. In fact, given the following test: +-- +-- > testp :: Int32 -> Int +-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls +-- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] +-- > hs = foldl' f golden +-- > f m c = fromIntegral (ord c) * k + hashInt32 m +-- > n = 100000 +-- +-- We discover that testp magic = 0. + +hashString :: String -> Int32 +hashString = foldl' f golden + where f m c = fromIntegral (ord c) * magic + hashInt32 m + magic = 0xdeadbeef diff --git a/PackedString.hs b/PackedString.hs --- a/PackedString.hs +++ b/PackedString.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Data.PackedString @@ -55,6 +55,8 @@ import qualified Data.ByteString.UTF8 as U import qualified Data.String.UTF8 as US import Data.Bits +import GHC.Generics (Generic) +import Data.Hashable import Data.Monoid instance Monoid PackedString where @@ -69,12 +71,13 @@ -- efficient operations. A 'PackedString' contains full Unicode 'Char's. -- much like UTF8 ByteString newtype PackedString = PS { unPS :: U.ByteString } - deriving(Typeable,Binary,Eq,Ord) + deriving(Typeable,Binary,Eq,Ord,Generic) instance Show PackedString where showsPrec p (PS ps) = showsPrec p (US.fromRep ps) +instance Hashable PackedString -- ----------------------------------------------------------------------------- -- Constructor functions diff --git a/RSA.hsc b/RSA.hsc --- a/RSA.hsc +++ b/RSA.hsc @@ -1,4 +1,4 @@ -{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, CPP #-} module RSA( EvpPkey, decryptAll, @@ -17,6 +17,8 @@ import ErrorLog import Foreign import Numeric(showHex) + +import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString as BS diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -20,7 +20,7 @@ info verb $ scs (cmdspec cmd) ++ " > " ++ outf (_,_,_,pid) <- createProcess cmd { std_out = UseHandle out } r <- waitForProcess pid - when (r /= ExitSuccess) $ die $ scs (cmdspec cmd) ++ ": " ++ show r + when (r /= ExitSuccess) $ Distribution.Simple.Utils.die $ scs (cmdspec cmd) ++ ": " ++ show r scs (ShellCommand s) = s scs (RawCommand c a) = unwords (c:a) diff --git a/SimpleParser.hs b/SimpleParser.hs --- a/SimpleParser.hs +++ b/SimpleParser.hs @@ -21,12 +21,11 @@ module SimpleParser where -import Data.Char +import Control.Applicative hiding (many) import Control.Monad +import Data.Char import Data.List -infixr 1 <|> - -- very simple parser combinators with failure but limited non-determinism. -- designed for parsing single lines or simple expressions. -- advantages: pure haskell 98, simple. @@ -42,10 +41,18 @@ (MkP p) >>= q = MkP $ \s -> (maybe Nothing (\(v,s') -> app (q v) s') (p s)) fail _ = MkP $ \_ -> Nothing +instance Applicative (GenParser c) where + pure = return + (<*>) = ap + instance Functor (GenParser c) where fmap = liftM +instance Alternative (GenParser c) where + empty = mzero + p <|> q = MkP $ \s -> maybe (app q s) Just (app p s) + instance MonadPlus (GenParser c) where mzero = MkP (\_ -> Nothing) mplus = (<|>) @@ -100,8 +107,6 @@ f _ = Nothing satisfy = sat - -p <|> q = MkP $ \s -> maybe (app q s) Just (app p s) many :: GenParser c a -> GenParser c [a] many p = (p >>= \x -> many p >>= \xs -> return (x:xs)) <|> return [] diff --git a/Text/ParserCombinators/ReadP/ByteString.hs b/Text/ParserCombinators/ReadP/ByteString.hs --- a/Text/ParserCombinators/ReadP/ByteString.hs +++ b/Text/ParserCombinators/ReadP/ByteString.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, TypeOperators, ExistentialQuantification, PolymorphicComponents #-} +{-# LANGUAGE CPP, NoImplicitPrelude, TypeOperators, ExistentialQuantification, PolymorphicComponents, DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : Text.ParserCombinators.ReadP.ByteString @@ -71,10 +71,11 @@ ) where +import Control.Applicative (Alternative(empty, (<|>)), Applicative(pure, (<*>))) import Control.Monad ( MonadPlus(..), liftM2, Monad, (>>), (>>=), - return, fail, Functor, fmap, replicateM ) + return, fail, Functor, fmap, replicateM, void, ap ) import Prelude ( (+), (-), (++), Int, Bool(..), (==), error, - fromInteger, (.), (>=), compare, Ordering(..) ) + (.), (>=), compare, Ordering(..), const ) import Data.Word (Word8) import Data.ByteString (ByteString,length,take,takeWhile,null) @@ -107,7 +108,14 @@ | Fail | Result a (P a) | Final [(a,ByteString)] -- invariant: list is non-empty! + deriving Functor +-- Applicative + +instance Applicative P where + pure = return + (<*>) = ap + -- Monad, MonadPlus instance Monad (P) where @@ -121,6 +129,10 @@ fail _ = Fail +instance Alternative P where + empty = mzero + (<|>) = mplus + instance MonadPlus (P) where mzero = Fail @@ -164,11 +176,19 @@ instance Functor (ReadP) where fmap h (R f) = R (\k -> f (k . h)) +instance Applicative (ReadP) where + pure = return + (<*>) = ap + instance Monad (ReadP) where return x = R (\k -> k x) - fail _ = R (\_ -> Fail) + fail _ = R (const Fail) R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) +instance Alternative ReadP where + empty = mzero + (<|>) = mplus + instance MonadPlus (ReadP) where mzero = pfail mplus = (+++) @@ -212,7 +232,7 @@ pfail :: ReadP a -- ^ Always fails. -pfail = R (\_ -> Fail) +pfail = R (const Fail) (+++) :: ReadP a -> ReadP a -> ReadP a -- ^ Symmetric choice. @@ -254,8 +274,8 @@ gath 0 _ | False = Fail gath l (Skip n f) = Skip n (gath (l+n) f) gath _ Fail = Fail - gath l (Look f) = Look (\s -> gath l (f s)) - gath l (Result k p) = k (l) `mplus` gath l p + gath l (Look f) = Look (gath l . f) + gath l (Result k p) = k l `mplus` gath l p gath _ (Final _) = error "do not use readS_to_P in gather or countsym!" -- --------------------------------------------------------------------------- @@ -309,12 +329,12 @@ skipSpaces :: ReadP () -- ^ Skips all whitespace. -skipSpaces = munch isSpaceWord8 >> return () +skipSpaces = void (munch isSpaceWord8) count :: Int -> ReadP a -> ReadP [a] -- ^ @count n p@ parses @n@ occurrences of @p@ in sequence. A list of -- results is returned. -count n p = replicateM n p +count = replicateM between :: ReadP open -> ReadP close -> ReadP a -> ReadP a -- ^ @between open close p@ parses @open@, followed by @p@ and finally @@ -331,7 +351,7 @@ optional :: ReadP a -> ReadP () -- ^ @optional p@ optionally parses @p@ and always returns @()@. -optional p = (p >> return ()) +++ return () +optional p = void p +++ return () many :: ReadP a -> ReadP [a] -- ^ Parses zero or more occurrences of the given parser. @@ -343,7 +363,7 @@ skipMany :: ReadP a -> ReadP () -- ^ Like 'many', but discards the result. -skipMany p = many p >> return () +skipMany p = void (many p) skipMany1 :: ReadP a -> ReadP () -- ^ Like 'many1', but discards the result. @@ -359,15 +379,18 @@ -- Returns a list of values returned by @p@. sepBy1 p sep = liftM2 (:) p (many (sep >> p)) +endByDo :: ReadP a -> ReadP sep -> ReadP a +endByDo p sep = do x <- p ; sep ; return x + endBy :: ReadP a -> ReadP sep -> ReadP [a] -- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended -- by @sep@. -endBy p sep = many (do x <- p ; sep ; return x) +endBy p sep = many (endByDo p sep) endBy1 :: ReadP a -> ReadP sep -> ReadP [a] -- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended -- by @sep@. -endBy1 p sep = many1 (do x <- p ; sep ; return x) +endBy1 p sep = many1 (endByDo p sep) chainr :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a -- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. @@ -404,7 +427,7 @@ -- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ -- succeeds. Returns a list of values returned by @p@. manyTill p end = scan - where scan = (end >> return []) <++ (liftM2 (:) p scan) + where scan = (end >> return []) <++ liftM2 (:) p scan -- --------------------------------------------------------------------------- -- Converting between ReadP and Read diff --git a/ginsu.cabal b/ginsu.cabal --- a/ginsu.cabal +++ b/ginsu.cabal @@ -1,6 +1,6 @@ -- vim:et Name: ginsu -Version: 0.8.1 +Version: 0.8.1.1 Copyright: 2002-2009 John Meacham 2011-2012 Dylan Simon Author: John Meacham @@ -14,7 +14,7 @@ Category: Network,Console Build-Type: Custom Cabal-Version: >= 1.6 -tested-with: GHC == 6.12.3, GHC == 7.6.1 +tested-with: GHC == 7.8.4, GHC == 7.10.1 extra-source-files: configure ginsu.buildinfo.in @@ -64,6 +64,7 @@ KeyHelpTable KeyName MyLocale + OldHash Options PackedString Paths_ginsu @@ -96,5 +97,7 @@ syb, network, parsec, - process + process, + hashtables, + hashable Extra-Libraries: ssl crypto