flare-freeap.purs

module Main where

import Prelude

import Data.Array (reverse)
import Data.Foldable (traverse_)
import Data.Monoid
import Data.Traversable (traverse)

import Control.Applicative.Free
import Control.Apply
import Control.Monad.Eff

import DOM
import Math
import Signal
import Signal.Channel

-- A simplified version of the current Flare API

type ElementId = String

type Label = String

type EventHandler a = a -> Eff (chan :: Chan) Unit

foreign import data Element :: *

foreign import appendComponent :: forall e. ElementId
                               -> Element -> Eff (dom :: DOM | e) Unit

type CreateComponent a = forall e b. Label
                         -> a
                         -> EventHandler b
                         -> Eff (dom :: DOM, chan :: Chan | e) Element

foreign import cNumber :: CreateComponent Number

foreign import cString :: CreateComponent String

foreign import renderString :: forall e. ElementId
                            -> String
                            -> Eff (dom :: DOM | e) Unit

data Flare a = Flare (Array Element) (Signal a)

instance functorFlare :: Functor Flare where
  map f (Flare cs sig) = Flare cs (map f sig)

instance applyFlare :: Apply Flare where
  apply (Flare cs1 sig1) (Flare cs2 sig2) = Flare (cs1 <> cs2) (sig1 <*> sig2)

instance applicativeFlare :: Applicative Flare where
  pure x = Flare mempty (pure x)

newtype UI e a = UI (Eff (dom :: DOM, chan :: Chan | e) (Flare a))

instance functorUI :: Functor (UI e) where
  map f (UI a) = UI $ map (map f) a

instance applyUI :: Apply (UI e) where
  apply (UI a1) (UI a2) = UI $ lift2 apply a1 a2

instance applicativeUI :: Applicative (UI e) where
  pure x = UI $ return (pure x)

-- my attempt to build a free applicative interface on top of this:

data Component = CompNumber Label Number
               | CompString Label String

data Cell a = Cell (Array Component) a

type Field = FreeAp Cell

number :: Label -> Number -> Field Number
number label default = liftFreeAp (Cell [CompNumber label default] default)

string :: Label -> String -> Field String
string label default = liftFreeAp (Cell [CompString label default] default)

cellToUI :: forall e. NaturalTransformation Cell (UI e)
cellToUI (Cell components x) = UI $ do
  chan <- channel x
  elements <- traverse (toElement (send chan)) components
  return (Flare elements (subscribe chan))

toElement :: forall a e. EventHandler a
          -> Component
          -> Eff (dom :: DOM, chan :: Chan | e) Element
toElement send (CompNumber label default) = cNumber label default send
toElement send (CompString label default) = cString label default send

runFlare :: forall e a. (Show a)
         => ElementId
         -> ElementId
         -> Field a
         -> Eff (chan :: Chan, dom :: DOM | e) Unit
runFlare controls target field =
  case foldFreeAp cellToUI field of
    (UI setup) -> do
      (Flare els sig) <- setup
      traverse_ (appendComponent controls) (reverse els)
      runSignal (map (show >>> renderString target) sig)

main =
  runFlare "controls" "output" $
    pow <$> number "Base" 2.0
        <*> number "Exponent" 10.0