robrix

{-# LANGUAGE DeriveFunctor #-}
module Bidi where

-- For 'guard'.
import Control.Monad
-- We use Cofree to represent type-annotated terms.
import Control.Comonad.Cofree
import Data.Functor.Classes
-- We use Fix to represent unannotated terms.
import Data.Functor.Foldable

robrix

data Ref ref (m :: K.Type -> K.Type) k where
  NewRef :: a -> Ref ref m (ref a)
  ReadRef :: ref a -> Ref ref m a
  WriteRef :: ref a -> a -> Ref ref m ()

newRef :: Has (Ref ref) sig m => a -> m (ref a)
newRef a = send (NewRef a)

readRef :: Has (Ref ref) sig m => ref a -> m a
readRef ref = send (ReadRef ref)

robrix

import Control.Algebra

-- Failover effect

failover :: Has Failover sig m => m a -> m a -> m a
failover a b = send (Failover a b)

infixl 3 `failover`

data Failover m k where

robrix

module ParameterizedRecursion where

import Data.Function

-- A recursive function…
showTable :: (Show a, Show b) => [(a, b)] -> String
showTable ((a, b) : rest) = show a ++ " | " ++ show b ++ "\n" ++ showTable rest
showTable [] = ""

-- …can be defined instead as a fixpoint…

robrix

newtype Fix f = In { out :: f (Fix f) }

cata :: Functor f => (f a -> a) -> (Fix f -> a)
cata alg = go where go = alg . fmap go . out

ana :: Functor f => (a -> f a) -> (a -> Fix f)
ana coalg = go where go = In . fmap go . coalg


hylo1 :: Functor f => (f b -> b) -> (a -> f a) -> (a -> b)

robrix

type Name = String

-- first-order syntax
data Tm
  = Var Name
  | Abs Name Tm
  | App Tm Tm
  deriving (Eq, Ord, Show)

type Env = [(Name, Val)]

robrix

newtype Mu f = Mu (forall r . (f r -> r) -> r)

foldMu :: (f a -> a) -> Mu f -> a
foldMu alg (Mu f) = f alg

unfoldMu :: Functor f => (a -> f a) -> a -> Mu f
unfoldMu coalg a = Mu $ \ alg -> refold alg coalg a

refoldMu :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
refoldMu f g = foldMu f . unfoldMu g

robrix

module FoldsAndUnfolds where

import Data.List -- for unfoldr

class Functor f => Recursive f t | t -> f where
  project :: t -> f t

  cata :: (f a -> a) -> t -> a
  cata alg = go where go = alg . fmap go . project

robrix

{-# LANGUAGE RankNTypes #-}
module Optics where

import           Control.Category ((>>>))
import qualified Control.Category as Cat
import           Control.Effect.Empty
import           Control.Effect.NonDet hiding (empty)
import           Control.Monad ((<=<))

-- riffing off of @serras’s post https://gist.github.com/serras/5152ec18ec5223b676cc67cac0e99b70

robrix

class Applicative f => Selective f where
  branch :: f (Either a b) -> f (a -> c) -> f (b -> c) -> f c
  branch ab f g = fmap (fmap Left) ab `select` fmap (fmap Right) f `select` g

  select :: f (Either a b) -> f (a -> b) -> f b
  select ab f = branch ab f (pure id)

  {-# MINIMAL branch | select #-} -- Defining in terms of both to double-check my work

filteredBy :: (Alternative f, Selective f) => f a -> (a -> Bool) -> f a -- from Staged Selective Parser Combinators