Invalidate child memo on state change

Invalidate child memo on state change

module Halogen.Component
  ( Component()
  , ComponentHTML()
  , ComponentSpec()
  , Render()
  , ComponentDSL()
  , Eval()
  , component
  , componentSpec
  , ParentHTML()
  , ParentQuery()
  , RenderParent()
  , SlotConstructor(..)
  , ParentDSL()
  , EvalParent()
  , Peek()
  , parentComponent
  , parentComponentSpec
  , parentComponent'
  , parentComponentSpec'
  , InstalledState()
  , installedState
  , ChildF(..)
  , runChildF
  , QueryF()
  , mkQuery
  , mkQuery'
  , mkQueries
  , mkQueries'
  , liftQuery
  , query
  , query'
  , queryAll
  , queryAll'
  , childSlots
  , transform
  , transformChild
  , interpret
  , renderComponent
  , queryComponent
  , initializeComponent
  , finalizeComponent
  ) where

import Prelude

import Control.Apply ((<*))
import Control.Bind ((=<<))
import Control.Monad.Free (Free(), foldFree, liftF, mapF)
import Control.Monad.Free.Trans as FT
import Control.Monad.State (State(), runState)
import Control.Monad.State.Trans as CMS
import Control.Monad.Writer.Trans (WriterT(), runWriterT)
import Control.Monad.Writer.Trans as CMW

import Data.Bifunctor (lmap, rmap)
import Data.Foldable (foldMap, for_)
import Data.Functor.Coproduct (Coproduct(), coproduct, left, right)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Maybe.Unsafe as U
import Data.NaturalTransformation (Natural())
import Data.Traversable (for, traverse)
import Data.Tuple (Tuple(..), snd)
import Data.Void (Void())

import Halogen.Component.ChildPath (ChildPath(..), injState, injQuery, injSlot, prjState, prjQuery, prjSlot)
import Halogen.Component.Hook (Hook(..), Finalized(), finalized, mapFinalized, lmapHook, rmapHook)
import Halogen.Component.Tree (Tree(), mkTree, mkTree', graftTree, thunkTree, emptyTree)
import Halogen.HTML.Core (HTML(..), fillSlot)
import Halogen.Query (get, modify, liftH, Action())
import Halogen.Query.EventSource (EventSource(..), ParentEventSource(), runEventSource, fromParentEventSource)
import Halogen.Query.HalogenF (HalogenF(), HalogenFP(..), hoistHalogenF, transformHF)
import Halogen.Query.StateF (StateF(..), mapState)

import Unsafe.Coerce (unsafeCoerce)

-- | Data type for Halogen components.
-- | - `s` - the component's state
-- | - `f` - the component's query algebra
-- | - `g` - a functor integrated into the component's query algebra that allows
-- |         embedding of external DSLs or handling of effects.
newtype Component s f g = Component
  { render :: RenderM s f g (Tree f Unit)
  , eval :: Eval f s f g
  , initializer :: Maybe (f Unit)
  , finalizers :: s -> Array (Finalized g)
  }

-- | The type for the internal render monad. Rendering returns HTML, a new
-- | state, and input hooks to run post-render.
type RenderM s f g = WriterT (Array (Hook f g)) (State s)

-- | The type for `HTML` rendered by a self-contained component.
type ComponentHTML f = HTML Void (f Unit)

-- | A type alias for a component `render` function - takes the component's
-- | current state and returns a `HTML` value.
type Render s f = s -> ComponentHTML f

-- | The DSL used in the `eval` function for self-contained components.
type ComponentDSL s f g = Free (HalogenF s f g)

-- | A type alias for a component `eval` function - takes a functorial value `i`
-- | and returns a `Free` of the Halogen component algebra.
-- |
-- | Usually `i` will be the same type as `f`, but sometimes it is useful to be
-- | able to break up an `Eval` function into different parts, in which case
-- | `i`'s type may differ.
type Eval i s f g = Natural i (ComponentDSL s f g)

-- | Builds a self-contained component with no possible children.
component :: forall s f g. Render s f -> Eval f s f g -> Component s f g
component r e = componentSpec { render: r, eval: e, initializer: Nothing, finalizer: Nothing }

-- | A full spec for a component, including lifecycle inputs.
type ComponentSpec s f g =
  { render :: Render s f
  , eval :: Eval f s f g
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a self-contained component with no possible children that may have
-- | lifecycle hooks.
componentSpec :: forall s f g. ComponentSpec s f g -> Component s f g
componentSpec spec =
  Component
    { render: renderTree <$> CMS.gets spec.render
    , eval: spec.eval
    , initializer: spec.initializer
    , finalizers: finalizers
    }
  where
  renderTree :: ComponentHTML f -> Tree f Unit
  renderTree html = mkTree'
    { slot: unit
    , html: unsafeCoerce html -- Safe because p is Void
    , eq: \_ _ -> false -- Absurd
    , thunk: false
    }

  finalizers :: s -> Array (Finalized g)
  finalizers s =
    case spec.finalizer of
      Just i -> [ finalized spec.eval s i ]
      _      -> []

-- | The type for `HTML` rendered by a parent component.
type ParentHTML s' f f' g p = HTML (SlotConstructor s' f' g p) (f Unit)

-- | The type for nested queries.
type ParentQuery f f' p = Coproduct f (ChildF p f')

-- | A variation on `Render` for parent components - the function follows the
-- | same form but the type representation is different.
type RenderParent s s' f f' g p = s -> ParentHTML s' f f' g p

-- | The type used for slots in the HTML rendered by parent components.
data SlotConstructor s' f' g p = SlotConstructor p (Unit -> { component :: Component s' f' g, initialState :: s' })

-- | The DSL used in the `eval` and `peek` functions for parent components.
type ParentDSL s s' f f' g p = Free (HalogenFP ParentEventSource s f (QueryF s s' f f' g p))

-- | A variation on `Eval` for parent components - the function follows the
-- | same form but the type representation is different.
type EvalParent i s s' f f' g p = Natural i (ParentDSL s s' f f' g p)

-- | A type alias for a component `peek` function that observes inputs to child
-- | components.
type Peek i s s' f f' g p = forall a. i a -> ParentDSL s s' f f' g p Unit

-- | Builds a component that may contain child components.
parentComponent
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => RenderParent s s' f f' g p
  -> EvalParent f s s' f f' g p
  -> Component (InstalledState s s' f f' g p) (ParentQuery f f' p) g
parentComponent r e = parentComponentSpec { render: r, eval: e, initializer: Nothing, finalizer: Nothing }

-- | A full spec for a parent component, including lifecycle inputs.
type ParentComponentSpec s s' f f' g p =
  { render :: RenderParent s s' f f' g p
  , eval :: EvalParent f s s' f f' g p
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a component that may contain child components and have lifcycle hooks.
parentComponentSpec
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => ParentComponentSpec s s' f f' g p
  -> Component (InstalledState s s' f f' g p) (ParentQuery f f' p) g
parentComponentSpec spec =
  Component
    { render: renderParent spec.render
    , eval: eval
    , initializer: left <$> spec.initializer
    , finalizers: parentFinalizers eval spec.finalizer
    }
  where
  eval :: Eval (ParentQuery f f' p) (InstalledState s s' f f' g p) (ParentQuery f f' p) g
  eval = coproduct (queryParent spec.eval) queryChild

-- | Builds a component that may contain child components and additionally
-- | supports the `peek` operation to allow the parent to observe queries that
-- | descendant components have processed.
parentComponent'
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => RenderParent s s' f f' g p
  -> EvalParent f s s' f f' g p
  -> Peek (ChildF p f') s s' f f' g p
  -> Component (InstalledState s s' f f' g p) (ParentQuery f f' p) g
parentComponent' r e p = parentComponentSpec' { render: r, eval: e, peek: p, initializer: Nothing, finalizer: Nothing }

-- | A full spec for a parent component, including lifecycle inputs and a
-- | `peek` operation.
type ParentComponentSpecP s s' f f' g p =
  { render :: RenderParent s s' f f' g p
  , eval :: EvalParent f s s' f f' g p
  , peek :: Peek (ChildF p f') s s' f f' g p
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a component that may contain child components, peek, and
-- | lifecycle hooks.
parentComponentSpec'
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => ParentComponentSpecP s s' f f' g p
  -> Component (InstalledState s s' f f' g p) (ParentQuery f f' p) g
parentComponentSpec' spec = Component
  { render: renderParent spec.render
  , eval: eval
  , initializer: left <$> spec.initializer
  , finalizers: parentFinalizers eval spec.finalizer
  }
  where
  eval :: Eval (ParentQuery f f' p) (InstalledState s s' f f' g p) (ParentQuery f f' p) g
  eval = coproduct (queryParent spec.eval) \q -> queryChild q <* queryParent spec.peek q

parentFinalizers
  :: forall s s' f f' g p
   . Eval (ParentQuery f f' p) (InstalledState s s' f f' g p) (ParentQuery f f' p) g
  -> Maybe (f Unit)
  -> InstalledState s s' f f' g p
  -> Array (Finalized g)
parentFinalizers eval fin (InstalledState s) =
  foldMap childFin s.children <> parentFin
  where
  parentFin :: Array (Finalized g)
  parentFin =
    case fin of
      Just i -> [ finalized eval (InstalledState s { children = M.empty, memo = M.empty }) (left i) ]
      _      -> []

  childFin :: Tuple (Component s' f' g) s' -> Array (Finalized g)
  childFin (Tuple (Component c) s) = c.finalizers s

-- | The type used by component containers for their state where `s` is the
-- | state local to the container, `p` is the type of slot used by the
-- | container, and the remaining parameters are the type variables for the
-- | child components.
newtype InstalledState s s' f f' g p = InstalledState
  { parent :: s
  , children :: M.Map p (Tuple (Component s' f' g) s')
  , memo :: M.Map p (Tree (ParentQuery f f' p) p)
  }

-- | Lifts a state value into an `InstalledState` value. Useful when providing
-- | an initial state value for a parent component.
installedState :: forall s s' f f' g p. (Ord p) => s -> InstalledState s s' f f' g p
installedState st = InstalledState { parent: st, children: M.empty, memo: M.empty }

-- | An intermediate algebra that parent components "produce" from their `eval`
-- | and `peek` functions. This takes the place of `g` when compared to a leaf
-- | (non-parent) component.
type QueryF s s' f f' g p = Free (HalogenF (InstalledState s s' f f' g p) (ChildF p f') g)

-- | An intermediate algebra used to associate values from a child component's
-- | algebra with the slot the component was installed into.
data ChildF p f i = ChildF p (f i)

-- | Extracts the query part from a ChildF value, discarding the slot value.
runChildF :: forall p f i. ChildF p f i -> f i
runChildF (ChildF _ q) = q

instance functorChildF :: (Functor f) => Functor (ChildF p f) where
  map f (ChildF p fi) = ChildF p (f <$> fi)

-- | Queries a child component, for use within a parent component's `eval` or
-- | `peek` function.
query
  :: forall s s' f f' g p i
   . (Functor g, Ord p)
  => p
  -> f' i
  -> Free (HalogenFP ParentEventSource s f (QueryF s s' f f' g p)) (Maybe i)
query p q = liftQuery (mkQuery p q)

-- | A version of [`query`](#query) for use when a parent component has multiple
-- | types of child component.
query'
  :: forall s s' s'' f f' f'' g p p' i
   . (Functor g, Ord p')
  => ChildPath s s' f f' p p'
  -> p
  -> f i
  -> Free (HalogenFP ParentEventSource s'' f'' (QueryF s'' s' f'' f' g p')) (Maybe i)
query' i p q = liftQuery (mkQuery' i p q)

-- | Queries every child component that is currently installed. For use within
-- | a parent component's `eval` or `peek` function.
queryAll
  :: forall s s' f f' g p i
   . (Functor g, Ord p)
  => f' i
  -> Free (HalogenFP ParentEventSource s f (QueryF s s' f f' g p)) (M.Map p i)
queryAll q = liftQuery (mkQueries q)

-- | Returns slots of all currently installed child components.
childSlots
  :: forall s s' f f' p g
  . (Functor g, Ord p)
  => QueryF s s' f f' g p (L.List p)
childSlots = do
  InstalledState st <- get
  pure (M.keys st.children)

-- | A version of [`queryAll](#queryAll) for use when a parent component has
-- | multiple types of child component.
queryAll'
  :: forall s s' s'' f f' f'' g p p' i
   . (Functor g, Ord p, Ord p')
  => ChildPath s s' f f' p p'
  -> f i
  -> Free (HalogenFP ParentEventSource s'' f'' (QueryF s'' s' f'' f' g p')) (M.Map p i)
queryAll' i q = liftQuery (mkQueries' i q)

-- | Creates a query for a child component where `p` is the slot the component
-- | was installed into and `f' i` in the input query.
-- |
-- | If a component is not found for the slot the result of the query
-- | will be `Nothing`.
mkQuery
  :: forall s s' f f' p g i
   . (Functor g, Ord p)
  => p
  -> f' i
  -> QueryF s s' f f' g p (Maybe i)
mkQuery p q = do
  InstalledState st <- get
  for (M.lookup p st.children) \(Tuple c _) ->
    mapF (transformHF (mapStateFChild p) (ChildF p) id) (queryComponent c q)

-- | A version of [`mkQuery`](#mkQuery) for use when a parent component has
-- | multiple types of child component.
mkQuery'
  :: forall s s' s'' f f' f'' g p p' i
   . (Functor g, Ord p')
  => ChildPath s s' f f' p p'
  -> p
  -> f i
  -> QueryF s'' s' f'' f' g p' (Maybe i)
mkQuery' i p q = mkQuery (injSlot i p) (injQuery i q)

-- | Creates a query for every child component that is currently installed.
mkQueries
  :: forall s s' f f' p g i
   . (Functor g, Ord p)
  => f' i
  -> QueryF s s' f f' g p (M.Map p i)
mkQueries = mkQueries' (ChildPath id id id)

-- | A version of [`mkQueries](#mkQueries) for use when a parent component has
-- | multiple types of child component.
mkQueries'
  :: forall s s' s'' f f' f'' g p p' i
   . (Functor g, Ord p', Ord p)
  => ChildPath s s' f f' p p'
  -> f i
  -> QueryF s'' s' f'' f' g p' (M.Map p i)
mkQueries' i q = do
  InstalledState st <- get
  M.fromList <<< L.catMaybes <$> traverse mkChildQuery (M.toList st.children)
  where
  mkChildQuery (Tuple p' (Tuple c _)) =
    for (prjSlot i p')
        \p -> Tuple p <$> mapF (transformHF (mapStateFChild p') (ChildF p') id)
                               (queryComponent c (injQuery i q))

-- | Lifts a value in the `QueryF` algebra into the monad used by a component's
-- | `eval` function.
liftQuery
  :: forall s s' f f' g p
   . (Functor g)
  => Natural (QueryF s s' f f' g p) (ParentDSL s s' f f' g p)
liftQuery = liftH

mapStateFParent :: forall s s' f f' g p. Natural (StateF s) (StateF (InstalledState s s' f f' g p))
mapStateFParent =
  mapState
    (\(InstalledState st) -> st.parent)
    (\f (InstalledState st) -> InstalledState
      { parent: f st.parent
      , children: st.children
      , memo: st.memo
      })

mapStateFChild :: forall s s' f f' g p. (Ord p) => p -> Natural (StateF s') (StateF (InstalledState s s' f f' g p))
mapStateFChild p =
  mapState
    (\(InstalledState st) -> U.fromJust $ snd <$> M.lookup p st.children)
    (\f (InstalledState st) -> InstalledState
      { parent: st.parent
      , children: M.update (Just <<< rmap f) p st.children
      , memo: M.delete p st.memo
      })

renderParent
  :: forall s s' f f' g p
   . (Ord p)
  => RenderParent s s' f f' g p
  -> RenderM (InstalledState s s' f f' g p) (ParentQuery f f' p) g (Tree (ParentQuery f f' p) Unit)
renderParent render = do
    InstalledState st <- CMS.get
    let html = render st.parent
    -- Empty the state so that we don't keep children that are no longer
    -- being rendered...
    CMS.put $ InstalledState
      { parent: st.parent
      , children: M.empty
      , memo: M.empty
      } :: InstalledState s s' f f' g p
    -- ...but then pass through the old state so we can lookup child
    -- components that are being re-rendered
    html' <- fillSlot (renderChild (InstalledState st)) left html
    (InstalledState st') :: InstalledState s s' f f' g p <- CMS.get
    for_ (M.toList st.children) \(Tuple k (Tuple c s)) ->
      if not (M.member k st'.children)
        then
          let hooks :: Array (Hook (ParentQuery f f' p) g)
              hooks = Finalized <$> finalizeComponent c s
          in CMW.tell hooks
        else
          pure unit
    pure $ mkTree html'

  where

  renderChild
    :: InstalledState s s' f f' g p
    -> SlotConstructor s' f' g p
    -> RenderM (InstalledState s s' f f' g p) (ParentQuery f f' p) g (HTML (Tree (ParentQuery f f' p) p) (ParentQuery f f' p Unit))
  renderChild (InstalledState st) (SlotConstructor p def) =
    let childState = M.lookup p st.children
    in case M.lookup p st.memo of
      Just tree -> do
        CMS.modify \(InstalledState st') -> InstalledState
          { parent: st'.parent
          , children: M.alter (const childState) p st'.children
          , memo: M.insert p tree st'.memo
          } :: InstalledState s s' f f' g p
        pure $ Slot (thunkTree tree)
      Nothing -> case childState of
        Just (Tuple c s) -> renderChild' p c s
        Nothing -> do
          let def' = def unit
          case initializeComponent def'.component of
            Nothing -> pure unit
            Just init ->
              let hook :: Hook (Coproduct f (ChildF p f')) g
                  hook = PostRender (right (ChildF p init))
              in CMW.tell [ hook ]
          renderChild' p def'.component def'.initialState

  renderChild'
    :: p
    -> Component s' f' g
    -> s'
    -> RenderM (InstalledState s s' f f' g p) (ParentQuery f f' p) g (HTML (Tree (ParentQuery f f' p) p) (ParentQuery f f' p Unit))
  renderChild' p c s = do
    let r = renderComponent c s
        tree = graftTree adapt (const p) r.tree

        hooks :: Array (Hook (Coproduct f (ChildF p f')) g)
        hooks = lmapHook adapt <$> r.hooks

        adapt :: Natural f' (Coproduct f (ChildF p f'))
        adapt a = right (ChildF p a)

    CMW.tell hooks
    CMS.modify \(InstalledState st) -> InstalledState
      { parent: st.parent
      , children: M.insert p (Tuple c r.state) st.children
      , memo: M.insert p tree st.memo
      } :: InstalledState s s' f f' g p
    pure $ Slot tree

queryParent
  :: forall s s' f f' g p a q r. (Functor g)
  => (q a -> ParentDSL s s' f f' g p r)
  -> q a
  -> ComponentDSL (InstalledState s s' f f' g p) (ParentQuery f f' p) g r
queryParent f =
  f >>> foldFree \h ->
    case h of
      StateHF q -> mergeParentStateF q
      SubscribeHF es next ->
        liftF $ SubscribeHF (EventSource (FT.interpret (lmap left) (runEventSource (fromParentEventSource es)))) next
      QueryHF q -> liftChildF q
      HaltHF -> liftF HaltHF

mergeParentStateF :: forall s s' f f' g p. Natural (StateF s) (ComponentDSL (InstalledState s s' f f' g p) (ParentQuery f f' p) g)
mergeParentStateF = liftF <<< StateHF <<< mapStateFParent

liftChildF
  :: forall s s' f f' g p
   . (Functor g)
  => Natural (Free (HalogenF (InstalledState s s' f f' g p) (ChildF p f') g)) (ComponentDSL (InstalledState s s' f f' g p) (ParentQuery f f' p) g)
liftChildF = mapF (transformHF id right id)

queryChild
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => Natural (ChildF p f') (ComponentDSL (InstalledState s s' f f' g p) (ParentQuery f f' p) g)
queryChild (ChildF p q) =
  mapF (transformHF id right id) (mkQuery p q)
    >>= maybe (liftF HaltHF) pure

-- | Transforms a `Component`'s types using partial mapping functions.
-- |
-- | If the initial state provided to the component fails the transformation an
-- | empty component will be rendered. If either of the transformations fail the
-- | component will "halt" (evaluate to `empty`), so care must be taken when
-- | handling transformed components to ensure they receive the intended query
-- | values and initial state type.
-- |
-- | Halogen itself will never cause a `transform`ed component to halt; this
-- | situation will only arise when the initial state is incorrect or a bad
-- | externally constructed query is passed to the component.
transform
  :: forall s s' f f' g
   . (Functor g)
  => (s -> s')
  -> (s' -> Maybe s)
  -> (forall a. f a -> f' a)
  -> (forall a. f' a -> Maybe (f a))
  -> Component s f g
  -> Component s' f' g
transform reviewS previewS reviewQ previewQ (Component c) =
  Component
    { render: maybe (pure emptyTree) render' <<< previewS =<< CMS.get
    , eval: maybe (liftF HaltHF) (foldFree go <<< c.eval) <<< previewQ
    , initializer: reviewQ <$> c.initializer
    , finalizers: maybe [] c.finalizers <<< previewS
    }
  where

  render' :: s -> RenderM s' f' g (Tree f' Unit)
  render' st =
    CMW.WriterT $ CMS.StateT \_ ->
      case runState (runWriterT c.render) st of
        Tuple (Tuple tree hooks) st' ->
          pure $ Tuple (Tuple (graftTree reviewQ id tree) (lmapHook reviewQ <$> hooks)) (reviewS st')

  go :: Natural (HalogenF s f g) (Free (HalogenF s' f' g))
  go (StateHF (Get k)) =
    liftF <<< maybe HaltHF (\st' -> StateHF (Get (k <<< const st'))) <<< previewS =<< get
  go (StateHF (Modify f next)) = liftF $ StateHF (Modify (modifyState f) next)
  go (SubscribeHF es next) = liftF $ SubscribeHF (EventSource (FT.interpret (lmap reviewQ) (runEventSource es))) next
  go (QueryHF q) = liftF $ QueryHF q
  go HaltHF = liftF HaltHF

  modifyState :: (s -> s) -> s' -> s'
  modifyState f s' = maybe s' (reviewS <<< f) (previewS s')

-- | Transforms a `Component`'s types using a `ChildPath` definition.
transformChild
  :: forall s s' f f' g p p'
   . (Functor g)
  => ChildPath s s' f f' p p'
  -> Component s f g
  -> Component s' f' g
transformChild i = transform (injState i) (prjState i) (injQuery i) (prjQuery i)

-- | Changes the component's `g` type. A use case for this would be to interpret
-- | some `Free` monad as `Aff` so the component can be used with `runUI`.
interpret
  :: forall s f g g'
   . (Functor g')
  => Natural g g'
  -> Component s f g
  -> Component s f g'
interpret nat (Component c) =
  Component
    { render: render'
    , eval: mapF (hoistHalogenF nat) <<< c.eval
    , initializer: c.initializer
    , finalizers: map (mapFinalized nat) <$> c.finalizers
    }
  where
  render' :: RenderM s f g' (Tree f Unit)
  render' =
    CMW.WriterT $ CMS.StateT \s ->
      case runState (runWriterT c.render) s of
        Tuple (Tuple tree hooks) s' ->
          pure $ Tuple (Tuple tree (rmapHook nat <$> hooks)) s'

-- | Runs a component's `render` function with the specified state, returning
-- | the generated `HTML` and new state.
renderComponent
  :: forall s f g
   . Component s f g
  -> s
  -> { tree  ::  Tree f Unit
     , hooks :: Array (Hook f g)
     , state :: s
     }
renderComponent (Component c) s =
  case runState (runWriterT c.render) s of
    Tuple (Tuple tree hooks) state -> { tree: tree, hooks: hooks, state: state }

-- | Runs a compnent's `query` function with the specified query input and
-- | returns the pending computation as a `Free` monad.
queryComponent :: forall s f g. Component s f g -> Eval f s f g
queryComponent (Component c) = c.eval

initializeComponent :: forall s f g. Component s f g -> Maybe (f Unit)
initializeComponent (Component c) = c.initializer

finalizeComponent :: forall s f g. Component s f g -> s -> Array (Finalized g)
finalizeComponent (Component c) = c.finalizers

module Halogen.Component
  ( Component()
  , ComponentHTML()
  , ComponentSpec()
  , Render()
  , ComponentDSL()
  , Eval()
  , component
  , componentSpec
  , ParentHTML()
  , ParentQuery()
  , RenderParent()
  , SlotConstructor(..)
  , ParentDSL()
  , EvalParent()
  , Peek()
  , parentComponent
  , parentComponentSpec
  , parentComponent'
  , parentComponentSpec'
  , InstalledState()
  , installedState
  , ChildF(..)
  , runChildF
  , QueryF()
  , mkQuery
  , mkQuery'
  , mkQueries
  , mkQueries'
  , liftQuery
  , query
  , query'
  , queryAll
  , queryAll'
  , childSlots
  , transform
  , transformChild
  , interpret
  , renderComponent
  , queryComponent
  , initializeComponent
  , finalizeComponent
  ) where

import Prelude

import Control.Apply ((<*))
import Control.Bind ((=<<))
import Control.Monad.Free (Free(), foldFree, liftF, mapF)
import Control.Monad.Free.Trans as FT
import Control.Monad.State (State(), runState)
import Control.Monad.State.Trans as CMS
import Control.Monad.Writer.Trans (WriterT(), runWriterT)
import Control.Monad.Writer.Trans as CMW

import Data.Bifunctor (lmap, rmap)
import Data.Foldable (foldMap, for_)
import Data.Functor.Coproduct (Coproduct(), coproduct, left, right)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Maybe.Unsafe as U
import Data.NaturalTransformation (Natural())
import Data.Traversable (for, traverse)
import Data.Tuple (Tuple(..), snd)
import Data.Void (Void())

import Halogen.Component.ChildPath (ChildPath(..), injState, injQuery, injSlot, prjState, prjQuery, prjSlot)
import Halogen.Component.Hook (Hook(..), Finalized(), finalized, mapFinalized, lmapHook, rmapHook)
import Halogen.Component.Tree (Tree(), mkTree, mkTree', graftTree, thunkTree, emptyTree)
import Halogen.HTML.Core (HTML(..), fillSlot)
import Halogen.Query (get, modify, liftH, Action())
import Halogen.Query.EventSource (EventSource(..), ParentEventSource(), runEventSource, fromParentEventSource)
import Halogen.Query.HalogenF (HalogenF(), HalogenFP(..), hoistHalogenF, transformHF)
import Halogen.Query.StateF (StateF(..), mapState)

import Unsafe.Coerce (unsafeCoerce)

-- | Data type for Halogen components.
-- | - `s` - the component's state
-- | - `f` - the component's query algebra
-- | - `g` - a functor integrated into the component's query algebra that allows
-- |         embedding of external DSLs or handling of effects.
newtype Component s f g = Component
  { render :: RenderM s f g (Tree f Unit)
  , eval :: Eval f s f g
  , initializer :: Maybe (f Unit)
  , finalizers :: s -> Array (Finalized g)
  }

-- | The type for the internal render monad. Rendering returns HTML, a new
-- | state, and input hooks to run post-render.
type RenderM s f g = WriterT (Array (Hook f g)) (State s)

-- | The type for `HTML` rendered by a self-contained component.
type ComponentHTML f = HTML Void (f Unit)

-- | A type alias for a component `render` function - takes the component's
-- | current state and returns a `HTML` value.
type Render s f = s -> ComponentHTML f

-- | The DSL used in the `eval` function for self-contained components.
type ComponentDSL s f g = Free (HalogenF s f g)

-- | A type alias for a component `eval` function - takes a functorial value `i`
-- | and returns a `Free` of the Halogen component algebra.
-- |
-- | Usually `i` will be the same type as `f`, but sometimes it is useful to be
-- | able to break up an `Eval` function into different parts, in which case
-- | `i`'s type may differ.
type Eval i s f g = Natural i (ComponentDSL s f g)

-- | Builds a self-contained component with no possible children.
component :: forall s f g. Render s f -> Eval f s f g -> Component s f g
component r e = componentSpec { render: r, eval: e, initializer: Nothing, finalizer: Nothing }

-- | A full spec for a component, including lifecycle inputs.
type ComponentSpec s f g =
  { render :: Render s f
  , eval :: Eval f s f g
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a self-contained component with no possible children that may have
-- | lifecycle hooks.
componentSpec :: forall s f g. ComponentSpec s f g -> Component s f g
componentSpec spec =
  Component
    { render: renderTree <$> CMS.gets spec.render
    , eval: spec.eval
    , initializer: spec.initializer
    , finalizers: finalizers
    }
  where
  renderTree :: ComponentHTML f -> Tree f Unit
  renderTree html = mkTree'
    { slot: unit
    , html: unsafeCoerce html -- Safe because p is Void
    , eq: \_ _ -> false -- Absurd
    , thunk: false
    }

  finalizers :: s -> Array (Finalized g)
  finalizers s =
    case spec.finalizer of
      Just i -> [ finalized spec.eval s i ]
      _      -> []

-- | The type for `HTML` rendered by a parent component.
type ParentHTML s' f f' g p = HTML (SlotConstructor s' f' g p) (f Unit)

-- | The type for nested queries.
type ParentQuery f f' p = Coproduct f (ChildF p f')

-- | A variation on `Render` for parent components - the function follows the
-- | same form but the type representation is different.
type RenderParent s s' f f' g p = s -> ParentHTML s' f f' g p

-- | The type used for slots in the HTML rendered by parent components.
data SlotConstructor s' f' g p = SlotConstructor p (Unit -> { component :: Component s' f' g, initialState :: s' })

-- | The DSL used in the `eval` and `peek` functions for parent components.
type ParentDSL s s' f f' g p = Free (HalogenFP ParentEventSource s f (QueryF s s' f f' g p))

-- | A variation on `Eval` for parent components - the function follows the
-- | same form but the type representation is different.
type EvalParent i s s' f f' g p = Natural i (ParentDSL s s' f f' g p)

-- | A type alias for a component `peek` function that observes inputs to child
-- | components.
type Peek i s s' f f' g p = forall a. i a -> ParentDSL s s' f f' g p Unit

-- | Builds a component that may contain child components.
parentComponent
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => RenderParent s s' f f' g p
  -> EvalParent f s s' f f' g p
  -> Component (InstalledState s s' f f' g p) (ParentQuery f f' p) g
parentComponent r e = parentComponentSpec { render: r, eval: e, initializer: Nothing, finalizer: Nothing }

-- | A full spec for a parent component, including lifecycle inputs.
type ParentComponentSpec s s' f f' g p =
  { render :: RenderParent s s' f f' g p
  , eval :: EvalParent f s s' f f' g p
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a component that may contain child components and have lifcycle hooks.
parentComponentSpec
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => ParentComponentSpec s s' f f' g p
  -> Component (InstalledState s s' f f' g p) (ParentQuery f f' p) g
parentComponentSpec spec =
  Component
    { render: renderParent spec.render
    , eval: eval
    , initializer: left <$> spec.initializer
    , finalizers: parentFinalizers eval spec.finalizer
    }
  where
  eval :: Eval (ParentQuery f f' p) (InstalledState s s' f f' g p) (ParentQuery f f' p) g
  eval = coproduct (queryParent spec.eval) queryChild

-- | Builds a component that may contain child components and additionally
-- | supports the `peek` operation to allow the parent to observe queries that
-- | descendant components have processed.
parentComponent'
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => RenderParent s s' f f' g p
  -> EvalParent f s s' f f' g p
  -> Peek (ChildF p f') s s' f f' g p
  -> Component (InstalledState s s' f f' g p) (ParentQuery f f' p) g
parentComponent' r e p = parentComponentSpec' { render: r, eval: e, peek: p, initializer: Nothing, finalizer: Nothing }

-- | A full spec for a parent component, including lifecycle inputs and a
-- | `peek` operation.
type ParentComponentSpecP s s' f f' g p =
  { render :: RenderParent s s' f f' g p
  , eval :: EvalParent f s s' f f' g p
  , peek :: Peek (ChildF p f') s s' f f' g p
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a component that may contain child components, peek, and
-- | lifecycle hooks.
parentComponentSpec'
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => ParentComponentSpecP s s' f f' g p
  -> Component (InstalledState s s' f f' g p) (ParentQuery f f' p) g
parentComponentSpec' spec = Component
  { render: renderParent spec.render
  , eval: eval
  , initializer: left <$> spec.initializer
  , finalizers: parentFinalizers eval spec.finalizer
  }
  where
  eval :: Eval (ParentQuery f f' p) (InstalledState s s' f f' g p) (ParentQuery f f' p) g
  eval = coproduct (queryParent spec.eval) \q -> queryChild q <* queryParent spec.peek q

parentFinalizers
  :: forall s s' f f' g p
   . Eval (ParentQuery f f' p) (InstalledState s s' f f' g p) (ParentQuery f f' p) g
  -> Maybe (f Unit)
  -> InstalledState s s' f f' g p
  -> Array (Finalized g)
parentFinalizers eval fin (InstalledState s) =
  foldMap childFin s.children <> parentFin
  where
  parentFin :: Array (Finalized g)
  parentFin =
    case fin of
      Just i -> [ finalized eval (InstalledState s { children = M.empty, memo = M.empty }) (left i) ]
      _      -> []

  childFin :: Tuple (Component s' f' g) s' -> Array (Finalized g)
  childFin (Tuple (Component c) s) = c.finalizers s

-- | The type used by component containers for their state where `s` is the
-- | state local to the container, `p` is the type of slot used by the
-- | container, and the remaining parameters are the type variables for the
-- | child components.
newtype InstalledState s s' f f' g p = InstalledState
  { parent :: s
  , children :: M.Map p (Tuple (Component s' f' g) s')
  , memo :: M.Map p (Tree (ParentQuery f f' p) p)
  }

-- | Lifts a state value into an `InstalledState` value. Useful when providing
-- | an initial state value for a parent component.
installedState :: forall s s' f f' g p. (Ord p) => s -> InstalledState s s' f f' g p
installedState st = InstalledState { parent: st, children: M.empty, memo: M.empty }

-- | An intermediate algebra that parent components "produce" from their `eval`
-- | and `peek` functions. This takes the place of `g` when compared to a leaf
-- | (non-parent) component.
type QueryF s s' f f' g p = Free (HalogenF (InstalledState s s' f f' g p) (ChildF p f') g)

-- | An intermediate algebra used to associate values from a child component's
-- | algebra with the slot the component was installed into.
data ChildF p f i = ChildF p (f i)

-- | Extracts the query part from a ChildF value, discarding the slot value.
runChildF :: forall p f i. ChildF p f i -> f i
runChildF (ChildF _ q) = q

instance functorChildF :: (Functor f) => Functor (ChildF p f) where
  map f (ChildF p fi) = ChildF p (f <$> fi)

-- | Queries a child component, for use within a parent component's `eval` or
-- | `peek` function.
query
  :: forall s s' f f' g p i
   . (Functor g, Ord p)
  => p
  -> f' i
  -> Free (HalogenFP ParentEventSource s f (QueryF s s' f f' g p)) (Maybe i)
query p q = liftQuery (mkQuery p q)

-- | A version of [`query`](#query) for use when a parent component has multiple
-- | types of child component.
query'
  :: forall s s' s'' f f' f'' g p p' i
   . (Functor g, Ord p')
  => ChildPath s s' f f' p p'
  -> p
  -> f i
  -> Free (HalogenFP ParentEventSource s'' f'' (QueryF s'' s' f'' f' g p')) (Maybe i)
query' i p q = liftQuery (mkQuery' i p q)

-- | Queries every child component that is currently installed. For use within
-- | a parent component's `eval` or `peek` function.
queryAll
  :: forall s s' f f' g p i
   . (Functor g, Ord p)
  => f' i
  -> Free (HalogenFP ParentEventSource s f (QueryF s s' f f' g p)) (M.Map p i)
queryAll q = liftQuery (mkQueries q)

-- | Returns slots of all currently installed child components.
childSlots
  :: forall s s' f f' p g
  . (Functor g, Ord p)
  => QueryF s s' f f' g p (L.List p)
childSlots = do
  InstalledState st <- get
  pure (M.keys st.children)

-- | A version of [`queryAll](#queryAll) for use when a parent component has
-- | multiple types of child component.
queryAll'
  :: forall s s' s'' f f' f'' g p p' i
   . (Functor g, Ord p, Ord p')
  => ChildPath s s' f f' p p'
  -> f i
  -> Free (HalogenFP ParentEventSource s'' f'' (QueryF s'' s' f'' f' g p')) (M.Map p i)
queryAll' i q = liftQuery (mkQueries' i q)

-- | Creates a query for a child component where `p` is the slot the component
-- | was installed into and `f' i` in the input query.
-- |
-- | If a component is not found for the slot the result of the query
-- | will be `Nothing`.
mkQuery
  :: forall s s' f f' p g i
   . (Functor g, Ord p)
  => p
  -> f' i
  -> QueryF s s' f f' g p (Maybe i)
mkQuery p q = do
  InstalledState st <- get
  for (M.lookup p st.children) \(Tuple c _) ->
    mapF (transformHF (mapStateFChild p) (ChildF p) id) (queryComponent c q)

-- | A version of [`mkQuery`](#mkQuery) for use when a parent component has
-- | multiple types of child component.
mkQuery'
  :: forall s s' s'' f f' f'' g p p' i
   . (Functor g, Ord p')
  => ChildPath s s' f f' p p'
  -> p
  -> f i
  -> QueryF s'' s' f'' f' g p' (Maybe i)
mkQuery' i p q = mkQuery (injSlot i p) (injQuery i q)

-- | Creates a query for every child component that is currently installed.
mkQueries
  :: forall s s' f f' p g i
   . (Functor g, Ord p)
  => f' i
  -> QueryF s s' f f' g p (M.Map p i)
mkQueries = mkQueries' (ChildPath id id id)

-- | A version of [`mkQueries](#mkQueries) for use when a parent component has
-- | multiple types of child component.
mkQueries'
  :: forall s s' s'' f f' f'' g p p' i
   . (Functor g, Ord p', Ord p)
  => ChildPath s s' f f' p p'
  -> f i
  -> QueryF s'' s' f'' f' g p' (M.Map p i)
mkQueries' i q = do
  InstalledState st <- get
  M.fromList <<< L.catMaybes <$> traverse mkChildQuery (M.toList st.children)
  where
  mkChildQuery (Tuple p' (Tuple c _)) =
    for (prjSlot i p')
        \p -> Tuple p <$> mapF (transformHF (mapStateFChild p') (ChildF p') id)
                               (queryComponent c (injQuery i q))

-- | Lifts a value in the `QueryF` algebra into the monad used by a component's
-- | `eval` function.
liftQuery
  :: forall s s' f f' g p
   . (Functor g)
  => Natural (QueryF s s' f f' g p) (ParentDSL s s' f f' g p)
liftQuery = liftH

mapStateFParent :: forall s s' f f' g p. Natural (StateF s) (StateF (InstalledState s s' f f' g p))
mapStateFParent =
  mapState
    (\(InstalledState st) -> st.parent)
    (\f (InstalledState st) -> InstalledState
      { parent: f st.parent
      , children: st.children
      , memo: st.memo
      })

mapStateFChild :: forall s s' f f' g p. (Ord p) => p -> Natural (StateF s') (StateF (InstalledState s s' f f' g p))
mapStateFChild p =
  mapState
    (\(InstalledState st) -> U.fromJust $ snd <$> M.lookup p st.children)
    (\f (InstalledState st) -> InstalledState
      { parent: st.parent
      , children: M.update (Just <<< rmap f) p st.children
      , memo: st.memo
      })

renderParent
  :: forall s s' f f' g p
   . (Ord p)
  => RenderParent s s' f f' g p
  -> RenderM (InstalledState s s' f f' g p) (ParentQuery f f' p) g (Tree (ParentQuery f f' p) Unit)
renderParent render = do
    InstalledState st <- CMS.get
    let html = render st.parent
    -- Empty the state so that we don't keep children that are no longer
    -- being rendered...
    CMS.put $ InstalledState
      { parent: st.parent
      , children: M.empty
      , memo: M.empty
      } :: InstalledState s s' f f' g p
    -- ...but then pass through the old state so we can lookup child
    -- components that are being re-rendered
    html' <- fillSlot (renderChild (InstalledState st)) left html
    (InstalledState st') :: InstalledState s s' f f' g p <- CMS.get
    for_ (M.toList st.children) \(Tuple k (Tuple c s)) ->
      if not (M.member k st'.children)
        then
          let hooks :: Array (Hook (ParentQuery f f' p) g)
              hooks = Finalized <$> finalizeComponent c s
          in CMW.tell hooks
        else
          pure unit
    pure $ mkTree html'

  where

  renderChild
    :: InstalledState s s' f f' g p
    -> SlotConstructor s' f' g p
    -> RenderM (InstalledState s s' f f' g p) (ParentQuery f f' p) g (HTML (Tree (ParentQuery f f' p) p) (ParentQuery f f' p Unit))
  renderChild (InstalledState st) (SlotConstructor p def) =
    let childState = M.lookup p st.children
    in case M.lookup p st.memo of
      Just tree -> do
        CMS.modify \(InstalledState st') -> InstalledState
          { parent: st'.parent
          , children: M.alter (const childState) p st'.children
          , memo: M.insert p tree st'.memo
          } :: InstalledState s s' f f' g p
        pure $ Slot (thunkTree tree)
      Nothing -> case childState of
        Just (Tuple c s) -> renderChild' p c s
        Nothing -> do
          let def' = def unit
          case initializeComponent def'.component of
            Nothing -> pure unit
            Just init ->
              let hook :: Hook (Coproduct f (ChildF p f')) g
                  hook = PostRender (right (ChildF p init))
              in CMW.tell [ hook ]
          renderChild' p def'.component def'.initialState

  renderChild'
    :: p
    -> Component s' f' g
    -> s'
    -> RenderM (InstalledState s s' f f' g p) (ParentQuery f f' p) g (HTML (Tree (ParentQuery f f' p) p) (ParentQuery f f' p Unit))
  renderChild' p c s = do
    let r = renderComponent c s
        tree = graftTree adapt (const p) r.tree

        hooks :: Array (Hook (Coproduct f (ChildF p f')) g)
        hooks = lmapHook adapt <$> r.hooks

        adapt :: Natural f' (Coproduct f (ChildF p f'))
        adapt a = right (ChildF p a)

    CMW.tell hooks
    CMS.modify \(InstalledState st) -> InstalledState
      { parent: st.parent
      , children: M.insert p (Tuple c r.state) st.children
      , memo: M.insert p tree st.memo
      } :: InstalledState s s' f f' g p
    pure $ Slot tree

queryParent
  :: forall s s' f f' g p a q r. (Functor g)
  => (q a -> ParentDSL s s' f f' g p r)
  -> q a
  -> ComponentDSL (InstalledState s s' f f' g p) (ParentQuery f f' p) g r
queryParent f =
  f >>> foldFree \h ->
    case h of
      StateHF q -> mergeParentStateF q
      SubscribeHF es next ->
        liftF $ SubscribeHF (EventSource (FT.interpret (lmap left) (runEventSource (fromParentEventSource es)))) next
      QueryHF q -> liftChildF q
      HaltHF -> liftF HaltHF

mergeParentStateF :: forall s s' f f' g p. Natural (StateF s) (ComponentDSL (InstalledState s s' f f' g p) (ParentQuery f f' p) g)
mergeParentStateF = liftF <<< StateHF <<< mapStateFParent

liftChildF
  :: forall s s' f f' g p
   . (Functor g)
  => Natural (Free (HalogenF (InstalledState s s' f f' g p) (ChildF p f') g)) (ComponentDSL (InstalledState s s' f f' g p) (ParentQuery f f' p) g)
liftChildF = mapF (transformHF id right id)

queryChild
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => Natural (ChildF p f') (ComponentDSL (InstalledState s s' f f' g p) (ParentQuery f f' p) g)
queryChild (ChildF p q) = do
  modify \(InstalledState st) -> InstalledState
    { parent: st.parent
    , children: st.children
    , memo: M.delete p st.memo
    }
  mapF (transformHF id right id) (mkQuery p q)
    >>= maybe (liftF HaltHF) pure

-- | Transforms a `Component`'s types using partial mapping functions.
-- |
-- | If the initial state provided to the component fails the transformation an
-- | empty component will be rendered. If either of the transformations fail the
-- | component will "halt" (evaluate to `empty`), so care must be taken when
-- | handling transformed components to ensure they receive the intended query
-- | values and initial state type.
-- |
-- | Halogen itself will never cause a `transform`ed component to halt; this
-- | situation will only arise when the initial state is incorrect or a bad
-- | externally constructed query is passed to the component.
transform
  :: forall s s' f f' g
   . (Functor g)
  => (s -> s')
  -> (s' -> Maybe s)
  -> (forall a. f a -> f' a)
  -> (forall a. f' a -> Maybe (f a))
  -> Component s f g
  -> Component s' f' g
transform reviewS previewS reviewQ previewQ (Component c) =
  Component
    { render: maybe (pure emptyTree) render' <<< previewS =<< CMS.get
    , eval: maybe (liftF HaltHF) (foldFree go <<< c.eval) <<< previewQ
    , initializer: reviewQ <$> c.initializer
    , finalizers: maybe [] c.finalizers <<< previewS
    }
  where

  render' :: s -> RenderM s' f' g (Tree f' Unit)
  render' st =
    CMW.WriterT $ CMS.StateT \_ ->
      case runState (runWriterT c.render) st of
        Tuple (Tuple tree hooks) st' ->
          pure $ Tuple (Tuple (graftTree reviewQ id tree) (lmapHook reviewQ <$> hooks)) (reviewS st')

  go :: Natural (HalogenF s f g) (Free (HalogenF s' f' g))
  go (StateHF (Get k)) =
    liftF <<< maybe HaltHF (\st' -> StateHF (Get (k <<< const st'))) <<< previewS =<< get
  go (StateHF (Modify f next)) = liftF $ StateHF (Modify (modifyState f) next)
  go (SubscribeHF es next) = liftF $ SubscribeHF (EventSource (FT.interpret (lmap reviewQ) (runEventSource es))) next
  go (QueryHF q) = liftF $ QueryHF q
  go HaltHF = liftF HaltHF

  modifyState :: (s -> s) -> s' -> s'
  modifyState f s' = maybe s' (reviewS <<< f) (previewS s')

-- | Transforms a `Component`'s types using a `ChildPath` definition.
transformChild
  :: forall s s' f f' g p p'
   . (Functor g)
  => ChildPath s s' f f' p p'
  -> Component s f g
  -> Component s' f' g
transformChild i = transform (injState i) (prjState i) (injQuery i) (prjQuery i)

-- | Changes the component's `g` type. A use case for this would be to interpret
-- | some `Free` monad as `Aff` so the component can be used with `runUI`.
interpret
  :: forall s f g g'
   . (Functor g')
  => Natural g g'
  -> Component s f g
  -> Component s f g'
interpret nat (Component c) =
  Component
    { render: render'
    , eval: mapF (hoistHalogenF nat) <<< c.eval
    , initializer: c.initializer
    , finalizers: map (mapFinalized nat) <$> c.finalizers
    }
  where
  render' :: RenderM s f g' (Tree f Unit)
  render' =
    CMW.WriterT $ CMS.StateT \s ->
      case runState (runWriterT c.render) s of
        Tuple (Tuple tree hooks) s' ->
          pure $ Tuple (Tuple tree (rmapHook nat <$> hooks)) s'

-- | Runs a component's `render` function with the specified state, returning
-- | the generated `HTML` and new state.
renderComponent
  :: forall s f g
   . Component s f g
  -> s
  -> { tree  ::  Tree f Unit
     , hooks :: Array (Hook f g)
     , state :: s
     }
renderComponent (Component c) s =
  case runState (runWriterT c.render) s of
    Tuple (Tuple tree hooks) state -> { tree: tree, hooks: hooks, state: state }

-- | Runs a compnent's `query` function with the specified query input and
-- | returns the pending computation as a `Free` monad.
queryComponent :: forall s f g. Component s f g -> Eval f s f g
queryComponent (Component c) = c.eval

initializeComponent :: forall s f g. Component s f g -> Maybe (f Unit)
initializeComponent (Component c) = c.initializer

finalizeComponent :: forall s f g. Component s f g -> s -> Array (Finalized g)
finalizeComponent (Component c) = c.finalizers


remove duplication

remove duplication

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in Data.String.
module Data.String.CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Prelude

import Data.Array as Array
import Data.Char as Char
import Data.List (List(Cons, Nil), fromFoldable)
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.String.Unsafe as Unsafe
-- WARN: This list must be updated to re-export any exports added to Data.String. That makes me sad.
import Data.String (Pattern(..), Replacement(..), charAt, charCodeAt, contains, fromCharArray, joinWith, localeCompare, null, replace, replaceAll, split, stripPrefix, stripSuffix, toChar, toCharArray, toLower, toUpper, trim) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

-- I would prefer that this smart constructor not need to exist and instead
-- CodePoint just implements Enum, but the Enum module already depends on this
-- one. To avoid the circular dependency, we just expose these two functions.
codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

codePointFromSurrogatePair :: Int -> Int -> Maybe CodePoint
codePointFromSurrogatePair lead trail | isLead lead && isTrail trail =
  Just (unsurrogate lead trail)
codePointFromSurrogatePair _ _ = Nothing

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = String.singleton <<< Char.fromCharCode

unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s | String.length s == 1 = CodePoint (Unsafe.charCodeAt 0 s)
unsafeCodePointAt0Fallback s = CodePoint (unsurrogate lead trail)
  where
    lead = Unsafe.charCodeAt 0 s
    trail = Unsafe.charCodeAt 1 s

codePointAt :: Int -> String -> Maybe CodePoint
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = Array.index (toCodePointArray s) n

count :: (CodePoint -> Boolean) -> String -> Int
count = _count isLead isTrail unsurrogate

foreign import _count
  :: (Int -> Boolean)
  -> (Int -> Boolean)
  -> (Int -> Int -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

drop :: Int -> String -> String
drop n s = fromCodePointArray (Array.drop n (toCodePointArray s))

dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.indexOf p s'

lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.lastIndexOf p s'

length :: String -> Int
length = Array.length <<< toCodePointArray

singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) = fromCharCode lead <> fromCharCode trail
  where
    lead = ((cp - 0x10000) / 0x400) + 0xD800
    trail = (cp - 0x10000) `mod` 0x400 + 0xDC00

splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps < i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n s = fromCodePointArray (Array.take n (toCodePointArray s))

takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode (fromFoldable (Char.toCharCode <$> String.toCharArray s))
  where
  decode :: List Int -> Maybe (Tuple CodePoint (List Int))
  decode (Cons h (Cons l rest)) | isLead h && isTrail l
    = Just (Tuple (unsurrogate h l) rest)
  decode (Cons c rest) = Just (Tuple (CodePoint c) rest)
  decode Nil = Nothing

uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s  = { head: _, tail: drop 1 s } <$> codePointAt 0 s

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in Data.String.
module Data.String.CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Prelude

import Data.Array as Array
import Data.Char as Char
import Data.List (List(Cons, Nil), fromFoldable)
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.String.Unsafe as Unsafe
-- WARN: This list must be updated to re-export any exports added to Data.String. That makes me sad.
import Data.String (Pattern(..), Replacement(..), charAt, charCodeAt, contains, fromCharArray, joinWith, localeCompare, null, replace, replaceAll, split, stripPrefix, stripSuffix, toChar, toCharArray, toLower, toUpper, trim) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

-- I would prefer that this smart constructor not need to exist and instead
-- CodePoint just implements Enum, but the Enum module already depends on this
-- one. To avoid the circular dependency, we just expose these two functions.
codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

codePointFromSurrogatePair :: Int -> Int -> Maybe CodePoint
codePointFromSurrogatePair lead trail | isLead lead && isTrail trail =
  Just (unsurrogate lead trail)
codePointFromSurrogatePair _ _ = Nothing

unsurrogate :: Int -> Int -> CodePoint
unsurrogate h l = CodePoint ((h - 0xD800) * 0x400 + (l - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = String.singleton <<< Char.fromCharCode

unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s | String.length s == 1 = CodePoint (Unsafe.charCodeAt 0 s)
unsafeCodePointAt0Fallback s = CodePoint (((lead - 0xD800) * 0x400) + (trail - 0xDC00) + 0x10000)
  where
    lead = Unsafe.charCodeAt 0 s
    trail = Unsafe.charCodeAt 1 s

codePointAt :: Int -> String -> Maybe CodePoint
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = Array.index (toCodePointArray s) n

count :: (CodePoint -> Boolean) -> String -> Int
count = _count isLead isTrail unsurrogate

foreign import _count
  :: (Int -> Boolean)
  -> (Int -> Boolean)
  -> (Int -> Int -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

drop :: Int -> String -> String
drop n s = fromCodePointArray (Array.drop n (toCodePointArray s))

dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.indexOf p s'

lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.lastIndexOf p s'

length :: String -> Int
length = Array.length <<< toCodePointArray

singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) = fromCharCode lead <> fromCharCode trail
  where
    lead = ((cp - 0x10000) / 0x400) + 0xD800
    trail = (cp - 0x10000) `mod` 0x400 + 0xDC00

splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps < i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n s = fromCodePointArray (Array.take n (toCodePointArray s))

takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode (fromFoldable (Char.toCharCode <$> String.toCharArray s))
  where
  decode :: List Int -> Maybe (Tuple CodePoint (List Int))
  decode (Cons h (Cons l rest)) | isLead h && isTrail l
    = Just (Tuple (unsurrogate h l) rest)
  decode (Cons c rest) = Just (Tuple (CodePoint c) rest)
  decode Nil = Nothing

uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s  = { head: _, tail: drop 1 s } <$> codePointAt 0 s


Simplify -- Renderers always run on Arrays. Improved coloring

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((!!), (..))
import Data.Array as Array
import Data.Foldable (foldMap, for_, length)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(..), fromJust, fromMaybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap, wrap)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)

type Track aff eff a = { source :: DataSource aff a
                       , render :: Array a -> Eff eff Unit
                       , getPoint :: Point -> Array a
                       , chrSize :: Chr -> Bp
                       }

-- given a size on the chromosome,
-- the position of the chromosome,
-- return a function from scale to ncanvas X-coordinate
-- TODO this should be more closely connected to Frames
type XPosInfo = { size :: Bp, scale :: BpPerPixel }

posPixelsX :: XPosInfo
           -> Bp
           -> Pixels
posPixelsX { scale } pos = bpToPixels scale pos

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
type YPosInfo = { offset :: Pixels, height :: Pixels }

posPixelsY :: YPosInfo
           -> Number
           -> Pixels
posPixelsY { offset, height } rel = height - (rel * height + offset)

type Renderer eff a =
  { hPos :: a -> XPosInfo -> Pixels
  , vPos :: a -> YPosInfo -> Pixels
  , render :: a -> Context2D -> Eff eff Unit
  , hit :: Maybe (a -> { x :: Pixels, y :: Pixels } -> a)
  }

gwasRenderer :: forall a.
                {min :: Number, max :: Number}
             -> (a -> String)
             -> Renderer _ {score :: Number, pos :: Bp, chr :: a}
gwasRenderer {min, max} color = { hPos, vPos, render, hit: Nothing }
  where hPos a xInfo = posPixelsX xInfo a.pos
        nScore s = (s - min) / (max - min)
        vPos a yInfo = posPixelsY yInfo (nScore a.score)
        render a ctx = renderGlyph ctx $ do
          stroke (color a.chr)
          fill (color a.chr)
          circle { x: 0.0, y: 0.0 } 5.0

-- Renderers always run on collections (for now Arrays) of objects,
-- since it's rare to only want to render one single thing.
-- if that is desired, one can simply pass along a singleton array.
runRenderer :: forall a.
               Renderer _ a
            -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
            -> Array a
            -> Context2D
            -> Eff _ Unit
runRenderer r {xInfo, yInfo} as ctx =
  for_ as (\a -> C.withContext ctx do
              let translateX = r.hPos a xInfo
                  translateY = r.vPos a yInfo
              _ <- C.translate {translateX, translateY} ctx
              r.render a ctx)

-- TODO the `offset` should probably be in XPosInfo,
-- and be the actual pixel offset for that bit on the canvas...
type Frames a = { offset :: Pixels
                , frames :: Array { xInfo :: XPosInfo
                                  , contents :: a
                                  } }

frames :: forall a.
          Pixels
       -> Pixels
       -> (a -> Bp)
       -> Array a
       -> Frames a
frames width offset f chrs = {offset, frames: g <$> chrs}
  where n = length chrs
        -- TODO the scale should depend on the current size; that needs more work
        totalSize = alaF Additive foldMap f chrs
        width' = width - offset * n
        g chr = let size = f chr
                    scale = BpPerPixel (unwrap totalSize / width')
                in {xInfo: {size, scale}, contents: chr}

mapFrames :: forall a b.
             (a -> b)
          -> Frames a
          -> Frames b
mapFrames f fs = fs { frames = (\a -> a { contents = f a.contents }) <$> fs.frames }

-- zipWithFrames :: forall a b.
--              Array (a -> b)
--           -> Frames a
--           -> Frames b
-- zipWithFrames funs fs = fs { frames = frames }
--   where frames = Array.zipWith (\fun frame -> fun <$> frame) funs fs.frames

renderFrames :: forall f a.
                YPosInfo
             -> Frames (Array a)
             -> Renderer _ a
             -> Context2D
             -> Eff _ Unit
renderFrames yInfo {offset, frames} r ctx = C.withContext ctx (foreachE frames f)
  where f {xInfo, contents} = do
            runRenderer r {xInfo, yInfo} contents ctx
            log $ "scale: " <> show (unwrap xInfo.scale)
            let len = bpToPixels xInfo.scale xInfo.size
            void $ C.translate {translateX: len+offset, translateY: 0.0} ctx

-- Commands the renderer thread can receive
data RenderCmds a =
    Render (Array { chrId :: ChrId, features :: Array a})
  | SetView View
  | Scroll Pixels

type RenderBackend = { canvas :: CanvasElement
                     , backCanvas :: CanvasElement
                     }
{-
renderer :: forall eff a.
            RenderBackend
         -> Renderer eff a
         -> AVar (RenderCmds a)
         -> StateT View (Aff _) Unit
renderer cvs r cmdVar = forever do
  cmd <- lift $ takeVar cmdVar
  case cmd of
    Render fs -> do
      -- let toRender :: Array (RenderParams -> Eff _ Unit)
      --     toRender = map r fs
      -- Use current (or provided?) View to derive RenderParams for each
      pure unit

    Scroll n -> do
      pure unit

    SetView v -> do
      State.put v
      pure unit
-}

testFetch :: forall r.
             String
          -> Aff _ (Array { score :: Number, pos :: Bp, chr :: Int })
testFetch url = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe {score :: Number, pos :: Bp, chr :: Int }
      f j = do
            obj <- j ^? _Object
            pos <- Bp <$> obj ^? ix "min" <<< _Number
            pValue <- readFloat <$> obj ^? ix "pValue" <<< _String
            let score = (-1.0) * (Math.log pValue / Math.log 10.0)
                chr = 11
            pure {pos, score, chr}

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

testRender :: forall r a.
              Renderer _ { chr :: Int | r }
           -> Array { chr :: a | r }
           -> Aff _ Unit
testRender r as = do
  liftEff $ log "running"
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let size = Bp 122030190.0
      n = 10
      scale = BpPerPixel (unwrap size / (w / 10.0))
      xInfo = { size, scale }
      height = h
      offset = 0.0
      yInfo = { height, offset }

      as' :: _
      as' = Array.zipWith (\i as' -> _ {chr = i} <$> as') (1..5) (Array.replicate 5 as)

      fs :: Frames _
      fs = frames w 20.0 (const size) as'

  liftEff $ renderFrames yInfo fs r ctx

main = launchAff $ do
  dat <- testFetch "./gwas.json"
  let min = 0.0
      max = 50.0

      colors = ["green", "yellow", "orange", "red", "purple", "blue"]

      chrColor :: Int -> String
      chrColor i = fromMaybe "black" (colors !! i `mod` 5)

      render' :: _
      render' = gwasRenderer {min, max} chrColor

  testRender render' dat

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((!!), (..))
import Data.Array as Array
import Data.Foldable (foldMap, for_, length)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(..), fromJust, fromMaybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap, wrap)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)

type Track aff eff a = { source :: DataSource aff a
                       , render :: Array a -> Eff eff Unit
                       , getPoint :: Point -> Array a
                       , chrSize :: Chr -> Bp
                       }

{-

Have a way to "prepare" data per-chromosome for rendering.

Then have a way to actually render that prepared data,
given some extra information such as offset, height scaling, etc.

Also need to map clicks backward, but that should be doable.

Maybe render to an offscreen canvas and copyImage.
Not sure that makes sense either
-}

-- given a size on the chromosome,
-- the position of the chromosome,
-- return a function from scale to ncanvas X-coordinate
type XPosInfo = { size :: Bp, scale :: BpPerPixel }

posPixelsX :: XPosInfo
           -> Bp
           -> Pixels
posPixelsX { scale } pos = bpToPixels scale pos

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
type YPosInfo = { offset :: Pixels, height :: Pixels }

posPixelsY :: YPosInfo
           -> Number
           -> Pixels
posPixelsY { offset, height } rel = height - (rel * height + offset)

type Renderer eff a =
  { hPos :: a -> XPosInfo -> Pixels
  , vPos :: a -> YPosInfo -> Pixels
  , render :: a -> Context2D -> Eff eff Unit
  , hit :: Maybe (a -> { x :: Pixels, y :: Pixels } -> a)
  }

gwasRenderer :: forall a.
                {min :: Number, max :: Number}
             -> (a -> String)
             -> Renderer _ {score :: Number, pos :: Bp, chr :: a}
gwasRenderer {min, max} color = { hPos, vPos, render, hit: Nothing }
  where hPos a xInfo = posPixelsX xInfo a.pos
        nScore s = (s - min) / (max - min)
        vPos a yInfo = posPixelsY yInfo (nScore a.score)
        render a ctx = renderGlyph ctx $ do
          stroke (color a.chr)
          fill (color a.chr)
          circle { x: 0.0, y: 0.0 } 5.0

runRenderer :: forall a.
               a
            -> Renderer _ a
            -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
            -> Context2D
            -> Eff _ Unit
runRenderer a { hPos, vPos, render, hit } { xInfo, yInfo } ctx = C.withContext ctx do
  let translateX = hPos a xInfo
      translateY = vPos a yInfo
  _ <- C.translate {translateX, translateY} ctx
  render a ctx

runRendererN :: forall a.
                Renderer _ a
             -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
             -> Array a
             -> Context2D
             -> Eff _ Unit
runRendererN r p as ctx =
  for_ as (\a -> runRenderer a r p ctx)

-- TODO the `offset` should probably be in XPosInfo,
-- and be the actual pixel offset for that bit on the canvas...
-- type Frames a = { offset :: Pixels, frames :: Array (Tuple {xInfo :: XPosInfo} a) }

type Frames f a = { offset :: Pixels
                  , frames :: Array { xInfo :: XPosInfo
                                    , context :: f
                                    , contents :: a
                                    } }

frames :: forall f a.
          Pixels
       -> Pixels
       -> (a -> Bp)
       -> Array (Tuple f a)
       -> Frames f a
frames width offset f chrs = { offset
                             , frames: g <$> chrs}
  where n = length chrs
        -- TODO the scale should depend on the current size; that needs more work
        totalSize = alaF Additive foldMap (f <<< snd) chrs
        width' = width - offset * n
        g (Tuple b a) = let size = f a
                            xInfo = { size, scale: BpPerPixel (unwrap totalSize / width' ) }
                            context = b
                            contents = a
                        in { xInfo, context, contents }

-- mapFrames :: forall a b.
--              (a -> b)
--           -> Frames a
--           -> Frames b
-- mapFrames f fs = fs { frames = map f <$> fs.frames }

-- zipWithFrames :: forall a b.
--              Array (a -> b)
--           -> Frames a
--           -> Frames b
-- zipWithFrames funs fs = fs { frames = frames }
--   where frames = Array.zipWith (\fun frame -> fun <$> frame) funs fs.frames

renderFrames :: forall f a.
                YPosInfo
             -> Frames f a
             -> Renderer _ a
             -> (f -> Context2D -> Eff _ Unit)
             -> Context2D
             -> Eff _ Unit
renderFrames yInfo {offset, frames} r pre ctx = C.withContext ctx (foreachE frames f)
  where f {xInfo, context, contents} = do
            void $ C.translate {translateX: offset, translateY: 0.0} ctx
            r.render contents ctx
            let len = bpToPixels xInfo.scale xInfo.size
            void $ C.translate {translateX: len, translateY: 0.0} ctx

renderFramesN :: forall f a.
                 YPosInfo
              -> Frames f (Array a)
              -> Renderer _ a
              -> (f -> Context2D -> Eff _ Unit)
              -> Context2D
              -> Eff _ Unit
renderFramesN yInfo {offset, frames} r pre ctx = C.withContext ctx (foreachE frames f)
  where f {xInfo, context, contents} = do
            pre context ctx
            runRendererN r {xInfo, yInfo} contents ctx
            log $ "scale: " <> show (unwrap xInfo.scale)
            let len = bpToPixels xInfo.scale xInfo.size
            void $ C.translate {translateX: len+offset, translateY: 0.0} ctx

{- note:
  check purescript-drawings out.

wait, aren't these basically the same

(         a -> (Translation, Eff _ Unit))
(Identity a -> (Translation, Eff _ Unit))

(       f a ->  g           (Eff _ Unit))
(       f a ->  Identity    (Eff _ Unit))
-}

-- Commands the renderer thread can receive
data RenderCmds a =
    Render (Array { chrId :: ChrId, features :: Array a})
  | SetView View
  | Scroll Pixels

type RenderBackend = { canvas :: CanvasElement
                     , backCanvas :: CanvasElement
                     }
{-
renderer :: forall eff a.
            RenderBackend
         -> Renderer eff a
         -> AVar (RenderCmds a)
         -> StateT View (Aff _) Unit
renderer cvs r cmdVar = forever do
  cmd <- lift $ takeVar cmdVar
  case cmd of
    Render fs -> do
      -- let toRender :: Array (RenderParams -> Eff _ Unit)
      --     toRender = map r fs
      -- Use current (or provided?) View to derive RenderParams for each
      pure unit

    Scroll n -> do
      pure unit

    SetView v -> do
      State.put v
      pure unit
-}

testFetch :: forall r.
             String
          -> Aff _ (Array { score :: Number, pos :: Bp, chr :: Int })
testFetch url = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe {score :: Number, pos :: Bp, chr :: Int }
      f j = do
            obj <- j ^? _Object
            pos <- Bp <$> obj ^? ix "min" <<< _Number
            pValue <- readFloat <$> obj ^? ix "pValue" <<< _String
            let score = (-1.0) * (Math.log pValue / Math.log 10.0)
                chr = 11
            pure {pos, score, chr}

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

testRender :: forall a.
              Renderer _ a
           -> Array a
           -> Aff _ Unit
testRender r as = do
  liftEff $ log "running"
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let size = Bp 122030190.0
      n = 10
      scale = BpPerPixel (unwrap size / (w / 10.0))
      xInfo = { size, scale }
      height = h
      offset = 0.0
      yInfo = { height, offset }
      colors = ["yellow", "orange", "red", "purple", "blue"]

      fs :: Frames _ (Array _)
      fs = frames w 20.0 (const size) $ Array.zip (1..5) (Array.replicate 5 as)

      pre :: Int -> Context2D -> Eff _ Unit
      pre i ctx = do
        let color = fromMaybe "black" (colors !! i `mod` 5)
        void $ C.setStrokeStyle color ctx
        void $ C.setFillStyle color ctx

  liftEff $ renderFramesN yInfo fs r pre ctx

main = launchAff $ do
  dat <- testFetch "./gwas.json"
  let min = 0.0
      max = 50.0
  testRender (gwasRenderer {min, max}) dat

{-
trackEvents :: _
trackEvents = viewB
  where cDrag = canvasDrag canvas
        lefts = case _ of
          Left x -> Just x
          Right _ -> Nothing
        -- the alt operator <|> combines the two event streams,
        -- resulting in an event of both button-click scrolls
        -- and canvas-drag scrolls

        dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
        updateViews = btnScroll (Bp 500.0)
                  <|> dragScroll
                  <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                              (wrap <<< (_ * 1.2) <<< unwrap)
                  <|> scrollZoom canvas
        viewB = FRP.fold foldView updateViews v
-}

-- a `Track` is the more or less abstract representation of the track;
-- it needs to be run to do anything.

-- TODO it also needs to be able to receive messages and send messages

-- runTrack :: forall a r.
--             View
--          -> Track _ _ a
--          -> Aff _ Unit
-- runTrack opts { source, render, getPoint, chrSize } = do
  -- ctx <- liftEff $ getContext2D opts.canvas

  -- {w,h} <- liftEff do
  --   {w} <- getScreenSize
  --   h <- getCanvasHeight opts.canvas
  --   _ <- setCanvasWidth (w-2.0) opts.canvas
  --   pure {w, h}

  -- trackState <- makeVar

  -- -- TODO handle resize
  -- let v = View.fromCanvasWidth chrSize opts

  -- feats <- fetch
  -- pure unit

{-

browser :: Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}
  browserState <- makeVar

  let minView = Bp 0.0
      maxView = Bp 15000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri

  fs <- f v

  let renderer :: View -> Array _ -> _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: View -> Aff _ _
      fetch v = do

        let gs = glyphifyFeatures fs v
            annGs = zip fs gs
        let gs' = filterFeatures v annGs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer v gs'

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    _ <- launchAff $ fetch v'

  fetch v
  -}