sexpr 0.1.2 → 0.2.0
raw patch · 7 files changed
+497/−206 lines, 7 filesdep +QuickCheckdep +randomnew-component:exe:sexpr-test
Dependencies added: QuickCheck, random
Files
- Codec/Sexpr.hs +36/−115
- Codec/Sexpr/Internal.hs +142/−0
- Codec/Sexpr/Parser.hs +75/−41
- Codec/Sexpr/Printer.hs +17/−18
- Codec/Sexpr/Tests.hs +170/−0
- LICENSE +28/−19
- sexpr.cabal +29/−13
Codec/Sexpr.hs view
@@ -5,119 +5,40 @@ -- atom. See http://people.csail.mit.edu/rivest/Sexp.txt module Codec.Sexpr (-- * Basics- Sexpr,- isAtom,- isList,- atom,- list,- unAtom,- unList,- -- * Hinted Atoms- hintedAtom,- hint,- defaultHint,- -- * Character predicates to support encoding- isTokenChar,isInitialTokenChar,isQuoteableChar- ) where--import Control.Applicative-import Data.Char-import qualified Data.Foldable as F-import Data.Traversable--data Sexpr s = Atom s- | HintedAtom String s- | List [Sexpr s] --instance Eq s => Eq (Sexpr s) where- (List a) == (List b) = and $ zipWith (==) a b- a == b = unAtom a == unAtom b && hint a == hint b---- |The 'Functor' instance maps over the underlying atomic contents of--- the S-expression. It does not map only over the top-level list,--- but over the fringe.-instance Functor Sexpr where- fmap f (Atom s) = Atom (f s)- fmap f (HintedAtom h s) = HintedAtom h (f s)- fmap f (List ss) = List $ map (fmap f) ss--instance F.Foldable Sexpr where- foldMap f (Atom s) = f s- foldMap f (HintedAtom h s) = f s- foldMap f (List ss) = F.foldMap (F.foldMap f) ss--instance Traversable Sexpr where- traverse f (Atom s) = Atom <$> f s- traverse f (HintedAtom h s) = HintedAtom h <$> f s- traverse f (List ss) = List <$> traverse (traverse f) ss---- |@fold f s@ applies f to each sub-S-expression of s, from each leaf--- to the root. @f@ need not preserve the shape of @s@, in contrast--- to the shape-preserving @Traversable@ instance.-fold :: (Sexpr t -> Sexpr t) -> Sexpr t -> Sexpr t-fold f z@(Atom s) = f z-fold f z@(HintedAtom h s) = f z-fold f (List ss) = f . List $ map (fold f) ss---- |Any atom whose hint is not specified is assumed to be --- "text/plain; charset=iso-8859-1". This is that default value.-defaultHint :: String-defaultHint = "text/plain; charset=iso-8859-1"---- |Construct an atom.-atom :: a -> Sexpr a-atom s = Atom s---- |Construct a list.-list :: [Sexpr a] -> Sexpr a-list xs = List xs---- |Construct an atom with a MIME type hint.--- @'hintedAtom' 'defaultHint' == 'atom'@-hintedAtom :: String -> a -> Sexpr a-hintedAtom h s | h == defaultHint = Atom s-hintedAtom h s = HintedAtom h s---- |A predicate for recognizing lists.-isList :: Sexpr a -> Bool-isList (List _) = True-isList _ = False---- |A predicate for identifying atoms, whether or not they have--- explicit hints.-isAtom :: Sexpr a -> Bool-isAtom (List _) = False-isAtom _ = True---- |Extract the hint of an atom. Lists do not have hints, but all--- atoms have hints.-hint :: Sexpr a -> Maybe String-hint (Atom s) = Just defaultHint-hint (HintedAtom h s) = Just h-hint _ = Nothing---- |Extract the content of an atom, discarding any MIME type hint.-unAtom :: Sexpr s -> s-unAtom (Atom s) = s-unAtom (HintedAtom h s) = s---- |Extract the sub-S-expressions of a List. If all you intend to do--- is traverse or map over that list, the Functor instance of--- S-expressions may work just fine.-unList :: Sexpr s -> [Sexpr s]-unList (List xs) = xs---- |Tokens may begin with any alphabetic character or the characters--- in @"-./_:*+="@ ;-isInitialTokenChar :: Char -> Bool-isInitialTokenChar x = isAlpha x || x `elem` "-./_:*+="---- |Tokens may internally contain any of the characters legitimate to--- begin tokens, or any numeral.-isTokenChar :: Char -> Bool-isTokenChar x = isAlphaNum x || x `elem` "-./_:*+="+ Sexpr,+ isAtom,+ isList,+ atom,+ list,+ unAtom,+ unList,+ -- * Hinted Atoms+ hintedAtom,+ hint,+ defaultHint,+ -- * Character predicates to support encoding+ isTokenChar,isInitialTokenChar,isQuoteableChar,+ -- * Transformations+ fold,+ -- * String printers+ canonicalString,+ basicString,+ advancedString,+ -- * ShowS printers+ canonical,+ -- * Doc pretty printers+ basic,+ advanced,+ -- * Put binary printers+ putCanonical, putCanonicalBS,+ -- * Parsers+ readSexpr,+ readSexprString,+ readCanonicalSexprString,+ advancedSexpr,+ canonicalSexpr+ ) where --- |Only token characters and spaces don't need to be escaped when--- shown in the "quoted" syntax.-isQuoteableChar :: Char -> Bool-isQuoteableChar x = isTokenChar x || isSpace x+import Codec.Sexpr.Internal+import Codec.Sexpr.Parser+import Codec.Sexpr.Printer
+ Codec/Sexpr/Internal.hs view
@@ -0,0 +1,142 @@+-- |A Sexpr is an S-expressionin the style of Rivest's Canonical+-- S-expressions. Atoms may be of any type, but String and+-- ByteString have special support. Rivest's implementation of+-- S-expressions is unusual in supporting MIME type hints for each+-- atom. See http://people.csail.mit.edu/rivest/Sexp.txt++module Codec.Sexpr.Internal (-- * Basics+ Sexpr,+ isAtom,+ isList,+ atom,+ list,+ unAtom,+ unList,+ -- * Hinted Atoms+ hintedAtom,+ hint,+ defaultHint,+ -- * Character predicates to support encoding+ isTokenChar,isInitialTokenChar,isQuoteableChar,+ -- * Transformations+ fold+ ) where++import Control.Applicative+import Data.Char+import qualified Data.Foldable as F+import Data.Traversable+import Test.QuickCheck+import Data.Monoid()++data Sexpr s = Atom s+ | HintedAtom String s+ | List [Sexpr s] ++instance Eq s => Eq (Sexpr s) where+ (List a) == (List b) = and $ zipWith (==) a b+ a == b = unAtom a == unAtom b && hint a == hint b++-- |The 'Functor' instance maps over the underlying atomic contents of+-- the S-expression. It does not map only over the top-level list,+-- but over the fringe.+instance Functor Sexpr where+ fmap f (Atom s) = Atom (f s)+ fmap f (HintedAtom h s) = HintedAtom h (f s)+ fmap f (List ss) = List $ map (fmap f) ss++instance F.Foldable Sexpr where+ foldMap f (Atom s) = f s+ foldMap f (HintedAtom _ s) = f s+ foldMap f (List ss) = F.foldMap (F.foldMap f) ss++instance Traversable Sexpr where+ traverse f (Atom s) = Atom <$> f s+ traverse f (HintedAtom h s) = HintedAtom h <$> f s+ traverse f (List ss) = List <$> traverse (traverse f) ss++instance Arbitrary a => Arbitrary (Sexpr a) where+ arbitrary = sized arbSexpr+ where + arbSexpr 0 = oneof [Atom <$> arbitrary,+ return $ List []]+ arbSexpr n = oneof [Atom <$> arbitrary,+ List <$> (resize (n `div` 2) arbitrary)]+ coarbitrary (Atom s) = variant 0 . coarbitrary s+ coarbitrary (HintedAtom h s) = variant 1 . coarbitrary_h . coarbitrary s+ where coarbitrary_h = + foldr (\a b -> variant (ord a) . variant 1 . b) (variant 0) h+ coarbitrary (List ss) = variant 2 . coarbitrary ss++-- |@fold f s@ applies f to each sub-S-expression of s, from each leaf+-- to the root. @f@ need not preserve the shape of @s@, in contrast+-- to the shape-preserving @Traversable@ instance.+fold :: (Sexpr t -> Sexpr t) -> Sexpr t -> Sexpr t+fold f z@(Atom _) = f z+fold f z@(HintedAtom _ _) = f z+fold f (List ss) = f . List $ map (fold f) ss++-- |Any atom whose hint is not specified is assumed to be +-- "text/plain; charset=iso-8859-1". This is that default value.+defaultHint :: String+defaultHint = "text/plain; charset=iso-8859-1"++-- |Construct an atom.+atom :: a -> Sexpr a+atom s = Atom s++-- |Construct a list.+list :: [Sexpr a] -> Sexpr a+list xs = List xs++-- |Construct an atom with a MIME type hint.+-- @'hintedAtom' 'defaultHint' == 'atom'@+hintedAtom :: String -> a -> Sexpr a+hintedAtom h s | h == defaultHint = Atom s+hintedAtom h s = HintedAtom h s++-- |A predicate for recognizing lists.+isList :: Sexpr a -> Bool+isList (List _) = True+isList _ = False++-- |A predicate for identifying atoms, whether or not they have+-- explicit hints.+isAtom :: Sexpr a -> Bool+isAtom (List _) = False+isAtom _ = True++-- |Extract the hint of an atom. Lists do not have hints, but all+-- atoms have hints.+hint :: Sexpr a -> Maybe String+hint (Atom _) = Just defaultHint+hint (HintedAtom h _) = Just h+hint _ = Nothing++-- |Extract the content of an atom, discarding any MIME type hint.+unAtom :: Sexpr s -> s+unAtom (Atom s) = s+unAtom (HintedAtom _ s) = s+unAtom _ = error "unAtom called on a non-atom"++-- |Extract the sub-S-expressions of a List. If all you intend to do+-- is traverse or map over that list, the Functor instance of+-- S-expressions may work just fine.+unList :: Sexpr s -> [Sexpr s]+unList (List xs) = xs+unList _ = error "unList called on a non-list"++-- |Tokens may begin with any alphabetic character or the characters+-- in @"-./_:*+="@ ;+isInitialTokenChar :: Char -> Bool+isInitialTokenChar x = (isAlpha x || x `elem` "-./_:*+=") && (128 > ord x)++-- |Tokens may internally contain any of the characters legitimate to+-- begin tokens, or any numeral.+isTokenChar :: Char -> Bool+isTokenChar x = (isAlphaNum x || x `elem` "-./_:*+=") && (128 > ord x)++-- |Only token characters and spaces don't need to be escaped when+-- shown in the "quoted" syntax.+isQuoteableChar :: Char -> Bool+isQuoteableChar x = isTokenChar x || isSpace x
Codec/Sexpr/Parser.hs view
@@ -31,12 +31,10 @@ -- > <base-64-char> :: <alpha> | <decimal-digit> | "+" | "/" | "=" ; -- > <null> :: "" ; -module Codec.Sexpr.Parser (readSexpr,- readSexprString,- sexpr,- canonicalSexpr) where+module Codec.Sexpr.Parser where -import Codec.Sexpr+import Codec.Sexpr.Internal+import Control.Monad -- import Data.Binary.Get -- import Data.ByteString@@ -47,14 +45,24 @@ instance Read s => Read (Sexpr s) where- readsPrec n s = map (\(a,b) -> (fmap read a, b)) s'+ readsPrec _ s = map (\(a,b) -> (fmap read a, b)) s' where - s' = readP_to_S sexpr s :: [(Sexpr String,String)]+ s' = readP_to_S advancedSexpr s :: [(Sexpr String,String)] -- |Read a @'Sexpr' 'String'@ in any encoding: Canonical, Basic, or Advanced. readSexprString :: String -> Sexpr String-readSexprString s = fst . head $ readP_to_S sexpr s+readSexprString s = case readP_to_S advancedSexpr s of+ [] -> error $ "Cannot parse sexpr from: " ++ s ++ "."+ s' -> fst $ head s' +-- |Read a @'Sexpr' 'String'@ in canonical encoding.+readCanonicalSexprString :: String -> Sexpr String+readCanonicalSexprString s = case readP_to_S canonicalSexpr s of+ [] -> error + $ "Cannot parse canonical sexpr from: " ++ s ++ "."+ s' -> fst $ head s'++ -- |Read a @'Sexpr' a@ using the 'Read' instance for @a@. The Sexpr -- may be in any encoding: Canonical, Basic, or Advanced. readSexpr :: Read a => String -> Sexpr a@@ -62,11 +70,10 @@ -- |Parser for @'Sexpr' 'String'@s suitable for embedding in other -- @ReadP@ parsers.-sexpr :: ReadP (Sexpr String)-sexpr = do- skipSpaces- s <- canonicalSexpr- skipSpaces+sexpr :: Bool -> ReadP (Sexpr String)+sexpr b = do+ s <- (internalSexpr b)+ when b skipSpaces return s {-@@ -89,55 +96,77 @@ -- S-expression (and optional terminating NUL), but not the Basic or -- Advanced encodings. canonicalSexpr :: ReadP (Sexpr String)-canonicalSexpr = do- s <- atomR <++ listR <++ basicTransport+canonicalSexpr = sexpr False++advancedSexpr :: ReadP (Sexpr String)+advancedSexpr = sexpr True++internalSexpr :: Bool -> ReadP (Sexpr String)+internalSexpr b = do+ s <- atomR b <++ listR b <++ basicTransport b optional $ char '\NUL' return s -basicTransport :: ReadP (Sexpr String)-basicTransport = do- b64Octets <- between (char '{') (char '}') $ many1 b64char- let parses = readP_to_S sexpr $ B64.decode b64Octets+basicTransport :: Bool -> ReadP (Sexpr String)+basicTransport b = do+ when b skipSpaces+ b64Octets <- between (char '{') (char '}') $ many b64char+ let parses = readP_to_S (sexpr b) $ B64.decode b64Octets choice $ map (return.fst) $ filter ((=="") . snd) parses +b64char :: ReadP Char b64char = satisfy (\x -> isAlphaNum x || x `elem` "+/=")++b64char' :: ReadP Char b64char' = skipSpaces >> b64char +hexchar :: ReadP Char hexchar = satisfy isHexDigit++hexchar' :: ReadP Char hexchar' = skipSpaces >> hexchar -listR :: ReadP (Sexpr String)-listR = do- l <- between (char '(') (char ')') $ many sexpr+listR :: Bool -> ReadP (Sexpr String)+listR b = do+ when b skipSpaces+ l <- between (char '(') ((when b skipSpaces) >> char ')') $ many (sexpr b) return $ list l -atomR :: ReadP (Sexpr String)-atomR = unhinted +++ hinted+atomR :: Bool -> ReadP (Sexpr String)+atomR b = unhinted +++ hinted where - unhinted = simpleString >>= (return . atom)+ unhinted = simpleString b >>= (return . atom) hinted = do- hint <- between (char '[' >> skipSpaces) - (skipSpaces >> char ']') - simpleString- value <- simpleString- return $ hintedAtom hint value+ when b skipSpaces+ h <- between (char '[' >> skipSpaces) + (skipSpaces >> char ']') + (simpleString b)+ v <- simpleString b+ return $ hintedAtom h v -simpleString :: ReadP String-simpleString = raw +++ token +++ b64Atom +++ hexAtom +++ quotedString+simpleString :: Bool -> ReadP String+simpleString False = raw+simpleString True =+ skipSpaces >> (raw +++ token +++ b64Atom +++ hexAtom +++ quotedString) +quotedString :: ReadP String quotedString = withLength +++ withoutLength where withLength = do l <- decimal c <- between (char '"') (char '"') (many get)- let s = read ('"':c ++ "\"")- if (l == length s)- then return s- else fail "length error" + readString c (\s -> if (l == length s)+ then return s+ else fail "length error") withoutLength = do c <- between (char '"') (char '"') (many get)- return $ read ('"':c ++ "\"")+ readString c (\s -> return s)+ readString c f = case filter (\x -> "" == snd x) $ reads ('"':c ++ "\"") of+ (s,""):_ -> f s+ _ -> pfail ++hexAtom :: ReadP String hexAtom = do s <- withLength +++ withoutLength return $ hexDecode s@@ -147,9 +176,12 @@ between (char '#') (char '#') (count (2*l) hexchar') withoutLength = between (char '#') (char '#') (many1 hexchar') +hexDecode :: String -> String hexDecode [] = ""+hexDecode [o] = [chr $ digitToInt o] hexDecode (h:o:cs) = chr (16*digitToInt h + digitToInt o) : (hexDecode cs) +b64Atom :: ReadP String b64Atom = do s <- withLength +++ withoutLength return $ B64.decode s@@ -158,9 +190,11 @@ l <- decimal between (char '|') (char '|') (count (b64length l) b64char') withoutLength = - between (char '|') (char '|') (many1 b64char')- b64length l = 4 * (ceiling (fromIntegral l / 3))+ between (char '|') (char '|') (many b64char')+ b64length l = -4 * (l `div` (-3))+ -- === 4 * (ceiling (fromIntegral l / 3)), without Double +token :: ReadP String token = do c <- satisfy isInitialTokenChar cs <- munch isTokenChar@@ -168,9 +202,9 @@ raw :: ReadP String raw = do- length <- decimal+ len <- decimal char ':'- count length get+ count len get decimal :: ReadP Int decimal = do
Codec/Sexpr/Printer.hs view
@@ -15,20 +15,9 @@ -- advancedString and the underlying Show instance. Overlapping -- instances are used to provide a nice show for @'Sexpr' 'String'@. -module Codec.Sexpr.Printer (-- * String printers- canonicalString,- basicString,- advancedString,- -- * ShowS printers- canonical,- -- * Doc pretty printers- basic, - advanced, - -- * Put binary printers- putCanonical, putCanonicalBS- ) where+module Codec.Sexpr.Printer where -import Codec.Sexpr+import Codec.Sexpr.Internal import Data.Binary.Put import qualified Data.ByteString.Char8 as B@@ -44,6 +33,7 @@ instance Show s => Show (Sexpr s) where show s = advancedString $ fmap show s +raw :: String -> String -> String raw s = shows (length s) . showString ":" . showString s canonicalString :: Sexpr String -> String@@ -55,7 +45,7 @@ . raw (fromJust $ hint s) . showString "]" . raw (unAtom s)-canonical s | isList s = showString "("+canonical s | otherwise = showString "(" . showString (foldr (.) id (map canonical $ unList s) $ "") . showString ")" @@ -71,6 +61,7 @@ putChar' ':' putByteString s +putChar' :: Char -> Put putChar' = putWord8 . fromIntegral . ord putCanonical :: Sexpr String -> Put@@ -87,7 +78,7 @@ putRaw (fromJust $ hint s) putChar' ']' putRaw' (unAtom s)-putCanonicalHelper putRaw' s | isList s = do+putCanonicalHelper putRaw' s | otherwise = do putChar' '(' mapM_ (putCanonicalHelper putRaw') $ unList s putChar' ')'@@ -103,31 +94,39 @@ advancedString :: Sexpr String -> String advancedString s = render $ advanced s -+format :: String -> Doc format s | canToken s = text s | canQuote s = quote s | canHex s = hex s | otherwise = base64 s +canToken :: String -> Bool canToken (x:xs) = isInitialTokenChar x && all isTokenChar xs+canToken [] = False +canQuote :: String -> Bool canQuote s = all isQuoteableChar s- || fromIntegral (length (show s)) <= 1.1 * fromIntegral (length s)+ || fromIntegral (length (show s)) * 10 <= (length s) * 11 +canHex :: String -> Bool canHex s = length s `elem` [1,2,3,4,8,16,20] +hex :: String -> Doc hex s = text (show $ length s) <> (char '#') <> hcat (map (text . hexEncode) s) <> (char '#') +hexEncode :: Char -> String hexEncode x = (intToDigit h) : (intToDigit o) : [] where (h,o) = quotRem (ord x) 16 +quote :: Show a => a -> Doc quote s = text $ show s +base64 :: String -> Doc base64 s = (char '|') <> hcat (map char $ B64.encode s) <> (char '|') advanced :: Sexpr String -> Doc advanced s | isAtom s && hint s == Just defaultHint = format $ unAtom s advanced s | isAtom s = brackets (format $ fromJust $ hint s) <> (format $ unAtom s) -advanced s | isList s = parens $ sep (map advanced $ unList s)+advanced s | otherwise = parens $ sep (map advanced $ unList s)
+ Codec/Sexpr/Tests.hs view
@@ -0,0 +1,170 @@+module Main where++import Codec.Sexpr+import Codec.Sexpr.Parser+import Codec.Sexpr.Printer+import Test.QuickCheck+import Data.Monoid()+import Text.Show.Functions()+import qualified Data.Traversable as T+import qualified Data.Foldable as F+import Data.Char+import Data.Binary.Put+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import Text.PrettyPrint (render)++import Text.Printf+import Control.Monad+import System.Environment+import System.Random+import System.IO+import Data.List++prop_atoms :: Int -> Bool+prop_atoms n = n == (unAtom $ atom n)++prop_foldMap :: (Int -> [Int]) -> Sexpr Int -> Bool+prop_foldMap f s = T.foldMapDefault f s == F.foldMap f s++prop_fmap :: (Int -> Int) -> Sexpr Int -> Bool+prop_fmap f s = T.fmapDefault f s == fmap f s++prop_readshow :: Sexpr Int -> Bool+prop_readshow s = (read . show $ s) == s++prop_readshowStr :: Sexpr String -> Bool+prop_readshowStr s = (readSexprString $ advancedString s) == s++prop_canonical_out :: Sexpr String -> Bool+prop_canonical_out s = (readSexprString $ canonicalString s) == s++prop_canonical_in :: Sexpr String -> Bool+prop_canonical_in s = (readCanonicalSexprString $ canonicalString s) == s++prop_put_canonical :: Sexpr String -> Bool+prop_put_canonical s = + (L.unpack . runPut $ putCanonical s) == canonicalString s++prop_put_canonicalBS :: Sexpr B.ByteString -> Bool+prop_put_canonicalBS s = + (L.unpack . runPut $ putCanonicalBS s) == (canonicalString $ fmap B.unpack s)++prop_atom_raw :: String -> Bool+prop_atom_raw s = (readSexprString $ Codec.Sexpr.Printer.raw s "") == atom s++prop_atom_token :: String -> Property+prop_atom_token s = canToken s ==> ((readSexprString s) == atom s)++prop_atom_hex :: String -> Property+prop_atom_hex s = canHex s ==> ((readSexprString $ render $ hex s) == atom s)++prop_atom_quote :: String -> Property+prop_atom_quote s = canQuote s ==> ((readSexprString $ render $ quote s) == atom s)++prop_atom_base64 :: String -> Bool+prop_atom_base64 s = (readSexprString $ render $ base64 s) == atom s ++instance Arbitrary B.ByteString where+ arbitrary = B.pack `fmap` arbitrary+ coarbitrary = undefined++instance Arbitrary Char where+ arbitrary = choose (32,255) >>= \n -> return (chr n)+ coarbitrary n = variant (ord n)+++main :: IO ()+main = do+ args <- fmap (drop 1) getArgs+ let n = if null args then 100 else read (head args)+ (results, passed) <- + liftM unzip $ mapM (\(s,a) -> printf "%-40s: " s >> a n) tests+ printf "Passed %d tests!\n" (sum passed)+ when (not . and $ results) $ fail "Not all tests passed!"++tests :: [(String, Int -> IO (Bool, Int))]+tests = [("Atom dis/assembly", mytest prop_atoms)+ ,("foldMap behaves as default", mytest prop_foldMap)+ ,("fmap behaves as default", mytest prop_fmap)+ ,("(read.show)==id | Int", mytest prop_readshow)+ ,("(read.show)==id | String", mytest prop_readshowStr)+ ,("canonical output", mytest prop_canonical_out)+ ,("canonical input", mytest prop_canonical_in)+ ,("efficient bytestring canonical", mytest prop_put_canonical)+ ,("efficient bytestring canonicalBS", mytest prop_put_canonicalBS)+ ,("token atom", mytest prop_atom_token)+ ,("hex atom", mytest prop_atom_hex)+ ,("quoted atom", mytest prop_atom_quote)+ ,("raw atom", mytest prop_atom_raw)+ ,("base64 atom", mytest prop_atom_base64)+ ]++------------------------------------------------------------------------+--+-- QC driver+-- copied from xmonad 0.8.1++debug :: Bool+debug = False++mytest :: Testable a => a -> Int -> IO (Bool, Int)+mytest a n = mycheck defaultConfig+ { configMaxTest=n+ , configEvery = \nu _ -> let s = show nu in s ++ [ '\b' | _ <- s ] } a+ -- , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a++mycheck :: Testable a => Config -> a -> IO (Bool, Int)+mycheck config a = do+ rnd <- newStdGen+ mytests config (evaluate a) rnd 0 0 []++mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int)+mytests config gen rnd0 ntest nfail stamps+ | ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest)+ | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest)+ | otherwise =+ do putStr (configEvery config ntest (arguments result)) >> hFlush stdout+ 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 ->+ putStr ( "Falsifiable after "+ ++ show ntest+ ++ " tests:\n"+ ++ unlines (arguments result)+ ) >> hFlush stdout >> return (False, ntest)+ where+ result = generate (configSize config ntest) rnd2 gen+ (rnd1,rnd2) = split rnd0++done :: String -> Int -> [[String]] -> IO ()+done mesg ntest stamps = putStr ( 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)+ pairLength [] = (0,undefined)+ entry (n, xs) = percentage n ntest+ ++ " "+ ++ concat (intersperse ", " xs)++ percentage n m = show ((100 * n) `div` m) ++ "%"++------------------------------------------------------------------------++
LICENSE view
@@ -1,22 +1,31 @@-Copyright (c) 2009 Brian Sniffen <bts@evenmere.org>+(c) 2009 Brian Sniffen -Permission is hereby granted, free of charge, to any person-obtaining a copy of this software and associated documentation-files (the "Software"), to deal in the Software without-restriction, including without limitation the rights to use,-copy, modify, merge, publish, distribute, sublicense, and/or sell-copies of the Software, and to permit persons to whom the-Software is furnished to do so, subject to the following-conditions:+All rights reserved. -The above copyright notice and this permission notice shall be-included in all copies or substantial portions of the Software.+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met: -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES-OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT-HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,-WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING-FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR-OTHER DEALINGS IN THE SOFTWARE.+1. Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+may be used to endorse or promote products derived from this software+without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.+~
sexpr.cabal view
@@ -1,19 +1,35 @@-Name: sexpr-Version: 0.1.2-Cabal-Version: >= 1.2-Synopsis: S-expression printer and parser -Description: Parser and printer for S-expressions, including Ron +name: sexpr+version: 0.2.0+cabal-version: >= 1.2+synopsis: S-expression printer and parser +description: Parser and printer for S-expressions, including Ron Rivest's Canonical S-expressions. These are used in SDSI and SPKI, and are generally useful for cryptographic operations over structured data.-Category: Codec-License: BSD3-License-file: LICENSE-Author: Brian Sniffen-Maintainer: bts@evenmere.org-Build-type: Simple+category: Codec+license: BSD3+license-file: LICENSE+author: Brian Sniffen+maintainer: bts@evenmere.org+build-type: Simple -Library+flag testing+ description: build test executable+ default: False++library+ if flag(testing)+ ghc-options: -Wall Build-Depends: base, base64-string, pretty, bytestring, binary- Exposed-modules: Codec.Sexpr, Codec.Sexpr.Parser, Codec.Sexpr.Printer+ Exposed-modules: Codec.Sexpr +executable sexpr-test+ if !flag(testing)+ buildable: False+ ghc-options: -Wall+ main-is: Codec/Sexpr/Tests.hs+ other-modules: Codec.Sexpr+ Codec.Sexpr.Parser+ Codec.Sexpr.Printer+ Codec.Sexpr.Internal+ build-depends: QuickCheck, random