1{-# LANGUAGE OverloadedStrings #-} 2{-# LANGUAGE RecordWildCards #-} 3 4import Control.Monad 5import Control.Applicative 6import Data.YAML as Y 7import qualified Data.Text as T 8import qualified Data.Map as Map 9import qualified Data.ByteString.Lazy.Char8 as BS.L 10import Test.Tasty (defaultMain, TestTree, testGroup) 11import Test.Tasty.QuickCheck (testProperty,Arbitrary(..)) 12 13outputStr :: ToYAML a => a -> BS.L.ByteString 14outputStr a = BS.L.init (encode1 a) -- TODO: remove trailing newline from Writer.hs 15 16roundTripInt :: Int -> Bool 17roundTripInt i = BS.L.pack (show i) == outputStr i 18 19roundTripBool :: Bool -> Bool 20roundTripBool b 21 | b = "true" == outputStr b 22 | otherwise = "false" == outputStr b 23 24roundTripDouble :: Double -> Double -> Bool 25roundTripDouble num denom 26 | d /= d = ".nan" == outputStr d 27 | d == (1/0) = ".inf" == outputStr d 28 | d == (-1/0) = "-.inf" == outputStr d 29 | otherwise = BS.L.pack (show d) == outputStr d 30 where d = num / denom 31 32roundTrip :: (Eq a, FromYAML a, ToYAML a) => (a -> a -> Bool) -> a -> a -> Bool 33roundTrip eq _ v = 34 case decode1 (encode1 v) :: (FromYAML a) => (Either (Pos, String) a) of 35 Left _ -> False 36 Right ans -> ans `eq` v 37 38approxEq :: Double -> Double -> Bool 39approxEq a b = a == b || d < maxAbsoluteError || d / max (abs b) (abs a) <= maxRelativeError 40 where 41 d = abs (a - b) 42 maxAbsoluteError = 1e-15 43 maxRelativeError = 1e-15 44 45roundTripEq :: (Eq a, FromYAML a, ToYAML a) => a -> a -> Bool 46roundTripEq x y = roundTrip (==) x y 47 48main :: IO () 49main = defaultMain (testGroup "tests" tests) 50 51tests :: [TestTree] 52tests = 53 [ testGroup "encode" 54 [ testProperty "encodeInt" roundTripInt 55 , testProperty "encodeBool" roundTripBool 56 , testProperty "encodeDouble" roundTripDouble 57 ] 58 , testGroup "roundTrip" 59 [ testProperty "Bool" $ roundTripEq True 60 , testProperty "Double" $ roundTrip approxEq (1::Double) 61 , testProperty "Int" $ roundTripEq (1::Int) 62 , testProperty "Integer" $ roundTripEq (1::Integer) 63 , testProperty "Text" $ roundTripEq T.empty 64 , testProperty "Seq" $ roundTripEq ([""]:: [T.Text]) 65 , testProperty "Map" $ roundTripEq (undefined :: Map.Map T.Text T.Text) 66 , testProperty "Foo" $ roundTripEq (undefined :: Foo) 67 ] 68 ] 69 70instance Arbitrary T.Text where 71 arbitrary = T.pack <$> arbitrary 72 73data Foo = Foo 74 { fooBool :: Bool 75 , fooInt :: Int 76 , fooTuple :: (T.Text, Int) 77 , fooSeq :: [T.Text] 78 , fooMap :: Map.Map T.Text T.Text 79 } deriving (Show,Eq) 80 81instance ToYAML Foo where 82 toYAML Foo{..} = mapping [ "fooBool" .= fooBool 83 , "fooInt" .= fooInt 84 , "fooTuple" .= fooTuple 85 , "fooSeq" .= fooSeq 86 , "fooMap" .= fooMap 87 ] 88 89instance FromYAML Foo where 90 parseYAML = withMap "Foo" $ \m -> Foo 91 <$> m .: "fooBool" 92 <*> m .: "fooInt" 93 <*> m .: "fooTuple" 94 <*> m .: "fooSeq" 95 <*> m .: "fooMap" 96 97instance Arbitrary Foo where 98 arbitrary = liftM5 Foo arbitrary arbitrary arbitrary arbitrary arbitrary