Widget.hs

#!/usr/bin/env stack
{- stack
  runghc
  --package extensible
  --package lens
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleContexts #-}
import Control.Lens
import Data.Extensible
import Data.Functor.Identity
import Data.Proxy

data Component mod = Component { runComponent :: forall m val. mod m val -> m (val (Component mod)) }
data Widget mods = Widget { runWidget :: Component :* mods }

newtype Value a w = Value { getValue :: a }

instance Functor (Value a) where
  fmap f (Value a) = Value a

baseChange :: Value a w -> Value a z
baseChange (Value a) = Value a


-- examples

data HasCharacter m (val :: * -> *) where
  SetName :: String -> HasCharacter Identity Identity
  PrintName :: HasCharacter IO (Value ())

data HasPosition m (val :: * -> *) where
  Walk :: Int -> HasPosition Identity Identity
  PrintPosition :: HasPosition IO (Value ())

charas :: Widget '[HasCharacter, HasPosition]
charas = Widget $ pchar "default" <: ppos 0 <: nil where
  pchar :: String -> Component HasCharacter
  pchar s = Component $ \t -> case t of
    SetName n -> Identity $ Identity $ pchar n
    PrintName -> print s >> return (Value ())

  ppos :: Int -> Component HasPosition
  ppos n = Component $ \t -> case t of
    Walk m -> Identity $ Identity $ ppos (n + m)
    PrintPosition -> print n >> return (Value ())

call :: (Monad m, Functor val) => Member mods op => Widget mods -> op m val -> m (val (Widget mods))
call w op = fmap (\t -> Widget $ runWidget w & piece .~ t) <$> runComponent (runWidget w ^. piece) op

class Printer p where
  printer :: p IO (Value ())

instance Printer HasCharacter where
  printer = PrintName

instance Printer HasPosition where
  printer = PrintPosition

op'print :: (Forall Printer mods) => Widget mods -> IO (Value () (Widget mods))
op'print w = fmap (\_ -> Value ()) $ hgenerateFor (Proxy :: Proxy Printer) (\mem -> baseChange <$> runComponent ((runWidget w) ^. pieceAt mem) printer)

main = do
  let w = charas
  op'print w

  let Identity (Identity w') = w `call` SetName "piyo"
  op'print w'
  
  let Identity (Identity w'') = w' `call` Walk 10
  op'print w''