ip 0.8.7 → 0.9

raw patch · 18 files changed

+1712/−313 lines, 18 filesdep ~vectorPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: vector

API changes (from Hackage documentation)

Files

• ip.cabal +14/−2
• src/Data/ByteString/Builder/Fixed.hs +166/−0
• src/Data/Text/Builder/Common/Internal.hs +89/−0
• src/Data/Text/Builder/Fixed.hs +136/−0
• src/Data/Text/Builder/Variable.hs +129/−0
• src/Data/Word/Synthetic.hs +13/−0
• src/Data/Word/Synthetic/Word12.hs +220/−0
• src/Data/Word/Synthetic/Word48.hs +252/−0
• src/Net/IPv6/Text.hs +1/−1
• src/Net/Internal.hs +114/−96
• src/Net/Mac.hs +14/−21
• src/Net/Mac/ByteString/Char8.hs +206/−31
• src/Net/Mac/Text.hs +184/−22
• src/Net/Types.hs +34/−124
• test/ArbitraryInstances.hs +21/−5
• test/Bench.hs +30/−10
• test/IPv4TextVariableBuilder.hs +30/−0
• test/Test.hs +59/−1

@@ -1,5 +1,5 @@ name:                ip-version:             0.8.7+version:             0.9 synopsis:            Library for IP and MAC addresses homepage:            https://github.com/andrewthad/haskell-ip#readme license:             BSD3@@ -53,15 +53,24 @@     Net.IP     Net.Types     Net.Internal+    Data.Word.Synthetic+    Data.Word.Synthetic.Word48+    Data.Word.Synthetic.Word12+    Data.Text.Builder.Fixed+    Data.Text.Builder.Variable+    Data.Text.Builder.Common.Internal+    Data.ByteString.Builder.Fixed   build-depends:       base        >= 4.8  && < 5     , attoparsec-    , aeson       >= 0.9  && < 0.12+    , aeson       >= 0.9  && < 1.1     , hashable    >= 1.2  && < 1.3     , text        >= 1.2  && < 1.3     , bytestring  >= 0.10 && < 0.11     , vector      >= 0.11 && < 0.12     , primitive+  -- if impl(ghcjs)+  --   build-depends: ghcjs-base >= 0.2 && < 0.3   ghc-options:         -Wall -O2   default-language:    Haskell2010 @@ -86,6 +95,7 @@     IPv4Text1     IPv4Text2     IPv4ByteString1+    IPv4TextVariableBuilder   ghc-options:         -Wall -O2   default-language:    Haskell2010 @@ -116,6 +126,7 @@     IPv4DecodeText1     IPv4DecodeText2     IPv4ByteString1+    IPv4TextVariableBuilder   ghc-options:         -Wall -O2   default-language:    Haskell2010   hs-source-dirs:      test@@ -124,3 +135,4 @@ source-repository head   type:     git   location: https://github.com/andrewthad/haskell-ip+

@@ -0,0 +1,166 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_GHC -O2 -Wall -funbox-strict-fields #-}++{-| For concatenating fixed-width strings that are only a few+    characters each, this can be six times faster than the builder+    that ships with @bytestring@.+-}+module Data.ByteString.Builder.Fixed+  ( Builder+  , fromByteString+  , run+  , contramapBuilder+  , char8+  , word8+  , word8HexFixedLower+  , word8HexFixedUpper+  , word12HexFixedLower+  , word12HexFixedUpper+  ) where++import Control.Monad.ST+import Data.Monoid+import Data.Word+import Data.Word.Synthetic (Word12)+import Data.Bits+import Data.Char (ord)+import Text.Printf+import Debug.Trace+import Data.ByteString.Internal (ByteString(..))+import Foreign+import Data.ByteString.Short (ShortByteString)+import System.IO.Unsafe+import qualified Data.ByteString.Internal as BI+import qualified Data.ByteString.Builder as BBuilder+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LByteString+import qualified Data.ByteString.Char8 as BC8+import qualified Data.ByteString.Short.Internal as SBS++data Builder a where+  BuilderStatic :: !ByteString -> Builder a+  BuilderFunction :: !ByteString -> !(Int -> Ptr Word8 -> a -> IO ()) -> Builder a++instance Monoid (Builder a) where+  {-# INLINE mempty #-}+  mempty = BuilderStatic ByteString.empty+  {-# INLINE mappend #-}+  mappend x y = case x of+    BuilderStatic t1@(PS _ _ len1) -> case y of+      BuilderStatic t2 -> BuilderStatic (t1 <> t2)+      BuilderFunction t2 f -> BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a)+    BuilderFunction t1@(PS _ _ len1) f1 -> case y of+      BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1+      BuilderFunction t2 f2 -> BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a)++contramapBuilder :: (b -> a) -> Builder a -> Builder b+contramapBuilder f x = case x of+  BuilderStatic t -> BuilderStatic t+  BuilderFunction t g -> BuilderFunction t (\ix marr b -> g ix marr (f b))+{-# INLINE contramapBuilder #-}++fromByteString :: ByteString -> Builder a+fromByteString = BuilderStatic+{-# INLINE fromByteString #-}++run :: Builder a -> a -> ByteString+run x a = case x of+  BuilderStatic t -> t+  BuilderFunction (PS inArr off len) f ->+    BI.unsafeCreate len $ \ptr -> withForeignPtr inArr $ \inPtr -> do+      copyArray ptr (advancePtr inPtr off) len+      f 0 ptr a++word12HexFixedGeneral :: Bool -> Builder Word12+word12HexFixedGeneral upper = BuilderFunction (BC8.pack "---") $ \i marr w -> do+  let !wInt = fromIntegral w+      !ix = wInt + wInt + wInt+      !arr = if upper then hexValuesWord12Upper else hexValuesWord12Lower+  pokeByteOff marr i (SBS.unsafeIndex arr ix)+  pokeByteOff marr (i + 1) (SBS.unsafeIndex arr (ix + 1))+  pokeByteOff marr (i + 2) (SBS.unsafeIndex arr (ix + 2))+{-# INLINE word12HexFixedGeneral #-}++word12HexFixedUpper :: Builder Word12+word12HexFixedUpper = word12HexFixedGeneral True+{-# INLINE word12HexFixedUpper #-}++word12HexFixedLower :: Builder Word12+word12HexFixedLower = word12HexFixedGeneral False+{-# INLINE word12HexFixedLower #-}++hexValuesWord12Upper :: ShortByteString+hexValuesWord12Upper =+  SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%03X") [0 :: Int ..4095]+{-# NOINLINE hexValuesWord12Upper #-}++hexValuesWord12Lower :: ShortByteString+hexValuesWord12Lower =+  SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%03x") [0 :: Int ..4095]+{-# NOINLINE hexValuesWord12Lower #-}++word8HexFixedUpper :: Builder Word8+word8HexFixedUpper = word8HexFixedGeneral True+{-# INLINE word8HexFixedUpper #-}++word8HexFixedLower :: Builder Word8+word8HexFixedLower = word8HexFixedGeneral False+{-# INLINE word8HexFixedLower #-}++-- The Bool is True if the hex digits are upper case.+word8HexFixedGeneral :: Bool -> Builder Word8+word8HexFixedGeneral upper = BuilderFunction (BC8.pack "--") $ \i marr w -> do+  let !ix = unsafeShiftL (fromIntegral w) 1+      !ix2 = ix + 1+      !arr = if upper then hexValuesWord8Upper else hexValuesWord8Lower+  pokeByteOff marr i (SBS.unsafeIndex arr ix)+  pokeByteOff marr (i + 1) (SBS.unsafeIndex arr ix2)+{-# INLINE word8HexFixedGeneral #-}++hexValuesWord8Upper :: ShortByteString+hexValuesWord8Upper =+  SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%02X") [0 :: Int ..255]+{-# NOINLINE hexValuesWord8Upper #-}++hexValuesWord8Lower :: ShortByteString+hexValuesWord8Lower =+  SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%02x") [0 :: Int ..255]+{-# NOINLINE hexValuesWord8Lower #-}++char8 :: Builder Char+char8 = BuilderFunction (BC8.pack "-") $ \i marr c -> pokeByteOff marr i (c2w c)+{-# INLINE char8 #-}++word8 :: Builder Word8+word8 = BuilderFunction (BC8.pack "-") $ \i marr w -> pokeByteOff marr i w+{-# INLINE word8 #-}++word8At :: Int -> Word64 -> Word8+word8At i w = fromIntegral (unsafeShiftR w i)+{-# INLINE word8At #-}++-- | Taken from @Data.ByteString.Internal@. The same warnings+--   apply here.+c2w :: Char -> Word8+c2w = fromIntegral . ord+{-# INLINE c2w #-}++-- macBuilder :: Builder Word64+-- macBuilder =+--      contramapBuilder (word8At 40) twoDigitWord8Hex+--   <> BuilderStatic ":"+--   <> contramapBuilder (word8At 32) twoDigitWord8Hex+--   <> BuilderStatic ":"+--   <> contramapBuilder (word8At 24) twoDigitWord8Hex+--   <> BuilderStatic ":"+--   <> contramapBuilder (word8At 16) twoDigitWord8Hex+--   <> BuilderStatic ":"+--   <> contramapBuilder (word8At 8) twoDigitWord8Hex+--   <> BuilderStatic ":"+--   <> contramapBuilder (word8At 0) twoDigitWord8Hex++

@@ -0,0 +1,89 @@+module Data.Text.Builder.Common.Internal where++import Data.Text (Text)+import Control.Monad.ST+import Data.Monoid+import Data.Word+import Data.Bits+import Text.Printf+import Debug.Trace+import Data.Char (ord)+import Data.Word.Synthetic (Word12)+import Data.Vector (Vector)+import Data.Foldable (fold)+import qualified Data.Vector as Vector+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.IO as LText+import qualified Data.Text.Lazy.Builder as TBuilder+import qualified Data.Text.Lazy.Builder.Int as TBuilder+import qualified Data.Text.IO as Text+import qualified Data.Text.Array as A+import qualified Data.Text.Internal as TI+import qualified Data.Text.Internal.Unsafe.Char as TC++-- | This is slower that just pattern matching on the Text data constructor.+--   However, it will work with GHCJS. This should only be used in places+--   where we know that it will only be evaluated once.+portableTextArray :: Text -> A.Array+portableTextArray = fst . portableUntext+{-# INLINE portableTextArray #-}++-- | This length is not the character length. It is the length of Word16s+--   required by a UTF16 representation.+portableTextLength :: Text -> Int+portableTextLength = snd . portableUntext+{-# INLINE portableTextLength #-}++portableUntext :: Text -> (A.Array,Int)+portableUntext t =+  let str = Text.unpack t+      Sum len = foldMap (Sum . charUtf16Size) str+      arr = A.run $ do+        marr <- A.new len+        writeString marr str+        return marr+   in (arr,len)+{-# NOINLINE portableUntext #-}++writeString :: A.MArray s -> String -> ST s ()+writeString marr = go 0 where+  go i s = case s of+    c : cs -> do+      n <- TC.unsafeWrite marr i c+      go (i + n) cs+    [] -> return ()++charUtf16Size :: Char -> Int+charUtf16Size c = if ord c < 0x10000 then 1 else 2++hexValuesWord12Upper :: A.Array+hexValuesWord12Upper = portableTextArray $ fold+  $ map (Text.pack . printf "%03X") [0 :: Int ..4096]+{-# NOINLINE hexValuesWord12Upper #-}++hexValuesWord12Lower :: A.Array+hexValuesWord12Lower = portableTextArray $ fold+  $ map (Text.pack . printf "%03x") [0 :: Int ..4096]+{-# NOINLINE hexValuesWord12Lower #-}++hexValuesWord8Upper :: A.Array+hexValuesWord8Upper = portableTextArray $ fold+  $ map (Text.pack . printf "%02X") [0 :: Int ..255]+{-# NOINLINE hexValuesWord8Upper #-}++hexValuesWord8Lower :: A.Array+hexValuesWord8Lower = portableTextArray $ fold+  $ map (Text.pack . printf "%02x") [0 :: Int ..255]+{-# NOINLINE hexValuesWord8Lower #-}++twoDecimalDigits :: A.Array+twoDecimalDigits = portableTextArray+  $ foldMap (Text.pack . printf "%02d") [0 :: Int ..99]+{-# NOINLINE twoDecimalDigits #-}++threeDecimalDigits :: A.Array+threeDecimalDigits = portableTextArray+  $ foldMap (Text.pack . printf "%03d") [0 :: Int ..255]+{-# NOINLINE threeDecimalDigits #-}+

@@ -0,0 +1,136 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_GHC -O2 -Wall -funbox-strict-fields #-}++{-| For concatenating fixed-width strings that are only a few+    characters each, this can be ten times faster than the builder+    that ships with @text@.+-}+module Data.Text.Builder.Fixed+  ( Builder+  , fromText+  , run+  , contramapBuilder+  , charBmp+  , word8HexFixedLower+  , word8HexFixedUpper+  , word12HexFixedLower+  , word12HexFixedUpper+  ) where++import Control.Monad.ST+import Data.Monoid+import Data.Word+import Data.Bits+import Text.Printf+import Debug.Trace+import Data.Char (ord)+import Data.Word.Synthetic (Word12)+import Data.Vector (Vector)+import Data.Foldable (fold)+import Data.Text (Text)+import qualified Data.Vector as Vector+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.IO as LText+import qualified Data.Text.Lazy.Builder as TBuilder+import qualified Data.Text.Lazy.Builder.Int as TBuilder+import qualified Data.Text.IO as Text+import qualified Data.Text.Array as A+import qualified Data.Text.Internal as TI+import qualified Data.Text.Internal.Unsafe.Char as TC+import qualified Data.Text.Builder.Common.Internal as I++data Builder a where+  BuilderStatic :: Text -> Builder a+  BuilderFunction :: Text -> (forall s. Int -> A.MArray s -> a -> ST s ()) -> Builder a++instance Monoid (Builder a) where+  {-# INLINE mempty #-}+  mempty = BuilderStatic Text.empty+  {-# INLINE mappend #-}+  mappend x y = case x of+    BuilderStatic t1 -> case y of+      BuilderStatic t2 -> BuilderStatic (t1 <> t2)+      BuilderFunction t2 f ->+        let len1 = I.portableTextLength t1+         in BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a)+    BuilderFunction t1 f1 -> case y of+      BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1+      BuilderFunction t2 f2 ->+        let len1 = I.portableTextLength t1+         in BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a)++fromText :: Text -> Builder a+fromText = BuilderStatic+{-# INLINE fromText #-}++contramapBuilder :: (b -> a) -> Builder a -> Builder b+contramapBuilder f x = case x of+  BuilderStatic t -> BuilderStatic t+  BuilderFunction t g -> BuilderFunction t (\ix marr b -> g ix marr (f b))+{-# INLINE contramapBuilder #-}++run :: Builder a -> a -> Text+run x = case x of+  BuilderStatic t -> \_ -> t+  BuilderFunction t f ->+    let (inArr, len) = I.portableUntext t+     in \a ->+          let outArr = runST $ do+                marr <- A.new len+                A.copyI marr 0 inArr 0 len+                f 0 marr a+                A.unsafeFreeze marr+           in TI.text outArr 0 len+{-# INLINE run #-}++word8HexFixedUpper :: Builder Word8+word8HexFixedUpper = word8HexFixedGeneral True+{-# INLINE word8HexFixedUpper #-}++word8HexFixedLower :: Builder Word8+word8HexFixedLower = word8HexFixedGeneral False+{-# INLINE word8HexFixedLower #-}++-- The Bool is True if the hex digits are upper case.+word8HexFixedGeneral :: Bool -> Builder Word8+word8HexFixedGeneral upper =+  BuilderFunction (Text.pack "--") $ \i marr w -> do+    let ix = unsafeShiftL (fromIntegral w) 1+        ix2 = ix + 1+        arr = if upper then I.hexValuesWord8Upper else I.hexValuesWord8Lower+    A.unsafeWrite marr i (A.unsafeIndex arr ix)+    A.unsafeWrite marr (i + 1) (A.unsafeIndex arr ix2)+{-# INLINE word8HexFixedGeneral #-}++-- | Characters outside the basic multilingual plane are not handled+--   correctly by this function. They will not cause a program to crash;+--   instead, the character will have the upper bits masked out.+charBmp :: Builder Char+charBmp =+  BuilderFunction (Text.pack "-") $ \i marr c -> A.unsafeWrite marr i (fromIntegral (ord c))+{-# INLINE charBmp #-}++word12HexFixedGeneral :: Bool -> Builder Word12+word12HexFixedGeneral upper =+  BuilderFunction (Text.pack "---") $ \i marr w -> do+    let !wInt = fromIntegral w+        !ix = wInt + wInt + wInt+        !arr = if upper then I.hexValuesWord12Upper else I.hexValuesWord12Lower+    A.unsafeWrite marr i (A.unsafeIndex arr ix)+    A.unsafeWrite marr (i + 1) (A.unsafeIndex arr (ix + 1))+    A.unsafeWrite marr (i + 2) (A.unsafeIndex arr (ix + 2))+{-# INLINE word12HexFixedGeneral #-}++word12HexFixedUpper :: Builder Word12+word12HexFixedUpper = word12HexFixedGeneral True+{-# INLINE word12HexFixedUpper #-}++word12HexFixedLower :: Builder Word12+word12HexFixedLower = word12HexFixedGeneral False+{-# INLINE word12HexFixedLower #-}+

@@ -0,0 +1,129 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}++{-| This is a builder optimized for concatenating short+    variable-length strings whose length has a known upper+    bound. In these cases, this can be up to ten times faster+    than the builder provided by the @text@ library. However,+    data whose textual encoding has no known upper bound cannot+    be encoded by the builder provided here. For example, it+    is possible to provide decimal builders for types like 'Int8' and+    'Word16', whose lengths are respectively bounded by+    4 and 5. However, this is not possible for 'Integer', since+    its decimal representation could be arbitrarily long.+-}+module Data.Text.Builder.Variable+  ( Builder+  , run+  , contramap+  , charBmp+  , staticCharBmp+  , word8+  ) where++import Data.Monoid+import Data.Word+import Data.Text (Text)+import Text.Printf (printf)+import Control.Monad.ST+import Data.Char (ord)+import Data.Vector (Vector)+import Data.Function (on)+import Data.Maybe (fromMaybe)+import qualified Data.Vector as Vector+import qualified Data.Text as Text+import qualified Data.Text.Array as A+import qualified Data.Text.Builder.Common.Internal as I+import qualified Data.Text.Internal as TI++data Builder a+  = Builder+      {-# UNPACK #-} !Int -- the maximum length, not a character count+      !(forall s. Int -> A.MArray s -> a -> ST s Int)++instance Monoid (Builder a) where+  {-# INLINE mempty #-}+  mempty = Builder 0 (\i _ _ -> return i)+  {-# INLINE mappend #-}+  mappend (Builder len1 f) (Builder len2 g) =+    Builder (len1 + len2) $ \ix1 marr a -> do+      ix2 <- f ix1 marr a+      g ix2 marr a++run :: Builder a -> a -> Text+run (Builder maxLen f) = \a ->+  let (outArr,len) = A.run2 $ do+        marr <- A.new maxLen+        finalIx <- f 0 marr a+        return (marr,finalIx)+   in TI.text outArr 0 len+{-# INLINE run #-}++contramap :: (b -> a) -> Builder a -> Builder b+contramap f (Builder len g) = Builder len $ \i marr b ->+  g i marr (f b)+{-# INLINE contramap #-}++-- finish writing this. it's important for completeness+-- char :: Builder a+-- char = Builder 2 $ \++-- | A character in the basic multilingual plane.+charBmp :: Builder Char+charBmp = Builder 1 $ \i marr c -> do+  A.unsafeWrite marr i (fromIntegral (ord c))+  return (i + 1)+{-# INLINE charBmp #-}++staticCharBmp :: Char -> Builder a+staticCharBmp c = Builder 1 $ \i marr _ -> do+  A.unsafeWrite marr i (fromIntegral (ord c))+  return (i + 1)+{-# INLINE staticCharBmp #-}++word8 :: Builder Word8+word8 = Builder 3 $ \pos marr w -> if+  | w < 10 -> do+      A.unsafeWrite marr pos (i2w w)+      return (pos + 1)+  | w < 100 -> do+      let wInt = fromIntegral w+          ix = wInt + wInt+      A.unsafeWrite marr pos (A.unsafeIndex I.twoDecimalDigits ix)+      A.unsafeWrite marr (pos + 1) (A.unsafeIndex I.twoDecimalDigits (ix + 1))+      return (pos + 2)+  | otherwise -> do+      let wInt = fromIntegral w+          ix = wInt + wInt + wInt+      A.unsafeWrite marr pos (A.unsafeIndex I.threeDecimalDigits ix)+      A.unsafeWrite marr (pos + 1) (A.unsafeIndex I.threeDecimalDigits (ix + 1))+      A.unsafeWrite marr (pos + 2) (A.unsafeIndex I.threeDecimalDigits (ix + 2))+      return (pos + 3)+{-# INLINE word8 #-}++-- This has not yet been tested.+vector ::+     Text -- ^ Default, used when index is out of range+  -> Vector Text -- ^ Texts to index into+  -> Builder Int+vector tDef v =+  let xs = Vector.map I.portableUntext v+      xDef = I.portableUntext tDef+   in Builder+        (Vector.maximum $ Vector.map I.portableTextLength $ Vector.cons tDef v)+        $ \pos marr i -> do+          let (arr,len) = fromMaybe xDef (xs Vector.!? i)+              finalIx = i + len+          A.copyI marr i arr 0 finalIx+          return finalIx+{-# INLINE vector #-}++i2w :: Integral a => a -> Word16+i2w v = asciiZero + fromIntegral v+{-# INLINE i2w #-}++asciiZero :: Word16+asciiZero = 48+{-# INLINE asciiZero #-}+

@@ -0,0 +1,13 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.Word.Synthetic+  ( Word48+  , Word12+  ) where++import Data.Word.Synthetic.Word48 (Word48)+import Data.Word.Synthetic.Word12 (Word12)+

@@ -0,0 +1,220 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE MagicHash         #-}+{-# LANGUAGE NoImplicitPrelude #-}+++-- |+-- Module      : Data.Word.Word12+-- License     : see  src/Data/LICENSE+-- Stability   : experimental+-- Portability : non-portable (GHC Extensions)++-- Provide a 12-bit unsigned integral type: 'Word12', analagous to Word8,+-- Word16, etc.+--++module Data.Word.Synthetic.Word12 (+  -- * Word12 type+    Word12(..)+  -- * Internal helpers+  , narrow12Word#+  , clz12#+  , ctz12#+  , popCnt12#+  )++where++import           Data.Bits+import           Data.Data+import           Data.Maybe+import           Foreign.Storable++import           GHC.Arr+import           GHC.Base+import           GHC.Enum+import           GHC.Num+import           GHC.Ptr+import           GHC.Read+import           GHC.Real+import           GHC.Show+import           GHC.Word++------------------------------------------------------------------------++-- Word12 is represented in the same way as Word.  Operations may assume and+-- must ensure that it holds only values in its logical range.++-- | 12-bit unsigned integer type+--+data Word12 = W12# Word# deriving (Eq, Ord)++word12Type :: DataType+word12Type = mkIntType "Data.Word.Synthetic.Word12.Word12"++instance Data Word12 where+  toConstr x = mkIntegralConstr word12Type x+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Word12."+  dataTypeOf _ = word12Type++-- | narrowings represented as primop 'and#' in GHC.+narrow12Word# :: Word# -> Word#+narrow12Word# = and# 0xFFF##++-- | count leading zeros+--+clz12# :: Word# -> Word#+clz12# w# = clz32# (narrow12Word# w#) `minusWord#` 20##++-- | count trailing zeros+--+ctz12# :: Word# -> Word#+ctz12# w# = ctz# w#++-- | the number of set bits+--+popCnt12# :: Word# -> Word#+popCnt12# w# = popCnt# (narrow12Word# w#)++instance Show Word12 where+  showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Word12 where+  (W12# x#) + (W12# y#) = W12# (narrow12Word# (x# `plusWord#` y#))+  (W12# x#) - (W12# y#) = W12# (narrow12Word# (x# `minusWord#` y#))+  (W12# x#) * (W12# y#) = W12# (narrow12Word# (x# `timesWord#` y#))+  negate (W12# x#)      = W12# (narrow12Word# (int2Word# (negateInt# (word2Int# x#))))+  abs x                 = x+  signum 0              = 0+  signum _              = 1+  fromInteger i         = W12# (narrow12Word# (integerToWord i))++instance Real Word12 where+  toRational x = toInteger x % 1++instance Enum Word12 where+  succ x+    | x /= maxBound  = x + 1+    | otherwise      = succError "Word12"+  pred x+    | x /= minBound  = x - 1+    | otherwise      = predError "Word12"+  toEnum i@(I# i#)+    | i >= 0 && i <= fromIntegral (maxBound :: Word12)+                     = W12# (int2Word# i#)+    | otherwise      = toEnumError "Word12" i (minBound::Word12, maxBound::Word12)+  fromEnum (W12# x#) = I# (word2Int# x#)+  enumFrom           = boundedEnumFrom+  enumFromThen       = boundedEnumFromThen++instance Integral Word12 where+  quot (W12# x#) y@(W12# y#)+    | y /= 0                 = W12# (x# `quotWord#` y#)+    | otherwise              = divZeroError+  rem (W12# x#) y@(W12# y#)+    | y /= 0                 = W12# (x# `remWord#` y#)+    | otherwise              = divZeroError+  div (W12# x#) y@(W12# y#)+    | y /= 0                 = W12# (x# `quotWord#` y#)+    | otherwise              = divZeroError+  mod (W12# x#) y@(W12# y#)+    | y /= 0                 = W12# (x# `remWord#` y#)+    | otherwise              = divZeroError+  quotRem (W12# x#) y@(W12# y#)+    | y /= 0                 = (W12# (x# `quotWord#` y#), W12# (x# `remWord#` y#))+    | otherwise              = divZeroError+  divMod (W12# x#) y@(W12# y#)+    | y /= 0                 = (W12# (x# `quotWord#` y#), W12# (x# `remWord#` y#))+    | otherwise              = divZeroError+  toInteger (W12# x#)        = smallInteger (word2Int# x#)++instance Bounded Word12 where+  minBound = 0+  maxBound = 0xFFFFFF++instance Ix Word12 where+  range (m,n)         = [m..n]+  unsafeIndex (m,_) i = fromIntegral (i - m)+  inRange (m,n) i     = m <= i && i <= n++instance Read Word12 where+  readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Word12 where+    {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}++    (W12# x#) .&.   (W12# y#)  = W12# (x# `and#` y#)+    (W12# x#) .|.   (W12# y#)  = W12# (x# `or#`  y#)+    (W12# x#) `xor` (W12# y#)  = W12# (x# `xor#` y#)+    complement (W12# x#)       = W12# (x# `xor#` mb#) where !(W12# mb#) = maxBound+    (W12# x#) `shift` (I# i#)+        | isTrue# (i# >=# 0#)  = W12# (narrow12Word# (x# `shiftL#` i#))+        | otherwise            = W12# (x# `shiftRL#` negateInt# i#)+    (W12# x#) `shiftL` (I# i#)       = W12# (narrow12Word# (x# `shiftL#` i#))+    (W12# x#) `unsafeShiftL` (I# i#) =+        W12# (narrow12Word# (x# `uncheckedShiftL#` i#))+    (W12# x#) `shiftR`       (I# i#) = W12# (x# `shiftRL#` i#)+    (W12# x#) `unsafeShiftR` (I# i#) = W12# (x# `uncheckedShiftRL#` i#)+    (W12# x#) `rotate`       i+        | isTrue# (i'# ==# 0#) = W12# x#+        | otherwise  = W12# (narrow12Word# ((x# `uncheckedShiftL#` i'#) `or#`+                                            (x# `uncheckedShiftRL#` (12# -# i'#))))+      where+        !(I# i'#) = i `mod` 12+    bitSizeMaybe i            = Just (finiteBitSize i)+    bitSize                   = finiteBitSize+    isSigned _                = False+    popCount (W12# x#)        = I# (word2Int# (popCnt12# x#))+    bit                       = bitDefault+    testBit                   = testBitDefault++instance FiniteBits Word12 where+    finiteBitSize _ = 12+    countLeadingZeros  (W12# x#) = I# (word2Int# (clz12# x#))+    countTrailingZeros (W12# x#) = I# (word2Int# (ctz12# x#))++{-# RULES+"fromIntegral/Word8->Word12"    fromIntegral = \(W8# x#) -> W12# x#+"fromIntegral/Word12->Word12"   fromIntegral = id :: Word12 -> Word12+"fromIntegral/Word12->Integer"  fromIntegral = toInteger :: Word12 -> Integer+"fromIntegral/a->Word12"        fromIntegral = \x -> case fromIntegral x of W# x# -> W12# (narrow12Word# x#)+"fromIntegral/Word12->a"        fromIntegral = \(W12# x#) -> fromIntegral (W# x#)+  #-}++{-# RULES+"properFraction/Float->(Word12,Float)"+    properFraction = \x ->+                      case properFraction x of {+                        (n, y) -> ((fromIntegral :: Int -> Word12) n, y :: Float) }+"truncate/Float->Word12"+    truncate = (fromIntegral :: Int -> Word12) . (truncate :: Float -> Int)+"floor/Float->Word12"+    floor    = (fromIntegral :: Int -> Word12) . (floor :: Float -> Int)+"ceiling/Float->Word12"+    ceiling  = (fromIntegral :: Int -> Word12) . (ceiling :: Float -> Int)+"round/Float->Word12"+    round    = (fromIntegral :: Int -> Word12) . (round  :: Float -> Int)+  #-}++{-# RULES+"properFraction/Double->(Word12,Double)"+    properFraction = \x ->+                      case properFraction x of {+                        (n, y) -> ((fromIntegral :: Int -> Word12) n, y :: Double) }+"truncate/Double->Word12"+    truncate = (fromIntegral :: Int -> Word12) . (truncate :: Double -> Int)+"floor/Double->Word12"+    floor    = (fromIntegral :: Int -> Word12) . (floor :: Double -> Int)+"ceiling/Double->Word12"+    ceiling  = (fromIntegral :: Int -> Word12) . (ceiling :: Double -> Int)+"round/Double->Word12"+    round    = (fromIntegral :: Int -> Word12) . (round  :: Double -> Int)+  #-}++

@@ -0,0 +1,252 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.Word.Synthetic.Word48 where++import Data.Bits+import Data.Word+import Data.Int+import Data.Ratio+import GHC.Arr+import GHC.Enum+import Data.Primitive.Types+import Data.Hashable (Hashable)+import qualified Data.Vector.Unboxed as UVector+import qualified Data.Vector.Generic as GVector+import qualified Data.Vector.Unboxed.Mutable as MUVector+import qualified Data.Vector.Generic.Mutable as MGVector++newtype Word48 = W48 Word64+  deriving (Eq,Ord,Hashable)++narrow48Word :: Word64 -> Word64+narrow48Word = (.&.) 0xFFFFFFFFFFFF+{-# INLINE narrow48Word #-}++popCnt48 :: Word64 -> Int+popCnt48 = popCount . narrow48Word+{-# INLINE popCnt48 #-}++word48UpperWord16 :: Word48 -> Word16+word48UpperWord16 (W48 w) = fromIntegral (unsafeShiftR w 32)++word48LowerWord32 :: Word48 -> Word32+word48LowerWord32 (W48 w) = fromIntegral w++word48FromUpperLower :: Word16 -> Word32 -> Word48+word48FromUpperLower a b =+  W48 (unsafeShiftL (fromIntegral a) 32 .|. fromIntegral b)++instance Show Word48 where+  showsPrec p (W48 x) = showsPrec p x++instance Num Word48 where+  (W48 x) + (W48 y) = W48 (narrow48Word (x + y))+  (W48 x) - (W48 y) = W48 (narrow48Word (x - y))+  (W48 x) * (W48 y) = W48 (narrow48Word (x * y))+  negate (W48 x) = W48 (negate (fromIntegral (negate (fromIntegral x :: Int64))))+  abs x = x+  signum 0 = 0+  signum _ = 1+  fromInteger i = W48 (narrow48Word (fromInteger i))++instance Real Word48 where+  toRational (W48 x) = toInteger x % 1++instance Enum Word48 where+  succ x+    | x /= maxBound = x + 1+    | otherwise = succError "Word48"+  pred x+    | x /= minBound  = x - 1+    | otherwise      = predError "Word48"+  toEnum i+    | i >= 0 && i <= fromIntegral (maxBound :: Word48)+                     = W48 (fromIntegral i)+    | otherwise      = toEnumError "Word48" i (minBound::Word48, maxBound::Word48)+  -- Causes a bounds check to occur twice+  fromEnum (W48 x)+    | x <= fromIntegral (maxBound :: Int) = fromIntegral x+    | otherwise = fromEnumError "Word48" x+  enumFrom           = boundedEnumFrom+  enumFromThen       = boundedEnumFromThen++instance Integral Word48 where+  quot (W48 x) (W48 y) = W48 (x `quot` y)+  rem (W48 x) (W48 y) = W48 (x `rem` y)+  div (W48 x) (W48 y) = W48 (x `quot` y)+  mod (W48 x) (W48 y) = W48 (x `rem` y)+  quotRem (W48 x) (W48 y) = (W48 (x `quot` y), W48 (x `rem` y))+  divMod (W48 x) (W48 y) = (W48 (x `quot` y), W48 (x `rem` y))+  toInteger (W48 x) = toInteger x++instance Bounded Word48 where+  minBound = 0+  maxBound = 0xFFFFFFFFFFFF++instance Ix Word48 where+  range (m,n)         = [m..n]+  unsafeIndex (m,_) i = fromIntegral (i - m)+  inRange (m,n) i     = m <= i && i <= n++instance Read Word48 where+  readsPrec p s = [(fromIntegral (x::Word64), r) | (x, r) <- readsPrec p s]++instance Bits Word48 where+    {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}++    (W48 x) .&.   (W48 y)  = W48 (x .&. y)+    (W48 x) .|.   (W48 y)  = W48 (x .|.  y)+    (W48 x) `xor` (W48 y)  = W48 (x `xor` y)+    complement (W48 x) = W48 (x `xor` mb) where !(W48 mb) = maxBound+    (W48 x) `shift` i+        | i >= 0 = W48 (narrow48Word (x `shiftL` i))+        | otherwise = W48 (x `shiftR` negate i)+    (W48 x) `shiftL` i = W48 (narrow48Word (x `shiftL` i))+    (W48 x) `unsafeShiftL` i =+        W48 (narrow48Word (x `unsafeShiftL` i))+    (W48 x) `shiftR`       i = W48 (x `shiftR` i)+    (W48 x) `unsafeShiftR` i = W48 (x `unsafeShiftR` i)+    (W48 x) `rotate`       i+        | i' == 0 = W48 x+        | otherwise = W48 (narrow48Word ((x `unsafeShiftL` i') .|.+                                            (x `unsafeShiftR` (48 - i'))))+      where+        !i' = i `mod` 48+    bitSizeMaybe i = Just (finiteBitSize i)+    bitSize = finiteBitSize+    isSigned _ = False+    popCount (W48 x) = popCnt48 x+    bit = bitDefault+    testBit = testBitDefault++instance FiniteBits Word48 where+    finiteBitSize _ = 48+    countLeadingZeros (W48 x) = countLeadingZeros x - 16+    countTrailingZeros (W48 x) = countTrailingZeros x++data instance MUVector.MVector s Word48+  = MV_Word48+      {-# UNPACK #-} !Int+      !(MUVector.MVector s Word16)+      !(MUVector.MVector s Word32)++data instance UVector.Vector Word48+  = V_Word48+      {-# UNPACK #-} !Int+      !(UVector.Vector Word16)+      !(UVector.Vector Word32)++instance UVector.Unbox Word48++instance MGVector.MVector MUVector.MVector Word48 where+  {-# INLINE basicLength  #-}+  basicLength (MV_Word48 n_ as bs) = n_+  {-# INLINE basicUnsafeSlice  #-}+  basicUnsafeSlice i_ m_ (MV_Word48 n_ as bs)+      = MV_Word48 m_+          (MGVector.basicUnsafeSlice i_ m_ as)+          (MGVector.basicUnsafeSlice i_ m_ bs)+  {-# INLINE basicOverlaps  #-}+  basicOverlaps (MV_Word48 n_1 as1 bs1) (MV_Word48 n_2 as2 bs2)+      = MGVector.basicOverlaps as1 as2+        || MGVector.basicOverlaps bs1 bs2+  {-# INLINE basicUnsafeNew  #-}+  basicUnsafeNew n_+      = do+          as <- MGVector.basicUnsafeNew n_+          bs <- MGVector.basicUnsafeNew n_+          return $ MV_Word48 n_ as bs+  {-# INLINE basicInitialize  #-}+  basicInitialize (MV_Word48 _ as bs)+      = do+          MGVector.basicInitialize as+          MGVector.basicInitialize bs+  {-# INLINE basicUnsafeReplicate  #-}+  basicUnsafeReplicate n_ w+      = do+          let upper = word48UpperWord16 w+              lower = word48LowerWord32 w+          as <- MGVector.basicUnsafeReplicate n_ upper+          bs <- MGVector.basicUnsafeReplicate n_ lower+          return $ MV_Word48 n_ as bs+  {-# INLINE basicUnsafeRead  #-}+  basicUnsafeRead (MV_Word48 n_ as bs) i_+      = do+          a <- MGVector.basicUnsafeRead as i_+          b <- MGVector.basicUnsafeRead bs i_+          return (word48FromUpperLower a b)+  {-# INLINE basicUnsafeWrite  #-}+  basicUnsafeWrite (MV_Word48 n_ as bs) i_ w+      = do+          let upper = word48UpperWord16 w+              lower = word48LowerWord32 w+          MGVector.basicUnsafeWrite as i_ upper+          MGVector.basicUnsafeWrite bs i_ lower+  {-# INLINE basicClear  #-}+  basicClear (MV_Word48 n_ as bs)+      = do+          MGVector.basicClear as+          MGVector.basicClear bs+  {-# INLINE basicSet  #-}+  basicSet (MV_Word48 n_ as bs) w+      = do+          let upper = word48UpperWord16 w+              lower = word48LowerWord32 w+          MGVector.basicSet as upper+          MGVector.basicSet bs lower+  {-# INLINE basicUnsafeCopy  #-}+  basicUnsafeCopy (MV_Word48 n_1 as1 bs1) (MV_Word48 n_2 as2 bs2)+      = do+          MGVector.basicUnsafeCopy as1 as2+          MGVector.basicUnsafeCopy bs1 bs2+  {-# INLINE basicUnsafeMove  #-}+  basicUnsafeMove (MV_Word48 n_1 as1 bs1) (MV_Word48 n_2 as2 bs2)+      = do+          MGVector.basicUnsafeMove as1 as2+          MGVector.basicUnsafeMove bs1 bs2+  {-# INLINE basicUnsafeGrow  #-}+  basicUnsafeGrow (MV_Word48 n_ as bs) m_+      = do+          as' <- MGVector.basicUnsafeGrow as m_+          bs' <- MGVector.basicUnsafeGrow bs m_+          return $ MV_Word48 (m_+n_) as' bs'++instance GVector.Vector UVector.Vector Word48 where+  {-# INLINE basicUnsafeFreeze  #-}+  basicUnsafeFreeze (MV_Word48 n_ as bs)+      = do+          as' <- GVector.basicUnsafeFreeze as+          bs' <- GVector.basicUnsafeFreeze bs+          return $ V_Word48 n_ as' bs'+  {-# INLINE basicUnsafeThaw  #-}+  basicUnsafeThaw (V_Word48 n_ as bs)+      = do+          as' <- GVector.basicUnsafeThaw as+          bs' <- GVector.basicUnsafeThaw bs+          return $ MV_Word48 n_ as' bs'+  {-# INLINE basicLength  #-}+  basicLength (V_Word48 n_ as bs) = n_+  {-# INLINE basicUnsafeSlice  #-}+  basicUnsafeSlice i_ m_ (V_Word48 n_ as bs)+      = V_Word48 m_ (GVector.basicUnsafeSlice i_ m_ as)+                 (GVector.basicUnsafeSlice i_ m_ bs)+  {-# INLINE basicUnsafeIndexM  #-}+  basicUnsafeIndexM (V_Word48 n_ as bs) i_+      = do+          a <- GVector.basicUnsafeIndexM as i_+          b <- GVector.basicUnsafeIndexM bs i_+          return (word48FromUpperLower a b)+  {-# INLINE basicUnsafeCopy  #-}+  basicUnsafeCopy (MV_Word48 n_1 as1 bs1) (V_Word48 n_2 as2 bs2)+      = do+          GVector.basicUnsafeCopy as1 as2+          GVector.basicUnsafeCopy bs1 bs2+  {-# INLINE elemseq  #-}+  elemseq _ = seq++

@@ -16,7 +16,7 @@ parser :: Atto.Parser IPv6 parser = do   s <- start-  case toIPv6 (traceShowId s) of+  case toIPv6 s of     Nothing -> fail "Wrong number of octets in IPv6 address"     Just ip -> return ip   where

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}  module Net.Internal where @@ -10,6 +11,9 @@ import Data.ByteString (ByteString) import Data.Text.Lazy.Builder.Int (decimal) import Control.Monad+import Text.Printf (printf)+import Data.Char (chr,ord)+import Data.Word.Synthetic (Word48) import qualified Data.Text              as Text import qualified Data.Text.Lazy         as LText import qualified Data.Attoparsec.Text   as AT@@ -22,6 +26,12 @@ import qualified Data.Text.Read         as TextRead import qualified Data.Text.Lazy.Builder.Int as TBuilder +-- | Taken from @Data.ByteString.Internal@. The same warnings+--   apply here.+c2w :: Char -> Word8+c2w = fromIntegral . ord+{-# INLINE c2w #-}+ eitherToAesonParser :: Either String a -> Aeson.Parser a eitherToAesonParser x = case x of   Left err -> fail err@@ -95,11 +105,27 @@ --   to do more of the math upfront and allocate less space. toTextPreAllocated :: Word32 -> Text toTextPreAllocated w =-  let w1 = fromIntegral $ 255 .&. shiftR w 24-      w2 = fromIntegral $ 255 .&. shiftR w 16-      w3 = fromIntegral $ 255 .&. shiftR w 8-      w4 = fromIntegral $ 255 .&. w-      dot = 46+  let w1 = 255 .&. unsafeShiftR (fromIntegral w) 24+      w2 = 255 .&. unsafeShiftR (fromIntegral w) 16+      w3 = 255 .&. unsafeShiftR (fromIntegral w) 8+      w4 = 255 .&. fromIntegral w+   in toTextPreallocatedPartTwo w1 w2 w3 w4++toTextPreallocatedPartTwo :: Word -> Word -> Word -> Word -> Text+toTextPreallocatedPartTwo w1 w2 w3 w4 =+#ifdef ghcjs_HOST_OS+  let dotStr = "."+   in Text.pack $ concat+        [ show w1+        , "."+        , show w2+        , "."+        , show w3+        , "."+        , show w4+        ]+#else+  let dot = 46       (arr,len) = runST $ do         marr <- TArray.new 15         i1 <- putAndCount 0 w1 marr@@ -117,9 +143,10 @@         i4 <- putAndCount n3' w4 marr         theArr <- TArray.unsafeFreeze marr         return (theArr,i4 + n3')-  in Text arr 0 len+   in Text arr 0 len+#endif -putAndCount :: Int -> Word8 -> TArray.MArray s -> ST s Int+putAndCount :: Int -> Word -> TArray.MArray s -> ST s Int putAndCount pos w marr   | w < 10 = TArray.unsafeWrite marr pos (i2w w) >> return 1   | w < 100 = write2 pos w >> return 2@@ -135,24 +162,63 @@     TArray.unsafeWrite marr (off + 1) $ get3 (j + 1)     TArray.unsafeWrite marr (off + 2) $ get3 (j + 2)   get2 = fromIntegral . ByteString.unsafeIndex twoDigits-  get3 = fromIntegral . ByteString.unsafeIndex threeDigits+  get3 = fromIntegral . ByteString.unsafeIndex threeDigitsWord8 -putMac :: ByteString -> Int -> Int -> TArray.MArray s -> ST s ()-putMac hexPairs pos w marr = do-  let i = w + w+putMac :: ByteString -> Int -> Word64 -> TArray.MArray s -> ST s ()+putMac hexPairs pos w' marr = do+  let w = fromIntegral w'+      i = w + w   TArray.unsafeWrite marr pos $ fromIntegral $ ByteString.unsafeIndex hexPairs i   TArray.unsafeWrite marr (pos + 1) $ fromIntegral $ ByteString.unsafeIndex hexPairs (i + 1) {-# INLINE putMac #-} -macToTextPreAllocated :: Word8 -> Bool -> Word16 -> Word32 -> Text-macToTextPreAllocated separator' isUpperCase wa wb =-  let w1 = fromIntegral $ 255 .&. unsafeShiftR wa 8-      w2 = fromIntegral $ 255 .&. wa-      w3 = fromIntegral $ 255 .&. unsafeShiftR wb 24-      w4 = fromIntegral $ 255 .&. unsafeShiftR wb 16-      w5 = fromIntegral $ 255 .&. unsafeShiftR wb 8-      w6 = fromIntegral $ 255 .&. wb-      hexPairs = if isUpperCase then twoHexDigits else twoHexDigitsLower+word48AsOctets :: Word48 -> (Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> a) -> a+word48AsOctets w f =+  let w1 = fromIntegral $ unsafeShiftR w 40+      w2 = fromIntegral $ unsafeShiftR w 32+      w3 = fromIntegral $ unsafeShiftR w 24+      w4 = fromIntegral $ unsafeShiftR w 16+      w5 = fromIntegral $ unsafeShiftR w 8+      w6 = fromIntegral w+  in f w1 w2 w3 w4 w5 w6+{-# INLINE word48AsOctets #-}++macToTextDefault :: Word48 -> Text+macToTextDefault = macToTextPreAllocated 58 False++macToTextPreAllocated :: Word8 -> Bool -> Word48 -> Text+macToTextPreAllocated separator' isUpperCase w =+  let w1 = 255 .&. unsafeShiftR (fromIntegral w) 40+      w2 = 255 .&. unsafeShiftR (fromIntegral w) 32+      w3 = 255 .&. unsafeShiftR (fromIntegral w) 24+      w4 = 255 .&. unsafeShiftR (fromIntegral w) 16+      w5 = 255 .&. unsafeShiftR (fromIntegral w) 8+      w6 = 255 .&. fromIntegral w+  in macToTextPartTwo separator' isUpperCase w1 w2 w3 w4 w5 w6+{-# INLINE macToTextPreAllocated #-}++macToTextPartTwo :: Word8 -> Bool -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Text+macToTextPartTwo separator' isUpperCase w1 w2 w3 w4 w5 w6 =+#ifdef ghcjs_HOST_OS+  Text.pack $ concat+    [ toHex w1+    , separatorStr+    , toHex w2+    , separatorStr+    , toHex w3+    , separatorStr+    , toHex w4+    , separatorStr+    , toHex w5+    , separatorStr+    , toHex w6+    ]+  where+  toHex :: Word64 -> String+  toHex = if isUpperCase then printf "%02X" else printf "%02x"+  separatorStr = [chr (fromEnum separator')]+#else+  let hexPairs = if isUpperCase then twoHexDigits else twoHexDigitsLower       separator = fromIntegral separator' :: Word16       arr = runST $ do         marr <- TArray.new 17@@ -169,8 +235,10 @@         putMac hexPairs 15 w6 marr         TArray.unsafeFreeze marr   in Text arr 0 17-{-# INLINE macToTextPreAllocated #-}+#endif+{-# INLINE macToTextPartTwo #-} + zero :: Word16 zero = 48 {-# INLINE zero #-}@@ -335,7 +403,7 @@ -- r1,r2,r3,r4,r5,r6 :: Word32 -- r1 = fromOctets' 0 0 0 0 -macTextParser :: Maybe Char -> (Word16 -> Word16 -> Word32 -> Word32 -> Word32 -> Word32 -> a) -> AT.Parser a+macTextParser :: Maybe Char -> (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> a) -> AT.Parser a macTextParser separator f = f   <$> (AT.hexadecimal >>= limitSize)   <*  parseSeparator@@ -357,91 +425,41 @@       then fail "All octets in a mac address must be between 00 and FF"       else return i -macToText :: Word16 -> Word32 -> Text-macToText a b = LText.toStrict (TBuilder.toLazyText (macToTextBuilder a b))--macToTextBuilder :: Word16 -> Word32 -> TBuilder.Builder-macToTextBuilder a b =-  TBuilder.hexadecimal (255 .&. shiftR a 8 )-  <> colon-  <> TBuilder.hexadecimal (255 .&. a )-  <> colon-  <> TBuilder.hexadecimal (255 .&. shiftR b 24 )-  <> colon-  <> TBuilder.hexadecimal (255 .&. shiftR b 16 )-  <> colon-  <> TBuilder.hexadecimal (255 .&. shiftR b 8 )-  <> colon-  <> TBuilder.hexadecimal (255 .&. b)-  where colon = TBuilder.singleton ':'+-- Unchecked invariant: each of these Word64s must be smaller+-- than 256.+unsafeWord48FromOctets :: Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word48+unsafeWord48FromOctets a b c d e f =+    fromIntegral+  $ unsafeShiftL a 40+  .|. unsafeShiftL b 32+  .|. unsafeShiftL c 24+  .|. unsafeShiftL d 16+  .|. unsafeShiftL e 8+  .|. f+{-# INLINE unsafeWord48FromOctets #-} -macFromText :: Maybe Char -> (Word16 -> Word16 -> Word32 -> Word32 -> Word32 -> Word32 -> a) -> Text -> Maybe a+macFromText :: Maybe Char -> (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> a) -> Text -> Maybe a macFromText separator f = rightToMaybe . macFromText' separator f {-# INLINE macFromText #-} -macFromText' :: Maybe Char -> (Word16 -> Word16 -> Word32 -> Word32 -> Word32 -> Word32 -> a) -> Text -> Either String a+macFromText' :: Maybe Char -> (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> a) -> Text -> Either String a macFromText' separator f =   AT.parseOnly (macTextParser separator f <* AT.endOfInput) {-# INLINE macFromText' #-}  twoDigits :: ByteString-twoDigits = BC8.pack-  "0001020304050607080910111213141516171819\-  \2021222324252627282930313233343536373839\-  \4041424344454647484950515253545556575859\-  \6061626364656667686970717273747576777879\-  \8081828384858687888990919293949596979899"+twoDigits = foldMap (BC8.pack . printf "%02d") $ enumFromTo (0 :: Int) 99+{-# NOINLINE twoDigits #-} -threeDigits :: ByteString-threeDigits =-  ByteString.replicate 300 0 <> BC8.pack-  "100101102103104105106107108109110111112\-  \113114115116117118119120121122123124125\-  \126127128129130131132133134135136137138\-  \139140141142143144145146147148149150151\-  \152153154155156157158159160161162163164\-  \165166167168169170171172173174175176177\-  \178179180181182183184185186187188189190\-  \191192193194195196197198199200201202203\-  \204205206207208209210211212213214215216\-  \217218219220221222223224225226227228229\-  \230231232233234235236237238239240241242\-  \243244245246247248249250251252253254255"+threeDigitsWord8 :: ByteString+threeDigitsWord8 = foldMap (BC8.pack . printf "%03d") $ enumFromTo (0 :: Int) 255+{-# NOINLINE threeDigitsWord8 #-}  twoHexDigits :: ByteString-twoHexDigits = BC8.pack-  "000102030405060708090A0B0C0D0E0F\-  \101112131415161718191A1B1C1D1E1F\-  \202122232425262728292A2B2C2D2E2F\-  \303132333435363738393A3B3C3D3E3F\-  \404142434445464748494A4B4C4D4E4F\-  \505152535455565758595A5B5C5D5E5F\-  \606162636465666768696A6B6C6D6E6F\-  \707172737475767778797A7B7C7D7E7F\-  \808182838485868788898A8B8C8D8E8F\-  \909192939495969798999A9B9C9D9E9F\-  \A0A1A2A3A4A5A6A7A8A9AAABACADAEAF\-  \B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF\-  \C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF\-  \D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF\-  \E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF\-  \F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF"+twoHexDigits = foldMap (BC8.pack . printf "%02X") $ enumFromTo (0 :: Int) 255+{-# NOINLINE twoHexDigits #-}  twoHexDigitsLower :: ByteString-twoHexDigitsLower = BC8.pack-  "000102030405060708090a0b0c0d0e0f\-  \101112131415161718191a1b1c1d1e1f\-  \202122232425262728292a2b2c2d2e2f\-  \303132333435363738393a3b3c3d3e3f\-  \404142434445464748494a4b4c4d4e4f\-  \505152535455565758595a5b5c5d5e5f\-  \606162636465666768696a6b6c6d6e6f\-  \707172737475767778797a7b7c7d7e7f\-  \808182838485868788898a8b8c8d8e8f\-  \909192939495969798999a9b9c9d9e9f\-  \a0a1a2a3a4a5a6a7a8a9aaabacadaeaf\-  \b0b1b2b3b4b5b6b7b8b9babbbcbdbebf\-  \c0c1c2c3c4c5c6c7c8c9cacbcccdcecf\-  \d0d1d2d3d4d5d6d7d8d9dadbdcdddedf\-  \e0e1e2e3e4e5e6e7e8e9eaebecedeeef\-  \f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff"+twoHexDigitsLower = foldMap (BC8.pack . printf "%02x") $ enumFromTo (0 :: Int) 255+{-# NOINLINE twoHexDigitsLower #-}+

@@ -3,34 +3,27 @@  module Net.Mac   ( fromOctets-  , fromOctetsNoCast+  , toOctets   ) where  import Net.Types (Mac(..))-import Data.Text (Text)-import Data.Hashable (Hashable)-import GHC.Generics (Generic) import Data.Word-import Data.Aeson (ToJSON(..),FromJSON(..))-import qualified Data.Attoparsec.Text as AT-import qualified Data.Attoparsec.ByteString.Char8 as AB-import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement)-import Net.Internal (attoparsecParseJSON,rightToMaybe)-import qualified Data.Text.Lazy.Builder as TBuilder-import Data.Text.Lazy.Builder.Int (hexadecimal)-import Data.Monoid ((<>))-import qualified Data.Aeson as Aeson-import qualified Data.Text.Lazy as LText+import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement,unsafeShiftR)+import qualified Net.Internal as Internal  fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Mac-fromOctets a b c d e f = fromOctetsNoCast+fromOctets a b c d e f = Mac $ Internal.unsafeWord48FromOctets   (fromIntegral a) (fromIntegral b) (fromIntegral c)   (fromIntegral d) (fromIntegral e) (fromIntegral f)--fromOctetsNoCast :: Word16 -> Word16 -> Word32 -> Word32 -> Word32 -> Word32 -> Mac-fromOctetsNoCast a b c d e f = Mac-    ( shiftL a 8 .|. b )-    ( shiftL c 24 .|. shiftL d 16 .|. shiftL e 8 .|. f )-{-# INLINE fromOctetsNoCast #-}+{-# INLINE fromOctets #-} +toOctets :: Mac -> (Word8,Word8,Word8,Word8,Word8,Word8)+toOctets (Mac w) =+  ( fromIntegral $ unsafeShiftR w 40+  , fromIntegral $ unsafeShiftR w 32+  , fromIntegral $ unsafeShiftR w 24+  , fromIntegral $ unsafeShiftR w 16+  , fromIntegral $ unsafeShiftR w 8+  , fromIntegral w+  ) 

@@ -1,36 +1,44 @@ module Net.Mac.ByteString.Char8   ( encode+  , encodeWith   , decode+  , decodeWith+  , decodeLenient   , builder   , parser   , parserWith+  , parserLenient   ) where -import Net.Types (Mac(..),MacEncoding(..),MacDecoding(..))+import Net.Types (Mac(..),MacCodec(..),MacGrouping(..)) import Net.Mac (fromOctets) import Data.ByteString (ByteString) import Data.Attoparsec.ByteString.Char8 (Parser) import Data.ByteString.Lazy.Builder (Builder)-import Net.Internal (rightToMaybe)+import Net.Internal (rightToMaybe,c2w) import Data.Text.Encoding (encodeUtf8, decodeUtf8') import Data.Word (Word8)-import Data.Bits (unsafeShiftL)+import Data.Word.Synthetic (Word12)+import Data.Bits (unsafeShiftL,unsafeShiftR) import Control.Monad+import Data.Monoid+import qualified Data.ByteString.Builder.Fixed as FB import qualified Data.ByteString.Builder as Builder import qualified Data.Attoparsec.ByteString as ABW import qualified Data.Attoparsec.ByteString.Char8 as AB-import qualified Net.Mac.Text as MacText --- | This is a mediocre implementation that should---   be rewritten. encode :: Mac -> ByteString-encode = encodeUtf8 . MacText.encode+encode = encodeWith defCodec --- | This is a mediocre implementation that should---   be rewritten. decode :: ByteString -> Maybe Mac-decode = MacText.decode <=< rightToMaybe . decodeUtf8'+decode = decodeWith defCodec +decodeWith :: MacCodec -> ByteString -> Maybe Mac+decodeWith codec bs = rightToMaybe (AB.parseOnly (parserWith codec <* AB.endOfInput) bs)++decodeLenient :: ByteString -> Maybe Mac+decodeLenient bs = rightToMaybe (AB.parseOnly (parserLenient <* AB.endOfInput) bs)+ -- | Make a bytestring builder from a 'Mac' address --   using a colon as the separator. builder :: Mac -> Builder@@ -39,41 +47,208 @@ -- | Parser for a 'Mac' address using with a colon as the --   separator (i.e. @FA:43:B2:C0:0F:99@). parser :: Parser Mac-parser = parserWith defDecoding+parser = parserWith defCodec --- | Parser for a 'Mac' address using to the provided---   settings.-parserWith :: MacDecoding -> Parser Mac-parserWith (MacDecoding separator) = fromOctets+-- | Parser for a 'Mac' address using the provided settings.+parserWith :: MacCodec -> Parser Mac+parserWith (MacCodec g _) = case g of+  MacGroupingPairs s -> parserPairs (c2w s)+  MacGroupingTriples s -> parserTriples (c2w s)+  MacGroupingQuadruples s -> parserQuadruples (c2w s)+  MacGroupingNoSeparator -> parserNoSeparator++parserLenient :: Parser Mac+parserLenient = do+  a1 <- parseOneHex+  a2 <- parseOneHexLenient+  a3 <- parseOneHexLenient+  a4 <- parseOneHexLenient+  a5 <- parseOneHexLenient+  a6 <- parseOneHexLenient+  a7 <- parseOneHexLenient+  a8 <- parseOneHexLenient+  a9 <- parseOneHexLenient+  a10 <- parseOneHexLenient+  a11 <- parseOneHexLenient+  a12 <- parseOneHexLenient+  return $ fromOctets+    (unsafeShiftL a1 4 + a2)+    (unsafeShiftL a3 4 + a4)+    (unsafeShiftL a5 4 + a6)+    (unsafeShiftL a7 4 + a8)+    (unsafeShiftL a9 4 + a10)+    (unsafeShiftL a11 4 + a12)+++parserNoSeparator :: Parser Mac+parserNoSeparator = fromOctets   <$> parseTwoHex-  <*  parseSeparator   <*> parseTwoHex-  <*  parseSeparator   <*> parseTwoHex-  <*  parseSeparator   <*> parseTwoHex-  <*  parseSeparator   <*> parseTwoHex-  <*  parseSeparator   <*> parseTwoHex-  where-  parseSeparator = case separator of-    Just c -> ABW.word8 c-    Nothing -> return 60 -- character is unused +parserPairs :: Word8 -> Parser Mac+parserPairs s = fromOctets+  <$> parseTwoHex <* ABW.word8 s+  <*> parseTwoHex <* ABW.word8 s+  <*> parseTwoHex <* ABW.word8 s+  <*> parseTwoHex <* ABW.word8 s+  <*> parseTwoHex <* ABW.word8 s+  <*> parseTwoHex++parserTriples :: Word8 -> Parser Mac+parserTriples s = do+  a1 <- parseOneHex+  a2 <- parseOneHex+  a3 <- parseOneHex+  _ <- ABW.word8 s+  a4 <- parseOneHex+  a5 <- parseOneHex+  a6 <- parseOneHex+  _ <- ABW.word8 s+  a7 <- parseOneHex+  a8 <- parseOneHex+  a9 <- parseOneHex+  _ <- ABW.word8 s+  a10 <- parseOneHex+  a11 <- parseOneHex+  a12 <- parseOneHex+  return $ fromOctets+    (unsafeShiftL a1 4 + a2)+    (unsafeShiftL a3 4 + a4)+    (unsafeShiftL a5 4 + a6)+    (unsafeShiftL a7 4 + a8)+    (unsafeShiftL a9 4 + a10)+    (unsafeShiftL a11 4 + a12)++parserQuadruples :: Word8 -> Parser Mac+parserQuadruples s  = fromOctets+  <$> parseTwoHex <*> parseTwoHex <* ABW.word8 s+  <*> parseTwoHex <*> parseTwoHex <* ABW.word8 s+  <*> parseTwoHex <*> parseTwoHex++parseOneHex :: Parser Word8+parseOneHex = ABW.anyWord8 >>= parseWord8Hex++-- | Parse a single hexidecimal character. This will skip+--   at most one character to do this.+parseOneHexLenient :: Parser Word8+parseOneHexLenient = do+  a <- ABW.anyWord8+  flip tryParseWord8Hex a $ do+    b <- ABW.anyWord8+    tryParseWord8Hex (fail "invalid hexadecimal character") b+ parseTwoHex :: Parser Word8 parseTwoHex = do   a <- ABW.anyWord8 >>= parseWord8Hex   b <- ABW.anyWord8 >>= parseWord8Hex   return (unsafeShiftL a 4 + b) -parseWord8Hex :: Word8 -> Parser Word8-parseWord8Hex w-  | w >= 48 && w <= 57  = return (w - 48)-  | w >= 65 && w <= 70  = return (w - 55)+-- | Kind of a confusing type signature. The Word8 that stands+--   alone represented an ascii-encoded value. The others actually+--   describes the numbers that would be decoded from this value.+tryParseWord8Hex :: Parser Word8 -> Word8 -> Parser Word8+tryParseWord8Hex a w+  | w >= 48 && w <= 57 = return (w - 48)+  | w >= 65 && w <= 70 = return (w - 55)   | w >= 97 && w <= 102 = return (w - 87)-  | otherwise = fail "invalid hexadecimal character"+  | otherwise = a -defDecoding :: MacDecoding-defDecoding = MacDecoding (Just 58)+parseWord8Hex :: Word8 -> Parser Word8+parseWord8Hex = tryParseWord8Hex (fail "invalid hexadecimal character")++defCodec :: MacCodec+defCodec = MacCodec (MacGroupingPairs ':') False++encodeWith :: MacCodec -> Mac -> ByteString+encodeWith (MacCodec g u) m = case g of+  MacGroupingNoSeparator -> case u of+    True -> FB.run (fixedBuilderNoSeparator FB.word8HexFixedUpper) m+    False -> FB.run (fixedBuilderNoSeparator FB.word8HexFixedLower) m+  MacGroupingPairs c -> case u of+    True -> FB.run (fixedBuilderPairs FB.word8HexFixedUpper) (Pair (c2w c) m)+    False -> FB.run (fixedBuilderPairs FB.word8HexFixedLower) (Pair (c2w c) m)+    -- withCasedBuilder u $ \bw8 -> FB.run (fixedBuilderPairs bw8) (Pair c m)+  MacGroupingTriples c -> case u of+    True -> FB.run (fixedBuilderTriples FB.word12HexFixedUpper) (Pair (c2w c) m)+    False -> FB.run (fixedBuilderTriples FB.word12HexFixedLower) (Pair (c2w c) m)+  MacGroupingQuadruples c -> case u of+    True -> FB.run (fixedBuilderQuadruples FB.word8HexFixedUpper) (Pair (c2w c) m)+    False -> FB.run (fixedBuilderQuadruples FB.word8HexFixedLower) (Pair (c2w c) m)++withCasedBuilder :: Bool -> (FB.Builder Word8 -> a) -> a+withCasedBuilder x f = case x of+  True -> f FB.word8HexFixedUpper+  False -> f FB.word8HexFixedLower+{-# INLINE withCasedBuilder #-}++withCasedBuilderTriple :: Bool -> (FB.Builder Word12 -> a) -> a+withCasedBuilderTriple x f = case x of+  True -> f FB.word12HexFixedUpper+  False -> f FB.word12HexFixedLower+{-# INLINE withCasedBuilderTriple #-}++data Pair = Pair+  { pairSep :: {-# UNPACK #-} !Word8+  , pairMac :: {-# UNPACK #-} !Mac+  }++fixedBuilderTriples :: FB.Builder Word12 -> FB.Builder Pair+fixedBuilderTriples tripBuilder =+     FB.contramapBuilder (word12At 36 . pairMac) tripBuilder+  <> FB.contramapBuilder pairSep FB.word8+  <> FB.contramapBuilder (word12At 24 . pairMac) tripBuilder+  <> FB.contramapBuilder pairSep FB.word8+  <> FB.contramapBuilder (word12At 12 . pairMac) tripBuilder+  <> FB.contramapBuilder pairSep FB.word8+  <> FB.contramapBuilder (word12At 0 . pairMac) tripBuilder+{-# INLINE fixedBuilderTriples #-}++fixedBuilderQuadruples :: FB.Builder Word8 -> FB.Builder Pair+fixedBuilderQuadruples pairBuilder =+     FB.contramapBuilder (word8At 40 . pairMac) pairBuilder+  <> FB.contramapBuilder (word8At 32 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.word8+  <> FB.contramapBuilder (word8At 24 . pairMac) pairBuilder+  <> FB.contramapBuilder (word8At 16 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.word8+  <> FB.contramapBuilder (word8At 8 . pairMac) pairBuilder+  <> FB.contramapBuilder (word8At 0 . pairMac) pairBuilder+{-# INLINE fixedBuilderQuadruples #-}++fixedBuilderPairs :: FB.Builder Word8 -> FB.Builder Pair+fixedBuilderPairs pairBuilder =+     FB.contramapBuilder (word8At 40 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.word8+  <> FB.contramapBuilder (word8At 32 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.word8+  <> FB.contramapBuilder (word8At 24 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.word8+  <> FB.contramapBuilder (word8At 16 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.word8+  <> FB.contramapBuilder (word8At 8 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.word8+  <> FB.contramapBuilder (word8At 0 . pairMac) pairBuilder+{-# INLINE fixedBuilderPairs #-}++fixedBuilderNoSeparator :: FB.Builder Word8 -> FB.Builder Mac+fixedBuilderNoSeparator hexBuilder =+     FB.contramapBuilder (word8At 40) hexBuilder+  <> FB.contramapBuilder (word8At 32) hexBuilder+  <> FB.contramapBuilder (word8At 24) hexBuilder+  <> FB.contramapBuilder (word8At 16) hexBuilder+  <> FB.contramapBuilder (word8At 8) hexBuilder+  <> FB.contramapBuilder (word8At 0) hexBuilder+{-# INLINE fixedBuilderNoSeparator #-}++word8At :: Int -> Mac -> Word8+word8At i (Mac w) = fromIntegral (unsafeShiftR w i)+{-# INLINE word8At #-}++word12At :: Int -> Mac -> Word12+word12At i (Mac w) = fromIntegral (unsafeShiftR w i)+{-# INLINE word12At #-} 

@@ -10,50 +10,212 @@   , parserWith   ) where -import Net.Types (Mac(..),MacEncoding(..),MacDecoding(..))-import Net.Mac (fromOctetsNoCast)+import Net.Types (Mac(..),MacCodec(..),MacGrouping(..))+import Net.Mac (fromOctets)+-- import Net.Mac (fromOctetsNoCast) import Data.Text (Text) import Data.Word (Word8)+import Data.Word.Synthetic (Word12) import Data.Char (chr)+import Data.Attoparsec.Text (Parser)+import Net.Internal (rightToMaybe,c2w)+import Data.Bits (unsafeShiftL,unsafeShiftR)+import Data.Monoid import qualified Net.Internal as Internal import qualified Data.Attoparsec.Text as AT import qualified Data.Text.Lazy.Builder as TBuilder+import qualified Data.Text.Builder.Fixed as FB  encode :: Mac -> Text-encode (Mac a b) = Internal.macToTextPreAllocated 58 False a b+encode = encodeWith defCodec -- Internal.macToTextDefault w -decodeEitherWith :: MacDecoding -> Text -> Either String Mac-decodeEitherWith (MacDecoding separator) =-  Internal.macFromText' (fmap w8ToChar separator) fromOctetsNoCast+encodeWith :: MacCodec -> Mac -> Text+encodeWith (MacCodec g u) m = case g of+  MacGroupingNoSeparator -> case u of+    True -> FB.run (fixedBuilderNoSeparator FB.word8HexFixedUpper) m+    False -> FB.run (fixedBuilderNoSeparator FB.word8HexFixedLower) m+  MacGroupingPairs c -> case u of+    True -> FB.run (fixedBuilderPairs FB.word8HexFixedUpper) (Pair c m)+    False -> FB.run (fixedBuilderPairs FB.word8HexFixedLower) (Pair c m)+    -- withCasedBuilder u $ \bw8 -> FB.run (fixedBuilderPairs bw8) (Pair c m)+  MacGroupingTriples c -> case u of+    True -> FB.run (fixedBuilderTriples FB.word12HexFixedUpper) (Pair c m)+    False -> FB.run (fixedBuilderTriples FB.word12HexFixedLower) (Pair c m)+  MacGroupingQuadruples c -> case u of+    True -> FB.run (fixedBuilderQuadruples FB.word8HexFixedUpper) (Pair c m)+    False -> FB.run (fixedBuilderQuadruples FB.word8HexFixedLower) (Pair c m) +withCasedBuilder :: Bool -> (FB.Builder Word8 -> a) -> a+withCasedBuilder x f = case x of+  True -> f FB.word8HexFixedUpper+  False -> f FB.word8HexFixedLower+{-# INLINE withCasedBuilder #-}+++decodeEitherWith :: MacCodec -> Text -> Either String Mac+decodeEitherWith codec t = AT.parseOnly (parserWith codec <* AT.endOfInput) t+ decodeEither :: Text -> Either String Mac-decodeEither = decodeEitherWith defDecoding+decodeEither = decodeEitherWith defCodec  decode :: Text -> Maybe Mac-decode = decodeWith defDecoding--decodeWith :: MacDecoding -> Text -> Maybe Mac-decodeWith d = Internal.rightToMaybe . decodeEitherWith d+decode = decodeWith defCodec --- decodeWith ::+decodeWith :: MacCodec -> Text -> Maybe Mac+decodeWith codec t = rightToMaybe (AT.parseOnly (parserWith codec <* AT.endOfInput) t)  builder :: Mac -> TBuilder.Builder-builder (Mac a b) = Internal.macToTextBuilder a b+builder = TBuilder.fromText . encode  parser :: AT.Parser Mac-parser = parserWith defDecoding+parser = parserWith defCodec -parserWith :: MacDecoding -> AT.Parser Mac-parserWith (MacDecoding separator) =-  Internal.macTextParser (fmap w8ToChar separator) fromOctetsNoCast+parserWith :: MacCodec -> AT.Parser Mac+parserWith (MacCodec g _) = case g of+  MacGroupingQuadruples c -> parserQuadruples c+  MacGroupingTriples c -> parserTriples c+  MacGroupingPairs c -> parserPairs c+  MacGroupingNoSeparator -> parserNoSeparator -encodeWith :: MacEncoding -> Mac -> Text-encodeWith (MacEncoding separator isUpperCase) (Mac a b) =-  Internal.macToTextPreAllocated separator isUpperCase a b -defDecoding :: MacDecoding-defDecoding = MacDecoding (Just 58)+defCodec :: MacCodec+defCodec = MacCodec (MacGroupingPairs ':') False  w8ToChar :: Word8 -> Char w8ToChar = chr . fromIntegral +parserQuadruples :: Char -> Parser Mac+parserQuadruples s = fromOctets+  <$> parseTwoHex <*> parseTwoHex <* AT.char s+  <*> parseTwoHex <*> parseTwoHex <* AT.char s+  <*> parseTwoHex <*> parseTwoHex++parserPairs :: Char -> Parser Mac+parserPairs s = fromOctets+  <$> parseTwoHex <* AT.char s+  <*> parseTwoHex <* AT.char s+  <*> parseTwoHex <* AT.char s+  <*> parseTwoHex <* AT.char s+  <*> parseTwoHex <* AT.char s+  <*> parseTwoHex++parserTriples :: Char -> Parser Mac+parserTriples s = do+  a1 <- parseOneHex+  a2 <- parseOneHex+  a3 <- parseOneHex+  _ <- AT.char s+  a4 <- parseOneHex+  a5 <- parseOneHex+  a6 <- parseOneHex+  _ <- AT.char s+  a7 <- parseOneHex+  a8 <- parseOneHex+  a9 <- parseOneHex+  _ <- AT.char s+  a10 <- parseOneHex+  a11 <- parseOneHex+  a12 <- parseOneHex+  return $ fromOctets+    (unsafeShiftL a1 4 + a2)+    (unsafeShiftL a3 4 + a4)+    (unsafeShiftL a5 4 + a6)+    (unsafeShiftL a7 4 + a8)+    (unsafeShiftL a9 4 + a10)+    (unsafeShiftL a11 4 + a12)++parserNoSeparator :: Parser Mac+parserNoSeparator = fromOctets+  <$> parseTwoHex+  <*> parseTwoHex+  <*> parseTwoHex+  <*> parseTwoHex+  <*> parseTwoHex+  <*> parseTwoHex++parseTwoHex :: Parser Word8+parseTwoHex = do+  a <- AT.anyChar >>= parseCharHex+  b <- AT.anyChar >>= parseCharHex+  return (unsafeShiftL a 4 + b)++tryParseCharHex :: Parser Word8 -> Char -> Parser Word8+tryParseCharHex a c+  | w >= 48 && w <= 57 = return (w - 48)+  | w >= 65 && w <= 70 = return (w - 55)+  | w >= 97 && w <= 102 = return (w - 87)+  | otherwise = a+  where w = c2w c++parseOneHex :: Parser Word8+parseOneHex = AT.anyChar >>= parseCharHex++parseCharHex :: Char -> Parser Word8+parseCharHex = tryParseCharHex (fail "invalid hexadecimal character")++withCasedBuilderTriple :: Bool -> (FB.Builder Word12 -> a) -> a+withCasedBuilderTriple x f = case x of+  True -> f FB.word12HexFixedUpper+  False -> f FB.word12HexFixedLower+{-# INLINE withCasedBuilderTriple #-}++data Pair = Pair+  { pairSep :: {-# UNPACK #-} !Char+  , pairMac :: {-# UNPACK #-} !Mac+  }++fixedBuilderTriples :: FB.Builder Word12 -> FB.Builder Pair+fixedBuilderTriples tripBuilder =+     FB.contramapBuilder (word12At 36 . pairMac) tripBuilder+  <> FB.contramapBuilder pairSep FB.charBmp+  <> FB.contramapBuilder (word12At 24 . pairMac) tripBuilder+  <> FB.contramapBuilder pairSep FB.charBmp+  <> FB.contramapBuilder (word12At 12 . pairMac) tripBuilder+  <> FB.contramapBuilder pairSep FB.charBmp+  <> FB.contramapBuilder (word12At 0 . pairMac) tripBuilder+{-# INLINE fixedBuilderTriples #-}++fixedBuilderNoSeparator :: FB.Builder Word8 -> FB.Builder Mac+fixedBuilderNoSeparator hexBuilder =+     FB.contramapBuilder (word8At 40) hexBuilder+  <> FB.contramapBuilder (word8At 32) hexBuilder+  <> FB.contramapBuilder (word8At 24) hexBuilder+  <> FB.contramapBuilder (word8At 16) hexBuilder+  <> FB.contramapBuilder (word8At 8) hexBuilder+  <> FB.contramapBuilder (word8At 0) hexBuilder+{-# INLINE fixedBuilderNoSeparator #-}++fixedBuilderQuadruples :: FB.Builder Word8 -> FB.Builder Pair+fixedBuilderQuadruples pairBuilder =+     FB.contramapBuilder (word8At 40 . pairMac) pairBuilder+  <> FB.contramapBuilder (word8At 32 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.charBmp+  <> FB.contramapBuilder (word8At 24 . pairMac) pairBuilder+  <> FB.contramapBuilder (word8At 16 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.charBmp+  <> FB.contramapBuilder (word8At 8 . pairMac) pairBuilder+  <> FB.contramapBuilder (word8At 0 . pairMac) pairBuilder+{-# INLINE fixedBuilderQuadruples #-}++fixedBuilderPairs :: FB.Builder Word8 -> FB.Builder Pair+fixedBuilderPairs pairBuilder =+     FB.contramapBuilder (word8At 40 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.charBmp+  <> FB.contramapBuilder (word8At 32 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.charBmp+  <> FB.contramapBuilder (word8At 24 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.charBmp+  <> FB.contramapBuilder (word8At 16 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.charBmp+  <> FB.contramapBuilder (word8At 8 . pairMac) pairBuilder+  <> FB.contramapBuilder pairSep FB.charBmp+  <> FB.contramapBuilder (word8At 0 . pairMac) pairBuilder+{-# INLINE fixedBuilderPairs #-}++word8At :: Int -> Mac -> Word8+word8At i (Mac w) = fromIntegral (unsafeShiftR w i)+{-# INLINE word8At #-}++word12At :: Int -> Mac -> Word12+word12At i (Mac w) = fromIntegral (unsafeShiftR w i)+{-# INLINE word12At #-}

@@ -13,8 +13,8 @@   , IP(..)   , IPv4Range(..)   , Mac(..)-  , MacEncoding(..)-  , MacDecoding(..)+  , MacCodec(..)+  , MacGrouping(..)   ) where  import qualified Net.Internal         as Internal@@ -29,8 +29,9 @@ import qualified Data.Vector.Generic.Mutable    as MGVector import qualified Data.Vector.Unboxed.Mutable    as MUVector import qualified Data.Vector.Primitive.Mutable  as MPVector+import Data.Word.Synthetic (Word48) import Data.Primitive.Types (Prim)-import Data.Bits (Bits,FiniteBits,(.|.),shiftL)+import Data.Bits (Bits,FiniteBits,(.|.),unsafeShiftL) import Data.Coerce (coerce) import Control.Monad import Data.Word@@ -65,34 +66,44 @@   } deriving (Eq,Ord,Show,Read,Generic)  -- | A 48-bit MAC address.-data Mac = Mac-  { macA :: {-# UNPACK #-} !Word16-  , macB :: {-# UNPACK #-} !Word32-  }+newtype Mac = Mac { getMac :: Word48 }   deriving (Eq,Ord,Show,Read,Generic) -data MacEncoding = MacEncoding-  { macEncodingSeparator :: {-# UNPACK #-} !Word8 -- ^ ASCII value of the separator-  , macEncodingUpperCase :: {-# UNPACK #-} !Bool+-- data MacEncoding = MacEncoding+--   { macEncodingSeparator :: {-# UNPACK #-} !Word8 -- ^ ASCII value of the separator+--   , macEncodingUpperCase :: {-# UNPACK #-} !Bool+--   } deriving (Eq,Ord,Show,Read,Generic)++data MacCodec = MacCodec+  { macCodecGrouping :: !MacGrouping+  , macCodecUpperCase :: !Bool   } deriving (Eq,Ord,Show,Read,Generic) -newtype MacDecoding = MacDecoding-  { macDecodingSeparator :: Maybe Word8-  }+-- | The format expected by the mac address parser. The 'Word8' taken+--   by some of these constructors is the ascii value of the character+--   to be used as the separator. This is typically a colon, a hyphen, or+--   a space character. All decoding functions are case insensitive.+data MacGrouping+  = MacGroupingPairs !Char -- ^ Two-character groups, @FA:2B:40:09:8C:11@+  | MacGroupingTriples !Char -- ^ Three-character groups, @24B-F0A-025-829@+  | MacGroupingQuadruples !Char -- ^ Four-character groups, @A220.0745.CAC7@+  | MacGroupingNoSeparator -- ^ No separator, @24AF4B5B0780@+  deriving (Eq,Ord,Show,Read,Generic)  instance Hashable Mac  instance ToJSON Mac where-  toJSON (Mac a b) = Aeson.String (Internal.macToText a b)+  toJSON (Mac w) = Aeson.String (Internal.macToTextDefault w)  instance FromJSON Mac where   parseJSON = Internal.attoparsecParseJSON     (Internal.macTextParser (Just ':') macFromOctets' <* AT.endOfInput) -macFromOctets' :: Word16 -> Word16 -> Word32 -> Word32 -> Word32 -> Word32 -> Mac-macFromOctets' a b c d e f = Mac-    ( shiftL a 8 .|. b )-    ( shiftL c 24 .|. shiftL d 16 .|. shiftL e 8 .|. f )+-- Unchecked invariant: each of these Word64s must be smaller+-- than 256.+macFromOctets' :: Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Mac+macFromOctets' a b c d e f = +  Mac (Internal.unsafeWord48FromOctets a b c d e f) {-# INLINE macFromOctets' #-}  instance Hashable IPv4Range@@ -275,109 +286,8 @@         . GVector.elemseq (undefined :: UVector.Vector b) b  -data instance MUVector.MVector s Mac-    = MV_Mac {-# UNPACK #-} !Int !(MUVector.MVector s Word16)-                                 !(MUVector.MVector s Word32)-data instance UVector.Vector Mac-    = V_Mac {-# UNPACK #-} !Int !(UVector.Vector Word16)-                                !(UVector.Vector Word32)-instance UVector.Unbox Mac-instance MGVector.MVector MUVector.MVector Mac where-  {-# INLINE basicLength  #-}-  basicLength (MV_Mac n_ as bs) = n_-  {-# INLINE basicUnsafeSlice  #-}-  basicUnsafeSlice i_ m_ (MV_Mac n_ as bs)-      = MV_Mac m_ (MGVector.basicUnsafeSlice i_ m_ as)-                  (MGVector.basicUnsafeSlice i_ m_ bs)-  {-# INLINE basicOverlaps  #-}-  basicOverlaps (MV_Mac n_1 as1 bs1) (MV_Mac n_2 as2 bs2)-      = MGVector.basicOverlaps as1 as2-        || MGVector.basicOverlaps bs1 bs2-  {-# INLINE basicUnsafeNew  #-}-  basicUnsafeNew n_-      = do-          as <- MGVector.basicUnsafeNew n_-          bs <- MGVector.basicUnsafeNew n_-          return $ MV_Mac n_ as bs-  {-# INLINE basicInitialize  #-}-  basicInitialize (MV_Mac _ as bs)-      = do-          MGVector.basicInitialize as-          MGVector.basicInitialize bs-  {-# INLINE basicUnsafeReplicate  #-}-  basicUnsafeReplicate n_ (Mac a b)-      = do-          as <- MGVector.basicUnsafeReplicate n_ a-          bs <- MGVector.basicUnsafeReplicate n_ b-          return $ MV_Mac n_ as bs-  {-# INLINE basicUnsafeRead  #-}-  basicUnsafeRead (MV_Mac n_ as bs) i_-      = do-          a <- MGVector.basicUnsafeRead as i_-          b <- MGVector.basicUnsafeRead bs i_-          return (Mac a b)-  {-# INLINE basicUnsafeWrite  #-}-  basicUnsafeWrite (MV_Mac n_ as bs) i_ (Mac a b)-      = do-          MGVector.basicUnsafeWrite as i_ a-          MGVector.basicUnsafeWrite bs i_ b-  {-# INLINE basicClear  #-}-  basicClear (MV_Mac n_ as bs)-      = do-          MGVector.basicClear as-          MGVector.basicClear bs-  {-# INLINE basicSet  #-}-  basicSet (MV_Mac n_ as bs) (Mac a b)-      = do-          MGVector.basicSet as a-          MGVector.basicSet bs b-  {-# INLINE basicUnsafeCopy  #-}-  basicUnsafeCopy (MV_Mac n_1 as1 bs1) (MV_Mac n_2 as2 bs2)-      = do-          MGVector.basicUnsafeCopy as1 as2-          MGVector.basicUnsafeCopy bs1 bs2-  {-# INLINE basicUnsafeMove  #-}-  basicUnsafeMove (MV_Mac n_1 as1 bs1) (MV_Mac n_2 as2 bs2)-      = do-          MGVector.basicUnsafeMove as1 as2-          MGVector.basicUnsafeMove bs1 bs2-  {-# INLINE basicUnsafeGrow  #-}-  basicUnsafeGrow (MV_Mac n_ as bs) m_-      = do-          as' <- MGVector.basicUnsafeGrow as m_-          bs' <- MGVector.basicUnsafeGrow bs m_-          return $ MV_Mac (m_+n_) as' bs'-instance GVector.Vector UVector.Vector Mac where-  {-# INLINE basicUnsafeFreeze  #-}-  basicUnsafeFreeze (MV_Mac n_ as bs)-      = do-          as' <- GVector.basicUnsafeFreeze as-          bs' <- GVector.basicUnsafeFreeze bs-          return $ V_Mac n_ as' bs'-  {-# INLINE basicUnsafeThaw  #-}-  basicUnsafeThaw (V_Mac n_ as bs)-      = do-          as' <- GVector.basicUnsafeThaw as-          bs' <- GVector.basicUnsafeThaw bs-          return $ MV_Mac n_ as' bs'-  {-# INLINE basicLength  #-}-  basicLength (V_Mac n_ as bs) = n_-  {-# INLINE basicUnsafeSlice  #-}-  basicUnsafeSlice i_ m_ (V_Mac n_ as bs)-      = V_Mac m_ (GVector.basicUnsafeSlice i_ m_ as)-                 (GVector.basicUnsafeSlice i_ m_ bs)-  {-# INLINE basicUnsafeIndexM  #-}-  basicUnsafeIndexM (V_Mac n_ as bs) i_-      = do-          a <- GVector.basicUnsafeIndexM as i_-          b <- GVector.basicUnsafeIndexM bs i_-          return (Mac a b)-  {-# INLINE basicUnsafeCopy  #-}-  basicUnsafeCopy (MV_Mac n_1 as1 bs1) (V_Mac n_2 as2 bs2)-      = do-          GVector.basicUnsafeCopy as1 as2-          GVector.basicUnsafeCopy bs1 bs2-  {-# INLINE elemseq  #-}-  elemseq _ (Mac a b)-      = GVector.elemseq (undefined :: UVector.Vector a) a-        . GVector.elemseq (undefined :: UVector.Vector b) b+newtype instance MUVector.MVector s Mac+    = MV_Mac (MUVector.MVector s Word48)++newtype instance UVector.Vector Mac+    = V_Mac (UVector.Vector Word48)

@@ -5,10 +5,13 @@  -- Orphan instances that are needed to make QuickCheck work. -import Net.Types (IPv4(..),IPv4Range(..),Mac(..))-import Test.QuickCheck (Arbitrary(..))+import Net.Types (IPv4(..),IPv4Range(..),Mac(..),MacGrouping(..),MacCodec(..))+import Test.QuickCheck (Arbitrary(..),oneof,Gen,elements)+import Data.Word+import Data.Word.Synthetic  deriving instance Arbitrary IPv4+deriving instance Arbitrary Mac  -- This instance can generate masks that exceed the recommended -- length of 32.@@ -16,7 +19,20 @@   arbitrary = fmap fromTuple arbitrary     where fromTuple (a,b) = IPv4Range a b -instance Arbitrary Mac where-  arbitrary = fmap fromTuple arbitrary-    where fromTuple (a,b) = Mac a b+instance Arbitrary Word48 where+  arbitrary = fromIntegral <$> (arbitrary :: Gen Word64)++instance Arbitrary MacCodec where+  arbitrary = MacCodec <$> arbitrary <*> arbitrary++instance Arbitrary MacGrouping where+  arbitrary = oneof+    [ MacGroupingPairs <$> arbitraryMacSeparator+    , MacGroupingTriples <$> arbitraryMacSeparator+    , MacGroupingQuadruples <$> arbitraryMacSeparator+    , pure MacGroupingNoSeparator+    ]++arbitraryMacSeparator :: Gen Char+arbitraryMacSeparator = elements [':','-','.','_'] 

@@ -1,7 +1,7 @@ module Main (main) where  import Criterion.Main-import Net.Types (IPv4(..))+import Net.Types (IPv4(..),MacGrouping(..),MacCodec(..)) import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement) import Data.Monoid ((<>)) import Data.Text.Lazy.Builder.Int (decimal)@@ -9,14 +9,17 @@ import Data.Word import Data.ByteString (ByteString) import Control.Monad.ST-import qualified Data.Text              as Text-import qualified Data.ByteString.Char8  as BC8-import qualified Data.ByteString        as ByteString-import qualified Data.ByteString.Unsafe as ByteString-import qualified Data.Text.Lazy         as LText-import qualified Data.Text.Lazy.Builder as TBuilder-import qualified Data.Text.Array        as TArray-import qualified Net.IPv4.Text          as IPv4_Text+import qualified Data.Text                as Text+import qualified Data.ByteString.Char8    as BC8+import qualified Data.ByteString          as ByteString+import qualified Data.ByteString.Unsafe   as ByteString+import qualified Data.Text.Lazy           as LText+import qualified Data.Text.Lazy.Builder   as TBuilder+import qualified Data.Text.Array          as TArray+import qualified Net.IPv4.Text            as IPv4_Text+import qualified Net.Mac.Text             as MacText+import qualified Net.Mac.ByteString.Char8 as MacByteString+import qualified Net.Mac                  as Mac  import qualified Naive import qualified IPv4Text1@@ -24,6 +27,7 @@ import qualified IPv4ByteString1 import qualified IPv4DecodeText1 import qualified IPv4DecodeText2+import qualified IPv4TextVariableBuilder  import qualified Net.IPv4.ByteString.Char8 as NIPBS @@ -31,11 +35,27 @@ main = do   let ipAddr = IPv4 1000000009       ipText = Text.pack "192.168.5.99"+      mac = Mac.fromOctets 0xFA 0xBB 0x43 0xA1 0x22 0x09   defaultMain-    [ bgroup "IPv4 to Text"+    [ bgroup "Mac to Text"+      [ bench "Current Implementation, pairs" $ whnf MacText.encode mac+      , bench "Current Implementation, no separator"+          $ whnf (MacText.encodeWith (MacCodec MacGroupingNoSeparator True)) mac+      , bench "Current Implementation, quads"+          $ whnf (MacText.encodeWith (MacCodec (MacGroupingQuadruples '-') True)) mac+      , bench "Current Implementation, triples"+          $ whnf (MacText.encodeWith (MacCodec (MacGroupingQuadruples '.') False)) mac+      ]+    , bgroup "Mac to ByteString"+      [ bench "Current Implementation, pairs" $ whnf MacByteString.encode mac+      , bench "Current Implementation, no separator"+          $ whnf (MacByteString.encodeWith (MacCodec MacGroupingNoSeparator True)) mac+      ]+    , bgroup "IPv4 to Text"       [ bench "Naive" $ whnf Naive.encodeText ipAddr       , bench "Text Builder" $ whnf IPv4Text2.encode ipAddr       , bench "Preallocated" $ whnf IPv4Text1.encode ipAddr+      , bench "Variable Builder" $ whnf IPv4TextVariableBuilder.encode ipAddr       ]     , bgroup "IPv4 from Text"       [ bench "Naive" $ whnf Naive.decodeText ipText

@@ -0,0 +1,30 @@+module IPv4TextVariableBuilder where++import Net.Types (IPv4(..))+import Data.Text (Text)+import Data.Monoid+import Data.Word+import Data.Bits+import qualified Net.IPv4 as IPv4+import qualified Data.Text as Text+import qualified Data.Text.Builder.Variable as VB++encode :: IPv4 -> Text+encode = VB.run variableBuilder++variableBuilder :: VB.Builder IPv4+variableBuilder =+  VB.contramap (word8At 24) VB.word8+  <> VB.staticCharBmp '.'+  <> VB.contramap (word8At 16) VB.word8+  <> VB.staticCharBmp '.'+  <> VB.contramap (word8At 8) VB.word8+  <> VB.staticCharBmp '.'+  <> VB.contramap (word8At 0) VB.word8++word8At :: Int -> IPv4 -> Word8+word8At i (IPv4 w) = fromIntegral (unsafeShiftR w i)+{-# INLINE word8At #-}+++

@@ -8,10 +8,12 @@ import Test.Framework.Providers.HUnit       (testCase) import Test.HUnit                           (Assertion,(@?=)) import Numeric                              (showHex)+import Test.QuickCheck.Property             (failed,succeeded,Result(..)) import Data.Word  import Net.Types (IPv4(..),IPv4Range(..),Mac(..),IPv6(..)) import qualified Data.Text as Text+import qualified Data.ByteString.Char8 as BC8 import qualified Net.IPv4 as IPv4 import qualified Net.IPv6 as IPv6 import qualified Net.IPv4.Range as IPv4Range@@ -20,6 +22,7 @@ import qualified Net.IPv4.ByteString.Char8 as IPv4ByteString import qualified Net.Mac as Mac import qualified Net.Mac.Text as MacText+import qualified Net.Mac.ByteString.Char8 as MacByteString  import qualified Data.Attoparsec.Text as AT @@ -28,6 +31,7 @@ import qualified IPv4Text1 import qualified IPv4Text2 import qualified IPv4ByteString1+import qualified IPv4TextVariableBuilder  main :: IO () main = defaultMain tests@@ -42,9 +46,14 @@       ] ++ testDecodeFailures     , testGroup "Currently used MAC Text encode/decode"       [ testProperty "Isomorphism"-          $ propEncodeDecodeIso MacText.encode MacText.decode+          $ propEncodeDecodeIsoSettings MacText.encodeWith MacText.decodeWith       , testCase "Encode a MAC Address" testMacEncode       ]+    , testGroup "Currently used MAC ByteString encode/decode"+      [ testProperty "Isomorphism"+          $ propEncodeDecodeIsoSettings MacByteString.encodeWith MacByteString.decodeWith+      , testCase "Lenient Decoding" testLenientMacByteStringParser+      ]     , testGroup "Naive IPv4 encode/decode"       [ testProperty "Isomorphism"           $ propEncodeDecodeIso Naive.encodeText Naive.decodeText@@ -53,6 +62,10 @@       [ testProperty "Identical to Naive"           $ propMatching IPv4Text2.encode Naive.encodeText       ]+    , testGroup "Variable Text Builder IPv4 Text encode/decode"+      [ testProperty "Identical to Naive"+          $ propMatching IPv4TextVariableBuilder.encode Naive.encodeText+      ]     , testGroup "Raw byte array IPv4 Text encode/decode"       [ testProperty "Identical to Naive"           $ propMatching IPv4Text1.encode Naive.encodeText@@ -81,6 +94,20 @@ propEncodeDecodeIso :: Eq a => (a -> b) -> (b -> Maybe a) -> a -> Bool propEncodeDecodeIso f g a = g (f a) == Just a +propEncodeDecodeIsoSettings :: (Eq a,Show a,Show b,Show e)+  => (e -> a -> b) -> (e -> b -> Maybe a) -> e -> a -> Result+propEncodeDecodeIsoSettings f g e a =+  let fa = f e a+      gfa = g e fa+   in if gfa == Just a+        then succeeded+        else failure $ concat+          [ "env:     ", show e, "\n"+          , "x:       ", show a, "\n"+          , "f(x):    ", show fa, "\n"+          , "g(f(x)): ", show gfa, "\n"+          ]+ propMatching :: Eq b => (a -> b) -> (a -> b) -> a -> Bool propMatching f g a = f a == g a @@ -101,6 +128,17 @@ testIPv4Decode = IPv4Text.decode (Text.pack "124.222.255.0")              @?= Just (IPv4.fromOctets 124 222 255 0) +testLenientMacByteStringParser :: Assertion+testLenientMacByteStringParser = do+  go 0xAB 0x12 0x0F 0x1C 0x88 0x79+     "AB:12:0F:1C:88:79"+  go 0xAB 0x12 0x0F 0x0C 0xAA 0x76+     "AB1-20F-0CA-A76"+  where+  go a b c d e f str =+    Just (HexMac (Mac.fromOctets a b c d e f))+    @?= fmap HexMac (MacByteString.decodeLenient (BC8.pack str))+ testIPv6Parser :: Assertion testIPv6Parser = do   -- Basic test@@ -150,6 +188,26 @@ testMacEncode :: Assertion testMacEncode = MacText.encode (Mac.fromOctets 0xFF 0x00 0xAB 0x12 0x99 0x0F)             @?= Text.pack "ff:00:ab:12:99:0f"++failure :: String -> Result+failure msg = failed+  { reason = msg+  , theException = Nothing+  }++newtype HexMac = HexMac { getHexMac :: Mac }+  deriving (Eq)++instance Show HexMac where+  showsPrec _ (HexMac v) =+    let (a,b,c,d,e,f) = Mac.toOctets v+     in showHex a . showChar ':'+        . showHex b . showChar ':'+        . showHex c . showChar ':'+        . showHex d . showChar ':'+        . showHex e . showChar ':'+        . showHex f+  newtype HexIPv6 = HexIPv6 { getHexIPv6 :: IPv6 }   deriving (Eq)