From a986d02401388cd0c89a816a3307496d40d4c8bf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 5 Aug 2015 22:08:33 +0200 Subject: beuteltier-2.lhs --- provider/posts/beuteltier-2.lhs | 173 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 173 insertions(+) create mode 100644 provider/posts/beuteltier-2.lhs 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) -- cgit v1.2.3