fixhs 0.1.3 → 0.1.4

raw patch · 10 files changed

+210/−33 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• fixhs.cabal +1/−2
• src/Data/Coparser.hs +22/−16
• src/Data/FIX/Common.hs +0/−3
• src/Data/FIX/Coparser.hs +3/−1
• src/Data/FIX/Message.hs +5/−1
• src/Data/FIX/Parser.hs +3/−3
• src/Data/FIX/ParserCombinators.hs +4/−3
• src/Data/LookupTable.hs +5/−1
• src/Utils/Generator.hs +5/−3
• testsuite/tests/FIXParserTest.hs +162/−0

@@ -1,5 +1,5 @@ name:                fixhs-version:             0.1.3+version:             0.1.4 description:         Financial Information eXchange (FIX) protocol (co)parser homepage:            http://github.com/urv/fixhs synopsis:            FIX (co)parser@@ -80,4 +80,3 @@ source-repository head   type:     git   location: http://github.com/urv/fixhs-

@@ -1,7 +1,12 @@ -- Module  : Data.Coparser -- License : LGPL-2.1  -{-# LANGUAGE BangPatterns, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE +    BangPatterns+  , MultiParamTypeClasses+  , FunctionalDependencies+  , FlexibleInstances+  , TypeSynonymInstances #-}  module Data.Coparser      ( Coparser (..)@@ -27,30 +32,31 @@ import Data.Monoid ( mappend, mconcat ) import qualified Data.DList as DL import Data.Bits.Utils ( w82c )+import GHC.Float ( showFloat ) -class Enum c => BuilderLike a c | a -> c where-    pack :: String -> a-    unpack :: a -> String-    singleton :: Char -> a-    append :: a -> a -> a-    concat :: [a] -> a-    cons :: Char -> a -> a-    snoc :: a -> Char -> a-    decimal :: Integral i => i -> a-    realFloat :: RealFloat r => r -> a+class Enum c => BuilderLike cs c | cs -> c where+    pack :: String -> cs+    unpack :: cs -> String+    singleton :: Char -> cs+    append :: cs -> cs -> cs+    concat :: [cs] -> cs+    cons :: Char -> cs -> cs+    snoc :: cs -> Char -> cs+    decimal :: Integral i => i -> cs+    realFloat :: RealFloat r => r -> cs -    decimal = pack . show-    realFloat = pack . show+    decimal = pack . show . toInteger+    realFloat r = pack $ showFloat r ""     cons c t = singleton c `append` t     snoc t c = t `append` singleton c -    length :: a -> Int+    length :: cs -> Int     length = P.length . unpack -    foldl' :: (b -> Char -> b) -> b -> a -> b+    foldl' :: (b -> Char -> b) -> b -> cs -> b     foldl' f x0 = P.foldl' f x0 . unpack -    foldl :: (b -> Char -> b) -> b -> a -> b+    foldl :: (b -> Char -> b) -> b -> cs -> b     foldl f x0 = P.foldl f x0 . unpack  instance BuilderLike String Char where

@@ -4,9 +4,6 @@ module Data.FIX.Common     ( delimiter)     where--import Data.ByteString ( ByteString )-import Data.ByteString.Char8 as C ( pack )   delimiter :: Char delimiter = '\SOH'

@@ -1,7 +1,9 @@ -- Module  : Data.FIX.Coparser -- License : LGPL-2.1  -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE +    TypeSynonymInstances+  , FlexibleInstances #-}  module Data.FIX.Coparser ( coparse) where 

@@ -1,7 +1,10 @@ -- Module  : Data.FIX.Message -- License : LGPL-2.1  -{-# LANGUAGE MagicHash, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE +    MagicHash+  , GeneralizedNewtypeDeriving #-}+ {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  -- | FIX messages@@ -18,6 +21,7 @@     , FIXSpec (..)     , checksum     , delimiter+    , ListOfValues(..)     ) where  import System.Time ( CalendarTime (..) )

@@ -111,9 +111,9 @@         -- are included in the checksum         _header' :: Parser (Int, Int)         _header' = do -            c1 <- (FIX.checksum <$> string (C.pack "8="))-            c2 <- (FIX.checksum <$> toString)-            c3 <- (FIX.checksum <$> string (C.pack "9="))+            c1 <- FIX.checksum <$> string (C.pack "8=")+            c2 <- FIX.checksum <$> toString+            c3 <- FIX.checksum <$> string (C.pack "9=")             l <- toString             let c4 = FIX.checksum l                 c = (c1 + c2 + c3 + c4 + 2 * ord FIX.delimiter) `mod` 256

@@ -32,12 +32,13 @@ import Data.Char ( ord ) import Data.ByteString hiding ( pack, putStrLn ) import Control.Applicative ( (<$>), (<|>), (*>) )+import Control.Monad (void) import System.Time ( CalendarTime (..) ) import qualified Data.FIX.Common as FIX ( delimiter )   skipFIXDelimiter :: Parser ()-skipFIXDelimiter = char8 FIX.delimiter >> return ()+skipFIXDelimiter = void (char8 FIX.delimiter)    toDouble :: Parser Double@@ -58,7 +59,7 @@     return i  toInt' :: ByteString -> Int-toInt' b = helper 0 b+toInt' = helper 0             where                  helper i j                      | null j    = i@@ -87,7 +88,7 @@      toBool :: Parser Bool toBool = do-    c <- (char 'Y' <|> char 'N')+    c <- char 'Y' <|> char 'N'     skipFIXDelimiter     case c of         'Y' -> return True

@@ -1,7 +1,11 @@ -- Module  : Data.LookupTable -- License : LGPL-2.1  -{-# LANGUAGE FunctionalDependencies, ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE +    FunctionalDependencies+  , ExistentialQuantification+  , MultiParamTypeClasses+  , FlexibleInstances #-}  module Data.LookupTable      ( LookupTable

@@ -1,4 +1,6 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}+{-# LANGUAGE +    GeneralizedNewtypeDeriving+  , FlexibleContexts #-}  import Text.XML.HaXml import qualified Text.XML.HaXml.Pretty as P @@ -362,10 +364,10 @@                 getSepAndCont (_ : ds) = getSepAndCont ds  groupsOf :: [Content a] -> Groups a-groupsOf cs = addGroups LT.new cs+groupsOf = addGroups LT.new      where         addGroups :: Groups a -> [Content a] -> Groups a-        addGroups t = foldr _insert t +        addGroups = foldr _insert              where                  _insert :: Content a -> Groups a -> Groups a                 _insert c@(CElem e _) gs

@@ -0,0 +1,162 @@+{-# LANGUAGE +    TupleSections+  , FlexibleInstances+  , TypeSynonymInstances #-}++import Data.FIX.Arbitrary+import qualified Data.LookupTable as LT+import Data.FIX.Message ( FIXGroupElement(..), FIXSpec(..), FIXMessage(..), FIXValue(..), FIXValues(..), FIXTag(..) )+import Data.FIX.Coparser ( coparse )+import Data.FIX.Parser ( nextP, nextP', messageP  )+import Data.Attoparsec ( parseOnly )+import Data.List (group)+import Test.QuickCheck ( (==>), sample, sample', Gen, oneof, quickCheck, quickCheckResult, forAll, collect, Result(..) )+import Data.FIX.Spec.FIX42+import qualified Data.FIX.Common as FIX+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Char8 as C ( singleton, append )+import System.Time ( CalendarTime(..) )+import System.Exit ( ExitCode(..), exitWith )+import Control.Monad ( void )++prop_orthogonal xs = +	collect (mType xs) $ +	xs == parse (coparse xs)+	where+	   types = xs :: FIXMessage FIXSpec+	   fixSpec = mContext xs+           parse ss = case parseOnly (nextP' >>= messageP fixSpec) ss of+	   	Left err -> error err+		Right ms -> ms+	   	+messagesOf :: FIXSpec -> Gen (FIXMessage FIXSpec)+messagesOf spec = oneof $ map (arbitraryFIXMessage spec) allMessages +	where+	   allMessages = map snd $ LT.toList $ fsMessages spec++tagsOf :: FIXSpec -> Gen (FIXTag, FIXValue)+tagsOf spec = oneof $ map arbitraryTag allTags+	where+	   allTags = map snd $ LT.toList $ fsTags spec+	   arbitraryTag t = fmap (t,) $ arbitraryValue t++prop_tag (tag, v) = collect (tName tag) $ +	v == parse (coparse v)+	where+           parse ss = let ss' = ss `C.append` C.singleton FIX.delimiter in +	   	case parseOnly (tparser tag) ss' of+			Left err -> error err+			Right ms -> ms++instance Eq FIXGroupElement where+	FIXGroupElement i1 s1 vs1 == FIXGroupElement i2 s2 vs2 = +		i1 == i2 && s1 == s2 && vs1 == vs2 ++instance Eq FIXValue where+	FIXInt left == FIXInt right = left == right+	FIXInt _ == _ = False++	FIXDouble left == FIXDouble right = +		left >= right - 0.5+		&& left <= right + 0.5+	FIXDouble _ == _ = False++	FIXChar left == FIXChar right = left == right+	FIXChar _ == _ = False++	FIXBool left == FIXBool right = left == right+	FIXBool _ == _ = False++	FIXString left == FIXString right = left == right+	FIXString _ == _ = False++	FIXData left == FIXData right = left == right+	FIXData _ == _ = False++	FIXMultipleValueString left == FIXMultipleValueString right = left == right+	FIXMultipleValueString _ == _ = False++	FIXTimestamp left == FIXTimestamp right = +		ctYear left == ctYear right +		&& ctMonth left == ctMonth right +		&& ctDay left == ctDay right +		&& ctHour left == ctHour right +		&& ctMin left == ctMin right +		&& ctSec left == ctSec right +		{-&& ctPicosec left == ctPicosec right-}+	FIXTimestamp _ == _ = False++	FIXTimeOnly left == FIXTimeOnly right = +		ctHour left == ctHour right +		&& ctMin left == ctMin right +		&& ctSec left == ctSec right +		{-ctPicosec left == ctPicosec right-}+	FIXTimeOnly _ == _ = False++	FIXDateOnly left == FIXDateOnly right = +		ctYear left == ctYear right +		&& ctMonth left == ctMonth right +		&& ctDay left == ctDay right+	FIXDateOnly _ == _ = False++	FIXMonthYear left == FIXMonthYear right = +		ctYear left == ctYear right +		&& ctMonth left == ctMonth right+	FIXMonthYear _ == _ = False++	FIXGroup nleft left == FIXGroup nright right = +		nleft == nright && left == right +	FIXGroup _ _ == _ = False++-- Define a new type Set that is an unordered List+newtype Set a = Set [a]++isSubset :: Eq a => [a] -> [a] -> Bool+isSubset xs ys = foldr ((&&) . isElement) True $ group ys+	where+           isElement = flip elem $ group xs++instance Eq a => Eq (Set a) where+	Set left == Set right = +		length left == length right &&+		isSubset left right && isSubset right left ++instance Eq FIXValues where+	left == right = Set (LT.toList left) == Set (LT.toList right)++instance Eq (FIXMessage a) where+	left == right = mType left == mType right +		&& mHeader left == mHeader right +		&& mBody left == mBody right +		&& mTrailer left == mTrailer right++instance Show FIXTag where+	show = tName++instance Show FIXValue where+	show (FIXInt i) = show i+	show (FIXDouble i) = show i+	show (FIXChar i) = show i+	show (FIXBool i) = show i+	show (FIXString i) = show i+	show (FIXData i) = show i+	show (FIXMultipleValueString i) = show i+	show (FIXTimestamp i) = show i+	show (FIXTimeOnly i) = show i+	show (FIXDateOnly i) = show i+	show (FIXMonthYear i) = show i++instance Show (FIXMessage FIXSpec) where+	show ms = show (coparse ms :: ByteString)+++main = do+	check $ quickCheckResult $ forAll (messagesOf fix42) prop_orthogonal+	check $ quickCheckResult $ forAll (tagsOf fix42) prop_tag+	where+		check :: IO Result -> IO ()+		check io = do +			res <- io+			case res of +				Success {} -> return ()+				_ -> void (exitWith (ExitFailure 1))