beuteltier-2.lhs

1 files changed, 173 insertions, 0 deletions

diff --git a/provider/posts/beuteltier-2.lhs b/provider/posts/beuteltier-2.lhs
new file mode 100644
index 0000000..bca4c86
--- /dev/null
+++ b/provider/posts/beuteltier-2.lhs
@@ -0,0 +1,173 @@
+---
+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.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 .numberLines}
+updateFoo :: Monad m => Foo -> m Foo
+updateFoo = alter $ do
+  bar <~ constructNewBarInM
+  buz .= makeConstantBuz
+~~~
+
+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)
+> 
+> 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)