Skip to content

Instantly share code, notes, and snippets.

@danbornside

danbornside/ViewSelectors.hs

Last active August 20, 2018 12:00
Show Gist options
  • Save danbornside/8192e71bb0842f2bd28862bcd370f16d to your computer and use it in GitHub Desktop.
Save danbornside/8192e71bb0842f2bd28862bcd370f16d to your computer and use it in GitHub Desktop.
Download ZIP
Raw
ViewSelectors.hs
{-# LANGUAGE ConstraintKinds , ScopedTypeVariables , UndecidableInstances , FlexibleContexts , FlexibleInstances , DeriveTraversable , FunctionalDependencies , GeneralizedNewtypeDeriving , InstanceSigs , LambdaCase , MultiParamTypeClasses , PolyKinds , Rank2Types , StandaloneDeriving , TupleSections , TypeFamilies , TypeOperators #-}
{-
name: view-selector
version: 0.1.0.0
license: BSD3
license-file: LICENSE
author: dan bornside
maintainer: dan.bornside@gmail.com
build-type: Simple
extra-source-files: ChangeLog.md
cabal-version: >=1.10
library
exposed-modules:
ViewSelector
build-depends:
base >=4.11 && <4.12 , lens , monoidal-containers >= 0.4 && < 0.5 , witherable , bifunctors , containers , constraints, IntervalMap
default-language: Haskell2010
ghc-options: -Wall
-}
{-# OPTIONS_GHC -Wno-orphans #-}
module ViewSelector where
import Prelude hiding (lookup)
import Data.Map.Monoidal (MonoidalMap)
import qualified Data.Map.Monoidal as MMap
import Data.Semigroup (First(..), Option(..))
import Data.Witherable
import Data.Constraint
import Data.Functor.Compose
import Control.Lens.Indexed (FunctorWithIndex, imap)
import Control.Lens.Indexed (FoldableWithIndex)
import Control.Lens.Indexed (TraversableWithIndex, itraverse)
-- we have the general problem of needing to send "incremental" updates to a
-- (view of) a shared data set. The general idea is to have an initial query
-- that captures the desired view in roughly the right format for that data
-- set, then have a "monoidal" operation that can update the initial data set
-- with the updated data, this can usually include whiteouts, counterfactuals
-- indicating that a previously known fact is now false and should be erased
-- from the dataset.
--
-- Whenever a new value for `View f` is learned, it
-- can be (left) `mappend`ed to the old value (`mappend new old`)
-- for ergonomics reasons, you can use the Query type in your code and the
-- correct instances will compute a suitable
-- | this is the parametric replacement for *crop*.
crop :: (Semigroup a, ViewSelector t) => (a -> b -> (Maybe c)) -> t a -> View t b -> View t c
crop f vs = iMapMaybe $ \i b -> maybe Nothing (flip f b) $ lookup i vs
class ( TraversableWithIndex (ViewIndex f) (View f)
, Witherable (View f)
) => ViewSelector f where
data View f :: * -> *
type ViewIndex f
-- we could do this with QuantifiedConstraints, in 8.6
_viewMonoid :: Semigroup a :- Monoid (View f a)
_viewSelectorSemiGrp :: Semigroup a :- Semigroup (f a)
lookup :: Semigroup a => ViewIndex f -> f a -> Maybe a
iMapMaybe :: (FunctorWithIndex i t, Filterable t) => (i -> a -> Maybe b) -> t a -> t b
iMapMaybe f = catMaybes . imap f
iWither :: (TraversableWithIndex i t, Witherable t, Applicative f) => (i -> a -> f (Maybe b)) -> t a -> f (t b)
iWither f = fmap catMaybes . itraverse f
-- because of the combining aspect of how these things get used, there will
-- also be an extra parameter that must be carried around with both queries and
-- their responses to tie response back to their queries. That may be
-- explained in detail later, but for now, there will need to be some extra,
-- functorial data, that can usually be counted on to be a Semigroup
-- The simplest is "Single" which is a global value that can be queried or not,
-- and be updated or not.
newtype MaybeSelector (v :: *) a = MaybeSelector { unMaybeSelector :: Maybe a }
deriving (Eq, Ord, Functor, Foldable, Traversable)
instance ViewSelector (MaybeSelector (v :: *)) where
newtype View (MaybeSelector v) a = Single { unSingle :: Option (First v, a) }
deriving (Semigroup, Monoid, Functor, Foldable, Traversable)
type ViewIndex (MaybeSelector v) = ()
_viewMonoid = Sub Dict
_viewSelectorSemiGrp = Sub Dict
lookup _ = unMaybeSelector
{-# INLINE lookup #-}
instance Semigroup a => Semigroup (MaybeSelector v a) where
MaybeSelector xs <> MaybeSelector ys = MaybeSelector (xs <> ys)
instance Filterable (View (MaybeSelector v)) where
mapMaybe f = Single . mapMaybe (traverse f) . unSingle
instance Witherable (View (MaybeSelector v))
instance FunctorWithIndex () (View (MaybeSelector v))
instance FoldableWithIndex () (View (MaybeSelector v))
instance TraversableWithIndex () (View (MaybeSelector v)) where
itraverse f = traverse $ f ()
newtype MapSelector (v :: *) k a = MapSelector { unMapSelector :: MonoidalMap k a }
deriving (Eq, Ord, Functor, Foldable, Traversable, Semigroup)
instance Ord k => ViewSelector (MapSelector v k) where
newtype View (MapSelector v k) a = MapView { unMapView :: MonoidalMap k (First v, a) }
deriving
( Show, Read, Functor, Eq, Ord -- , NFData
, Foldable, Traversable
-- , Data, Typeable
-- , Ixed, At, Each, Newtype, IsList
, Semigroup, Monoid
)
type ViewIndex (MapSelector v k) = k
_viewMonoid = Sub Dict
_viewSelectorSemiGrp = Sub Dict
lookup k = MMap.lookup k . unMapSelector
instance Filterable (View (MapSelector v k)) where
mapMaybe f = MapView . mapMaybe (traverse f) . unMapView
instance Witherable (View (MapSelector v k))
instance FunctorWithIndex k (View (MapSelector v k))
instance FoldableWithIndex k (View (MapSelector v k))
instance TraversableWithIndex k (View (MapSelector v k)) where
itraverse :: forall f a b. Applicative f => (k -> a -> f b) -> View (MapSelector v k) a -> f (View (MapSelector v k) b)
itraverse f = fmap MapView . itraverse f' . unMapView
where
f' :: k -> (First v, a) -> f (First v, b)
f' k (x, y) = (x,) <$> f k y
-- okay, time to turn on the brain
instance ( ViewSelector f , ViewSelector g)
=> ViewSelector (Compose f g) where
newtype View (Compose f g) a = ComposeView { unComposeView :: Compose (View f) (View g) a }
type ViewIndex (Compose f g) = (ViewIndex f, ViewIndex g)
_viewMonoid = Sub Dict
_viewSelectorSemiGrp = Sub Dict
lookup = composeLookup
composeLookup :: forall f g a.
( ViewSelector g , ViewSelector f , Semigroup a )
=> (ViewIndex f, ViewIndex g) -> Compose f g a -> Maybe a
composeLookup (k0, k1) (Compose xs) = case _viewSelectorSemiGrp :: Semigroup a :- Semigroup (g a) of
Sub Dict -> lookup k0 xs >>= lookup k1
-- Well, without QuantifiedConstraints, we can't actually have these instances
-- in the first place, (the :- methods in ViewSelector are a hack that gives us
-- an alternative). As such, orphan instances are a lesser evil
instance (ViewSelector f, ViewSelector g, Semigroup a) => Semigroup (Compose f g a) where
Compose xs <> Compose ys =
case (_viewSelectorSemiGrp :: Semigroup a :- Semigroup (g a)) of
Sub Dict -> case (_viewSelectorSemiGrp :: Semigroup (g a) :- Semigroup (f (g a))) of
Sub Dict -> Compose $ xs <> ys
instance (ViewSelector f, ViewSelector g, Semigroup a) => Semigroup (View (Compose f g) a) where
ComposeView (Compose xs) <> ComposeView (Compose ys) =
case (_viewMonoid :: Semigroup a :- Monoid (View g a)) of
Sub Dict -> case (_viewMonoid :: Semigroup (View g a) :- Monoid (View f (View g a))) of
Sub Dict -> ComposeView (Compose $ xs <> ys)
instance (ViewSelector f, ViewSelector g, Semigroup a) => Monoid (View (Compose f g) a) where
mappend = (<>)
mempty =
case (_viewMonoid :: Semigroup a :- Monoid (View g a)) of
Sub Dict -> case (_viewMonoid :: Semigroup (View g a) :- Monoid (View f (View g a))) of
Sub Dict -> ComposeView (Compose mempty)
-- case (_viewMonoid :: Semigroup a :- Monoid (View f a)) of
-- Sub Dict -> case (_viewMonoid :: Semigroup a :- Monoid (View g a)) of
-- Sub Dict -> Sub Dict
deriving instance (Functor (View v), Functor (View w)) => Functor (View (Compose v w))
deriving instance (Foldable (View v), Foldable (View w)) => Foldable (View (Compose v w))
deriving instance (Traversable (View v), Traversable (View w)) => Traversable (View (Compose v w))
-- deriving instance Filterable (
deriving instance (Functor (View v), Filterable (View w)) => Filterable (View (Compose v w))
-- TODO: We'd like have an extra `Witherable` on the `View v` so that we can
-- chop out whole subtrees of the outer view when the inner view is
-- `Foldable.null` That way we can trim out query responses that are not
-- supposed to be visible to the caller. For now though, the default instance
-- is nearly right.
instance (Traversable (View v), Witherable (View w)) => Witherable (View (Compose v w))
instance
( ViewSelector f, FunctorWithIndex (ViewIndex f) (View f)
, ViewSelector g, FunctorWithIndex (ViewIndex g) (View g)
, i ~ ViewIndex (Compose f g)
)
=> FunctorWithIndex i (View (Compose f g))
instance
( ViewSelector f, FoldableWithIndex (ViewIndex f) (View f)
, ViewSelector g, FoldableWithIndex (ViewIndex g) (View g)
, i ~ ViewIndex (Compose f g)
)
=> FoldableWithIndex i (View (Compose f g))
-- i think this is where i need UndecidableInstances
instance
( ViewSelector f, TraversableWithIndex (ViewIndex f) (View f)
, ViewSelector g, TraversableWithIndex (ViewIndex g) (View g)
, i ~ ViewIndex (Compose f g)
)
=> TraversableWithIndex i (View (Compose f g)) where
itraverse f = fmap ComposeView . itraverse f . unComposeView
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment