summaryrefslogtreecommitdiffstats
path: root/test/Test.hs
blob: 0836220afbe5a2d0bf48090243b07eb08646bbcd (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
{-# LANGUAGE DeriveGeneric, DeriveAnyClass, RankNTypes #-}

import GHC.Generics
import Generic.Random
import Test.Tasty
import Test.Tasty.QuickCheck as QC
import Data.Proxy
import Test.Tasty.Travis
import Data.Word
import Data.Int
import Data.Complex
import Data.Either

import Coalpit


data Basic = Basic Int String Double
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Basic where arbitrary = genericArbitraryU

data WithLists = WithLists [Int] [String] [Double]
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary WithLists where arbitrary = genericArbitraryU

data Record = Record { maybeInt :: Maybe Int
                     , maybeDouble :: Maybe Double
                     , str :: String
                     , listOfStrings :: [String]
                     , maybeNonEmptyListOfNumbers :: Maybe [Integer]
                     , otherString :: String
                     } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Record where arbitrary = genericArbitraryU

data Sum = Foo Int Bool
         | Bar
         | Baz (Int8, (Complex Float, Word16), Rational)
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Sum where arbitrary = genericArbitraryU

data Nested = Nested Record Basic WithLists Sum
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Nested where arbitrary = genericArbitraryU

data Polymorphic a b = Polymorphic (Maybe a) (Either a b)
  deriving (Generic, Eq, Show)
instance (Coalpit a, Coalpit b) => Coalpit (Polymorphic a b)
instance (Arbitrary a, Arbitrary b) => Arbitrary (Polymorphic a b) where
  arbitrary = genericArbitraryU

data Recursive = RecursiveA
               | RecursiveB Recursive
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Recursive where arbitrary = genericArbitraryU

data NestedRecord = NestedRecord { record1 :: Maybe Record
                                 , record2 :: Maybe Record
                                 , record3 :: Maybe Record
                                 } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary NestedRecord where arbitrary = genericArbitraryU

data NestedSum = NestedFoo Record
               | NestedBar Sum Basic Nested
               | NestedBaz (Polymorphic Char Double)
               deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary NestedSum where arbitrary = genericArbitraryU

data RecursiveRecordMaybe = RecursiveRecordMaybe
  { rrm :: Maybe RecursiveRecordMaybe
  , record :: Maybe Record
  , guard :: Word8
  } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary RecursiveRecordMaybe where arbitrary = genericArbitraryU

data RecursiveRecordMaybe2 = RecursiveRecordMaybe2
  { record1' :: Maybe Record
  , rrm' :: Maybe (Maybe RecursiveRecordMaybe2)
  , record2' :: Maybe Record
  , guard' :: Word8
  } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary RecursiveRecordMaybe2 where arbitrary = genericArbitraryU

data RecordStrings = RecordStrings
  { s1 :: String
  , s2 :: String
  , s3 :: String
  } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary RecordStrings where arbitrary = genericArbitraryU

printAndParse :: (Coalpit a, Eq a)
              => Options -> Proxy a -> a -> Bool
printAndParse opt _ r = Right r == fromArgs opt (toArgs opt r)

printAndParseDSV :: (Coalpit a, Eq a)
                 -- It would take a long time to test with [a], so
                 -- just repeating it 0--2 times.
                 => Options -> Proxy a -> (a, Int) -> Bool
printAndParseDSV opt _ (x, n) =
  let xs = (replicate (n `mod` 3) x)
  in xs == (rights . map (readDSV opt) . lines . unlines . map (showDSV opt) $ xs)


variousTypes :: (forall a. (Coalpit a, Eq a, Show a, Arbitrary a) =>
                  Proxy a -> String -> TestTree)
             -> [TestTree]
variousTypes f =
  [ f (Proxy :: Proxy Basic) "Basic"
  , f (Proxy :: Proxy WithLists) "WithLists"
  , f (Proxy :: Proxy Record) "Record"
  , f (Proxy :: Proxy Sum) "Sum"
  , f (Proxy :: Proxy Nested) "Nested"
  , f (Proxy :: Proxy (Polymorphic Int Double)) "Polymorphic Int Double"
  , f (Proxy :: Proxy (Polymorphic Basic Record)) "Polymorphic Basic Record"
  , f (Proxy :: Proxy (Polymorphic Nested (Polymorphic Basic Sum)))
    "Polymorphic Nested (Polymorphic Basic Sum)"
  , f (Proxy :: Proxy Recursive) "Recursive"
  , f (Proxy :: Proxy NestedRecord) "NestedRecord"
  , f (Proxy :: Proxy NestedSum) "NestedSum"
  , f (Proxy :: Proxy RecursiveRecordMaybe) "RecursiveRecordMaybe"
  , f (Proxy :: Proxy RecursiveRecordMaybe2) "RecursiveRecordMaybe2"
  , f (Proxy :: Proxy RecordStrings) "RecordStrings"
  ]

variousOptions :: (Options -> [TestTree]) -> [TestTree]
variousOptions tt =
  [ testGroup (concat [ "alwaysUseSelName = ", show ausn
                      , ", omitNamedOptions = ", show ono])
    (tt defOpt { alwaysUseSelName = ausn
               , omitNamedOptions = ono })
  | ausn <- [True, False]
  , ono <- [True, False]
  ]

qcProps :: TestTree
qcProps = testGroup "Quickcheck properties"
  [ testGroup "Right == fromArgs opt . toArgs opt"
    (variousOptions $ \opt ->
        variousTypes $ \p n -> QC.testProperty n (printAndParse opt p))
  , testGroup
    "id == rights . map (readDSV opt) . lines . unlines . map (showDSV opt)"
    (variousOptions $ \opt ->
        variousTypes $ \p n -> QC.testProperty n (printAndParseDSV opt p))
  ]

main :: IO ()
main = travisTestReporter defaultConfig [] qcProps