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
|
---
title: "\"Type level\" utilities for an overly complicated feedreader"
published: 2015-08-05
tags: Beuteltier
---
By popular (n=1) demand we will, in this post, be taking a look at
`beuteltier/Beuteltier/Types/Util.hs` the, creatively named, module providing some "type
level" utilities.
What I mean when I say "type level" is: additional instances (placed here when they
contain major design decisions and are not "Ord" or "Eq"), utilities not connected to
beuteltier itself (like the different flavours of `alter` below)
In contrast to the first, this post is straightforward enough to be read linearly.
> {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
>
> module Beuteltier.Types.Util
> ( -- * Constructing structures
> construct
> , construct'
> , alter
> , alter'
> -- * Dealing with 'ObjectGen's (here be dragons)
> , generateObject
> , liftGen
> -- * Equivalence on 'Object's (for nubbing)
> , Equivalent(..)
> -- * Operations on 'SearchQuery's
> , runQuery
> -- , runExpr
> ) where
>
> import Beuteltier.Types
> import Beuteltier.Types.Lenses
We make use of lenses (as provided by [lens](http://hackage.haskell.org/package/lens))
extensively.
We won´t dedicate a post to `beuteltier/Beuteltier/Types/Lenses.hs` because it consists
mostly of the canonical invocations of
[makeLenses](http://hackage.haskell.org/package/lens-4.12.3/docs/Control-Lens-TH.html#v:makeLenses).
> import Data.Default
>
> import Prelude hiding (sequence)
> import Data.Traversable (sequence)
>
> import Control.Lens
>
> import Control.Monad.State.Lazy hiding (sequence) -- Why is this exported?
>
> import Data.Map (Map)
> import qualified Data.Map as Map
>
> import Data.Set (Set)
> import qualified Data.Set as Set
>
> import Data.Hashable (Hashable(..), hashUsing)
>
> import Data.Monoid ((<>))
>
> import Data.Function (on)
> import Data.Maybe (mapMaybe)
>
> import Data.BoolExpr
Quite often we find ourselves in the position that we want to alter some small parts of a
complicated structure. We would therefore like to write the following:
~~~ {.haskell}
updateFoo :: Foo -> Monad Foo
updateFoo x = alter x $ do
bar <~ (constructNewBar :: Monad Bar)
buz .= (makeConstantBuz :: Buz)
~~~
The definitions below allow us not only to do so, but also provide some convenience
functions for constructing entirely new values and performing both operations in a pure
context.
> alter :: Monad m => s -> StateT s m a -> m s
> -- ^ Alter a complex structure monodically
> alter = flip execStateT
>
> alter' :: s -> State s a -> s
> -- ^ Specialization of 'alter' to 'Identity'
> alter' s = runIdentity . alter s
>
> construct :: (Monad m, Default s) => StateT s m a -> m s
> -- ^ Compute a complex structure monadically
> construct = alter def
>
> construct' :: Default s => State s a -> s
> -- ^ Specialization of 'construct' to 'Identity'
> construct' = runIdentity . construct
Sometimes we just really want to translate an `ObjectGen` to an `Object`.
> generateObject :: Monad f => ObjectGen f -> f Object
> -- ^ Run an object generator.
> -- Use iff /all/ components of an object are needed /in RAM now/.
> generateObject gen = construct $ do
> content <- lift $ gen ^. oContent >>= sequence
> thunks <- lift $ gen ^. oThunks >>= sequence
> meta <- lift $ gen ^. oMeta
> oContent .= return (fmap return content)
> oThunks .= return (fmap return thunks)
> oMeta .= return meta
>
> liftGen :: Monad f => Object -> ObjectGen f
> -- ^ Lift an 'Object' to be an 'ObjectGen' in any 'Monad' by the power of 'return'
> liftGen obj = construct' $ do
> oContent .= return (Map.map return $ obj ^. oContent')
> oThunks .= return (map return $ obj ^. oThunks')
> oMeta .= return (obj ^. oMeta')
We expect implementations of `insert` to perform what we call nubbing. That is removal of
`Object`s that are, in some sense, `Equivalent` to the new one we´re currently
inserting. Thus we provide a definition of what we mean, when we say `Equivalent`.
> class Equivalent a where
> (~~) :: a -> a -> Bool
>
> -- | Two 'Object's are equivalent iff their content is identical as follows:
> -- the set of 'SubObjectName's both promised and actually occurring is identical
> -- and all 'SubObject's that actually occurr and share a 'SubObjectName' are
> -- identical (as per '(==)')
> --
> -- Additionally we expect their 'Metadata' to be identical (as per '(==)')
> instance Equivalent Object where
> a ~~ b = (contentCompare `on` content) a b && ((==) `on` (^. oMeta')) a b
> where
> contentCompare :: (Ord k, Eq v) => Map k (Maybe v) -> Map k (Maybe v) -> Bool
> contentCompare a b = Map.foldl (&&) True $ Map.mergeWithKey combine setFalse setFalse a b
> combine _ a b = Just $ cmpMaybes a b
> setFalse = Map.map $ const False
>
> cmpMaybes Nothing _ = True
> cmpMaybes _ Nothing = True
> cmpMaybes (Just a) (Just b) = a == b
To speed up nubbing we also provide a quick way to "cache results". To make caching
meaningful we of course expect the following to hold:
~~~
a ~~ b ⇒ (hash a) == (hash b)
~~~
Note that we do not expect the converse to hold. We will thus require a second pass over
all objects sharing a hash to determine true equivalency.
> -- | Two 'Object's´ hashes are a first indication of whether they are 'Equivalent'
> instance Hashable Object where
> hashWithSalt = hashUsing $ \a -> (a ^. oMeta', Map.keys $ content a)
>
> instance Hashable MetaData where
> hashWithSalt = hashUsing $ Set.toList . (^. mTags)
>
> content :: Object -> Map SubObjectName (Maybe SubObject)
> content obj = promised obj <> actual obj
> actual :: Object -> Map SubObjectName (Maybe SubObject)
> actual = fmap Just . (^. oContent')
> promised :: Object -> Map SubObjectName (Maybe SubObject)
> promised = Map.fromList . map (\n -> (n, Nothing)) . concat . promises
> promises :: Object -> [[SubObjectName]]
> promises = mapMaybe (^. tPromises) . (^. oThunks')
Evaluating a `SearchQuery` against an `ObjectGen` is, due to the structure of elementary
`SearchQuery`s quite straightforward.
> runQuery :: Monad f => SearchQuery f -> ObjectGen f -> f Bool
> -- ^ Run a 'SearchQuery' against an 'ObjectGen'
> runQuery query obj = liftM reduceBoolExpr $ sequence $ fmap ($ obj) query
>
> -- runExpr :: Monad f => ObjectGen f -> Predicate f -> f Bool
> -- -- ^ Run a 'Predicate' (»an atomic 'SearchQuery'«) against an 'ObjectGen'
> -- runExpr obj (Prim f) = f obj
> -- runExpr obj (Meta f) = liftM f (obj ^. oMeta)
|
