smarter browser view update & cleaner interface

module Genetics.Browser.UI where

import Prelude

import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Filterable (filterMap)
import Data.Foldable (foldMap, length)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Int as Int
import Data.Lens ((^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Newtype (over, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Symbol (SProxy(SProxy))
import Data.Traversable (for_, traverse_)
import Data.Tuple (Tuple(Tuple))
import Data.Variant (Variant, case_, inj)
import Data.Variant as V
import Effect (Effect)
import Effect.Aff (Aff, Fiber, Milliseconds(..), delay, forkAff, killFiber, launchAff, launchAff_)
import Effect.Aff.AVar (AVar)
import Effect.Aff.AVar as AVar
import Effect.Class (liftEffect)
import Effect.Console (log)
import Effect.Exception (error, throw)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Foreign (Foreign, MultipleErrors, renderForeignError)
import Genetics.Browser (LegendConfig, Peak, VScale, pixelSegments)
import Genetics.Browser.Canvas (BrowserContainer, _Container, browserClickHandler, browserContainer, dragScroll, getDimensions, setBrowserContainerSize, setElementStyle, wheelZoom)
import Genetics.Browser.Coordinates (CoordSys, CoordSysView(..), _Segments, _TotalSize, coordSys, normalizeView, pairsOverlap, scalePairBy, scaleToScreen, translatePairBy, viewScale)
import Genetics.Browser.Demo (Annotation, AnnotationField, SNP, SNPConfig, AnnotationsConfig, addDemoLayers, annotationsForScale, filterSig, getAnnotations, getGenes, getSNPs, showAnnotationField)
import Genetics.Browser.Layer (Component(Padded), BrowserPadding, browserSlots)
import Genetics.Browser.Types (ChrId(ChrId), _NegLog10, _prec)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Point)
import Math as Math
import Partial.Unsafe (unsafePartial)
import Simple.JSON (read)
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM (Element)
import Web.DOM.Document (createElement, documentElement) as DOM
import Web.DOM.Document (toParentNode)
import Web.DOM.Element (setId)
import Web.DOM.Element as Element
import Web.DOM.Node (appendChild)
import Web.DOM.ParentNode (querySelector) as DOM
import Web.HTML (window) as DOM
import Web.HTML.HTMLDocument (toDocument) as DOM
import Web.HTML.Window (document) as DOM
import Web.UIEvent.KeyboardEvent (KeyboardEvent)
import Web.UIEvent.KeyboardEvent (key) as DOM

foreign import windowInnerSize :: Effect Canvas.Dimensions

-- | Set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Effect Unit
                           -> Effect Unit

foreign import keydownEvent :: Element
                            -> (KeyboardEvent -> Effect Unit)
                            -> Effect Unit

-- | Set callback to run after the window has resized (see UI.js for
-- | time waited), providing it with the new window size.
foreign import resizeEvent :: ({ width  :: Number
                               , height :: Number } -> Effect Unit)
                           -> Effect Unit

-- | The value returned by the function that initializes the genome browser;
-- | provides an interface to the running browser instance.
type BrowserInterface a
  = { getView          :: Effect CoordSysView
    , container        :: BrowserContainer
    , lastHotspots     :: Effect (Number -> Point -> Array a)
    , queueCommand     :: Variant UICmdR -> Aff Unit
    , queueUpdateView  :: UpdateView -> Effect Unit
    }

-- | Creates the browser using the provided initial data, returning
-- | a BrowserInterface for reading state & sending commands to it
initializeBrowser :: ∀ c r.
                     CoordSys c BigInt
                  -> { snps        :: Pair Number -> CoordSysView -> Effect Unit
                     , annotations :: Pair Number -> CoordSysView -> Effect Unit
                     , chrs        :: Pair Number -> CoordSysView -> Effect Unit
                     , hotspots    :: Effect (Number -> Point -> Array (SNP ()))
                     , fixedUI     :: Effect Unit | r}
                  -> CoordSysView
                  -> BrowserContainer
                  -> Aff (BrowserInterface (SNP ()))
initializeBrowser cSys renderFuns initView bc = do

  renderFiberVar <- AVar.empty

  browserView <- liftEffect $ Ref.new initView
  bcVar <- AVar.new bc

  uiCmdVar <- AVar.empty
  lastHotspotsVar <- AVar.empty

  let getView = Ref.read browserView
      queueCommand = flip AVar.put uiCmdVar
      lastHotspots = renderFuns.hotspots

    -- hardcoded timeout for now
  queueUpdateView <- liftEffect $ uiViewUpdate cSys (wrap 30.0) {view: browserView, uiCmd: uiCmdVar}

  let mainLoop = do
        uiCmd <- AVar.take uiCmdVar
        case_ # V.on _render (\_ -> pure unit)
              # V.on _docResize (\ {width} -> do
                      {height} <- _.size <$> getDimensions bc
                      setBrowserContainerSize {width, height} bc
                      queueCommand $ inj _render unit
                      mainLoop)
              $ uiCmd

        -- if there's a rendering fiber running, we kill it
        traverse_ (killFiber (error "Resetting renderer"))
          =<< AVar.tryTake renderFiberVar

        csView <- liftEffect $ getView

        currentDims <- getDimensions bc

        let trackDims = _.padded $ browserSlots currentDims
            currentScale = viewScale trackDims.size csView
            pxView = scaleToScreen currentScale <$> (unwrap csView)

        -- fork a new renderFiber
        renderFiber <- forkAff $ liftEffect do

          renderFuns.chrs        pxView csView
          renderFuns.annotations pxView csView
          renderFuns.snps        pxView csView
          renderFuns.fixedUI

        AVar.put renderFiber renderFiberVar

        mainLoop

  _ <- forkAff mainLoop

  queueCommand $ inj _render unit

  pure { getView
       , container: bc
       , lastHotspots
       , queueCommand
       , queueUpdateView }

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (Pair BigInt -> Pair BigInt)

instance showUpdateView :: Show UpdateView where
  show (ScrollView x) = "(Scroll by " <> show x <> ")"
  show (ZoomView s) = "(Zoom by " <> show s <> ")"
  show _ = "(ModView)"

    -- TODO idk if this instance makes sense??? whatevs
instance semigroupUpdateView :: Semigroup UpdateView where
  append (ScrollView x1) (ScrollView x2) = ScrollView (x1 + x2)
  append (ZoomView s1)   (ZoomView s2)   = ZoomView   (s1 * s2)
  append _ y = y

instance monoidUpdateView :: Monoid UpdateView where
  mempty = ModView identity

updateViewFold :: UpdateView
               -> CoordSysView
               -> CoordSysView
updateViewFold uv = over CoordSysView case uv of
  ZoomView   x -> (_ `scalePairBy`     x)
  ScrollView x -> (_ `translatePairBy` x)
  ModView f    -> f

queueCmd :: ∀ a. AVar a -> a -> Effect Unit
queueCmd av cmd = launchAff_ $ AVar.put cmd av

foreign import onTimeout
  :: Milliseconds
  -> Effect Unit
  -> Effect { run    :: Effect Unit
            , cancel :: Effect Unit }

animateDelta :: ∀ a a'.
                Monoid a'
             => (a' -> a -> a)
             -> (a -> Effect Unit)
             -> { current  :: Ref a
                , velocity :: Ref a'
                }
             -> Milliseconds
             -> Effect (a' -> Effect Unit)
animateDelta update done refs timeout = do

  comms <- onTimeout timeout do
    vD <- Ref.read refs.velocity
    Ref.write mempty refs.velocity
    launchAff_ $ liftEffect do
      Ref.modify (update vD) refs.current >>= done

  pure \cmd -> do
    Ref.modify_ (_ <> cmd) refs.velocity
    comms.run

uiViewUpdate :: ∀ c r.
                CoordSys c BigInt
             -> Milliseconds
             -> { view  :: Ref CoordSysView
                , uiCmd :: AVar (Variant UICmdR) | r }
             -> Effect (UpdateView -> Effect Unit)
uiViewUpdate cs timeout {view, uiCmd} = do
  let update vD = normalizeView cs (BigInt.fromInt 200000)
                 <<< updateViewFold vD
      done _ = launchAff_ $ AVar.put (inj _render unit) uiCmd

  velocity <- Ref.new mempty
  animateDelta update done { current: view, velocity } timeout

btnUI :: { scrollMod :: Number, zoomMod :: Number }
      -> (UpdateView -> Effect Unit)
      -> Effect Unit
btnUI mods cb = do
  buttonEvent "scrollLeft"  $ cb $ ScrollView     (-mods.scrollMod)
  buttonEvent "scrollRight" $ cb $ ScrollView       mods.scrollMod
  buttonEvent "zoomOut"     $ cb $ ZoomView $ 1.0 + mods.zoomMod
  buttonEvent "zoomIn"      $ cb $ ZoomView $ 1.0 - mods.zoomMod

keyUI :: ∀ r.
         Element
      -> { scrollMod :: Number | r }
      -> (UpdateView -> Effect Unit)
      -> Effect Unit
keyUI el mods cb = keydownEvent el f
  where f ke = case DOM.key ke of
          "ArrowLeft"  -> cb $ ScrollView (-mods.scrollMod)
          "ArrowRight" -> cb $ ScrollView   mods.scrollMod
          _ -> pure unit

type UICmdR = ( render :: Unit
              , docResize :: { width :: Number, height :: Number } )

_render = SProxy :: SProxy "render"
_docResize = SProxy :: SProxy "docResize"

debugView :: ∀ a.
             BrowserInterface a
          -> Effect { get :: String -> Effect Unit
                    , set :: { l :: Number, r :: Number } -> Effect Unit }
debugView s = unsafePartial do
  let get name = launchAff_ do
         view <- liftEffect $ s.getView
         liftEffect do
           log $ "CoordSysView: " <> show (map BigInt.toString $ unwrap view)
           setWindow name $ (\(Pair l r) -> {l,r}) $ unwrap view

  let set lr = s.queueUpdateView
               $ ModView $ const ((fromJust <<< BigInt.fromNumber) <$> Pair lr.l lr.r)

  pure {get, set}

printSNPInfo :: ∀ r. Array (SNP r) -> Effect Unit
printSNPInfo fs = do
  let n = length fs :: Int
      m = 5
  log $ "showing " <> show m <> " out of " <> show n <> " clicked glyphs"
  for_ (Array.take m fs) (log <<< unsafeCoerce)

wrapWith :: String -> String -> String
wrapWith tag x =
  "<"<> tag <>">" <> x <> "</"<> tag <>">"

snpHTML :: ∀ r.
           SNP r
        -> String
snpHTML {position, feature} = wrapWith "div" contents
  where contents = foldMap (wrapWith "p")
            [ "SNP: "    <> feature.name
            , "Chr: "    <> show feature.chrId
            , "Pos: "    <> show (Pair.fst position)
            , "-log10: " <> feature.score ^. _NegLog10 <<< _Newtype <<< _prec 4
            ]

peakHTML :: ∀ a b c.
            (a -> String)
         -> Peak b c a
         -> String
peakHTML disp peak =
  case Array.uncons peak.elements of
    Nothing               -> ""
    Just {head, tail: []} -> disp head
    Just {head, tail}     ->
      wrapWith "div" $ wrapWith "p"
        $ show (length tail + 1) <> " annotations"

annoPeakHTML :: ∀ a b.
                Peak a b (Annotation ())
             -> String
annoPeakHTML peak =
  case Array.uncons peak.elements of
    Nothing               -> ""
    Just {head, tail: []} -> annotationHTMLAll head
    Just {head, tail}     -> wrapWith "div"
                             ( wrapWith "p" "Annotations:"
                             <> foldMap annotationHTMLShort peak.elements)

-- | Given a function to transform the data in the annotation's "rest" field
-- | to text (or Nothing if the field should not be displayed), produce a
-- | function that generates HTML from annotations
annotationHTML :: (AnnotationField -> Maybe String)
                -> Annotation () -> String
annotationHTML disp {feature} = wrapWith "div" contents
  where url = fromMaybe "No URL"
              $ map (\a -> "URL: <a target='_blank' href='"
                           <> a <> "'>" <> a <> "") feature.url

        name = fromMaybe ("Annotated SNP: " <> feature.name)
                         (("Gene: " <> _) <$> feature.gene)

        showOther fv = fv.field <> ": " <> (unsafeCoerce fv.value)

        contents = foldMap (wrapWith "p")
          $ [ name
            , url
            ] <> (filterMap disp
                  $ Array.fromFoldable feature.rest)

-- | Shows all data in "rest" using the default showAnnotationField (which uses unsafeCoerce)
annotationHTMLAll :: Annotation () -> String
annotationHTMLAll =
  annotationHTML (pure <<< showAnnotationField)

annotationHTMLDefault :: Annotation () -> String
annotationHTMLDefault = annotationHTML \x -> pure case x of
  {field: "p_lrt", value} ->
     "p_lrt: " <> (unsafeCoerce value) ^. _NegLog10 <<< _Newtype <<< _prec 4
  fv -> showAnnotationField fv

annotationHTMLShort :: Annotation () -> String
annotationHTMLShort {feature} = wrapWith "p" anchor
  where
        name' = fromMaybe (feature.name)
                          (feature.gene)

        showOther fv = fv.field <> ": " <> (unsafeCoerce fv.value)

        anchor = case feature.url of
          Nothing  -> name'
          Just url -> "<a target='_blank' href='" <> url <> "'>" <> name' <> ""

foreign import initDebugDiv :: Number -> Effect Unit
foreign import setDebugDivVisibility :: String -> Effect Unit
foreign import setDebugDivPoint :: Point -> Effect Unit

foreign import setElementContents :: Element -> String -> Effect Unit

data InfoBoxF
  = IBoxShow
  | IBoxHide
  | IBoxSetY Int
  | IBoxSetX Int
  | IBoxSetContents String

derive instance genericInfoBoxF :: Generic InfoBoxF _

instance showInfoBoxF :: Show InfoBoxF where
  show = genericShow

updateInfoBox :: Element -> InfoBoxF -> Effect Unit
updateInfoBox el cmd =
  case cmd of
    IBoxShow ->
      setElementStyle el "visibility" "visible"
    IBoxHide ->
      setElementStyle el "visibility" "hidden"
    (IBoxSetX x)    ->
      setElementStyle el "left" $ show x <> "px"
    (IBoxSetY y)    ->
      setElementStyle el "top"  $ show y <> "px"
    (IBoxSetContents html) ->
      setElementContents el html

infoBoxId :: String
infoBoxId = "infoBox"

initInfoBox :: Effect (InfoBoxF -> Effect Unit)
initInfoBox = do
  doc <- map DOM.toDocument
           $ DOM.document =<< DOM.window
  el <- DOM.createElement "div" doc

  setId infoBoxId el

  DOM.documentElement doc >>= case _ of
    Nothing -> throw "Couldn't find document body!"
    Just docBody -> void $ appendChild (Element.toNode el) (Element.toNode docBody)

  pure $ updateInfoBox el

runBrowser :: Conf -> BrowserContainer -> Effect (Fiber Unit)
runBrowser config bc = launchAff $ do

  let cSys :: CoordSys ChrId BigInt
      cSys = coordSys mouseChrSizes

      initialView = fromMaybe (wrap $ Pair zero (cSys^._TotalSize)) do
        {left, right} <- config.initialChrs
        (Pair l _) <- Map.lookup (wrap left) $ cSys^._Segments
        (Pair _ r) <- Map.lookup (wrap right) $ cSys^._Segments
        pure $ wrap $ Pair l r

      clickRadius = 1.0

  liftEffect $ initDebugDiv clickRadius

  cmdInfoBox <- liftEffect $ initInfoBox

  trackData <-
    {genes:_, snps:_, annotations:_}
    <$> foldMap (getGenes       cSys) config.urls.genes
    <*> foldMap (getSNPs        cSys) config.urls.snps
    <*> foldMap (getAnnotations cSys) config.urls.annotations

  render <- liftEffect
            $ addDemoLayers cSys config trackData bc

  browser <-
    initializeBrowser cSys render initialView bc

  liftEffect do
    resizeEvent \d ->
      launchAff_ $ browser.queueCommand $ inj _docResize d

    let btnMods = { scrollMod: 0.10, zoomMod: 0.15 }
    btnUI btnMods browser.queueUpdateView

    buttonEvent "reset"
      $ browser.queueUpdateView
        (ModView (const $ unwrap initialView))

    keyUI (bc ^. _Container) { scrollMod: 0.075 } browser.queueUpdateView

    dragScroll bc \ {x,y} ->
      -- only do anything when scrolling at least a pixel
      when (Math.abs x >= one) do
        trackDims <- _.padded <<< browserSlots <$> getDimensions bc
        browser.queueUpdateView
         $ ScrollView $ (-x) / trackDims.size.width

    let scrollZoomScale = 0.06
    wheelZoom bc \dY ->
       browser.queueUpdateView
         $ ZoomView $ 1.0 + scrollZoomScale * dY

  liftEffect do
    let sigSnps = filterSig config.score trackData.snps
        annotAround pks snp =
          Array.find (\a -> a.covers `pairsOverlap` snp.position)
            =<< Map.lookup snp.feature.chrId pks

        glyphClick :: Point -> Effect Unit
        glyphClick p = launchAff_ do
          v  <- liftEffect $ browser.getView

          trackDims <- _.padded <<< browserSlots <$> getDimensions bc
          let segs = pixelSegments { segmentPadding: 12.0 } cSys trackDims.size v
              annoPeaks = annotationsForScale cSys sigSnps
                            trackData.annotations segs

          lastHotspots' <- liftEffect $ browser.lastHotspots
          liftEffect do
            let clicked = (lastHotspots' clickRadius p)
            printSNPInfo clicked
            case Array.head clicked of
              Nothing -> cmdInfoBox IBoxHide
              Just g  -> do
                cmdInfoBox IBoxShow
                cmdInfoBox $ IBoxSetX $ Int.round p.x
                cmdInfoBox $ IBoxSetY $ Int.round p.y
                cmdInfoBox $ IBoxSetContents
                  $ snpHTML g
                  <> foldMap annoPeakHTML (annotAround annoPeaks g)

    browserClickHandler bc
      $ Padded 5.0 glyphClick

  pure unit

type DataURLs = { snps        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf =
  { browserHeight :: Number
  , padding :: BrowserPadding
  , score :: { min :: Number, max :: Number, sig :: Number }
  , urls :: DataURLs
  , chrLabels :: { fontSize :: Int }
  , snpsConfig        :: SNPConfig
  , annotationsConfig :: AnnotationsConfig
  , legend :: LegendConfig ()
  , vscale :: VScale ()
  , initialChrs :: Maybe { left :: String, right :: String }
  }

foreign import setWindow :: ∀ a. String -> a -> Effect Unit

main :: Foreign -> Effect Unit
main rawConfig = do

  el' <- do
    doc <- DOM.toDocument
           <$> (DOM.document =<< DOM.window)
    DOM.querySelector (wrap "#browser") (toParentNode doc)

  case el' of
    Nothing -> log "Could not find element '#browser'"
    Just el -> do

      case read rawConfig :: Either MultipleErrors Conf of
        Left errs -> do
          setElementContents el
            $  "
Error when parsing provided config object:
"
            <> foldMap (wrapWith "p" <<< renderForeignError) errs

        Right c   -> do

              {width} <- windowInnerSize
              let dimensions = { width, height: c.browserHeight }
              bc <- browserContainer dimensions c.padding el

              log $ unsafeStringify c
              void $ runBrowser c bc

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
  unsafePartial
  $ map (bimap ChrId (fromJust <<< BigInt.fromString))
      [ Tuple "1"   "195471971"
      , Tuple "2"   "182113224"
      , Tuple "3"   "160039680"
      , Tuple "4"   "156508116"
      , Tuple "5"   "151834684"
      , Tuple "6"   "149736546"
      , Tuple "7"   "145441459"
      , Tuple "8"   "129401213"
      , Tuple "9"   "124595110"
      , Tuple "10"  "130694993"
      , Tuple "11"  "122082543"
      , Tuple "12"  "120129022"
      , Tuple "13"  "120421639"
      , Tuple "14"  "124902244"
      , Tuple "15"  "104043685"
      , Tuple "16"  "98207768"
      , Tuple "17"  "94987271"
      , Tuple "18"  "90702639"
      , Tuple "19"  "61431566"
      ]

module Genetics.Browser.UI where

import Prelude

import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Filterable (filterMap)
import Data.Foldable (foldMap, length)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Int as Int
import Data.Lens ((^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Newtype (over, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Symbol (SProxy(SProxy))
import Data.Traversable (for_, traverse_)
import Data.Tuple (Tuple(Tuple))
import Data.Variant (Variant, case_, inj)
import Data.Variant as V
import Effect (Effect)
import Effect.Aff (Aff, Fiber, Milliseconds(..), delay, forkAff, killFiber, launchAff, launchAff_)
import Effect.Aff.AVar (AVar)
import Effect.Aff.AVar as AVar
import Effect.Class (liftEffect)
import Effect.Console (log)
import Effect.Exception (error, throw)
import Effect.Ref as Ref
import Foreign (Foreign, MultipleErrors, renderForeignError)
import Genetics.Browser (LegendConfig, Peak, VScale, pixelSegments)
import Genetics.Browser.Canvas (BrowserContainer, _Container, browserClickHandler, browserContainer, dragScroll, getDimensions, setBrowserContainerSize, setElementStyle, wheelZoom)
import Genetics.Browser.Coordinates (CoordSys, CoordSysView(CoordSysView), _TotalSize, _Segments, coordSys, normalizeView, pairsOverlap, scalePairBy, scaleToScreen, translatePairBy, viewScale)
import Genetics.Browser.Demo (Annotation, AnnotationField, SNP, SNPConfig, AnnotationsConfig, addDemoLayers, annotationsForScale, filterSig, getAnnotations, getGenes, getSNPs, showAnnotationField)
import Genetics.Browser.Layer (Component(Padded), BrowserPadding, browserSlots)
import Genetics.Browser.Types (ChrId(ChrId), _NegLog10, _prec)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Point)
import Math as Math
import Partial.Unsafe (unsafePartial)
import Simple.JSON (read)
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM (Element)
import Web.DOM.Document (createElement, documentElement) as DOM
import Web.DOM.Document (toParentNode)
import Web.DOM.Element (setId)
import Web.DOM.Element as Element
import Web.DOM.Node (appendChild)
import Web.DOM.ParentNode (querySelector) as DOM
import Web.HTML (window) as DOM
import Web.HTML.HTMLDocument (toDocument) as DOM
import Web.HTML.Window (document) as DOM
import Web.UIEvent.KeyboardEvent (KeyboardEvent)
import Web.UIEvent.KeyboardEvent (key) as DOM

foreign import windowInnerSize :: Effect Canvas.Dimensions

-- | Set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Effect Unit
                           -> Effect Unit

foreign import keydownEvent :: Element
                            -> (KeyboardEvent -> Effect Unit)
                            -> Effect Unit

-- | Set callback to run after the window has resized (see UI.js for
-- | time waited), providing it with the new window size.
foreign import resizeEvent :: ({ width  :: Number
                               , height :: Number } -> Effect Unit)
                           -> Effect Unit

-- | The value returned by the function that initializes the genome browser;
-- | provides an interface to the running browser instance.
type BrowserInterface a
  = { getView          :: Aff CoordSysView
    , getBrowserCanvas :: Aff BrowserContainer
    , lastHotspots     :: Effect (Number -> Point -> Array a)
    , queueCommand     :: Variant UICmdR -> Aff Unit
    , queueUpdateView  :: UpdateView -> Effect Unit
    }

-- | Creates the browser using the provided initial data, returning
-- | a BrowserInterface for reading state & sending commands to it
initializeBrowser :: ∀ c r.
                     CoordSys c BigInt
                  -> { snps        :: Pair Number -> CoordSysView -> Effect Unit
                     , annotations :: Pair Number -> CoordSysView -> Effect Unit
                     , chrs        :: Pair Number -> CoordSysView -> Effect Unit
                     , hotspots    :: Effect (Number -> Point -> Array (SNP ()))
                     , fixedUI     :: Effect Unit | r}
                  -> CoordSysView
                  -> BrowserContainer
                  -> Aff (BrowserInterface (SNP ()))
initializeBrowser cSys renderFuns initView bc = do

  renderFiberVar <- AVar.empty

  viewVar <- AVar.new initView
  bcVar <- AVar.new bc

  uiCmdVar <- AVar.empty
  lastHotspotsVar <- AVar.empty

  let getView = AVar.read viewVar
      getBrowserCanvas = AVar.read bcVar
      queueCommand = flip AVar.put uiCmdVar
      lastHotspots = renderFuns.hotspots

    -- hardcoded timeout for now
  queueUpdateView <- liftEffect $ uiViewUpdate cSys (wrap 30.0) {view: viewVar, uiCmd: uiCmdVar}

  let mainLoop = do
        uiCmd <- AVar.take uiCmdVar
        case_ # V.on _render (\_ -> pure unit)
              # V.on _docResize (\ {width} -> do
                      {height} <- _.size <$> getDimensions bc
                      setBrowserContainerSize {width, height} bc
                      queueCommand $ inj _render unit
                      mainLoop)
              $ uiCmd

        -- if there's a rendering fiber running, we kill it
        traverse_ (killFiber (error "Resetting renderer"))
          =<< AVar.tryTake renderFiberVar

        csView <- getView
        canvas <- getBrowserCanvas

        currentDims <- getDimensions canvas

        let trackDims = _.padded $ browserSlots currentDims
            currentScale = viewScale trackDims.size csView
            pxView = scaleToScreen currentScale <$> (unwrap csView)

        -- fork a new renderFiber
        renderFiber <- forkAff $ liftEffect do

          renderFuns.chrs        pxView csView
          renderFuns.annotations pxView csView
          renderFuns.snps        pxView csView
          renderFuns.fixedUI

        AVar.put renderFiber renderFiberVar

        mainLoop

  _ <- forkAff mainLoop

  queueCommand $ inj _render unit

  pure { getView
       , getBrowserCanvas
       , lastHotspots
       , queueCommand
       , queueUpdateView }

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (Pair BigInt -> Pair BigInt)

instance showUpdateView :: Show UpdateView where
  show (ScrollView x) = "(Scroll by " <> show x <> ")"
  show (ZoomView s) = "(Zoom by " <> show s <> ")"
  show _ = "(ModView)"

    -- TODO idk if this instance makes sense??? whatevs
instance semigroupUpdateView :: Semigroup UpdateView where
  append (ScrollView x1) (ScrollView x2) = ScrollView (x1 + x2)
  append (ZoomView s1)   (ZoomView s2)   = ZoomView   (s1 * s2)
  append _ y = y

instance monoidUpdateView :: Monoid UpdateView where
  mempty = ModView identity

updateViewFold :: UpdateView
               -> CoordSysView
               -> CoordSysView
updateViewFold uv = over CoordSysView case uv of
  ZoomView   x -> (_ `scalePairBy`     x)
  ScrollView x -> (_ `translatePairBy` x)
  ModView f    -> f

queueCmd :: ∀ a. AVar a -> a -> Effect Unit
queueCmd av cmd = launchAff_ $ AVar.put cmd av

foreign import onTimeout
  :: Milliseconds
  -> Effect Unit
  -> Effect { run    :: Effect Unit
            , cancel :: Effect Unit }

-- | Provided with the AVar containing the view state (which is updated atomically)
-- | and the UICmd AVar queue (which is only written to),
-- | return a function that combines multiple view updates within a period,
-- | updating the browser view once a timeout is reached.
uiViewUpdate :: ∀ c r.
                CoordSys c BigInt
             -> Milliseconds
             -> { view  :: AVar CoordSysView
                , uiCmd :: AVar (Variant UICmdR) | r }
             -> Effect (UpdateView -> Effect Unit)
uiViewUpdate cs timeout { view, uiCmd } = do

  let normView = normalizeView cs (BigInt.fromInt 200000)
  viewDeltaRef <- Ref.new (ModView identity)

  comms <- onTimeout timeout do
    vD <- Ref.read viewDeltaRef
    Ref.write mempty viewDeltaRef
    launchAff_ do
      vr <- AVar.take view
      let vr' = normView $ updateViewFold vD vr
      AVar.put vr' view
      AVar.put (inj _render unit) uiCmd

  pure \cmd -> do
    Ref.modify_ (_ <> cmd) viewDeltaRef
    comms.run

btnUI :: { scrollMod :: Number, zoomMod :: Number }
      -> (UpdateView -> Effect Unit)
      -> Effect Unit
btnUI mods cb = do
  buttonEvent "scrollLeft"  $ cb $ ScrollView     (-mods.scrollMod)
  buttonEvent "scrollRight" $ cb $ ScrollView       mods.scrollMod
  buttonEvent "zoomOut"     $ cb $ ZoomView $ 1.0 + mods.zoomMod
  buttonEvent "zoomIn"      $ cb $ ZoomView $ 1.0 - mods.zoomMod

keyUI :: ∀ r.
         Element
      -> { scrollMod :: Number | r }
      -> (UpdateView -> Effect Unit)
      -> Effect Unit
keyUI el mods cb = keydownEvent el f
  where f ke = case DOM.key ke of
          "ArrowLeft"  -> cb $ ScrollView (-mods.scrollMod)
          "ArrowRight" -> cb $ ScrollView   mods.scrollMod
          _ -> pure unit

type UICmdR = ( render :: Unit
              , docResize :: { width :: Number, height :: Number } )

_render = SProxy :: SProxy "render"
_docResize = SProxy :: SProxy "docResize"

debugView :: ∀ a.
             BrowserInterface a
          -> Effect { get :: String -> Effect Unit
                    , set :: { l :: Number, r :: Number } -> Effect Unit }
debugView s = unsafePartial do
  let get name = launchAff_ do
         view <- s.getView
         liftEffect do
           log $ "CoordSysView: " <> show (map BigInt.toString $ unwrap view)
           setWindow name $ (\(Pair l r) -> {l,r}) $ unwrap view

  let set lr = s.queueUpdateView
               $ ModView $ const ((fromJust <<< BigInt.fromNumber) <$> Pair lr.l lr.r)

  pure {get, set}

printSNPInfo :: ∀ r. Array (SNP r) -> Effect Unit
printSNPInfo fs = do
  let n = length fs :: Int
      m = 5
  log $ "showing " <> show m <> " out of " <> show n <> " clicked glyphs"
  for_ (Array.take m fs) (log <<< unsafeCoerce)

wrapWith :: String -> String -> String
wrapWith tag x =
  "<"<> tag <>">" <> x <> "</"<> tag <>">"

snpHTML :: ∀ r.
           SNP r
        -> String
snpHTML {position, feature} = wrapWith "div" contents
  where contents = foldMap (wrapWith "p")
            [ "SNP: "    <> feature.name
            , "Chr: "    <> show feature.chrId
            , "Pos: "    <> show (Pair.fst position)
            , "-log10: " <> feature.score ^. _NegLog10 <<< _Newtype <<< _prec 4
            ]

peakHTML :: ∀ a b c.
            (a -> String)
         -> Peak b c a
         -> String
peakHTML disp peak =
  case Array.uncons peak.elements of
    Nothing               -> ""
    Just {head, tail: []} -> disp head
    Just {head, tail}     ->
      wrapWith "div" $ wrapWith "p"
        $ show (length tail + 1) <> " annotations"

annoPeakHTML :: ∀ a b.
                Peak a b (Annotation ())
             -> String
annoPeakHTML peak =
  case Array.uncons peak.elements of
    Nothing               -> ""
    Just {head, tail: []} -> annotationHTMLAll head
    Just {head, tail}     -> wrapWith "div"
                             ( wrapWith "p" "Annotations:"
                             <> foldMap annotationHTMLShort peak.elements)

-- | Given a function to transform the data in the annotation's "rest" field
-- | to text (or Nothing if the field should not be displayed), produce a
-- | function that generates HTML from annotations
annotationHTML :: (AnnotationField -> Maybe String)
                -> Annotation () -> String
annotationHTML disp {feature} = wrapWith "div" contents
  where url = fromMaybe "No URL"
              $ map (\a -> "URL: <a target='_blank' href='"
                           <> a <> "'>" <> a <> "") feature.url

        name = fromMaybe ("Annotated SNP: " <> feature.name)
                         (("Gene: " <> _) <$> feature.gene)

        showOther fv = fv.field <> ": " <> (unsafeCoerce fv.value)

        contents = foldMap (wrapWith "p")
          $ [ name
            , url
            ] <> (filterMap disp
                  $ Array.fromFoldable feature.rest)

-- | Shows all data in "rest" using the default showAnnotationField (which uses unsafeCoerce)
annotationHTMLAll :: Annotation () -> String
annotationHTMLAll =
  annotationHTML (pure <<< showAnnotationField)

annotationHTMLDefault :: Annotation () -> String
annotationHTMLDefault = annotationHTML \x -> pure case x of
  {field: "p_lrt", value} ->
     "p_lrt: " <> (unsafeCoerce value) ^. _NegLog10 <<< _Newtype <<< _prec 4
  fv -> showAnnotationField fv

annotationHTMLShort :: Annotation () -> String
annotationHTMLShort {feature} = wrapWith "p" anchor
  where
        name' = fromMaybe (feature.name)
                          (feature.gene)

        showOther fv = fv.field <> ": " <> (unsafeCoerce fv.value)

        anchor = case feature.url of
          Nothing  -> name'
          Just url -> "<a target='_blank' href='" <> url <> "'>" <> name' <> ""

foreign import initDebugDiv :: Number -> Effect Unit
foreign import setDebugDivVisibility :: String -> Effect Unit
foreign import setDebugDivPoint :: Point -> Effect Unit

foreign import setElementContents :: Element -> String -> Effect Unit

data InfoBoxF
  = IBoxShow
  | IBoxHide
  | IBoxSetY Int
  | IBoxSetX Int
  | IBoxSetContents String

derive instance genericInfoBoxF :: Generic InfoBoxF _

instance showInfoBoxF :: Show InfoBoxF where
  show = genericShow

updateInfoBox :: Element -> InfoBoxF -> Effect Unit
updateInfoBox el cmd =
  case cmd of
    IBoxShow ->
      setElementStyle el "visibility" "visible"
    IBoxHide ->
      setElementStyle el "visibility" "hidden"
    (IBoxSetX x)    ->
      setElementStyle el "left" $ show x <> "px"
    (IBoxSetY y)    ->
      setElementStyle el "top"  $ show y <> "px"
    (IBoxSetContents html) ->
      setElementContents el html

infoBoxId :: String
infoBoxId = "infoBox"

initInfoBox :: Effect (InfoBoxF -> Effect Unit)
initInfoBox = do
  doc <- map DOM.toDocument
           $ DOM.document =<< DOM.window
  el <- DOM.createElement "div" doc

  setId infoBoxId el

  DOM.documentElement doc >>= case _ of
    Nothing -> throw "Couldn't find document body!"
    Just docBody -> void $ appendChild (Element.toNode el) (Element.toNode docBody)

  pure $ updateInfoBox el

runBrowser :: Conf -> BrowserContainer -> Effect (Fiber Unit)
runBrowser config bc = launchAff $ do

  let cSys :: CoordSys ChrId BigInt
      cSys = coordSys mouseChrSizes

      initialView = fromMaybe (wrap $ Pair zero (cSys^._TotalSize)) do
        {left, right} <- config.initialChrs
        (Pair l _) <- Map.lookup (wrap left) $ cSys^._Segments
        (Pair _ r) <- Map.lookup (wrap right) $ cSys^._Segments
        pure $ wrap $ Pair l r

      clickRadius = 1.0

  liftEffect $ initDebugDiv clickRadius

  cmdInfoBox <- liftEffect $ initInfoBox

  trackData <-
    {genes:_, snps:_, annotations:_}
    <$> foldMap (getGenes       cSys) config.urls.genes
    <*> foldMap (getSNPs        cSys) config.urls.snps
    <*> foldMap (getAnnotations cSys) config.urls.annotations

  render <- liftEffect
            $ addDemoLayers cSys config trackData bc

  browser <-
    initializeBrowser cSys render initialView bc

  liftEffect do
    resizeEvent \d ->
      launchAff_ $ browser.queueCommand $ inj _docResize d

    let btnMods = { scrollMod: 0.10, zoomMod: 0.15 }
    btnUI btnMods browser.queueUpdateView

    buttonEvent "reset"
      $ browser.queueUpdateView
        (ModView (const $ unwrap initialView))

    keyUI (bc ^. _Container) { scrollMod: 0.075 } browser.queueUpdateView

    dragScroll bc \ {x,y} ->
      -- only do anything when scrolling at least a pixel
      when (Math.abs x >= one) do
        trackDims <- _.padded <<< browserSlots <$> getDimensions bc
        browser.queueUpdateView
         $ ScrollView $ (-x) / trackDims.size.width

    let scrollZoomScale = 0.06
    wheelZoom bc \dY ->
       browser.queueUpdateView
         $ ZoomView $ 1.0 + scrollZoomScale * dY

  liftEffect do
    let sigSnps = filterSig config.score trackData.snps
        annotAround pks snp =
          Array.find (\a -> a.covers `pairsOverlap` snp.position)
            =<< Map.lookup snp.feature.chrId pks

        glyphClick :: Point -> Effect Unit
        glyphClick p = launchAff_ do
          v  <- browser.getView

          trackDims <- _.padded <<< browserSlots <$> getDimensions bc
          let segs = pixelSegments { segmentPadding: 12.0 } cSys trackDims.size v
              annoPeaks = annotationsForScale cSys sigSnps
                            trackData.annotations segs

          lastHotspots' <- liftEffect $ browser.lastHotspots
          liftEffect do
            let clicked = (lastHotspots' clickRadius p)
            printSNPInfo clicked
            case Array.head clicked of
              Nothing -> cmdInfoBox IBoxHide
              Just g  -> do
                cmdInfoBox IBoxShow
                cmdInfoBox $ IBoxSetX $ Int.round p.x
                cmdInfoBox $ IBoxSetY $ Int.round p.y
                cmdInfoBox $ IBoxSetContents
                  $ snpHTML g
                  <> foldMap annoPeakHTML (annotAround annoPeaks g)

    browserClickHandler bc
      $ Padded 5.0 glyphClick

  pure unit

type DataURLs = { snps        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf =
  { browserHeight :: Number
  , padding :: BrowserPadding
  , score :: { min :: Number, max :: Number, sig :: Number }
  , urls :: DataURLs
  , chrLabels :: { fontSize :: Int }
  , snpsConfig        :: SNPConfig
  , annotationsConfig :: AnnotationsConfig
  , legend :: LegendConfig ()
  , vscale :: VScale ()
  , initialChrs :: Maybe { left :: String, right :: String }
  }

foreign import setWindow :: ∀ a. String -> a -> Effect Unit

main :: Foreign -> Effect Unit
main rawConfig = do

  el' <- do
    doc <- DOM.toDocument
           <$> (DOM.document =<< DOM.window)
    DOM.querySelector (wrap "#browser") (toParentNode doc)

  case el' of
    Nothing -> log "Could not find element '#browser'"
    Just el -> do

      case read rawConfig :: Either MultipleErrors Conf of
        Left errs -> do
          setElementContents el
            $  "
Error when parsing provided config object:
"
            <> foldMap (wrapWith "p" <<< renderForeignError) errs

        Right c   -> do

              {width} <- windowInnerSize
              let dimensions = { width, height: c.browserHeight }
              bc <- browserContainer dimensions c.padding el

              log $ unsafeStringify c
              void $ runBrowser c bc

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
  unsafePartial
  $ map (bimap ChrId (fromJust <<< BigInt.fromString))
      [ Tuple "1"   "195471971"
      , Tuple "2"   "182113224"
      , Tuple "3"   "160039680"
      , Tuple "4"   "156508116"
      , Tuple "5"   "151834684"
      , Tuple "6"   "149736546"
      , Tuple "7"   "145441459"
      , Tuple "8"   "129401213"
      , Tuple "9"   "124595110"
      , Tuple "10"  "130694993"
      , Tuple "11"  "122082543"
      , Tuple "12"  "120129022"
      , Tuple "13"  "120421639"
      , Tuple "14"  "124902244"
      , Tuple "15"  "104043685"
      , Tuple "16"  "98207768"
      , Tuple "17"  "94987271"
      , Tuple "18"  "90702639"
      , Tuple "19"  "61431566"
      ]


Fix path check on windows

Fix path check on windows

module IdePurescript.PscIdeServer
  ( startServer
  , startServer'
  , stopServer
  , ServerStartResult(..)
  , ServerEff
  , Port
  , QuitCallback
  , ErrorLevel(..)
  , Notify(..)
  ) where

import Prelude
import PscIde.Server as S
import Control.Monad.Aff (runAff, Aff, attempt)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Array (length, head)
import Data.Either (either)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.String (Pattern(Pattern), split, toLower, trim)
import Data.Traversable (traverse, traverse_)
import Global (readInt)
import IdePurescript.Exec (getPathVar, findBins)
import IdePurescript.PscIde (cwd) as PscIde
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, ChildProcess, stderr, stdout)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.Path (normalize)
import Node.Platform (Platform(..))
import Node.Process (PROCESS, platform)
import Node.Stream (onDataString)
import PscIde (NET)
import PscIde.Server (Executable(Executable), getSavedPort, defaultServerArgs, savePort, pickFreshPort)

type Port = Int

data ServerStartResult =
    CorrectPath Port
  | WrongPath Port String
  | Started Port ChildProcess
  | Closed
  | StartError String

type ServerEff eff = (cp :: CHILD_PROCESS, process :: PROCESS, console :: CONSOLE, net :: NET, avar :: AVAR, fs :: FS, exception :: EXCEPTION, random :: RANDOM, buffer :: BUFFER | eff)

type QuitCallback eff = (Eff (exception :: EXCEPTION, net :: NET, cp :: CHILD_PROCESS, fs :: FS | eff) Unit)

data ErrorLevel = Success | Info | Warning | Error
type Notify eff = ErrorLevel -> String -> Eff eff Unit

data Version = Version Int Int Int

parseVersion :: String -> Maybe Version
parseVersion s =
  case traverse fromNumber $ readInt 10 <$> split (Pattern ".") s of
    Just [a, b, c] -> Just $ Version a b c
    _ -> Nothing

instance eqVersion :: Eq Version where
  eq (Version a b c) (Version a' b' c') = a == a' && b == b' && c == c'

instance ordVersion :: Ord Version where
  compare (Version a b c) (Version a' b' c') = compare [a,b,c] [a',b',c']

instance showVersion :: Show Version where
  show (Version a b c) = show a <> "." <> show b <> "." <> show c

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
-- | Will notify as to what is happening, choose to supply globs appropriately
startServer' :: forall eff eff'.
  String
  -> String
  -> Boolean
  -> Boolean
  -> Array String
  -> Notify (ServerEff eff)
  -> Notify (ServerEff eff)
  -> Aff (ServerEff eff) { quit :: QuitCallback eff', port :: Maybe Int }
startServer' path server addNpmBin usePurs glob cb logCb = do
  pathVar <- liftEff $ getPathVar addNpmBin path
  serverBins <- findBins pathVar server
  case head serverBins of
    Nothing -> do
      liftEff $ cb Info $ "Couldn't find psc-ide-server, check PATH. Looked for: "
        <> server <> " in PATH: " <> either id id pathVar
      pure { quit: pure unit, port: Nothing }
    Just (Executable bin version) -> do
      liftEff $ log $ "Resolved psc-ide-server paths (1st is used):"
      traverse_ (\(Executable x vv) -> do
        liftEff $ log $ x <> ": " <> fromMaybe "ERROR" vv) serverBins
      liftEff $ when (length serverBins > 1) $ cb Warning $ "Found multiple psc-ide-server executables; using " <> bin
      let glob' = if join (parseVersion <$> trim <$> version) >= Just (Version 0 9 2) then glob else []
      res <- startServer bin path glob' usePurs
      let noRes = { quit: pure unit, port: Nothing }
      liftEff $ case res of
        CorrectPath usedPort -> { quit: pure unit, port: Just usedPort } <$ cb Info ("Found existing psc-ide-server with correct path on port " <> show usedPort)
        WrongPath usedPort wrongPath -> do
          cb Error $ "Found existing psc-ide-server on port '" <> show usedPort <> "' with wrong path: '" <> wrongPath
            <> "'. Correct, kill or configure a different port, and restart."
          pure noRes
        Started usedPort cp -> do
          cb Success $ "Started psc-ide-server (port " <> show usedPort <> ")"
          wireOutput cp logCb
          pure
            { quit: void $ runAff (\_ -> pure unit) (\_ -> pure unit) $ stopServer usedPort path cp
            , port: Just usedPort
            }
        Closed -> noRes <$ cb Info "psc-ide-server exited with success code"
        StartError err -> noRes <$ (cb Error $ "Could not start psc-ide-server process. Check the configured port number is valid.\n" <> err)
  where
    wireOutput :: ChildProcess -> Notify (ServerEff eff) -> Eff (ServerEff eff) Unit
    wireOutput cp log = do
      onDataString (stderr cp) UTF8 (log Warning)
      onDataString (stdout cp) UTF8 (log Info)

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
startServer :: forall eff. String -> String -> Array String -> Boolean -> Aff (ServerEff eff) ServerStartResult
startServer exe rootPath glob usePurs = do
  port <- liftEff $ getSavedPort rootPath
  case port of
    Just p -> do
      workingDir <- attempt $ PscIde.cwd p
      liftEff $ log $ "Found existing port from file: " <> show p <> (either (const "") (", cwd: " <> _) workingDir)
      either (const launchServer) (gotPath p) workingDir
    Nothing -> launchServer

  where
  launchServer = do
    newPort <- liftEff pickFreshPort
    liftEff $ do
      log $ "Starting psc-ide-server on port " <> show newPort <> " with cwd " <> rootPath
      savePort newPort rootPath
    r newPort <$> S.startServer (defaultServerArgs { exe = exe, combinedExe = usePurs, cwd = Just rootPath, port = Just newPort, source = glob })
    where
      r newPort (S.Started cp) = Started newPort cp
      r _ (S.Closed) = Closed
      r _ (S.StartError s) = StartError s

  gotPath port workingDir =
    liftEff $ if normalizePath workingDir == normalizePath rootPath then
        do
          log $ "Found psc-ide-server on port " <> show port <> " with correct path: " <> workingDir
          pure $ CorrectPath port
      else
        do
          log $ "Found psc-ide-server on port " <> show port <> " with wrong path: " <> normalizePath workingDir <> " instead of " <> normalizePath rootPath
          pure $ WrongPath port workingDir

  normalizePath = (if platform == Win32 then toLower else id) <<< normalize

-- | Stop a psc-ide server. Currently implemented by asking it nicely, but potentially by killing it if that doesn't work...
stopServer :: forall eff. Int -> String -> ChildProcess -> Aff (cp :: CHILD_PROCESS, net :: NET, fs :: FS, exception :: EXCEPTION | eff) Unit
stopServer port rootPath cp = do
  oldPort <- liftEff $ S.getSavedPort rootPath
  liftEff $ when (oldPort == Just port) $ S.deleteSavedPort rootPath
  S.stopServer port

module IdePurescript.PscIdeServer
  ( startServer
  , startServer'
  , stopServer
  , ServerStartResult(..)
  , ServerEff
  , Port
  , QuitCallback
  , ErrorLevel(..)
  , Notify(..)
  ) where

import Prelude
import PscIde.Server as S
import Control.Monad.Aff (runAff, Aff, attempt)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Array (length, head)
import Data.Either (either)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.String (Pattern(Pattern), trim, split)
import Data.Traversable (traverse, traverse_)
import Global (readInt)
import IdePurescript.Exec (getPathVar, findBins)
import IdePurescript.PscIde (cwd) as PscIde
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, ChildProcess, stderr, stdout)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.Process (PROCESS)
import Node.Stream (onDataString)
import PscIde (NET)
import PscIde.Server (Executable(Executable), getSavedPort, defaultServerArgs, savePort, pickFreshPort)

type Port = Int

data ServerStartResult =
    CorrectPath Port
  | WrongPath Port String
  | Started Port ChildProcess
  | Closed
  | StartError String

type ServerEff eff = (cp :: CHILD_PROCESS, process :: PROCESS, console :: CONSOLE, net :: NET, avar :: AVAR, fs :: FS, exception :: EXCEPTION, random :: RANDOM, buffer :: BUFFER | eff)

type QuitCallback eff = (Eff (exception :: EXCEPTION, net :: NET, cp :: CHILD_PROCESS, fs :: FS | eff) Unit)

data ErrorLevel = Success | Info | Warning | Error
type Notify eff = ErrorLevel -> String -> Eff eff Unit

data Version = Version Int Int Int

parseVersion :: String -> Maybe Version
parseVersion s =
  case traverse fromNumber $ readInt 10 <$> split (Pattern ".") s of
    Just [a, b, c] -> Just $ Version a b c
    _ -> Nothing

instance eqVersion :: Eq Version where
  eq (Version a b c) (Version a' b' c') = a == a' && b == b' && c == c'

instance ordVersion :: Ord Version where
  compare (Version a b c) (Version a' b' c') = compare [a,b,c] [a',b',c']

instance showVersion :: Show Version where
  show (Version a b c) = show a <> "." <> show b <> "." <> show c

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
-- | Will notify as to what is happening, choose to supply globs appropriately
startServer' :: forall eff eff'.
  String
  -> String
  -> Boolean
  -> Boolean
  -> Array String
  -> Notify (ServerEff eff)
  -> Notify (ServerEff eff)
  -> Aff (ServerEff eff) { quit :: QuitCallback eff', port :: Maybe Int }
startServer' path server addNpmBin usePurs glob cb logCb = do
  pathVar <- liftEff $ getPathVar addNpmBin path
  serverBins <- findBins pathVar server
  case head serverBins of
    Nothing -> do
      liftEff $ cb Info $ "Couldn't find psc-ide-server, check PATH. Looked for: "
        <> server <> " in PATH: " <> either id id pathVar
      pure { quit: pure unit, port: Nothing }
    Just (Executable bin version) -> do
      liftEff $ log $ "Resolved psc-ide-server paths (1st is used):"
      traverse_ (\(Executable x vv) -> do
        liftEff $ log $ x <> ": " <> fromMaybe "ERROR" vv) serverBins
      liftEff $ when (length serverBins > 1) $ cb Warning $ "Found multiple psc-ide-server executables; using " <> bin
      let glob' = if join (parseVersion <$> trim <$> version) >= Just (Version 0 9 2) then glob else []
      res <- startServer bin path glob' usePurs
      let noRes = { quit: pure unit, port: Nothing }
      liftEff $ case res of
        CorrectPath usedPort -> { quit: pure unit, port: Just usedPort } <$ cb Info ("Found existing psc-ide-server with correct path on port " <> show usedPort)
        WrongPath usedPort wrongPath -> do
          cb Error $ "Found existing psc-ide-server on port '" <> show usedPort <> "' with wrong path: '" <> wrongPath
            <> "'. Correct, kill or configure a different port, and restart."
          pure noRes
        Started usedPort cp -> do
          cb Success $ "Started psc-ide-server (port " <> show usedPort <> ")"
          wireOutput cp logCb
          pure
            { quit: void $ runAff (\_ -> pure unit) (\_ -> pure unit) $ stopServer usedPort path cp
            , port: Just usedPort
            }
        Closed -> noRes <$ cb Info "psc-ide-server exited with success code"
        StartError err -> noRes <$ (cb Error $ "Could not start psc-ide-server process. Check the configured port number is valid.\n" <> err)
  where
    wireOutput :: ChildProcess -> Notify (ServerEff eff) -> Eff (ServerEff eff) Unit
    wireOutput cp log = do
      onDataString (stderr cp) UTF8 (log Warning)
      onDataString (stdout cp) UTF8 (log Info)

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
startServer :: forall eff. String -> String -> Array String -> Boolean -> Aff (ServerEff eff) ServerStartResult
startServer exe rootPath glob usePurs = do
  port <- liftEff $ getSavedPort rootPath
  case port of
    Just p -> do
      workingDir <- attempt $ PscIde.cwd p
      liftEff $ log $ "Found existing port from file: " <> show p <> (either (const "") (", cwd: " <> _) workingDir)
      either (const launchServer) (gotPath p) workingDir
    Nothing -> launchServer

  where
  launchServer = do
    newPort <- liftEff pickFreshPort
    liftEff $ do
      log $ "Starting psc-ide-server on port " <> show newPort <> " with cwd " <> rootPath
      savePort newPort rootPath
    r newPort <$> S.startServer (defaultServerArgs { exe = exe, combinedExe = usePurs, cwd = Just rootPath, port = Just newPort, source = glob })
    where
      r newPort (S.Started cp) = Started newPort cp
      r _ (S.Closed) = Closed
      r _ (S.StartError s) = StartError s

  gotPath port workingDir =
    liftEff $ if workingDir == rootPath then
        do
          log $ "Found psc-ide-server on port " <> show port <> " with correct path: " <> workingDir
          pure $ CorrectPath port
      else
        do
          log $ "Found psc-ide-server on port " <> show port <> " with wrong path: " <> workingDir <> " instead of " <> rootPath
          pure $ WrongPath port workingDir

-- | Stop a psc-ide server. Currently implemented by asking it nicely, but potentially by killing it if that doesn't work...
stopServer :: forall eff. Int -> String -> ChildProcess -> Aff (cp :: CHILD_PROCESS, net :: NET, fs :: FS, exception :: EXCEPTION | eff) Unit
stopServer port rootPath cp = do
  oldPort <- liftEff $ S.getSavedPort rootPath
  liftEff $ when (oldPort == Just port) $ S.deleteSavedPort rootPath
  S.stopServer port


Move initialState inside component

Move initialState inside component

module Halogen.Component
  ( Component
  , ComponentHTML
  , ComponentDSL
  , ComponentSpec
  , component
  , LifecycleComponentSpec
  , lifecycleComponent
  , ParentHTML
  , SlotConstructor(..)
  , ParentQuery
  , ParentDSL
  , ParentComponentSpec
  , parentComponent
  , LifecycleParentComponentSpec
  , lifecycleParentComponent
  , ParentState
  , parentState
  , 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.Monad.Eff (runPure, foreachE)
import Control.Monad.Free (Free, foldFree, liftF, hoistFree)
import Control.Monad.Free.Trans as FT
import Control.Monad.ST (runST, newSTRef, readSTRef, writeSTRef)

import Data.Array (cons) as A
import Data.Array.ST (emptySTArray, pushSTArray, STArray) as A
import Data.Bifunctor (lmap)
import Data.Foldable (foldMap, for_)
import Data.Functor.Coproduct (Coproduct, coproduct, left, right)
import Data.Lazy (defer)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, fromJust)
import Data.Traversable (for, traverse)
import Data.Tuple (Tuple(..))

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(..))
import Halogen.Query (get, liftH)
import Halogen.Query.EventSource (EventSource(..), ParentEventSource, runEventSource, fromParentEventSource)
import Halogen.Query.HalogenF (HalogenF, HalogenFP(..), RenderPending(..), hoistHalogenF, transformHF)
import Halogen.Query.StateF (StateF(..), mapState)

import Partial.Unsafe (unsafePartial)

import Unsafe.Coerce (unsafeCoerce)

type RenderResult s f g =
  { state :: s
  , hooks :: Array (Hook f g)
  , tree  :: Tree f Unit
  }

emptyResult :: forall s f g. s -> RenderResult s f g
emptyResult state =
  { state
  , hooks: []
  , tree: emptyTree
  }

-- | 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
  { initialState :: s
  , render :: s -> RenderResult s f g
  , eval :: f ~> (ComponentDSL s f g)
  , initializer :: Maybe (f Unit)
  , finalizers :: s -> Array (Finalized g)
  }

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

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

-- | A spec for a component.
type ComponentSpec s f g =
  { initialState :: s
  , render :: s -> ComponentHTML f
  , eval :: f ~> ComponentDSL s f g
  }

-- | Builds a self-contained component with no possible children.
component :: forall s f g. ComponentSpec s f g -> Component s f g
component spec =
  lifecycleComponent
    { initialState: spec.initialState
    , render: spec.render
    , eval: spec.eval
    , initializer: Nothing
    , finalizer: Nothing
    }

-- | A spec for a component, including lifecycle inputs.
type LifecycleComponentSpec s f g =
  { initialState :: s
  , render :: s -> ComponentHTML f
  , eval :: f ~> ComponentDSL s f g
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a self-contained component with lifecycle inputs and no possible
-- | children.
lifecycleComponent :: forall s f g. LifecycleComponentSpec s f g -> Component s f g
lifecycleComponent spec =
  Component
    { initialState: spec.initialState
    , render: \s -> { state: s, hooks: [], tree: renderTree (spec.render s) }
    , eval: spec.eval
    , initializer: spec.initializer
    , finalizers: \s -> maybe [] (\i -> [finalized spec.eval s i]) spec.finalizer
    }
  where
  renderTree :: ComponentHTML f -> Tree f Unit
  renderTree html = mkTree'
    { slot: unit
    , html: defer \_ -> unsafeCoerce html -- Safe because p is Void
    , eq: \_ _ -> false -- Absurd
    , thunk: false
    }

-- | 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 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 type for nested queries.
type ParentQuery f f' p = Coproduct f (ChildF p f')

-- | 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 full spec for a parent component.
type ParentComponentSpec s s' f f' g p =
  { initialState :: ParentState s s' f f' g p
  , render :: s -> ParentHTML s' f f' g p
  , eval :: f ~> ParentDSL s s' f f' g p
  , peek :: forall x. Maybe (ChildF p f' x -> 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)
  => ParentComponentSpec s s' f f' g p
  -> Component (ParentState s s' f f' g p) (ParentQuery f f' p) g
parentComponent spec =
  lifecycleParentComponent
    { initialState: spec.initialState
    , render: spec.render
    , eval: spec.eval
    , peek: spec.peek
    , initializer: Nothing
    , finalizer: Nothing
    }

-- | A full spec for a parent component, including lifecycle inputs.
type LifecycleParentComponentSpec s s' f f' g p =
  { initialState :: ParentState s s' f f' g p
  , render :: s -> ParentHTML s' f f' g p
  , eval :: f ~> ParentDSL s s' f f' g p
  , peek :: forall x. Maybe (ChildF p f' x -> ParentDSL s s' f f' g p Unit)
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a component with lifecycle inputs that may contain child components.
lifecycleParentComponent
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => LifecycleParentComponentSpec s s' f f' g p
  -> Component (ParentState s s' f f' g p) (ParentQuery f f' p) g
lifecycleParentComponent spec =
  Component
    { initialState: spec.initialState
    , render: renderParent spec.render
    , eval: eval
    , initializer: left <$> spec.initializer
    , finalizers: parentFinalizers eval spec.finalizer
    }
  where
  eval :: ParentQuery f f' p ~> ComponentDSL (ParentState s s' f f' g p) (ParentQuery f f' p) g
  eval = coproduct (queryParent spec.eval) case spec.peek of
    Nothing -> queryChild
    Just peek -> \q -> queryChild q <* queryParent peek q

parentFinalizers
  :: forall s s' f f' g p
   . (ParentQuery f f' p ~> ComponentDSL (ParentState s s' f f' g p) (ParentQuery f f' p) g)
  -> Maybe (f Unit)
  -> ParentState s s' f f' g p
  -> Array (Finalized g)
parentFinalizers eval fin (ParentState s) =
  foldMap childFin s.children <> foldMap parentFin fin
  where
  parentFin :: f Unit -> Array (Finalized g)
  parentFin i = [ finalized eval (parentState s.parent) (left i) ]

  childFin :: ChildState s' f f' g p -> Array (Finalized g)
  childFin child = finalizeComponent child.component child.state

-- | 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 ParentState s s' f f' g p = ParentState
  { parent :: s
  , children :: M.Map p (ChildState s' f f' g p)
  }

type ChildState s' f f' g p =
  { component :: Component s' f' g
  , state :: s'
  , memo :: Maybe (Tree (ParentQuery f f' p) p)
  }

-- | Lifts a state value into an `ParentState` value. Useful when providing
-- | an initial state value for a parent component.
parentState :: forall s s' f f' g p. s -> ParentState s s' f f' g p
parentState st = ParentState { parent: st, children: 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 (ParentState 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
  ParentState 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)

bracketQuery :: forall s f g a. ComponentDSL s f g a -> ComponentDSL s f g a
bracketQuery f = do
  rp <- liftF (RenderPendingHF id)
  case rp of
    Just Pending -> liftF (RenderHF Nothing unit)
    _ -> pure unit
  res <- f
  rp' <- liftF (RenderPendingHF id)
  for_ rp \_ -> liftF (RenderHF (Just Deferred) unit)
  pure res

-- | 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 = bracketQuery do
  ParentState st <- get
  for (M.lookup p st.children) \child ->
    hoistFree (transformHF (mapStateFChild p) (ChildF p) id) (queryComponent child.component 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 = bracketQuery do
  ParentState st <- get
  M.fromList <<< L.catMaybes <$> traverse mkChildQuery (M.toList st.children)
  where
  mkChildQuery (Tuple p' child) =
    for (prjSlot i p')
        \p -> Tuple p <$> hoistFree (transformHF (mapStateFChild p') (ChildF p') id)
                               (queryComponent child.component (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
   . QueryF s s' f f' g p
  ~> ParentDSL s s' f f' g p
liftQuery = liftH

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

mapStateFChild :: forall s s' f f' g p. Ord p => p -> StateF s' ~> StateF (ParentState s s' f f' g p)
mapStateFChild p =
  mapState
    (\(ParentState st) -> unsafePartial fromJust $ _.state <$> M.lookup p st.children)
    (\f (ParentState st) -> ParentState
      { parent: st.parent
      , children: M.update (\child -> Just { component: child.component, state: f child.state, memo: Nothing }) p st.children
      })

renderParent
  :: forall s s' f f' g p
   . (Ord p)
  => (s -> ParentHTML s' f f' g p)
  -> (ParentState s s' f f' g p)
  -> RenderResult (ParentState s s' f f' g p) (ParentQuery f f' p) g
renderParent render (ParentState curr) =
  case install (render curr.parent) init of
    Tuple html acc ->
      { state: ParentState { parent: curr.parent, children: acc.children }
      , hooks: foldMap finalizeChild acc.removed <> acc.hooks
      , tree:  mkTree $ defer \_ -> html
      }

  where

  init =
    { children: M.empty
    , removed: curr.children
    , hooks: []
    }

  install (Text s) st = Tuple (Text s) st
  install (Slot p) st = installChild p st
  install (Element ns name props els) st = runPure $ runST do
    arr <- A.emptySTArray
    acc <- newSTRef st
    foreachE els \el -> do
      st' <- readSTRef acc
      case install el st' of
        Tuple el' st'' -> do
          void $ A.pushSTArray arr el'
          void $ writeSTRef acc st''
    acc' <- readSTRef acc
    pure $ Tuple (Element ns name (map left <$> props) $ unsafeFreeze arr) acc'

  -- Prevents an unnecessary array copy
  unsafeFreeze :: forall h a. A.STArray h a -> Array a
  unsafeFreeze = unsafeCoerce

  finalizeChild child =
    map Finalized $ finalizeComponent child.component child.state

  installChild (SlotConstructor p def) { hooks, removed, children } =
    case M.lookup p curr.children of
      Just child' ->
        renderChild Nothing child'

      Nothing ->
        let def' = def unit
            hook = PostRender <$> initializeComponent def'.component
        in
            renderChild hook
              { component: def'.component
              , state: def'.initialState
              , memo: Nothing
              }
    where
    update hs c =
      { children: M.insert p c children
      , removed: M.delete p removed
      , hooks: hooks <> hs
      }

    renderChild _ c@{ memo : Just tree } =
      Tuple (Slot $ thunkTree tree) (update [] c)

    renderChild hook c =
      let r = renderComponent c.component c.state
          tree = graftTree adapt (const p) r.tree
          hooks' = lmapHook adapt <$> maybe r.hooks (flip A.cons r.hooks) hook

          adapt :: f' ~> Coproduct f (ChildF p f')
          adapt a = right (ChildF p a)
      in
          Tuple (Slot tree) $ update hooks'
            { component: c.component
            , state: r.state
            , memo: Just 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 (ParentState 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
      RenderHF p a -> liftF $ RenderHF p a
      RenderPendingHF k -> liftF $ RenderPendingHF k
      HaltHF -> liftF HaltHF

mergeParentStateF :: forall s s' f f' g p. StateF s ~> ComponentDSL (ParentState 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)
  => Free (HalogenF (ParentState s s' f f' g p) (ChildF p f') g)
  ~> ComponentDSL (ParentState s s' f f' g p) (ParentQuery f f' p) g
liftChildF = hoistFree (transformHF id right id)

queryChild
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => ChildF p f'
  ~> ComponentDSL (ParentState s s' f f' g p) (ParentQuery f f' p) g
queryChild (ChildF p q) =
  hoistFree (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)
  -> (f ~> f')
  -> (forall a. f' a -> Maybe (f a))
  -> Component s f g
  -> Component s' f' g
transform reviewS previewS reviewQ previewQ (Component c) =
  Component
    { initialState: reviewS c.initialState
    , render: \st -> maybe (emptyResult st) render' (previewS st)
    , eval: maybe (liftF HaltHF) (foldFree go <<< c.eval) <<< previewQ
    , initializer: reviewQ <$> c.initializer
    , finalizers: maybe [] c.finalizers <<< previewS
    }
  where

  render' :: s -> RenderResult s' f' g
  render' st =
    case c.render st of
      { state, hooks, tree } ->
        { state: reviewS state
        , hooks: lmapHook reviewQ <$> hooks
        , tree: graftTree reviewQ id tree
        }

  go :: 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 (RenderHF p a) = liftF $ RenderHF p a
  go (RenderPendingHF k) = liftF $ RenderPendingHF k
  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'
  => g ~> g'
  -> Component s f g
  -> Component s f g'
interpret nat (Component c) =
  Component
    { initialState: c.initialState
    , render: render'
    , eval: hoistFree (hoistHalogenF nat) <<< c.eval
    , initializer: c.initializer
    , finalizers: map (mapFinalized nat) <$> c.finalizers
    }
  where
  render' :: s -> RenderResult s f g'
  render' st =
    case c.render st of
      { state, hooks, tree } ->
        { state
        , hooks: rmapHook nat <$> hooks
        , tree
        }

-- | 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
  -> { state :: s
     , hooks :: Array (Hook f g)
     , tree  :: Tree f Unit
     }
renderComponent (Component c) = c.render

-- | 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 -> f ~> ComponentDSL 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
  , ComponentDSL
  , ComponentSpec
  , component
  , LifecycleComponentSpec
  , lifecycleComponent
  , ParentHTML
  , SlotConstructor(..)
  , ParentQuery
  , ParentDSL
  , ParentComponentSpec
  , parentComponent
  , LifecycleParentComponentSpec
  , lifecycleParentComponent
  , ParentState
  , parentState
  , 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.Monad.Eff (runPure, foreachE)
import Control.Monad.Free (Free, foldFree, liftF, hoistFree)
import Control.Monad.Free.Trans as FT
import Control.Monad.ST (runST, newSTRef, readSTRef, writeSTRef)

import Data.Array (cons) as A
import Data.Array.ST (emptySTArray, pushSTArray, STArray) as A
import Data.Bifunctor (lmap)
import Data.Foldable (foldMap, for_)
import Data.Functor.Coproduct (Coproduct, coproduct, left, right)
import Data.Lazy (defer)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, fromJust)
import Data.Traversable (for, traverse)
import Data.Tuple (Tuple(..))

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(..))
import Halogen.Query (get, liftH)
import Halogen.Query.EventSource (EventSource(..), ParentEventSource, runEventSource, fromParentEventSource)
import Halogen.Query.HalogenF (HalogenF, HalogenFP(..), RenderPending(..), hoistHalogenF, transformHF)
import Halogen.Query.StateF (StateF(..), mapState)

import Partial.Unsafe (unsafePartial)

import Unsafe.Coerce (unsafeCoerce)

type RenderResult s f g =
  { state :: s
  , hooks :: Array (Hook f g)
  , tree  :: Tree f Unit
  }

emptyResult :: forall s f g. s -> RenderResult s f g
emptyResult state =
  { state
  , hooks: []
  , tree: emptyTree
  }

-- | 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 :: s -> RenderResult s f g
  , eval :: f ~> (ComponentDSL s f g)
  , initializer :: Maybe (f Unit)
  , finalizers :: s -> Array (Finalized g)
  }

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

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

-- | A spec for a component.
type ComponentSpec s f g =
  { render :: s -> ComponentHTML f
  , eval :: f ~> ComponentDSL s f g
  }

-- | Builds a self-contained component with no possible children.
component :: forall s f g. ComponentSpec s f g -> Component s f g
component spec =
  lifecycleComponent
    { render: spec.render
    , eval: spec.eval
    , initializer: Nothing
    , finalizer: Nothing
    }

-- | A spec for a component, including lifecycle inputs.
type LifecycleComponentSpec s f g =
  { render :: s -> ComponentHTML f
  , eval :: f ~> ComponentDSL s f g
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a self-contained component with lifecycle inputs and no possible
-- | children.
lifecycleComponent :: forall s f g. LifecycleComponentSpec s f g -> Component s f g
lifecycleComponent spec =
  Component
    { render: \s -> { state: s, hooks: [], tree: renderTree (spec.render s) }
    , eval: spec.eval
    , initializer: spec.initializer
    , finalizers: \s -> maybe [] (\i -> [finalized spec.eval s i]) spec.finalizer
    }
  where
  renderTree :: ComponentHTML f -> Tree f Unit
  renderTree html = mkTree'
    { slot: unit
    , html: defer \_ -> unsafeCoerce html -- Safe because p is Void
    , eq: \_ _ -> false -- Absurd
    , thunk: false
    }

-- | 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 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 type for nested queries.
type ParentQuery f f' p = Coproduct f (ChildF p f')

-- | 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 full spec for a parent component.
type ParentComponentSpec s s' f f' g p =
  { render :: s -> ParentHTML s' f f' g p
  , eval :: f ~> ParentDSL s s' f f' g p
  , peek :: forall x. Maybe (ChildF p f' x -> 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)
  => ParentComponentSpec s s' f f' g p
  -> Component (ParentState s s' f f' g p) (ParentQuery f f' p) g
parentComponent spec =
  lifecycleParentComponent
    { render: spec.render
    , eval: spec.eval
    , peek: spec.peek
    , initializer: Nothing
    , finalizer: Nothing
    }

-- | A full spec for a parent component, including lifecycle inputs.
type LifecycleParentComponentSpec s s' f f' g p =
  { render :: s -> ParentHTML s' f f' g p
  , eval :: f ~> ParentDSL s s' f f' g p
  , peek :: forall x. Maybe (ChildF p f' x -> ParentDSL s s' f f' g p Unit)
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a component with lifecycle inputs that may contain child components.
lifecycleParentComponent
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => LifecycleParentComponentSpec s s' f f' g p
  -> Component (ParentState s s' f f' g p) (ParentQuery f f' p) g
lifecycleParentComponent spec =
  Component
    { render: renderParent spec.render
    , eval: eval
    , initializer: left <$> spec.initializer
    , finalizers: parentFinalizers eval spec.finalizer
    }
  where
  eval :: ParentQuery f f' p ~> ComponentDSL (ParentState s s' f f' g p) (ParentQuery f f' p) g
  eval = coproduct (queryParent spec.eval) case spec.peek of
    Nothing -> queryChild
    Just peek -> \q -> queryChild q <* queryParent peek q

parentFinalizers
  :: forall s s' f f' g p
   . (ParentQuery f f' p ~> ComponentDSL (ParentState s s' f f' g p) (ParentQuery f f' p) g)
  -> Maybe (f Unit)
  -> ParentState s s' f f' g p
  -> Array (Finalized g)
parentFinalizers eval fin (ParentState s) =
  foldMap childFin s.children <> foldMap parentFin fin
  where
  parentFin :: f Unit -> Array (Finalized g)
  parentFin i = [ finalized eval (parentState s.parent) (left i) ]

  childFin :: ChildState s' f f' g p -> Array (Finalized g)
  childFin child = finalizeComponent child.component child.state

-- | 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 ParentState s s' f f' g p = ParentState
  { parent :: s
  , children :: M.Map p (ChildState s' f f' g p)
  }

type ChildState s' f f' g p =
  { component :: Component s' f' g
  , state :: s'
  , memo :: Maybe (Tree (ParentQuery f f' p) p)
  }

-- | Lifts a state value into an `ParentState` value. Useful when providing
-- | an initial state value for a parent component.
parentState :: forall s s' f f' g p. s -> ParentState s s' f f' g p
parentState st = ParentState { parent: st, children: 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 (ParentState 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
  ParentState 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)

bracketQuery :: forall s f g a. ComponentDSL s f g a -> ComponentDSL s f g a
bracketQuery f = do
  rp <- liftF (RenderPendingHF id)
  case rp of
    Just Pending -> liftF (RenderHF Nothing unit)
    _ -> pure unit
  res <- f
  rp' <- liftF (RenderPendingHF id)
  for_ rp \_ -> liftF (RenderHF (Just Deferred) unit)
  pure res

-- | 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 = bracketQuery do
  ParentState st <- get
  for (M.lookup p st.children) \child ->
    hoistFree (transformHF (mapStateFChild p) (ChildF p) id) (queryComponent child.component 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 = bracketQuery do
  ParentState st <- get
  M.fromList <<< L.catMaybes <$> traverse mkChildQuery (M.toList st.children)
  where
  mkChildQuery (Tuple p' child) =
    for (prjSlot i p')
        \p -> Tuple p <$> hoistFree (transformHF (mapStateFChild p') (ChildF p') id)
                               (queryComponent child.component (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
   . QueryF s s' f f' g p
  ~> ParentDSL s s' f f' g p
liftQuery = liftH

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

mapStateFChild :: forall s s' f f' g p. Ord p => p -> StateF s' ~> StateF (ParentState s s' f f' g p)
mapStateFChild p =
  mapState
    (\(ParentState st) -> unsafePartial fromJust $ _.state <$> M.lookup p st.children)
    (\f (ParentState st) -> ParentState
      { parent: st.parent
      , children: M.update (\child -> Just { component: child.component, state: f child.state, memo: Nothing }) p st.children
      })

renderParent
  :: forall s s' f f' g p
   . (Ord p)
  => (s -> ParentHTML s' f f' g p)
  -> (ParentState s s' f f' g p)
  -> RenderResult (ParentState s s' f f' g p) (ParentQuery f f' p) g
renderParent render (ParentState curr) =
  case install (render curr.parent) init of
    Tuple html acc ->
      { state: ParentState { parent: curr.parent, children: acc.children }
      , hooks: foldMap finalizeChild acc.removed <> acc.hooks
      , tree:  mkTree $ defer \_ -> html
      }

  where

  init =
    { children: M.empty
    , removed: curr.children
    , hooks: []
    }

  install (Text s) st = Tuple (Text s) st
  install (Slot p) st = installChild p st
  install (Element ns name props els) st = runPure $ runST do
    arr <- A.emptySTArray
    acc <- newSTRef st
    foreachE els \el -> do
      st' <- readSTRef acc
      case install el st' of
        Tuple el' st'' -> do
          void $ A.pushSTArray arr el'
          void $ writeSTRef acc st''
    acc' <- readSTRef acc
    pure $ Tuple (Element ns name (map left <$> props) $ unsafeFreeze arr) acc'

  -- Prevents an unnecessary array copy
  unsafeFreeze :: forall h a. A.STArray h a -> Array a
  unsafeFreeze = unsafeCoerce

  finalizeChild child =
    map Finalized $ finalizeComponent child.component child.state

  installChild (SlotConstructor p def) { hooks, removed, children } =
    case M.lookup p curr.children of
      Just child' ->
        renderChild Nothing child'

      Nothing ->
        let def' = def unit
            hook = PostRender <$> initializeComponent def'.component
        in
            renderChild hook
              { component: def'.component
              , state: def'.initialState
              , memo: Nothing
              }
    where
    update hs c =
      { children: M.insert p c children
      , removed: M.delete p removed
      , hooks: hooks <> hs
      }

    renderChild _ c@{ memo : Just tree } =
      Tuple (Slot $ thunkTree tree) (update [] c)

    renderChild hook c =
      let r = renderComponent c.component c.state
          tree = graftTree adapt (const p) r.tree
          hooks' = lmapHook adapt <$> maybe r.hooks (flip A.cons r.hooks) hook

          adapt :: f' ~> Coproduct f (ChildF p f')
          adapt a = right (ChildF p a)
      in
          Tuple (Slot tree) $ update hooks'
            { component: c.component
            , state: r.state
            , memo: Just 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 (ParentState 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
      RenderHF p a -> liftF $ RenderHF p a
      RenderPendingHF k -> liftF $ RenderPendingHF k
      HaltHF -> liftF HaltHF

mergeParentStateF :: forall s s' f f' g p. StateF s ~> ComponentDSL (ParentState 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)
  => Free (HalogenF (ParentState s s' f f' g p) (ChildF p f') g)
  ~> ComponentDSL (ParentState s s' f f' g p) (ParentQuery f f' p) g
liftChildF = hoistFree (transformHF id right id)

queryChild
  :: forall s s' f f' g p
   . (Functor g, Ord p)
  => ChildF p f'
  ~> ComponentDSL (ParentState s s' f f' g p) (ParentQuery f f' p) g
queryChild (ChildF p q) =
  hoistFree (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)
  -> (f ~> f')
  -> (forall a. f' a -> Maybe (f a))
  -> Component s f g
  -> Component s' f' g
transform reviewS previewS reviewQ previewQ (Component c) =
  Component
    { render: \st -> maybe (emptyResult st) render' (previewS st)
    , eval: maybe (liftF HaltHF) (foldFree go <<< c.eval) <<< previewQ
    , initializer: reviewQ <$> c.initializer
    , finalizers: maybe [] c.finalizers <<< previewS
    }
  where

  render' :: s -> RenderResult s' f' g
  render' st =
    case c.render st of
      { state, hooks, tree } ->
        { state: reviewS state
        , hooks: lmapHook reviewQ <$> hooks
        , tree: graftTree reviewQ id tree
        }

  go :: 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 (RenderHF p a) = liftF $ RenderHF p a
  go (RenderPendingHF k) = liftF $ RenderPendingHF k
  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'
  => g ~> g'
  -> Component s f g
  -> Component s f g'
interpret nat (Component c) =
  Component
    { render: render'
    , eval: hoistFree (hoistHalogenF nat) <<< c.eval
    , initializer: c.initializer
    , finalizers: map (mapFinalized nat) <$> c.finalizers
    }
  where
  render' :: s -> RenderResult s f g'
  render' st =
    case c.render st of
      { state, hooks, tree } ->
        { state
        , hooks: rmapHook nat <$> hooks
        , tree
        }

-- | 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
  -> { state :: s
     , hooks :: Array (Hook f g)
     , tree  :: Tree f Unit
     }
renderComponent (Component c) = c.render

-- | 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 -> f ~> ComponentDSL 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