Skip to content

Instantly share code, notes, and snippets.

@kl0tl
Last active January 11, 2018 10:23
Show Gist options
  • Save kl0tl/04eb7640c5ba84d201bd19307b45354a to your computer and use it in GitHub Desktop.
Save kl0tl/04eb7640c5ba84d201bd19307b45354a to your computer and use it in GitHub Desktop.
Stores, Pretexts and Bazaars!
{-# LANGUAGE DeriveFunctor, RankNTypes #-}
data Const r a = Const { getConst :: r }
deriving Functor
instance Monoid r => Applicative (Const r) where
pure _ = Const mempty
(Const a) <*> (Const b) = Const (a `mappend` b)
foldMapDefault f = getConst . traverse (Const . f)
data Compose f g a = Compose { decompose :: f (g a) }
deriving Functor
instance (Applicative f, Applicative g) => Applicative (Compose f g) where
pure = Compose . pure . pure
(Compose fgab) <*> (Compose fga) = Compose $ fmap (<*>) fgab <*> fga
-- A parameterized `Store`, a.k.a. `Context`.
-- `Functor` in `a` and `t`, `Traversable` in `a`.
data PStore a b t = PStore { peek :: b -> t, pos :: a }
deriving Functor
-- Pretext a b t ≅ PStore a b t
newtype Pretext a b t = Pretext {
runPretext :: forall f. Functor f =>
(a -> f b) -> f t
} deriving Functor
fromPretext :: Pretext a b t -> PStore a b t
fromPretext (Pretext f) = f (PStore id)
toPretext :: PStore a b t -> Pretext a b t
toPretext (PStore bt a) = Pretext (\afb -> bt <$> (afb a))
-- A traversable `PStore`.
data PStore' t b a = PStore' (b -> t) a
deriving Functor
instance Foldable (PStore' t b) where
foldMap = foldMapDefault
instance Traversable (PStore' t b) where
traverse afc (PStore' bt a) = fmap (PStore' bt) (afc a)
-- Pretext' t b a ≅ PStore' t b a
newtype Pretext' t b a = Pretext' {
runPretext' :: forall f. Functor f =>
(a -> f b) -> f t
} deriving Functor
instance Foldable (Pretext' t b) where
foldMap = foldMapDefault
instance Traversable (Pretext' t b) where
-- The easiest `traverse` implementation extract the `a` and `b -> t`
-- contained inside `Pretext' t b a` by running the inner function
-- twice with carefully chosen functors (`Const a` and `(->) b`).
-- traverse afc x =
-- fmap (\c -> Pretext' (\cfb -> (peek x) <$> cfb c)) $ afc $ pos $ x
-- where pos (Pretext' f) = getConst $ f $ Const
-- peek (Pretext' f) = f (const id)
-- `PStore a b` can be used instead of `Const a` and `(->) b`
-- to extract `a` and `b -> t` at the same time!
-- traverse afc (Pretext' f) =
-- let (PStore bt fc) = f $ \a -> PStore id (afc a)
-- in fmap (\c -> Pretext' (\cfb -> bt <$> (cfb c))) fc
-- `Compose` is mostly aesthetic here (?) but makes this implementation
-- more symmetrical to the `Traversable` instance of `Baz t b`.
-- traverse afc (Pretext' f) =
-- fmap (\(PStore bt c) -> Pretext' (\cfb -> bt <$> cfb c)) $
-- decompose $ f $ \a -> Compose $ (PStore id) <$> (afc a)
-- `Pretext a b` instead of `PStore a b` allows to build
-- automatically the function wrapped by `Pretext'`.
traverse afc (Pretext' f) =
fmap (\x -> Pretext' (runPretext x)) $ decompose $ f $
(\a -> Compose $ (\c -> Pretext (\cfb -> cfb c)) <$> (afc a))
-- A parameterized Cartesian `Store`, a.k.a.
-- parameterized Kleene Store and parameterized `FunList`.
-- `Functor` in `a` and `t`, `Applicative` in `t` and `Traversable` in `a`.
-- PKStore a b t ≅ ∃ n ∈ ℕ. a^n ⨯ b^n → t
data PKStore a b t = Pure t | Ap a (PKStore a b (b -> t))
instance Functor (PKStore a b) where
fmap f (Pure a) = Pure (f a)
fmap f (Ap a as) = Ap a (fmap (f.) as)
instance Applicative (PKStore a b) where
pure = Pure
Pure f <*> as = fmap f as
Ap a as <*> rhs = Ap a (fmap flip as <*> rhs)
-- Bazaar a b t ≅ PKStore a b t
newtype Bazaar a b t = Bazaar {
runBazaar :: forall f. Applicative f =>
(a -> f b) -> f t
} deriving Functor
instance Applicative (Bazaar a b) where
pure t = Bazaar (\_ -> pure t)
afbtu <*> afbt = Bazaar (\k -> runBazaar afbtu k <*> runBazaar afbt k)
fromBazaar :: Bazaar a b t -> PKStore a b t
fromBazaar (Bazaar f) = f (\a -> Ap a (Pure id))
toBazaar :: PKStore a b t -> Bazaar a b t
toBazaar (Pure t) = Bazaar (\_ -> pure t)
toBazaar (Ap a (Pure bt)) = Bazaar (\afb -> bt <$> (afb a))
toBazaar (Ap a as) = Bazaar (\afb -> runBazaar (toBazaar as) afb <*> (afb a))
-- A traversable PKStore.
data PKStore' t b a = Pure' t | Ap' a (PKStore' (b -> t) b a)
instance Functor (PKStore' t b) where
fmap _ (Pure' a) = Pure' a
fmap f (Ap' a as) = Ap' (f a) (fmap f as)
instance Foldable (PKStore' t b) where
foldMap = foldMapDefault
instance Traversable (PKStore' t b) where
traverse afc (Pure' t) = pure (Pure' t)
traverse afc (Ap' a as) = (\c cs -> Ap' c cs) <$> (afc a) <*> (traverse afc as)
-- Baz t b a ≅ PKStore' t b a
newtype Baz t b a = Baz {
runBaz :: forall f. Applicative f =>
(a -> f b) -> f t
} deriving Functor
instance Foldable (Baz t b) where
foldMap = foldMapDefault
instance Traversable (Baz t b) where
-- This `traverse` implementation reuse the logic of the `Traversable`
-- instance for `Pretext' t b`: all `a`s and the `b -> t` function
-- contained inside `Baz t b a` are extracted at the same time
-- with `Bazaar a b t` and `Bazaar` instead of `PKStore` allows
-- to build a new `Baz` incrementally. ⚠️ `Compose` is mandatory
-- here to merge `Bazaar t b c`s **inside** an `Applicative`.
traverse afc bz =
fmap (\bz' -> Baz (runBazaar bz')) $ decompose $ runBaz bz $
(\a -> Compose $ (\c -> Bazaar (\cfb -> cfb c)) <$> (afc a))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment