Generic.hs

{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
module Graphics.UI.Threepenny.Editors.Generic where

import Data.Profunctor
import Data.Proxy
import Generics.SOP
import Graphics.UI.Threepenny.Core
import Graphics.UI.Threepenny.Editors.Profunctor

genericEditor
  :: forall a .
     (Generic a, HasDatatypeInfo a, All2 Editable (Code a))
  => EditorFactory a a
genericEditor = dimap from to $ genericEditor' (datatypeInfo(Proxy @ a))

genericEditor' :: (All2 Editable xx) => DatatypeInfo xx -> EditorFactory (SOP I xx) (SOP I xx)
genericEditor' (ADT _ _ (c :* Nil)) = dimap (unZ . unSOP) (SOP . Z) $ snd $ constructorEditorFor c
genericEditor' (ADT _ _ cc) = editorSum (_f editors) discriminator where
  editors = hcollapse $ hcliftA p (constructorEditorFor) cc

constructorEditorFor :: All Editable xs => ConstructorInfo xs -> (String, EditorFactory (NP I xs) (NP I xs))
constructorEditorFor (Record name fields) = K $ (name,) $ unVEF $ hsequence $ hliftA VEF $ fieldsEditors (hliftA (K . fieldName) fields)

fieldsEditors :: forall xs . All Editable xs => NP (K String) xs -> NP (EditorFactory (NP I xs)) xs
fieldsEditors = go id sList where
  go :: forall ys. All Editable ys => (forall f . NP f xs -> NP f ys) -> SList ys -> NP (K String) ys -> NP (EditorFactory (NP I xs)) ys
  go _ SNil Nil = Nil
  go f SCons (K fn :* xs) = (field fn (unI . hd . f) editor) :* go (tl . f) sList xs

p :: Proxy Editable
p = Proxy

-- | EditorFactory with an Applicative instance for vertical composition
newtype VEF a b = VEF {unVEF :: EditorFactory a b} deriving (Functor, Profunctor)
instance Applicative (VEF a) where
  pure = error "VEF: pure"
  VEF a <*> VEF b = VEF (a |*| b)