-
Notifications
You must be signed in to change notification settings - Fork 1
/
Object.hs
236 lines (206 loc) · 7.73 KB
/
Object.hs
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
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
---------------------------------------------------------
--
-- Module : Data.Object
-- Copyright : Michael Snoyman
-- License : BSD3
--
-- Maintainer : Michael Snoyman <michael@snoyman.com>
-- Stability : Stable
-- Portability : portable
--
-- These objects show up in different places, eg JSON, Yaml.
-- By providing a representation in a separate repository,
-- other libraries can share a single representation of
-- these structures.
--
---------------------------------------------------------
-- | The core of this package is the 'Object' data type, which is used for
-- handling scalars, sequences and mappings in a nested manner. This
-- is the same structure used in JSON or Yaml data.
--
-- The 'Object' data type is polymorphic in its keys and values. Submodules
-- within this package provide more concrete datatypes, such as a 'String'
-- 'Object' and a specialized scalar type.
--
-- Besides the 'Object' data type, there are utility functions and type classes
-- for converting objects around. Care has been taken to avoid any overloaded
-- instances for these type classes.
module Data.Object
( -- * Object data type
Object (..)
-- ** Convenient type synonyms
, StringObject
, TextObject
-- ** Scalar data type
, Scalar (..)
, ScalarObject
-- * Basic mapping of keys and values
, mapKeys
, mapValues
, mapKeysValues
, mapKeysValuesA
, mapKeysValuesM
-- * Extracting underlying values
, ObjectExtractError (..)
, fromScalar
, fromSequence
, fromMapping
-- * Lookups
, lookupObject
, lookupScalar
, lookupSequence
, lookupMapping
) where
import Control.Arrow
import Control.Applicative
import Control.Monad (ap, (<=<))
import Prelude hiding (mapM, sequence)
import Data.Foldable hiding (concatMap, concat)
import Data.Traversable
import Data.Monoid
import Control.Exception (Exception)
import Data.Data (Data, Typeable)
import Control.Failure
import Data.Text (Text)
import Data.Time (UTCTime)
import Data.ByteString (ByteString)
-- | Can represent nested values as scalars, sequences and mappings. A
-- sequence is synonymous with a list, while a mapping is synonymous with a
-- list of pairs.
--
-- Note that instances of standard library type classes for this data type
-- leave the key untouched while altering the value. For example, the 'Functor'
-- instance defines 'fmap' to be synonymous with 'mapValues'.
data Object key val =
Mapping [(key, Object key val)]
| Sequence [Object key val]
| Scalar val
deriving (Show, Eq, Data, Typeable)
type StringObject = Object String String
-- | 'Object's with keys and values of strict 'Text'.
type TextObject = Object Text Text
data Scalar = Numeric Rational
| Text Text
| Binary ByteString
| Bool Bool
| Timestamp UTCTime
| Null
type ScalarObject = Object String Scalar
instance Functor (Object key) where
fmap = mapValues
instance Foldable (Object key) where
foldMap f (Scalar v) = f v
foldMap f (Sequence vs) = mconcat $ map (foldMap f) vs
foldMap f (Mapping pairs) = mconcat $ map (foldMap f . snd) pairs
instance Traversable (Object key) where
traverse f (Scalar v) = Scalar <$> f v
traverse f (Sequence vs) = Sequence <$> traverse (traverse f) vs
traverse f (Mapping pairs) =
Mapping <$> traverse (traverse' (traverse f)) pairs
-- It would be nice if there were an "instance Traversable ((,) a)", but I
-- won't make an orphan instance simply for convenience. Instead:
traverse' :: Applicative f => (a -> f b) -> (x, a) -> f (x, b)
traverse' f (x, a) = (,) x <$> f a
joinObj :: Object key (Object key scalar) -> Object key scalar
joinObj (Scalar x) = x
joinObj (Sequence xs) = Sequence (map joinObj xs)
joinObj (Mapping xs) = Mapping (map (second joinObj) xs)
instance Monad (Object key) where
return = Scalar
x >>= f = joinObj . fmap f $ x
instance Applicative (Object key) where
pure = Scalar
(<*>) = ap
-- | Apply some conversion to the keys of an 'Object', leaving the values
-- unchanged.
mapKeys :: (keyIn -> keyOut) -> Object keyIn val -> Object keyOut val
mapKeys = flip mapKeysValues id
-- | Apply some conversion to the values of an 'Object', leaving the keys
-- unchanged. This is equivalent to 'fmap'.
mapValues :: (valIn -> valOut) -> Object key valIn -> Object key valOut
mapValues = mapKeysValues id
-- | Apply a conversion to both the keys and values of an 'Object'.
mapKeysValues :: (keyIn -> keyOut)
-> (valIn -> valOut)
-> Object keyIn valIn
-> Object keyOut valOut
mapKeysValues _ fv (Scalar v) = Scalar $ fv v
mapKeysValues fk fv (Sequence os)= Sequence $ map (mapKeysValues fk fv) os
mapKeysValues fk fv (Mapping pairs) =
Mapping $ map (fk *** mapKeysValues fk fv) pairs
-- | Apply an 'Applicative' conversion to both the keys and values of an
-- 'Object'.
mapKeysValuesA :: Applicative f
=> (keyIn -> f keyOut)
-> (valIn -> f valOut)
-> Object keyIn valIn
-> f (Object keyOut valOut)
mapKeysValuesA _ fv (Scalar v) = Scalar <$> fv v
mapKeysValuesA fk fv (Sequence os) =
Sequence <$> traverse (mapKeysValuesA fk fv) os
mapKeysValuesA fk fv (Mapping pairs) = Mapping <$>
traverse (uncurry (liftA2 (,)) . (fk *** mapKeysValuesA fk fv)) pairs
-- | The same as 'mapKeysValuesA', but using a 'Monad' since some people are
-- more comfortable with 'Monad's and not all 'Monad's are 'Applicative'.
mapKeysValuesM :: Monad m
=> (keyIn -> m keyOut)
-> (valIn -> m valOut)
-> Object keyIn valIn
-> m (Object keyOut valOut)
mapKeysValuesM fk fv =
let fk' = WrapMonad . fk
fv' = WrapMonad . fv
in unwrapMonad . mapKeysValuesA fk' fv'
-- | An error value returned when an unexpected node is encountered, eg you
-- were expecting a 'Scalar' and found a 'Mapping'.
data ObjectExtractError =
ExpectedScalar
| ExpectedSequence
| ExpectedMapping
| MissingKey String
deriving (Typeable, Show)
instance Exception ObjectExtractError
-- | Extract a scalar from the input, failing if the input is a sequence or
-- mapping.
fromScalar :: Failure ObjectExtractError m => Object k v -> m v
fromScalar (Scalar s) = return s
fromScalar _ = failure ExpectedScalar
-- | Extract a sequence from the input, failing if the input is a scalar or
-- mapping.
fromSequence :: Failure ObjectExtractError m
=> Object k v
-> m [Object k v]
fromSequence (Sequence s) = return s
fromSequence _ = failure ExpectedSequence
-- | Extract a mapping from the input, failing if the input is a scalar or
-- sequence.
fromMapping :: Failure ObjectExtractError m
=> Object k v
-> m [(k, Object k v)]
fromMapping (Mapping m) = return m
fromMapping _ = failure ExpectedMapping
lookupObject :: (Show k, Eq k, Failure ObjectExtractError m)
=> k
-> [(k, Object k v)]
-> m (Object k v)
lookupObject k pairs =
case lookup k pairs of
Nothing -> failure $ MissingKey $ show k
Just v -> return v
lookupScalar :: (Show k, Eq k, Failure ObjectExtractError m)
=> k
-> [(k, Object k v)]
-> m v
lookupScalar k = fromScalar <=< lookupObject k
lookupSequence :: (Show k, Eq k, Failure ObjectExtractError m)
=> k
-> [(k, Object k v)]
-> m [Object k v]
lookupSequence k = fromSequence <=< lookupObject k
lookupMapping :: (Show k, Eq k, Failure ObjectExtractError m)
=> k
-> [(k, Object k v)]
-> m [(k, Object k v)]
lookupMapping k = fromMapping <=< lookupObject k