Backing code for http://lahteenmaki.net/dev_*15/

Main.hs

{-# LANGUAGE TupleSections #-}
module Main where

-- hide the-dot to use it from Control.Category
import Prelude hiding ((.))
import Control.Category
import Control.Monad ((<=<))
import Control.Comonad.Env
import Control.Arrow
import Data.Profunctor

-- a simple use case:
-- 1) get smallest integer from a list
-- 2) divide "some number" with this integer
-- 3) compose these functions in the spirit of functional programming

-- types are commented out just to show that the compiler really doesn't need them.
-- that is, they don't carry any necessary information, for the compiler or the reader.



-- A) The simplest case, ordinary functions.

--functionAB :: [Int] -> Int
functionAB a = minimum a

--functionBC :: Int -> Int
functionBC b = 42 `div` b

--function :: [Int] -> Int
function = functionBC . functionAB



-- B) Sometimes our values are wrapped within a context, but this is no
--    problem since we can just lift the regular function to work with
--    contextual values. As long as it's a Functor.

--liftedAB :: Maybe [Int] -> Maybe Int
liftedAB = fmap functionAB

--liftedBC :: Maybe Int -> Maybe Int
liftedBC = fmap functionBC

--lifted :: Maybe [Int] -> Maybe Int
lifted = liftedBC . liftedAB



-- C) Since the calculation can fail, we might want to encode it in the types.
--    This gives rise to a monadic version of the same use case.

--monadicAmB :: [Int] -> Maybe Int
monadicAmB [] = Nothing
monadicAmB a = Just (minimum a)

--monadicBmC :: Int -> Maybe Int
monadicBmC 0 = Nothing
monadicBmC b = Just (42 `div` b)

--monadic :: [Int] -> Maybe Int
monadic  = monadicBmC <=< monadicAmB

-- In order to compose monads as a Category, they need to be wrapped to a Kleisli arrow.
-- Yes, this is somewhat silly.
--monadic2 :: Kleisli Maybe [Int] Int
monadic2 = Kleisli monadicBmC . Kleisli monadicAmB


-- D) Perhaps the dividend is really not a constant, but something to be read from an environment?
--    This gives rise to a comonadic version of the same use case.

-- Tuple2 happens to be a Comonad, so we can simply pass in the environment value as
-- the left side.
type WithEnv e = (,) e

--comonadic_mAB :: WithEnv Int [Int] -> Int
comonadic_mAB (e,[]) = e
comonadic_mAB (e,a) = minimum a

--comonadic_mBC :: WithEnv Int Int -> Int
comonadic_mBC (e,0) = e
comonadic_mBC (e,b) = e `div` b

--comonadic :: WithEnv Int [Int] -> Int
comonadic  = comonadic_mBC =<= comonadic_mAB

-- In order to compose comonads as a Category, they need to be wrapped to a Cokleisli arrow.
-- Yes, this is also somewhat silly.
--comonadic2 :: Cokleisli (WithEnv Int) [Int] Int
comonadic2 = Cokleisli comonadic_mBC . Cokleisli comonadic_mAB



-- E) What about if we want to add logging to the individual parts of the calculation?
--    This could be modelled as a Writer Monad, but the simplest way would be to use an Applicative:

-- define composition for Applicatives (why is this not in hackage?)
(<.>) :: Applicative f => f (b -> c) -> f (a -> b) -> f (a -> c)
f <.> g = (.) <$> f <*> g

-- define Applicative as a Category over Cayley, or whatever. Similar to Monad/Kleisli
newtype Cayley f a b = Cayley { runCayley :: (f (a -> b)) }
instance Applicative f => Category (Cayley f) where
  id = Cayley $ pure Prelude.id
  Cayley g . Cayley f = Cayley $ (.) <$> g <*> f
  
-- Tuple2 happens to be an Applicative, so we just keep the log on its left side.
type Logged = (,) [String]

--applicativeAB :: Logged ([Int] -> Int)
applicativeAB = (["calculating minimums..."], minimum)

--applicativeBC :: Logged (Int -> Int)
applicativeBC = (["dividing by the value..."], (42 `div` ))

--applicative :: Logged ([Int] -> Int)
applicative = applicativeBC <.> applicativeAB

-- In order to compose applicatives as a Category, they need to be wrapped to a Cayley type.
-- Yes, yet again this is somewhat silly.
--applicative2 :: Cayley Logged [Int] Int
applicative2 = Cayley applicativeBC . Cayley applicativeAB


-- F) What if we need both? A contextual input and a contextual output?

--both_wAmB :: WithEnv Int [Int] -> Maybe Int
both_wAmB (e,[]) = Nothing
both_wAmB (e,a)  = Just (minimum a)

--both_wBmC :: WithEnv Int Int -> Maybe Int
both_wBmC (e,0) = Nothing
both_wBmC (e,b) = Just (e `div` b)

-- Whoops, how to compose these?
--both :: WithEnv Int [Int] -> Maybe Int
both = undefined--both_wBmC . both_wAmB



-- Let's wrap out use case to its own type:

data MyFunctionType a b = MyFunctionType (WithEnv Int a -> Maybe b)

-- to provide Functor and Applicative, we need to "fix" the input type:

instance Functor (MyFunctionType a) where
  fmap f (MyFunctionType g) = MyFunctionType $ fmap f . g

instance Applicative (MyFunctionType a) where
  pure b = MyFunctionType $ \wa -> pure b
  MyFunctionType f <*> MyFunctionType g = MyFunctionType $ \wa -> f wa <*> g wa 

--cat_AB :: MyFunctionType [Int] Int
cat_AB = MyFunctionType f
  where f (_,[]) = Nothing
        f (_,a)  = Just (minimum a)

--cat_BC :: MyFunctionType Int Int
cat_BC = MyFunctionType f
  where f (_,0) = Nothing
        f (e,b) = Just (e `div` b)

-- whoops, functions with different input types do not compose as Applicatives.
cat :: MyFunctionType [Int] Int
--cat = ar_BC <.> ar_AB

-- But we can make it a Category:

instance Category MyFunctionType where
  id = MyFunctionType $ Just . snd
  MyFunctionType g . MyFunctionType f = MyFunctionType $
    \(e,a) -> case f (e,a) of
                Nothing -> Nothing
                Just b -> g (e,b)

-- now we got composition
cat = cat_BC . cat_AB

-- if additionally we make out type a Profunctor, that is,
-- a two-argument thing where the first argument can be considered
-- as "input" (contravariant) and second argument as "output" (covariant):

instance Profunctor MyFunctionType where
  rmap f (MyFunctionType ff) = MyFunctionType $ fmap f . ff
  lmap f (MyFunctionType ff) = MyFunctionType $ ff . fmap f

-- and provide "Strength", that is, capability to "drop in" values to "pass through":

instance Strong MyFunctionType where
  first' f = MyFunctionType $ \p@(_,a) -> let (MyFunctionType h) = dimap fst (,snd a) f in h p

-- what can we do with these?
-- Surprisingly, these simple additions give as ability to build
-- various kinds of _component networks_!
-- e.g. "stream transformers", "simple automata", "FRP", "Music signals", ...

-- if additionally we state that our type can "choose its output type based on its input":

instance Choice MyFunctionType where
  left' = dimap (\(Left a) -> a) Left

-- ...and that it can "drop out" values from input and output:

instance Costrong MyFunctionType where
  unfirst = dimap (,undefined) fst

-- ...we get the power of branching and feedback!

-- These are Arrow/ArrowChoice/ArrowLoop:

instance Arrow MyFunctionType where
  arr = MyFunctionType . dimap snd Just 
  first = first'

instance ArrowChoice MyFunctionType where
  left = left'

instance ArrowLoop MyFunctionType where
  loop = unfirst

-- Now we can build our networks with a common, well understood, abstraction.

arrow :: MyFunctionType [Int] Int
arrow = cat_BC <<< cat_AB

main = do
  print $ function [42]
  print $ lifted (Just [42])
  print $ applicative <*> ([], [42])