summaryrefslogtreecommitdiff
path: root/provider/posts/beuteltier/2.lhs
diff options
context:
space:
mode:
Diffstat (limited to 'provider/posts/beuteltier/2.lhs')
-rw-r--r--provider/posts/beuteltier/2.lhs179
1 files changed, 179 insertions, 0 deletions
diff --git a/provider/posts/beuteltier/2.lhs b/provider/posts/beuteltier/2.lhs
new file mode 100644
index 0000000..8da4711
--- /dev/null
+++ b/provider/posts/beuteltier/2.lhs
@@ -0,0 +1,179 @@
1---
2title: "\"Type level\" utilities for an overly complicated feedreader"
3published: 2015-08-05
4tags: Beuteltier
5---
6
7By popular (n=1) demand we will, in this post, be taking a look at
8`beuteltier/Beuteltier/Types/Util.hs` the, creatively named, module providing some "type
9level" utilities.
10
11What I mean when I say "type level" is: additional instances (placed here when they
12contain major design decisions and are not "Ord" or "Eq"), utilities not connected to
13beuteltier itself (like the different flavours of `alter` below)
14
15In contrast to the first, this post is straightforward enough to be read linearly.
16
17> {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
18>
19> module Beuteltier.Types.Util
20> ( -- * Constructing structures
21> construct
22> , construct'
23> , alter
24> , alter'
25> -- * Dealing with 'ObjectGen's (here be dragons)
26> , generateObject
27> , liftGen
28> -- * Equivalence on 'Object's (for nubbing)
29> , Equivalent(..)
30> -- * Operations on 'SearchQuery's
31> , runQuery
32> -- , runExpr
33> ) where
34>
35> import Beuteltier.Types
36> import Beuteltier.Types.Lenses
37
38We make use of lenses (as provided by [lens](http://hackage.haskell.org/package/lens))
39extensively.
40We won´t dedicate a post to `beuteltier/Beuteltier/Types/Lenses.hs` because it consists
41mostly of the canonical invocations of
42[makeLenses](http://hackage.haskell.org/package/lens-4.12.3/docs/Control-Lens-TH.html#v:makeLenses).
43
44> import Data.Default
45>
46> import Prelude hiding (sequence)
47> import Data.Traversable (sequence)
48>
49> import Control.Lens
50>
51> import Control.Monad.State.Lazy hiding (sequence) -- Why is this exported?
52>
53> import Data.Map (Map)
54> import qualified Data.Map as Map
55>
56> import Data.Set (Set)
57> import qualified Data.Set as Set
58>
59> import Data.Hashable (Hashable(..), hashUsing)
60>
61> import Data.Monoid ((<>))
62>
63> import Data.Function (on)
64> import Data.Maybe (mapMaybe)
65>
66> import Data.BoolExpr
67
68Quite often we find ourselves in the position that we want to alter some small parts of a
69complicated structure. We would therefore like to write the following:
70
71~~~ {.haskell}
72updateFoo :: Foo -> Monad Foo
73updateFoo x = alter x $ do
74 bar <~ (constructNewBar :: Monad Bar)
75 buz .= (makeConstantBuz :: Buz)
76~~~
77
78The definitions below allow us not only to do so, but also provide some convenience
79functions for constructing entirely new values and performing both operations in a pure
80context.
81
82> alter :: Monad m => s -> StateT s m a -> m s
83> -- ^ Alter a complex structure monodically
84> alter = flip execStateT
85>
86> alter' :: s -> State s a -> s
87> -- ^ Specialization of 'alter' to 'Identity'
88> alter' s = runIdentity . alter s
89>
90> construct :: (Monad m, Default s) => StateT s m a -> m s
91> -- ^ Compute a complex structure monadically
92> construct = alter def
93>
94> construct' :: Default s => State s a -> s
95> -- ^ Specialization of 'construct' to 'Identity'
96> construct' = runIdentity . construct
97
98Sometimes we just really want to translate an `ObjectGen` to an `Object`.
99
100> generateObject :: Monad f => ObjectGen f -> f Object
101> -- ^ Run an object generator.
102> -- Use iff /all/ components of an object are needed /in RAM now/.
103> generateObject gen = construct $ do
104> content <- lift $ gen ^. oContent >>= sequence
105> thunks <- lift $ gen ^. oThunks >>= sequence
106> meta <- lift $ gen ^. oMeta
107> oContent .= return (fmap return content)
108> oThunks .= return (fmap return thunks)
109> oMeta .= return meta
110>
111> liftGen :: Monad f => Object -> ObjectGen f
112> -- ^ Lift an 'Object' to be an 'ObjectGen' in any 'Monad' by the power of 'return'
113> liftGen obj = construct' $ do
114> oContent .= return (Map.map return $ obj ^. oContent')
115> oThunks .= return (map return $ obj ^. oThunks')
116> oMeta .= return (obj ^. oMeta')
117
118We expect implementations of `insert` to perform what we call nubbing. That is removal of
119`Object`s that are, in some sense, `Equivalent` to the new one we´re currently
120inserting. Thus we provide a definition of what we mean, when we say `Equivalent`.
121
122> class Equivalent a where
123> (~~) :: a -> a -> Bool
124>
125> -- | Two 'Object's are equivalent iff their content is identical as follows:
126> -- the set of 'SubObjectName's both promised and actually occurring is identical
127> -- and all 'SubObject's that actually occurr and share a 'SubObjectName' are
128> -- identical (as per '(==)')
129> --
130> -- Additionally we expect their 'Metadata' to be identical (as per '(==)')
131> instance Equivalent Object where
132> a ~~ b = (contentCompare `on` content) a b && ((==) `on` (^. oMeta')) a b
133> where
134> contentCompare :: (Ord k, Eq v) => Map k (Maybe v) -> Map k (Maybe v) -> Bool
135> contentCompare a b = Map.foldl (&&) True $ Map.mergeWithKey combine setFalse setFalse a b
136> combine _ a b = Just $ cmpMaybes a b
137> setFalse = Map.map $ const False
138>
139> cmpMaybes Nothing _ = True
140> cmpMaybes _ Nothing = True
141> cmpMaybes (Just a) (Just b) = a == b
142
143To speed up nubbing we also provide a quick way to "cache results". To make caching
144meaningful we of course expect the following to hold:
145
146~~~
147a ~~ b ⇒ (hash a) == (hash b)
148~~~
149
150Note that we do not expect the converse to hold. We will thus require a second pass over
151all objects sharing a hash to determine true equivalency.
152
153> -- | Two 'Object's´ hashes are a first indication of whether they are 'Equivalent'
154> instance Hashable Object where
155> hashWithSalt = hashUsing $ \a -> (a ^. oMeta', Map.keys $ content a)
156>
157> instance Hashable MetaData where
158> hashWithSalt = hashUsing $ Set.toList . (^. mTags)
159>
160> content :: Object -> Map SubObjectName (Maybe SubObject)
161> content obj = promised obj <> actual obj
162> actual :: Object -> Map SubObjectName (Maybe SubObject)
163> actual = fmap Just . (^. oContent')
164> promised :: Object -> Map SubObjectName (Maybe SubObject)
165> promised = Map.fromList . map (\n -> (n, Nothing)) . concat . promises
166> promises :: Object -> [[SubObjectName]]
167> promises = mapMaybe (^. tPromises) . (^. oThunks')
168
169Evaluating a `SearchQuery` against an `ObjectGen` is, due to the structure of elementary
170`SearchQuery`s quite straightforward.
171
172> runQuery :: Monad f => SearchQuery f -> ObjectGen f -> f Bool
173> -- ^ Run a 'SearchQuery' against an 'ObjectGen'
174> runQuery query obj = liftM reduceBoolExpr $ sequence $ fmap ($ obj) query
175>
176> -- runExpr :: Monad f => ObjectGen f -> Predicate f -> f Bool
177> -- -- ^ Run a 'Predicate' (»an atomic 'SearchQuery'«) against an 'ObjectGen'
178> -- runExpr obj (Prim f) = f obj
179> -- runExpr obj (Meta f) = liftM f (obj ^. oMeta)
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-06 18:29:26 +0000