Remove stacked tailrec-ing

Remove stacked tailrec-ing

module Halogen.Aff.Driver
  ( RenderSpec
  , runUI
  , module Halogen
  , module Exports
  ) where

import Prelude

import Control.Applicative.Free (hoistFreeAp, retractFreeAp)
import Control.Coroutine (($$))
import Control.Coroutine as CR
import Control.Monad.Aff (Aff, forkAff, forkAll, runAff)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error, throwException)
import Control.Monad.Eff.Ref (Ref, modifyRef, writeRef, readRef, newRef)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Fork (fork)
import Control.Monad.Trans.Class (lift)
import Control.Parallel (parSequence_, sequential, parallel)

import Data.Lazy (force)
import Data.List (List, (:))
import Data.List as L
import Data.Either (Either(..))
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (for_, traverse_, sequence_)
import Data.Tuple (Tuple(..))

import Halogen (HalogenIO)
import Halogen.Aff.Driver.State (ComponentType(..), DriverStateX, DriverState(..), unDriverStateX, initDriverState)
import Halogen.Component (Component, ComponentSlot, unComponent, unComponentSlot)
import Halogen.Data.OrdBox (OrdBox, unOrdBox)
import Halogen.Effects (HalogenEffects)
import Halogen.Query.ChildQuery (ChildQuery, unChildQuery)
import Halogen.Query.ForkF as FF
import Halogen.Query.HalogenM (HalogenM(..), HalogenF(..), HalogenAp(..))
import Halogen.Query.EventSource as ES

import Halogen.Aff.Driver.State (ComponentType(..)) as Exports

type LifecycleHandlers eff =
  { initializers :: List (Aff (HalogenEffects eff) Unit)
  , finalizers :: List (Aff (HalogenEffects eff) Unit)
  }

handleLifecycle
  :: forall eff r
   . (Ref (LifecycleHandlers eff) -> Aff (HalogenEffects eff) r)
  -> Aff (HalogenEffects eff) r
handleLifecycle f = do
  lchs <- liftEff $ newRef { initializers: L.Nil, finalizers: L.Nil }
  result <- f lchs
  { initializers, finalizers } <- liftEff $ readRef lchs
  forkAll finalizers
  -- No need to par/fork initializers here as there's only ever zero or one at
  -- this point, due to the squashing at each level of the component hierarchy.
  sequence_ initializers
  pure result

type RenderSpec h r eff =
  { render
      :: forall f g p
       . (forall x. f x -> Eff (HalogenEffects eff) Unit)
      -> (ComponentSlot h g (Aff (HalogenEffects eff)) p (f Unit) -> Aff (HalogenEffects eff) r)
      -> h (ComponentSlot h g (Aff (HalogenEffects eff)) p (f Unit)) (f Unit)
      -> ComponentType
      -> Maybe r
      -> Aff (HalogenEffects eff) r
  , renderChild
      :: Int
      -> Maybe r
      -> Aff (HalogenEffects eff) r
  }

runUI
  :: forall h r f o eff
   . RenderSpec h r eff
  -> Component h f o (Aff (HalogenEffects eff))
  -> Aff (HalogenEffects eff) (HalogenIO f o (Aff (HalogenEffects eff)))
runUI renderSpec component = do
  fresh <- liftEff $ newRef 0
  handleLifecycle \lchs -> do
    listeners <- liftEff $ newRef M.empty
    runComponent (rootHandler listeners) fresh lchs Root component
      >>= peekVar
      >>= unDriverStateX \st ->
        pure
          { query: evalF st.selfRef
          , subscribe: subscribe fresh listeners
          }

  where

  rootHandler :: Ref (M.Map Int (AV.AVar o)) -> o -> Aff (HalogenEffects eff) Unit
  rootHandler ref message = do
    listeners <- liftEff $ readRef ref
    void $ forkAll $ map (\var -> AV.putVar var message) listeners

  subscribe
    :: Ref Int
    -> Ref (M.Map Int (AV.AVar o))
    -> CR.Consumer o (Aff (HalogenEffects eff)) Unit
    -> Aff (HalogenEffects eff) Unit
  subscribe fresh ref consumer = do
    inputVar <- AV.makeVar
    listenerId <- liftEff do
      listenerId <- readRef fresh
      modifyRef fresh (_ + 1)
      modifyRef ref (M.insert listenerId inputVar)
      pure listenerId
    let producer = CR.producer (Left <$> AV.takeVar inputVar)
    void $ forkAff do
      CR.runProcess (CR.connect producer consumer)
      liftEff $ modifyRef ref (M.delete listenerId)
      AV.killVar inputVar (error "ended")

  runComponent
    :: forall f' o'
     . (o' -> Aff (HalogenEffects eff) Unit)
    -> Ref Int
    -> Ref (LifecycleHandlers eff)
    -> ComponentType
    -> Component h f' o' (Aff (HalogenEffects eff))
    -> Aff (HalogenEffects eff) (AV.AVar (DriverStateX h r f' eff))
  runComponent handler fresh lchs componentType = unComponent \c -> do
    keyId <- liftEff $ readRef fresh
    liftEff $ modifyRef fresh (_ + 1)
    var <- initDriverState c componentType handler keyId fresh
    unDriverStateX (render lchs <<< _.selfRef) =<< peekVar var
    squashChildInitializers lchs =<< peekVar var
    pure var

  eval
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> HalogenF s f' g p o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  eval ref = case _ of
    GetState k -> do
      DriverState { state } <- peekVar ref
      pure (k state)
    ModifyState f -> do
      DriverState (st@{ state }) <- AV.takeVar ref
      case f state of
        Tuple a state' -> do
          AV.putVar ref (DriverState (st { state = state' }))
          handleLifecycle \lchs -> render lchs ref
          pure a
    Subscribe es next -> do
      forkAff do
        { producer, done } <- ES.unEventSource es
        isDone <- liftEff $ newRef false
        blocker <- AV.makeVar
        let
          consumer :: CR.Consumer (f' Boolean) (Aff (HalogenEffects eff)) Unit
          consumer = do
            q <- CR.await
            unlessM (lift $ liftEff $ readRef isDone) do
              lift $ forkAff $ unlessM (evalF ref q) (AV.putVar blocker unit)
              consumer
        forkAff $ CR.runProcess (producer $$ consumer)
        AV.takeVar blocker
        liftEff $ writeRef isDone true
        done
      pure next
    Lift aff ->
      aff
    Halt msg ->
      throwError (error msg)
    GetSlots k -> do
      DriverState { children } <- peekVar ref
      pure $ k $ map unOrdBox $ M.keys children
    CheckSlot p k -> do
      DriverState { mkOrdBox, children } <- peekVar ref
      pure $ k $ M.member (mkOrdBox p) children
    ChildQuery cq ->
      evalChildQuery ref cq
    Raise o a -> do
      DriverState (ds@{ handler, pendingOut }) <- AV.takeVar ref
      case pendingOut of
        Nothing -> do
          AV.putVar ref (DriverState ds)
          handler o
        Just p ->
          AV.putVar ref (DriverState ds { pendingOut = Just (o : p) })
      pure a
    Par (HalogenAp p) ->
      sequential $ retractFreeAp $ hoistFreeAp (parallel <<< evalM ref) p
    Fork f ->
      FF.unFork (\(FF.ForkF fx k) →
        k <<< map unsafeCoerceAff <$> fork (evalM ref fx)) f

  evalChildQuery
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> ChildQuery g (Aff (HalogenEffects eff)) p
    ~> Aff (HalogenEffects eff)
  evalChildQuery ref = unChildQuery \p k -> do
    DriverState st <- peekVar ref
    case M.lookup (st.mkOrdBox p) st.children of
      Just var -> do
        dsx <- peekVar var
        k (unDriverStateX (\ds -> evalF ds.selfRef) dsx)
      Nothing -> throwError (error "Slot lookup failed for child query")

  evalF
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> f'
    ~> Aff (HalogenEffects eff)
  evalF ref q = do
    DriverState st <- peekVar ref
    case st.component.eval q of
      HalogenM fx -> foldFree (eval ref) fx

  evalM
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> HalogenM s f' g p o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  evalM ref (HalogenM q) = foldFree (eval ref) q

  render
    :: forall s f' g p o'
     . Ref (LifecycleHandlers eff)
    -> AV.AVar (DriverState h r s f' g p o' eff)
    -> Aff (HalogenEffects eff) Unit
  render lchs var = AV.takeVar var >>= \(DriverState ds) -> do
    childrenVar <- liftEff $ newRef M.empty
    oldChildren <- liftEff $ newRef ds.children
    let
      selfEval = evalF ds.selfRef
      handler :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      handler = void <<< selfEval
      handler' :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      handler' = maybe handler (\_ -> queuingHandler ds.selfRef handler) ds.pendingIn
    rendering <-
      renderSpec.render
        (handleAff <<< selfEval)
        (renderChild handler' ds.fresh ds.mkOrdBox oldChildren childrenVar lchs)
        (ds.component.render ds.state)
        ds.componentType
        ds.rendering
    children <- liftEff $ readRef childrenVar
    liftEff (readRef oldChildren) >>= traverse_ (addFinalizer lchs <=< peekVar)
    AV.putVar var $
      DriverState
        { rendering: Just rendering
        , componentType: ds.componentType
        , component: ds.component
        , state: ds.state
        , children
        , mkOrdBox: ds.mkOrdBox
        , selfRef: ds.selfRef
        , handler: ds.handler
        , pendingIn: ds.pendingIn
        , pendingOut: ds.pendingOut
        , keyId: ds.keyId
        , fresh: ds.fresh
        }

  queuingHandler
    :: forall s f' g p o' x
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> (f' x -> Aff (HalogenEffects eff) Unit)
    -> f' x
    -> Aff (HalogenEffects eff) Unit
  queuingHandler var handler message = do
    DriverState (ds@{ pendingIn }) <- AV.takeVar var
    case pendingIn of
      Nothing -> do
        AV.putVar var (DriverState ds)
        handler message
      Just p ->
        AV.putVar var (DriverState ds { pendingIn = Just (handler message : p) })

  renderChild
    :: forall f' g p
     . (forall x. f' x -> Aff (HalogenEffects eff) Unit)
    -> Ref Int
    -> (p -> OrdBox p)
    -> Ref (M.Map (OrdBox p) (AV.AVar (DriverStateX h r g eff)))
    -> Ref (M.Map (OrdBox p) (AV.AVar (DriverStateX h r g eff)))
    -> Ref (LifecycleHandlers eff)
    -> ComponentSlot h g (Aff (HalogenEffects eff)) p (f' Unit)
    -> Aff (HalogenEffects eff) r
  renderChild handler fresh mkOrdBox childrenInRef childrenOutRef lchs =
    unComponentSlot \p ctor k -> do
      childrenIn <- liftEff $ readRef childrenInRef
      var <- case M.pop (mkOrdBox p) childrenIn of
        Just (Tuple existing childrenIn') -> do
          liftEff $ writeRef childrenInRef childrenIn'
          pure existing
        Nothing ->
          runComponent (maybe (pure unit) handler <<< k) fresh lchs Child (force ctor)
      liftEff $ modifyRef childrenOutRef (M.insert (mkOrdBox p) var)
      unDriverStateX (\st -> renderSpec.renderChild st.keyId st.rendering) =<< peekVar var

  addInitializer
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  addInitializer ref =
    unDriverStateX \st -> do
      case evalF st.selfRef <$> st.component.initializer of
        Just i -> do
          liftEff $ modifyRef ref \lchs ->
            { initializers: handlePending st.selfRef : i : lchs.initializers
            , finalizers: lchs.finalizers
            }
        _ ->
          pure unit

  squashChildInitializers
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  squashChildInitializers ref =
    unDriverStateX \st -> do
      let parentInitializer = evalF st.selfRef <$> st.component.initializer
      liftEff $ modifyRef ref \lchs ->
        { initializers: pure $ do
            parSequence_ (L.reverse lchs.initializers)
            sequence_ parentInitializer
            handlePending st.selfRef
        , finalizers: lchs.finalizers
        }

  handlePending
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> Aff (HalogenEffects eff) Unit
  handlePending ref = do
    DriverState (dsi@{ pendingIn }) <- AV.takeVar ref
    AV.putVar ref (DriverState dsi { pendingIn = Nothing })
    for_ pendingIn (forkAll <<< L.reverse)
    DriverState (dso@{ pendingOut, handler }) <- AV.takeVar ref
    AV.putVar ref (DriverState dso { pendingOut = Nothing })
    for_ pendingOut (forkAll <<< map handler <<< L.reverse)

  addFinalizer
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  addFinalizer ref =
    unDriverStateX \st -> do
      for_ (evalF st.selfRef <$> st.component.finalizer) \f ->
        liftEff $ modifyRef ref (\lchs ->
          { initializers: lchs.initializers
          , finalizers: f : lchs.finalizers
          })
      for_ st.children (addFinalizer ref <=< peekVar)

-- | TODO: we could do something more intelligent now this isn't baked into the
-- | virtual-dom rendering. Perhaps write to an avar when an error occurs...
-- | something other than a runtime exception anyway.
handleAff
  :: forall eff a
   . Aff (HalogenEffects eff) a
  -> Eff (HalogenEffects eff) Unit
handleAff = void <<< runAff throwException (const (pure unit))

peekVar :: forall eff a. AV.AVar a -> Aff (avar :: AV.AVAR | eff) a
peekVar v = do
  a <- AV.takeVar v
  AV.putVar v a
  pure a

module Halogen.Aff.Driver
  ( RenderSpec
  , runUI
  , module Halogen
  , module Exports
  ) where

import Prelude

import Control.Applicative.Free (hoistFreeAp, retractFreeAp)
import Control.Coroutine (($$))
import Control.Coroutine as CR
import Control.Monad.Aff (Aff, forkAff, forkAll, runAff)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error, throwException)
import Control.Monad.Eff.Ref (Ref, modifyRef, writeRef, readRef, newRef)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Fork (fork)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Monad.Trans.Class (lift)
import Control.Parallel (parSequence_, sequential, parallel)

import Data.Lazy (force)
import Data.List (List, (:))
import Data.List as L
import Data.Either (Either(..))
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (for_, traverse_, sequence_)
import Data.Tuple (Tuple(..))

import Halogen (HalogenIO)
import Halogen.Aff.Driver.State (ComponentType(..), DriverStateX, DriverState(..), unDriverStateX, initDriverState)
import Halogen.Component (Component, ComponentSlot, unComponent, unComponentSlot)
import Halogen.Data.OrdBox (OrdBox, unOrdBox)
import Halogen.Effects (HalogenEffects)
import Halogen.Query.ChildQuery (ChildQuery, unChildQuery)
import Halogen.Query.ForkF as FF
import Halogen.Query.HalogenM (HalogenM(..), HalogenF(..), HalogenAp(..))
import Halogen.Query.EventSource as ES

import Halogen.Aff.Driver.State (ComponentType(..)) as Exports

type LifecycleHandlers eff =
  { initializers :: List (Aff (HalogenEffects eff) Unit)
  , finalizers :: List (Aff (HalogenEffects eff) Unit)
  }

handleLifecycle
  :: forall eff r
   . (Ref (LifecycleHandlers eff) -> Aff (HalogenEffects eff) r)
  -> Aff (HalogenEffects eff) r
handleLifecycle f = do
  lchs <- liftEff $ newRef { initializers: L.Nil, finalizers: L.Nil }
  result <- f lchs
  { initializers, finalizers } <- liftEff $ readRef lchs
  forkAll finalizers
  -- No need to par/fork initializers here as there's only ever zero or one at
  -- this point, due to the squashing at each level of the component hierarchy.
  sequence_ initializers
  pure result

type RenderSpec h r eff =
  { render
      :: forall f g p
       . (forall x. f x -> Eff (HalogenEffects eff) Unit)
      -> (ComponentSlot h g (Aff (HalogenEffects eff)) p (f Unit) -> Aff (HalogenEffects eff) r)
      -> h (ComponentSlot h g (Aff (HalogenEffects eff)) p (f Unit)) (f Unit)
      -> ComponentType
      -> Maybe r
      -> Aff (HalogenEffects eff) r
  , renderChild
      :: Int
      -> Maybe r
      -> Aff (HalogenEffects eff) r
  }

runUI
  :: forall h r f o eff
   . RenderSpec h r eff
  -> Component h f o (Aff (HalogenEffects eff))
  -> Aff (HalogenEffects eff) (HalogenIO f o (Aff (HalogenEffects eff)))
runUI renderSpec component = do
  fresh <- liftEff $ newRef 0
  handleLifecycle \lchs -> do
    listeners <- liftEff $ newRef M.empty
    runComponent (rootHandler listeners) fresh lchs Root component
      >>= peekVar
      >>= unDriverStateX \st ->
        pure
          { query: evalF st.selfRef
          , subscribe: subscribe fresh listeners
          }

  where

  rootHandler :: Ref (M.Map Int (AV.AVar o)) -> o -> Aff (HalogenEffects eff) Unit
  rootHandler ref message = do
    listeners <- liftEff $ readRef ref
    void $ forkAll $ map (\var -> AV.putVar var message) listeners

  subscribe
    :: Ref Int
    -> Ref (M.Map Int (AV.AVar o))
    -> CR.Consumer o (Aff (HalogenEffects eff)) Unit
    -> Aff (HalogenEffects eff) Unit
  subscribe fresh ref consumer = do
    inputVar <- AV.makeVar
    listenerId <- liftEff do
      listenerId <- readRef fresh
      modifyRef fresh (_ + 1)
      modifyRef ref (M.insert listenerId inputVar)
      pure listenerId
    let producer = CR.producer (Left <$> AV.takeVar inputVar)
    void $ forkAff do
      CR.runProcess (CR.connect producer consumer)
      liftEff $ modifyRef ref (M.delete listenerId)
      AV.killVar inputVar (error "ended")

  runComponent
    :: forall f' o'
     . (o' -> Aff (HalogenEffects eff) Unit)
    -> Ref Int
    -> Ref (LifecycleHandlers eff)
    -> ComponentType
    -> Component h f' o' (Aff (HalogenEffects eff))
    -> Aff (HalogenEffects eff) (AV.AVar (DriverStateX h r f' eff))
  runComponent handler fresh lchs componentType = unComponent \c -> do
    keyId <- liftEff $ readRef fresh
    liftEff $ modifyRef fresh (_ + 1)
    var <- initDriverState c componentType handler keyId fresh
    unDriverStateX (render lchs <<< _.selfRef) =<< peekVar var
    squashChildInitializers lchs =<< peekVar var
    pure var

  eval
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> HalogenF s f' g p o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  eval ref = case _ of
    GetState k -> do
      DriverState { state } <- peekVar ref
      pure (k state)
    ModifyState f -> do
      DriverState (st@{ state }) <- AV.takeVar ref
      case f state of
        Tuple a state' -> do
          AV.putVar ref (DriverState (st { state = state' }))
          handleLifecycle \lchs -> render lchs ref
          pure a
    Subscribe es next -> do
      forkAff do
        { producer, done } <- ES.unEventSource es
        isDone <- liftEff $ newRef false
        blocker <- AV.makeVar
        let
          consumer :: CR.Consumer (f' Boolean) (Aff (HalogenEffects eff)) Unit
          consumer = flip tailRecM unit \_ -> do
            q <- CR.await
            lift (liftEff (readRef isDone)) >>= case _ of
              true -> pure (Done unit)
              false -> lift do
                forkAff $ unlessM (evalF ref q) (AV.putVar blocker unit)
                pure (Loop unit)
        forkAff $ CR.runProcess (producer $$ consumer)
        AV.takeVar blocker
        liftEff $ writeRef isDone true
        done
      pure next
    Lift aff ->
      aff
    Halt msg ->
      throwError (error msg)
    GetSlots k -> do
      DriverState { children } <- peekVar ref
      pure $ k $ map unOrdBox $ M.keys children
    CheckSlot p k -> do
      DriverState { mkOrdBox, children } <- peekVar ref
      pure $ k $ M.member (mkOrdBox p) children
    ChildQuery cq ->
      evalChildQuery ref cq
    Raise o a -> do
      DriverState (ds@{ handler, pendingOut }) <- AV.takeVar ref
      case pendingOut of
        Nothing -> do
          AV.putVar ref (DriverState ds)
          handler o
        Just p ->
          AV.putVar ref (DriverState ds { pendingOut = Just (o : p) })
      pure a
    Par (HalogenAp p) ->
      sequential $ retractFreeAp $ hoistFreeAp (parallel <<< evalM ref) p
    Fork f ->
      FF.unFork (\(FF.ForkF fx k) →
        k <<< map unsafeCoerceAff <$> fork (evalM ref fx)) f

  evalChildQuery
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> ChildQuery g (Aff (HalogenEffects eff)) p
    ~> Aff (HalogenEffects eff)
  evalChildQuery ref = unChildQuery \p k -> do
    DriverState st <- peekVar ref
    case M.lookup (st.mkOrdBox p) st.children of
      Just var -> do
        dsx <- peekVar var
        k (unDriverStateX (\ds -> evalF ds.selfRef) dsx)
      Nothing -> throwError (error "Slot lookup failed for child query")

  evalF
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> f'
    ~> Aff (HalogenEffects eff)
  evalF ref q = do
    DriverState st <- peekVar ref
    case st.component.eval q of
      HalogenM fx -> foldFree (eval ref) fx

  evalM
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> HalogenM s f' g p o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  evalM ref (HalogenM q) = foldFree (eval ref) q

  render
    :: forall s f' g p o'
     . Ref (LifecycleHandlers eff)
    -> AV.AVar (DriverState h r s f' g p o' eff)
    -> Aff (HalogenEffects eff) Unit
  render lchs var = AV.takeVar var >>= \(DriverState ds) -> do
    childrenVar <- liftEff $ newRef M.empty
    oldChildren <- liftEff $ newRef ds.children
    let
      selfEval = evalF ds.selfRef
      handler :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      handler = void <<< selfEval
      handler' :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      handler' = maybe handler (\_ -> queuingHandler ds.selfRef handler) ds.pendingIn
    rendering <-
      renderSpec.render
        (handleAff <<< selfEval)
        (renderChild handler' ds.fresh ds.mkOrdBox oldChildren childrenVar lchs)
        (ds.component.render ds.state)
        ds.componentType
        ds.rendering
    children <- liftEff $ readRef childrenVar
    liftEff (readRef oldChildren) >>= traverse_ (addFinalizer lchs <=< peekVar)
    AV.putVar var $
      DriverState
        { rendering: Just rendering
        , componentType: ds.componentType
        , component: ds.component
        , state: ds.state
        , children
        , mkOrdBox: ds.mkOrdBox
        , selfRef: ds.selfRef
        , handler: ds.handler
        , pendingIn: ds.pendingIn
        , pendingOut: ds.pendingOut
        , keyId: ds.keyId
        , fresh: ds.fresh
        }

  queuingHandler
    :: forall s f' g p o' x
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> (f' x -> Aff (HalogenEffects eff) Unit)
    -> f' x
    -> Aff (HalogenEffects eff) Unit
  queuingHandler var handler message = do
    DriverState (ds@{ pendingIn }) <- AV.takeVar var
    case pendingIn of
      Nothing -> do
        AV.putVar var (DriverState ds)
        handler message
      Just p ->
        AV.putVar var (DriverState ds { pendingIn = Just (handler message : p) })

  renderChild
    :: forall f' g p
     . (forall x. f' x -> Aff (HalogenEffects eff) Unit)
    -> Ref Int
    -> (p -> OrdBox p)
    -> Ref (M.Map (OrdBox p) (AV.AVar (DriverStateX h r g eff)))
    -> Ref (M.Map (OrdBox p) (AV.AVar (DriverStateX h r g eff)))
    -> Ref (LifecycleHandlers eff)
    -> ComponentSlot h g (Aff (HalogenEffects eff)) p (f' Unit)
    -> Aff (HalogenEffects eff) r
  renderChild handler fresh mkOrdBox childrenInRef childrenOutRef lchs =
    unComponentSlot \p ctor k -> do
      childrenIn <- liftEff $ readRef childrenInRef
      var <- case M.pop (mkOrdBox p) childrenIn of
        Just (Tuple existing childrenIn') -> do
          liftEff $ writeRef childrenInRef childrenIn'
          pure existing
        Nothing ->
          runComponent (maybe (pure unit) handler <<< k) fresh lchs Child (force ctor)
      liftEff $ modifyRef childrenOutRef (M.insert (mkOrdBox p) var)
      unDriverStateX (\st -> renderSpec.renderChild st.keyId st.rendering) =<< peekVar var

  addInitializer
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  addInitializer ref =
    unDriverStateX \st -> do
      case evalF st.selfRef <$> st.component.initializer of
        Just i -> do
          liftEff $ modifyRef ref \lchs ->
            { initializers: handlePending st.selfRef : i : lchs.initializers
            , finalizers: lchs.finalizers
            }
        _ ->
          pure unit

  squashChildInitializers
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  squashChildInitializers ref =
    unDriverStateX \st -> do
      let parentInitializer = evalF st.selfRef <$> st.component.initializer
      liftEff $ modifyRef ref \lchs ->
        { initializers: pure $ do
            parSequence_ (L.reverse lchs.initializers)
            sequence_ parentInitializer
            handlePending st.selfRef
        , finalizers: lchs.finalizers
        }

  handlePending
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> Aff (HalogenEffects eff) Unit
  handlePending ref = do
    DriverState (dsi@{ pendingIn }) <- AV.takeVar ref
    AV.putVar ref (DriverState dsi { pendingIn = Nothing })
    for_ pendingIn (forkAll <<< L.reverse)
    DriverState (dso@{ pendingOut, handler }) <- AV.takeVar ref
    AV.putVar ref (DriverState dso { pendingOut = Nothing })
    for_ pendingOut (forkAll <<< map handler <<< L.reverse)

  addFinalizer
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  addFinalizer ref =
    unDriverStateX \st -> do
      for_ (evalF st.selfRef <$> st.component.finalizer) \f ->
        liftEff $ modifyRef ref (\lchs ->
          { initializers: lchs.initializers
          , finalizers: f : lchs.finalizers
          })
      for_ st.children (addFinalizer ref <=< peekVar)

-- | TODO: we could do something more intelligent now this isn't baked into the
-- | virtual-dom rendering. Perhaps write to an avar when an error occurs...
-- | something other than a runtime exception anyway.
handleAff
  :: forall eff a
   . Aff (HalogenEffects eff) a
  -> Eff (HalogenEffects eff) Unit
handleAff = void <<< runAff throwException (const (pure unit))

peekVar :: forall eff a. AV.AVar a -> Aff (avar :: AV.AVAR | eff) a
peekVar v = do
  a <- AV.takeVar v
  AV.putVar v a
  pure a


Fix argument names for open

Fix argument names for open

module DOM.HTML.Window
  ( document
  , navigator
  , location
  , history
  , innerWidth
  , innerHeight
  , alert
  , confirm
  , moveBy
  , moveTo
  , open
  , outerHeight
  , outerWidth
  , print
  , prompt
  , promptDefault
  , resizeBy
  , resizeTo
  , screenX
  , screenY
  , scroll
  , scrollBy
  , scrollX
  , scrollY
  , url
  , localStorage
  , sessionStorage
  , requestAnimationFrame
  , cancelAnimationFrame
  , RequestAnimationFrameId
  , requestIdleCallback
  , cancelIdleCallback
  , RequestIdleCallbackId
  ) where

import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.HTML.Types (ALERT, CONFIRM, HISTORY, HTMLDocument, History, Location, Navigator, PROMPT, WINDOW, Window, URL)
import DOM.WebStorage.Types (Storage)
import Data.Maybe (Maybe)
import Data.Nullable (Nullable, toMaybe)
import Data.Newtype (class Newtype, unwrap)
import Prelude (class Eq, class Ord, Unit, (<$>), (<<<), map)

foreign import document :: forall eff. Window -> Eff (dom :: DOM | eff) HTMLDocument

foreign import navigator :: forall eff. Window -> Eff (dom :: DOM | eff) Navigator

foreign import location :: forall eff. Window -> Eff (dom :: DOM | eff) Location

foreign import history :: forall e. Window -> Eff (history :: HISTORY | e) History

foreign import url :: forall eff. Window -> Eff (dom :: DOM | eff) URL

foreign import innerWidth :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import innerHeight :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import alert :: forall eff. String -> Window -> Eff (alert :: ALERT | eff) Unit

foreign import confirm :: forall eff. String -> Window -> Eff (confirm :: CONFIRM | eff) Boolean

foreign import moveBy :: forall eff. Int -> Int -> Window -> Eff (window :: WINDOW | eff) Unit

foreign import moveTo :: forall eff. Int -> Int -> Window -> Eff (window :: WINDOW | eff) Unit

open :: forall eff. String -> String -> String -> Window -> Eff (window :: WINDOW | eff) (Maybe Window)
open url' name features window = toMaybe <$> _open url' name features window

foreign import _open
  :: forall eff
   . String
  -> String
  -> String
  -> Window
  -> Eff (window :: WINDOW | eff) (Nullable Window)

foreign import outerHeight :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import outerWidth :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import print :: forall eff. Window -> Eff (window :: WINDOW | eff) Unit

prompt :: forall eff. String -> Window -> Eff (prompt :: PROMPT | eff) (Maybe String)
prompt msg window = toMaybe <$> _prompt msg "" window

promptDefault :: forall eff. String -> String -> Window -> Eff (prompt :: PROMPT | eff) (Maybe String)
promptDefault msg defaultText window = toMaybe <$> _prompt msg defaultText window

foreign import _prompt :: forall eff. String -> String -> Window -> Eff (prompt :: PROMPT | eff) (Nullable String)

foreign import resizeBy :: forall eff. Int -> Int -> Window -> Eff (window :: WINDOW | eff) Unit

foreign import resizeTo :: forall eff. Int -> Int -> Window -> Eff (window :: WINDOW | eff) Unit

foreign import screenX :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import screenY :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import scroll :: forall eff. Int -> Int -> Window -> Eff (window :: WINDOW | eff) Unit

foreign import scrollBy :: forall eff. Int -> Int -> Window -> Eff (window :: WINDOW | eff) Unit

foreign import scrollX :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import scrollY :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import localStorage :: forall eff. Window -> Eff (dom :: DOM | eff) Storage

foreign import sessionStorage :: forall eff. Window -> Eff (dom :: DOM | eff) Storage

newtype RequestAnimationFrameId = RequestAnimationFrameId Int

derive instance newtypeRequestAnimationFrameId :: Newtype RequestAnimationFrameId _
derive instance eqRequestAnimationFrameId :: Eq RequestAnimationFrameId
derive instance ordRequestAnimationFrameId :: Ord RequestAnimationFrameId

foreign import _requestAnimationFrame :: forall eff. Eff (dom :: DOM | eff) Unit -> Window -> Eff (dom :: DOM | eff) Int

requestAnimationFrame :: forall eff. Eff (dom :: DOM | eff) Unit -> Window -> Eff (dom :: DOM | eff ) RequestAnimationFrameId
requestAnimationFrame fn = map RequestAnimationFrameId <<< _requestAnimationFrame fn

foreign import _cancelAnimationFrame :: forall eff. Int -> Window -> Eff (dom :: DOM | eff) Unit

cancelAnimationFrame :: forall eff. RequestAnimationFrameId -> Window -> Eff (dom :: DOM | eff) Unit
cancelAnimationFrame idAF = _cancelAnimationFrame (unwrap idAF)

newtype RequestIdleCallbackId = RequestIdleCallbackId Int

derive instance newtypeRequestIdleCallbackId :: Newtype RequestIdleCallbackId _
derive instance eqRequestIdleCallbackId :: Eq RequestIdleCallbackId
derive instance ordRequestIdleCallbackId :: Ord RequestIdleCallbackId

foreign import _requestIdleCallback :: forall eff. { timeout :: Int } -> Eff (dom :: DOM | eff) Unit -> Window -> Eff (dom :: DOM | eff) Int

-- | Set timeout to `0` to get the same behaviour as when it is `undefined` in
-- | [JavaScript](https://w3c.github.io/requestidlecallback/#h-the-requestidle-callback-method).
requestIdleCallback :: forall eff. { timeout :: Int } -> Eff (dom :: DOM | eff) Unit -> Window -> Eff (dom :: DOM | eff ) RequestIdleCallbackId
requestIdleCallback opts fn = map RequestIdleCallbackId <<< _requestIdleCallback opts fn

foreign import _cancelIdleCallback :: forall eff. Int -> Window -> Eff (dom :: DOM | eff) Unit

cancelIdleCallback :: forall eff. RequestIdleCallbackId -> Window -> Eff (dom :: DOM | eff) Unit
cancelIdleCallback idAF = _cancelIdleCallback (unwrap idAF)

module DOM.HTML.Window
  ( document
  , navigator
  , location
  , history
  , innerWidth
  , innerHeight
  , alert
  , confirm
  , moveBy
  , moveTo
  , open
  , outerHeight
  , outerWidth
  , print
  , prompt
  , promptDefault
  , resizeBy
  , resizeTo
  , screenX
  , screenY
  , scroll
  , scrollBy
  , scrollX
  , scrollY
  , url
  , localStorage
  , sessionStorage
  , requestAnimationFrame
  , cancelAnimationFrame
  , RequestAnimationFrameId
  , requestIdleCallback
  , cancelIdleCallback
  , RequestIdleCallbackId
  ) where

import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.HTML.Types (ALERT, CONFIRM, HISTORY, HTMLDocument, History, Location, Navigator, PROMPT, WINDOW, Window, URL)
import DOM.WebStorage.Types (Storage)
import Data.Maybe (Maybe)
import Data.Nullable (Nullable, toMaybe)
import Data.Newtype (class Newtype, unwrap)
import Prelude (class Eq, class Ord, Unit, (<$>), (<<<), map)

foreign import document :: forall eff. Window -> Eff (dom :: DOM | eff) HTMLDocument

foreign import navigator :: forall eff. Window -> Eff (dom :: DOM | eff) Navigator

foreign import location :: forall eff. Window -> Eff (dom :: DOM | eff) Location

foreign import history :: forall e. Window -> Eff (history :: HISTORY | e) History

foreign import url :: forall eff. Window -> Eff (dom :: DOM | eff) URL

foreign import innerWidth :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import innerHeight :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import alert :: forall eff. String -> Window -> Eff (alert :: ALERT | eff) Unit

foreign import confirm :: forall eff. String -> Window -> Eff (confirm :: CONFIRM | eff) Boolean

foreign import moveBy :: forall eff. Int -> Int -> Window -> Eff (window :: WINDOW | eff) Unit

foreign import moveTo :: forall eff. Int -> Int -> Window -> Eff (window :: WINDOW | eff) Unit

open :: forall eff. String -> String -> String -> Window -> Eff (window :: WINDOW | eff) (Maybe Window)
open window url' name features = toMaybe <$> _open window url' name features

foreign import _open
  :: forall eff
   . String
  -> String
  -> String
  -> Window
  -> Eff (window :: WINDOW | eff) (Nullable Window)

foreign import outerHeight :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import outerWidth :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import print :: forall eff. Window -> Eff (window :: WINDOW | eff) Unit

prompt :: forall eff. String -> Window -> Eff (prompt :: PROMPT | eff) (Maybe String)
prompt msg window = toMaybe <$> _prompt msg "" window

promptDefault :: forall eff. String -> String -> Window -> Eff (prompt :: PROMPT | eff) (Maybe String)
promptDefault msg defaultText window = toMaybe <$> _prompt msg defaultText window

foreign import _prompt :: forall eff. String -> String -> Window -> Eff (prompt :: PROMPT | eff) (Nullable String)

foreign import resizeBy :: forall eff. Int -> Int -> Window -> Eff (window :: WINDOW | eff) Unit

foreign import resizeTo :: forall eff. Int -> Int -> Window -> Eff (window :: WINDOW | eff) Unit

foreign import screenX :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import screenY :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import scroll :: forall eff. Int -> Int -> Window -> Eff (window :: WINDOW | eff) Unit

foreign import scrollBy :: forall eff. Int -> Int -> Window -> Eff (window :: WINDOW | eff) Unit

foreign import scrollX :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import scrollY :: forall eff. Window -> Eff (dom :: DOM | eff) Int

foreign import localStorage :: forall eff. Window -> Eff (dom :: DOM | eff) Storage

foreign import sessionStorage :: forall eff. Window -> Eff (dom :: DOM | eff) Storage

newtype RequestAnimationFrameId = RequestAnimationFrameId Int

derive instance newtypeRequestAnimationFrameId :: Newtype RequestAnimationFrameId _
derive instance eqRequestAnimationFrameId :: Eq RequestAnimationFrameId
derive instance ordRequestAnimationFrameId :: Ord RequestAnimationFrameId

foreign import _requestAnimationFrame :: forall eff. Eff (dom :: DOM | eff) Unit -> Window -> Eff (dom :: DOM | eff) Int

requestAnimationFrame :: forall eff. Eff (dom :: DOM | eff) Unit -> Window -> Eff (dom :: DOM | eff ) RequestAnimationFrameId
requestAnimationFrame fn = map RequestAnimationFrameId <<< _requestAnimationFrame fn

foreign import _cancelAnimationFrame :: forall eff. Int -> Window -> Eff (dom :: DOM | eff) Unit

cancelAnimationFrame :: forall eff. RequestAnimationFrameId -> Window -> Eff (dom :: DOM | eff) Unit
cancelAnimationFrame idAF = _cancelAnimationFrame (unwrap idAF)

newtype RequestIdleCallbackId = RequestIdleCallbackId Int

derive instance newtypeRequestIdleCallbackId :: Newtype RequestIdleCallbackId _
derive instance eqRequestIdleCallbackId :: Eq RequestIdleCallbackId
derive instance ordRequestIdleCallbackId :: Ord RequestIdleCallbackId

foreign import _requestIdleCallback :: forall eff. { timeout :: Int } -> Eff (dom :: DOM | eff) Unit -> Window -> Eff (dom :: DOM | eff) Int

-- | Set timeout to `0` to get the same behaviour as when it is `undefined` in
-- | [JavaScript](https://w3c.github.io/requestidlecallback/#h-the-requestidle-callback-method).
requestIdleCallback :: forall eff. { timeout :: Int } -> Eff (dom :: DOM | eff) Unit -> Window -> Eff (dom :: DOM | eff ) RequestIdleCallbackId
requestIdleCallback opts fn = map RequestIdleCallbackId <<< _requestIdleCallback opts fn

foreign import _cancelIdleCallback :: forall eff. Int -> Window -> Eff (dom :: DOM | eff) Unit

cancelIdleCallback :: forall eff. RequestIdleCallbackId -> Window -> Eff (dom :: DOM | eff) Unit
cancelIdleCallback idAF = _cancelIdleCallback (unwrap idAF)


Fix a really stupid bug

Fix a really stupid bug

Original commit b532ce8678f9b42dff37b8eacc93e6821b50976c

module IR where

import Control.Monad.State
import Control.Monad.State.Class
import Prelude

import Data.Either (Either(..))
import Data.Foldable (find, all, any)
import Data.List (List(..), concatMap, length, singleton, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromJust)
import Data.Set (Set)
import Data.Set as S
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)

newtype IRGraph = IRGraph { classes :: List (Either IRClassData Int) }

newtype IRClassData = IRClassData { names :: Set String, properties :: Map String IRType }

makeClass :: String -> Map String IRType -> IRClassData
makeClass name properties =
    IRClassData { names: S.singleton name, properties }

emptyGraph :: IRGraph
emptyGraph = IRGraph { classes: L.Nil }

addClass :: IRClassData -> State IRGraph IRType
addClass classData =
    do
        IRGraph { classes } <- get
        put (IRGraph { classes: (L.snoc classes (Left classData)) })
        pure $ IRClass (L.length classes)

redirectClass :: Int -> Int -> State IRGraph Unit
redirectClass from to =
    do
        (IRGraph { classes: c1 }) <- get
        let c2 = unsafePartial $ fromJust $ L.updateAt from (Right to) c1
        put (IRGraph { classes: c2 })

getClassFromGraph :: IRGraph -> Int -> IRClassData
getClassFromGraph graph@(IRGraph { classes }) index =
    case unsafePartial $ fromJust $ L.index classes index of
    Left cd -> cd
    Right i -> getClassFromGraph graph i

getClass :: Int -> State IRGraph IRClassData
getClass index =
    do
        graph <- get
        pure $ getClassFromGraph graph index

combineClasses :: Int -> Int -> IRClassData -> State IRGraph IRType
combineClasses ia ib combined =
    do
        IRGraph { classes } <- get
        let newIndex = L.length classes
        t <- addClass combined
        redirectClass ia newIndex
        redirectClass ib newIndex
        pure t

classesInGraph :: IRGraph -> List IRClassData
classesInGraph (IRGraph { classes }) =
    L.concatMap mapper classes
    where
        mapper =
            case _ of
            Left cd -> L.singleton cd
            Right _ -> L.Nil

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass Int
    | IRUnion (Set IRType)

lookupOrDefault :: forall k v. Ord k => v -> k -> Map k v -> v
lookupOrDefault default key m =
    case M.lookup key m of
    Nothing -> default
    Just x -> x

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s =
    let element = (find p s)
    in
        case element of
            Just x -> { element: element, rest: S.delete x s }
            Nothing -> { element: element, rest: s }

mapM :: forall a b. (a -> State IRGraph b) -> List a -> State IRGraph (List b)
mapM _ L.Nil = pure L.Nil
mapM f (x : xs) =
    do
        ys <- mapM f xs
        y <- f x
        pure $ y : ys

-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> State IRGraph v) -> v -> Map k v -> Map k v -> State IRGraph (Map k v)
unionWithDefault unifier default m1 m2 =
    let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ M.keys m1) (S.fromFoldable $ M.keys m2)
        valueFor k = unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2)
        keyMapper k =
            do
                v <- valueFor k
                pure $ Tuple k v
    in
        do
            kvps <- mapM keyMapper allKeys
            pure $ M.fromFoldable kvps

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

decomposeTypeSet :: S.Set IRType -> { maybeArray :: Maybe IRType, maybeClass :: Maybe IRType, rest :: S.Set IRType }
decomposeTypeSet s =
    let { element: maybeArray, rest: rest } = removeElement isArray s
        { element: maybeClass, rest: rest } = removeElement isClass rest
    in
        { maybeArray, maybeClass, rest }

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

unifyClasses :: IRClassData -> IRClassData -> State IRGraph IRClassData
unifyClasses (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) =
    do
        properties <- unionWithDefault unifyTypesWithNull IRNothing pa pb
        pure $ IRClassData { names: (S.union na nb), properties: properties }

unifyMaybes :: Maybe IRType -> Maybe IRType -> State IRGraph IRType
unifyMaybes Nothing Nothing = pure IRNothing
unifyMaybes (Just a) Nothing = pure a
unifyMaybes Nothing (Just b) = pure b
unifyMaybes (Just a) (Just b) = unifyTypes a b

unifyUnion :: S.Set IRType -> S.Set IRType -> State IRGraph (S.Set IRType)
unifyUnion sa sb =
    do
        let { maybeArray: arrayA, maybeClass: classA, rest: sa } = decomposeTypeSet sa
        let { maybeArray: arrayB, maybeClass: classB, rest: sb } = decomposeTypeSet sb
        unifiedArray <- unifyMaybes arrayA arrayB
        unifiedClasses <- unifyMaybes classA classB
        pure $ S.unions [sa, sb, setFromType unifiedArray, setFromType unifiedClasses]

unifyTypes :: IRType -> IRType -> State IRGraph IRType
unifyTypes IRNothing x = pure x
unifyTypes x IRNothing = pure x
unifyTypes (IRArray a) (IRArray b) =
    do
        unified <- unifyTypes a b
        pure $ IRArray unified
unifyTypes (IRClass ia) (IRClass ib) =
    do
        a <- getClass ia
        b <- getClass ib
        unified <- unifyClasses a b
        combineClasses ia ib unified
unifyTypes (IRUnion a) (IRUnion b) =
    do
        unified <- unifyUnion a b
        pure $ IRUnion unified
unifyTypes (IRUnion a) b =
    do
        unified <- unifyUnion a (S.singleton b)
        pure $ IRUnion unified
unifyTypes a (IRUnion b) =
    do
        unified <- unifyUnion (S.singleton a) b
        pure $ IRUnion unified
unifyTypes a b =
    do
        pure $ if a == b then a else IRUnion (S.fromFoldable [a, b])

nullifyNothing :: IRType -> IRType
nullifyNothing IRNothing = IRNull
nullifyNothing x = x

unifyTypesWithNull :: IRType -> IRType -> State IRGraph IRType
unifyTypesWithNull IRNothing IRNothing = pure IRNothing
unifyTypesWithNull a b = unifyTypes (nullifyNothing a) (nullifyNothing b)

matchingProperties :: forall v. Eq v => Map String v -> Map String v -> Map String v
matchingProperties ma mb =
    M.fromFoldable (L.concatMap getFromB (M.toUnfoldable ma))
    where
        getFromB (Tuple k va) =
            case M.lookup k mb of
            Just vb -> if va == vb then Tuple k vb : L.Nil else L.Nil
            Nothing -> L.Nil

propertiesSimilar :: forall v. Eq v => Map String v -> Map String v -> Boolean
propertiesSimilar pa pb =
    let aInB = M.size $ matchingProperties pa pb
        bInA = M.size $ matchingProperties pb pa
    in
        (aInB * 4 >= (M.size pa) * 3) && (bInA * 4 >= (M.size pb) * 3)

isMaybeSubtypeOfMaybe :: IRGraph -> Maybe IRType -> Maybe IRType -> Boolean
isMaybeSubtypeOfMaybe _ Nothing Nothing = true
isMaybeSubtypeOfMaybe graph (Just a) (Just b) = isSubtypeOf graph a b
isMaybeSubtypeOfMaybe _ _ _ = false

isSubtypeOf :: IRGraph ->  IRType -> IRType -> Boolean
isSubtypeOf _ IRNothing _ = true
isSubtypeOf graph (IRUnion sa) (IRUnion sb) =
    all (\ta -> any (isSubtypeOf graph ta) sb) sa
isSubtypeOf graph (IRArray a) (IRArray b) =
    isSubtypeOf graph a b
isSubtypeOf graph (IRClass ia) (IRClass ib) =
    let IRClassData { names: _, properties: pa } = getClassFromGraph graph ia
        IRClassData { names: _, properties: pb } = getClassFromGraph graph ib
    in
        propertiesAreSubset graph pa pb
isSubtypeOf _ a b = a == b

propertiesAreSubset :: IRGraph -> Map String IRType -> Map String IRType -> Boolean
propertiesAreSubset graph ma mb =
    all isInB (M.toUnfoldable ma :: List _)
    where
        isInB (Tuple n ta) =
            case M.lookup n mb of
            Nothing -> false
            Just tb -> isSubtypeOf graph ta tb

classesSimilar :: IRGraph -> IRClassData -> IRClassData -> Boolean
classesSimilar graph (IRClassData { names: _, properties: pa }) (IRClassData { names: _, properties: pb }) =
    propertiesSimilar pa pb ||
    propertiesAreSubset graph pa pb ||
    propertiesAreSubset graph pb pa

-- similarClasses :: L.List IRClassData -> { classes :: Set IRClassData, replacements :: Map IRClassData IRClassData }
-- similarClasses L.Nil = { classes: S.empty, replacements: M.empty }
-- similarClasses (thisClass@(IRClassData name properties) : rest) =
--     let { yes: similar, no: others } = L.partition isSimilar rest
--         recursiveResult@{ classes, replacements } = similarClasses others
--     in
--         if L.length similar == 0 then
--             recursiveResult
--         else
--             let unified = L.foldl unifyClasses thisClass similar
--                 newReplacements = M.fromFoldable (map (\c -> Tuple c unified) (thisClass : similar))
--             in
--                 { classes: S.insert unified classes, replacements: M.union replacements newReplacements  }
--     where
--         isSimilar = classesSimilar thisClass

combineNames :: S.Set String -> String
combineNames s =
    case L.fromFoldable s of
    L.Nil -> "NONAME"
    n : _ -> n

instance eqIRType :: Eq IRType where
    eq IRNothing IRNothing = true
    eq IRNull IRNull = true
    eq IRInteger IRInteger = true
    eq IRDouble IRDouble = true
    eq IRBool IRBool = true
    eq IRString IRString = true
    eq (IRArray a) (IRArray b) = a == b
    eq (IRClass a) (IRClass b) = a == b
    eq (IRUnion a) (IRUnion b) = a == b
    eq _ _ = false

instance ordIRType :: Ord IRType where
    compare IRNothing IRNothing = EQ
    compare IRNothing _ = LT
    compare _ IRNothing = GT
    compare IRNull IRNull = EQ
    compare IRNull _ = LT
    compare _ IRNull = GT
    compare IRInteger IRInteger = EQ
    compare IRInteger _ = LT
    compare _ IRInteger = GT
    compare IRDouble IRDouble = EQ
    compare IRDouble _ = LT
    compare _ IRDouble = GT
    compare IRBool IRBool = EQ
    compare IRBool _ = LT
    compare _ IRBool = GT
    compare IRString IRString = EQ
    compare IRString _ = LT
    compare _ IRString = GT
    compare (IRArray a) (IRArray b) = compare a b
    compare (IRArray _) _ = LT
    compare _ (IRArray _) = GT
    compare (IRClass a) (IRClass b) = compare a b
    compare (IRClass _) _ = LT
    compare _ (IRClass _) = GT
    compare (IRUnion a) (IRUnion b) = compare a b

instance eqIRClassData :: Eq IRClassData where
    eq (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) = na == nb && pa == pb

instance ordIRClassData :: Ord IRClassData where
    compare (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) =
        case compare na nb of
        EQ -> compare pa pb
        x -> x

module IR where

import Control.Monad.State
import Control.Monad.State.Class
import Prelude

import Data.Either (Either(..))
import Data.Foldable (find, all, any)
import Data.List (List(..), concatMap, length, singleton, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromJust)
import Data.Set (Set)
import Data.Set as S
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)

newtype IRGraph = IRGraph { classes :: List (Either IRClassData Int) }

newtype IRClassData = IRClassData { names :: Set String, properties :: Map String IRType }

makeClass :: String -> Map String IRType -> IRClassData
makeClass name properties =
    IRClassData { names: S.singleton name, properties }

emptyGraph :: IRGraph
emptyGraph = IRGraph { classes: L.Nil }

addClass :: IRClassData -> State IRGraph IRType
addClass classData =
    do
        IRGraph { classes } <- get
        put (IRGraph { classes: (L.snoc classes (Left classData)) })
        pure $ IRClass (L.length classes)

redirectClass :: Int -> Int -> State IRGraph Unit
redirectClass from to =
    do
        (IRGraph { classes: c1 }) <- get
        let c2 = unsafePartial $ fromJust $ L.updateAt from (Right to) c1
        put (IRGraph { classes: c2 })

getClassFromGraph :: IRGraph -> Int -> IRClassData
getClassFromGraph graph@(IRGraph { classes }) index =
    case unsafePartial $ fromJust $ L.index classes index of
    Left cd -> cd
    Right i -> getClassFromGraph graph i

getClass :: Int -> State IRGraph IRClassData
getClass index =
    do
        graph <- get
        pure $ getClassFromGraph graph index

combineClasses :: Int -> Int -> IRClassData -> State IRGraph IRType
combineClasses ia ib combined =
    do
        IRGraph { classes } <- get
        let newIndex = L.length classes
        t <- addClass combined
        redirectClass ia newIndex
        redirectClass ib newIndex
        pure t

classesInGraph :: IRGraph -> List IRClassData
classesInGraph (IRGraph { classes }) =
    L.concatMap mapper classes
    where
        mapper =
            case _ of
            Left cd -> L.singleton cd
            Right _ -> L.Nil

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass Int
    | IRUnion (Set IRType)

lookupOrDefault :: forall k v. Ord k => v -> k -> Map k v -> v
lookupOrDefault default key m =
    case M.lookup key m of
    Nothing -> default
    Just x -> x

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s =
    let element = (find p s)
    in
        case element of
            Just x -> { element: element, rest: S.difference s (S.delete x s) }
            Nothing -> { element: element, rest: s }

mapM :: forall a b. (a -> State IRGraph b) -> List a -> State IRGraph (List b)
mapM _ L.Nil = pure L.Nil
mapM f (x : xs) =
    do
        ys <- mapM f xs
        y <- f x
        pure $ y : ys

-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> State IRGraph v) -> v -> Map k v -> Map k v -> State IRGraph (Map k v)
unionWithDefault unifier default m1 m2 =
    let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ M.keys m1) (S.fromFoldable $ M.keys m2)
        valueFor k = unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2)
        keyMapper k =
            do
                v <- valueFor k
                pure $ Tuple k v
    in
        do
            kvps <- mapM keyMapper allKeys
            pure $ M.fromFoldable kvps

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

decomposeTypeSet :: S.Set IRType -> { maybeArray :: Maybe IRType, maybeClass :: Maybe IRType, rest :: S.Set IRType }
decomposeTypeSet s =
    let { element: maybeArray, rest: rest } = removeElement isArray s
        { element: maybeClass, rest: rest } = removeElement isClass rest
    in
        { maybeArray, maybeClass, rest }

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

unifyClasses :: IRClassData -> IRClassData -> State IRGraph IRClassData
unifyClasses (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) =
    do
        properties <- unionWithDefault unifyTypesWithNull IRNothing pa pb
        pure $ IRClassData { names: (S.union na nb), properties: properties }

unifyMaybes :: Maybe IRType -> Maybe IRType -> State IRGraph IRType
unifyMaybes Nothing Nothing = pure IRNothing
unifyMaybes (Just a) Nothing = pure a
unifyMaybes Nothing (Just b) = pure b
unifyMaybes (Just a) (Just b) = unifyTypes a b

unifyUnion :: S.Set IRType -> S.Set IRType -> State IRGraph (S.Set IRType)
unifyUnion sa sb =
    do
        let { maybeArray: arrayA, maybeClass: classA, rest: sa } = decomposeTypeSet sa
        let { maybeArray: arrayB, maybeClass: classB, rest: sb } = decomposeTypeSet sb
        unifiedArray <- unifyMaybes arrayA arrayB
        unifiedClasses <- unifyMaybes classA classB
        pure $ S.unions [sa, sb, setFromType unifiedArray, setFromType unifiedClasses]

unifyTypes :: IRType -> IRType -> State IRGraph IRType
unifyTypes IRNothing x = pure x
unifyTypes x IRNothing = pure x
unifyTypes (IRArray a) (IRArray b) =
    do
        unified <- unifyTypes a b
        pure $ IRArray unified
unifyTypes (IRClass ia) (IRClass ib) =
    do
        a <- getClass ia
        b <- getClass ib
        unified <- unifyClasses a b
        combineClasses ia ib unified
unifyTypes (IRUnion a) (IRUnion b) =
    do
        unified <- unifyUnion a b
        pure $ IRUnion unified
unifyTypes (IRUnion a) b =
    do
        unified <- unifyUnion a (S.singleton b)
        pure $ IRUnion unified
unifyTypes a (IRUnion b) =
    do
        unified <- unifyUnion (S.singleton a) b
        pure $ IRUnion unified
unifyTypes a b =
    do
        pure $ if a == b then a else IRUnion (S.fromFoldable [a, b])

nullifyNothing :: IRType -> IRType
nullifyNothing IRNothing = IRNull
nullifyNothing x = x

unifyTypesWithNull :: IRType -> IRType -> State IRGraph IRType
unifyTypesWithNull IRNothing IRNothing = pure IRNothing
unifyTypesWithNull a b = unifyTypes (nullifyNothing a) (nullifyNothing b)

matchingProperties :: forall v. Eq v => Map String v -> Map String v -> Map String v
matchingProperties ma mb =
    M.fromFoldable (L.concatMap getFromB (M.toUnfoldable ma))
    where
        getFromB (Tuple k va) =
            case M.lookup k mb of
            Just vb -> if va == vb then Tuple k vb : L.Nil else L.Nil
            Nothing -> L.Nil

propertiesSimilar :: forall v. Eq v => Map String v -> Map String v -> Boolean
propertiesSimilar pa pb =
    let aInB = M.size $ matchingProperties pa pb
        bInA = M.size $ matchingProperties pb pa
    in
        (aInB * 4 >= (M.size pa) * 3) && (bInA * 4 >= (M.size pb) * 3)

isMaybeSubtypeOfMaybe :: IRGraph -> Maybe IRType -> Maybe IRType -> Boolean
isMaybeSubtypeOfMaybe _ Nothing Nothing = true
isMaybeSubtypeOfMaybe graph (Just a) (Just b) = isSubtypeOf graph a b
isMaybeSubtypeOfMaybe _ _ _ = false

isSubtypeOf :: IRGraph ->  IRType -> IRType -> Boolean
isSubtypeOf _ IRNothing _ = true
isSubtypeOf graph (IRUnion sa) (IRUnion sb) =
    all (\ta -> any (isSubtypeOf graph ta) sb) sa
isSubtypeOf graph (IRArray a) (IRArray b) =
    isSubtypeOf graph a b
isSubtypeOf graph (IRClass ia) (IRClass ib) =
    let IRClassData { names: _, properties: pa } = getClassFromGraph graph ia
        IRClassData { names: _, properties: pb } = getClassFromGraph graph ib
    in
        propertiesAreSubset graph pa pb
isSubtypeOf _ a b = a == b

propertiesAreSubset :: IRGraph -> Map String IRType -> Map String IRType -> Boolean
propertiesAreSubset graph ma mb =
    all isInB (M.toUnfoldable ma :: List _)
    where
        isInB (Tuple n ta) =
            case M.lookup n mb of
            Nothing -> false
            Just tb -> isSubtypeOf graph ta tb

classesSimilar :: IRGraph -> IRClassData -> IRClassData -> Boolean
classesSimilar graph (IRClassData { names: _, properties: pa }) (IRClassData { names: _, properties: pb }) =
    propertiesSimilar pa pb ||
    propertiesAreSubset graph pa pb ||
    propertiesAreSubset graph pb pa

-- similarClasses :: L.List IRClassData -> { classes :: Set IRClassData, replacements :: Map IRClassData IRClassData }
-- similarClasses L.Nil = { classes: S.empty, replacements: M.empty }
-- similarClasses (thisClass@(IRClassData name properties) : rest) =
--     let { yes: similar, no: others } = L.partition isSimilar rest
--         recursiveResult@{ classes, replacements } = similarClasses others
--     in
--         if L.length similar == 0 then
--             recursiveResult
--         else
--             let unified = L.foldl unifyClasses thisClass similar
--                 newReplacements = M.fromFoldable (map (\c -> Tuple c unified) (thisClass : similar))
--             in
--                 { classes: S.insert unified classes, replacements: M.union replacements newReplacements  }
--     where
--         isSimilar = classesSimilar thisClass

combineNames :: S.Set String -> String
combineNames s =
    case L.fromFoldable s of
    L.Nil -> "NONAME"
    n : _ -> n

instance eqIRType :: Eq IRType where
    eq IRNothing IRNothing = true
    eq IRNull IRNull = true
    eq IRInteger IRInteger = true
    eq IRDouble IRDouble = true
    eq IRBool IRBool = true
    eq IRString IRString = true
    eq (IRArray a) (IRArray b) = a == b
    eq (IRClass a) (IRClass b) = a == b
    eq (IRUnion a) (IRUnion b) = a == b
    eq _ _ = false

instance ordIRType :: Ord IRType where
    compare IRNothing IRNothing = EQ
    compare IRNothing _ = LT
    compare _ IRNothing = GT
    compare IRNull IRNull = EQ
    compare IRNull _ = LT
    compare _ IRNull = GT
    compare IRInteger IRInteger = EQ
    compare IRInteger _ = LT
    compare _ IRInteger = GT
    compare IRDouble IRDouble = EQ
    compare IRDouble _ = LT
    compare _ IRDouble = GT
    compare IRBool IRBool = EQ
    compare IRBool _ = LT
    compare _ IRBool = GT
    compare IRString IRString = EQ
    compare IRString _ = LT
    compare _ IRString = GT
    compare (IRArray a) (IRArray b) = compare a b
    compare (IRArray _) _ = LT
    compare _ (IRArray _) = GT
    compare (IRClass a) (IRClass b) = compare a b
    compare (IRClass _) _ = LT
    compare _ (IRClass _) = GT
    compare (IRUnion a) (IRUnion b) = compare a b

instance eqIRClassData :: Eq IRClassData where
    eq (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) = na == nb && pa == pb

instance ordIRClassData :: Ord IRClassData where
    compare (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) =
        case compare na nb of
        EQ -> compare pa pb
        x -> x


Fix Test.Glyph

Fix Test.Glyph

module Test.Glyph
       ( svgCanvasTest
       , prop_semigroup
       , prop_monoid
       ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log)
import DOM (DOM)
import DOM.Node.Types as DOM
import Data.Int (toNumber)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Monoid (mempty)
import Data.Traversable (traverse_)
import Genetics.Browser.Feature (Feature(..), ScreenFeature, featureToScreen)
import Genetics.Browser.Glyph (Glyph, circle, fill, rect, stroke)
import Genetics.Browser.GlyphF.Canvas as Canvas
import Genetics.Browser.GlyphF.SVG as SVG
import Genetics.Browser.GlyphPosition (GlyphPosition(..))
import Genetics.Browser.Units (Bp(..), MBp(..))
import Graphics.Canvas (getCanvasElementById, getContext2D, translate)
import Jack (Gen, Property, chooseInt, forAll, forAllRender, property)

type ThreeGlyphs = {l :: GlyphPosition, c :: GlyphPosition, r :: GlyphPosition}

renderGlyphs :: ThreeGlyphs -> String
renderGlyphs {l,c,r} = "{ l: " <> show l <> ", c:" <> show c <> ", r:" <> show r <> "}"

genGlyphPosition :: Gen GlyphPosition
genGlyphPosition = do
  let cf = toNumber <$> chooseInt (-10000000) (10000000)
  min <- cf
  max <- cf
  minY <- cf
  maxY <- cf
  pure $ GlyphPos { min, max, minY, maxY }

genThreeGlyphs :: Gen ThreeGlyphs
genThreeGlyphs = do
  l <- genGlyphPosition
  c <- genGlyphPosition
  r <- genGlyphPosition
  pure $ {l, c, r}

prop_semigroup :: Property
prop_semigroup =
  forAllRender renderGlyphs genThreeGlyphs \pos ->
    property $ (pos.l <> pos.c) <> pos.r == pos.l <> (pos.c <> pos.r)

prop_monoid :: Property
prop_monoid =
  forAll genGlyphPosition \pos ->
    property $ pos <> mempty == pos

-- In browser SVG/Canvas tests
foreign import addElementToDiv :: ∀ eff. String -> DOM.Element -> Eff ( dom :: DOM | eff ) Unit
foreign import setOnLoad :: ∀ eff. Eff eff Unit -> Eff eff Unit

exGlyph :: Glyph Unit
exGlyph = do
  stroke "#ff0000"
  fill "#333333"
  rect {x: 0.0, y: 0.0} {x: 20.0, y: 140.0}
  stroke "#00ff00"
  fill "#777777"
  circle {x: 48.0, y: 30.0} 5.356
  stroke "#0000ff"
  fill "#aaaaaa"
  rect {x: 0.0, y: 10.0} {x: 400.0, y: 15.0}

exFeature1 :: Feature MBp Unit
exFeature1 = Feature ("1") (MBp (-5.0)) (MBp 5.0) unit
exFeature2 :: Feature MBp Unit
exFeature2 = Feature ("1") (MBp 10.0) (MBp 20.0) unit
exFeature3 :: Feature Bp Unit
exFeature3 = Feature ("1") (Bp 60000.0) (Bp 61000.0) unit

glyph1 :: Glyph Unit
glyph1 = glyphify 0.0 (featureToScreen (MBp 0.0) (MBp 5.0) exFeature1)

glyph2 :: Glyph Unit
glyph2 = glyphify 50.0 (featureToScreen (MBp 0.0) (MBp 5.0) exFeature2)

glyph3 :: Glyph Unit
glyph3 = glyphify 100.0 (featureToScreen (Bp 0.0) (Bp 5.0) exFeature3)

glyphify :: Number -> ScreenFeature Unit -> Glyph Unit
glyphify y (Feature _ xl xr _) = do
  stroke "#ff0000"
  fill "#555555"
  rect { x: xl, y: y } { x: xr, y: y + 40.0 }

runBrowserTest :: Eff _ Unit
runBrowserTest = do
  canvas <- getCanvasElementById "canvas"
  case canvas of
    Nothing -> log "couldn't find canvas"
    Just c  -> do
      ctx <- getContext2D c
      _ <- translate {translateX: -200.0, translateY: 0.0} ctx
      log "rendering glyph to canvas"
      traverse_ (Canvas.renderGlyph ctx) [glyph1, glyph2, glyph3]

  log "rendering glyph to svg"
  traverse_ (\g -> SVG.renderGlyph g >>= addElementToDiv "svgDiv") [glyph1, glyph2, glyph3]
  pure unit

svgCanvasTest :: Eff _ Unit
svgCanvasTest = setOnLoad runBrowserTest

module Test.Glyph
       ( svgCanvasTest
       , prop_semigroup
       , prop_monoid
       ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log)
import DOM (DOM)
import DOM.Node.Types as DOM
import Data.Int (toNumber)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Monoid (mempty)
import Data.Traversable (traverse_)
import Genetics.Browser.Feature (Feature(..), ScreenFeature, featureToScreen)
import Genetics.Browser.Glyph (Glyph, circle, fill, rect, stroke)
import Genetics.Browser.GlyphF.Canvas as Canvas
import Genetics.Browser.GlyphF.SVG as SVG
import Genetics.Browser.GlyphPosition (GlyphPosition(..))
import Genetics.Browser.Units (Bp(..), MBp(..))
import Graphics.Canvas (getCanvasElementById, getContext2D, translate)
import Jack (Gen, Property, chooseInt, forAll, forAllRender, property)

type ThreeGlyphs = {l :: GlyphPosition, c :: GlyphPosition, r :: GlyphPosition}

renderGlyphs :: ThreeGlyphs -> String
renderGlyphs {l,c,r} = "{ l: " <> show l <> ", c:" <> show c <> ", r:" <> show r <> "}"

genGlyphPosition :: Gen GlyphPosition
genGlyphPosition = do
  let cf = toNumber <$> chooseInt (-10000000) (10000000)
  min <- cf
  max <- cf
  minY <- cf
  maxY <- cf
  pure $ GlyphPos { min, max, minY, maxY }

genThreeGlyphs :: Gen ThreeGlyphs
genThreeGlyphs = do
  l <- genGlyphPosition
  c <- genGlyphPosition
  r <- genGlyphPosition
  pure $ {l, c, r}

prop_semigroup :: Property
prop_semigroup =
  forAllRender renderGlyphs genThreeGlyphs \pos ->
    property $ (pos.l <> pos.c) <> pos.r == pos.l <> (pos.c <> pos.r)

prop_monoid :: Property
prop_monoid =
  forAll genGlyphPosition \pos ->
    property $ pos <> mempty == pos

-- In browser SVG/Canvas tests
foreign import addElementToDiv :: ∀ eff. String -> DOM.Element -> Eff ( dom :: DOM | eff ) Unit
foreign import setOnLoad :: ∀ eff. Eff eff Unit -> Eff eff Unit

exGlyph :: Glyph Unit
exGlyph = do
  stroke "#ff0000"
  fill "#333333"
  rect {x: 0.0, y: 0.0} {x: 20.0, y: 140.0}
  stroke "#00ff00"
  fill "#777777"
  circle {x: 48.0, y: 30.0} 5.356
  stroke "#0000ff"
  fill "#aaaaaa"
  rect {x: 0.0, y: 10.0} {x: 400.0, y: 15.0}

exFeature1 :: Feature MBp Unit
exFeature1 = Feature "1" (MBp (-5.0)) (MBp 5.0) unit
exFeature2 :: Feature MBp Unit
exFeature2 = Feature "1" (MBp 10.0) (MBp 20.0) unit
exFeature3 :: Feature Bp Unit
exFeature3 = Feature "1" (Bp 60000.0) (Bp 61000.0) unit

glyph1 :: Glyph Unit
glyph1 = glyphify 0.0 (featureToScreen (MBp 0.0) (MBp 5.0) exFeature1)

glyph2 :: Glyph Unit
glyph2 = glyphify 50.0 (featureToScreen (MBp 0.0) (MBp 5.0) exFeature2)

glyph3 :: Glyph Unit
glyph3 = glyphify 100.0 (featureToScreen (Bp 0.0) (Bp 5.0) exFeature3)

glyphify :: Number -> ScreenFeature Unit -> Glyph Unit
glyphify y (Feature _ xl xr _) = do
  stroke "#ff0000"
  fill "#555555"
  rect { x: xl, y: y } { x: xr, y: y + 40.0 }

runBrowserTest :: Eff _ Unit
runBrowserTest = do
  canvas <- getCanvasElementById "canvas"
  case canvas of
    Nothing -> log "couldn't find canvas"
    Just c  -> do
      ctx <- getContext2D c
      _ <- translate {translateX: -200.0, translateY: 0.0} ctx
      log "rendering glyph to canvas"
      traverse_ (Canvas.renderGlyph ctx) [glyph1, glyph2, glyph3]

  log "rendering glyph to svg"
  traverse_ (\g -> SVG.renderGlyph g >>= addElementToDiv "svgDiv") [glyph1, glyph2, glyph3]
  pure unit

svgCanvasTest :: Eff _ Unit
svgCanvasTest = setOnLoad runBrowserTest