Skip to content

Instantly share code, notes, and snippets.

@danbornside

danbornside/ReflexNonsense.hs

Last active October 7, 2019 03:52
Show Gist options
  • Save danbornside/71dc3419b47c5b30513b3555116791e6 to your computer and use it in GitHub Desktop.
Save danbornside/71dc3419b47c5b30513b3555116791e6 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
ReflexNonsense.hs
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Werror #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- lots of general abstract nonsense related to reflex types.
module Reflex.Nonsense where
import Prelude hiding (id, (.))
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad.Fix
import Control.Categorical.Bifunctor as Cat
import Control.Category
import Control.Category.Associative as Cat
import Control.Category.Braided as Cat
import Control.Category.Monoidal as Cat
import Control.Lens (preview, over)
import Data.Align
import Data.Functor.Identity
import Data.Functor.Apply
import Data.Map.Monoidal (MonoidalMap)
import qualified Data.Map.Monoidal as MMap
import Data.Monoid
import Data.These
import Data.These.Lens (here, there)
import Data.Void
import Reflex.Query.Class
import Reflex.Query.Base
import Reflex.Class
import Control.Lens (At, Index, IxValue, set, at, view)
import Data.Vessel (Selectable, Selection, selector, selection)
-- | We can already say this in reflex
subQuery :: (Reflex t, MonadQuery t q2 m, Monad m) => QueryMorphism q1 q2 -> Dynamic t q1 -> m (Dynamic t (QueryResult q1))
subQuery (QueryMorphism f g) x = fmap g <$> queryDyn (fmap f x)
mapQueryT ::
( Reflex t, MonadQuery t q2 m, Group q1, Additive q1, MonadFix m)
=> QueryMorphism q1 q2
-> QueryT t q1 m a
-> m a
mapQueryT (QueryMorphism f g) k = do
rec
(a, q) <- runQueryT k (fmap g q')
q' <- queryIncremental $ unsafeMapIncremental f (AdditivePatch . f . unAdditivePatch) q
return a
-- Lets add a few more ways to build queries from simpler parts:
-- asking two questions is the same as asking both questions.
instance (Query a, Query b) => Query (a, b) where
type QueryResult (a, b) = (QueryResult a, QueryResult b)
crop (x, x') (y, y') = (crop x y, crop x' y')
-- ¯\_(ﾟヮﾟ)_/¯ ¯\_(ツ)_/¯
instance Query () where
type QueryResult () = ()
crop _ _ = ()
instance Query Void where
type QueryResult Void = ()
crop = absurd
-- | We can lift queries into monoidal containers.
-- But beware of Applicatives who's monoid is different from (pure mempty, liftA2 mappend)
instance (Query q, Applicative f) => Query (Ap f q) where
type QueryResult (Ap f q) = Ap f (QueryResult q)
crop = liftA2 crop
-- | Functionally similar to the instance for (,), but doesn't respond when there
-- was no question.
instance (Query a, Query b) => Query (These a b) where
type QueryResult (These a b) = Maybe (These (QueryResult a) (QueryResult b))
crop (This q) r = (r >>= preview here >>= Just . This . crop q)
crop (That q') r = (r >>= preview there >>= Just . That . crop q')
crop (These q q') r = fmap (bimap (crop q) (crop q')) r
-- | reflex already defines an instance for MonodalMap, which relies
-- essentially on the lattice structure of sets; we can formalize that.
-- But beware of Functor's whos Apply is different from (mapMaybe (preview _These) . align)
instance (Query q, Align f, Apply f) => Query (WrappedAlign f q) where
type QueryResult (WrappedAlign f q) = WrappedAlign f (QueryResult q)
crop = liftF2 crop
newtype WrappedAlign f a = WrapAlign { unwrapAlign :: f a }
deriving (Functor, Foldable, Traversable)
instance (Semigroup a, Semialign f) => Semigroup (WrappedAlign f a) where
WrapAlign xs <> WrapAlign ys = WrapAlign (salign xs ys)
instance (Semigroup a, Align f) => Monoid (WrappedAlign f a) where
mempty = WrapAlign nil
mappend = (<>)
instance Apply f => Apply (WrappedAlign f) where
liftF2 f (WrapAlign x) (WrapAlign y) = WrapAlign (liftF2 f x y)
WrapAlign f <.> WrapAlign x = WrapAlign (f <.> x)
-- QueryMorphism is a category, lets take it as far as it'll suffer
instance PFunctor (,) QueryMorphism QueryMorphism where first f = bimap f id
instance QFunctor (,) QueryMorphism QueryMorphism where second f = bimap id f
instance Bifunctor (,) QueryMorphism QueryMorphism QueryMorphism where
bimap (QueryMorphism f g) (QueryMorphism f' g') = QueryMorphism (bimap f f') (bimap g g')
instance Associative QueryMorphism (,) where
associate = QueryMorphism associate disassociate
disassociate = QueryMorphism disassociate associate
instance Braided QueryMorphism (,) where
braid = QueryMorphism braid braid
instance Symmetric QueryMorphism (,)
instance Monoidal QueryMorphism (,) where
type Id QueryMorphism (,) = ()
idl = QueryMorphism idl coidl
idr = QueryMorphism idr coidr
coidl = QueryMorphism coidl idl
coidr = QueryMorphism coidr idr
-- however, we'd like not to get answers to questions' we've not asked.
instance PFunctor These QueryMorphism QueryMorphism where first f = bimap f id
instance QFunctor These QueryMorphism QueryMorphism where second f = bimap id f
instance Bifunctor These QueryMorphism QueryMorphism QueryMorphism where
bimap (QueryMorphism f g) (QueryMorphism f' g') = QueryMorphism (bimap f f') (fmap (bimap g g'))
instance PFunctor These (->) (->) where first = over here
instance QFunctor These (->) (->) where second = over there
instance Bifunctor These (->) (->) (->) where
bimap a2b c2d = over here a2b . over there c2d
instance Associative (->) These where
associate = these (over there This) (That . That) (these (\a c -> These a (That c)) (\b c -> That (These b c)) (\a b c -> These a (These b c)))
disassociate = these (This . This) (over here That) (\a -> these (\b -> This (These a b)) (\c -> These (This a) c) (\b c -> These (These a b) c)) -- read this aloud
instance Braided (->) These where
braid = these That This (flip These)
instance Symmetric (->) These
instance Monoidal (->) These where
type Id (->) These = Void
idl = these absurd id absurd
idr = these id absurd (const absurd)
coidl = That
coidr = This
fromMaybeThese :: Maybe (These a b) -> (Maybe a, Maybe b)
fromMaybeThese = (preview (traverse . here) &&& preview (traverse . there))
toMaybeThese :: (Maybe a, Maybe b) -> Maybe (These a b)
toMaybeThese = uncurry align
instance Associative QueryMorphism These where
associate = QueryMorphism associate $ toMaybeThese . first (return . toMaybeThese) . disassociate . second (fromMaybeThese . join) . fromMaybeThese
disassociate = QueryMorphism disassociate $ toMaybeThese . second (return . toMaybeThese) . associate . first (fromMaybeThese . join) . fromMaybeThese
instance Braided QueryMorphism These where
braid = QueryMorphism braid $ fmap braid
instance Symmetric QueryMorphism These
qMap :: (Ord k, Query q) => k -> QueryMorphism q (MonoidalMap k q)
qMap k = QueryMorphism (MMap.singleton k) (maybe mempty id . MMap.lookup k)
qAt ::
( At (t q), At (QueryResult (t q))
, IxValue (QueryResult (t q)) ~ QueryResult q
, Index (t q) ~ Index (QueryResult (t q))
, q ~ IxValue (t q)
, Align t
, Query q
)
=> Index (t q)
-> QueryMorphism (q) (t q)
qAt k = QueryMorphism (\q -> set (at k) (Just q) nil) (maybe mempty id . view (at k))
qV :: forall v k q.
( Selectable v k
, v Identity ~ QueryResult (v (Const q))
, Selection v k ~ QueryResult q
) => k -> QueryMorphism q (v (Const q))
qV k = QueryMorphism (\q -> selector (Const q) k) (selection k)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment