summaryrefslogtreecommitdiff
path: root/test/Arbitrary.hs
blob: 2e6f5c697a01c34f436dc3ae96934fa48ff49efc (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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE StandaloneDeriving #-}
-- | External 'Arbitrary' instances used by OPML types.
-- All instances are defined through the 'OpmlGen' wrapper to avoid conflicts.
module Arbitrary (module Arbitrary) where

-- {{{ Imports
import           Data.ByteString           (ByteString)
import           Data.Char
import           Data.List.NonEmpty
import           Data.Maybe
import           Data.MonoTraversable      (Element)
import           Data.NonNull
import           Data.Sequences            (SemiSequence)
import           Data.Text                 (Text, find, pack)
import           Data.Text.Encoding
import           Data.Time.Clock
import           Data.Tree
import           Data.Version

import           GHC.Generics

import           Test.QuickCheck
import           Test.QuickCheck.Instances ()

import           Text.OPML.Types

import           URI.ByteString
-- }}}

#if MIN_VERSION_base(4,9,0)
#else
deriving instance Generic Version
#endif

-- | OPML version may only be @1.0@, @1.1@ or @2.0@
genOPMLVersion :: Gen Version
genOPMLVersion = Version <$> elements [ [1, 0], [1, 1], [2, 0] ] <*> pure []

-- | Reasonable enough 'URI' generator.
instance Arbitrary URI where
  arbitrary = URI <$> arbitrary <*> arbitrary <*> genPath <*> arbitrary <*> (Just <$> genFragment)
  shrink (URI a b c d e) = URI <$> shrink a <*> shrink b <*> shrink c <*> shrink d <*> shrink e

-- | Reasonable enough 'Authority' generator.
instance Arbitrary Authority where
  arbitrary = Authority <$> arbitrary <*> arbitrary <*> arbitrary
  shrink = genericShrink

genFragment :: Gen ByteString
genFragment = encodeUtf8 . pack <$> listOf1 genAlphaNum

instance Arbitrary Host where
  arbitrary = Host . encodeUtf8 . pack <$> listOf1 genAlphaNum
  shrink = genericShrink

genPath :: Gen ByteString
genPath = encodeUtf8 . pack . ("/" ++) <$> listOf1 genAlphaNum

instance Arbitrary Port where
  arbitrary = do
    Positive port <- arbitrary
    return $ Port port

instance Arbitrary Query where
  arbitrary = do
    a <- listOf1 (encodeUtf8 . pack <$> listOf1 genAlphaNum)
    b <- listOf1 (encodeUtf8 . pack <$> listOf1 genAlphaNum)
    return $ Query $ Prelude.zip a b
  shrink = genericShrink

instance Arbitrary Scheme where
  arbitrary = Scheme . encodeUtf8 . pack <$> listOf1 (choose('a', 'z'))
  shrink = genericShrink

instance Arbitrary UserInfo where
  arbitrary = do
    a <- encodeUtf8 . pack <$> listOf1 genAlphaNum
    b <- encodeUtf8 . pack <$> listOf1 genAlphaNum
    return $ UserInfo a b
  shrink = genericShrink


-- | Generates 'UTCTime' with rounded seconds.
genTime :: Gen UTCTime
genTime = do
  (UTCTime d s) <- arbitrary
  return $ UTCTime d $ fromIntegral (round s :: Int)

-- | Generates 'OutlineBase''s categories.
-- This generator makes sure that the result has no @,@ nor @/@ characters, since those are used as separators.
genCategoryPath :: Gen (NonEmpty (NonNull Text))
genCategoryPath = (:|) <$> genCategory <*> listOf genCategory where
  genCategory = genNonNull `suchThat` (isNothing . find (\c -> c == ',' || c == '/') . toNullable)

-- | Alpha-numeric generator.
genAlphaNum :: Gen Char
genAlphaNum = oneof [choose('a', 'z'), suchThat arbitrary isDigit]

-- | Non-empty mono-foldable
genNonNull :: (SemiSequence a, Arbitrary (Element a), Arbitrary a) => Gen (NonNull a)
genNonNull = ncons <$> arbitrary <*> arbitrary


instance Arbitrary OpmlHead where
  arbitrary = OpmlHead <$> arbitrary
                       <*> (Just <$> genTime)
                       <*> (Just <$> genTime)
                       <*> arbitrary
                       <*> arbitrary
                       <*> arbitrary
                       <*> arbitrary
                       <*> arbitrary
                       <*> arbitrary
                       <*> arbitrary
                       <*> arbitrary
                       <*> arbitrary
                       <*> arbitrary
  shrink = genericShrink

instance Arbitrary OutlineBase where
  arbitrary = OutlineBase <$> genNonNull
                          <*> arbitrary
                          <*> arbitrary
                          <*> (Just <$> genTime)
                          <*> listOf genCategoryPath
  shrink (OutlineBase a b c d e) = OutlineBase <$> [a]
                                               <*> shrink b
                                               <*> shrink c
                                               <*> shrink d
                                               <*> [e]

instance Arbitrary OutlineSubscription where
  arbitrary = OutlineSubscription <$> arbitrary
                                  <*> arbitrary
                                  <*> arbitrary
                                  <*> arbitrary
                                  <*> arbitrary
                                  <*> arbitrary
  shrink = genericShrink

instance Arbitrary OpmlOutline where
  arbitrary = oneof [ OpmlOutlineGeneric <$> arbitrary <*> arbitrary
                    , OpmlOutlineLink <$> arbitrary <*> arbitrary
                    , OpmlOutlineSubscription <$> arbitrary <*> arbitrary
                    ]
  shrink = genericShrink

instance Arbitrary Opml where
  arbitrary = do
    degree <- choose (0, 100)
    Opml <$> genOPMLVersion
         <*> arbitrary
         <*> vectorOf degree (genOutlineTree 1)
  shrink (Opml a b c) = Opml <$> [a] <*> shrink b <*> shrink c

-- | Generate a tree of outlines with the given maximum depth.
-- This generator makes sure that only 'OpmlOutlineGeneric' may have children.
genOutlineTree :: Int -> Gen (Tree OpmlOutline)
genOutlineTree n = do
  root <- arbitrary
  degree <- choose (0, 100)
  case (n > 1, root) of
    (True, OpmlOutlineGeneric _ _) -> Node <$> pure root <*> vectorOf degree (genOutlineTree (n-1))
    (False, OpmlOutlineGeneric _ _) -> return $ Node root []
    _ -> return $ Node root []