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