Begin work on a more rigorous layer definition

module Genetics.Browser.Track
       ( class TrackRecord
       , buildTrack
       , makeTrack
       , TrackConfigRecord
       , class TrackConfig
       , makeContainersImpl
       , makeContainers
       , class TrackData
       , fetchDataImpl
       , fetchData
       , class CombineFuns
       , combineFunsImpl
       , combineFuns
       ) where

import Prelude

import Data.Foldable (foldMap)
import Data.Maybe (Maybe)
import Data.Pair (Pair)
import Effect (Effect)
import Effect.Aff (Aff)
import Genetics.Browser.Canvas (TrackContainer, trackContainer, withLoadingIndicator)
import Genetics.Browser.Coordinates (CoordSysView)
import Genetics.Browser.Layer (TrackPadding)
import Genetics.Browser.Types (Point)
import Prim.Boolean (False, True, kind Boolean)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Record (delete, get, insert)
import Type.Data.Boolean as Boolean
import Type.Data.Symbol as Symbol
import Type.Prelude (class IsSymbol, class TypeEquals, Proxy(..), RLProxy(..), RProxy(..), SProxy(..), from)
import Unsafe.Coerce (unsafeCoerce)

type TrackInterface a =
  { render   :: Pair Number -> CoordSysView -> Aff Unit
  , hotspots :: Aff (Number -> Point -> Array a) }

class TrackRecord
      (trackList :: RowList)
      (trackRow :: # Type)
      a
      | trackList -> trackRow
      , trackList -> a where
  buildTrack :: RLProxy trackList
             -> Record trackRow
             -> TrackContainer
             -> Aff { render   :: Pair Number -> CoordSysView -> Aff Unit
                    , hotspots :: Aff (Number -> Point -> Array a) }

instance trackRecordRender ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Pair Number -> CoordSysView -> Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Pair Number -> CoordSysView -> Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer p c = (get name r) p c

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordUI ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer _ _ = (get name r)

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordHotspots ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff (Number -> pt -> Array a)) trackRow' trackRow
  , TypeEquals pt Point
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff (Number -> pt -> Array a)) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let hotspots = ado
          h  <- get name r
          h' <- rest.hotspots
          in \rad p -> h rad (from p) <> h' rad p

    pure { render: rest.render, hotspots }

instance trackRecordNil ::
  ( TypeEquals (Record trackRow) {}
  ) => TrackRecord Nil trackRow a where
  buildTrack _ _ _ = mempty

makeTrack :: ∀ row list a.
             RowToList row list
          => TrackRecord list row a
          => Record row
          -> TrackContainer
          -> Aff (TrackInterface a)
makeTrack r c = buildTrack (RLProxy :: RLProxy list) r c

type TrackConfigRecord r =
  { trackHeight :: Number
  , padding :: TrackPadding | r }

class TrackConfig
  (confList :: RowList)
  (confRow  :: # Type)
  (trackRow :: # Type)
  | confList -> confRow trackRow
  where
  makeContainersImpl :: RLProxy confList
                     -> Number
                     -> Record confRow
                     -> Effect (Record trackRow)

instance trackConfigNil ::
  ( TypeEquals (Record tr) {}
  ) => TrackConfig Nil cr tr where
  makeContainersImpl _ _ _ = pure $ from {}

instance trackConfigCons ::
  ( IsSymbol name
  , TrackConfig tail confRow' trackRow'
  , Row.Cons name c confRow' confRow
  , Row.Lacks name confRow'
  , Row.Cons name TrackContainer trackRow' trackRow
  , Row.Lacks name trackRow'
  , TypeEquals (TrackConfigRecord we) c
  ) => TrackConfig (Cons name c tail) confRow trackRow where
  makeContainersImpl _ width r = do
    let n = SProxy :: SProxy name

        c :: TrackConfigRecord we
        c = from $ get n r

    cont <- trackContainer
              {width, height: c.trackHeight}
              c.padding
              (Symbol.reflectSymbol n)

    rest <- makeContainersImpl
              (RLProxy :: RLProxy tail)
              width
              (delete n $ from r)

    pure $ insert n cont rest

makeContainers :: ∀ cl cr tr.
                  RowToList cr cl
               => TrackConfig cl cr tr
               => Number
               -> Record cr
               -> Effect (Record tr)
makeContainers = makeContainersImpl (RLProxy :: RLProxy cl)

class TrackData
      (fetcherList :: RowList)
      (fetcherRow :: # Type)
      (urlRow :: # Type)
      (dataRow :: # Type)
      | fetcherList -> fetcherRow
      , fetcherList -> urlRow
      , fetcherList -> dataRow where
  fetchDataImpl :: RLProxy fetcherList
            -> Record fetcherRow
            -> Record urlRow
            -> Aff (Record dataRow)

instance trackDataCons ::
  ( IsSymbol  name
  , Row.Lacks name fetcherRow'
  , Row.Cons  name (String -> Aff x) fetcherRow' fetcherRow
  , Monoid x
  , Row.Cons  name (Maybe String) urlRow' urlRow
  , Row.Lacks name dataRow'
  , Row.Cons  name x dataRow' dataRow
  , TrackData fetcherTail fetcherRow' urlRow dataRow'
  ) => TrackData (Cons name (String -> Aff x) fetcherTail)
                 fetcherRow
                 urlRow
                 dataRow where
  fetchDataImpl _ fetchers urls = do
    let name = SProxy :: _ name

    rest <- fetchDataImpl (RLProxy :: _ fetcherTail)
                          (delete name fetchers)
                          urls

    dataset <- foldMap (get name fetchers) (get name urls)

    pure $ insert name dataset rest

instance trackDataNil ::
  ( TypeEquals (Record dataRow) {}
  ) => TrackData Nil () urlRow dataRow where
  fetchDataImpl _ _ _ = pure $ from {}

-- | `fetchData` puts a loading indicator in the provided TrackContainer,
-- | fetches the data in the provided `urlRow` record, and parses it
-- | using the parsers in the provided `parserRow` record.
fetchData :: ∀ fetcherRow fetcherList urlRow urlList dataRow.
             RowToList fetcherRow fetcherList
          => RowToList urlRow urlList
          => TrackData fetcherList fetcherRow urlRow dataRow
          => TrackContainer
          -> Record fetcherRow
          -> Record urlRow
          -> Aff (Record dataRow)
fetchData tc fs urls = withLoadingIndicator tc
                       $ fetchDataImpl (RLProxy :: _ fetcherList)
                                       fs
                                       urls

-- | Combine a record of functions from records,
-- | into a function from a record of their union,
-- | to a record of their outputs.
-- | E.g. `{f :: Record r1 -> a, g :: Record r2 -> b}`
-- | into `Record (r1 + r2) -> { f :: a, g :: b }`
class CombineFuns
  (funsList :: RowList)
  (funsRow :: # Type)
  (argRow :: # Type)
  (outRow :: # Type)
  | funsList -> funsRow
  , funsList -> argRow
  , funsList -> outRow where
  combineFunsImpl :: RLProxy funsList
              -> Record funsRow
              -> Record argRow
              -> Record outRow

instance combineFunCons ::
  ( IsSymbol  name
  , Row.Lacks name funsRow'
  , Row.Cons  name (Record r -> a) funsRow' funsRow
  , Row.Union argRow' r argRowUnion
  , Row.Nub   argRowUnion argRowNubbed
  , Row.Lacks name outRow'
  , Row.Cons  name a outRow' outRow
  , CombineFuns funsTail funsRow' argRow' outRow'
  ) => CombineFuns (Cons name (Record r -> a) funsTail)
                  funsRow
                  argRowNubbed
                  outRow where
  combineFunsImpl _ funs args =
    let name = SProxy :: _ name

        thoseArgs :: Record argRow'
        thoseArgs = unsafeCoerce args

        theseArgs :: Record r
        theseArgs = unsafeCoerce args

        rest = combineFunsImpl (RLProxy :: _ funsTail)
                               (delete name funs)
                               thoseArgs
        fn = (get name funs)

    in (insert name (fn theseArgs) rest)

instance combineFunNil ::
  ( TypeEquals (Record outRow) {}
  ) => CombineFuns Nil () () outRow where
  combineFunsImpl _ _ _ = from {}

-- | Note! this isn't actually type safe yet.
-- | If two functions use arguments with the same label
-- | but different types, things break...
combineFuns :: ∀ funsList funsRow argRow outRow.
               RowToList funsRow funsList
            => CombineFuns funsList funsRow argRow outRow
            => Record funsRow
            -> Record argRow
            -> Record outRow
combineFuns funs args = combineFunsImpl (RLProxy :: _ funsList) funs args

class BuildLayers
  (layers :: # Type)
  (output :: # Type)
  | layers -> output

class GetBrowserConfig
  (totalConfig :: # Type)
  (browser :: # Type)
  | totalConfig -> browser where
    getBrowserConfigImpl :: Record totalConfig
                         -> Record browser

instance getBrowserConfig ::
  ( IsSymbol sBrowser
  , TypeEquals (SProxy sBrowser) (SProxy "browser")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")

  , Row.Cons sBrowser (Record browser') totalConfig' totalConfig
  , Row.Lacks sBrowser totalConfig'

  , Row.Cons sLayers layers browser browser'
  , Row.Lacks sLayers browser
  ) => GetBrowserConfig totalConfig browser where
  getBrowserConfigImpl total =
    let browser' :: Record browser'
        browser' = get (from (SProxy :: _ "browser")) total
    in delete (from (SProxy :: _ "layers")) browser'

class GetTrackConfig
  (totalConfig :: # Type)
  (track :: # Type)
  (trackName :: Symbol)
  | totalConfig trackName -> track where
    getTrackConfigImpl :: Record totalConfig
                       -> SProxy trackName
                       -> Record track

instance getTrackConfig ::
  ( IsSymbol sTracks
  , TypeEquals (SProxy sTracks) (SProxy "tracks")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")
  , IsSymbol trackName

  , Row.Cons sTracks (Record tracks) totalConfig' totalConfig
  , Row.Lacks sTracks totalConfig'

  , Row.Cons trackName (Record thisTrack') tracks' tracks
  , Row.Lacks trackName tracks'

  , Row.Cons sLayers layers thisTrack thisTrack'
  , Row.Lacks sLayers thisTrack

  ) => GetTrackConfig totalConfig thisTrack trackName where
    getTrackConfigImpl total _ =
      let tracks' :: Record tracks
          tracks' = get (from (SProxy :: _ "tracks")) total

          thisTrack :: Record thisTrack'
          thisTrack = get (from (SProxy :: _ trackName)) tracks'

      in delete (from (SProxy :: _ "layers")) thisTrack

class GetLayerConfig
  (totalConfig :: # Type)
  (layer :: # Type)
  (trackName :: Symbol)
  (layerName :: Symbol)
  | totalConfig trackName layerName -> layer where
    getLayerConfigImpl :: Record totalConfig
                       -> SProxy trackName
                       -> SProxy layerName
                       -> Record layer

instance getLayerConfig ::
  ( IsSymbol sTracks
  , TypeEquals (SProxy sTracks) (SProxy "tracks")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")
  , IsSymbol trackName
  , IsSymbol layerName

  , Row.Cons sTracks (Record tracks) totalConfig' totalConfig
  , Row.Lacks sTracks totalConfig'

  , Row.Cons trackName (Record thisTrack) tracks' tracks
  , Row.Lacks trackName tracks'

  , Row.Cons sLayers (Record layers) thisTrack' thisTrack
  , Row.Lacks sLayers thisTrack

  , Row.Cons layerName (Record thisLayer) layers' layers
  , Row.Lacks layerName layers'
  ) => GetLayerConfig totalConfig thisLayer trackName layerName where
    getLayerConfigImpl total _ _ =
      let tracks' :: Record tracks
          tracks' = get (from (SProxy :: _ "tracks")) total

          thisTrack :: Record thisTrack
          thisTrack = get (from (SProxy :: _ trackName)) tracks'

          layers :: Record layers
          layers = get (from (SProxy :: _ "layers")) thisTrack

      in get (from (SProxy :: _ layerName)) layers

newtype LayerDef browser track layer a
  = LayerDef ({ browserConfig :: Record browser
              , trackConfig :: Record track
              , layerConfig :: Record layer }
              -> a)

class ApplyLayerDef
  (browser :: # Type)
  (track :: # Type)
  (layer :: # Type)
  (totalConfig :: # Type)
  (trackName :: Symbol)
  (layerName :: Symbol)
  a
  | trackName layerName totalConfig -> track layer where
    applyLayerDefImpl :: LayerDef browser track layer a
                      -> SProxy trackName
                      -> SProxy layerName
                      -> Record totalConfig
                      -> a

instance applyLayerDefInst ::
  ( IsSymbol trackName
  , IsSymbol layerName
  , GetBrowserConfig totalConfig browser
  , GetTrackConfig totalConfig track trackName
  , GetLayerConfig totalConfig layer trackName layerName
  ) => ApplyLayerDef browser track layer totalConfig trackName layerName a where
    applyLayerDefImpl (LayerDef f) trackName layerName total =
      let browserConfig = getBrowserConfigImpl total
          trackConfig = getTrackConfigImpl total trackName
          layerConfig = getLayerConfigImpl total trackName layerName
      in f { browserConfig, trackConfig, layerConfig }

applyLayerDef :: ∀ browser track layer trackName layerName config a.
                 IsSymbol trackName
              => IsSymbol layerName
              => ApplyLayerDef browser track layer config trackName layerName a
              => LayerDef browser track layer a
              -> SProxy trackName
              -> SProxy layerName
              -> Record config
              -> a
applyLayerDef = applyLayerDefImpl

module Genetics.Browser.Track
       ( class TrackRecord
       , buildTrack
       , makeTrack
       , TrackConfigRecord
       , class TrackConfig
       , makeContainersImpl
       , makeContainers
       , class TrackData
       , fetchDataImpl
       , fetchData
       , class CombineFuns
       , combineFunsImpl
       , combineFuns
       ) where

import Prelude

import Data.Foldable (foldMap)
import Data.Maybe (Maybe)
import Data.Pair (Pair)
import Effect (Effect)
import Effect.Aff (Aff)
import Genetics.Browser.Canvas (TrackContainer, trackContainer, withLoadingIndicator)
import Genetics.Browser.Coordinates (CoordSysView)
import Genetics.Browser.Layer (TrackPadding)
import Genetics.Browser.Types (Point)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Record (delete, get, insert)
import Type.Data.Symbol as Symbol
import Type.Prelude (class IsSymbol, class TypeEquals, RLProxy(..), SProxy(..), from)
import Unsafe.Coerce (unsafeCoerce)

type TrackInterface a =
  { render   :: Pair Number -> CoordSysView -> Aff Unit
  , hotspots :: Aff (Number -> Point -> Array a) }

class TrackRecord
      (trackList :: RowList)
      (trackRow :: # Type)
      a
      | trackList -> trackRow
      , trackList -> a where
  buildTrack :: RLProxy trackList
             -> Record trackRow
             -> TrackContainer
             -> Aff { render   :: Pair Number -> CoordSysView -> Aff Unit
                    , hotspots :: Aff (Number -> Point -> Array a) }

instance trackRecordRender ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Pair Number -> CoordSysView -> Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Pair Number -> CoordSysView -> Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer p c = (get name r) p c

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordUI ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer _ _ = (get name r)

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordHotspots ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff (Number -> pt -> Array a)) trackRow' trackRow
  , TypeEquals pt Point
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff (Number -> pt -> Array a)) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let hotspots = ado
          h  <- get name r
          h' <- rest.hotspots
          in \rad p -> h rad (from p) <> h' rad p

    pure { render: rest.render, hotspots }

instance trackRecordNil ::
  ( TypeEquals (Record trackRow) {}
  ) => TrackRecord Nil trackRow a where
  buildTrack _ _ _ = mempty

makeTrack :: ∀ row list a.
             RowToList row list
          => TrackRecord list row a
          => Record row
          -> TrackContainer
          -> Aff (TrackInterface a)
makeTrack r c = buildTrack (RLProxy :: RLProxy list) r c

type TrackConfigRecord r =
  { trackHeight :: Number
  , padding :: TrackPadding | r }

class TrackConfig
  (confList :: RowList)
  (confRow  :: # Type)
  (trackRow :: # Type)
  | confList -> confRow trackRow
  where
  makeContainersImpl :: RLProxy confList
                     -> Number
                     -> Record confRow
                     -> Effect (Record trackRow)

instance trackConfigNil ::
  ( TypeEquals (Record tr) {}
  ) => TrackConfig Nil cr tr where
  makeContainersImpl _ _ _ = pure $ from {}

instance trackConfigCons ::
  ( IsSymbol name
  , TrackConfig tail confRow' trackRow'
  , Row.Cons name c confRow' confRow
  , Row.Lacks name confRow'
  , Row.Cons name TrackContainer trackRow' trackRow
  , Row.Lacks name trackRow'
  , TypeEquals (TrackConfigRecord we) c
  ) => TrackConfig (Cons name c tail) confRow trackRow where
  makeContainersImpl _ width r = do
    let n = SProxy :: SProxy name

        c :: TrackConfigRecord we
        c = from $ get n r

    cont <- trackContainer
              {width, height: c.trackHeight}
              c.padding
              (Symbol.reflectSymbol n)

    rest <- makeContainersImpl
              (RLProxy :: RLProxy tail)
              width
              (delete n $ from r)

    pure $ insert n cont rest

makeContainers :: ∀ cl cr tr.
                  RowToList cr cl
               => TrackConfig cl cr tr
               => Number
               -> Record cr
               -> Effect (Record tr)
makeContainers = makeContainersImpl (RLProxy :: RLProxy cl)

class TrackData
      (fetcherList :: RowList)
      (fetcherRow :: # Type)
      (urlRow :: # Type)
      (dataRow :: # Type)
      | fetcherList -> fetcherRow
      , fetcherList -> urlRow
      , fetcherList -> dataRow where
  fetchDataImpl :: RLProxy fetcherList
            -> Record fetcherRow
            -> Record urlRow
            -> Aff (Record dataRow)

instance trackDataCons ::
  ( IsSymbol  name
  , Row.Lacks name fetcherRow'
  , Row.Cons  name (String -> Aff x) fetcherRow' fetcherRow
  , Monoid x
  , Row.Cons  name (Maybe String) urlRow' urlRow
  , Row.Lacks name dataRow'
  , Row.Cons  name x dataRow' dataRow
  , TrackData fetcherTail fetcherRow' urlRow dataRow'
  ) => TrackData (Cons name (String -> Aff x) fetcherTail)
                 fetcherRow
                 urlRow
                 dataRow where
  fetchDataImpl _ fetchers urls = do
    let name = SProxy :: _ name

    rest <- fetchDataImpl (RLProxy :: _ fetcherTail)
                          (delete name fetchers)
                          urls

    dataset <- foldMap (get name fetchers) (get name urls)

    pure $ insert name dataset rest

instance trackDataNil ::
  ( TypeEquals (Record dataRow) {}
  ) => TrackData Nil () urlRow dataRow where
  fetchDataImpl _ _ _ = pure $ from {}

-- | `fetchData` puts a loading indicator in the provided TrackContainer,
-- | fetches the data in the provided `urlRow` record, and parses it
-- | using the parsers in the provided `parserRow` record.
fetchData :: ∀ fetcherRow fetcherList urlRow urlList dataRow.
             RowToList fetcherRow fetcherList
          => RowToList urlRow urlList
          => TrackData fetcherList fetcherRow urlRow dataRow
          => TrackContainer
          -> Record fetcherRow
          -> Record urlRow
          -> Aff (Record dataRow)
fetchData tc fs urls = withLoadingIndicator tc
                       $ fetchDataImpl (RLProxy :: _ fetcherList)
                                       fs
                                       urls

-- | Combine a record of functions from records,
-- | into a function from a record of their union,
-- | to a record of their outputs.
-- | E.g. `{f :: Record r1 -> a, g :: Record r2 -> b}`
-- | into `Record (r1 + r2) -> { f :: a, g :: b }`
class CombineFuns
  (funsList :: RowList)
  (funsRow :: # Type)
  (argRow :: # Type)
  (outRow :: # Type)
  | funsList -> funsRow
  , funsList -> argRow
  , funsList -> outRow where
  combineFunsImpl :: RLProxy funsList
              -> Record funsRow
              -> Record argRow
              -> Record outRow

instance combineFunCons ::
  ( IsSymbol  name
  , Row.Lacks name funsRow'
  , Row.Cons  name (Record r -> a) funsRow' funsRow
  , Row.Union argRow' r argRowUnion
  , Row.Nub   argRowUnion argRowNubbed
  , Row.Lacks name outRow'
  , Row.Cons  name a outRow' outRow
  , CombineFuns funsTail funsRow' argRow' outRow'
  ) => CombineFuns (Cons name (Record r -> a) funsTail)
                  funsRow
                  argRowNubbed
                  outRow where
  combineFunsImpl _ funs args =
    let name = SProxy :: _ name

        thoseArgs :: Record argRow'
        thoseArgs = unsafeCoerce args

        theseArgs :: Record r
        theseArgs = unsafeCoerce args

        rest = combineFunsImpl (RLProxy :: _ funsTail)
                               (delete name funs)
                               thoseArgs
        fn = (get name funs)

    in (insert name (fn theseArgs) rest)

instance combineFunNil ::
  ( TypeEquals (Record outRow) {}
  ) => CombineFuns Nil () () outRow where
  combineFunsImpl _ _ _ = from {}

-- | Note! this isn't actually type safe yet.
-- | If two functions use arguments with the same label
-- | but different types, things break...
combineFuns :: ∀ funsList funsRow argRow outRow.
               RowToList funsRow funsList
            => CombineFuns funsList funsRow argRow outRow
            => Record funsRow
            -> Record argRow
            -> Record outRow
combineFuns funs args = combineFunsImpl (RLProxy :: _ funsList) funs args


update.

update.

module ToneDeaf where

import Data.Functor
import Data.Maybe
import Data.String
import Prelude

import Audio.WebAudio.AudioParam (getValue, setValue, setValueAtTime)
import Audio.WebAudio.BaseAudioContext (createGain, createOscillator, currentTime, destination, newAudioContext, resume, state, suspend)
import Audio.WebAudio.GainNode (gain)
import Audio.WebAudio.Oscillator (OscillatorType(..), frequency, setOscillatorType, startOscillator, stopOscillator)
import Audio.WebAudio.Types (AudioContext, GainNode, OscillatorNode, AudioContextState(..), connect)
import Control.Coroutine (Producer, Consumer, runProcess, pullFrom, await)
import Control.Coroutine.Aff (produce')
import Data.Array (filter, (..))
import Data.Newtype (wrap)
import Effect (Effect)
import Effect.Console (log)
import Web.DOM.Element (toEventTarget)
import Web.DOM.ParentNode (querySelector)
import Web.Event.CustomEvent ( CustomEvent)
import Web.Event.Event (EventType(..), Event)
import Web.Event.EventTarget (EventTarget, addEventListener, dispatchEvent, eventListener)
import Web.HTML (window)
import Web.HTML.HTMLDocument (toParentNode, toDocument)
import Web.HTML.HTMLElement (toElement, fromElement, className, HTMLElement)
import Web.DOM (Element)
import Web.HTML.Window (Window, document)
-- import Web.HTML.Window (Window)
-- import Web.HTML (window)
-- import Web.HTML.HTMLDocument (toParentNode)
-- import Web.HTML.Window (document)
-- import DOM (DOM)
-- import DOM.HTML (window)
-- import DOM.HTML.Types (HTMLElement, htmlElementToElement)
-- import DOM.HTML.Window (requestAnimationFrame)
-- import DOM.HTML.HTMLElement (getBoundingClientRect)
-- import DOM.Node.Types (elementToEventTarget)
-- import DOM.Event.EventTarget (addEventListener, eventListener)
-- import DOM.Event.MouseEvent (MouseEvent, eventToMouseEvent, clientX, clientY)
-- import DOM.Event.Types (Event, EventType(..), EventTarget)

-- import Data.Enum (Bounded)

sampleFreq :: Number
sampleFreq = 440.0

-- chromaticIntervals[0] = 1.000000;
-- chromaticIntervals[1] = 1.059463;
-- chromaticIntervals[2] = 1.122462;
-- chromaticIntervals[3] = 1.189207;
-- chromaticIntervals[4] = 1.259921;
-- chromaticIntervals[5] = 1.334839;
-- chromaticIntervals[6] = 1.414213;
-- chromaticIntervals[7] = 1.498307;
-- chromaticIntervals[8] = 1.587401;
-- chromaticIntervals[9] = 1.681792;
-- chromaticIntervals[10] = 1.781797;
-- chromaticIntervals[11] = 1.887748;

-- chromaticIntervals :: Int -> Number
-- chromaticIntervals 0  = 1.000000
-- chromaticIntervals 1  = 1.059463
-- chromaticIntervals 2  = 1.122462

chromaticMap :: ToneIndex -> Number
chromaticMap Zero  = 1.000000
chromaticMap One  = 1.059463
chromaticMap Two  = 1.122462
chromaticMap Three = 1.189207
chromaticMap Four = 1.259921
chromaticMap Five = 1.334839
chromaticMap Six = 1.414213
chromaticMap Seven = 1.498307
chromaticMap Eight = 1.587401
chromaticMap Nine = 1.681792
chromaticMap Ten = 1.781797
chromaticMap Eleven = 1.887748

chromaticIntervals :: ToneInterval -> Number
chromaticIntervals Tonic  = 1.000000
chromaticIntervals First  = 1.059463
chromaticIntervals Second  = 1.122462
chromaticIntervals MinThird = 1.189207
chromaticIntervals MajThird = 1.259921
chromaticIntervals Fourth = 1.334839
chromaticIntervals Diminished = 1.414213
chromaticIntervals Fifth = 1.498307
chromaticIntervals AugFifth = 1.587401
chromaticIntervals Sixth = 1.681792
chromaticIntervals MinSeventh = 1.781797
chromaticIntervals MajSeventh = 1.887748
-- data ToneInterval = 0 | 1 | 2 deriving (Enum)
-- data ToneInterval = Zero | One | Two deriving (Enum)
data ToneIndex = Zero | One | Two | Three | Four | Five
  | Six | Seven | Eight | Nine | Ten | Eleven

derive instance eqToneIndex :: Eq ToneIndex
derive instance ordToneIndex :: Ord ToneIndex

data ToneInterval = Tonic | First | Second | MinThird | MajThird | Fourth
  | Diminished | Fifth | AugFifth | Sixth | MinSeventh | MajSeventh

derive instance eqToneInterval :: Eq ToneInterval
derive instance ordToneInterval :: Ord ToneInterval
-- derive instance enumToneInterval :: Bounded ToneInterval

-- derive instance ti :: Enum
-- type ToneInterval = "abc" | "def"

-- data ModuleType2
--   = Regular
--   | Foreign
  -- deriving (Show, Eq, Ord)
beep :: Number -> Effect Unit
beep freq = do
  ctx <- newAudioContext
  osc <- createOscillator ctx
  setOscillatorType Sine osc
  log "ToneDeaf: now calling startOscillator"
  startOscillator 0.0 osc
  setValue freq =<< frequency osc
  connect osc =<< destination ctx
  stopOscillator 0.5 osc
  pure unit

-- getBtn :: String -> Effect Unit
getBtn ::  Effect Unit
getBtn = do
  log "ToneDeaf: now in getBtn"
  doc <- map toParentNode (window >>= document)
  mbtn <- querySelector (wrap "#btn") doc
  case mbtn of
    Nothing -> log "mbtn failed"
    Just btn -> do
      let mhtmlEl = fromElement btn
      case mhtmlEl of
        Nothing -> log "mhtml failed"
        Just htmlEl -> do
          let cn = className htmlEl
          log $ "classname below:"
          cn >>= log
          -- "cn=" <> cn >>= log
          -- cn  do
          --   log cn
          -- addEventListener :: EventType -> EventListener -> Boolean -> EventTarget -> Effect Unit
          -- addEventListener (EventType "mousedown")
          -- (eventListener (emit <<< Left <<< EMouseMove)) false target
          -- eventListener :: forall a. (Event -> Effect a) -> Effect EventListener
          -- $ (eventListener (btnDownHandler))
          -- (eventListener (emit <<< Left <<< EMouseMove)) false target

          -- method 2
          evtListener <- (eventListener btnHandler2)
          -- addEventListener :: EventType -> EventListener -> Boolean -> EventTarget -> Effect Unit
          addEventListener
            (EventType "mousedown")
            -- (eventListener btnHandler3)
            evtListener
            false
            -- ((elementToEventTarget <<< htmlElementToElement) bodyHtmlElement)
            -- ((elementToEventTarget <<< htmlElementToElement) htmlEl)
            ((toEventTarget <<< toElement) htmlEl)
            -- htmlEl
          -- end method 2
          vtEvtListener <- (eventListener vtEvtHandler)
          addEventListener
            (EventType "vtEvt")
            vtEvtListener
            false
            ((toEventTarget <<< toElement) htmlEl)
          pure unit
      pure unit

  pure unit

-- getClassName :: Maybe HTMLElement -> String
-- getClassName e = map className  (map fromElement e)
-- note: the following actually compiles
-- getClassName e =  (map fromElement e)
-- getClassName e = className (map fromElement e)
-- getClassName Nothing = Nothing
-- getClassName (Just a) = className <*> a
-- getClassName elem = do
--   map className (map fromElement elem)

-- unboxMaybeElement :: Maybe Element -> HTMLElement
-- unboxMaybeElement Nothing = Nothing
-- unboxMaybeElement (Just a) = maybe (Element) (\x -> x) a

-- btnDownHandler :: Event -> Effect Unit
btnDownHandler e = log "btn pressed"

-- btnHandler2 :: forall e. Event -> GameEffect e Unit
-- btnHandler2 :: forall e. Event -> Effect e Unit
btnHandler2 :: Event -> Effect Unit
btnHandler2 e = do
  log "btn2 pressed"
  beep 880.0
  -- dispatchEvent :: Event -> EventTarget -> Effect Boolean
  -- let custEvt = customEvent $ EventType "vtEvt"
  -- TODO: how to create a new Event?
  let custEvt =  EventType "vtEvt"
  dispatchVtEvt custEvt
  -- dispatchVtEvt e
  -- let evtTgt = do
  -- evtTgt <- do
  --   doc <- map toParentNode (window >>= document)
  --   mBodyEl <- querySelector (wrap "body") doc
  --   case mBodyEl of
  --     Nothing -> log "mBodyEl failed"
  --     just bodyEl = pure bodyEl
  --
  -- dispatchEvent custEvt evtTgt
  pure unit

btnHandler3 = 7

vtEvtHandler :: Event -> Effect Unit
vtEvtHandler e = do
  log "vtEvtHandler entered"

-- getBodyEl :: Effect Unit
-- getBodyEl :: Maybe Element
-- getBodyEl = do
--   -- doc <- map toParentNode (window >>= document)
--   let doc = map toParentNode (window >>= document)
--   -- mEl <- querySelector (wrap "body") doc
--   -- mEl <- querySelector (wrap "body") doc
--   -- querySelector (wrap "body")  <<< (map  <<< toParentNode (window >>= document))
--   -- querySelector (wrap "body") $  doc
--   -- let mEl = (doc >>= querySelector (wrap "body"))
--   let mBodyEl = (doc >>= querySelector (wrap "body"))
--   -- pure <<< bodyEl
--   mBodyEl <- do
--     evtTgt <- Just mBodyEl
--     -- pure abc
--     let custEvt = EventType "vtEvt"
--     -- dispatchEvent :: Event -> EventTarget -> Effect Boolean
--     dispatchEvent custEvt evtTgt
--     -- Nothing
--     -- <<< mBodyEl
--     -- mBodyEl >>= HTMLElement
--     -- case mBodyEl of
--     --   Nothing -> Nothing
--     --   just el -> Just el
--   --   -- bodyEl
--   --   pure unit
--   -- pure bodyEl
--
--   -- mEl -> do
--   --   case mEl of
--   --     Nothing -> Nothing
--   --     Just el -> pure el
--   -- pure unit
--   Nothing
  -- Just abc

-- dispatchVtEvt :: Event -> Maybe Element
dispatchVtEvt :: Event -> Effect Unit
dispatchVtEvt e = do
  doc <- map toParentNode (window >>= document)
  mBodyEl <- querySelector (wrap "body") doc
  -- mBodyEl <- do
    -- evtTgt <- Just mBodyEl
    -- let custEvt = EventType "vtEvt"
    -- dispatchEvent :: Event -> EventTarget -> Effect Boolean
    -- dispatchEvent e evtTgt
  case mBodyEl of
    Nothing -> log "mBodyEl is Nothing"
    -- Nothing -> pure unit
    Just bodyEl -> do
      -- let rc = dispatchEvent e (toEventTarget bodyEl)
      rc <- dispatchEvent e (toEventTarget bodyEl)
      -- rc -> do
      case rc of
        false -> log "bad rc"
        -- true -> pure unit
        true -> log "good rc"
      -- result <- do
      -- case mRc of
      --   Nothing -> log "fail"
      --   Just rc ->

  -- Nothing
  pure unit

module ToneDeaf where

import Data.Functor
import Data.Maybe
import Data.String
import Prelude

import Audio.WebAudio.AudioParam (getValue, setValue, setValueAtTime)
import Audio.WebAudio.BaseAudioContext (createGain, createOscillator, currentTime, destination, newAudioContext, resume, state, suspend)
import Audio.WebAudio.GainNode (gain)
import Audio.WebAudio.Oscillator (OscillatorType(..), frequency, setOscillatorType, startOscillator, stopOscillator)
import Audio.WebAudio.Types (AudioContext, GainNode, OscillatorNode, AudioContextState(..), connect)
import Control.Coroutine (Producer, Consumer, runProcess, pullFrom, await)
import Control.Coroutine.Aff (produce')
import Data.Array (filter, (..))
import Data.Newtype (wrap)
import Effect (Effect)
import Effect.Console (log)
import Web.DOM.Element (toEventTarget)
import Web.DOM.ParentNode (querySelector)
import Web.Event.Event (EventType(..), Event)
import Web.Event.EventTarget (EventTarget, addEventListener, eventListener)
import Web.HTML (window)
import Web.HTML.HTMLDocument (toParentNode, toDocument)
import Web.HTML.HTMLElement (toElement, fromElement, className, HTMLElement)
import Web.HTML.Window (Window, document)
-- import Web.HTML.Window (Window)
-- import Web.HTML (window)
-- import Web.HTML.HTMLDocument (toParentNode)
-- import Web.HTML.Window (document)
-- import DOM (DOM)
-- import DOM.HTML (window)
-- import DOM.HTML.Types (HTMLElement, htmlElementToElement)
-- import DOM.HTML.Window (requestAnimationFrame)
-- import DOM.HTML.HTMLElement (getBoundingClientRect)
-- import DOM.Node.Types (elementToEventTarget)
-- import DOM.Event.EventTarget (addEventListener, eventListener)
-- import DOM.Event.MouseEvent (MouseEvent, eventToMouseEvent, clientX, clientY)
-- import DOM.Event.Types (Event, EventType(..), EventTarget)

-- import Data.Enum (Bounded)

sampleFreq :: Number
sampleFreq = 440.0

-- chromaticIntervals[0] = 1.000000;
-- chromaticIntervals[1] = 1.059463;
-- chromaticIntervals[2] = 1.122462;
-- chromaticIntervals[3] = 1.189207;
-- chromaticIntervals[4] = 1.259921;
-- chromaticIntervals[5] = 1.334839;
-- chromaticIntervals[6] = 1.414213;
-- chromaticIntervals[7] = 1.498307;
-- chromaticIntervals[8] = 1.587401;
-- chromaticIntervals[9] = 1.681792;
-- chromaticIntervals[10] = 1.781797;
-- chromaticIntervals[11] = 1.887748;

-- chromaticIntervals :: Int -> Number
-- chromaticIntervals 0  = 1.000000
-- chromaticIntervals 1  = 1.059463
-- chromaticIntervals 2  = 1.122462

chromaticMap :: ToneIndex -> Number
chromaticMap Zero  = 1.000000
chromaticMap One  = 1.059463
chromaticMap Two  = 1.122462
chromaticMap Three = 1.189207
chromaticMap Four = 1.259921
chromaticMap Five = 1.334839
chromaticMap Six = 1.414213
chromaticMap Seven = 1.498307
chromaticMap Eight = 1.587401
chromaticMap Nine = 1.681792
chromaticMap Ten = 1.781797
chromaticMap Eleven = 1.887748

chromaticIntervals :: ToneInterval -> Number
chromaticIntervals Tonic  = 1.000000
chromaticIntervals First  = 1.059463
chromaticIntervals Second  = 1.122462
chromaticIntervals MinThird = 1.189207
chromaticIntervals MajThird = 1.259921
chromaticIntervals Fourth = 1.334839
chromaticIntervals Diminished = 1.414213
chromaticIntervals Fifth = 1.498307
chromaticIntervals AugFifth = 1.587401
chromaticIntervals Sixth = 1.681792
chromaticIntervals MinSeventh = 1.781797
chromaticIntervals MajSeventh = 1.887748
-- data ToneInterval = 0 | 1 | 2 deriving (Enum)
-- data ToneInterval = Zero | One | Two deriving (Enum)
data ToneIndex = Zero | One | Two | Three | Four | Five
  | Six | Seven | Eight | Nine | Ten | Eleven

derive instance eqToneIndex :: Eq ToneIndex
derive instance ordToneIndex :: Ord ToneIndex

data ToneInterval = Tonic | First | Second | MinThird | MajThird | Fourth
  | Diminished | Fifth | AugFifth | Sixth | MinSeventh | MajSeventh

derive instance eqToneInterval :: Eq ToneInterval
derive instance ordToneInterval :: Ord ToneInterval
-- derive instance enumToneInterval :: Bounded ToneInterval

-- derive instance ti :: Enum
-- type ToneInterval = "abc" | "def"

-- data ModuleType2
--   = Regular
--   | Foreign
  -- deriving (Show, Eq, Ord)
beep :: Number -> Effect Unit
beep freq = do
  ctx <- newAudioContext
  osc <- createOscillator ctx
  setOscillatorType Sine osc
  log "ToneDeaf: now calling startOscillator"
  startOscillator 0.0 osc
  setValue freq =<< frequency osc
  connect osc =<< destination ctx
  stopOscillator 0.5 osc
  pure unit

-- getBtn :: String -> Effect Unit
getBtn ::  Effect Unit
getBtn = do
  log "ToneDeaf: now in getBtn"
  doc <- map toParentNode (window >>= document)
  -- doc <- map toParentNode (window >>= document)
  -- doc <- map toParentNode ( document)
  -- let doc = map toParentNode ( document)
  -- doc <-  map toParentNode $ document
  -- doc <- "hit"
  -- doc <- document window
  -- doc <- map toParentNode (htmlWindow >>= document)
  -- let doc :: Effect
  -- let doc :: Effect =<< (map toParentNode $ document)
  -- let doc =<< map toParentNode $  document
  -- doc <- toDocument document
  mbtn <- querySelector (wrap "#btn") doc
  -- mbtn <- querySelector "#btn" doc
  case mbtn of
    Nothing -> log "mbtn failed"
    Just btn -> do
      let mhtmlEl = fromElement btn
      case mhtmlEl of
        Nothing -> log "mhtml failed"
        Just htmlEl -> do
          let cn = className htmlEl
          -- log $ "cn=" <> map cn
          log $ "classname below:"
          cn >>= log
          -- "cn=" <> cn >>= log
          -- cn  do
          --   log cn
          -- addEventListener :: EventType -> EventListener -> Boolean -> EventTarget -> Effect Unit
          -- addEventListener (EventType "mousedown")
          -- (eventListener (emit <<< Left <<< EMouseMove)) false target
          -- eventListener :: forall a. (Event -> Effect a) -> Effect EventListener
          -- $ (eventListener (btnDownHandler))
          -- (eventListener (emit <<< Left <<< EMouseMove)) false target

          -- method 2
          evtListener <- (eventListener btnHandler2)
          -- addEventListener :: EventType -> EventListener -> Boolean -> EventTarget -> Effect Unit
          addEventListener
            (EventType "mousedown")
            -- (eventListener btnHandler3)
            evtListener
            false
            -- ((elementToEventTarget <<< htmlElementToElement) bodyHtmlElement)
            -- ((elementToEventTarget <<< htmlElementToElement) htmlEl)
            ((toEventTarget <<< toElement) htmlEl)
            -- htmlEl
          -- end method 2
          pure unit
      -- let cn = className htmlEl
      -- htmlEl <- fromElement button

      -- htmlEl <- button
      -- cn <- (fromElement htmlEl)
      pure unit

  -- button <- querySelector (wrap "#btn") doc
  -- case button of
  --   Nothing -> pure unit
  --   Just btn -> do
  --     let htmlEl = fromElement btn
  --     case htmlEl of
  --       Nothing -> pure unit
  --       Just he -> do
  --         let cn = className he
  --         -- log $ "cn=" <> map cn
  --         cn >>= log
  --         -- "cn=" <> cn >>= log
  --         log $ "abc"
  --         -- cn  do
  --         --   log cn
  --         pure unit
  --     -- let cn = className htmlEl
  --     -- htmlEl <- fromElement button
  --     -- htmlEl <- button
  --     -- cn <- (fromElement htmlEl)
  --     pure unit
  -- el <- button
  -- el do
  --   htmlEl <- fromElement el
  --   pure unit
  -- cn <- className $ (map fromElement el)
  -- case el of
  --   Nothing -> pure unit
  --   Just el -> do
  --     cn <- className el
  --     pure unit
  -- button do
  --   el <- button
  --   case el of
  --     Nothing -> pure unit
  --     Just el -> do
  --       cn <- className el
  --       pure unit
    -- cn <- className htmlEl
    -- pure unit
  -- cn2 <- className button
  -- let cn = getClassName button
  -- log $ "classname=" <> show cn
  -- do
    -- log $ "now in inner do" <> className  button
    -- let cn = map className ( map fromElement button )
    -- -- let cn = className ( fromElement button )
    -- let cn = (button >>= fromElement )
    -- pure cn
    -- log $ "now in inner do" <> map className ( map fromElement button )

  -- let unbox = button
  -- log $ "className=" <> button >>= getClassName
  -- className <*> button
  -- btnClass <- maybe "no-class" (\x -> x) $ className button
  -- btnClass <- maybe Element (\x -> x) button
  -- btnClass <- button >>= fromElement >>= className
  -- btnClass <- className <<= (button >>= fromElement)
  -- btnClass <- fromElement button >>= className
  -- btnClass <- button >>= fromElement >>= className
  -- log "btn-class=" <>
  -- button <- querySelector (wrap "#btn") =<< (map toParentNode $ document)
  -- button <- querySelector (wrap "#btn") document
  pure unit

-- getClassName :: Maybe HTMLElement -> String
-- getClassName e = map className  (map fromElement e)
-- note: the following actually compiles
-- getClassName e =  (map fromElement e)
-- getClassName e = className (map fromElement e)
-- getClassName Nothing = Nothing
-- getClassName (Just a) = className <*> a
-- getClassName elem = do
--   map className (map fromElement elem)

-- unboxMaybeElement :: Maybe Element -> HTMLElement
-- unboxMaybeElement Nothing = Nothing
-- unboxMaybeElement (Just a) = maybe (Element) (\x -> x) a

-- btnDownHandler :: Event -> Effect Unit
btnDownHandler e = log "btn pressed"

-- btnHandler2 :: forall e. Event -> GameEffect e Unit
-- btnHandler2 :: forall e. Event -> Effect e Unit
btnHandler2 :: Event -> Effect Unit
btnHandler2 a = do
  log "btn2 pressed"
  beep 880.0

btnHandler3 = 7


style the channel list

style the channel list

module Views.Channel
     ( channelView
    , channelsView
    ) where

--import Data.Array
import Data.Maybe

import Halogen

import Control.Alternative

import Halogen.Component
import Halogen.Signal
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Forms as A
import qualified Halogen.HTML.Events.Handler as E

import qualified Halogen.Themes.Bootstrap3 as B

import Models.Action
import Models.Channel
import Views.Types

import qualified Models.State as AS

data State = State (Maybe Channel)

-- Classes

selectedClass :: A.ClassName
selectedClass = A.className "selected"

notSelectedClass :: A.ClassName
notSelectedClass = A.className "not-selected"

--- Views

channelViewSelectClass :: Maybe Channel -> Channel -> A.ClassName
channelViewSelectClass Nothing channel = notSelectedClass
channelViewSelectClass (Just selectedChannel) channel =
    if channel == selectedChannel then
        selectedClass
    else
        notSelectedClass

channelView :: forall m. (Alternative m) => Maybe Channel -> Channel -> H.HTML (m _)
channelView selectedChannel channel =
    H.li [ A.classes [ A.className "channel", B.listGroupItem ] ]
        [ H.span
            [ A.classes [ A.className "channel-name", channelViewSelectClass selectedChannel channel ]
            --, E.onClick ctx (const $ SelectChannel channel)
            ]
            [ H.text (unChannel channel).name ]
        ]

channelsView :: forall m. (Alternative m) => [Channel] -> Maybe Channel -> H.HTML (m _)
channelsView channels selectedChannel =
    H.div [ A.class_ $ A.className "channels" ]
        [ H.h2_ [ H.text "Channels" ]
        , H.ul [ A.classes [ A.className "channels-list", B.listGroup ] ] ((channelView selectedChannel) <$> channels)
        ]

module Views.Channel
     ( channelView
    , channelsView
    ) where

--import Data.Array
import Data.Maybe

import Halogen

import Control.Alternative

import Halogen.Component
import Halogen.Signal
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Forms as A
import qualified Halogen.HTML.Events.Handler as E

import Models.Action
import Models.Channel
import Views.Types

import qualified Models.State as AS

data State = State (Maybe Channel)

-- Classes

selectedClass :: A.ClassName
selectedClass = A.className "selected"

notSelectedClass :: A.ClassName
notSelectedClass = A.className "not-selected"

--- Views

channelViewSelectClass :: Maybe Channel -> Channel -> A.ClassName
channelViewSelectClass Nothing channel = notSelectedClass
channelViewSelectClass (Just selectedChannel) channel =
    if channel == selectedChannel then
        selectedClass
    else
        notSelectedClass

channelView :: forall m. (Alternative m) => Maybe Channel -> Channel -> H.HTML (m _)
channelView selectedChannel channel =
    H.li [ A.class_ $ A.className "channel" ]
        [ H.span
            [ A.classes [ A.className "channel-name", channelViewSelectClass selectedChannel channel ]
            --, E.onClick ctx (const $ SelectChannel channel)
            ]
            [ H.text (unChannel channel).name ]
        ]

channelsView :: forall m. (Alternative m) => [Channel] -> Maybe Channel -> H.HTML (m _)
channelsView channels selectedChannel =
    H.div [ A.class_ $ A.className "channels" ]
        [ H.h2_ [ H.text "Channels" ]
        , H.ul [ A.class_ $ A.className "channels-list" ] ((channelView selectedChannel) <$> channels)
        ]


Refactored ability to highlight a piece at a particular square into its own function

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus (guard)
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:               createGrid offset width height layers,
    currentPlayer:      playerOne,
    selectedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\s -> s.coordinate == coordinate) squares

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getCoordinateIndex squares coordinate of
    Nothing -> false
    Just index ->
      case (fromJust (squares !! index)).piece of
        Nothing -> false
        Just p -> p.player == player

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Pixel -> Boolean
isOnSquare square (Tuple x y) =
  let vx = fst square.render + fst square.offset
      vy = snd square.render + snd square.offset
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

isOnActiveSquare :: Grid -> Player -> Square -> Pixel -> Boolean
isOnActiveSquare grid player square pixel =
  let moves = getMoves grid player square.coordinate
  in isOnSquare square pixel && not (null moves)

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  potential <- getDiagonalSquares coordinate
  guard $ (isValid grid potential && isValidMove grid player coordinate potential)
  return potential

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex grid.squares from)
      toIndex = fromJust (getCoordinateIndex grid.squares to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          let pixel = Tuple (toNumber ux) (toNumber uy)
          case isOnActiveSquare state.grid state.currentPlayer pixel square of
            true -> highlightPiece ctx square
            false -> return unit
          return unit
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

highlightPiece :: forall e. Context2D -> Square -> Eff (canvas :: Canvas | e) Unit
highlightPiece ctx square = do
  let arcPiece = { x: fst square.render + 0.5 * renderSize,
                   y: snd square.render + 0.5 * renderSize,
                   r: (renderSize / 2.0) * 0.8,
                   start: 0.0,
                   end: 2.0 * pi }
  setLineWidth highlightWidth ctx
  strokePath ctx $ arc ctx arcPiece
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      renderPage st (Just event)
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      addMouseEventListener MouseClickEvent (\e -> clickListener st e) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus (guard)
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:               createGrid offset width height layers,
    currentPlayer:      playerOne,
    selectedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\s -> s.coordinate == coordinate) squares

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getCoordinateIndex squares coordinate of
    Nothing -> false
    Just index ->
      case (fromJust (squares !! index)).piece of
        Nothing -> false
        Just p -> p.player == player

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Pixel -> Boolean
isOnSquare square (Tuple x y) =
  let vx = fst square.render + fst square.offset
      vy = snd square.render + snd square.offset
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

isOnActiveSquare :: Grid -> Player -> Square -> Pixel -> Boolean
isOnActiveSquare grid player square pixel =
  let moves = getMoves grid player square.coordinate
  in isOnSquare square pixel && not (null moves)

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  potential <- getDiagonalSquares coordinate
  guard $ (isValid grid potential && isValidMove grid player coordinate potential)
  return potential

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex grid.squares from)
      toIndex = fromJust (getCoordinateIndex grid.squares to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          let pixel = Tuple (toNumber ux) (toNumber uy)
          case isOnActiveSquare state.grid state.currentPlayer square pixel of
            true -> do
              setLineWidth highlightWidth ctx
              strokePath ctx $ arc ctx arcPiece
              return unit
            false -> return unit
          return unit
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      renderPage st (Just event)
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      addMouseEventListener MouseClickEvent (\e -> clickListener st e) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


Minor edit

Minor edit

module Main where

import Control.Monad.Aff (delay)
import Control.Monad.Aff.Console (CONSOLE)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import DOM (DOM)
import Data.Array (fromFoldable)
import Data.Helpers (generateSequence, convertToColors)
import Data.List (List(..), snoc, index, range)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Sounds (play, SOUND)
import Data.Styles (buttonStyled)
import Data.Time.Duration (Milliseconds(..))
import Prelude hiding (div,id)
import Pux (CoreEffects, EffModel, noEffects, onlyEffects, start)
import Pux.DOM.Events (DOMEvent, onChange, onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, input, label)
import Text.Smolder.HTML.Attributes (type', checked)
import Text.Smolder.Markup (text, (#!), (!), (!?))

data Event
  = Start
  | AnimateColor Number String
  | NewSequence (List String)
  | PlaySequence
  | UserClick String
  | ResetColor
  | Strict DOMEvent

type AppEffects =
  ( random :: RANDOM
  , console :: CONSOLE
  , dom :: DOM
  , sound :: SOUND
  , timer :: TIMER
  )

type State =
  { sequence :: List String
  , userInput :: List String
  , currentColor :: String
  , count :: Int
  , strict :: Boolean
  }

init :: State
init =
  { sequence: Nil
  , userInput: Nil
  , currentColor: ""
  , count : 0
  , strict: false
  }

generatePlaySequence :: forall e. Applicative e => Int -> List String -> Array (e (Maybe Event))
generatePlaySequence count sequence =
  range 0 (count - 1) #
  map (\v -> pure $ Just $ AnimateColor 300.0 (fromMaybe "" $ index sequence v) ) #
  fromFoldable

foldp :: Event -> State -> EffModel State Event AppEffects
foldp Start state =
  if state.count > 0 then
    noEffects $ state
  else
  { state: state { count = state.count + 1 }
  , effects:
      [ do
          result <- liftEff generateSequence
          let colors = convertToColors result
          pure $ Just $ NewSequence colors
      ]
  }

foldp (NewSequence list) state =
  { state: state { sequence = list }
  , effects: [pure $ Just $ PlaySequence]
  }

foldp (UserClick color) state =
  { state: state { userInput = snoc state.userInput color, currentColor = color }
  , effects: [ pure $ Just $ AnimateColor 300.0 color ]
  }
foldp ResetColor state = noEffects $ state { currentColor = "" }

foldp (AnimateColor time color) state =
  { state: state { currentColor = color },
    effects:
      [ liftEff $ play color *> pure Nothing
      , do
        delay $ Milliseconds time
        pure $ Just $ ResetColor
      ]
  }

foldp PlaySequence state =
  onlyEffects state $ generatePlaySequence state.count state.sequence

foldp (Strict e) state = noEffects $ state { strict = not state.strict }

view :: State -> HTML Event
view state =
  div do
    div do
      div
        ! buttonStyled "red" state.currentColor
        #! onClick (const $ UserClick "red")
        $ text ""
      div
        ! buttonStyled "green" state.currentColor
        #! onClick (const $ UserClick "green")
        $ text ""
      div
        ! buttonStyled "yellow" state.currentColor
        #! onClick (const $ UserClick "yellow")
        $ text ""
      div
        ! buttonStyled "blue" state.currentColor
        #! onClick (const $ UserClick "blue")
        $ text ""
    div do
      text $ "Count" <> show state.count
    div do
      label $ text "Strict"
      (input !? state.strict) (checked "checked") ! type' "checkbox" #! onChange Strict
    button #! onClick (const Start) $ text "Start"

main :: Eff (CoreEffects AppEffects) Unit
main = do
  app <- start
    { initialState: init
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input

module Main where

import Control.Monad.Aff (delay)
import Control.Monad.Aff.Console (CONSOLE)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import DOM (DOM)
import Data.Array (fromFoldable)
import Data.Helpers (generateSequence, convertToColors)
import Data.List (List(..), snoc, index, range)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Sounds (play, SOUND)
import Data.Styles (buttonStyled)
import Data.Time.Duration (Milliseconds(..))
import Prelude hiding (div,id)
import Pux (CoreEffects, EffModel, noEffects, onlyEffects, start)
import Pux.DOM.Events (DOMEvent, onChange, onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, input, label)
import Text.Smolder.HTML.Attributes (type', checked)
import Text.Smolder.Markup (text, (#!), (!), (!?))

data Event
  = Start
  | AnimateColor Number String
  | NewSequence (List String)
  | PlaySequence
  | UserClick String
  | ResetColor
  | Strict DOMEvent

type AppEffects = (random :: RANDOM, console :: CONSOLE, dom :: DOM, sound :: SOUND)

type State =
  { sequence :: List String
  , userInput :: List String
  , currentColor :: String
  , count :: Int
  , strict :: Boolean
  }

init :: State
init =
  { sequence: Nil
  , userInput: Nil
  , currentColor: ""
  , count : 0
  , strict: false
  }

generatePlaySequence :: forall e. Applicative e => Int -> List String -> Array (e (Maybe Event))
generatePlaySequence count sequence =
  range 0 (count - 1) #
  map (\v -> pure $ Just $ AnimateColor 300.0 (fromMaybe "" $ index sequence v) ) #
  fromFoldable

foldp :: Event -> State -> EffModel State Event AppEffects
foldp Start state =
  if state.count > 0 then
    noEffects $ state
  else
  { state: state { count = state.count + 1 }
  , effects:
      [ do
          result <- liftEff generateSequence
          let colors = convertToColors result
          pure $ Just $ NewSequence colors
      ]
  }

foldp (NewSequence list) state =
  { state: state { sequence = list }
  , effects: [pure $ Just $ PlaySequence]
  }

foldp (UserClick color) state =
  { state: state { userInput = snoc state.userInput color, currentColor = color }
  , effects: [ pure $ Just $ AnimateColor 300.0 color ]
  }
foldp ResetColor state = noEffects $ state { currentColor = "" }

foldp (AnimateColor time color) state =
  { state: state { currentColor = color },
    effects:
      [ liftEff $ play color *> pure Nothing
      , do
        delay $ Milliseconds time
        pure $ Just $ ResetColor
      ]
  }

foldp PlaySequence state =
  onlyEffects state $ generatePlaySequence state.count state.sequence

foldp (Strict e) state = noEffects $ state { strict = not state.strict }

view :: State -> HTML Event
view state =
  div do
    div do
      div
        ! buttonStyled "red" state.currentColor
        #! onClick (const $ UserClick "red")
        $ text ""
      div
        ! buttonStyled "green" state.currentColor
        #! onClick (const $ UserClick "green")
        $ text ""
      div
        ! buttonStyled "yellow" state.currentColor
        #! onClick (const $ UserClick "yellow")
        $ text ""
      div
        ! buttonStyled "blue" state.currentColor
        #! onClick (const $ UserClick "blue")
        $ text ""
    div do
      text $ "Count" <> show state.count
    div do
      label $ text "Strict"
      (input !? state.strict) (checked "checked") ! type' "checkbox" #! onChange Strict
    button #! onClick (const Start) $ text "Start"

main :: Eff (CoreEffects AppEffects) Unit
main = do
  app <- start
    { initialState: init
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input