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.LensesWe make use of lenses (as provided by lens) extensively. We won´t dedicate a post to beuteltier/Beuteltier/Types/Lenses.hs because it consists mostly of the canonical invocations of 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.BoolExprQuite 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:
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 . constructSometimes 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 Objects 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 == bTo 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 SearchQuerys 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)