---
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)