flare-freeap.purs

module Test.Main where

import Prelude

import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)

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 hiding (foldp)
import qualified Signal as S
import Signal.Channel

import Unsafe.Coerce (unsafeCoerce)

-- 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 cSelect :: forall a. (a -> String) -> Array a -> CreateComponent a

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
               | CompSelect Label (forall a. a) (forall a. Array a) (forall a. a -> String)

data Cell a = Cell (Array Component) a
            | Wrap (Signal a)
            | Lift (forall e. Eff (chan :: Chan, dom :: DOM | e) (Signal a))
            | Foldp (forall b. b -> a -> a) a (forall b. Field b)

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)

select :: forall a. (Show a) => Label -> a -> Array a -> Field a
select label default xs =
  liftFreeAp (Cell [CompSelect label
                               (unsafeCoerce default)
                               (unsafeCoerce xs)
                               (\a -> show ((unsafeCoerce a) :: a))] default)

wrap :: forall a. Signal a -> Field a
wrap sig = liftFreeAp (Wrap sig)

lift :: forall e a. Eff (chan :: Chan, dom :: DOM | e) (Signal a) -> Field a
lift msig = liftFreeAp (Lift (unsafeInterleaveEff msig))

foldp :: forall a b. (a -> b -> b) -> b -> Field a -> Field b
foldp f x0 fa = liftFreeAp (Foldp (unsafeCoerce f) x0 (unsafeCoerce fa))

cellToUI :: forall e. NaturalTransformation Cell (UI e)
cellToUI (Wrap sig) = UI $ pure (Flare [] sig)
cellToUI (Lift msig) = UI $ Flare [] <$> msig
cellToUI (Foldp f x0 fa) = UI $ do
  (Flare comp sig) <- case foldFreeAp cellToUI fa of UI setup -> setup
  return (Flare comp (S.foldp f x0 sig))
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
toElement send (CompSelect label default xs toString) = cSelect toString xs 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 :: Eff (dom :: DOM, chan :: Chan) Unit
main =
  runFlare "controls" "output" $
    pow <$> number "Base" 2.0
        <*> number "Exponent" 10.0