ComonadicUI : https://arthurxavierx.github.io/ComonadsForUIs.pdf

Component.hs

module ComonadicUI.Component where
  
import Control.Comonad (Comonad(..))

import ComonadicUI.Pairing
import ComonadicUI.UI 


type Component base w m a = w (UI base m a)


type Component' base w m a = w (UI' base m a)

Console.hs

module ComonadicUI.Target.Console where
  
import Data.IORef
import Control.Monad (forever)
import Control.Comonad (Comonad(..))

import ComonadicUI.Pairing
import ComonadicUI.Component
import ComonadicUI.Space


data Console = Console { _text :: String, _action :: String -> IO () }


explore :: (Comonad w, Pairing m w) => Component IO w m Console -> IO ()
explore component = do
  ref <- newIORef component -- initialize the reference with the initial space
  forever $ do
    space <- readIORef ref
    
    -- send receives an action dispatched by the UI
    -- and updates the state by moving around in the space
    let send action = writeIORef ref (move space action)
    
     -- extract the current interface
    let Console text action = extract space send 
    
    putStrLn text 
    input <- getLine
    action input


explore' :: (Comonad w, Pairing m w) => Component' IO w m Console -> IO ()
explore' component = do
  ref <- newIORef component -- initialize the reference with the initial space 
  forever $ do
    space <- readIORef ref
 
    -- send receives an action dispatched by the UI
    -- encapsulated in the base monad 
    -- and updates the state by moving around in the space
    let send baseAction = do
        action <- baseAction
        writeIORef ref (move space action)
        
     -- extract the current interface
    let Console text action = extract space send
    
    putStrLn text 
    input <- getLine 
    action input

Counter.hs

module ComonadicUI.Component.Counter where
  
import ComonadicUI.Stream
import ComonadicUI.Sequence
import ComonadicUI.Component
import ComonadicUI.UI
import ComonadicUI.Target.Console


counter :: Component IO Stream Sequence Console
-- counter = render <$> stream
counter = unfold 0 (\state -> (render state, state + 1))
  where 
    render :: Int -> UI IO Sequence Console
    render state = \send -> 
      Console 
         (show state)
         (\input -> send (Next (End ())))

Files.hs

{-# LANGUAGE MultiParamTypeClasses #-}

module ComonadicUI.Component.Files where

import System.Directory

import ComonadicUI.Pairing
import ComonadicUI.Store
import ComonadicUI.State
import ComonadicUI.UI
import ComonadicUI.Component
import ComonadicUI.Target.Console


instance Pairing (State s) (Store s) where 
  pair f (State g) (Store get s) = f a (get s')
    where (a, s') = g s
    

files :: Component' IO (Store [String]) (State [String]) Console
files = Store render []
  where 
    render :: [String] -> UI' IO (State [String]) Console
    render list = \send ->
      Console 
          ("Files read: " ++ show list)
          (send . tryReadFile)
          

tryReadFile :: String -> IO (State [String] ())
tryReadFile input = do
  fileExists <- doesFileExist input 
  if fileExists
    then do 
      contents <- readFile input 
      putStrLn (takeWhile (/= '\n') contents)
      return (modify (++[input]))
    else do
      putStrLn "File not found"
      return (put [])

List.hs

{-# LANGUAGE MultiParamTypeClasses #-}

module ComonadicUI.Component.List where

import ComonadicUI.Pairing
import ComonadicUI.Store
import ComonadicUI.State
import ComonadicUI.UI
import ComonadicUI.Component
import ComonadicUI.Target.Console


instance Pairing (State s) (Store s) where 
  pair f (State g) (Store get s) = f a (get s')
    where (a, s') = g s
    

list :: Component IO (Store [String]) (State [String]) Console
list = Store render []
  where 
    render :: [String] -> UI IO (State [String]) Console
    render list = \send ->
      Console 
          ("I've received: " ++ show list)
          (\input -> 
              send (if input == "" then put [] else modify (++[input])))

Main.hs

module ComonadicUI.Main where

import ComonadicUI.Component.Counter
import ComonadicUI.Component.List
import ComonadicUI.Target.Console


--main :: IO ()
--main = explore counter


main :: IO ()
main = explore list

Pairing.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}

module ComonadicUI.Pairing where
  

import Data.Functor.Identity
  

-- type Pairing f g = forall a b. f (a -> b) -> g a -> b

class Pairing f g | f -> g, g -> f where 
  pair :: (a -> b -> c) -> f a -> g b -> c 


instance Pairing Identity Identity where
  pair f (Identity a) (Identity b) = f a b
  

instance Pairing ((->) b) ((,) b) where
  pair f g (a, b) = f (g a) b
  

uncurry' :: (a -> b -> c) -> (a, b) -> c
uncurry' = pair ($)



{-
uncurry' (+) (1, 2)

($)
-}

Sequence.hs

{-# LANGUAGE MultiParamTypeClasses #-}

module ComonadicUI.Sequence where
  

import ComonadicUI.Pairing
import ComonadicUI.Stream
import ComonadicUI.Space (move)


data Sequence a = End a | Next (Sequence a)


instance Functor Sequence where 
    fmap f (End v) = End (f v)
    fmap f (Next x) = fmap f x


instance Applicative Sequence where 
    pure = End
    (End f) <*> s = f <$> s
    (Next x) <*> s = x <*> s


instance Monad Sequence where 
    return = End
    (End a) >>= f = f a
    (Next next) >>= f = Next (next >>= f)
    

instance Pairing Sequence Stream where 
    pair f (End a) (Cons b _) = f a b
    pair f (Next next) (Cons _ stream) = pair f next stream
    
    
    
{- 
firstN 9 (move stream (Next (Next (End ()))))

firstN 9 (move stream' (Next (Next (End ()))))

firstN' 9 (move streams (Next (Next (End ()))))
-}

Space.hs

module ComonadicUI.Space where

import Control.Comonad (Comonad(..), (=>>))

import ComonadicUI.Stream  
import ComonadicUI.Pairing


move :: (Comonad w, Pairing m w) => w a -> m b -> w a
move space movement = pair (\_ newSpace -> newSpace) movement (duplicate space)

State.hs

module ComonadicUI.State where


data State s a = State (s -> (a, s))


instance Functor (State s) where
  fmap f (State g) = State $ \s ->
    let (a, s') = g s in (f a, s')


instance Applicative (State s) where 
  pure a = State (\s -> (a, s))
  -- (<*>) :: forall a b. State s (a -> b) -> State s a -> State s b
  (State f) <*> (State g) = State $ \s ->
    let (h, s') = f s
        (a, s'') = g s'
    in (h a, s'')
             

instance Monad (State s) where 
  return a = State (\s -> (a, s))
  (State g) >>= f = State $ \s ->
    let (a, s') = g s
        State h = f a
    in h s'


modify :: (s -> s) -> State s () 
modify transform = State (\state -> ((), transform state))


put :: s -> State s ()
put newState = State (\_ -> ((), newState))

Store.hs

module ComonadicUI.Store where
  
import Control.Comonad (Comonad(..))

  
data Store s a = Store (s -> a) s


instance Functor (Store s) where
  fmap f (Store sf s) = Store (f . sf) s


instance Comonad (Store s) where
  extract (Store f s) = f s
  duplicate (Store f s) = Store (Store f) s

Stream.hs

module ComonadicUI.Stream where
  
import Control.Comonad (Comonad(..), (=>>))


data Stream a = Cons a (Stream a)


instance Functor Stream where
  fmap f (Cons x xs) = Cons (f x) (fmap f xs)
  

instance Comonad Stream where
  extract (Cons x _) = x
  duplicate s@(Cons _ xs) = Cons s (duplicate xs)
 
  
sumWithNext :: Num a => Stream a -> a
sumWithNext (Cons a (Cons a' _)) = a + a


stream :: Stream Int
stream = convert [1..] 
  where 
     convert [] = error "no more values"
     convert (x:xs) = Cons x (convert xs)
     

streams :: Stream (Stream Int)
streams = duplicate stream


stream' :: Stream Int
stream' = extend sumWithNext stream


walk :: Int -> (a -> IO ()) -> Stream a -> IO ()
walk 0 _ _ = return ()
walk n f (Cons x xs) =
  f x >>= \_ -> walk (n - 1) f xs
  

next :: Stream a -> a
next (Cons _ (Cons n _)) = n
  
    
first3 :: Stream a -> [a]
first3 s =  
  let 
     s2 = s =>> next
     s3 = s2 =>> next
  in [ extract s, extract s2, extract s3 ]
  

firstN :: Int -> Stream a -> [a]
firstN 0 _ = []
firstN n (Cons x xs) = x : firstN (n - 1) xs


firstN' :: Int -> Stream (Stream a) -> [[a]]
firstN' n ss = firstN n <$> firstN n ss 


unfold :: s -> (s -> (a, s)) -> Stream a
unfold initialState next =  
  Cons a (unfold nextState next)
  where (a, nextState) = next initialState



{- 
-- walk 5 print stream
-- walk 5 print stream'


firstN 5 stream
firstN 5 stream'


firstN' 5 streams


first3 stream

first3 stream'
-}

UI.hs

module ComonadicUI.UI where 
  

type UI base m a = (m () -> base ()) -> a


type UI' base m a = (base (m ()) -> base ()) -> a