mission02

module Main where

import Prelude

import Data.List (List(..))
import Data.Maybe
import Control.Monad.Eff
import Control.Monad.Aff
import Graphics.Canvas as C
import Signal as S
import Signal.Time as S

import Utils
import CanvasUtils
import Zipper
import Input as I
import Screen
import SimScreen as Sim

main = do
  Just canvas <- C.getCanvasElementById "canvas"
  context <- C.getContext2D canvas
  input <- I.input
  launchAff $ do
    initState <- initialState
    let game = S.foldp update initState input
    liftEff' $ S.runSignal (render context <$> game)

-----------
-- Model
-----------

data State
  = VNScreen (Zipper Screen)
  | Simulation Sim.SimScreen
  | Wait S.Time State
  | Screens State State

finished :: State -> Boolean
finished (VNScreen zipp) = not $ fst $ next zipp
finished (Wait _ _) = false
finished (Simulation sim) = Sim.done sim
finished (Screens s1 s2) = finished s1 && finished s2

initialState :: Aff _ State
initialState = do
  comp <- loadImageData "assets/comp2.png"
  pure $
    Screens
      (Screens
        (VNScreen $ screens comp intro) $
        Screens
          (mission01 comp)
          (mission02 comp))
      (VNScreen $ screens comp end_text)

mission01 comp =
  Screens
     (VNScreen $ screens comp mission01_text)
     (Simulation $ Sim.mkSimScreen (zipper {input: Nil, output: Cons 5 Nil} Nil Nil) comp)

mission01_text =
  """
Your first mission is to make the machine print the number 5.

We are counting on you!
"""

mission02 comp =
  Screens
     (VNScreen $ screens comp mission02_text)
     (Simulation $ Sim.mkSimScreen (zipper {input: Cons 4 $ Cons 5 Nil, output: Cons 9 Nil} Nil $
                                      Cons {input: Cons 3 $ Cons 3 Nil, output: Cons 6 Nil} $
                                      Cons {input: Cons (-3) $ Cons 3 Nil, output: Cons 0 Nil} Nil) comp)

mission02_text =
  """
Nice, you have completed the first mission!

Though maybe it's not that impressive, there are only two buttons, how hard can it be?

Next, we need a machine that can add two numbers together.

Build one for us, we'll give you two numbers, you give us their sum.
"""

end_text =
  """
You did it! You completed all of our tasks!

That's amazing!

We have no more tasks for you.

Therefore, you are fired.

Thank you, and goodbye.

The End.
"""

------------
-- Update
------------

update :: I.Input -> State -> State
update input currState@(Screens currScreen nextScreen) =
  if (input.screenDir > 0.0 || isJust input.mouseClick) && finished currScreen
  then Wait input.time nextScreen
  else Screens (update input currScreen) nextScreen
update input currState@(Wait t nextState) =
  if t + S.second / 4.0 <= input.time
  then nextState
  else currState
update input (Simulation sim) = Simulation $ Sim.update input sim
update input state@(VNScreen screens) =
  if input.screenDir > 0.0 || isJust input.mouseClick then
    (VNScreen <<< snd <<< next) screens
  else if input.screenDir < 0.0 then
    (VNScreen <<< snd <<< back) screens
  else
    state

------------
-- Render
------------

renderScreens :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderScreens ctx (Simulation screen) = Sim.render ctx screen
renderScreens ctx (VNScreen screens) = renderScreen ctx (current screens)
renderScreens ctx (Wait _ state) = renderScreens ctx state
renderScreens ctx (Screens s _) = renderScreens ctx s

render :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
render context state = do
  clearCanvas context
  renderScreens context state
  pure unit

clearCanvas ctx = do
  C.setFillStyle "#1B1C1B" ctx
  C.fillRect ctx { x: 0.0, y: 0.0, w: 1024.0, h: 800.0 }

module Main where

import Prelude

import Data.List (List(..))
import Data.Maybe
import Control.Monad.Eff
import Control.Monad.Aff
import Graphics.Canvas as C
import Signal as S
import Signal.Time as S

import Utils
import CanvasUtils
import Zipper
import Input as I
import Screen
import SimScreen as Sim

main = do
  Just canvas <- C.getCanvasElementById "canvas"
  context <- C.getContext2D canvas
  input <- I.input
  launchAff $ do
    initState <- initialState
    let game = S.foldp update initState input
    liftEff' $ S.runSignal (render context <$> game)

-----------
-- Model
-----------

data State
  = VNScreen (Zipper Screen)
  | Simulation Sim.SimScreen
  | Wait S.Time State
  | Screens State State

finished :: State -> Boolean
finished (VNScreen zipp) = not $ fst $ next zipp
finished (Wait _ _) = false
finished (Simulation sim) = Sim.done sim
finished (Screens s1 s2) = finished s1 && finished s2

initialState :: Aff _ State
initialState = do
  comp <- loadImageData "assets/comp2.png"
  pure $
    Screens
      (Screens
        (VNScreen $ screens comp intro)
        (mission01 comp))
      (VNScreen $ screens comp end_text)

mission01 comp =
  Screens
     (VNScreen $ screens comp mission01_text)
     (Simulation $ Sim.mkSimScreen (zipper {input: Nil, output: Cons 5 Nil} Nil Nil) comp)

mission01_text =
  """
Your first mission is to make the machine print the number 5.

We are counting on you!
"""

end_text =
  """
You did it! You completed all of our tasks!

That's amazing!

We have no more tasks for you.

Therefore, you are fired.

Thank you, and goodbye.

End.
"""

------------
-- Update
------------

update :: I.Input -> State -> State
update input currState@(Screens currScreen nextScreen) =
  if (input.screenDir > 0.0 || isJust input.mouseClick) && finished currScreen
  then Wait input.time nextScreen
  else Screens (update input currScreen) nextScreen
update input currState@(Wait t nextState) =
  if t + S.second / 4.0 <= input.time
  then nextState
  else currState
update input (Simulation sim) = Simulation $ Sim.update input sim
update input state@(VNScreen screens) =
  if input.screenDir > 0.0 || isJust input.mouseClick then
    (VNScreen <<< snd <<< next) screens
  else if input.screenDir < 0.0 then
    (VNScreen <<< snd <<< back) screens
  else
    state

------------
-- Render
------------

renderScreens :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderScreens ctx (Simulation screen) = Sim.render ctx screen
renderScreens ctx (VNScreen screens) = renderScreen ctx (current screens)
renderScreens ctx (Wait _ state) = renderScreens ctx state
renderScreens ctx (Screens s _) = renderScreens ctx s

render :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
render context state = do
  clearCanvas context
  renderScreens context state
  pure unit

clearCanvas ctx = do
  C.setFillStyle "#1B1C1B" ctx
  C.fillRect ctx { x: 0.0, y: 0.0, w: 1024.0, h: 800.0 }


Dropped some debugging message

Dropped some debugging message

in order to see what's important

module Main where

import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Overview as OverviewC
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Loaded as LoadedC
import Gonimo.UI.Loaded.Types as LoadedC
import Gonimo.UI.Socket as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Pux.Html.Attributes as A
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Servant.Subscriber.Subscriptions as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (launchAff, Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Ref (newRef, writeRef, readRef, REF, Ref)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (runIO, IO)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (modify, put, get)
import Data.Array (head)
import Data.Either (Either(Right, Left))
import Data.Foldable (traverse_)
import Data.Generic (gShow)
import Data.Lens (prism', PrismP, (^?))
import Data.List (toUnfoldable, reverse, List(Nil, Cons))
import Data.Maybe (fromMaybe, Maybe(..))
import Data.Profunctor (lmap)
import Data.Traversable (traverse)
import Data.Tuple (fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Router (match, Route(AcceptInvitation, Home))
import Gonimo.Client.Types (toIO, GonimoError, Gonimo, class ReportErrorAction)
import Gonimo.Client.Types (Settings)
import Gonimo.Pux (toPux, noEffects, wrapAction, onlyModify, Update, ComponentType, makeChildData, ToChild, liftChild, Component)
import Gonimo.Server.Types (DeviceType(NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Secret(Secret))
import Gonimo.UI.Error (viewError, handleError, class ErrorAction, UserError(NoError))
import Gonimo.UI.Html as Html
import Gonimo.Util (fromMaybeM, coerceEffects)
import Gonimo.WebAPI (postFunnyName, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (App, renderToDOM, fromSimple, start)
import Pux.Html (text, span, Html, img, div)
import Gonimo.Util (sampleUrl)
import Pux.Devtool (Action, start) as Pux.Devtool
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber, SubscriberEff)
import Servant.Subscriber.Connection (setPongRequest)
import Signal (foldp, map2, runSignal, constant, Signal)
import Signal.Channel (Channel, CHANNEL, send, subscribe, channel)
import Unsafe.Coerce (unsafeCoerce)
import Prelude hiding (div)

data State = LoadingS LoadingS'
           | LoadedS LoadedC.State

_LoadingS :: PrismP State LoadingS'
_LoadingS = prism' LoadingS (\s -> case s of
                                LoadingS x -> Just x
                                _ -> Nothing)

_LoadedS :: PrismP State LoadedC.State
_LoadedS = prism' LoadedS (\s -> case s of
                                LoadedS x -> Just x
                                _ -> Nothing)

type LoadingS' = { actionQueue :: List LoadedC.Action -- | We queue actions until we are loaded.
                 , userError :: UserError
                 , sendAction :: Action -> Eff () Unit
                 }

type LoadedState = {
               authData :: AuthData
             , settings :: Settings
             }

init :: (Action -> Eff () Unit) -> State
init sendAction' = LoadingS { actionQueue : Nil
                            , userError : NoError
                            , sendAction : sendAction'
                            }

data Action = Start
            | Init LoadedC.State
            | ReportError GonimoError
            | LoadedA LoadedC.Action
            | ResetDevice
            | ClearError
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

instance errorActionAction :: ErrorAction Action where
  resetDevice = ResetDevice
  nop = Nop
  clearError = ClearError

type MySubscriber = Subscriber () LoadedC.Action
--------------------------------------------------------------------------------

update :: Update Unit State Action
update action = do
  state <- ( get :: Component Unit State State)
  case action of
    Nop -> noEffects
    Init ls -> fromMaybe [] <$> handleInit ls
    _ -> fromMaybeM (fromMaybe [] <$> updateLoaded action) (updateLoading action)

toLoading :: ToChild Unit State Unit LoadingS'
toLoading = pure $ makeChildData _LoadingS unit

toLoaded :: ToChild Unit State Unit LoadedC.State
toLoaded = pure $ makeChildData _LoadedS unit

updateLoading' ::  Update Unit LoadingS' Action
updateLoading' action = do
  state <- get
  case action of
    Start           -> pure [ load state.sendAction ]
    LoadedA action  -> onlyModify $ \state' -> state' {
                          actionQueue = Cons action state.actionQueue
                        }
    Init ls         -> pure [ do
                                  Gonimo.log "Init command should be handled in toplevel update!"
                                  pure Nop
                              ]
    ReportError err -> handleError err
    ResetDevice     -> handleResetDevice
    ClearError      -> do
      modify $ _ { userError = NoError }
      pure $ wrapAction Start
    Nop             -> noEffects

handleResetDevice :: ComponentType Unit LoadingS' Action
handleResetDevice = pure $ [ do
  liftEff $ localStorage.removeItem Key.authData
  pure Start
 ]
updateLoading :: Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoading = liftChild toLoading <<< updateLoading'

updateLoaded :: Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoaded action = case action of
  LoadedA act -> updateLoaded' act
  (ReportError err) -> updateLoaded' (LoadedC.ReportError err)
  _ -> do
       state <- get
       case state of
        LoadedS _ -> pure <<< Just $
                     [ do Gonimo.log "Only LoadedA actions are supported when loaded"
                          pure Nop
                     ]
        _ -> pure Nothing

updateLoaded' :: LoadedC.Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoaded' = map (map (map (map LoadedA))) <<< liftChild toLoaded <<< LoadedC.update

handleInit :: LoadedC.State -> Component Unit State (Maybe (Array (IO Action)))
handleInit ls = do
    state <- get
    case state ^? _LoadingS of
      Nothing -> pure Nothing
      Just loadingS -> do
        let queueEffects = map (pure <<< LoadedA) <<< reverse $ loadingS.actionQueue
        put $ LoadedS ls
        pure <<< Just $ toUnfoldable queueEffects

--------------------------------------------------------------------------------

view :: State -> Html Action
view (LoadingS state) = viewLoading state
view (LoadedS state)  = map LoadedA $ LoadedC.view state

viewLoading :: LoadingS' -> Html Action
viewLoading state = case state.userError of
      NoError -> Html.viewLoading "Loading your gonimo, stay tight ..."
      _ -> viewError state

--------------------------------------------------------------------------------

load :: (Action -> Eff () Unit) -> IO Action
load sendAction' = Gonimo.toIO initSettings $ authToAction =<< LoadedC.getAuthData
  where
    initSettings = mkSettings $ GonimoSecret (Secret "blabala")

    mkSettings :: AuthToken -> Settings
    mkSettings secret = defaultSettings $ SPParams_ {
          authorization : secret
        , baseURL       : "http://localhost:8081/"
        }

    authToAction :: AuthData -> Gonimo Action
    authToAction (authData@(AuthData auth)) = do
      pure $ Init
            { subscriberUrl : "ws://localhost:8081/subscriber"
            , overviewS         : OverviewC.init
            , socketS       : SocketC.init authData
            , central       : LoadedC.CentralOverview
            , familyIds     : []
            , families      : Map.empty
            , url           : ""
            , onlineDevices : []
            , deviceInfos   : []
            , userError     : NoError
            , sendAction    : lmap LoadedA sendAction'
            }

makeCallback :: forall eff. Channel Action ->  (LoadedC.Action -> SubscriberEff (channel :: CHANNEL | eff) Unit)
makeCallback c = send c <<< LoadedA

makeNotify :: forall eff. Channel Action ->  (Sub.Notification -> SubscriberEff (channel :: CHANNEL | eff) Unit)
makeNotify c = send c <<< LoadedA <<< LoadedC.HandleSubscriber

deploySubscriptions :: IO (Maybe MySubscriber) -> State -> IO Unit
deploySubscriptions _ (LoadingS _) = pure unit
deploySubscriptions getSubscriber (LoadedS s) = do
  let subscriptions = LoadedC.getSubscriptions s
  subscriber <- getSubscriber
  case subscriber of
    Nothing -> Console.log "Not deploying - no subscriber yet!"
    Just subscriber' -> do
      liftEff $ traverse_ (flip Sub.setPongRequest  (Sub.getConnection subscriber')) $ LoadedC.getPongRequest s
      liftEff $ traverse_ (flip Sub.setCloseRequest (Sub.getConnection subscriber')) $ LoadedC.getCloseRequest s
      liftEff $ Sub.deploy subscriptions subscriber'

-- | Don't use a foldp instead of Ref - you will build up an endless thunk of actions in memory.
renewSubscriber :: Channel Action -> Ref (Maybe MySubscriber)
                   -> State -> IO (Maybe MySubscriber)
renewSubscriber controlChan subscriberRef state = do
    oldSub <- liftEff $ readRef subscriberRef
    let oldUrl = Sub.getUrl <<< Sub.getConnection <$> oldSub
    let newUrl = case state of
          LoadedS lState -> Just lState.subscriberUrl
          _ -> Nothing
    if (newUrl /= oldUrl)
      then do
        Console.log $ "Closing old subscriber ..."
        liftEff $ traverse_ (Sub.close <<< Sub.getConnection) oldSub
        newSub <- traverse makeMySubscriber newUrl
        liftEff $ writeRef subscriberRef newSub
        pure newSub
       else
        pure oldSub
  where
    makeMySubscriber :: String -> IO MySubscriber
    makeMySubscriber url' = do
        map coerceSubscriberEffects <<< liftEff $ Sub.makeSubscriber
                  { url : url'
                  , callback : makeCallback controlChan
                  , notify : makeNotify controlChan
                  }

main = do
  urlSignal <- sampleUrl
  controlChan <- channel Nop
  subscriberRef <- newRef Nothing
  let controlSig = subscribe controlChan
  let routeSignal = map (LoadedA <<< LoadedC.SetURL) urlSignal
  app <- start $
    { initialState: init (coerceEffects <<< send controlChan)
    , update: toPux update
    , view: view
    , inputs: [controlSig, routeSignal]
    }
  -- We have to send Start after the fact, because on merging const signals one gets lost!
  send controlChan Start
  let subscriberSignal = map (renewSubscriber controlChan subscriberRef) app.state
  let subscribeSignal = deploySubscriptions <$> subscriberSignal <*> app.state
  runSignal $ coerceEffects <<< map (const unit) <<< launchAff <<< runIO <$> subscribeSignal
  -- runSignal $ map (\_ -> Console.log "State changed!") app.state
  runSignal $ Console.log <$> urlSignal
  renderToDOM "#app" app.html
  pure app

debug = do
  urlSignal <- sampleUrl
  controlChan <- channel Nop
  subscriberRef <- newRef Nothing
  let controlSig = subscribe controlChan
  let routeSignal = map (LoadedA <<< LoadedC.SetURL) urlSignal
  app <- Pux.Devtool.start $
    { initialState: init (coerceEffects <<< send controlChan)
    , update: toPux update
    , view: view
    , inputs: [controlSig, routeSignal]
    }
  -- We have to send Start after the fact, because on merging const signals one gets lost!
  send controlChan Start
  let subscriberSignal = map (renewSubscriber controlChan subscriberRef) app.state
  let subscribeSignal = deploySubscriptions <$> subscriberSignal <*> app.state
  runSignal $ coerceEffects <<< map (const unit) <<< launchAff <<< runIO <$> subscribeSignal
  -- runSignal $ map (\_ -> Console.log "State changed!") app.state
  runSignal $ Console.log <$> urlSignal
  renderToDOM "#app" app.html
  pure app

coerceSubscriberEffects :: forall eff1 eff2 a. Subscriber eff1 a -> Subscriber eff2 a
coerceSubscriberEffects = unsafeCoerce

module Main where

import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Overview as OverviewC
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Loaded as LoadedC
import Gonimo.UI.Loaded.Types as LoadedC
import Gonimo.UI.Socket as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Pux.Html.Attributes as A
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Servant.Subscriber.Subscriptions as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (launchAff, Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Ref (newRef, writeRef, readRef, REF, Ref)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (runIO, IO)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (modify, put, get)
import Data.Array (head)
import Data.Either (Either(Right, Left))
import Data.Foldable (traverse_)
import Data.Generic (gShow)
import Data.Lens (prism', PrismP, (^?))
import Data.List (toUnfoldable, reverse, List(Nil, Cons))
import Data.Maybe (fromMaybe, Maybe(..))
import Data.Profunctor (lmap)
import Data.Traversable (traverse)
import Data.Tuple (fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Router (match, Route(AcceptInvitation, Home))
import Gonimo.Client.Types (toIO, GonimoError, Gonimo, class ReportErrorAction)
import Gonimo.Client.Types (Settings)
import Gonimo.Pux (toPux, noEffects, wrapAction, onlyModify, Update, ComponentType, makeChildData, ToChild, liftChild, Component)
import Gonimo.Server.Types (DeviceType(NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Secret(Secret))
import Gonimo.UI.Error (viewError, handleError, class ErrorAction, UserError(NoError))
import Gonimo.UI.Html as Html
import Gonimo.Util (fromMaybeM, coerceEffects)
import Gonimo.WebAPI (postFunnyName, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (App, renderToDOM, fromSimple, start)
import Pux.Html (text, span, Html, img, div)
import Gonimo.Util (sampleUrl)
import Pux.Devtool (Action, start) as Pux.Devtool
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber, SubscriberEff)
import Servant.Subscriber.Connection (setPongRequest)
import Signal (foldp, map2, runSignal, constant, Signal)
import Signal.Channel (Channel, CHANNEL, send, subscribe, channel)
import Unsafe.Coerce (unsafeCoerce)
import Prelude hiding (div)

data State = LoadingS LoadingS'
           | LoadedS LoadedC.State

_LoadingS :: PrismP State LoadingS'
_LoadingS = prism' LoadingS (\s -> case s of
                                LoadingS x -> Just x
                                _ -> Nothing)

_LoadedS :: PrismP State LoadedC.State
_LoadedS = prism' LoadedS (\s -> case s of
                                LoadedS x -> Just x
                                _ -> Nothing)

type LoadingS' = { actionQueue :: List LoadedC.Action -- | We queue actions until we are loaded.
                 , userError :: UserError
                 , sendAction :: Action -> Eff () Unit
                 }

type LoadedState = {
               authData :: AuthData
             , settings :: Settings
             }

init :: (Action -> Eff () Unit) -> State
init sendAction' = LoadingS { actionQueue : Nil
                            , userError : NoError
                            , sendAction : sendAction'
                            }

data Action = Start
            | Init LoadedC.State
            | ReportError GonimoError
            | LoadedA LoadedC.Action
            | ResetDevice
            | ClearError
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

instance errorActionAction :: ErrorAction Action where
  resetDevice = ResetDevice
  nop = Nop
  clearError = ClearError

type MySubscriber = Subscriber () LoadedC.Action
--------------------------------------------------------------------------------

update :: Update Unit State Action
update action = do
  state <- ( get :: Component Unit State State)
  case action of
    Nop -> noEffects
    Init ls -> fromMaybe [] <$> handleInit ls
    _ -> fromMaybeM (fromMaybe [] <$> updateLoaded action) (updateLoading action)

toLoading :: ToChild Unit State Unit LoadingS'
toLoading = pure $ makeChildData _LoadingS unit

toLoaded :: ToChild Unit State Unit LoadedC.State
toLoaded = pure $ makeChildData _LoadedS unit

updateLoading' ::  Update Unit LoadingS' Action
updateLoading' action = do
  state <- get
  case action of
    Start           -> pure [ load state.sendAction ]
    LoadedA action  -> onlyModify $ \state' -> state' {
                          actionQueue = Cons action state.actionQueue
                        }
    Init ls         -> pure [ do
                                  Gonimo.log "Init command should be handled in toplevel update!"
                                  pure Nop
                              ]
    ReportError err -> handleError err
    ResetDevice     -> handleResetDevice
    ClearError      -> do
      modify $ _ { userError = NoError }
      pure $ wrapAction Start
    Nop             -> noEffects

handleResetDevice :: ComponentType Unit LoadingS' Action
handleResetDevice = pure $ [ do
  liftEff $ localStorage.removeItem Key.authData
  pure Start
 ]
updateLoading :: Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoading = liftChild toLoading <<< updateLoading'

updateLoaded :: Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoaded action = case action of
  LoadedA act -> updateLoaded' act
  (ReportError err) -> updateLoaded' (LoadedC.ReportError err)
  _ -> do
       state <- get
       case state of
        LoadedS _ -> pure <<< Just $
                     [ do Gonimo.log "Only LoadedA actions are supported when loaded"
                          pure Nop
                     ]
        _ -> pure Nothing

updateLoaded' :: LoadedC.Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoaded' = map (map (map (map LoadedA))) <<< liftChild toLoaded <<< LoadedC.update

handleInit :: LoadedC.State -> Component Unit State (Maybe (Array (IO Action)))
handleInit ls = do
    state <- get
    case state ^? _LoadingS of
      Nothing -> pure Nothing
      Just loadingS -> do
        let queueEffects = map (pure <<< LoadedA) <<< reverse $ loadingS.actionQueue
        put $ LoadedS ls
        pure <<< Just $ toUnfoldable queueEffects

--------------------------------------------------------------------------------

view :: State -> Html Action
view (LoadingS state) = viewLoading state
view (LoadedS state)  = map LoadedA $ LoadedC.view state

viewLoading :: LoadingS' -> Html Action
viewLoading state = case state.userError of
      NoError -> Html.viewLoading "Loading your gonimo, stay tight ..."
      _ -> viewError state

--------------------------------------------------------------------------------

load :: (Action -> Eff () Unit) -> IO Action
load sendAction' = Gonimo.toIO initSettings $ authToAction =<< LoadedC.getAuthData
  where
    initSettings = mkSettings $ GonimoSecret (Secret "blabala")

    mkSettings :: AuthToken -> Settings
    mkSettings secret = defaultSettings $ SPParams_ {
          authorization : secret
        , baseURL       : "http://localhost:8081/"
        }

    authToAction :: AuthData -> Gonimo Action
    authToAction (authData@(AuthData auth)) = do
      pure $ Init
            { subscriberUrl : "ws://localhost:8081/subscriber"
            , overviewS         : OverviewC.init
            , socketS       : SocketC.init authData
            , central       : LoadedC.CentralOverview
            , familyIds     : []
            , families      : Map.empty
            , url           : ""
            , onlineDevices : []
            , deviceInfos   : []
            , userError     : NoError
            , sendAction    : lmap LoadedA sendAction'
            }

makeCallback :: forall eff. Channel Action ->  (LoadedC.Action -> SubscriberEff (channel :: CHANNEL | eff) Unit)
makeCallback c = send c <<< LoadedA

makeNotify :: forall eff. Channel Action ->  (Sub.Notification -> SubscriberEff (channel :: CHANNEL | eff) Unit)
makeNotify c = send c <<< LoadedA <<< LoadedC.HandleSubscriber

deploySubscriptions :: IO (Maybe MySubscriber) -> State -> IO Unit
deploySubscriptions _ (LoadingS _) = pure unit
deploySubscriptions getSubscriber (LoadedS s) = do
  let subscriptions = LoadedC.getSubscriptions s
  subscriber <- getSubscriber
  case subscriber of
    Nothing -> Console.log "Not deploying - no subscriber yet!"
    Just subscriber' -> do
      Console.log "Setting pong and close requests ..."
      liftEff $ traverse_ (flip Sub.setPongRequest  (Sub.getConnection subscriber')) $ LoadedC.getPongRequest s
      liftEff $ traverse_ (flip Sub.setCloseRequest (Sub.getConnection subscriber')) $ LoadedC.getCloseRequest s
      liftEff $ Sub.deploy subscriptions subscriber'
      Console.log $ "Deployed " <> show (Sub.size subscriptions) <> " subscriptions!"

-- | Don't use a foldp instead of Ref - you will build up an endless thunk of actions in memory.
renewSubscriber :: Channel Action -> Ref (Maybe MySubscriber)
                   -> State -> IO (Maybe MySubscriber)
renewSubscriber controlChan subscriberRef state = do
    oldSub <- liftEff $ readRef subscriberRef
    let oldUrl = Sub.getUrl <<< Sub.getConnection <$> oldSub
    let newUrl = case state of
          LoadedS lState -> Just lState.subscriberUrl
          _ -> Nothing
    Console.log $ "Old url: " <> show oldUrl
    Console.log $ "New url: " <> show newUrl
    Console.log $ "Is different: " <> show (newUrl /= oldUrl)
    if (newUrl /= oldUrl)
      then do
        Console.log $ "Closing old subscriber ..."
        liftEff $ traverse_ (Sub.close <<< Sub.getConnection) oldSub
        newSub <- traverse makeMySubscriber newUrl
        liftEff $ writeRef subscriberRef newSub
        pure newSub
       else
        pure oldSub
  where
    makeMySubscriber :: String -> IO MySubscriber
    makeMySubscriber url' = do
        map coerceSubscriberEffects <<< liftEff $ Sub.makeSubscriber
                  { url : url'
                  , callback : makeCallback controlChan
                  , notify : makeNotify controlChan
                  }

main = do
  urlSignal <- sampleUrl
  controlChan <- channel Nop
  subscriberRef <- newRef Nothing
  let controlSig = subscribe controlChan
  let routeSignal = map (LoadedA <<< LoadedC.SetURL) urlSignal
  app <- start $
    { initialState: init (coerceEffects <<< send controlChan)
    , update: toPux update
    , view: view
    , inputs: [controlSig, routeSignal]
    }
  -- We have to send Start after the fact, because on merging const signals one gets lost!
  send controlChan Start
  let subscriberSignal = map (renewSubscriber controlChan subscriberRef) app.state
  let subscribeSignal = deploySubscriptions <$> subscriberSignal <*> app.state
  runSignal $ coerceEffects <<< map (const unit) <<< launchAff <<< runIO <$> subscribeSignal
  runSignal $ map (\_ -> Console.log "State changed!") app.state
  runSignal $ Console.log <$> urlSignal
  renderToDOM "#app" app.html
  pure app

debug = do
  urlSignal <- sampleUrl
  controlChan <- channel Nop
  subscriberRef <- newRef Nothing
  let controlSig = subscribe controlChan
  let routeSignal = map (LoadedA <<< LoadedC.SetURL) urlSignal
  app <- Pux.Devtool.start $
    { initialState: init (coerceEffects <<< send controlChan)
    , update: toPux update
    , view: view
    , inputs: [controlSig, routeSignal]
    }
  -- We have to send Start after the fact, because on merging const signals one gets lost!
  send controlChan Start
  let subscriberSignal = map (renewSubscriber controlChan subscriberRef) app.state
  let subscribeSignal = deploySubscriptions <$> subscriberSignal <*> app.state
  runSignal $ coerceEffects <<< map (const unit) <<< launchAff <<< runIO <$> subscribeSignal
  runSignal $ map (\_ -> Console.log "State changed!") app.state
  runSignal $ Console.log <$> urlSignal
  renderToDOM "#app" app.html
  pure app

coerceSubscriberEffects :: forall eff1 eff2 a. Subscriber eff1 a -> Subscriber eff2 a
coerceSubscriberEffects = unsafeCoerce


gene rendering optimizations

gene rendering optimizations

module Genetics.Browser.Demo where

import Prelude

import Color (black)
import Color.Scheme.Clrs (blue, red)
import Color.Scheme.X11 (darkblue, darkgrey, lightgrey)
import Control.Monad.Except (runExcept, throwError)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Filterable (filter, filterMap, partition, partitionMap)
import Data.Foldable (class Foldable, foldMap, foldr, length, minimumBy, sequence_, traverse_)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.Function (on)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (re, view, (^.))
import Data.Lens.Lens.Tuple (_2)
import Data.List (List, (:))
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Strong (fanout)
import Data.Traversable (for)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple as Tuple
import Data.Unfoldable (unfoldr)
import Data.Variant (inj)
import Effect.Aff (Aff, error)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Foreign (F, Foreign, ForeignError(ForeignError))
import Foreign (readArray) as Foreign
import Foreign.Index (readProp) as Foreign
import Foreign.Keys (keys) as Foreign
import Genetics.Browser (Feature, HexColor, LegendConfig, LegendEntry, Peak, Threshold, VScale, VScaleRow, chrBackgroundLayer, chrLabelsLayer, drawLegendInSlot, drawVScaleInSlot, featureNormX, groupToMap, renderFixedUI, thresholdRuler, trackLegend, trackLikeLayer)
import Genetics.Browser.Bed (BedFeature)
import Genetics.Browser.Canvas (BatchDrawing, BigDrawing, Label, LabelPlace(LLeft, LCenter), Renderable, RenderableLayer, RenderableLayerHotspots, TrackContainer, _bigDrawing, _drawingBatch, _labels, createAndAddLayer, createAndAddLayer_, renderLayer)
import Genetics.Browser.Canvas (BatchDrawing, Label, LabelPlace(LLeft, LCenter), Renderable, RenderableLayer, RenderableLayerHotspots, TrackContainer, BigDrawing, _bigDrawing, _drawing, _drawingBatch, _labels, createAndAddLayer, createAndAddLayer_, renderLayer)
import Genetics.Browser.Coordinates (CoordSys, CoordSysView, _Segments, aroundPair, normalize, pairSize, pairsOverlap)
import Genetics.Browser.Layer (Component(..), Layer(..), LayerMask(..), LayerType(..), TrackPadding)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), NegLog10(..), _NegLog10)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math as Math
import Network.HTTP.Affjax (get) as Affjax
import Network.HTTP.Affjax.Response (json) as Affjax
import Record (insert) as Record
import Record.Builder (build, insert, merge, modify)
import Record.Extra (class Keys)
import Record.Extra (keys) as Record
import Simple.JSON as Simple
import Type.Prelude (class RowToList, SProxy(SProxy))
import Unsafe.Coerce (unsafeCoerce)

renderGenes :: Map ChrId (Array BedFeature)
            -> _
            -> Map ChrId (Pair Number)
            -> Canvas.Dimensions
            -> List Renderable
renderGenes geneData _ segs size =
  let
      chunks :: Map ChrId (Array _ )
      chunks = mapWithIndex f geneData
        where f :: ChrId -> Array BedFeature -> _
              f chr genes = fromMaybe mempty do
                  seg <- Map.lookup chr segs
                  pure $ filterMap (drawGene size seg) genes

      output :: Tuple (List Renderable) (List Label)
      output = foldMap (foldr f mempty) chunks
        where
              f :: _ -> Tuple _ _ -> Tuple _ _
              f r (Tuple rs ls) = Tuple (inj _bigDrawing r.bigDrawing : rs)
                                           (r.label : ls)

  in (inj _labels $ Tuple.snd output)
     : (Tuple.fst output)

drawGene :: Canvas.Dimensions
         -> Pair Number
         -> BedFeature
         -> Maybe { bigDrawing :: BigDrawing, label :: Label }
drawGene size seg gene =
  let (Pair l r) = gene.position
      segWidth = pairSize seg
      toLocal x = segWidth * (unwrap $ x / gene.frameSize)

      width = toLocal (r - l)

      exon block =
        let p@(Pair exL' size') = toLocal <$> block
        in rectangle exL' zero size' 30.0

      exonSize b = Pair.snd $ toLocal <$> b

      exons _ = let s' = foldMap exon $ filter (\b -> exonSize b > one) gene.feature.blocks
                in (outlined (outlineColor darkgrey <> lineWidth 1.0) s')
                   <> (filled (fillColor lightgrey) s')

      introns _ =
        let s = rectangle 1.5 14.0 (width-1.5) 2.0
        in outlined (outlineColor black <> lineWidth 3.0) s
        <> filled   (fillColor black) s

      drawing _ =
          introns unit
          <> exons unit

  in if width < one
     then Nothing
     else let point :: Point
              point =
                let (Pair offset _) = seg
                in { x: offset + (pairSize seg) * (unwrap $ featureNormX gene)
                   , y: size.height * 0.5 }

              topLeft = point
              bottomRight = point + { x: width, y: 15.0 }

          in pure { bigDrawing: { drawing
                                , topLeft
                                , bottomRight
                                }
                  , label:   { text: gene.feature.geneName
                             , point
                             , gravity: LCenter }  }

type SNPRow chr score r =
  ( "chrId"  :: chr
  , "name" :: String
  , "score" :: score
  | r )

type SNP r =
  Feature (Record (SNPRow ChrId Number r))

parseSNP :: CoordSys ChrId BigInt
         -> Foreign
         -> F (SNP ())
parseSNP cSys a = do
  raw <- Simple.read' a

  let
      snp :: { chr :: String, ps :: Number, p_wald :: Number, rs :: String }
      snp = raw

      feature :: Record (SNPRow ChrId Number ())
      feature =
        { score:      snp.p_wald
        , chrId: wrap snp.chr
        , name:       snp.rs }

      position = (\p -> wrap <$> Pair p p) $ snp.ps

  frameSize <- case Map.lookup feature.chrId (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

type AnnotationRow chr pos r =
  ( "chr"  :: chr
  , "pos"  :: pos
  , "name" :: String
  , "url"  :: Maybe String
  , "gene" :: Maybe String
  | r )

type AnnotationField = { field :: String, value :: Foreign }

type Annotation r =
  Feature (Record (AnnotationRow ChrId Bp
                     ( rest :: List AnnotationField | r )))

annotationFields :: ∀ a b rl.
                    Keys rl
                 => RowToList (AnnotationRow a b ()) rl
                 => List String
annotationFields =
  Record.keys (unsafeCoerce unit :: Record (AnnotationRow a b ()))

parseAnnotation :: CoordSys ChrId BigInt
                -> Foreign
                -> F (Annotation ())
parseAnnotation cSys a = do
  raw <- Simple.read' a
  rest <- parseAnnotationRest a

  let
      feature =
        build
         (insert    (SProxy :: SProxy "rest") rest
         >>> modify (SProxy :: SProxy "chr") ChrId
         >>> modify (SProxy :: SProxy "pos") Bp) raw

      position = (\p -> Pair p p) $ feature.pos

  frameSize <- case Map.lookup feature.chr (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

-- | Partially parse the parts of the annotation record that are *not* in the Annotation type
parseAnnotationRest :: Foreign
                    -> F (List AnnotationField)
parseAnnotationRest a = do
  allFields <- List.fromFoldable <$> Foreign.keys a

  let restFields = allFields `List.difference` annotationFields

  for restFields \field ->
     { field, value: _ } <$> Foreign.readProp field a

-- | A completely dumb default way of rendering arbitrary annotation fields
showAnnotationField :: AnnotationField -> String
showAnnotationField fv = fv.field <> ": " <> unsafeCoerce fv.value

showAnnotation :: Annotation ()
               -> List String
showAnnotation a = (List.fromFoldable
                    [ name, chr, pos ]) <> (map showAnnotationField annot.rest)
  where annot = a.feature
        name = fromMaybe ("SNP: " <> annot.name)
                         (("Gene: " <> _) <$> annot.gene)
        chr = "Chr: " <> show annot.chr
        pos = "Pos: " <> show annot.pos

getSNPs :: CoordSys ChrId BigInt
        -> String
        -> Aff (Map ChrId (Array (SNP ())))
getSNPs cs url = do
  resp <- Affjax.get Affjax.json url

  rawSNPs <-
    case runExcept $ Foreign.readArray $ unsafeCoerce resp.response of
           Left err -> throwError $ error "SNP data is not an array"
           Right as -> pure as

  let parsed =
        partitionMap (runExcept <<< parseSNP cs) rawSNPs

  pure $ groupToMap _.feature.chrId
         $ filter (\f -> Pair.fst (f.position) >= wrap zero)
         $ parsed.right

getAnnotations :: CoordSys ChrId BigInt
               -> String
               -> Aff (Map ChrId (Array (Annotation ())))
getAnnotations cs url = do
  resp <- Affjax.get Affjax.json url

  rawAnnots <- case runExcept
                    $ Foreign.readArray $ unsafeCoerce resp.response of
                 Left err -> throwError $ error "Annotations data is not an array"
                 Right as -> pure as

  let parsed = partitionMap
               (runExcept <<< parseAnnotation cs) rawAnnots

  -- debug/testing stuff
  liftEffect do
    log $ "Raw annotations array length: " <> show (Array.length rawAnnots)
    log $ "Could not parse "
        <> show (length parsed.left :: Int)
        <> " annotations."
    log $ "Successfully parsed "
        <> show (length parsed.right :: Int)
        <> " annotations."

    -- logging with unsafeCoerce lets us examine the raw JS object in the console!
    log $ unsafeCoerce (parsed.right)
  case Array.head parsed.right of
    Nothing -> pure unit
    Just an -> liftEffect do
      log "first annotation: "
      sequence_ (log <$> (("> " <> _) <$> showAnnotation an))

  pure $ groupToMap _.feature.chr parsed.right

peak1 :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Maybe (Tuple (Peak Bp Number (SNP rS))
                      (Array (SNP rS)))
peak1 radius snps = do
  top <- minimumBy (compare `on` _.feature.score) snps

  let covers = radius `aroundPair` top.position
      y = top.feature.score
      {no, yes} = partition (\p -> p.position `pairsOverlap` covers) snps

  pure $ Tuple {covers, y, elements: yes} no

peaks :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Array (Peak Bp Number (SNP rS))
peaks r snps = unfoldr (peak1 r) snps

type AnnotationsConfig =
  { radius    :: Number
  , outline   :: HexColor
  , snpColor  :: HexColor
  , geneColor :: HexColor }

defaultAnnotationsConfig :: AnnotationsConfig
defaultAnnotationsConfig =
  { radius:    5.5
  , outline:   wrap black
  , snpColor:  wrap blue
  , geneColor: wrap red }

annotationLegendEntry :: ∀ r. AnnotationsConfig -> Annotation r -> LegendEntry
annotationLegendEntry conf a =
  let mkIcon color = outlined (outlineColor (unwrap conf.outline) <> lineWidth 2.0)
                  <> filled (fillColor $ unwrap color)
                   $ circle 0.0 0.0 conf.radius
  in case a.feature.gene of
       Nothing -> { text: "SNP name",  icon: mkIcon conf.snpColor  }
       Just gn -> { text: "Gene name", icon: mkIcon conf.geneColor }

annotationLegendTest :: ∀ f r.
                   Foldable f
                => Functor f
                => AnnotationsConfig
                -> Map ChrId (f (Annotation r))
                -> Array LegendEntry
annotationLegendTest config fs = trackLegend (annotationLegendEntry config) as
  where as = Array.concat
             $ Array.fromFoldable
             $ Array.fromFoldable <$> Map.values fs

normYLogScore :: ∀ r.
                 { min :: Number
                 , max :: Number
                 | r }
              -> Number
              -> Number
normYLogScore s =
  normalize s.min s.max <<< unwrap <<< view _NegLog10

dist :: Point -> Point -> Number
dist p1 p2 = Math.sqrt $ x' `Math.pow` 2.0 + y' `Math.pow` 2.0
  where x' = p1.x - p2.x
        y' = p1.y - p2.y

filterSig :: ∀ r1 r2.
             { sig :: Number | r1 }
          -> Map ChrId (Array (SNP r2))
          -> Map ChrId (Array (SNP r2))
filterSig {sig} = map (filter
  (\snp -> snp.feature.score <= (NegLog10 sig ^. re _NegLog10)))

snpsUI :: ∀ c.
          VScale (VScaleRow ())
       -> RenderableLayer c
snpsUI vscale = renderFixedUI (CLeft $ drawVScaleInSlot vscale)

annotationsUI :: ∀ r c.
                 LegendConfig (entries :: Array LegendEntry | r)
              -> RenderableLayer c
annotationsUI legend = renderFixedUI (CRight $ drawLegendInSlot legend)

type SNPConfig
  = { radius :: Number
    , lineWidth :: Number
    , color :: { outline :: HexColor
               , fill    :: HexColor }
    , pixelOffset :: Point }

defaultSNPConfig :: SNPConfig
defaultSNPConfig =
  { radius: 3.75
  , lineWidth: 1.0
  , color: { outline: wrap darkblue, fill: wrap darkblue }
  , pixelOffset: {x: 0.0, y: 0.0}
  }

renderSNPs :: ∀ r1.
              Map ChrId (Array (SNP ()))
           -> { threshold  :: { min  :: Number, max :: Number | r1 }
              , render :: SNPConfig }
           -> Map ChrId (Pair Number)
           -> Canvas.Dimensions
           -> { renderables :: List Renderable
              , hotspots :: Number -> Point -> Array (SNP ()) }
renderSNPs snpData { render, threshold } =
  let radius = render.radius

      snpData' = List.fromFoldable <$> snpData

      drawing =
          let {x,y} = render.pixelOffset
              c     = circle x y radius
              out   = outlined (outlineColor (unwrap render.color.outline) <>
                                lineWidth render.lineWidth) c
              fill  = filled   (fillColor    $ unwrap render.color.fill)    c
          in out <> fill

      drawings :: List (Tuple (SNP ()) Point) -> Array BatchDrawing
      drawings pts = pure { drawing, points: view _2 <$> (Array.fromFoldable pts) }

      pointed :: Canvas.Dimensions
              -> Map ChrId (Pair Number)
              -> List (Tuple (SNP ()) Point)
      pointed size = foldMapWithIndex placeSeg
        where
              place :: Pair Number -> SNP () -> Point
              place seg@(Pair offset _) s =
                { x: offset + (pairSize seg) * (unwrap $ featureNormX s)
                , y: size.height * (one - normYLogScore threshold s.feature.score) }

              placeSeg :: ChrId -> Pair Number -> List (Tuple (SNP ()) Point)
              placeSeg chrId seg = foldMap (map $ fanout identity (place seg))
                                    $ Map.lookup chrId snpData'

      hotspots :: List (Tuple (SNP ()) Point)
               -> Number -> Point
               -> Array (SNP ())
      hotspots pts radius' pt = Array.fromFoldable $ filterMap covers pts
        where covers :: Tuple (SNP ()) Point -> Maybe (SNP ())
              covers (Tuple f fPt)
                | dist fPt pt <= radius + radius'   = Just f
                | otherwise = Nothing

  in \seg size ->
        let pts = pointed size seg
        in { renderables: pure $ inj _drawingBatch $ drawings pts
           , hotspots: hotspots pts }

annotationsForScale :: ∀ r1 r2 i c.
                       CoordSys i c
                    -> Map ChrId (Array (SNP r1))
                    -> Map ChrId (Array (Annotation r2))
                    -> Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
annotationsForScale cSys snps annots =
  mapWithIndex \chr seg -> fromMaybe [] do
    segSnps      <- Map.lookup chr snps
    segAnnots    <- Map.lookup chr annots
    frameSize <- _.frameSize <$> Array.head segSnps

    let rad = (wrap 3.75 * frameSize) / (wrap $ pairSize seg)
        f pk = pk { elements = filter
                          (pairsOverlap pk.covers <<< _.position) segAnnots }

    pure $ f <$> peaks rad segSnps

renderAnnotationPeaks :: ∀ r1 r2.
                         CoordSys ChrId BigInt
                      -> { min :: Number, max :: Number | r1 }
                      -> AnnotationsConfig
                      -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
                      -> Canvas.Dimensions
                      -> Map ChrId (Pair Number)
                      -> { drawingBatch :: Array BatchDrawing
                         , labels :: List Label }
renderAnnotationPeaks cSys vScale conf annoPks cdim =
  let

      curAnnotPeaks :: Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Number Number (Annotation r2)))
      curAnnotPeaks segs = mapWithIndex f annoPks
        where f chr pks = fromMaybe [] do
                  frameSize <- (wrap <<< BigInt.toNumber <<< pairSize)
                             <$> (Map.lookup chr $ cSys ^. _Segments)
                  pxSeg@(Pair l _) <- Map.lookup chr segs

                  let rescale pk = pk { covers = (\x -> l + pairSize pxSeg *
                                          (unwrap $ x / frameSize)) <$> pk.covers
                                      , y = cdim.height * (one - normYLogScore vScale pk.y) }

                  pure $ map rescale pks

      tailHeight = 0.06
      tailPixels = tailHeight * cdim.height
      iconYOffset = 6.5
      labelOffset = 8.0

      -- part of the canvas that a given peak will cover when rendered
      drawingCovers :: ∀ a.
                       Peak Number Number a
                    -> Canvas.Rectangle
      drawingCovers aPeak = {x, y, width: w, height: h}
        where (Pair x _) = aPeak.covers
              w = 14.0  -- hardcoded glyph width in pixels
              gH = (11.0 - iconYOffset) -- hardcoded height
              h = tailPixels + gH * length aPeak.elements
              y = aPeak.y - h

      drawAndLabel :: Peak Number Number (Annotation r2)
                   -> Tuple (Array BatchDrawing) (List Label)
      drawAndLabel aPeak = Tuple [drawing] label
        where
              (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)

              icons = Drawing.translate 0.0 (-tailPixels)
                      $ foldr (\a d -> Drawing.translate 0.0 (-iconYOffset)
                                     $ (annotationLegendEntry conf a).icon <> d)
                          mempty aPeak.elements

              tail = if Array.null aPeak.elements
                then mempty
                else Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                       $ Drawing.path [ {x: 0.0, y: 0.0 }, {x: 0.0, y: -tailPixels }]

              drawing = { drawing: tail <> icons, points: [{x, y: aPeak.y }] }

              -- hardcoded font size because this will be handled by UI.Canvas later
              fontHeight = 14.0
              labelsHeight = length aPeak.elements * fontHeight

              dC = drawingCovers aPeak
                -- if all the labels fit above the icons, they're centered;
                -- otherwise just place them to the left and hope for the best
              {g, y0} = if dC.y > labelsHeight
                then { g: LCenter, y0: dC.y  }
                else { g: LLeft, y0: aPeak.y }

              label = Tuple.snd $ foldr f (Tuple y0 mempty) aPeak.elements
              f a (Tuple y ls) = Tuple (y - labelOffset)
                                    $ List.Cons { text: fromMaybe a.feature.name a.feature.gene
                                                , point: { x, y }
                                                , gravity: g
                                                } ls

      drawAndLabelAll :: Map ChrId (Array (Peak _ _ _))
                      -> Tuple (Array BatchDrawing) (List Label)
      drawAndLabelAll pks = foldMap (foldMap drawAndLabel) pks

  in \segs -> let (Tuple drawingBatch labels) =
                    drawAndLabelAll $ curAnnotPeaks segs
              in { drawingBatch, labels }

renderAnnotations :: ∀ r1 r2 rC.
                    CoordSys ChrId BigInt
                 -> Map ChrId (Array (SNP ()))
                 -> Map ChrId (Array (Annotation r1))
                 -> { threshold :: { min :: Number, max :: Number | r2 }
                    , render :: AnnotationsConfig | rC }
                 -> Map ChrId (Pair Number)
                 -> Canvas.Dimensions
                 -> List Renderable
renderAnnotations cSys sigSnps allAnnots conf =
  let annoPeaks = annotationsForScale cSys sigSnps allAnnots

  in \seg size ->
        let {drawingBatch, labels} =
              renderAnnotationPeaks cSys conf.threshold conf.render (annoPeaks seg) size seg
        in List.fromFoldable
           [ inj _drawingBatch $ drawingBatch
           , inj _labels   $ labels ]

_snps = SProxy :: SProxy "snps"
_annotations = SProxy :: SProxy "annotations"

addChrLayers :: ∀ r.
                { coordinateSystem :: CoordSys ChrId BigInt
                , segmentPadding :: Number | r }
             -> { chrLabels :: { fontSize :: Int }
                , chrBG1 :: HexColor
                , chrBG2 :: HexColor }
             -> TrackContainer
             -> Aff (Pair Number -> CoordSysView -> Aff Unit)
addChrLayers trackConf {chrLabels, chrBG1, chrBG2} tc = do

  rBG  <-
    createAndAddLayer_ tc "chrBackground"
      $ trackLikeLayer trackConf (SProxy :: SProxy "background")
          (Center chrBackgroundLayer)

  rChrLabels <-
    createAndAddLayer_ tc "chrLabels"
      $ chrLabelsLayer trackConf { fontSize: chrLabels.fontSize }

  let chrs o v = do
        let background = { chrBG1
                         , chrBG2
                         , segmentPadding: trackConf.segmentPadding }
            bgConf = { background
                     , view: v }
        traverse_ (renderLayer o bgConf)
                    [ rBG, rChrLabels]

  pure chrs

addGWASLayers :: ∀ r.
                 CoordSys ChrId BigInt
              -> { score :: { min :: Number, max :: Number, sig :: Number }
                 , legend :: LegendConfig ()
                 , vscale :: VScale ()
                 , snps :: SNPConfig
                 , annotations :: AnnotationsConfig
                 , trackHeight :: Number
                 , padding :: TrackPadding }
              -> { snps        :: Map ChrId (Array (SNP ()))
                 , annotations :: Map ChrId (Array (Annotation ())) | r }
              -> TrackContainer
              -> Aff { snps        :: Pair Number -> CoordSysView -> Aff Unit
                     , annotations :: Pair Number -> CoordSysView -> Aff Unit
                     , hotspots    :: Aff (Number -> Point -> Array (SNP ()))
                     , fixedUI     :: Aff Unit }
addGWASLayers coordinateSystem config trackData =
  let threshold = config.score
      vscale = build (merge config.vscale) threshold

      sigSnps = filterSig config.score trackData.snps
      legend = Record.insert (SProxy :: SProxy "entries")
               (annotationLegendTest
                 config.annotations
                 trackData.annotations) config.legend

      segmentPadding = 12.0
      conf = { segmentPadding
             , coordinateSystem }
      cSys = coordinateSystem

      snpLayer :: RenderableLayerHotspots _ _
      snpLayer =
        trackLikeLayer conf _snps
          (Center $ renderSNPs trackData.snps)

      annotationLayer :: RenderableLayer
                         { annotations
                           :: { threshold :: Threshold
                              , render :: AnnotationsConfig }
                         , view :: CoordSysView }
      annotationLayer =
        trackLikeLayer conf _annotations
          (Center $ renderAnnotations cSys sigSnps trackData.annotations)

  in \bc -> do

    rRuler <-
      createAndAddLayer_ bc "ruler"
        $ Layer Fixed NoMask (Center thresholdRuler)

    rSNPs  <-
      createAndAddLayer  bc "snps" snpLayer

    rAnnos <-
      createAndAddLayer_ bc "annotations" annotationLayer

    rVScale <-
      createAndAddLayer_ bc "vscale" $ snpsUI vscale

    rLegend <-
      createAndAddLayer_ bc "legend" $ annotationsUI legend

    let fixedUI = do
          let uiConf = { rulerColor: wrap red, threshold }

          traverse_ (renderLayer (Pair 0.0 0.0) uiConf)
                      [ rVScale, rLegend, rRuler ]

        snps o v = do
          renderLayer o { snps: { threshold, render: config.snps }
                        , view: v } rSNPs

        hotspots = rSNPs.lastHotspots

        annotations o v =
          renderLayer o { annotations: { threshold, render: config.annotations }
                        , view: v } rAnnos

    pure { snps
         , annotations
         , hotspots
         , fixedUI
         }

addGeneLayers :: ∀ r.
                 CoordSys ChrId BigInt
              -> { trackHeight :: Number
                 , padding :: TrackPadding }
              -> { genes        :: Map ChrId (Array BedFeature) }
              -> TrackContainer
              -> Aff { genes :: Pair Number -> CoordSysView -> Aff Unit }
addGeneLayers coordinateSystem config trackData tcont = do

  let
      segmentPadding = 12.0
      conf = { segmentPadding
             , coordinateSystem }

      geneLayer :: _
      geneLayer =
        trackLikeLayer conf (SProxy :: SProxy "genes")
          (Center $ renderGenes trackData.genes)

  rGenes <-
    createAndAddLayer_ tcont "genes" geneLayer

  let genes o v =
        renderLayer o { genes: {}, view: v } rGenes

  pure { genes }

module Genetics.Browser.Demo where

import Prelude

import Color (black)
import Color.Scheme.Clrs (blue, red)
import Color.Scheme.X11 (darkblue, darkgrey, lightgrey)
import Control.Monad.Except (runExcept, throwError)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Filterable (filter, filterMap, partition, partitionMap)
import Data.Foldable (class Foldable, foldMap, foldr, length, minimumBy, sequence_, traverse_)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.Function (on)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (re, view, (^.))
import Data.Lens.Lens.Tuple (_2)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Strong (fanout)
import Data.Traversable (for)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple as Tuple
import Data.Unfoldable (unfoldr)
import Data.Variant (inj)
import Effect.Aff (Aff, error)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Foreign (F, Foreign, ForeignError(ForeignError))
import Foreign (readArray) as Foreign
import Foreign.Index (readProp) as Foreign
import Foreign.Keys (keys) as Foreign
import Genetics.Browser (Feature, HexColor, LegendConfig, LegendEntry, Peak, Threshold, VScale, VScaleRow, chrBackgroundLayer, chrLabelsLayer, drawLegendInSlot, drawVScaleInSlot, featureNormX, groupToMap, renderFixedUI, thresholdRuler, trackLegend, trackLikeLayer)
import Genetics.Browser.Bed (BedFeature)
import Genetics.Browser.Canvas (BatchDrawing, BigDrawing, Label, LabelPlace(LLeft, LCenter), Renderable, RenderableLayer, RenderableLayerHotspots, TrackContainer, _bigDrawing, _drawingBatch, _labels, createAndAddLayer, createAndAddLayer_, renderLayer)
import Genetics.Browser.Canvas (BatchDrawing, Label, LabelPlace(LLeft, LCenter), Renderable, RenderableLayer, RenderableLayerHotspots, TrackContainer, BigDrawing, _bigDrawing, _drawing, _drawingBatch, _labels, createAndAddLayer, createAndAddLayer_, renderLayer)
import Genetics.Browser.Coordinates (CoordSys, CoordSysView, _Segments, aroundPair, normalize, pairSize, pairsOverlap)
import Genetics.Browser.Layer (Component(..), Layer(..), LayerMask(..), LayerType(..), TrackPadding)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), NegLog10(..), _NegLog10)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math as Math
import Network.HTTP.Affjax (get) as Affjax
import Network.HTTP.Affjax.Response (json) as Affjax
import Record (insert) as Record
import Record.Builder (build, insert, merge, modify)
import Record.Extra (class Keys)
import Record.Extra (keys) as Record
import Simple.JSON as Simple
import Type.Prelude (class RowToList, SProxy(SProxy))
import Unsafe.Coerce (unsafeCoerce)

renderGenes :: Map ChrId (Array BedFeature)
            -> _
            -> Map ChrId (Pair Number)
            -> Canvas.Dimensions
            -> List Renderable
renderGenes geneData _ segs size =
  let
      output = foldMapWithIndex f geneData
        where f :: ChrId -> Array BedFeature -> _
              f chr genes = fromMaybe mempty do
                  seg <- Map.lookup chr segs
                  pure $ foldMap (drawGene size seg) genes

  in  (inj _bigDrawing <$> output.bigDrawing)
   <> (pure $ inj _labels $ output.label)

drawGene :: Canvas.Dimensions
         -> Pair Number
         -> BedFeature
         -> { bigDrawing :: List BigDrawing, label :: List Label }
drawGene size seg gene =
  let (Pair l r) = gene.position
      segWidth = pairSize seg
      toLocal x = segWidth * (unwrap $ x / gene.frameSize)

      width = toLocal (r - l)

      exon block =
        let p@(Pair exL' size') = toLocal <$> block
            s = if size' < one then mempty else rectangle exL' zero size' 30.0
        in s

      exons _ = let s' = foldMap exon gene.feature.blocks
                in (outlined (outlineColor darkgrey <> lineWidth 1.0) s')
                   <> (filled (fillColor lightgrey) s')

      introns _ =
        let s = rectangle 1.5 14.0 (width-1.5) 2.0
        in outlined (outlineColor black <> lineWidth 3.0) s
        <> filled   (fillColor black) s

      drawing _ =
          introns unit
          <> exons unit

  in if width < one
     then mempty
     else let point :: Point
              point =
                let (Pair offset _) = seg
                in { x: offset + (pairSize seg) * (unwrap $ featureNormX gene)
                   , y: size.height * 0.5 }

              topLeft = point
              bottomRight = point + { x: width, y: 15.0 }

          in { bigDrawing: pure { drawing
                                , topLeft
                                , bottomRight
                                }
             , label:   pure { text: gene.feature.geneName
                             , point
                             , gravity: LCenter }  }

type SNPRow chr score r =
  ( "chrId"  :: chr
  , "name" :: String
  , "score" :: score
  | r )

type SNP r =
  Feature (Record (SNPRow ChrId Number r))

parseSNP :: CoordSys ChrId BigInt
         -> Foreign
         -> F (SNP ())
parseSNP cSys a = do
  raw <- Simple.read' a

  let
      snp :: { chr :: String, ps :: Number, p_wald :: Number, rs :: String }
      snp = raw

      feature :: Record (SNPRow ChrId Number ())
      feature =
        { score:      snp.p_wald
        , chrId: wrap snp.chr
        , name:       snp.rs }

      position = (\p -> wrap <$> Pair p p) $ snp.ps

  frameSize <- case Map.lookup feature.chrId (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

type AnnotationRow chr pos r =
  ( "chr"  :: chr
  , "pos"  :: pos
  , "name" :: String
  , "url"  :: Maybe String
  , "gene" :: Maybe String
  | r )

type AnnotationField = { field :: String, value :: Foreign }

type Annotation r =
  Feature (Record (AnnotationRow ChrId Bp
                     ( rest :: List AnnotationField | r )))

annotationFields :: ∀ a b rl.
                    Keys rl
                 => RowToList (AnnotationRow a b ()) rl
                 => List String
annotationFields =
  Record.keys (unsafeCoerce unit :: Record (AnnotationRow a b ()))

parseAnnotation :: CoordSys ChrId BigInt
                -> Foreign
                -> F (Annotation ())
parseAnnotation cSys a = do
  raw <- Simple.read' a
  rest <- parseAnnotationRest a

  let
      feature =
        build
         (insert    (SProxy :: SProxy "rest") rest
         >>> modify (SProxy :: SProxy "chr") ChrId
         >>> modify (SProxy :: SProxy "pos") Bp) raw

      position = (\p -> Pair p p) $ feature.pos

  frameSize <- case Map.lookup feature.chr (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

-- | Partially parse the parts of the annotation record that are *not* in the Annotation type
parseAnnotationRest :: Foreign
                    -> F (List AnnotationField)
parseAnnotationRest a = do
  allFields <- List.fromFoldable <$> Foreign.keys a

  let restFields = allFields `List.difference` annotationFields

  for restFields \field ->
     { field, value: _ } <$> Foreign.readProp field a

-- | A completely dumb default way of rendering arbitrary annotation fields
showAnnotationField :: AnnotationField -> String
showAnnotationField fv = fv.field <> ": " <> unsafeCoerce fv.value

showAnnotation :: Annotation ()
               -> List String
showAnnotation a = (List.fromFoldable
                    [ name, chr, pos ]) <> (map showAnnotationField annot.rest)
  where annot = a.feature
        name = fromMaybe ("SNP: " <> annot.name)
                         (("Gene: " <> _) <$> annot.gene)
        chr = "Chr: " <> show annot.chr
        pos = "Pos: " <> show annot.pos

getSNPs :: CoordSys ChrId BigInt
        -> String
        -> Aff (Map ChrId (Array (SNP ())))
getSNPs cs url = do
  resp <- Affjax.get Affjax.json url

  rawSNPs <-
    case runExcept $ Foreign.readArray $ unsafeCoerce resp.response of
           Left err -> throwError $ error "SNP data is not an array"
           Right as -> pure as

  let parsed =
        partitionMap (runExcept <<< parseSNP cs) rawSNPs

  pure $ groupToMap _.feature.chrId
         $ filter (\f -> Pair.fst (f.position) >= wrap zero)
         $ parsed.right

getAnnotations :: CoordSys ChrId BigInt
               -> String
               -> Aff (Map ChrId (Array (Annotation ())))
getAnnotations cs url = do
  resp <- Affjax.get Affjax.json url

  rawAnnots <- case runExcept
                    $ Foreign.readArray $ unsafeCoerce resp.response of
                 Left err -> throwError $ error "Annotations data is not an array"
                 Right as -> pure as

  let parsed = partitionMap
               (runExcept <<< parseAnnotation cs) rawAnnots

  -- debug/testing stuff
  liftEffect do
    log $ "Raw annotations array length: " <> show (Array.length rawAnnots)
    log $ "Could not parse "
        <> show (length parsed.left :: Int)
        <> " annotations."
    log $ "Successfully parsed "
        <> show (length parsed.right :: Int)
        <> " annotations."

    -- logging with unsafeCoerce lets us examine the raw JS object in the console!
    log $ unsafeCoerce (parsed.right)
  case Array.head parsed.right of
    Nothing -> pure unit
    Just an -> liftEffect do
      log "first annotation: "
      sequence_ (log <$> (("> " <> _) <$> showAnnotation an))

  pure $ groupToMap _.feature.chr parsed.right

peak1 :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Maybe (Tuple (Peak Bp Number (SNP rS))
                      (Array (SNP rS)))
peak1 radius snps = do
  top <- minimumBy (compare `on` _.feature.score) snps

  let covers = radius `aroundPair` top.position
      y = top.feature.score
      {no, yes} = partition (\p -> p.position `pairsOverlap` covers) snps

  pure $ Tuple {covers, y, elements: yes} no

peaks :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Array (Peak Bp Number (SNP rS))
peaks r snps = unfoldr (peak1 r) snps

type AnnotationsConfig =
  { radius    :: Number
  , outline   :: HexColor
  , snpColor  :: HexColor
  , geneColor :: HexColor }

defaultAnnotationsConfig :: AnnotationsConfig
defaultAnnotationsConfig =
  { radius:    5.5
  , outline:   wrap black
  , snpColor:  wrap blue
  , geneColor: wrap red }

annotationLegendEntry :: ∀ r. AnnotationsConfig -> Annotation r -> LegendEntry
annotationLegendEntry conf a =
  let mkIcon color = outlined (outlineColor (unwrap conf.outline) <> lineWidth 2.0)
                  <> filled (fillColor $ unwrap color)
                   $ circle 0.0 0.0 conf.radius
  in case a.feature.gene of
       Nothing -> { text: "SNP name",  icon: mkIcon conf.snpColor  }
       Just gn -> { text: "Gene name", icon: mkIcon conf.geneColor }

annotationLegendTest :: ∀ f r.
                   Foldable f
                => Functor f
                => AnnotationsConfig
                -> Map ChrId (f (Annotation r))
                -> Array LegendEntry
annotationLegendTest config fs = trackLegend (annotationLegendEntry config) as
  where as = Array.concat
             $ Array.fromFoldable
             $ Array.fromFoldable <$> Map.values fs

normYLogScore :: ∀ r.
                 { min :: Number
                 , max :: Number
                 | r }
              -> Number
              -> Number
normYLogScore s =
  normalize s.min s.max <<< unwrap <<< view _NegLog10

dist :: Point -> Point -> Number
dist p1 p2 = Math.sqrt $ x' `Math.pow` 2.0 + y' `Math.pow` 2.0
  where x' = p1.x - p2.x
        y' = p1.y - p2.y

filterSig :: ∀ r1 r2.
             { sig :: Number | r1 }
          -> Map ChrId (Array (SNP r2))
          -> Map ChrId (Array (SNP r2))
filterSig {sig} = map (filter
  (\snp -> snp.feature.score <= (NegLog10 sig ^. re _NegLog10)))

snpsUI :: ∀ c.
          VScale (VScaleRow ())
       -> RenderableLayer c
snpsUI vscale = renderFixedUI (CLeft $ drawVScaleInSlot vscale)

annotationsUI :: ∀ r c.
                 LegendConfig (entries :: Array LegendEntry | r)
              -> RenderableLayer c
annotationsUI legend = renderFixedUI (CRight $ drawLegendInSlot legend)

type SNPConfig
  = { radius :: Number
    , lineWidth :: Number
    , color :: { outline :: HexColor
               , fill    :: HexColor }
    , pixelOffset :: Point }

defaultSNPConfig :: SNPConfig
defaultSNPConfig =
  { radius: 3.75
  , lineWidth: 1.0
  , color: { outline: wrap darkblue, fill: wrap darkblue }
  , pixelOffset: {x: 0.0, y: 0.0}
  }

renderSNPs :: ∀ r1.
              Map ChrId (Array (SNP ()))
           -> { threshold  :: { min  :: Number, max :: Number | r1 }
              , render :: SNPConfig }
           -> Map ChrId (Pair Number)
           -> Canvas.Dimensions
           -> { renderables :: List Renderable
              , hotspots :: Number -> Point -> Array (SNP ()) }
renderSNPs snpData { render, threshold } =
  let radius = render.radius

      snpData' = List.fromFoldable <$> snpData

      drawing =
          let {x,y} = render.pixelOffset
              c     = circle x y radius
              out   = outlined (outlineColor (unwrap render.color.outline) <>
                                lineWidth render.lineWidth) c
              fill  = filled   (fillColor    $ unwrap render.color.fill)    c
          in out <> fill

      drawings :: List (Tuple (SNP ()) Point) -> Array BatchDrawing
      drawings pts = pure { drawing, points: view _2 <$> (Array.fromFoldable pts) }

      pointed :: Canvas.Dimensions
              -> Map ChrId (Pair Number)
              -> List (Tuple (SNP ()) Point)
      pointed size = foldMapWithIndex placeSeg
        where
              place :: Pair Number -> SNP () -> Point
              place seg@(Pair offset _) s =
                { x: offset + (pairSize seg) * (unwrap $ featureNormX s)
                , y: size.height * (one - normYLogScore threshold s.feature.score) }

              placeSeg :: ChrId -> Pair Number -> List (Tuple (SNP ()) Point)
              placeSeg chrId seg = foldMap (map $ fanout identity (place seg))
                                    $ Map.lookup chrId snpData'

      hotspots :: List (Tuple (SNP ()) Point)
               -> Number -> Point
               -> Array (SNP ())
      hotspots pts radius' pt = Array.fromFoldable $ filterMap covers pts
        where covers :: Tuple (SNP ()) Point -> Maybe (SNP ())
              covers (Tuple f fPt)
                | dist fPt pt <= radius + radius'   = Just f
                | otherwise = Nothing

  in \seg size ->
        let pts = pointed size seg
        in { renderables: pure $ inj _drawingBatch $ drawings pts
           , hotspots: hotspots pts }

annotationsForScale :: ∀ r1 r2 i c.
                       CoordSys i c
                    -> Map ChrId (Array (SNP r1))
                    -> Map ChrId (Array (Annotation r2))
                    -> Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
annotationsForScale cSys snps annots =
  mapWithIndex \chr seg -> fromMaybe [] do
    segSnps      <- Map.lookup chr snps
    segAnnots    <- Map.lookup chr annots
    frameSize <- _.frameSize <$> Array.head segSnps

    let rad = (wrap 3.75 * frameSize) / (wrap $ pairSize seg)
        f pk = pk { elements = filter
                          (pairsOverlap pk.covers <<< _.position) segAnnots }

    pure $ f <$> peaks rad segSnps

renderAnnotationPeaks :: ∀ r1 r2.
                         CoordSys ChrId BigInt
                      -> { min :: Number, max :: Number | r1 }
                      -> AnnotationsConfig
                      -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
                      -> Canvas.Dimensions
                      -> Map ChrId (Pair Number)
                      -> { drawingBatch :: Array BatchDrawing
                         , labels :: List Label }
renderAnnotationPeaks cSys vScale conf annoPks cdim =
  let

      curAnnotPeaks :: Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Number Number (Annotation r2)))
      curAnnotPeaks segs = mapWithIndex f annoPks
        where f chr pks = fromMaybe [] do
                  frameSize <- (wrap <<< BigInt.toNumber <<< pairSize)
                             <$> (Map.lookup chr $ cSys ^. _Segments)
                  pxSeg@(Pair l _) <- Map.lookup chr segs

                  let rescale pk = pk { covers = (\x -> l + pairSize pxSeg *
                                          (unwrap $ x / frameSize)) <$> pk.covers
                                      , y = cdim.height * (one - normYLogScore vScale pk.y) }

                  pure $ map rescale pks

      tailHeight = 0.06
      tailPixels = tailHeight * cdim.height
      iconYOffset = 6.5
      labelOffset = 8.0

      -- part of the canvas that a given peak will cover when rendered
      drawingCovers :: ∀ a.
                       Peak Number Number a
                    -> Canvas.Rectangle
      drawingCovers aPeak = {x, y, width: w, height: h}
        where (Pair x _) = aPeak.covers
              w = 14.0  -- hardcoded glyph width in pixels
              gH = (11.0 - iconYOffset) -- hardcoded height
              h = tailPixels + gH * length aPeak.elements
              y = aPeak.y - h

      drawAndLabel :: Peak Number Number (Annotation r2)
                   -> Tuple (Array BatchDrawing) (List Label)
      drawAndLabel aPeak = Tuple [drawing] label
        where
              (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)

              icons = Drawing.translate 0.0 (-tailPixels)
                      $ foldr (\a d -> Drawing.translate 0.0 (-iconYOffset)
                                     $ (annotationLegendEntry conf a).icon <> d)
                          mempty aPeak.elements

              tail = if Array.null aPeak.elements
                then mempty
                else Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                       $ Drawing.path [ {x: 0.0, y: 0.0 }, {x: 0.0, y: -tailPixels }]

              drawing = { drawing: tail <> icons, points: [{x, y: aPeak.y }] }

              -- hardcoded font size because this will be handled by UI.Canvas later
              fontHeight = 14.0
              labelsHeight = length aPeak.elements * fontHeight

              dC = drawingCovers aPeak
                -- if all the labels fit above the icons, they're centered;
                -- otherwise just place them to the left and hope for the best
              {g, y0} = if dC.y > labelsHeight
                then { g: LCenter, y0: dC.y  }
                else { g: LLeft, y0: aPeak.y }

              label = Tuple.snd $ foldr f (Tuple y0 mempty) aPeak.elements
              f a (Tuple y ls) = Tuple (y - labelOffset)
                                    $ List.Cons { text: fromMaybe a.feature.name a.feature.gene
                                                , point: { x, y }
                                                , gravity: g
                                                } ls

      drawAndLabelAll :: Map ChrId (Array (Peak _ _ _))
                      -> Tuple (Array BatchDrawing) (List Label)
      drawAndLabelAll pks = foldMap (foldMap drawAndLabel) pks

  in \segs -> let (Tuple drawingBatch labels) =
                    drawAndLabelAll $ curAnnotPeaks segs
              in { drawingBatch, labels }

renderAnnotations :: ∀ r1 r2 rC.
                    CoordSys ChrId BigInt
                 -> Map ChrId (Array (SNP ()))
                 -> Map ChrId (Array (Annotation r1))
                 -> { threshold :: { min :: Number, max :: Number | r2 }
                    , render :: AnnotationsConfig | rC }
                 -> Map ChrId (Pair Number)
                 -> Canvas.Dimensions
                 -> List Renderable
renderAnnotations cSys sigSnps allAnnots conf =
  let annoPeaks = annotationsForScale cSys sigSnps allAnnots

  in \seg size ->
        let {drawingBatch, labels} =
              renderAnnotationPeaks cSys conf.threshold conf.render (annoPeaks seg) size seg
        in List.fromFoldable
           [ inj _drawingBatch $ drawingBatch
           , inj _labels   $ labels ]

_snps = SProxy :: SProxy "snps"
_annotations = SProxy :: SProxy "annotations"

addChrLayers :: ∀ r.
                { coordinateSystem :: CoordSys ChrId BigInt
                , segmentPadding :: Number | r }
             -> { chrLabels :: { fontSize :: Int }
                , chrBG1 :: HexColor
                , chrBG2 :: HexColor }
             -> TrackContainer
             -> Aff (Pair Number -> CoordSysView -> Aff Unit)
addChrLayers trackConf {chrLabels, chrBG1, chrBG2} tc = do

  rBG  <-
    createAndAddLayer_ tc "chrBackground"
      $ trackLikeLayer trackConf (SProxy :: SProxy "background")
          (Center chrBackgroundLayer)

  rChrLabels <-
    createAndAddLayer_ tc "chrLabels"
      $ chrLabelsLayer trackConf { fontSize: chrLabels.fontSize }

  let chrs o v = do
        let background = { chrBG1
                         , chrBG2
                         , segmentPadding: trackConf.segmentPadding }
            bgConf = { background
                     , view: v }
        traverse_ (renderLayer o bgConf)
                    [ rBG, rChrLabels]

  pure chrs

addGWASLayers :: ∀ r.
                 CoordSys ChrId BigInt
              -> { score :: { min :: Number, max :: Number, sig :: Number }
                 , legend :: LegendConfig ()
                 , vscale :: VScale ()
                 , snps :: SNPConfig
                 , annotations :: AnnotationsConfig
                 , trackHeight :: Number
                 , padding :: TrackPadding }
              -> { snps        :: Map ChrId (Array (SNP ()))
                 , annotations :: Map ChrId (Array (Annotation ())) | r }
              -> TrackContainer
              -> Aff { snps        :: Pair Number -> CoordSysView -> Aff Unit
                     , annotations :: Pair Number -> CoordSysView -> Aff Unit
                     , hotspots    :: Aff (Number -> Point -> Array (SNP ()))
                     , fixedUI     :: Aff Unit }
addGWASLayers coordinateSystem config trackData =
  let threshold = config.score
      vscale = build (merge config.vscale) threshold

      sigSnps = filterSig config.score trackData.snps
      legend = Record.insert (SProxy :: SProxy "entries")
               (annotationLegendTest
                 config.annotations
                 trackData.annotations) config.legend

      segmentPadding = 12.0
      conf = { segmentPadding
             , coordinateSystem }
      cSys = coordinateSystem

      snpLayer :: RenderableLayerHotspots _ _
      snpLayer =
        trackLikeLayer conf _snps
          (Center $ renderSNPs trackData.snps)

      annotationLayer :: RenderableLayer
                         { annotations
                           :: { threshold :: Threshold
                              , render :: AnnotationsConfig }
                         , view :: CoordSysView }
      annotationLayer =
        trackLikeLayer conf _annotations
          (Center $ renderAnnotations cSys sigSnps trackData.annotations)

  in \bc -> do

    rRuler <-
      createAndAddLayer_ bc "ruler"
        $ Layer Fixed NoMask (Center thresholdRuler)

    rSNPs  <-
      createAndAddLayer  bc "snps" snpLayer

    rAnnos <-
      createAndAddLayer_ bc "annotations" annotationLayer

    rVScale <-
      createAndAddLayer_ bc "vscale" $ snpsUI vscale

    rLegend <-
      createAndAddLayer_ bc "legend" $ annotationsUI legend

    let fixedUI = do
          let uiConf = { rulerColor: wrap red, threshold }

          traverse_ (renderLayer (Pair 0.0 0.0) uiConf)
                      [ rVScale, rLegend, rRuler ]

        snps o v = do
          renderLayer o { snps: { threshold, render: config.snps }
                        , view: v } rSNPs

        hotspots = rSNPs.lastHotspots

        annotations o v =
          renderLayer o { annotations: { threshold, render: config.annotations }
                        , view: v } rAnnos

    pure { snps
         , annotations
         , hotspots
         , fixedUI
         }

addGeneLayers :: ∀ r.
                 CoordSys ChrId BigInt
              -> { trackHeight :: Number
                 , padding :: TrackPadding }
              -> { genes        :: Map ChrId (Array BedFeature) }
              -> TrackContainer
              -> Aff { genes :: Pair Number -> CoordSysView -> Aff Unit }
addGeneLayers coordinateSystem config trackData tcont = do

  let
      segmentPadding = 12.0
      conf = { segmentPadding
             , coordinateSystem }

      geneLayer :: _
      geneLayer =
        trackLikeLayer conf (SProxy :: SProxy "genes")
          (Center $ renderGenes trackData.genes)

  rGenes <-
    createAndAddLayer_ tcont "genes" geneLayer

  let genes o v =
        renderLayer o { genes: {}, view: v } rGenes

  pure { genes }


Revert changes to string property

Revert changes to string property

module Halogen.VDom.DOM.Prop
  ( Prop(..)
  , ElemRef(..)
  , PropValue
  , propFromString
  , propFromBoolean
  , propFromInt
  , propFromNumber
  , buildProp
  ) where

import Prelude

import Data.Function.Uncurried as Fn
import Data.Maybe (Maybe(..))
import Data.Nullable (null, toNullable)
import Data.Tuple (Tuple(..), fst, snd)
import Effect (Effect)
import Effect.Ref as Ref
import Effect.Uncurried as EFn
import Foreign (typeOf)
import Foreign.Object as Object
import Halogen.VDom as V
import Halogen.VDom.Machine (Step'(..), mkStep)
import Halogen.VDom.Types (Namespace(..))
import Halogen.VDom.Util as Util
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Element (Element) as DOM
import Web.Event.Event (EventType(..), Event) as DOM
import Web.Event.EventTarget (eventListener) as DOM

-- | Attributes, properties, event handlers, and element lifecycles.
-- | Parameterized by the type of handlers outputs.
data Prop a
  = Attribute (Maybe Namespace) String String
  | Property String PropValue
  | Handler DOM.EventType (DOM.Event → Maybe a)
  | Ref (ElemRef DOM.Element → Maybe a)

instance functorProp ∷ Functor Prop where
  map f (Handler ty g) = Handler ty (map f <$> g)
  map f (Ref g) = Ref (map f <$> g)
  map f p = unsafeCoerce p

data ElemRef a
  = Created a
  | Removed a

instance functorElemRef ∷ Functor ElemRef where
  map f (Created a) = Created (f a)
  map f (Removed a) = Removed (f a)

foreign import data PropValue ∷ Type

propFromString ∷ String → PropValue
propFromString = unsafeCoerce

propFromBoolean ∷ Boolean → PropValue
propFromBoolean = unsafeCoerce

propFromInt ∷ Int → PropValue
propFromInt = unsafeCoerce

propFromNumber ∷ Number → PropValue
propFromNumber = unsafeCoerce

-- | A `Machine`` for applying attributes, properties, and event handlers.
-- | An emitter effect must be provided to respond to events. For example,
-- | to allow arbitrary effects in event handlers, one could use `id`.
buildProp
  ∷ ∀ a
  . (a → Effect Unit)
  → DOM.Element
  → V.Machine (Array (Prop a)) Unit
buildProp emit el = renderProp
  where
  renderProp = EFn.mkEffectFn1 \ps1 → do
    events ← Util.newMutMap
    ps1' ← EFn.runEffectFn3 Util.strMapWithIxE ps1 propToStrKey (applyProp events)
    let
      state =
        { events: Util.unsafeFreeze events
        , props: ps1'
        }
    pure $ mkStep $ Step unit state patchProp haltProp

  patchProp = EFn.mkEffectFn2 \state ps2 → do
    events ← Util.newMutMap
    let
      { events: prevEvents, props: ps1 } = state
      onThese = Fn.runFn2 diffProp prevEvents events
      onThis = removeProp prevEvents
      onThat = applyProp events
    props ← EFn.runEffectFn6 Util.diffWithKeyAndIxE ps1 ps2 propToStrKey onThese onThis onThat
    let
      nextState =
        { events: Util.unsafeFreeze events
        , props
        }
    pure $ mkStep $ Step unit nextState patchProp haltProp

  haltProp = EFn.mkEffectFn1 \state → do
    case Object.lookup "ref" state.props of
      Just (Ref f) →
        EFn.runEffectFn1 mbEmit (f (Removed el))
      _ → pure unit

  mbEmit = EFn.mkEffectFn1 case _ of
    Just a → emit a
    _ → pure unit

  applyProp events = EFn.mkEffectFn3 \_ _ v →
    case v of
      Attribute ns attr val → do
        EFn.runEffectFn4 Util.setAttribute (toNullable ns) attr val el
        pure v
      Property prop val → do
        EFn.runEffectFn3 setProperty prop val el
        pure v
      Handler (DOM.EventType ty) f → do
        case Fn.runFn2 Util.unsafeGetAny ty events of
          handler | Fn.runFn2 Util.unsafeHasAny ty events → do
            Ref.write f (snd handler)
            pure v
          _ → do
            ref ← Ref.new f
            listener ← DOM.eventListener \ev → do
              f' ← Ref.read ref
              EFn.runEffectFn1 mbEmit (f' ev)
            EFn.runEffectFn3 Util.pokeMutMap ty (Tuple listener ref) events
            EFn.runEffectFn3 Util.addEventListener ty listener el
            pure v
      Ref f → do
        EFn.runEffectFn1 mbEmit (f (Created el))
        pure v

  diffProp = Fn.mkFn2 \prevEvents events → EFn.mkEffectFn4 \_ _ v1 v2 →
    case v1, v2 of
      Attribute _ _ val1, Attribute ns2 attr2 val2 →
        if val1 == val2
          then pure v2
          else do
            EFn.runEffectFn4 Util.setAttribute (toNullable ns2) attr2 val2 el
            pure v2
      Property _ val1, Property prop2 val2 →
        case Fn.runFn2 Util.refEq val1 val2, prop2 of
          true, _ →
            pure v2
          _, "value" → do
            let elVal = Fn.runFn2 unsafeGetProperty "value" el
            if Fn.runFn2 Util.refEq elVal val2
              then pure v2
              else do
                EFn.runEffectFn3 setProperty prop2 val2 el
                pure v2
          _, _ → do
            EFn.runEffectFn3 setProperty prop2 val2 el
            pure v2
      Handler _ _, Handler (DOM.EventType ty) f → do
        let
          handler = Fn.runFn2 Util.unsafeLookup ty prevEvents
        Ref.write f (snd handler)
        EFn.runEffectFn3 Util.pokeMutMap ty handler events
        pure v2
      _, _ →
        pure v2

  removeProp prevEvents = EFn.mkEffectFn2 \_ v →
    case v of
      Attribute ns attr _ →
        EFn.runEffectFn3 Util.removeAttribute (toNullable ns) attr el
      Property prop _ →
        EFn.runEffectFn2 removeProperty prop el
      Handler (DOM.EventType ty) _ → do
        let
          handler = Fn.runFn2 Util.unsafeLookup ty prevEvents
        EFn.runEffectFn3 Util.removeEventListener ty (fst handler) el
      Ref _ →
        pure unit

propToStrKey ∷ ∀ i. Prop i → String
propToStrKey = case _ of
  Attribute (Just (Namespace ns)) attr _ → "attr/" <> ns <> ":" <> attr
  Attribute _ attr _ → "attr/:" <> attr
  Property prop _ → "prop/" <> prop
  Handler (DOM.EventType ty) _ → "handler/" <> ty
  Ref _ → "ref"

setProperty ∷ EFn.EffectFn3 String PropValue DOM.Element Unit
setProperty = Util.unsafeSetAny

unsafeGetProperty ∷ Fn.Fn2 String DOM.Element PropValue
unsafeGetProperty = Util.unsafeGetAny

removeProperty ∷ EFn.EffectFn2 String DOM.Element Unit
removeProperty = EFn.mkEffectFn2 \key el →
  EFn.runEffectFn3 Util.hasAttribute null key el >>= case _ of
    true -> EFn.runEffectFn3 Util.removeAttribute null key el
    false -> case typeOf (Fn.runFn2 Util.unsafeGetAny key el) of
      "string" → EFn.runEffectFn3 Util.unsafeSetAny key "" el
      _        → case key of
        "rowSpan" → EFn.runEffectFn3 Util.unsafeSetAny key 1 el
        "colSpan" → EFn.runEffectFn3 Util.unsafeSetAny key 1 el
        _ → EFn.runEffectFn3 Util.unsafeSetAny key Util.jsUndefined el

module Halogen.VDom.DOM.Prop
  ( Prop(..)
  , ElemRef(..)
  , PropValue
  , propFromString
  , propFromBoolean
  , propFromInt
  , propFromNumber
  , buildProp
  ) where

import Prelude

import Data.Function.Uncurried as Fn
import Data.Maybe (Maybe(..))
import Data.Nullable (null, toNullable)
import Data.Tuple (Tuple(..), fst, snd)
import Effect (Effect)
import Effect.Ref as Ref
import Effect.Uncurried as EFn
import Foreign (typeOf)
import Foreign.Object as Object
import Halogen.VDom as V
import Halogen.VDom.Machine (Step'(..), mkStep)
import Halogen.VDom.Types (Namespace(..))
import Halogen.VDom.Util as Util
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Element (Element) as DOM
import Web.Event.Event (EventType(..), Event) as DOM
import Web.Event.EventTarget (eventListener) as DOM

-- | Attributes, properties, event handlers, and element lifecycles.
-- | Parameterized by the type of handlers outputs.
data Prop a
  = Attribute (Maybe Namespace) String String
  | Property String PropValue
  | Handler DOM.EventType (DOM.Event → Maybe a)
  | Ref (ElemRef DOM.Element → Maybe a)

instance functorProp ∷ Functor Prop where
  map f (Handler ty g) = Handler ty (map f <$> g)
  map f (Ref g) = Ref (map f <$> g)
  map f p = unsafeCoerce p

data ElemRef a
  = Created a
  | Removed a

instance functorElemRef ∷ Functor ElemRef where
  map f (Created a) = Created (f a)
  map f (Removed a) = Removed (f a)

foreign import data PropValue ∷ Type

propFromString ∷ String → PropValue
propFromString = unsafeCoerce

propFromBoolean ∷ Boolean → PropValue
propFromBoolean = unsafeCoerce

propFromInt ∷ Int → PropValue
propFromInt = unsafeCoerce

propFromNumber ∷ Number → PropValue
propFromNumber = unsafeCoerce

-- | A `Machine`` for applying attributes, properties, and event handlers.
-- | An emitter effect must be provided to respond to events. For example,
-- | to allow arbitrary effects in event handlers, one could use `id`.
buildProp
  ∷ ∀ a
  . (a → Effect Unit)
  → DOM.Element
  → V.Machine (Array (Prop a)) Unit
buildProp emit el = renderProp
  where
  renderProp = EFn.mkEffectFn1 \ps1 → do
    events ← Util.newMutMap
    ps1' ← EFn.runEffectFn3 Util.strMapWithIxE ps1 propToStrKey (applyProp events)
    let
      state =
        { events: Util.unsafeFreeze events
        , props: ps1'
        }
    pure $ mkStep $ Step unit state patchProp haltProp

  patchProp = EFn.mkEffectFn2 \state ps2 → do
    events ← Util.newMutMap
    let
      { events: prevEvents, props: ps1 } = state
      onThese = Fn.runFn2 diffProp prevEvents events
      onThis = removeProp prevEvents
      onThat = applyProp events
    props ← EFn.runEffectFn6 Util.diffWithKeyAndIxE ps1 ps2 propToStrKey onThese onThis onThat
    let
      nextState =
        { events: Util.unsafeFreeze events
        , props
        }
    pure $ mkStep $ Step unit nextState patchProp haltProp

  haltProp = EFn.mkEffectFn1 \state → do
    case Object.lookup "ref" state.props of
      Just (Ref f) →
        EFn.runEffectFn1 mbEmit (f (Removed el))
      _ → pure unit

  mbEmit = EFn.mkEffectFn1 case _ of
    Just a → emit a
    _ → pure unit

  applyProp events = EFn.mkEffectFn3 \_ _ v →
    case v of
      Attribute ns attr val → do
        EFn.runEffectFn4 Util.setAttribute (toNullable ns) attr val el
        pure v
      Property prop val → do
        EFn.runEffectFn3 setProperty prop val el
        pure v
      Handler (DOM.EventType ty) f → do
        case Fn.runFn2 Util.unsafeGetAny ty events of
          handler | Fn.runFn2 Util.unsafeHasAny ty events → do
            Ref.write f (snd handler)
            pure v
          _ → do
            ref ← Ref.new f
            listener ← DOM.eventListener \ev → do
              f' ← Ref.read ref
              EFn.runEffectFn1 mbEmit (f' ev)
            EFn.runEffectFn3 Util.pokeMutMap ty (Tuple listener ref) events
            EFn.runEffectFn3 Util.addEventListener ty listener el
            pure v
      Ref f → do
        EFn.runEffectFn1 mbEmit (f (Created el))
        pure v

  diffProp = Fn.mkFn2 \prevEvents events → EFn.mkEffectFn4 \_ _ v1 v2 →
    case v1, v2 of
      Attribute _ _ val1, Attribute ns2 attr2 val2 →
        if val1 == val2
          then pure v2
          else do
            EFn.runEffectFn4 Util.setAttribute (toNullable ns2) attr2 val2 el
            pure v2
      Property _ val1, Property prop2 val2 →
        case Fn.runFn2 Util.refEq val1 val2, prop2 of
          true, _ →
            pure v2
          _, "value" → do
            let elVal = Fn.runFn2 unsafeGetProperty "value" el
            if Fn.runFn2 Util.refEq elVal val2
              then pure v2
              else do
                EFn.runEffectFn3 setProperty prop2 val2 el
                pure v2
          _, _ → do
            EFn.runEffectFn3 setProperty prop2 val2 el
            pure v2
      Handler _ _, Handler (DOM.EventType ty) f → do
        let
          handler = Fn.runFn2 Util.unsafeLookup ty prevEvents
        Ref.write f (snd handler)
        EFn.runEffectFn3 Util.pokeMutMap ty handler events
        pure v2
      _, _ →
        pure v2

  removeProp prevEvents = EFn.mkEffectFn2 \_ v →
    case v of
      Attribute ns attr _ →
        EFn.runEffectFn3 Util.removeAttribute (toNullable ns) attr el
      Property prop _ →
        EFn.runEffectFn2 removeProperty prop el
      Handler (DOM.EventType ty) _ → do
        let
          handler = Fn.runFn2 Util.unsafeLookup ty prevEvents
        EFn.runEffectFn3 Util.removeEventListener ty (fst handler) el
      Ref _ →
        pure unit

propToStrKey ∷ ∀ i. Prop i → String
propToStrKey = case _ of
  Attribute (Just (Namespace ns)) attr _ → "attr/" <> ns <> ":" <> attr
  Attribute _ attr _ → "attr/:" <> attr
  Property prop _ → "prop/" <> prop
  Handler (DOM.EventType ty) _ → "handler/" <> ty
  Ref _ → "ref"

setProperty ∷ EFn.EffectFn3 String PropValue DOM.Element Unit
setProperty = Util.unsafeSetAny

unsafeGetProperty ∷ Fn.Fn2 String DOM.Element PropValue
unsafeGetProperty = Util.unsafeGetAny

removeProperty ∷ EFn.EffectFn2 String DOM.Element Unit
removeProperty = EFn.mkEffectFn2 \key el →
  EFn.runEffectFn3 Util.hasAttribute null key el >>= case _ of
    true -> EFn.runEffectFn3 Util.removeAttribute null key el
    false -> case typeOf (Fn.runFn2 Util.unsafeGetAny key el) of
      "string" → EFn.runEffectFn3 Util.removeAttribute null key el
      _        → case key of
        "rowSpan" → EFn.runEffectFn3 Util.unsafeSetAny key 1 el
        "colSpan" → EFn.runEffectFn3 Util.unsafeSetAny key 1 el
        _ → EFn.runEffectFn3 Util.unsafeSetAny key Util.jsUndefined el


Fix show instance

Fix show instance

module Data.Maybe where

  data Maybe a = Nothing | Just a

  maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
  maybe b _ Nothing = b
  maybe _ f (Just a) = f a

  fromMaybe :: forall a. a -> Maybe a -> a
  fromMaybe a = maybe a (id :: forall a. a -> a)

  isJust :: forall a. Maybe a -> Boolean
  isJust = maybe false (const true)

  isNothing :: forall a. Maybe a -> Boolean
  isNothing = maybe true (const false)

  instance functorMaybe :: Functor Maybe where
    (<$>) fn (Just x) = Just (fn x)
    (<$>) _  _        = Nothing

  instance applyMaybe :: Apply Maybe where
    (<*>) (Just fn) x = fn <$> x
    (<*>) Nothing   _ = Nothing

  instance applicativeMaybe :: Applicative Maybe where
    pure = Just

  instance alternativeMaybe :: Alternative Maybe where
    empty = Nothing
    (<|>) Nothing r = r
    (<|>) l       _ = l

  instance bindMaybe :: Bind Maybe where
    (>>=) (Just x) k = k x
    (>>=) Nothing  _ = Nothing

  instance monadMaybe :: Monad Maybe

  instance showMaybe :: (Show a) => Show (Maybe a) where
    show (Just x) = "Just (" ++ show x ++ ")"
    show Nothing  = "Nothing"

  instance eqMaybe :: (Eq a) => Eq (Maybe a) where
    (==) Nothing   Nothing   = true
    (==) (Just a1) (Just a2) = a1 == a2
    (==) _         _         = false
    (/=) a b = not (a == b)

  instance ordMaybe :: (Ord a) => Ord (Maybe a) where
    compare (Just x) (Just y) = compare x y
    compare Nothing  Nothing  = EQ
    compare Nothing  _        = LT
    compare _        Nothing  = GT

module Data.Maybe where

  data Maybe a = Nothing | Just a

  maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
  maybe b _ Nothing = b
  maybe _ f (Just a) = f a

  fromMaybe :: forall a. a -> Maybe a -> a
  fromMaybe a = maybe a (id :: forall a. a -> a)

  isJust :: forall a. Maybe a -> Boolean
  isJust = maybe false (const true)

  isNothing :: forall a. Maybe a -> Boolean
  isNothing = maybe true (const false)

  instance functorMaybe :: Functor Maybe where
    (<$>) fn (Just x) = Just (fn x)
    (<$>) _  _        = Nothing

  instance applyMaybe :: Apply Maybe where
    (<*>) (Just fn) x = fn <$> x
    (<*>) Nothing   _ = Nothing

  instance applicativeMaybe :: Applicative Maybe where
    pure = Just

  instance alternativeMaybe :: Alternative Maybe where
    empty = Nothing
    (<|>) Nothing r = r
    (<|>) l       _ = l

  instance bindMaybe :: Bind Maybe where
    (>>=) (Just x) k = k x
    (>>=) Nothing  _ = Nothing

  instance monadMaybe :: Monad Maybe

  instance showMaybe :: (Show a) => Show (Maybe a) where
    show (Just x) = "Just " ++ (show x)
    show Nothing  = "Nothing"

  instance eqMaybe :: (Eq a) => Eq (Maybe a) where
    (==) Nothing   Nothing   = true
    (==) (Just a1) (Just a2) = a1 == a2
    (==) _         _         = false
    (/=) a b = not (a == b)

  instance ordMaybe :: (Ord a) => Ord (Maybe a) where
    compare (Just x) (Just y) = compare x y
    compare Nothing  Nothing  = EQ
    compare Nothing  _        = LT
    compare _        Nothing  = GT