diff --git a/fixhs.cabal b/fixhs.cabal --- a/fixhs.cabal +++ b/fixhs.cabal @@ -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 - diff --git a/src/Data/Coparser.hs b/src/Data/Coparser.hs --- a/src/Data/Coparser.hs +++ b/src/Data/Coparser.hs @@ -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 diff --git a/src/Data/FIX/Common.hs b/src/Data/FIX/Common.hs --- a/src/Data/FIX/Common.hs +++ b/src/Data/FIX/Common.hs @@ -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' diff --git a/src/Data/FIX/Coparser.hs b/src/Data/FIX/Coparser.hs --- a/src/Data/FIX/Coparser.hs +++ b/src/Data/FIX/Coparser.hs @@ -1,7 +1,9 @@ -- Module : Data.FIX.Coparser -- License : LGPL-2.1 -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE + TypeSynonymInstances + , FlexibleInstances #-} module Data.FIX.Coparser ( coparse) where diff --git a/src/Data/FIX/Message.hs b/src/Data/FIX/Message.hs --- a/src/Data/FIX/Message.hs +++ b/src/Data/FIX/Message.hs @@ -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 (..) ) diff --git a/src/Data/FIX/Parser.hs b/src/Data/FIX/Parser.hs --- a/src/Data/FIX/Parser.hs +++ b/src/Data/FIX/Parser.hs @@ -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 diff --git a/src/Data/FIX/ParserCombinators.hs b/src/Data/FIX/ParserCombinators.hs --- a/src/Data/FIX/ParserCombinators.hs +++ b/src/Data/FIX/ParserCombinators.hs @@ -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 diff --git a/src/Data/LookupTable.hs b/src/Data/LookupTable.hs --- a/src/Data/LookupTable.hs +++ b/src/Data/LookupTable.hs @@ -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 diff --git a/src/Utils/Generator.hs b/src/Utils/Generator.hs --- a/src/Utils/Generator.hs +++ b/src/Utils/Generator.hs @@ -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 diff --git a/testsuite/tests/FIXParserTest.hs b/testsuite/tests/FIXParserTest.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/FIXParserTest.hs @@ -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))