THC inspired HKDs

KindMVC.hs

{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
module Lib
    ( someFunc
    ) where

import           Control.Concurrent               (MVar, newEmptyMVar, putMVar,
                                                   takeMVar, threadDelay)
import           Control.Monad                    (void)
import           Control.Monad.Identity           (Identity (..))
import           Control.Monad.IO.Class           (MonadIO (..))
import           Data.Kind                        (Type)
--import           GHC.Generics                     (Generic)
import           Language.Javascript.JSaddle      (JSM, JSVal, eval, fun,
                                                   function, js, js1, jsg, jss)
import           Language.Javascript.JSaddle.Warp (run)
import           Lens.Micro                       ((^.))


type family ToView v

class Widget m v where
  -- | Create the initial view.
  create  :: m (ToView v)

  -- | Given the view (or view resources) and a value,
  -- update/render the view.
  render  :: ToView v -> v -> m ()

  -- | Destroy the view, removing it from the screen and
  -- releasing the resources.
  destroy :: ToView v -> m ()


-- | A string maintains an object in Javascript
type instance ToView String = JSVal

instance Widget JSM String where
  create = jsg "document" ^. js1 "createTextNode" ""

  render v s = v ^. jss "textContent" s

  destroy _ = return ()


-- | An Int view is the same as String.
type instance ToView Int = ToView String


instance Widget JSM Int where
  create = create @_ @String

  render v i = render @_ @String v (show i)

  destroy = destroy @_ @String



type family HKD f a where
  HKD Identity a = a
  HKD f        a = f a


data PairT f
  = Pair
  { pairTitle :: HKD f String
  , pairCount :: HKD f Int
  }

-- | A PairT view is just a PairT of ToView.
-- This doesn't work, but maybe it's apparent what
-- I want to happen. I'd like ToView to descend into
-- PairT so that it becomes:
--
-- data PairT ToView
--   = Pair
--   { pairTitle :: ToView String
--   , pairCount :: ToView Int
--   }
--
-- Maybe another type constructor and matching
-- entry in HKD?
instance Widget JSM (PairT f) where


someFunc :: IO ()
someFunc = run 8888 $ do
  doc  <- jsg "document"
  body <- doc ^. js "body"
  view :: JSVal <- create @_ @PairT
  void $ body ^. js1 "appendChild" view
  render view (Pair "initial title" "initial count")