Stores, Pretexts and Bazaars!

gistfile1.hs

{-# 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))