attoparsec 0.13.0.1 → 0.13.0.2
raw patch · 19 files changed
+194/−374 lines, 19 filesdep +tastydep +tasty-quickcheckdep −test-frameworkdep −test-framework-quickcheck2new-uploader
Dependencies added: tasty, tasty-quickcheck
Dependencies removed: test-framework, test-framework-quickcheck2
Files
- Data/Attoparsec/ByteString/Internal.hs +16/−9
- Data/Attoparsec/Internal.hs +10/−0
- Data/Attoparsec/Text/Buffer.hs +2/−0
- Data/Attoparsec/Text/FastSet.hs +91/−11
- Data/Attoparsec/Text/Internal.hs +17/−8
- attoparsec.cabal +6/−6
- benchmarks/Benchmarks.hs +4/−0
- benchmarks/Main.hs +4/−0
- benchmarks/TextFastSet.hs +3/−1
- benchmarks/attoparsec-benchmarks.cabal +1/−0
- changelog.md +6/−0
- tests/QC.hs +2/−2
- tests/QC/Buffer.hs +3/−3
- tests/QC/ByteString.hs +3/−3
- tests/QC/Combinator.hs +3/−3
- tests/QC/IPv6.hs +0/−322
- tests/QC/Simple.hs +3/−3
- tests/QC/Text.hs +5/−3
- tests/QC/Text/FastSet.hs +15/−0
Data/Attoparsec/ByteString/Internal.hs view
@@ -257,15 +257,24 @@ -- parsers loop until a failure occurs. Careless use will thus result -- in an infinite loop. takeWhile :: (Word8 -> Bool) -> Parser ByteString-takeWhile p = (B.concat . reverse) `fmap` go []+takeWhile p = do+ s <- B8.takeWhile p <$> get+ continue <- inputSpansChunks (B.length s)+ if continue+ then takeWhileAcc p [s]+ else return s+{-# INLINE takeWhile #-}++takeWhileAcc :: (Word8 -> Bool) -> [ByteString] -> Parser ByteString+takeWhileAcc p = go where go acc = do s <- B8.takeWhile p <$> get continue <- inputSpansChunks (B.length s) if continue then go (s:acc)- else return (s:acc)-{-# INLINE takeWhile #-}+ else return $ concatReverse (s:acc)+{-# INLINE takeWhileAcc #-} takeRest :: Parser [ByteString] takeRest = go []@@ -329,16 +338,13 @@ -- parsers loop until a failure occurs. Careless use will thus result -- in an infinite loop. scan :: s -> (s -> Word8 -> Maybe s) -> Parser ByteString-scan = scan_ $ \_ chunks ->- case chunks of- [x] -> return x- xs -> return $! B.concat $ reverse xs+scan = scan_ $ \_ chunks -> return $! concatReverse chunks {-# INLINE scan #-} -- | Like 'scan', but generalized to return the final state of the -- scanner. runScanner :: s -> (s -> Word8 -> Maybe s) -> Parser (ByteString, s)-runScanner = scan_ $ \s xs -> return (B.concat (reverse xs), s)+runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s) {-# INLINE runScanner #-} -- | Consume input as long as the predicate returns 'True', and return@@ -358,8 +364,9 @@ advance len eoc <- endOfChunk if eoc- then (s<>) `fmap` takeWhile p+ then takeWhileAcc p [s] else return s+{-# INLINE takeWhile1 #-} -- | Match any byte in a set. --
Data/Attoparsec/Internal.hs view
@@ -20,10 +20,12 @@ , endOfInput , atEnd , satisfyElem+ , concatReverse ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))+import Data.Monoid (Monoid, mconcat) #endif import Data.Attoparsec.Internal.Types import Data.ByteString (ByteString)@@ -159,3 +161,11 @@ | otherwise -> lose t pos more [] "satisfyElem" Nothing -> satisfySuspended p t pos more lose succ {-# INLINE satisfyElem #-}++-- | Concatenate a monoid after reversing its elements. Used to+-- glue together a series of textual chunks that have been accumulated+-- \"backwards\".+concatReverse :: Monoid m => [m] -> m+concatReverse [x] = x+concatReverse xs = mconcat (reverse xs)+{-# INLINE concatReverse #-}
Data/Attoparsec/Text/Buffer.hs view
@@ -82,10 +82,12 @@ instance Monoid Buffer where mempty = Buf A.empty 0 0 0 0+ {-# INLINE mempty #-} mappend (Buf _ _ _ 0 _) b = b mappend a (Buf _ _ _ 0 _) = a mappend buf (Buf arr off len _ _) = append buf arr off len+ {-# INLINE mappend #-} mconcat [] = mempty mconcat xs = foldl1' mappend xs
Data/Attoparsec/Text/FastSet.hs view
@@ -1,38 +1,118 @@+{-# LANGUAGE BangPatterns #-}++------------------------------------------------------------------------------ -- |--- Module : Data.Attoparsec.Text.FastSet--- Copyright : Bryan O'Sullivan 2015+-- Module : Data.Attoparsec.FastSet+-- Copyright : Felipe Lessa 2010, Bryan O'Sullivan 2007-2015 -- License : BSD3 ----- Maintainer : bos@serpentine.com+-- Maintainer : felipe.lessa@gmail.com -- Stability : experimental -- Portability : unknown ----- Fast set membership tests for 'Char' values.-+-- Fast set membership tests for 'Char' values. We test for+-- membership using a hashtable implemented with Robin Hood+-- collision resolution. The set representation is unboxed,+-- and the characters and hashes interleaved, for efficiency.+--+--+----------------------------------------------------------------------------- module Data.Attoparsec.Text.FastSet ( -- * Data type FastSet -- * Construction , fromList+ , set -- * Lookup , member -- * Handy interface , charClass ) where -import qualified Data.IntSet as I-import Data.Char (ord)+import Data.Bits ((.|.), (.&.), shiftR)+import Data.Function (on)+import Data.List (sort, sortBy)+import qualified Data.Array.Base as AB+import qualified Data.Array.Unboxed as A+import qualified Data.Text as T -newtype FastSet = FastSet I.IntSet+data FastSet = FastSet {+ table :: {-# UNPACK #-} !(A.UArray Int Int)+ , mask :: {-# UNPACK #-} !Int+ } +data Entry = Entry {+ key :: {-# UNPACK #-} !Char+ , initialIndex :: {-# UNPACK #-} !Int+ , index :: {-# UNPACK #-} !Int+ }++offset :: Entry -> Int+offset e = index e - initialIndex e++resolveCollisions :: [Entry] -> [Entry]+resolveCollisions [] = []+resolveCollisions [e] = [e]+resolveCollisions (a:b:entries) = a' : resolveCollisions (b' : entries)+ where (a', b')+ | index a < index b = (a, b)+ | offset a < offset b = (b { index=index a }, a { index=index a + 1 })+ | otherwise = (a, b { index=index a + 1 })++pad :: Int -> [Entry] -> [Entry]+pad = go 0+ where -- ensure that we pad enough so that lookups beyond the+ -- last hash in the table fall within the array+ go !_ !m [] = replicate (max 1 m + 1) empty+ go k m (e:entries) = map (const empty) [k..i - 1] ++ e :+ go (i + 1) (m + i - k - 1) entries+ where i = index e+ empty = Entry '\0' maxBound 0++nextPowerOf2 :: Int -> Int+nextPowerOf2 0 = 1+nextPowerOf2 x = go (x - 1) 1+ where go y 32 = y + 1+ go y k = go (y .|. (y `shiftR` k)) $ k * 2++fastHash :: Char -> Int+fastHash = fromEnum+ fromList :: String -> FastSet-fromList = FastSet . I.fromList . map ord+fromList s = FastSet (AB.listArray (0, length interleaved - 1) interleaved)+ mask'+ where s' = ordNub (sort s)+ l = length s'+ mask' = nextPowerOf2 ((5 * l) `div` 4) - 1+ entries = pad mask' .+ resolveCollisions .+ sortBy (compare `on` initialIndex) .+ zipWith (\c i -> Entry c i i) s' .+ map ((.&. mask') . fastHash) $ s'+ interleaved = concatMap (\e -> [fromEnum $ key e, initialIndex e])+ entries +ordNub :: Eq a => [a] -> [a]+ordNub [] = []+ordNub (y:ys) = go y ys+ where go x (z:zs)+ | x == z = go x zs+ | otherwise = x : go z zs+ go x [] = [x]++set :: T.Text -> FastSet+set = fromList . T.unpack+ -- | Check the set for membership. member :: Char -> FastSet -> Bool-member c (FastSet s) = I.member (ord c) s-{-# INLINE member #-}+member c a = go (2 * i)+ where i = fastHash c .&. mask a+ lookupAt j b = (i' <= i) && (c == c' || b)+ where c' = toEnum $ AB.unsafeAt (table a) j+ i' = AB.unsafeAt (table a) $ j + 1+ go j = lookupAt j . lookupAt (j + 2) . lookupAt (j + 4) .+ lookupAt (j + 6) . go $ j + 8 charClass :: String -> FastSet charClass = fromList . go
Data/Attoparsec/Text/Internal.hs view
@@ -269,14 +269,25 @@ -- parsers loop until a failure occurs. Careless use will thus result -- in an infinite loop. takeWhile :: (Char -> Bool) -> Parser Text-takeWhile p = (T.concat . reverse) `fmap` go []+takeWhile p = do+ h <- T.takeWhile p <$> get+ continue <- inputSpansChunks (size h)+ -- only use slow concat path if necessary+ if continue+ then takeWhileAcc p [h]+ else return h+{-# INLINE takeWhile #-}++takeWhileAcc :: (Char -> Bool) -> [Text] -> Parser Text+takeWhileAcc p = go where go acc = do h <- T.takeWhile p <$> get continue <- inputSpansChunks (size h) if continue then go (h:acc)- else return (h:acc)+ else return $ concatReverse (h:acc)+{-# INLINE takeWhileAcc #-} takeRest :: Parser [Text] takeRest = go []@@ -334,16 +345,13 @@ -- parsers loop until a failure occurs. Careless use will thus result -- in an infinite loop. scan :: s -> (s -> Char -> Maybe s) -> Parser Text-scan = scan_ $ \_ chunks ->- case chunks of- [x] -> return x- xs -> return . T.concat . reverse $ xs+scan = scan_ $ \_ chunks -> return $! concatReverse chunks {-# INLINE scan #-} -- | Like 'scan', but generalized to return the final state of the -- scanner. runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)-runScanner = scan_ $ \s xs -> return (T.concat (reverse xs), s)+runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s) {-# INLINE runScanner #-} -- | Consume input as long as the predicate returns 'True', and return@@ -361,8 +369,9 @@ advance size' eoc <- endOfChunk if eoc- then (h<>) `fmap` takeWhile p+ then takeWhileAcc p [h] else return h+{-# INLINE takeWhile1 #-} -- | Match any character in a set. --
attoparsec.cabal view
@@ -1,12 +1,12 @@ name: attoparsec-version: 0.13.0.1+version: 0.13.0.2 license: BSD3 license-file: LICENSE category: Text, Parsing author: Bryan O'Sullivan <bos@serpentine.com> maintainer: Bryan O'Sullivan <bos@serpentine.com> stability: experimental-tested-with: GHC == 7.0, GHC == 7.2, GHC == 7.4, GHC == 7.6, GHC == 7.8, GHC == 7.10+tested-with: GHC == 7.0.1, GHC == 7.2.1, GHC == 7.4.2, GHC ==7.6.3, GHC ==7.8.4, GHC ==7.10.3 synopsis: Fast combinator parsing for bytestrings and text cabal-version: >= 1.8 homepage: https://github.com/bos/attoparsec@@ -89,6 +89,7 @@ QC.Rechunked QC.Simple QC.Text+ QC.Text.FastSet ghc-options: -Wall -threaded -rtsopts@@ -100,13 +101,12 @@ array, base >= 4 && < 5, bytestring,- containers, deepseq >= 1.1, QuickCheck >= 2.7, quickcheck-unicode, scientific,- test-framework >= 0.8.0.2,- test-framework-quickcheck2 >= 0.3.0.3,+ tasty >= 0.11,+ tasty-quickcheck >= 0.8, text, transformers, vector@@ -136,7 +136,6 @@ base == 4.*, bytestring >= 0.10.4.0, case-insensitive,- containers, criterion >= 1.0, deepseq >= 1.1, directory,@@ -146,6 +145,7 @@ parsec >= 3.1.2, scientific, text >= 1.1.1.0,+ transformers, unordered-containers, vector
benchmarks/Benchmarks.hs view
@@ -71,10 +71,14 @@ , bench "isAlpha_ascii" $ nf (ABL.parse (AC.takeWhile AC.isAlpha_ascii)) bl , bench "isAlpha_iso8859_15" $ nf (ABL.parse (AC.takeWhile AC.isAlpha_iso8859_15)) bl+ , bench "T isAlpha" $ nf (AT.parse (AT.takeWhile isAlpha)) t+ , bench "TL isAlpha" $ nf (ATL.parse (AT.takeWhile isAlpha)) tl ] , bgroup "takeWhile1" [ bench "isAlpha" $ nf (ABL.parse (AC.takeWhile1 isAlpha)) bl , bench "isAlpha_ascii" $ nf (ABL.parse (AC.takeWhile1 AC.isAlpha_ascii)) bl+ , bench "T isAlpha" $ nf (AT.parse (AT.takeWhile1 isAlpha)) t+ , bench "TL isAlpha" $ nf (ATL.parse (AT.takeWhile1 isAlpha)) tl ] , bench "word32LE" $ nf (AB.parse word32LE) b , bgroup "scan" [
+ benchmarks/Main.hs view
@@ -0,0 +1,4 @@+import Sets+import Criterion.Main++main = defaultMain [Sets.benchmarks]
benchmarks/TextFastSet.hs view
@@ -62,7 +62,9 @@ pad :: Int -> [Entry] -> [Entry] pad = go 0- where go !_ !m [] = replicate (max 1 m) empty+ where -- ensure that we pad enough so that lookups beyond the+ -- last hash in the table fall within the array+ go !_ !m [] = replicate (max 1 m + 1) empty go k m (e:entries) = map (const empty) [k..i - 1] ++ e : go (i + 1) (m + i - k - 1) entries where i = index e
benchmarks/attoparsec-benchmarks.cabal view
@@ -17,6 +17,7 @@ Numbers Network.Wai.Handler.Warp.ReadInt Sets+ TextFastSet Warp hs-source-dirs: .. . warp-3.0.1.1 ghc-options: -O2 -Wall -rtsopts
changelog.md view
@@ -1,3 +1,9 @@+0.13.0.2++* Restore the fast specialised character set implementation for Text+* Move testsuite from test-framework to tasty+* Performance optimization of takeWhile and takeWhile1+ 0.13.0.1 * Fixed a bug in the implementations of inClass and notInClass for
tests/QC.hs view
@@ -6,11 +6,11 @@ import qualified QC.Combinator as Combinator import qualified QC.Simple as Simple import qualified QC.Text as Text-import Test.Framework (defaultMain, testGroup)+import Test.Tasty (defaultMain, testGroup) main = defaultMain tests -tests = [+tests = testGroup "tests" [ testGroup "bs" ByteString.tests , testGroup "buf" Buffer.tests , testGroup "combinator" Combinator.tests
tests/QC/Buffer.hs view
@@ -8,8 +8,8 @@ import Data.Monoid (Monoid(mconcat)) #endif import QC.Common ()-import Test.Framework (Test)-import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck import qualified Data.Attoparsec.ByteString.Buffer as BB import qualified Data.Attoparsec.Text.Buffer as BT@@ -82,7 +82,7 @@ i <- choose (0, T.lengthWord16 t) return $ T.dropWord16 i t === BT.dropWord16 i buf -tests :: [Test]+tests :: [TestTree] tests = [ testProperty "b_unbuffer" b_unbuffer , testProperty "t_unbuffer" t_unbuffer
tests/QC/ByteString.hs view
@@ -9,8 +9,8 @@ import Data.Word (Word8) import Prelude hiding (take, takeWhile) import QC.Common (ASCII(..), liftOp, parseBS, toStrictBS)-import Test.Framework (Test)-import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck import qualified Data.Attoparsec.ByteString as P import qualified Data.Attoparsec.ByteString.Char8 as P8@@ -155,7 +155,7 @@ nonmembers s s' = property . not . any (`S.memberWord8` set) $ filter (not . (`elem` s)) s' where set = S.fromList s -tests :: [Test]+tests :: [TestTree] tests = [ testProperty "anyWord8" anyWord8 , testProperty "endOfInput" endOfInput
tests/QC/Combinator.hs view
@@ -8,8 +8,8 @@ import Data.Maybe (fromJust, isJust) import Data.Word (Word8) import QC.Common (Repack, parseBS, repackBS, toLazyBS)-import Test.Framework (Test)-import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.Attoparsec.Combinator as C@@ -43,7 +43,7 @@ B8.replicate x 'x', B8.pack (show n), B8.replicate y 'y' ] -tests :: [Test]+tests :: [TestTree] tests = [ testProperty "choice" choice , testProperty "count" count
− tests/QC/IPv6.hs
@@ -1,322 +0,0 @@--- --------------------------------------------------------------------------------- |--- Module : Text.IPv6Addr--- Copyright : Copyright © Michel Boucey 2011-2015--- License : BSD-Style--- Maintainer : michel.boucey@gmail.com------ Dealing with IPv6 address text representations, canonization and manipulations.------- -------------------------------------------------------------------------------{-# LANGUAGE OverloadedStrings #-}--module Text.IPv6Addr.Internal- ( expandTokens- , macAddr- , maybeIPv6AddrTokens- , ipv4AddrToIPv6AddrTokens- , ipv6TokensToText- , ipv6TokensToIPv6Addr- , isIPv6Addr- , maybeTokIPv6Addr- , maybeTokPureIPv6Addr- , fromDoubleColon- , fromIPv6Addr- , toDoubleColon- , networkInterfacesIPv6AddrList- ) where--import Control.Monad (replicateM)-import Data.Attoparsec.Text-import Data.Char (isDigit,isHexDigit,toLower)-import Data.Monoid ((<>))-import Control.Applicative ((<|>),(<*))-import Data.List (group,isSuffixOf,elemIndex,elemIndices,intersperse)-import Numeric (showHex)-import qualified Data.Text as T-import qualified Data.Text.Read as R (decimal)-import Data.Maybe (fromJust)-import Network.Info--import Text.IPv6Addr.Types--tok0 = "0"---- | Returns the 'T.Text' of an IPv6 address.-fromIPv6Addr :: IPv6Addr -> T.Text-fromIPv6Addr (IPv6Addr t) = t---- | Given an arbitrary list of 'IPv6AddrToken', returns the corresponding 'T.Text'.-ipv6TokensToText :: [IPv6AddrToken] -> T.Text-ipv6TokensToText l = T.concat $ map ipv6TokenToText l---- | Returns the corresponding 'T.Text' of an IPv6 address token.-ipv6TokenToText :: IPv6AddrToken -> T.Text-ipv6TokenToText (SixteenBit s) = s-ipv6TokenToText Colon = ":"-ipv6TokenToText DoubleColon = "::"-ipv6TokenToText AllZeros = tok0 -- "A single 16-bit 0000 field MUST be represented as 0" (RFC 5952, 4.1)-ipv6TokenToText (IPv4Addr a) = a---- | Returns 'True' if a list of 'IPv6AddrToken' constitutes a valid IPv6 Address.-isIPv6Addr :: [IPv6AddrToken] -> Bool-isIPv6Addr [] = False-isIPv6Addr [DoubleColon] = True-isIPv6Addr [DoubleColon,SixteenBit tok1] = True-isIPv6Addr tks =- diffNext tks && (do- let cdctks = countDoubleColon tks- let lentks = length tks- let lasttk = last tks- let lenconst = (lentks == 15 && cdctks == 0) || (lentks < 15 && cdctks == 1)- firstValidToken tks &&- (case countIPv4Addr tks of- 0 -> case lasttk of- SixteenBit _ -> lenconst- DoubleColon -> lenconst- AllZeros -> lenconst- _ -> False- 1 -> case lasttk of- IPv4Addr _ -> (lentks == 13 && cdctks == 0) || (lentks < 12 && cdctks == 1)- _ -> False- otherwise -> False))- where diffNext [] = False- diffNext [_] = True- diffNext (t:ts) = do- let h = head ts- case t of- SixteenBit _ -> case h of- SixteenBit _ -> False- AllZeros -> False- _ -> diffNext ts- AllZeros -> case h of- SixteenBit _ -> False- AllZeros -> False- _ -> diffNext ts- _ -> diffNext ts- firstValidToken l =- case head l of- SixteenBit _ -> True- DoubleColon -> True- AllZeros -> True- _ -> False- countDoubleColon l = length $ elemIndices DoubleColon l- tok1 = "1"--countIPv4Addr = foldr oneMoreIPv4Addr 0- where- oneMoreIPv4Addr t c = case t of- IPv4Addr _ -> c + 1- otherwise -> c---- | This is the main function which returns 'Just' the list of a tokenized IPv6--- address text representation validated against RFC 4291 and canonized--- in conformation with RFC 5952, or 'Nothing'.-maybeTokIPv6Addr :: T.Text -> Maybe [IPv6AddrToken]-maybeTokIPv6Addr t =- case maybeIPv6AddrTokens t of- Just ltks -> if isIPv6Addr ltks- then Just $ (ipv4AddrReplacement . toDoubleColon . fromDoubleColon) ltks- else Nothing- Nothing -> Nothing- where- ipv4AddrReplacement ltks =- if ipv4AddrRewrite ltks- then init ltks ++ ipv4AddrToIPv6AddrTokens (last ltks)- else ltks---- | Returns 'Just' the list of tokenized pure IPv6 address, always rewriting an--- embedded IPv4 address if present.-maybeTokPureIPv6Addr :: T.Text -> Maybe [IPv6AddrToken]-maybeTokPureIPv6Addr t = do- ltks <- maybeIPv6AddrTokens t- if isIPv6Addr ltks- then Just $ (toDoubleColon . ipv4AddrReplacement . fromDoubleColon) ltks- else Nothing- where- ipv4AddrReplacement ltks' = init ltks' ++ ipv4AddrToIPv6AddrTokens (last ltks')---- | Tokenize a 'T.Text' into 'Just' a list of 'IPv6AddrToken', or 'Nothing'.-maybeIPv6AddrTokens :: T.Text -> Maybe [IPv6AddrToken]-maybeIPv6AddrTokens s =- case readText s of- Done r l -> if r==T.empty then Just l else Nothing- Fail {} -> Nothing- where- readText s = feed (parse (many1 $ ipv4Addr <|> sixteenBit <|> doubleColon <|> colon) s) T.empty---- | An embedded IPv4 address have to be rewritten to output a pure IPv6 Address--- text representation in hexadecimal digits. But some well-known prefixed IPv6--- addresses have to keep visible in their text representation the fact that--- they deals with IPv4 to IPv6 transition process (RFC 5952 Section 5):------ IPv4-compatible IPv6 address like "::1.2.3.4"------ IPv4-mapped IPv6 address like "::ffff:1.2.3.4"------ IPv4-translated address like "::ffff:0:1.2.3.4"------ IPv4-translatable address like "64:ff9b::1.2.3.4"------ ISATAP address like "fe80::5efe:1.2.3.4"----ipv4AddrRewrite :: [IPv6AddrToken] -> Bool-ipv4AddrRewrite tks =- case last tks of- IPv4Addr _ -> do- let itks = init tks- not (itks == [DoubleColon]- || itks == [DoubleColon,SixteenBit tokffff,Colon]- || itks == [DoubleColon,SixteenBit tokffff,Colon,AllZeros,Colon]- || itks == [SixteenBit "64",Colon,SixteenBit "ff9b",DoubleColon]- || [SixteenBit "200",Colon,SixteenBit tok5efe,Colon] `isSuffixOf` itks- || [AllZeros,Colon,SixteenBit tok5efe,Colon] `isSuffixOf` itks- || [DoubleColon,SixteenBit tok5efe,Colon] `isSuffixOf` itks)- _ -> False- where- tokffff = "ffff"- tok5efe = "5efe"---- | Rewrites an embedded 'IPv4Addr' into the corresponding list of pure 'IPv6Addr' tokens.------ > ipv4AddrToIPv6AddrTokens (IPv4Addr "127.0.0.1") == [SixteenBits "7f0",Colon,SixteenBits "1"]----ipv4AddrToIPv6AddrTokens :: IPv6AddrToken -> [IPv6AddrToken]-ipv4AddrToIPv6AddrTokens t =- case t of- IPv4Addr a -> do- let m = toHex a- [ SixteenBit ((!!) m 0 <> addZero ((!!) m 1))- , Colon- , SixteenBit ((!!) m 2 <> addZero ((!!) m 3)) ]- _ -> [t]- where- toHex a = map (\x -> T.pack $ showHex (read (T.unpack x)::Int) "") $ T.split (=='.') a- addZero d = if T.length d == 1 then tok0 <> d else d--expandTokens :: [IPv6AddrToken] -> [IPv6AddrToken]-expandTokens = map expandToken- where expandToken (SixteenBit s) = SixteenBit $ T.justifyRight 4 '0' s- expandToken AllZeros = SixteenBit "0000"- expandToken t = t--fromDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken]-fromDoubleColon tks =- if DoubleColon `notElem` tks- then tks- else do let s = splitAt (fromJust $ elemIndex DoubleColon tks) tks- let fsts = fst s- let snds = if not (null (snd s)) then tail(snd s) else []- let fste = if null fsts then [] else fsts ++ [Colon]- let snde = if null snds then [] else Colon : snds- fste ++ allZerosTokensReplacement(quantityOfAllZerosTokenToReplace tks) ++ snde- where- allZerosTokensReplacement x = intersperse Colon (replicate x AllZeros)- quantityOfAllZerosTokenToReplace x =- ntks tks - foldl (\c x -> if (x /= DoubleColon) && (x /= Colon) then c+1 else c) 0 x- where- ntks tks = if countIPv4Addr tks == 1 then 7 else 8--toDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken]-toDoubleColon tks =- zerosToDoubleColon tks (zerosRunToReplace $ zerosRunsList tks)- where- zerosToDoubleColon :: [IPv6AddrToken] -> (Int,Int) -> [IPv6AddrToken]- -- No all zeros token, so no double colon replacement...- zerosToDoubleColon ls (_,0) = ls- -- "The symbol '::' MUST NOT be used to shorten just one 16-bit 0 field" (RFC 5952 4.2.2)- zerosToDoubleColon ls (_,1) = ls- zerosToDoubleColon ls (i,l) =- let ls' = filter (/= Colon) ls- in intersperse Colon (Prelude.take i ls') ++ [DoubleColon] ++ intersperse Colon (drop (i+l) ls')- zerosRunToReplace t =- let l = longestLengthZerosRun t- in (firstLongestZerosRunIndex t l,l)- where- firstLongestZerosRunIndex x y = sum . snd . unzip $ Prelude.takeWhile (/=(True,y)) x- longestLengthZerosRun x =- maximum $ map longest x- where longest t = case t of- (True,i) -> i- _ -> 0- zerosRunsList x = map helper $ groupZerosRuns x- where- helper h = (head h == AllZeros, lh) where lh = length h- groupZerosRuns = group . filter (/= Colon)--ipv6TokensToIPv6Addr :: [IPv6AddrToken] -> Maybe IPv6Addr-ipv6TokensToIPv6Addr l = Just $ IPv6Addr $ ipv6TokensToText l--networkInterfacesIPv6AddrList :: IO [(String,IPv6)]-networkInterfacesIPv6AddrList =- getNetworkInterfaces >>= \n -> return $ map networkInterfacesIPv6Addr n- where- networkInterfacesIPv6Addr (NetworkInterface n _ a _) = (n,a)--fullSixteenBit :: T.Text -> Maybe IPv6AddrToken-fullSixteenBit t =- case parse ipv6AddrFullChunk t of- Done a b -> if a==T.empty then Just $ SixteenBit $ T.pack b else Nothing- _ -> Nothing--macAddr :: Parser (Maybe [IPv6AddrToken])-macAddr = do- n1 <- count 2 hexaChar <* ":"- n2 <- count 2 hexaChar <* ":"- n3 <- count 2 hexaChar <* ":"- n4 <- count 2 hexaChar <* ":"- n5 <- count 2 hexaChar <* ":"- n6 <- count 2 hexaChar- return $ maybeIPv6AddrTokens $ T.pack $ concat [n1,n2,n3,n4,n5,n6]--sixteenBit :: Parser IPv6AddrToken-sixteenBit = do- r <- ipv6AddrFullChunk <|> count 3 hexaChar <|> count 2 hexaChar <|> count 1 hexaChar- -- "Leading zeros MUST be suppressed" (RFC 5952, 4.1)- let r' = T.dropWhile (=='0') $ T.pack r- return $ if T.null r'- then AllZeros- -- Hexadecimal digits MUST be in lowercase (RFC 5952 4.3)- else SixteenBit $ T.toLower r'--ipv4Addr :: Parser IPv6AddrToken-ipv4Addr = do- n1 <- manyDigits <* "."- if n1 /= T.empty- then do n2 <- manyDigits <* "."- if n2 /= T.empty- then do n3 <- manyDigits <* "."- if n3 /= T.empty- then do n4 <- manyDigits- if n4 /= T.empty- then return $ IPv4Addr $ T.intercalate "." [n1,n2,n3,n4]- else parserFailure- else parserFailure- else parserFailure- else parserFailure- where- parserFailure = fail "ipv4Addr parsing failure"- manyDigits = do- ds <- takeWhile1 isDigit- case R.decimal ds of- Right (n,_) -> return (if n < 256 then T.pack $ show n else T.empty)- Left _ -> return T.empty--doubleColon :: Parser IPv6AddrToken-doubleColon = do- string "::"- return DoubleColon--colon :: Parser IPv6AddrToken-colon = do- string ":"- return Colon--ipv6AddrFullChunk :: Parser String-ipv6AddrFullChunk = count 4 hexaChar--hexaChar :: Parser Char-hexaChar = satisfy (inClass "0-9a-fA-F")
tests/QC/Simple.hs view
@@ -10,8 +10,8 @@ import Data.List (foldl') import Data.Maybe (fromMaybe) import QC.Rechunked (rechunkBS)-import Test.Framework (Test)-import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck (Property, counterexample, forAll) import qualified Data.Attoparsec.ByteString.Char8 as A @@ -31,7 +31,7 @@ parse p (x:xs) = foldl' A.feed (A.parse p x) xs parse p [] = A.parse p "" -tests :: [Test]+tests :: [TestTree] tests = [ testProperty "issue75" t_issue75 ]
tests/QC/Text.hs view
@@ -8,8 +8,9 @@ import Data.Int (Int64) import Prelude hiding (take, takeWhile) import QC.Common (liftOp, parseT)-import Test.Framework (Test)-import Test.Framework.Providers.QuickCheck2 (testProperty)+import qualified QC.Text.FastSet as FastSet+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck import qualified Data.Attoparsec.Text as P import qualified Data.Attoparsec.Text.Lazy as PL@@ -160,7 +161,7 @@ nonmembers s s' = property . not . any (`S.member` set) $ filter (not . (`elem` s)) s' where set = S.fromList s -tests :: [Test]+tests :: [TestTree] tests = [ testProperty "anyChar" anyChar , testProperty "asciiCI" asciiCI@@ -188,4 +189,5 @@ , testProperty "takeWhile1_empty" takeWhile1_empty , testProperty "members" members , testProperty "nonmembers" nonmembers+ , testGroup "FastSet" FastSet.tests ]
+ tests/QC/Text/FastSet.hs view
@@ -0,0 +1,15 @@+module QC.Text.FastSet where++import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck+import qualified Data.Attoparsec.Text.FastSet as FastSet++membershipCorrect :: String -> String -> Property+membershipCorrect members others =+ let fs = FastSet.fromList members+ correct c = (c `FastSet.member` fs) == (c `elem` members)+ in property $ all correct (members ++ others)++tests :: [TestTree]+tests = [ testProperty "membership is correct" membershipCorrect ]