Comonad UI snippet

Toy.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeAbstractions #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Toy where

import Control.Monad (ap)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.List.NonEmpty qualified as NonEmpty
import Test.DocTest (doctest)

test :: IO ()
test = doctest ["src/Toy.hs"]

--------------------------------------------------------------------------------

--class Functor m => Monad m where
--  return :: a -> m a
--  (>>=) :: m a -> (a -> m b) -> m b
--  join :: m (m a) -> m a

class Functor w => Comonad w where
  extract :: w a -> a

  duplicate :: w a -> w (w a)
  duplicate
    = extend id

  extend :: (w a -> b) -> w a -> w b
  extend f w
    = fmap f (duplicate w)


-- |
-- >>> ex = 1 :| [2, 3] :: NonEmpty Int
-- >>> printNonEmpty ex
-- [1,2,3]
--
-- >>> extract ex
-- 1
--
-- >>> printNonEmptyNonEmpty $ duplicate ex
-- [[1,2,3],[2,3],[3]]
-- >>> printNonEmpty $ extend length ex
-- [3,2,1]
instance Comonad NonEmpty where
  extract (x :| _)
    = x
  duplicate xs@(_ :| [])
    = xs :| []
  duplicate xs0@(_x0 :| (x1 : xs1))
    = xs0 :| NonEmpty.toList (duplicate (x1 :| xs1))

printNonEmpty :: Show a => NonEmpty a -> IO ()
printNonEmpty
  = print . NonEmpty.toList

printNonEmptyNonEmpty :: Show a => NonEmpty (NonEmpty a) -> IO ()
printNonEmptyNonEmpty
  = print . NonEmpty.toList . fmap NonEmpty.toList

data Drop = Drop Int

runDrop :: Drop -> NonEmpty a -> NonEmpty a
runDrop (Drop 0) xs
  = xs
runDrop (Drop _) xs@(_ :| [])
  = xs
runDrop (Drop n) (_ :| (x : xs))
  = runDrop (Drop (n - 1)) (x :| xs)

toCo :: Drop -> Co NonEmpty ()
toCo drp = Co $ \wu2r
  -> let wr = fmap ($ ()) wu2r
  in extract (runDrop drp wr)

fromCo :: Co NonEmpty () -> Drop
fromCo co
  = runCo co ints $ \() wi
 -> Drop (extract wi)
 where
  ints :: NonEmpty Int
  ints = 0 :| [1..]


data Pair a = Pair a a
  deriving (Eq, Show, Functor)

-- |
-- >>> fmap (+1) (Pair 1 10)
-- Pair 2 11
-- >>> duplicate (Pair "me" "neighbour")
-- Pair (Pair "me" "neighbour") (Pair "neighbour" "me")
-- >>> extend (\(Pair _ n) -> n) (Pair "me" "neighbour")
-- Pair "neighbour" "me"
instance Comonad Pair where
  extract (Pair x _y)
    = x
  duplicate pair@(Pair x y)
    = Pair pair (Pair y x)


put :: s -> Store s a -> Store s a
put s (Store _ view)
  = Store s view

move :: s -> Store s a -> Store s a
move s' (Store _ view)
  = Store
      { here = s'
      , view = view
      }


instance Comonad (Store s) where
  extract (Store {..})
    = view here
  duplicate (Store {..})
    = Store
        { here = here
        , view = \s1 -> Store
            { here = s1
            , view = \s2 -> view s2
            }
        }

data Traced s a = Traced
  { mview :: s -> a
  }
  deriving Functor

instance Monoid s => Comonad (Traced s) where
  extract (Traced {..})
    = mview mempty
  duplicate (Traced {..})
    = Traced
        { mview = \s1 -> Traced
            { mview = \s2 -> mview (s1 <> s2)
            }
        }


defaultDuplicate :: Functor w => w a -> w (w a)
defaultDuplicate wa = fmap (const wa) wa


-- > ..xxxxxxx
-- > ..xxxxxxx
-- > ..xxxxxxx :: w (a -> r)
-- > ..fxxxxxx
-- > .........
--
-- >     .....xxxx
-- >     .....xxxx
-- > (a, .....xxxx ) :: Co w a
-- >     ..-->fxxx
-- >     .........
newtype Co w a = Co
  { unCo :: forall r. w (a -> r) -> r }
  deriving Functor

-- >           .....xxxx         .....xxxx
-- >           .....xxxx         .....xxxx
-- > runCo (a, .....xxxx ) (a -> .....xxxx -> r ) :: r
-- >           ..-->fxxx         .....bxxx
-- >           .........         .........
runCo
  :: forall w a b r. Comonad w
  => Co w a
  -> w b
  -> (a -> w b -> r)
  -> r
runCo co wbFromZero f
  = unCo co $ flip extend wbFromZero $ \wbFromCo a
 -> f a wbFromCo

type Action w = Co w ()

mkAction :: (forall r. w r -> r) -> Action w
mkAction f = Co $ \wf
  -> f wf ()

-- >           ......... ..aaaaaaa   .....aaaa
-- >           ......... ..aaaaaaa   .....aaaa
-- > runAction ......... ..aaaaaaa = .....aaaa
-- >           ..-->.... ..Aaaaaaa   .....Aaaa
-- >           ......... .........   .........
--
-- > .........    .........   .........
-- > .........    .........   .........
-- > ......... >> ......... = .........
-- > ..-->....    .....->..   ..---->..
-- > .........    .........   .........
runAction 
  :: forall w a. Comonad w 
  => Co w ()
  -> w a
  -> w a
runAction co waFromZero
  = runCo co waFromZero $ \() waFromCo
 -> waFromCo

-- >          .........
-- >          .........
-- > pure a = .........
-- >          ..a......
-- >          .........
--
-- >                 .........     ..b.......     ......c...
-- >                 .........     ..^.......     ......^...
-- > (\a b -> c) <$> ......... <*> ..|.......  =  ......|...
-- >                 ..0--->a.     ..0.......     ..0---'...
-- >                 .........     ..........     ..........
instance Comonad w => Applicative (Co w) where
  pure a = Co $ \wf
    -> extract wf a
  (<*>) = ap

-- > .........           ..b.......     ......b...
-- > .........           ..^.......     ......^...
-- > ......... >>= \a -> ..|.......  =  ......|...
-- > ..0--->a.           ..0.......     ..0---'...
-- > .........           ..........     ..........
instance Comonad w => Monad (Co w) where
  return = pure
  coA >>= cc = Co $ \wBContFromZero
    -> runCo coA wBContFromZero $ \a wBContFromCoA
    -> runCo (cc a) wBContFromCoA $ \b wBContFromCoAThenCC
    -> let bCont = extract wBContFromCoAThenCC
    in bCont b

-- >        ........ .........     ....
-- >        ........ a1...a3..     b3..
-- > select ........ .........  =  ....
-- >        0--->f.. a0...a2..     b2..
select
  :: forall w a b. Comonad w
  => Co w (a -> b)
  -> w a -> w b
select co waFromZero
  = runCo co waFromZero $ \f waFromCo
 -> fmap f waFromCo



data Elm s i a = Elm
  { elmInit :: s
  , elmUpdate :: i -> s -> s
  , elmRender :: s -> a
  }

toElm :: Moore i a -> Elm (Moore i a) i a
toElm s0
  = Elm
      { elmInit = s0
      , elmUpdate = \i (Moore _ next) -> next i
      , elmRender = \(Moore a _) -> a
      }

fromElm :: forall s i a. Elm s i a -> Moore i a
fromElm (Elm {..}) = go elmInit
  where
    go :: s -> Moore i a
    go s = Moore
             (elmRender s)
             (\i -> go (elmUpdate i s))

data Free f a = Pure a | Free (f (Free f a))
  deriving Functor

instance Comonad (Moore i) where
  extract (Moore a _)
    = a
  duplicate moore@(Moore _ next)
    = Moore moore $ \i -> duplicate (next i)

instance Functor f => Comonad (Cofree f) where
  extract (Cofree a _)
    = a
  duplicate cofree@(Cofree _ next)
    = Cofree cofree $ fmap duplicate next

toCofree :: Moore i a -> Cofree ((->) i) a
toCofree (Moore a next)
  = Cofree a (\i -> toCofree (next i))

fromCofree :: Cofree ((->) i) a -> Moore i a
fromCofree (Cofree a next)
  = Moore a $ \i -> fromCofree (next i)

toCofreePair :: Cofree ((->) Bool) a -> Cofree Pair a
toCofreePair (Cofree a next)
  = Cofree a (Pair
               (toCofreePair (next True))
               (toCofreePair (next False)))

fromCofreePair :: Cofree Pair a -> Cofree ((->) Bool) a
fromCofreePair (Cofree a (Pair tt ff))
  = Cofree a $ \case
      True -> fromCofreePair tt
      False -> fromCofreePair ff

cofreeGame :: Cofree Maybe Int
cofreeGame
  = Cofree 3 $ Just
  $ Cofree 2 $ Just
  $ Cofree 1 $ Just
  $ Cofree 0 Nothing


















































































--------------------------------------------------------------------------------

data Msg = ClickFile | ClickNew
  deriving (Show, Eq, Ord)
data State = Empty | OpenedMenu | BlankCanvas
  deriving (Show, Eq, Ord)

update :: State -> Msg -> State
update Empty       ClickFile = OpenedMenu
update OpenedMenu  ClickNew  = BlankCanvas
update BlankCanvas ClickFile = OpenedMenu
-- but also all those superfluous combinations:
update Empty       ClickNew  = BlankCanvas
update OpenedMenu  ClickFile = OpenedMenu
update BlankCanvas ClickNew  = BlankCanvas
-- TODO: use Cofree to make those illegal message unrepresentable

render :: State -> String
render Empty       = "Empty"
render OpenedMenu  = "Opened Menu"
render BlankCanvas = "Blank Canvas"

--------------------------------------------------------------------------------

data Store s a = Store
  { here :: s
  , view :: s -> a
  }
  deriving Functor

type StoreAction s = Action (Store s)

indentation
 :: Int -> String
indentation indent
  = replicate (indent * 2) ' '

-- |
-- >>> extract emptyStore
-- "Empty"
emptyStore :: Store State String
emptyStore = Store Empty render

clickFileAction :: StoreAction State
clickFileAction = mkAction $ \s
  -> view s OpenedMenu

-- |
-- >>> extract openedMenuStore
-- "Opened Menu"
openedMenuStore :: Store State String
openedMenuStore = runAction clickFileAction emptyStore

--------------------------------------------------------------------------------

data Moore i a = Moore a (i -> Moore i a)
  deriving Functor

type MooreState = Moore Msg String
type MooreAction = Action (Moore Msg)

-- |
-- >>> extract emptyMoore
-- "Empty"
emptyMoore :: MooreState
emptyMoore = empty
  where
    empty, openedMenu, blankCanvas :: MooreState
    empty = Moore (render Empty) $ \case
      ClickFile -> openedMenu
      ClickNew  -> blankCanvas  -- superfluous
    openedMenu = Moore (render OpenedMenu) $ \case
      ClickNew  -> blankCanvas
      ClickFile -> openedMenu   -- superfluous
    blankCanvas = Moore (render BlankCanvas) $ \case
      ClickFile -> openedMenu
      ClickNew  -> blankCanvas  -- superfluous

mkMooreAction :: Msg -> Action (Moore Msg)
mkMooreAction msg = mkAction $ \(Moore _ next)
  -> extract $ next msg

-- |
-- >>> extract openedMenuMoore
-- "Opened Menu"
openedMenuMoore :: MooreState
openedMenuMoore = runAction (mkMooreAction ClickFile) emptyMoore

--------------------------------------------------------------------------------

data Cofree f a = Cofree a (f (Cofree f a))
  deriving Functor

type CofreeState = Cofree MsgF String
type CofreeAction = Action (Cofree MsgF)

data MsgF a
  = FromEmpty
      { clickFile :: a }
  | FromOpenedMenu
      { clickNew :: a, clickOutside :: a }
  | FromBlankCanvas
      { clickFile :: a }
  deriving Functor

-- |
-- >>> extract emptyCofree
-- "Empty"
emptyCofree :: CofreeState
emptyCofree = empty
  where
    empty, openedMenuFromEmpty, openedMenuFromBlank, blankCanvas :: CofreeState
    empty = Cofree (render Empty) $ FromEmpty
      { clickFile = openedMenuFromEmpty }
    openedMenuFromEmpty = Cofree (render OpenedMenu) $ FromOpenedMenu
      { clickNew = blankCanvas, clickOutside = empty }
    openedMenuFromBlank = Cofree (render OpenedMenu) $ FromOpenedMenu
      { clickNew = blankCanvas, clickOutside = blankCanvas }
    blankCanvas = Cofree (render BlankCanvas) $ FromBlankCanvas
      { clickFile = openedMenuFromBlank }

chooseNextCofreeAction :: Action (Cofree MsgF)
chooseNextCofreeAction = mkAction $ \(Cofree _ next)
  -> case next of
      FromEmpty {..}
        -> extract $ clickFile
      FromOpenedMenu {..}
        -> extract $ clickNew
      FromBlankCanvas {..}
        -> extract $ clickFile

chooseOutsideCofreeAction :: Action (Cofree MsgF)
chooseOutsideCofreeAction = mkAction $ \(Cofree _ next)
  -> case next of
      FromEmpty {..}
        -> extract $ clickFile
      FromOpenedMenu {..}
        -> extract $ clickOutside
      FromBlankCanvas {..}
        -> extract $ clickFile

-- |
-- >>> extract openedMenuCofree
-- "Opened Menu"
openedMenuCofree :: CofreeState
openedMenuCofree
  = runAction
      chooseNextCofreeAction
      emptyCofree

-- |
-- >>> extract blankCanvasCofree
-- "Blank Canvas"
blankCanvasCofree :: CofreeState
blankCanvasCofree
  = runAction
      ( chooseNextCofreeAction
     >> chooseNextCofreeAction
      )
      emptyCofree

-- |
-- >>> extract outsideFromEmptyCofree
-- "Empty"
outsideFromEmptyCofree :: CofreeState
outsideFromEmptyCofree
  = runAction
      ( chooseNextCofreeAction
     >> chooseOutsideCofreeAction
      )
      emptyCofree

-- |
-- >>> extract outsideFromBlankCofree
-- "Blank Canvas"
outsideFromBlankCofree :: CofreeState
outsideFromBlankCofree
  = runAction
      ( chooseNextCofreeAction
     >> chooseNextCofreeAction
     >> chooseNextCofreeAction
     >> chooseOutsideCofreeAction
      )
      emptyCofree

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

data TabBasedConfig = TabBasedConfig
  { activeTab :: ConfigTab
  , copilotTab :: CopilotConfig
  , editorTab :: EditorConfig
  }
  deriving (Show, Eq, Ord)

type SectionBasedConfig = (CopilotConfig, EditorConfig)

data ConfigTab = CopilotTab | EditorTab
  deriving (Show, Eq, Ord)

data CopilotConfig = Claude | Codex
  deriving (Show, Eq, Ord)

data EditorConfig = Spaces | Tabs
  deriving (Show, Eq, Ord)

renderTabBasedConfig :: TabBasedConfig -> String
renderTabBasedConfig (TabBasedConfig {..})
  = case activeTab of
      CopilotTab
        -> "Copilot: " ++ show copilotTab
      EditorTab
        -> "Editor: " ++ show editorTab

renderSectionBasedConfig :: CopilotConfig -> EditorConfig -> String
renderSectionBasedConfig copilotCfg editorCfg
  = show copilotCfg ++ " | " ++ show editorCfg

data TabBasedConfigMsg
  = SwitchToCopilotTab
  | SwitchToEditorTab
  | SetCopilotTabToClaude
  | SetCopilotTabToCodex
  | SetEditorTabToSpaces
  | SetEditorTabToTabs
  deriving (Show, Eq, Ord)

updateTabBasedConfig :: TabBasedConfig -> TabBasedConfigMsg -> TabBasedConfig
updateTabBasedConfig cfg = \case
  SwitchToCopilotTab    -> cfg { activeTab = CopilotTab }
  SwitchToEditorTab     -> cfg { activeTab = EditorTab }
  SetCopilotTabToClaude -> cfg { copilotTab = Claude }
  SetCopilotTabToCodex  -> cfg { copilotTab = Codex }
  SetEditorTabToSpaces  -> cfg { editorTab = Spaces }
  SetEditorTabToTabs    -> cfg { editorTab = Tabs }

--------------------------------------------------------------------------------

-- not this!
--data (:+:) f g a = InL (f a) | InR (g a)
--  deriving Functor

data Sum f g a = Sum Bool (f a) (g a)
  deriving Functor

onSum
  :: Sum f g r
  -> (forall x. f x -> x)
  -> (forall x. g x -> x)
  -> r
onSum (Sum False fr _gr) fromF _fromG
  = fromF fr
onSum (Sum True _fr gr) _fromF fromG
  = fromG gr

data CopilotTabF a
  = FromCopilotTab
      { switchToEditorTab :: a
      , setCopilotTabToClaude :: a
      , setCopilotTabToCodex  :: a
      }
  deriving Functor

data EditorTabF a
  = FromEditorTab
      { switchToCopilotTab :: a
      , setEditorTabToSpaces :: a
      , setEditorTabToTabs   :: a
      }
  deriving Functor

type TabBasedConfigF = Sum CopilotTabF EditorTabF
type TabBasedState = Cofree TabBasedConfigF String
type TabBasedAction = Action (Cofree TabBasedConfigF)

-- |
-- >>> extract copilotTabConfig
-- "Copilot: Claude"
copilotTabConfig :: TabBasedState
copilotTabConfig = toTabBasedConfigF $ TabBasedConfig
    { activeTab = CopilotTab
    , copilotTab = Claude
    , editorTab = Spaces
    }
  where
    toTabBasedConfigF :: TabBasedConfig -> TabBasedState
    toTabBasedConfigF cfg@(TabBasedConfig {activeTab})
      = Cofree (renderTabBasedConfig cfg)
      $ case activeTab of
          CopilotTab
            -> Sum False (toCopilotConfigF cfg) (toEditorConfigF cfg)
          EditorTab
            -> Sum True (toCopilotConfigF cfg) (toEditorConfigF cfg)

    toCopilotConfigF :: TabBasedConfig -> CopilotTabF TabBasedState
    toCopilotConfigF cfg = FromCopilotTab
      { switchToEditorTab = toTabBasedConfigF $ updateTabBasedConfig cfg SwitchToEditorTab
      , setCopilotTabToClaude = toTabBasedConfigF $ updateTabBasedConfig cfg SetCopilotTabToClaude
      , setCopilotTabToCodex  = toTabBasedConfigF $ updateTabBasedConfig cfg SetCopilotTabToCodex
      }

    toEditorConfigF :: TabBasedConfig -> EditorTabF TabBasedState
    toEditorConfigF cfg = FromEditorTab
      { switchToCopilotTab = toTabBasedConfigF $ updateTabBasedConfig cfg SwitchToCopilotTab
      , setEditorTabToSpaces = toTabBasedConfigF $ updateTabBasedConfig cfg SetEditorTabToSpaces
      , setEditorTabToTabs   = toTabBasedConfigF $ updateTabBasedConfig cfg SetEditorTabToTabs
      }


towardsUsingTabs :: TabBasedAction
towardsUsingTabs = mkAction $ \(Cofree _ sum_)
  -> extract
   $ onSum sum_
       (\(FromCopilotTab {..}) -> switchToEditorTab)
       (\(FromEditorTab {..}) -> setEditorTabToTabs)

-- |
-- >>> extract editorTabConfig
-- "Editor: Spaces"
editorTabConfig :: TabBasedState
editorTabConfig = runAction towardsUsingTabs copilotTabConfig

-- |
-- >>> extract usingTabs
-- "Editor: Spaces"
usingTabs :: TabBasedState
usingTabs = runAction towardsUsingTabs copilotTabConfig

--------------------------------------------------------------------------------

data Day f g a where
  Day :: (x -> y -> a) -> f x -> g y -> Day f g a

deriving instance Functor (Day f g)

instance (Comonad f, Comonad g) => Comonad (Day f g) where
  extract (Day xy2a fx gy)
    = xy2a (extract fx) (extract gy)
  duplicate (Day xy2a fx gy)
    = Day (Day xy2a)
        (duplicate fx)
        (duplicate gy)

data CopilotSectionF a = InCopilotSection
  { setCopilotSectionToClaude :: a
  , setCopilotSectionToCodex  :: a
  }
  deriving Functor

data EditorSectionF a = InEditorSection
  { setEditorSectionToSpaces :: a
  , setEditorSectionToTabs   :: a
  }
  deriving Functor

type SectionBasedConfigF = Day (Cofree CopilotSectionF) (Cofree EditorSectionF)
type SectionBasedState = SectionBasedConfigF String
type SectionBasedAction = Action SectionBasedConfigF

-- |
-- >>> extract sectionBasedConfig
-- "Claude | Spaces"
sectionBasedConfig :: SectionBasedState
sectionBasedConfig = toSectionBasedState Claude Spaces
  where
    toSectionBasedState :: CopilotConfig -> EditorConfig -> SectionBasedState
    toSectionBasedState copilotCfg editorCfg
      = Day
          renderSectionBasedConfig
          (toCopilotSectionF copilotCfg)
          (toEditorSectionF editorCfg)

    toCopilotSectionF :: CopilotConfig -> Cofree CopilotSectionF CopilotConfig
    toCopilotSectionF cfg
      = Cofree cfg
      $ InCopilotSection
        { setCopilotSectionToClaude = toCopilotSectionF Claude
        , setCopilotSectionToCodex  = toCopilotSectionF Codex
        }

    toEditorSectionF :: EditorConfig -> Cofree EditorSectionF EditorConfig
    toEditorSectionF cfg
      = Cofree cfg
      $ InEditorSection
        { setEditorSectionToSpaces = toEditorSectionF Spaces
        , setEditorSectionToTabs   = toEditorSectionF Tabs
        }

directlyUseTabs :: SectionBasedAction
directlyUseTabs = mkAction $ \(Day xy2a
                                   (Cofree copilotSection _inCopilotSection)
                                   (Cofree _editorSection inEditorSection))
  -> let x = copilotSection
  in let y = extract $ inEditorSection.setEditorSectionToTabs
  in xy2a x y

mkSndAction
  :: forall f g. Comonad f
  => (forall y. g y -> y)
  -> Action (Day f g)
mkSndAction gy2y = mkAction $ \(Day xy2a cofreeFX cofreeGY)
  -> let x = extract cofreeFX
  in let y = gy2y cofreeGY
  in xy2a x y

-- |
-- >>> extract usingTabsAgain
-- "Claude | Tabs"
usingTabsAgain :: SectionBasedState
usingTabsAgain = runAction directlyUseTabs sectionBasedConfig