summaryrefslogtreecommitdiff
path: root/Text/OPML/Types.hs
blob: 2de5f6432a3e3cd95aeff03d293acbed03197afd (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
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE StandaloneDeriving     #-}
{-# LANGUAGE TemplateHaskell        #-}
-- | OPML is an XML format for outlines.
--
-- Example:
--
-- > <opml version="2.0">
-- >   <head>
-- >     <title>OPML title</title>
-- >     <dateCreated>Mon, 31 Oct 2005 19:23:00 GMT</dateCreated>
-- >   </head>
-- >   <body>
-- >     <outline text="Outline 1" created="Mon, 31 Oct 2005 18:21:33 GMT"/>
-- >     <outline text="Outline 2" created="Mon, 31 Oct 2005 18:21:33 GMT"/>
-- >   </body>
-- > </opml>
module Text.OPML.Types
  ( -- * Top-level OPML structure
    Opml(..)
  , opmlVersion_
  , head_
  , outlines_
    -- * OPML header
  , OpmlHead(..)
  , Direction(..)
  , opmlTitle_
  , opmlCreated_
  , modified_
  , ownerName_
  , ownerEmail_
  , ownerId_
  , docs_
  , expansionState_
  , vertScrollState_
  , window_
    -- * OPML outlines
  , OpmlOutline(..)
  , _OpmlOutlineGeneric
  , _OpmlOutlineLink
  , _OpmlOutlineSubscription
    -- ** Generic outlines
  , OutlineBase(..)
  , mkOutlineBase
  , text_
  , isComment_
  , isBreakpoint_
  , outlineCreated_
  , categories_
    -- ** Subscription outlines
  , OutlineSubscription(..)
  , mkOutlineSubscription
  , xmlUri_
  , htmlUri_
  , description_
  , language_
  , subscriptionTitle_
  , subscriptionVersion_
  ) where

-- {{{ Imports
import           Control.Lens.TH
import           Control.Monad

import           Data.Default
import           Data.Map
import           Data.NotEmpty
import           Data.Text
import           Data.Time.Clock
import           Data.Time.LocalTime ()
import           Data.Tree
import           Data.Version

import           GHC.Generics

import           Network.URI

import           Test.QuickCheck
import           Text.OPML.Arbitrary
-- }}}

data Direction = Top' | Left' | Bottom' | Right' deriving(Eq, Generic, Ord, Show)

instance Arbitrary Direction where
  arbitrary = elements [Top', Left', Right', Bottom']
  shrink = genericShrink


declareLenses [d|
  data OpmlHead = OpmlHead
    { opmlTitle_ :: Text
    , opmlCreated_ :: Maybe UTCTime
    , modified_ :: Maybe UTCTime
    , ownerName_ :: Text
    , ownerEmail_ :: Text
    , ownerId_ :: Maybe URI
    , docs_ :: Maybe URI
    , expansionState_ :: [Int]
    , vertScrollState_ :: Maybe Int
    , window_ :: Map Direction Int
    }
  |]

deriving instance Eq OpmlHead
deriving instance Generic OpmlHead
deriving instance Show OpmlHead

-- | Use 'def' as a smart constructor. All fields are set to 'mempty'.
instance Default OpmlHead where
  def = OpmlHead mempty mzero mzero mempty mempty mzero mzero mzero mzero mempty

instance Arbitrary OpmlHead where
  arbitrary = OpmlHead <$> arbitrary
                       <*> (unwrap <$> arbitrary)
                       <*> (unwrap <$> arbitrary)
                       <*> arbitrary
                       <*> arbitrary
                       <*> (unwrap <$> arbitrary)
                       <*> (unwrap <$> arbitrary)
                       <*> arbitrary
                       <*> arbitrary
                       <*> arbitrary
  shrink (OpmlHead a b c d e f g h i j) = OpmlHead <$> shrink a
                                                   <*> (unwrap <$> shrink (OpmlGen b))
                                                   <*> (unwrap <$> shrink (OpmlGen c))
                                                   <*> shrink d
                                                   <*> shrink e
                                                   <*> (unwrap <$> shrink (OpmlGen f))
                                                   <*> (unwrap <$> shrink (OpmlGen g))
                                                   <*> shrink h
                                                   <*> shrink i
                                                   <*> shrink j

declareLenses [d|
  data OutlineBase = OutlineBase
    { text_ :: NE Text
    , isComment_ :: Maybe Bool
    , isBreakpoint_ :: Maybe Bool
    , outlineCreated_ :: Maybe UTCTime
    , categories_ :: [[NE Text]]
    }
  |]

deriving instance Eq OutlineBase
deriving instance Generic OutlineBase
deriving instance Show OutlineBase

instance Arbitrary OutlineBase where
  arbitrary = OutlineBase <$> arbitrary
                          <*> arbitrary
                          <*> arbitrary
                          <*> (unwrap <$> arbitrary)
                          <*> (unwrap <$> arbitrary)
  shrink = genericShrink

-- | Smart constructor for 'OutlineBase'.
mkOutlineBase :: NE Text -> OutlineBase
mkOutlineBase t = OutlineBase t mzero mzero mzero mzero


declareLenses [d|
  data OutlineSubscription = OutlineSubscription
    { xmlUri_ :: URI
    , htmlUri_ :: Maybe URI
    , description_ :: Text
    , language_ :: Text
    , subscriptionTitle_ :: Text
    , subscriptionVersion_ :: Text
    }
  |]

deriving instance Eq OutlineSubscription
deriving instance Generic OutlineSubscription
deriving instance Show OutlineSubscription

instance Arbitrary OutlineSubscription where
  arbitrary = OutlineSubscription <$> (unwrap <$> arbitrary)
                                  <*> (unwrap <$> arbitrary)
                                  <*> arbitrary
                                  <*> arbitrary
                                  <*> arbitrary
                                  <*> arbitrary
  shrink (OutlineSubscription a b c d e f) = OutlineSubscription <$> (unwrap <$> shrink (OpmlGen a)) <*> (unwrap <$> shrink (OpmlGen b)) <*> shrink c <*> shrink d <*> shrink e <*> shrink f

-- | Smart constructor for 'OutlineSubscription'
mkOutlineSubscription :: URI -> OutlineSubscription
mkOutlineSubscription uri = OutlineSubscription uri mzero mempty mempty mempty mempty


-- | Outlines are the main payload of an OPML document.
declarePrisms [d|
  data OpmlOutline = OpmlOutlineGeneric OutlineBase Text
                   | OpmlOutlineLink OutlineBase URI
                   | OpmlOutlineSubscription OutlineBase OutlineSubscription
  |]

deriving instance Eq OpmlOutline
deriving instance Generic OpmlOutline
deriving instance Show OpmlOutline

instance Arbitrary OpmlOutline where
  arbitrary = oneof [ OpmlOutlineGeneric <$> arbitrary <*> arbitrary
                    , OpmlOutlineLink <$> arbitrary <*> (unwrap <$> arbitrary)
                    , OpmlOutlineSubscription <$> arbitrary <*> arbitrary
                    ]
  shrink (OpmlOutlineGeneric a b) = OpmlOutlineGeneric <$> shrink a <*> shrink b
  shrink (OpmlOutlineLink a b) = OpmlOutlineLink <$> shrink a <*> (unwrap <$> shrink (OpmlGen b))
  shrink (OpmlOutlineSubscription a b) = OpmlOutlineSubscription <$> shrink a <*> shrink b


declareLenses [d|
  data Opml = Opml
    { opmlVersion_ :: Version
    , head_ :: OpmlHead
    , outlines_ :: Forest OpmlOutline
    }
  |]

deriving instance Eq Opml
deriving instance Generic Opml
deriving instance Show Opml

instance Default Opml where
  def = Opml (makeVersion [2, 0]) def mempty

instance Arbitrary Opml where
  arbitrary = Opml <$> (unwrap <$> arbitrary)
                   <*> arbitrary
                   <*> listOf (genOutlineTree 1)
  shrink (Opml a b c) = Opml <$> (unwrap <$> shrink (OpmlGen 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
  case (n > 1, root) of
    (True, OpmlOutlineGeneric _ _) -> Node <$> pure root <*> listOf (genOutlineTree (n-1))
    (False, OpmlOutlineGeneric _ _) -> return $ Node root []
    _ -> return $ Node root []