dlist-0.5/0000755000175000000120000000000011217265402011314 5ustar donswheeldlist-0.5/dlist.cabal0000644000175000000120000000202311217265402013414 0ustar donswheelName: dlist Version: 0.5 Synopsis: Differences lists Description: Differences lists: a list-like type supporting O(1) append. This is particularly useful for efficient logging and pretty printing, (e.g. with the Writer monad), where list append quickly becomes too expensive. Category: Data License: BSD3 License-file: LICENSE Author: Don Stewart Maintainer: dons@galois.com Copyright: 2006-9 Don Stewart Homepage: http://code.haskell.org/~dons/code/dlist/ extra-source-files: README tests/Properties.hs tests/Parallel.hs build-type: Simple cabal-version: >= 1.2 flag applicative-in-base Library Build-Depends: base Ghc-options: -O2 -Wall Extensions: CPP Exposed-modules: Data.DList if flag(applicative-in-base) build-depends: base >= 2.0 && < 5 cpp-options: -DAPPLICATIVE_IN_BASE else build-depends: base < 2.0 dlist-0.5/Setup.lhs0000644000175000000120000000011311217265402013117 0ustar donswheel#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMaindlist-0.5/Data/0000755000175000000120000000000011217265402012165 5ustar donswheeldlist-0.5/Data/DList.hs0000644000175000000120000001271611217265402013547 0ustar donswheel----------------------------------------------------------------------------- -- | -- Module : Data.DList -- Copyright : (c) Don Stewart 2006-2007 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : dons@cse.unsw.edu.au -- Stability : experimental -- Portability : portable (Haskell 98) -- -- Difference lists: a data structure for O(1) append on lists. -- ----------------------------------------------------------------------------- module Data.DList ( DList(..) -- abstract, instance Monoid, Functor, Applicative, Monad, MonadPlus -- * Construction ,fromList -- :: [a] -> DList a ,toList -- :: DList a -> [a] -- * Basic functions ,empty -- :: DList a ,singleton -- :: a -> DList a ,cons -- :: a -> DList a -> DList a ,snoc -- :: DList a -> a -> DList a ,append -- :: DList a -> DList a -> DList a ,concat -- :: [DList a] -> DList a ,replicate -- :: Int -> a -> DList a ,list -- :: b -> (a -> DList a -> b) -> DList a -> b ,head -- :: DList a -> a ,tail -- :: DList a -> DList a ,unfoldr -- :: (b -> Maybe (a, b)) -> b -> DList a ,foldr -- :: (a -> b -> b) -> b -> DList a -> b ,map -- :: (a -> b) -> DList a -> DList b -- * MonadPlus , maybeReturn ) where import Prelude hiding (concat, foldr, map, head, tail, replicate) import qualified Data.List as List import Control.Monad import Data.Monoid #ifdef APPLICATIVE_IN_BASE import Control.Applicative(Applicative(..)) #endif -- | A difference list is a function that given a list, returns the -- original contents of the difference list prepended at the given list -- -- This structure supports /O(1)/ append and snoc operations on lists, -- making it very useful for append-heavy uses, such as logging and -- pretty printing. -- -- For example, using DList as the state type when printing a tree with -- the Writer monad -- -- > import Control.Monad.Writer -- > import Data.DList -- > -- > data Tree a = Leaf a | Branch (Tree a) (Tree a) -- > -- > flatten_writer :: Tree x -> DList x -- > flatten_writer = snd . runWriter . flatten -- > where -- > flatten (Leaf x) = tell (singleton x) -- > flatten (Branch x y) = flatten x >> flatten y -- newtype DList a = DL { unDL :: [a] -> [a] } -- | Converting a normal list to a dlist fromList :: [a] -> DList a fromList = DL . (++) {-# INLINE fromList #-} -- | Converting a dlist back to a normal list toList :: DList a -> [a] toList = ($[]) . unDL {-# INLINE toList #-} -- | Create a difference list containing no elements empty :: DList a empty = DL id {-# INLINE empty #-} -- | Create difference list with given single element singleton :: a -> DList a singleton = DL . (:) {-# INLINE singleton #-} -- | /O(1)/, Prepend a single element to a difference list infixr `cons` cons :: a -> DList a -> DList a cons x xs = DL ((x:) . unDL xs) {-# INLINE cons #-} -- | /O(1)/, Append a single element at a difference list infixl `snoc` snoc :: DList a -> a -> DList a snoc xs x = DL (unDL xs . (x:)) {-# INLINE snoc #-} -- | /O(1)/, Appending difference lists append :: DList a -> DList a -> DList a append xs ys = DL (unDL xs . unDL ys) {-# INLINE append #-} -- | /O(spine)/, Concatenate difference lists concat :: [DList a] -> DList a concat = List.foldr append empty {-# INLINE concat #-} -- | /O(n)/, Create a difference list of the given number of elements replicate :: Int -> a -> DList a replicate n x = DL $ \xs -> let go m | m <= 0 = xs | otherwise = x : go (m-1) in go n {-# INLINE replicate #-} -- | /O(length dl)/, List elimination, head, tail. list :: b -> (a -> DList a -> b) -> DList a -> b list nill consit dl = case toList dl of [] -> nill (x : xs) -> consit x (fromList xs) -- | Return the head of the list head :: DList a -> a head = list (error "Data.DList.head: empty list") const -- | Return the tail of the list tail :: DList a -> DList a tail = list (error "Data.DList.tail: empty list") (flip const) -- | Unfoldr for difference lists unfoldr :: (b -> Maybe (a, b)) -> b -> DList a unfoldr pf b = case pf b of Nothing -> empty Just (a, b') -> cons a (unfoldr pf b') -- | Foldr over difference lists foldr :: (a -> b -> b) -> b -> DList a -> b foldr f b = List.foldr f b . toList {-# INLINE foldr #-} -- | Map over difference lists. map :: (a -> b) -> DList a -> DList b map f = foldr (cons . f) empty {-# INLINE map #-} instance Monoid (DList a) where mempty = empty mappend = append instance Functor DList where fmap = map {-# INLINE fmap #-} #ifdef APPLICATIVE_IN_BASE instance Applicative DList where pure = return (<*>) = ap #endif instance Monad DList where m >>= k -- = concat (toList (fmap k m)) -- = (concat . toList . fromList . List.map k . toList) m -- = concat . List.map k . toList $ m -- = List.foldr append empty . List.map k . toList $ m -- = List.foldr (append . k) empty . toList $ m = foldr (append . k) empty m {-# INLINE (>>=) #-} return x = singleton x {-# INLINE return #-} fail _ = empty {-# INLINE fail #-} instance MonadPlus DList where mzero = empty mplus = append -- Use this to convert Maybe a into DList a, or indeed into any other MonadPlus instance. maybeReturn :: MonadPlus m => Maybe a -> m a maybeReturn = maybe mzero return dlist-0.5/LICENSE0000644000175000000120000000275411217265402012331 0ustar donswheelCopyright Don Stewart 2006. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Don Stewart nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. dlist-0.5/README0000644000175000000120000000063711217265402012202 0ustar donswheelDLists: a Haskell list type supporting O(1) append and snoc Build instructions: $ runhaskell Setup.lhs configure --prefix=$HOME $ runhaskell Setup.lhs build $ runhaskell Setup.lhs install Running the testsuite: $ cd tests && runhaskell Properties.hs $ cd tests && ghc --make -O2 -ddump-simpl-stats Properties.hs -o prop && ./prop Author: Don Stewart http://www.cse.unsw.edu.au/~dons dlist-0.5/tests/0000755000175000000120000000000011217265402012456 5ustar donswheeldlist-0.5/tests/Properties.hs0000644000175000000120000000467511217265402015162 0ustar donswheel import qualified Prelude as P import qualified Data.List as P (unfoldr) import Prelude hiding (concat,map,head,tail,foldr,map,replicate) import Data.List hiding (concat,map,head,tail,unfoldr,foldr,map,replicate) import Text.Show.Functions import Parallel import Data.DList type T = [Int] prop_model x = (toList . fromList $ (x :: T)) == id x prop_empty = ([] :: T) == (toList empty :: T) prop_singleton c = ([c] :: T) == toList (singleton c) prop_cons c xs = (c : xs :: T) == toList (cons c (fromList xs)) prop_snoc xs c = (xs ++ [c] :: T) == toList (snoc (fromList xs) c) prop_append xs ys = (xs ++ ys :: T) == toList (append (fromList xs) (fromList ys)) prop_concat zss = (P.concat zss) == toList (concat (P.map fromList zss)) where _ = zss :: [T] prop_replicate n x = (P.replicate n x :: T) == toList (replicate n x) prop_head xs = not (null xs) ==> (P.head xs) == head (fromList xs) where _ = xs :: T prop_tail xs = not (null xs) ==> (P.tail xs) == (toList . tail . fromList) xs where _ = xs :: T prop_unfoldr f x n = n >= 0 ==> take n (P.unfoldr f x) == take n (toList $ unfoldr f x) where _ = x :: Int _ = f :: Int -> Maybe (Int,Int) prop_foldr f x xs = (P.foldr f x xs) == (foldr f x (fromList xs)) where _ = x :: Int _ = f :: Int -> Int -> Int prop_map f xs = (P.map f xs) == (toList $ map f (fromList xs)) where _ = f :: Int -> Int prop_map_fusion f g xs = (P.map f . P.map g $ xs) == (toList $ map f . map g $ fromList xs) where _ = f :: Int -> Int -- -- run 8 threads simultaneously -- main = pRun 8 300 [ ("model", pDet prop_model) , ("empty", pDet prop_empty) , ("singleton", pDet prop_singleton) , ("cons", pDet prop_cons) , ("snoc", pDet prop_snoc) , ("append", pDet prop_append) , ("concat", pDet prop_concat) , ("replicate", pDet prop_replicate) , ("head", pDet prop_head) , ("tail", pDet prop_tail) , ("unfoldr", pDet prop_unfoldr) , ("foldr", pDet prop_foldr) , ("map", pDet prop_map) , ("map fusion",pDet prop_map) ] ------------------------------------------------------------------------ -- -- missing QC instances -- {- instance Arbitrary a => Arbitrary (Maybe a) where arbitrary = do a <- arbitrary ; elements [Nothing, Just a] coarbitrary Nothing = variant 0 coarbitrary _ = variant 1 -- ok? -} dlist-0.5/tests/Parallel.hs0000644000175000000120000001120111217265402014541 0ustar donswheel----------------------------------------------------------------------------- -- | -- Module : Test.QuickCheck.Parallel -- Copyright : (c) Don Stewart 2006 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : dons@cse.unsw.edu.au -- Stability : experimental -- Portability : non-portable (uses Control.Exception, Control.Concurrent) -- -- A parallel batch driver for running QuickCheck on threaded or SMP systems. -- See the /Example.hs/ file for a complete overview. -- module Parallel ( module Test.QuickCheck, pRun, pDet, pNon ) where import Test.QuickCheck import Data.List import Control.Concurrent import Control.Exception hiding (evaluate) import System.Random import System.IO (hFlush,stdout) import Text.Printf type Name = String type Depth = Int type Test = (Name, Depth -> IO String) -- | Run a list of QuickCheck properties in parallel chunks, using -- 'n' Haskell threads (first argument), and test to a depth of 'd' -- (second argument). Compile your application with '-threaded' and run -- with the SMP runtime's '-N4' (or however many OS threads you want to -- donate), for best results. -- -- > import Test.QuickCheck.Parallel -- > -- > do n <- getArgs >>= readIO . head -- > pRun n 1000 [ ("sort1", pDet prop_sort1) ] -- -- Will run 'n' threads over the property list, to depth 1000. -- pRun :: Int -> Int -> [Test] -> IO () pRun n depth tests = do chan <- newChan ps <- getChanContents chan work <- newMVar tests forM_ [1..n] $ forkIO . thread work chan let wait xs i | i >= n = return () -- done | otherwise = case xs of Nothing : xs -> wait xs $! i+1 Just s : xs -> putStr s >> hFlush stdout >> wait xs i wait ps 0 where thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO () thread work chan me = loop where loop = do job <- modifyMVar work $ \jobs -> return $ case jobs of [] -> ([], Nothing) (j:js) -> (js, Just j) case job of Nothing -> writeChan chan Nothing -- done Just (name,prop) -> do v <- prop depth writeChan chan . Just $ printf "%d: %-25s: %s" me name v loop -- | Wrap a property, and run it on a deterministic set of data pDet :: Testable a => a -> Int -> IO String pDet a n = mycheck Det defaultConfig { configMaxTest = n , configEvery = \n args -> unlines args } a -- | Wrap a property, and run it on a non-deterministic set of data pNon :: Testable a => a -> Int -> IO String pNon a n = mycheck NonDet defaultConfig { configMaxTest = n , configEvery = \n args -> unlines args } a data Mode = Det | NonDet ------------------------------------------------------------------------ mycheck :: Testable a => Mode -> Config -> a -> IO String mycheck Det config a = do let rnd = mkStdGen 99 -- deterministic mytests config (evaluate a) rnd 0 0 [] mycheck NonDet config a = do rnd <- newStdGen -- different each run mytests config (evaluate a) rnd 0 0 [] mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String mytests config gen rnd0 ntest nfail stamps | ntest == configMaxTest config = do done "OK," ntest stamps | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps | otherwise = do case ok result of Nothing -> mytests config gen rnd1 ntest (nfail+1) stamps Just True -> mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) Just False -> return ( "Falsifiable after " ++ show ntest ++ " tests:\n" ++ unlines (arguments result) ) where result = generate (configSize config ntest) rnd2 gen (rnd1,rnd2) = split rnd0 done :: String -> Int -> [[String]] -> IO String done mesg ntest stamps = return ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) where table = display . map entry . reverse . sort . map pairLength . group . sort . filter (not . null) $ stamps display [] = ".\n" display [x] = " (" ++ x ++ ").\n" display xs = ".\n" ++ unlines (map (++ ".") xs) pairLength xss@(xs:_) = (length xss, xs) entry (n, xs) = percentage n ntest ++ " " ++ concat (intersperse ", " xs) percentage n m = show ((100 * n) `div` m) ++ "%" forM_ = flip mapM_