dlist (empty) → 0.2
raw patch · 7 files changed
+385/−0 lines, 7 filesdep +basebuild-type:Customsetup-changed
Dependencies added: base
Files
- Data/DList.hs +135/−0
- LICENSE +31/−0
- README +14/−0
- Setup.lhs +3/−0
- dlist.cabal +12/−0
- tests/Parallel.hs +148/−0
- tests/Properties.hs +42/−0
+ Data/DList.hs view
@@ -0,0 +1,135 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.DList+-- Copyright : (c) Don Stewart 2006+-- 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, 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+ ,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++ ) where++import Prelude hiding (concat, foldr, map, head, tail)+import Control.Monad+import qualified Data.List as List (concat, foldr, map, unfoldr)+import Data.Monoid++-- | 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.+--+newtype DList a = DL { unDL :: [a] -> [a] }++-- | Converting a normal list to a dlist+fromList :: [a] -> DList a+fromList = DL . (++)++-- | Converting a dlist back to a normal list+toList :: DList a -> [a]+toList = ($[]) . unDL++-- | Create a difference list containing no elements+empty :: DList a+empty = DL id++-- | Create difference list with given single element+singleton :: a -> DList a+singleton = DL . (:)++-- | /O(1)/, Prepend a single element to a difference list+cons :: a -> DList a -> DList a+cons x xs = DL ((x:) . unDL xs)++-- | /O(1)/, Append a single element at a difference list+snoc :: DList a -> a -> DList a+snoc xs x = DL (unDL xs . (x:))++-- | Appending difference lists+append :: DList a -> DList a -> DList a+append xs ys = DL (unDL xs . unDL ys)++-- | Concatenate difference lists+concat :: [DList a] -> DList a+concat = List.foldr append empty++-- | /O(length dl)/, List elimination, head, tail+list :: b -> (a -> DList a -> b) -> DList a -> b+list null cons dl =+ case toList dl of+ [] -> null+ (x : xs) -> cons x (fromList xs)++-- | Return the head of the list+head :: DList a -> a+head = list (error "Data.DList.head: empty list") (curry fst)++-- | Return the tail of the list+tail :: DList a -> DList a+tail = list (error "Data.DList.tail: empty list") (curry snd) ++-- | 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++-- | Map over difference lists+map :: (a -> b) -> DList a -> DList b+map f = foldr (cons . f) empty+++instance Monoid (DList a) where+ mempty = empty+ mappend = append++instance Functor DList where+ fmap = map++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++ return x = singleton x+ fail s = empty++instance MonadPlus DList where+ mzero = empty+ mplus = append
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright 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.
+ README view
@@ -0,0 +1,14 @@+DLists: 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++Author:+ Don Stewart+ http://www.cse.unsw.edu.au/~dons
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ dlist.cabal view
@@ -0,0 +1,12 @@+Name: dlist+Version: 0.2+Description: Differences lists: lists supporting efficient append+Category: Data+Synopsis: Differences lists: lists supporting efficient append+License: BSD3+License-file: LICENSE+Author: Don Stewart +Maintainer: <dons@cse.unsw.edu.au>+Build-Depends: base+ghc-options: -O+Exposed-modules: Data.DList
+ tests/Parallel.hs view
@@ -0,0 +1,148 @@+-----------------------------------------------------------------------------+-- |+-- 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_
+ tests/Properties.hs view
@@ -0,0 +1,42 @@++import qualified Prelude as P+import Prelude hiding (concat,map,head,tail)+import Data.List hiding (concat,map,head,tail)++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_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++main = pRun 2 500 [ ("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)+ , ("head", pDet prop_head)+ , ("tail", pDet prop_tail)+ ]+