Types.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE PatternSynonyms     #-}
{-# LANGUAGE RecursiveDo         #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE ViewPatterns        #-}
{-# OPTIONS_GHC -Wno-name-shadowing     #-}
{-# OPTIONS_GHC -Wno-duplicate-exports  #-}

module Graphics.UI.Threepenny.Editors.Types
  (
  -- * GenericWidgets
    GenericWidget(..)
  , edited
  , contents
  , widgetControl
  , widgetTidings
  -- * Editors
  , Editor(.., Horizontally, horizontally, Vertically, vertically)
  , liftElement
  , dimapE
  , applyE
    -- ** Editor composition
  , (|*|), (|*), (*|)
  , (-*-), (-*), (*-)
  , field
  , fieldLayout
    -- ** Editor constructors
  , editorUnit
  , editorIdentity
  , editorString
  , editorText
  , editorCheckBox
  , editorReadShow
  , editorEnumBounded
  , editorSelection
  , editorSum
  , editorJust
  , EditorCollection(..)
  , editorCollection
  , editorList
  , EditorCollectionConfig(..)
  , defaultEditorCollectionConfig
  -- ** Representation of empty values
  , HasEmpty(..)
  ) where

import           Control.Monad
import           Data.Biapplicative
import           Data.Maybe
import           Data.HasEmpty
import qualified Data.Foldable as F
import           Data.Functor.Compose
import           Data.Functor.Identity
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Profunctor
import           Data.Text (Text)
import qualified Data.Text as Text
import           Graphics.UI.Threepenny.Attributes
import           Graphics.UI.Threepenny.Core           as UI hiding (empty)
import           Graphics.UI.Threepenny.Editors.Layout
import           Graphics.UI.Threepenny.Editors.Utils
import           Graphics.UI.Threepenny.Elements
import           Graphics.UI.Threepenny.Events
import           Graphics.UI.Threepenny.Widgets
import           Text.Read

data GenericWidget control a = GenericWidget
  { widgetTidings :: Tidings a -- ^ The dynamic contents of the widget.
  , widgetControl :: control   -- ^ The actual widget.
  }
  deriving Functor

instance Bifunctor GenericWidget where
  bimap f g (GenericWidget t e) = GenericWidget (g <$> t) (f e)

traverseControl :: Applicative f => (control -> f control') -> GenericWidget control a -> f (GenericWidget control' a)
traverseControl f (GenericWidget t e) = GenericWidget t <$> f e

edited :: GenericWidget el a -> Event a
edited = rumors . widgetTidings

contents :: GenericWidget el a -> Behavior a
contents = facts . widgetTidings

instance Widget el => Widget (GenericWidget el a) where
  getElement = getElement . widgetControl

instance Renderable el => Renderable (GenericWidget el a) where
  render = render . widgetControl

renderEditor :: Renderable w => GenericWidget w a -> UI (GenericWidget Element a)
renderEditor = traverseControl render

-- | An editor for values of type @inner@ inside a datatype @outer@ realized by a @widget@.
--
--   All the three type arguments are functorial, but @outer@ is contravariant, so @Editor@ is a 'Biapplicative' functor and a 'Profunctor' (via 'dimapE').
--
--  'Biapplicative' allows to compose editors on both their @widget@ and @inner@ structure. When @widget@ is monoidal, widget composition is implicit and 'Applicative' suffices.
--
--  'Profunctor' allows to apply an @inner@ editor to an @outer@ datatype.
--
--   Once 'create'd, an 'Editor' yields a tuple of an @widget@ and a @Tidings inner@ which can be integrated in a threepenny app.
--

newtype Editor outer widget inner = Editor {
  create :: Behavior outer -> UI (GenericWidget widget inner)
  }

-- | Lift an HTML element into a vacuous editor.
liftElement :: UI el -> Editor a el ()
liftElement el = Editor $ \_ -> GenericWidget (pure ()) <$> el

bimapEditor :: (el -> el') -> (b -> b') -> Editor a el b -> Editor a el' b'
bimapEditor g h = Editor . fmap (fmap (bimap g h)) . create

dimapE :: (a' -> a) -> (b -> b') -> Editor a el b -> Editor a' el b'
dimapE g h  = unCoer . dimap (fmap g) h . coer
  where
    coer   = Star . (Compose .) . create
    unCoer = Editor . fmap getCompose . runStar

applyE :: (el1 -> el2 -> el) -> Editor in_ el1 (a -> b) -> Editor in_ el2 a -> Editor in_ el b
applyE combineElements a b = Editor $ \s -> do
    a <- create a s
    b <- create b s
    return $ GenericWidget (widgetTidings a <*> widgetTidings b) (widgetControl a `combineElements` widgetControl b)

instance Functor (Editor a el) where
  fmap = dimapE id

instance Bifunctor (Editor a) where
  bimap = bimapEditor

instance Biapplicative (Editor a) where
  bipure w o = Editor $ \_ -> return $ GenericWidget (pure o) w
  (<<*>>) = applyE ($)

instance Monoid el => Applicative (Editor a el) where
  pure = bipure mempty
  (<*>) = applyE mappend

-- | Applicative modifier for vertical composition of editor factories.
--   This can be used in conjunction with ApplicativeDo as:
--
-- > editorPerson = vertically $ do
-- >       firstName <- Vertically $ field "First:" firstName editor
-- >       lastName  <- Vertically $ field "Last:"  lastName editor
-- >       age       <- Vertically $ field "Age:"   age editor
-- >       return Person{..}
--
-- DEPRECATED: Use the 'Vertical' layout builder instead
pattern Vertically :: Editor a Layout b -> Editor a Vertical b
pattern Vertically {vertically} <- (withLayout getVertical -> vertically) where Vertically a = withLayout Vertical a

-- | Applicative modifier for horizontal composition of editor factories.
--   This can be used in conjunction with ApplicativeDo as:
--
-- > editorPerson = horizontally $ do
-- >       firstName <- Horizontally $ field "First:" firstName editor
-- >       lastName  <- Horizontally $ field "Last:"  lastName editor
-- >       age       <- Horizontally $ field "Age:"   age editor
-- >       return Person{..}
--
-- DEPRECATED: Use the 'Horizontal' layout builder instead
pattern Horizontally :: Editor a Layout b -> Editor a Horizontal b
pattern Horizontally {horizontally} <- (withLayout getHorizontal -> horizontally) where Horizontally a = withLayout Horizontal a

infixl 4 |*|, -*-
infixl 5 |*, *|, -*, *-

-- | Apply a layout builder.
withLayout :: (layout -> layout') -> Editor a layout b -> Editor a layout' b
withLayout f = bimap f id

-- | Left-right editor composition
(|*|) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a
a |*| b = withLayout getHorizontal $ withLayout Horizontal a <*> withLayout Horizontal b

-- | Left-right composition of an element with a editor
(*|) :: UI Element -> Editor s Layout a -> Editor s Layout a
e *| a = withLayout getHorizontal $ liftElement(return $ horizontal e) *> withLayout Horizontal a

-- | Left-right composition of an element with a editor
(|*) :: Editor s Layout a -> UI Element -> Editor s Layout a
a |* e = withLayout getHorizontal $ withLayout Horizontal a <* liftElement(return $ horizontal e)

-- | Left-right editor composition
(-*-) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a
a -*- b = withLayout getVertical $ withLayout Vertical a <*> withLayout Vertical b

-- | Left-right composition of an element with a editor
(*-) :: UI Element -> Editor s Layout a -> Editor s Layout a
e *- a = withLayout getVertical $ liftElement(return $ vertical e) *> withLayout Vertical a

-- | Left-right composition of an element with a editor
(-*) :: Editor s Layout a -> UI Element -> Editor s Layout a
a -* e = withLayout getVertical $ withLayout Vertical a <* liftElement(return $ vertical e)

-- | A helper that arranges a label and an editor horizontally,
--   wrapped in the given monoidal layout builder.
fieldLayout :: (Renderable m, Renderable m') => (Layout -> m') -> String -> (out -> inn) -> Editor inn m a -> Editor out m' a
fieldLayout l name f e = withLayout l (string name *| first getLayout (dimapE f id e))

-- | A helper that arranges a label
--   and an editor horizontally.
field :: Renderable m => String -> (out -> inn) -> Editor inn m a -> Editor out Layout a
field name f e = string name *| first getLayout (dimapE f id e)

editorUnit :: Editor b Element b
editorUnit = Editor $ \b -> do
    t <- new
    return $ GenericWidget (tidings b never) t

editorCheckBox :: Editor Bool Element Bool
editorCheckBox = Editor $ \b -> do
    t <- sink checked b $ input # set type_ "checkbox"
    return $ GenericWidget (tidings b $ checkedChange t) t

editorString :: Editor String TextEntry String
editorString = Editor $ \b -> do
    w <- askWindow
    t <- entry b
    liftIOLater $ do
      initialValue <- currentValue b
      _ <- runUI w $ set value initialValue (element t)
      return ()
    return $ GenericWidget (userText t) t

editorText :: Editor Text TextEntry Text
editorText = dimapE Text.unpack Text.pack editorString

editorReadShow :: (Read a, Show a) => Editor (Maybe a) TextEntry (Maybe a)
editorReadShow = Editor $ \b -> do
    e <- create editorString (maybe "" show <$> b)
    let readIt "" = Nothing
        readIt x  = readMaybe x
    let t = tidings b (readIt <$> edited e)
    return $ GenericWidget t (widgetControl e)

-- An editor that presents a choice of values.
editorEnumBounded
  :: (Bounded a, Enum a, Ord a, Show a)
  => Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a)
editorEnumBounded = editorSelection (pure $ enumFrom minBound)

-- | An editor that presents a dynamic choice of values.
editorSelection
  :: Ord a
  => Behavior [a] -> Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a)
editorSelection options display = Editor $ \b -> do
  l <- listBox options b display
  return $ GenericWidget (tidings b (rumors $ userSelection l)) l

-- | Ignores 'Nothing' values and only updates for 'Just' values
editorJust :: Editor (Maybe b) el (Maybe b) -> Editor b el b
editorJust (Editor editor) = Editor $ \b -> do
  e <- editor (Just <$> b)
  let ev = filterJust (edited e)
  return $ GenericWidget (tidings b ev) (widgetControl e)

-- | An editor for union types, built from editors for its constructors.
editorSum
  :: (Ord tag, Show tag, Renderable el)
  => (Layout -> Layout -> Layout) -> [(tag, Editor a el a)] -> (a -> tag) -> Editor a Layout a
editorSum combineLayout options selector = Editor $ \ba -> do
  options <- mapM (\(tag, Editor mk) -> (tag,) <$> (mk ba >>= renderEditor)) options
  let tag = selector <$> ba
  tag' <- calmB tag
  let build a = lookup a options
  -- build a tag selector following the current tag
  l <- listBox (pure $ fmap fst options) (Just <$> tag) (pure (string . show))
  -- a placeholder for the constructor editor
  nestedEditor <-
    new # sink children ((\x -> [maybe (error "editorSum") widgetControl (build x)]) <$> tag')
  --
  let composed = combineLayout (Single (return $ getElement l)) (Single $ return nestedEditor)
  -- the result event fires when any of the nested editors or the tag selector fire.
  let editedEvents = fmap (edited . snd) options
      eTag = filterJust $ rumors (userSelection l)
      taggedOptions = sequenceA [(tag, ) <$> contents e | (tag, e) <- options]
      editedTag = filterJust $ flip lookup <$> taggedOptions <@> eTag
      editedE = head <$> unions (editedTag : editedEvents)
  return $ GenericWidget (tidings ba editedE) composed

editorIdentity :: Editor a el a -> Editor (Identity a) el (Identity a)
editorIdentity = dimapE runIdentity Identity

--------------------------
-- EditorCollection

data EditorCollection k w = EditorCollection
  { selector :: ListBox k
  , add, remove :: Element
  , selected :: w
  }

instance Renderable w => Renderable (EditorCollection k w) where
  render EditorCollection{..} =
    column
    [row [ element selector, element add, element remove]
    ,render selected]

data EditorCollectionConfig k v = EditorCollectionConfig
  { eccNewKey      :: Behavior k                 -- ^ Current value to use for creating a new key
  , eccAfterDelKey :: Behavior (Maybe k)         -- ^ Current value to use if the selected key is deleted
  , eccTemplate    :: v                          -- ^ Value to use for creating new items
  , eccOptions     :: Behavior (Set k)           -- ^ Currently user select able keys
  , eccDisplay     :: Behavior (k -> UI Element) -- ^ How to render a key
  }

defaultEditorCollectionConfig
  :: (Enum k, Ord k, Show k, HasEmpty v)
  => Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v
defaultEditorCollectionConfig db = EditorCollectionConfig
  { eccTemplate = emptyValue
  , eccOptions  = options
  , eccDisplay  = pure (UI.string . show)
  , eccNewKey   = maybe (toEnum 0) succ . Set.lookupMax <$> options
  , eccAfterDelKey = deletedKey <$> (fst <$> db) <*> options
  }
  where
    options = Map.keysSet . snd <$> db

    deletedKey Nothing  _  = Nothing
    deletedKey (Just k) kk = Set.lookupLT k kk `mplus` Set.lookupGT k kk

-- | A barebones editor for collections of editable items.
--   Displays an index selector, add and delete buttons, and an editor for the selected item.
--   Limitations:
--     - Won't work with recursive data structures, due to the lack of FRP switch.
editorCollection
  :: forall k v w.
     (Ord k, Renderable w)
  => (Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v)
  -> Editor v w v
  -> Editor (Maybe k, Map k v) (EditorCollection k w) (Maybe k, Map k v)
editorCollection mkConfig editorOne = Editor $ \(ba :: Behavior (Maybe k, Map k v)) -> mdo
  let EditorCollectionConfig{..} = mkConfig ba
      (selectedKey, db) = (fst <$> ba, snd <$> ba)
  sel  <- create (editorSelection (Set.toList <$> eccOptions) eccDisplay) (fst <$> ba)
  one  <- create editorOne $ (\(k, db) -> fromMaybe eccTemplate (k >>= (`Map.lookup` db))) <$> ba
  addB <- button #+ [string "+"]
  remB <- button #+ [string "-"]
  let insert i = Map.insert i eccTemplate
      editsDb = head <$> unions
                [ replace <$> ba <@> edited one
                , insert  <$> eccNewKey <*> db <@ click addB
                , delete  <$> ba <@ click remB
                ]
      editsKey = head <$> unions
                [ edited sel
                , Just <$> eccNewKey <@ click addB
                , eccAfterDelKey <@ click remB
                ]
      tids = (,) <$> tidings selectedKey editsKey <*> tidings db editsDb
  return $ GenericWidget tids (EditorCollection (widgetControl sel) addB remB (widgetControl one))
 where
   replace (Just i,xx) x = Map.alter (const $ Just x) i xx
   replace (Nothing,x) _ = x
   delete  (Just i,xx)   = Map.delete i xx
   delete  (_,xx)        = xx

-- | A barebones editor for collections of editable items.
--   Displays an index selector, add and delete buttons, and an editor for the selected item.
--   Limitations:
--     - Won't work with recursive data structures, due to the lack of FRP switch.
editorList
  :: (HasEmpty a, Renderable w)
  => Editor a w a -> Editor (Maybe Int, [a]) (EditorCollection Int w) (Maybe Int, [a])
editorList e =
  dimapE (second (Map.fromAscList . zip [0 ..])) (second F.toList) $
  editorCollection config e
  where
    (<&>) = flip (<$>)
    infixl 1 <&>
    config ba =
      (defaultEditorCollectionConfig ba)
      { eccAfterDelKey =
        ba <&> (\(i,m) ->
             i >>= (\i ->
                      if Map.member (i + 1) m
                      then return i
                      else let i' = max 0 (i - 1)
                           in guard(i'>=0) >> return i'))
      }