Container clean up

Container clean up

module Genetics.Browser.UI.Container
       where

import Prelude

import Control.Coroutine as CR
import Control.Error.Util (note)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (runExcept)
import Control.MonadPlus (guard)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (class EncodeJson, JObject, Json, _Array, _Number, _Object, _String, decodeJson, encodeJson, jsonEmptyObject, jsonParser, (.?), (~>))
import Data.Array (mapMaybe, null, uncons)
import Data.Const (Const)
import Data.Either (Either(..))
import Data.Either.Nested (Either2)
import Data.Foldable (foldMap, length, sequence_)
import Data.Foreign (Foreign, renderForeignError)
import Data.Functor.Contravariant ((>$<))
import Data.Functor.Coproduct.Nested (type (<\/>), Coproduct3, Coproduct2)
import Data.Int (round)
import Data.Lens (re, (^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.Options (Options, (:=))
import Data.Predicate (Predicate(..))
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.Symbol (SProxy(..))
import Data.Traversable (sequence, traverse, traverse_)
import Data.Tuple (Tuple(..))
import Data.Variant (Variant)
import Debug.Trace (traceShow)
import Genetics.Browser.Biodalliance (initBD, setLocation)
import Genetics.Browser.Biodalliance as Biodalliance
import Genetics.Browser.Biodalliance.Config (RendererInfo, renderers, sources)
import Genetics.Browser.Biodalliance.Source (Source)
import Genetics.Browser.Biodalliance.Source as Source
import Genetics.Browser.Biodalliance.Types (BD, Biodalliance, Renderer)
import Genetics.Browser.Config (BrowserConfig(..), parseBrowserConfig)
import Genetics.Browser.Config.Track (validateConfigs)
import Genetics.Browser.Cytoscape as Cytoscape
import Genetics.Browser.Cytoscape.Collection (connectedEdges, connectedNodes, filter, isEdge, targetNodes)
import Genetics.Browser.Cytoscape.Collection as CyCollection
import Genetics.Browser.Cytoscape.Types (CY, Cytoscape, Element, elementJObject, elementJson)
import Genetics.Browser.Events (Location(..), Range(..))
import Genetics.Browser.Events.TrackSink (SinkConfig, TrackSink, forkTrackSink, makeTrackSink, makeTrackSinks)
import Genetics.Browser.Events.TrackSource (SourceConfig, TrackSource, emptyTrackSource, makeTrackSource, makeTrackSources, runTrackSource)
import Genetics.Browser.Events.Types (Event)
import Genetics.Browser.Renderer.GWAS as GWAS
import Genetics.Browser.Renderer.Lineplot (LinePlotConfig)
import Genetics.Browser.Renderer.Lineplot as QTL
import Genetics.Browser.UI.Biodalliance as UIBD
import Genetics.Browser.UI.Cytoscape as UICy
import Genetics.Browser.Units (Bp(Bp), Chr(..), _Bp, _BpMBp, _Chr, _MBp, bp)
import Global.Unsafe (unsafeStringify)
import Halogen as H
import Halogen.Aff as HA
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.VDom.Driver (runUI)
import IPFS as IPFS
import IPFS.Files as Files
import IPFS.Types (IPFSPath(..))
import Node.Encoding (Encoding, Encoding(..))
import Node.Stream (Readable, readString)
import Node.Stream as Stream
import Unsafe.Coerce (unsafeCoerce)

type BDEventEff eff = (console :: CONSOLE, bd :: BD, avar :: AVAR | eff)
type CyEventEff eff = (console :: CONSOLE, cy :: CY, avar :: AVAR | eff)

subscribeBDEvents :: ∀ r.
                     (TrackSource Event)
                  -> Biodalliance
                  -> BusRW Event
                  -> Eff _ Unit
subscribeBDEvents h bd bus =
  Biodalliance.addFeatureListener bd $ \obj -> do
    let evs = runTrackSource h (unwrap obj)

    traverse_ (\x -> Aff.launchAff $ Bus.write x bus) evs

subscribeCyEvents :: ∀ r.
                     (TrackSource Event)
                  -> Cytoscape
                  -> BusRW Event
                  -> Eff _ Unit
subscribeCyEvents h cy bus =
  Cytoscape.onClick cy $ \obj -> do
    let evs = runTrackSource h (unwrap obj)
    traverse_ (\x -> Aff.launchAff $ Bus.write x bus) evs

qtlGlyphify :: LinePlotConfig -> Renderer
qtlGlyphify = QTL.render

gwasGlyphify :: Renderer
gwasGlyphify = GWAS.render

data Track = BDTrack | CyTrack

type State = Unit

data Query a
  = CreateBD (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance) a
  | PropagateMessage Message a
  | BDScroll Bp a
  | BDJump Chr Bp Bp a
  | CreateCy String a
  | ResetCy a

data Message
  = BDInstance Biodalliance
  | CyInstance Cytoscape

type ChildSlot = Either2 UIBD.Slot UICy.Slot

type ChildQuery = Coproduct2 UIBD.Query UICy.Query
type Effects eff = UIBD.Effects (UICy.Effects eff)

component :: ∀ eff. H.Component HH.HTML Query Unit Message (Aff (Effects eff))
component =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = unit

  render :: State -> H.ParentHTML Query ChildQuery ChildSlot (Aff (Effects eff))
  render state =
    HH.div_
      [ HH.button
        [  HE.onClick (HE.input_ (BDScroll (Bp (-1000000.0))))
        ]
        [ HH.text "Scroll left 1MBp" ]
      , HH.button
        [  HE.onClick (HE.input_ (BDScroll (Bp 1000000.0)))
        ]
        [ HH.text "Scroll right 1MBp" ]
      , HH.button
        [  HE.onClick (HE.input_ ResetCy)
        ]
        [ HH.text "Reset cytoscape" ]
        -- these divs are used to control the sizes of the subcomponents without having to query the children
      , HH.div
          [] [HH.slot' CP.cp1 UIBD.Slot UIBD.component unit handleBDMessage]
      , HH.div
          [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]
      ]

  handleBDMessage :: UIBD.Message -> Maybe (Query Unit)
  handleBDMessage UIBD.Initialized = Nothing
  handleBDMessage (UIBD.SendBD bd) = Just $ H.action $ PropagateMessage (BDInstance bd)

  -- TODO the event source track should be handled automatically somehow
  handleCyMessage :: UICy.Output -> Maybe (Query Unit)
  handleCyMessage (UICy.SendCy cy) = Just $ H.action $ PropagateMessage (CyInstance cy)
  handleCyMessage (UICy.SendEvent) = Nothing

  eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Message (Aff (Effects eff))
  eval = case _ of
    CreateBD bd next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Initialize bd)
      pure next

    PropagateMessage msg next -> do
      case msg of
        BDInstance _ -> liftEff $ log "propagating BD"
        CyInstance _ -> liftEff $ log "propagating Cy"
      H.raise msg
      pure next

    BDScroll dist next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Scroll dist)
      pure next
    BDJump chr xl xr next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Jump chr xl xr)
      pure next

    CreateCy div next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action (UICy.Initialize div)
      pure next
    ResetCy next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action UICy.Reset
      pure next

qtlRenderer :: Int -> RendererInfo
qtlRenderer h = { renderer: qtlGlyphify { minScore: 4.0
                                        , maxScore: 6.0
                                        , color: "#ff0000"
                                        }
                , canvasHeight: h
                }

gwasRenderer :: Int -> RendererInfo
gwasRenderer h = { renderer: gwasGlyphify
                 , canvasHeight: h
                 }

createSource :: forall eff a. (Chr -> Bp -> Bp -> Aff eff a) -> Source a
createSource = Source.createSource

type BasicFeature r = { chr :: String
                      , min :: Int
                      , max :: Int
                      | r
                      }

testPath = "QmQwtu1Lr1R3syY15Ak2U85NZjbWrtda8pE8Dp4mnQLPEx"

parseScoreFeature :: Json -> Either String (BasicFeature (score :: Number))
parseScoreFeature j = do
  obj <- decodeJson j
  chr <- (obj .? "chr")
  min <- round <$> obj .? "min"
  max <- round <$> obj .? "max"
  score <- (obj .? "score")
  pure {chr, min, max, score}

foreign import setBDRef :: ∀ eff. Biodalliance -> Eff eff Unit

filterCytoscape :: Cytoscape -> Predicate Json -> Eff _ Unit
filterCytoscape cy p = do
  g <- Cytoscape.graphGetCollection cy
  let g' = CyCollection.filter (elementJson >$< p) g
      gAll = g' <> (connectedEdges g') <> (connectedNodes g')
  Cytoscape.graphRemoveCollection g' *> pure unit

main :: Foreign -> Eff _ Unit
main fConfig = HA.runHalogenAff do
  case runExcept $ parseBrowserConfig fConfig of
    Left e -> liftEff $ do
      log "Invalid browser configuration:"
      sequence_ $ log <<< renderForeignError <$> e

    Right (BrowserConfig config) -> do
      let {bdTracks, cyGraphs} = validateConfigs config.tracks

          opts' = sources := bdTracks.results <>
                  renderers := config.bdRenderers

      liftEff $ log $ "BDTrack errors: " <> foldMap ((<>) ", ") bdTracks.errors
      liftEff $ log $ "CyGraph errors: " <> foldMap ((<>) ", ") cyGraphs.errors

      let mkBd :: (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance)
          mkBd = initBD opts' config.wrapRenderer config.browser

      liftEff $ log "running main"
      HA.awaitLoad
      el <- HA.selectElement (wrap "#psgbHolder")

      case el of
        Nothing -> do
          liftEff $ log "no element for browser!"
        Just el' -> do

          io <- runUI component unit el'

          busFromBD <- Bus.make
          busFromCy <- Bus.make

          let bdTrackSink = makeTrackSinks <<< _.bdEventSinks
                              =<< note "No BD event sinks configured" (config.events)
              bdTrackSource = makeTrackSources <<< _.bdEventSources
                              =<< note "No BD event sources configured" (config.events)

          when (not null bdTracks.results) do
            io.subscribe $ CR.consumer $ case _ of
              BDInstance bd -> do
                liftEff $ log "attaching BD event handlers"

                case bdTrackSink of
                  Left err -> liftEff $ log "No BD TrackSink!"
                  Right ts -> forkTrackSink ts bd busFromCy *> pure unit

                case bdTrackSource of
                  Left err -> liftEff do
                    log "No BD TrackSource! Error:"
                    log err
                  Right ts -> liftEff do
                    subscribeBDEvents ts bd busFromBD

                liftEff $ setBDRef bd
                pure Nothing
              _ -> pure $ Just unit
            liftEff $ log "creating BD"
            io.query $ H.action (CreateBD mkBd)
            liftEff $ log "created BD!"

          liftEff $ log $ "cytoscape enabled: " <> show (not null cyGraphs.results)

          let cyGraphSink = makeTrackSinks <<< _.cyEventSinks
                              =<< note "No Cy.js event sinks configured" (config.events)
              cyGraphSource = makeTrackSources <<< _.cyEventSources
                              =<< note "No Cy.js event sources configured" (config.events)

          case uncons cyGraphs.results of
            Nothing -> pure unit
            Just {head, tail} -> do
              io.subscribe $ CR.consumer $ case _ of
                CyInstance cy -> do
                  liftEff $ log "attaching Cy event handlers"

                  case cyGraphSource of
                    Left err -> liftEff do
                      log "No Cy graph source!"
                      log err
                    Right gs -> liftEff do
                      log $ unsafeStringify gs
                      subscribeCyEvents gs cy busFromCy

                  case cyGraphSink of
                      Left err -> liftEff $ log "No Cy.js TrackSink!"
                      Right ts -> forkTrackSink ts cy busFromBD *> pure unit

                  pure Nothing
                _ -> pure $ Just unit

              liftEff $ log "creating Cy.js"
              io.query $ H.action (CreateCy $ _.elementsUri <<< unwrap $ head)
              liftEff $ log "created cy!"

module Genetics.Browser.UI.Container
       where

import Prelude

import Control.Coroutine as CR
import Control.Error.Util (note)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (runExcept)
import Control.MonadPlus (guard)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (class EncodeJson, JObject, Json, _Array, _Number, _Object, _String, decodeJson, encodeJson, jsonEmptyObject, jsonParser, (.?), (~>))
import Data.Array (mapMaybe, null, uncons)
import Data.Const (Const)
import Data.Either (Either(..))
import Data.Either.Nested (Either2)
import Data.Foldable (foldMap, length, sequence_)
import Data.Foreign (Foreign, renderForeignError)
import Data.Functor.Contravariant ((>$<))
import Data.Functor.Coproduct.Nested (type (<\/>))
import Data.Int (round)
import Data.Lens (re, (^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.Options (Options, (:=))
import Data.Predicate (Predicate(..))
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.Symbol (SProxy(..))
import Data.Traversable (sequence, traverse, traverse_)
import Data.Tuple (Tuple(..))
import Data.Variant (Variant)
import Debug.Trace (traceShow)
import Genetics.Browser.Biodalliance (initBD, setLocation)
import Genetics.Browser.Biodalliance as Biodalliance
import Genetics.Browser.Biodalliance.Config (RendererInfo, renderers, sources)
import Genetics.Browser.Biodalliance.Source (Source)
import Genetics.Browser.Biodalliance.Source as Source
import Genetics.Browser.Biodalliance.Types (BD, Biodalliance, Renderer)
import Genetics.Browser.Config (BrowserConfig(..), parseBrowserConfig)
import Genetics.Browser.Config.Track (validateConfigs)
import Genetics.Browser.Cytoscape as Cytoscape
import Genetics.Browser.Cytoscape.Collection (connectedEdges, connectedNodes, filter, isEdge, targetNodes)
import Genetics.Browser.Cytoscape.Collection as CyCollection
import Genetics.Browser.Cytoscape.Types (CY, Cytoscape, Element, elementJObject, elementJson)
import Genetics.Browser.Events (Location(..), Range(..))
import Genetics.Browser.Events.TrackSink (SinkConfig, TrackSink, forkTrackSink, makeTrackSink, makeTrackSinks)
import Genetics.Browser.Events.TrackSource (SourceConfig, TrackSource, emptyTrackSource, makeTrackSource, makeTrackSources, runTrackSource)
import Genetics.Browser.Events.Types (Event)
import Genetics.Browser.Renderer.GWAS as GWAS
import Genetics.Browser.Renderer.Lineplot (LinePlotConfig)
import Genetics.Browser.Renderer.Lineplot as QTL
import Genetics.Browser.UI.Biodalliance as UIBD
import Genetics.Browser.UI.Cytoscape as UICy
import Genetics.Browser.Units (Bp(Bp), Chr(..), _Bp, _BpMBp, _Chr, _MBp, bp)
import Global.Unsafe (unsafeStringify)
import Halogen as H
import Halogen.Aff as HA
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.VDom.Driver (runUI)
import IPFS as IPFS
import IPFS.Files as Files
import IPFS.Types (IPFSPath(..))
import Node.Encoding (Encoding, Encoding(..))
import Node.Stream (Readable, readString)
import Node.Stream as Stream
import Unsafe.Coerce (unsafeCoerce)

type BDEventEff eff = (console :: CONSOLE, bd :: BD, avar :: AVAR | eff)
type CyEventEff eff = (console :: CONSOLE, cy :: CY, avar :: AVAR | eff)

subscribeBDEvents :: ∀ r.
                     (TrackSource Event)
                  -> Biodalliance
                  -> BusRW Event
                  -> Eff _ Unit
subscribeBDEvents h bd bus =
  Biodalliance.addFeatureListener bd $ \obj -> do
    let evs = runTrackSource h (unwrap obj)

    traverse_ (\x -> Aff.launchAff $ Bus.write x bus) evs

subscribeCyEvents :: ∀ r.
                     (TrackSource Event)
                  -> Cytoscape
                  -> BusRW Event
                  -> Eff _ Unit
subscribeCyEvents h cy bus =
  Cytoscape.onClick cy $ \obj -> do
    let evs = runTrackSource h (unwrap obj)
    traverse_ (\x -> Aff.launchAff $ Bus.write x bus) evs

qtlGlyphify :: LinePlotConfig -> Renderer
qtlGlyphify = QTL.render

gwasGlyphify :: Renderer
gwasGlyphify = GWAS.render

data Track = BDTrack | CyTrack

type State = Unit

data Query a
  = CreateBD (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance) a
  | PropagateMessage Message a
  | BDScroll Bp a
  | BDJump Chr Bp Bp a
  | CreateCy String a
  | ResetCy a

data Message
  = BDInstance Biodalliance
  | CyInstance Cytoscape
  -- | WithCy Cytoscape

type ChildSlot = Either2 UIBD.Slot UICy.Slot

type ChildQuery = UIBD.Query <\/> UICy.Query <\/> Const Void
type Effects eff = UIBD.Effects (UICy.Effects eff)

component :: ∀ eff. H.Component HH.HTML Query Unit Message (Aff (Effects eff))
component =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = unit

  render :: State -> H.ParentHTML Query ChildQuery ChildSlot (Aff (Effects eff))
  render state =
    HH.div_
      [ HH.div_
        [ HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp (-1000000.0))))
          ]
          [ HH.text "Scroll left 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp 1000000.0)))
          ]
          [ HH.text "Scroll right 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ ResetCy)
          ]
          [ HH.text "Reset cytoscape" ]
          -- these divs are used to control the sizes of the subcomponents without having to query the children
        , HH.div
            [] [HH.slot' CP.cp1 UIBD.Slot UIBD.component unit handleBDMessage]
        , HH.div
            [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]
        ]
      ]

  handleBDMessage :: UIBD.Message -> Maybe (Query Unit)
  handleBDMessage UIBD.Initialized = Nothing
  handleBDMessage (UIBD.SendBD bd) = Just $ H.action $ PropagateMessage (BDInstance bd)

  -- TODO the event source track should be handled automatically somehow
  handleCyMessage :: UICy.Output -> Maybe (Query Unit)
  handleCyMessage (UICy.SendCy cy) = Just $ H.action $ PropagateMessage (CyInstance cy)
  handleCyMessage (UICy.SendEvent) = Nothing

  eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Message (Aff (Effects eff))
  eval = case _ of
    CreateBD bd next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Initialize bd)
      pure next

    PropagateMessage msg next -> do
      case msg of
        BDInstance _ -> liftEff $ log "propagating BD"
        CyInstance _ -> liftEff $ log "propagating Cy"
      H.raise msg
      pure next

    BDScroll dist next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Scroll dist)
      pure next
    BDJump chr xl xr next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Jump chr xl xr)
      pure next

    CreateCy div next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action (UICy.Initialize div)
      pure next
    ResetCy next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action UICy.Reset
      pure next

qtlRenderer :: Int -> RendererInfo
qtlRenderer h = { renderer: qtlGlyphify { minScore: 4.0
                                        , maxScore: 6.0
                                        , color: "#ff0000"
                                        }
                , canvasHeight: h
                }

gwasRenderer :: Int -> RendererInfo
gwasRenderer h = { renderer: gwasGlyphify
                 , canvasHeight: h
                 }

createSource :: forall eff a. (Chr -> Bp -> Bp -> Aff eff a) -> Source a
createSource = Source.createSource

type BasicFeature r = { chr :: String
                      , min :: Int
                      , max :: Int
                      | r
                      }

testPath = "QmQwtu1Lr1R3syY15Ak2U85NZjbWrtda8pE8Dp4mnQLPEx"

parseScoreFeature :: Json -> Either String (BasicFeature (score :: Number))
parseScoreFeature j = do
  obj <- decodeJson j
  chr <- (obj .? "chr")
  min <- round <$> obj .? "min"
  max <- round <$> obj .? "max"
  score <- (obj .? "score")
  pure {chr, min, max, score}

foreign import setBDRef :: ∀ eff. Biodalliance -> Eff eff Unit

filterCytoscape :: Cytoscape -> Predicate Json -> Eff _ Unit
filterCytoscape cy p = do
  g <- Cytoscape.graphGetCollection cy
  let g' = CyCollection.filter (elementJson >$< p) g
      gAll = g' <> (connectedEdges g') <> (connectedNodes g')
  Cytoscape.graphRemoveCollection g' *> pure unit

main :: Foreign -> Eff _ Unit
main fConfig = HA.runHalogenAff do
  case runExcept $ parseBrowserConfig fConfig of
    Left e -> liftEff $ do
      log "Invalid browser configuration:"
      sequence_ $ log <<< renderForeignError <$> e

    Right (BrowserConfig config) -> do
      let {bdTracks, cyGraphs} = validateConfigs config.tracks

          opts' = sources := bdTracks.results <>
                  renderers := config.bdRenderers

      liftEff $ log $ "BDTrack errors: " <> foldMap ((<>) ", ") bdTracks.errors
      liftEff $ log $ "CyGraph errors: " <> foldMap ((<>) ", ") cyGraphs.errors

      let mkBd :: (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance)
          mkBd = initBD opts' config.wrapRenderer config.browser

      liftEff $ log "running main"
      HA.awaitLoad
      el <- HA.selectElement (wrap "#psgbHolder")

      case el of
        Nothing -> do
          liftEff $ log "no element for browser!"
        Just el' -> do

          io <- runUI component unit el'

          busFromBD <- Bus.make
          busFromCy <- Bus.make

          let bdTrackSink = makeTrackSinks <<< _.bdEventSinks
                              =<< note "No BD event sinks configured" (config.events)
              bdTrackSource = makeTrackSources <<< _.bdEventSources
                              =<< note "No BD event sources configured" (config.events)

          when (not null bdTracks.results) do
            io.subscribe $ CR.consumer $ case _ of
              BDInstance bd -> do
                liftEff $ log "attaching BD event handlers"

                case bdTrackSink of
                  Left err -> liftEff $ log "No BD TrackSink!"
                  Right ts -> forkTrackSink ts bd busFromCy *> pure unit

                case bdTrackSource of
                  Left err -> liftEff do
                    log "No BD TrackSource! Error:"
                    log err
                  Right ts -> liftEff do
                    subscribeBDEvents ts bd busFromBD

                liftEff $ setBDRef bd
                pure Nothing
              _ -> pure $ Just unit
            liftEff $ log "creating BD"
            io.query $ H.action (CreateBD mkBd)
            liftEff $ log "created BD!"

          liftEff $ log $ "cytoscape enabled: " <> show (not null cyGraphs.results)

          let cyGraphSink = makeTrackSinks <<< _.cyEventSinks
                              =<< note "No Cy.js event sinks configured" (config.events)
              cyGraphSource = makeTrackSources <<< _.cyEventSources
                              =<< note "No Cy.js event sources configured" (config.events)

          case uncons cyGraphs.results of
            Nothing -> pure unit
            Just {head, tail} -> do
              io.subscribe $ CR.consumer $ case _ of
                CyInstance cy -> do
                  liftEff $ log "attaching Cy event handlers"

                  case cyGraphSource of
                    Left err -> liftEff do
                      log "No Cy graph source!"
                      log err
                    Right gs -> liftEff do
                      log $ unsafeStringify gs
                      subscribeCyEvents gs cy busFromCy

                  case cyGraphSink of
                      Left err -> liftEff $ log "No Cy.js TrackSink!"
                      Right ts -> forkTrackSink ts cy busFromBD *> pure unit

                  pure Nothing
                _ -> pure $ Just unit

              liftEff $ log "creating Cy.js"
              io.query $ H.action (CreateCy $ _.elementsUri <<< unwrap $ head)
              liftEff $ log "created cy!"


Update Data.Array.ST docs

Update Data.Array.ST docs

- Fix deprecated syntax [a] for Array a
- Add a missing full stop

-- | Helper functions for working with mutable arrays using the `ST` effect.
-- |
-- | This module can be used when performance is important and mutation is a local effect.

module Data.Array.ST
  ( STArray(..)
  , Assoc()
  , runSTArray
  , emptySTArray
  , peekSTArray
  , pokeSTArray
  , pushSTArray
  , pushAllSTArray
  , spliceSTArray
  , freeze, thaw
  , toAssocArray
  ) where

import Prelude

import Control.Monad.Eff (Eff())
import Control.Monad.ST (ST())

import Data.Maybe (Maybe(..))

-- | A reference to a mutable array.
-- |
-- | The first type parameter represents the memory region which the array belongs to.
-- | The second type parameter defines the type of elements of the mutable array.
-- |
-- | The runtime representation of a value of type `STArray h a` is the same as that of `Array a`,
-- | except that mutation is allowed.
foreign import data STArray :: * -> * -> *

-- | An element and its index.
type Assoc a = { value :: a, index :: Int }

-- | Freeze a mutable array, creating an immutable array. Use this function as you would use
-- | `runST` to freeze a mutable reference.
-- |
-- | The rank-2 type prevents the reference from escaping the scope of `runSTArray`.
foreign import runSTArray :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r (Array a)

-- | Create an empty mutable array.
foreign import emptySTArray :: forall a h r. Eff (st :: ST h | r) (STArray h a)

-- | Create a mutable copy of an immutable array.
thaw :: forall a h r. Array a -> Eff (st :: ST h | r) (STArray h a)
thaw = copyImpl

-- | Create an immutable copy of a mutable array.
freeze :: forall a h r. STArray h a -> Eff (st :: ST h | r) (Array a)
freeze = copyImpl

foreign import copyImpl :: forall a b h r. a -> Eff (st :: ST h | r) b

-- | Read the value at the specified index in a mutable array.
peekSTArray :: forall a h r. STArray h a -> Int -> Eff (st :: ST h | r) (Maybe a)
peekSTArray = peekSTArrayImpl Just Nothing

foreign import peekSTArrayImpl :: forall a h e r. (a -> r) -> r -> (STArray h a) -> Int -> (Eff (st :: ST h | e) r)

-- | Change the value at the specified index in a mutable array.
foreign import pokeSTArray :: forall a h r. STArray h a -> Int -> a -> Eff (st :: ST h | r) Boolean

-- | Append an element to the end of a mutable array.
pushSTArray :: forall a h r. STArray h a -> a -> Eff (st :: ST h | r) Int
pushSTArray arr a = pushAllSTArray arr [a]

-- | Append the values in an immutable array to the end of a mutable array.
foreign import pushAllSTArray :: forall a h r. STArray h a -> Array a -> Eff (st :: ST h | r) Int

-- | Remove and/or insert elements from/into a mutable array at the specified index.
foreign import spliceSTArray :: forall a h r. STArray h a -> Int -> Int -> Array a -> Eff (st :: ST h | r) (Array a)

-- | Create an immutable copy of a mutable array, where each element
-- | is labelled with its index in the original array.
foreign import toAssocArray :: forall a h r. STArray h a -> Eff (st :: ST h | r) (Array (Assoc a))

-- | Helper functions for working with mutable arrays using the `ST` effect.
-- |
-- | This module can be used when performance is important and mutation is a local effect.

module Data.Array.ST
  ( STArray(..)
  , Assoc()
  , runSTArray
  , emptySTArray
  , peekSTArray
  , pokeSTArray
  , pushSTArray
  , pushAllSTArray
  , spliceSTArray
  , freeze, thaw
  , toAssocArray
  ) where

import Prelude

import Control.Monad.Eff (Eff())
import Control.Monad.ST (ST())

import Data.Maybe (Maybe(..))

-- | A reference to a mutable array.
-- |
-- | The first type parameter represents the memory region which the array belongs to.
-- | The second type parameter defines the type of elements of the mutable array.
-- |
-- | The runtime representation of a value of type `STArray h a` is the same as that of `[a]`,
-- | except that mutation is allowed.
foreign import data STArray :: * -> * -> *

-- | An element and its index
type Assoc a = { value :: a, index :: Int }

-- | Freeze a mutable array, creating an immutable array. Use this function as you would use
-- | `runST` to freeze a mutable reference.
-- |
-- | The rank-2 type prevents the reference from escaping the scope of `runSTArray`.
foreign import runSTArray :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r (Array a)

-- | Create an empty mutable array.
foreign import emptySTArray :: forall a h r. Eff (st :: ST h | r) (STArray h a)

-- | Create a mutable copy of an immutable array.
thaw :: forall a h r. Array a -> Eff (st :: ST h | r) (STArray h a)
thaw = copyImpl

-- | Create an immutable copy of a mutable array.
freeze :: forall a h r. STArray h a -> Eff (st :: ST h | r) (Array a)
freeze = copyImpl

foreign import copyImpl :: forall a b h r. a -> Eff (st :: ST h | r) b

-- | Read the value at the specified index in a mutable array.
peekSTArray :: forall a h r. STArray h a -> Int -> Eff (st :: ST h | r) (Maybe a)
peekSTArray = peekSTArrayImpl Just Nothing

foreign import peekSTArrayImpl :: forall a h e r. (a -> r) -> r -> (STArray h a) -> Int -> (Eff (st :: ST h | e) r)

-- | Change the value at the specified index in a mutable array.
foreign import pokeSTArray :: forall a h r. STArray h a -> Int -> a -> Eff (st :: ST h | r) Boolean

-- | Append an element to the end of a mutable array.
pushSTArray :: forall a h r. STArray h a -> a -> Eff (st :: ST h | r) Int
pushSTArray arr a = pushAllSTArray arr [a]

-- | Append the values in an immutable array to the end of a mutable array.
foreign import pushAllSTArray :: forall a h r. STArray h a -> Array a -> Eff (st :: ST h | r) Int

-- | Remove and/or insert elements from/into a mutable array at the specified index.
foreign import spliceSTArray :: forall a h r. STArray h a -> Int -> Int -> Array a -> Eff (st :: ST h | r) (Array a)

-- | Create an immutable copy of a mutable array, where each element
-- | is labelled with its index in the original array.
foreign import toAssocArray :: forall a h r. STArray h a -> Eff (st :: ST h | r) (Array (Assoc a))


double oops

double oops

module Data.Dom.Simple.Element where

import Control.Monad.Eff

foreign import data DOM :: !
foreign import data HTMLElement :: *
foreign import data HTMLWindow :: *

foreign import globalWindow
  "var globalWindow = window;" :: HTMLWindow

foreign import getDocument
  "function getDocument(win) { \
  \  return function () {      \
  \    return win.document;    \
  \  };                        \
  \}" :: forall eff. HTMLWindow -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import getElementById
  "function getElementById(targ_id) {         \
  \  return function (src) {                  \
  \    return function () {                   \
  \      return src.getElementById(targ_id);  \
  \    };                                     \
  \  };                                       \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import getElementsByClassName
  "function getElementsByClassName(targ_id) {         \
  \  return function (src) {                          \
  \    return function () {                           \
  \      return src.getElementsByClassName(targ_id);  \
  \    };                                             \
  \  }                                                \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import getElementsByName
  "function getElementsByName(targ_id) {            \
  \  return function (src) {                        \
  \    return function () {                         \
  \      return src.getElementsByName(targ_id);     \
  \    };                                           \
  \  };                                             \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import querySelector
  "function querySelector(selector) {         \
  \  return function (src) {                  \
  \    return function () {                   \
  \      return src.querySelector(selector);  \
  \    };                                     \
  \  };                                       \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import querySelectorAll
  "function querySelectorAll(selector) {        \
  \  return function (src) {                    \
  \    return function () {                     \
  \      return src.querySelectorAll(selector); \
  \    };                                       \
  \  };                                         \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import getAttribute
  "function getAttribute(name) {            \
  \  return function (src) {                \
  \    return function () {                 \
  \      return src.getAttribute(name);     \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) String)

foreign import setAttribute
  "function setAttribute(name) {            \
  \  return function (value) {              \
  \    return function (src) {              \
  \      return function () {               \
  \        src.getAttribute(name);          \
  \      };                                 \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff. String -> String -> HTMLElement -> (Eff (dom :: DOM | eff) Unit)

foreign import hasAttribute
  "function hasAttribute(name) {            \
  \  return function (src) {                \
  \    return function () {                 \
  \      return src.hasAttribute(name);     \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) Boolean)

foreign import innerHTML
  "function innerHTML(src) {                \
  \  return function () {                   \
  \    return src.innerHTML;                \
  \  };                                     \
  \}" :: forall eff. HTMLElement -> (Eff (dom :: DOM | eff) String)

foreign import setInnerHTML
  "function setInnerHTML(value) {           \
  \  return function (src) {                \
  \    return function () {                 \
  \      src.innerHTML = value;             \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) Unit)

foreign import innerText
  "function innerText(src) {                \
  \  return function () {                   \
  \    return src.innerText;                \
  \  };                                     \
  \}" :: forall eff. HTMLElement -> (Eff (dom :: DOM | eff) String)

foreign import setInnerText
  "function setInnerText(value) {           \
  \  return function (src) {                \
  \    return function () {                 \
  \      src.innerText = value;             \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) Unit)

foreign import contentWindow
  "function contentWindow(obj) {  \
  \  return function () {         \
  \    return obj.contentWindow;  \
  \  };                           \
  \}" :: forall eff. HTMLElement -> (Eff (dom :: DOM | eff) HTMLWindow)

module Data.Dom.Simple.Element where

import Control.Monad.Eff

foreign import data DOM :: !
foreign import data HTMLElement :: *
foreign import data HTMLWindow :: *

foreign import globalWindow
  "globalWindow = return window;" :: HTMLWindow

foreign import getDocument
  "function getDocument(win) { \
  \  return function () {      \
  \    return win.document;    \
  \  };                        \
  \}" :: forall eff. HTMLWindow -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import getElementById
  "function getElementById(targ_id) {         \
  \  return function (src) {                  \
  \    return function () {                   \
  \      return src.getElementById(targ_id);  \
  \    };                                     \
  \  };                                       \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import getElementsByClassName
  "function getElementsByClassName(targ_id) {         \
  \  return function (src) {                          \
  \    return function () {                           \
  \      return src.getElementsByClassName(targ_id);  \
  \    };                                             \
  \  }                                                \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import getElementsByName
  "function getElementsByName(targ_id) {            \
  \  return function (src) {                        \
  \    return function () {                         \
  \      return src.getElementsByName(targ_id);     \
  \    };                                           \
  \  };                                             \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import querySelector
  "function querySelector(selector) {         \
  \  return function (src) {                  \
  \    return function () {                   \
  \      return src.querySelector(selector);  \
  \    };                                     \
  \  };                                       \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import querySelectorAll
  "function querySelectorAll(selector) {        \
  \  return function (src) {                    \
  \    return function () {                     \
  \      return src.querySelectorAll(selector); \
  \    };                                       \
  \  };                                         \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import getAttribute
  "function getAttribute(name) {            \
  \  return function (src) {                \
  \    return function () {                 \
  \      return src.getAttribute(name);     \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) String)

foreign import setAttribute
  "function setAttribute(name) {            \
  \  return function (value) {              \
  \    return function (src) {              \
  \      return function () {               \
  \        src.getAttribute(name);          \
  \      };                                 \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff. String -> String -> HTMLElement -> (Eff (dom :: DOM | eff) Unit)

foreign import hasAttribute
  "function hasAttribute(name) {            \
  \  return function (src) {                \
  \    return function () {                 \
  \      return src.hasAttribute(name);     \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) Boolean)

foreign import innerHTML
  "function innerHTML(src) {                \
  \  return function () {                   \
  \    return src.innerHTML;                \
  \  };                                     \
  \}" :: forall eff. HTMLElement -> (Eff (dom :: DOM | eff) String)

foreign import setInnerHTML
  "function setInnerHTML(value) {           \
  \  return function (src) {                \
  \    return function () {                 \
  \      src.innerHTML = value;             \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) Unit)

foreign import innerText
  "function innerText(src) {                \
  \  return function () {                   \
  \    return src.innerText;                \
  \  };                                     \
  \}" :: forall eff. HTMLElement -> (Eff (dom :: DOM | eff) String)

foreign import setInnerText
  "function setInnerText(value) {           \
  \  return function (src) {                \
  \    return function () {                 \
  \      src.innerText = value;             \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff. String -> HTMLElement -> (Eff (dom :: DOM | eff) Unit)

foreign import contentWindow
  "function contentWindow(obj) {  \
  \  return function () {         \
  \    return obj.contentWindow;  \
  \  };                           \
  \}" :: forall eff. HTMLElement -> (Eff (dom :: DOM | eff) HTMLWindow)


Refactor

Refactor

module IdePurescript.Atom.Main where

import Prelude
import Control.Promise as Promise
import Data.StrMap as StrMap
import IdePurescript.Atom.Completion as C
import IdePurescript.Atom.Psci as Psci
import PscIde as P
import Atom.Atom (getAtom)
import Atom.CommandRegistry (COMMAND, addCommand)
import Atom.Config (CONFIG, getConfig)
import Atom.Editor (EDITOR, TextEditor, toEditor, onDidSave, getPath, getText, getTextInRange)
import Atom.Grammar (GRAMMAR)
import Atom.NotificationManager (NOTIFY, addError)
import Atom.Pane (PANE)
import Atom.Point (Point, getRow, mkPoint)
import Atom.Project (PROJECT)
import Atom.Range (mkRange)
import Atom.Workspace (WORKSPACE, onDidChangeActivePaneItem, observeTextEditors, getActiveTextEditor)
import Control.Monad.Aff (runAff, Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log, error)
import Control.Monad.Eff.Exception (Error, EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Ref (modifyRef, REF, Ref, readRef, writeRef, newRef)
import Control.Monad.Error.Class (catchError)
import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
import Control.Promise (Promise)
import DOM (DOM)
import DOM.Node.Types (Element)
import Data.Array (length)
import Data.Either (either)
import Data.Foreign (Foreign, readBoolean, toForeign)
import Data.Function.Eff (mkEffFn1)
import Data.Maybe (maybe, Maybe(Just, Nothing))
import Data.StrMap (lookup, empty)
import Data.String (contains)
import Data.Traversable (sequence)
import IdePurescript.Atom.Assist (fixTypo, addClause, caseSplit)
import IdePurescript.Atom.Build (AtomLintMessage)
import IdePurescript.Atom.BuildStatus (getBuildStatus)
import IdePurescript.Atom.Config (config)
import IdePurescript.Atom.Hooks.Dependencies (installDependencies)
import IdePurescript.Atom.Hooks.Linter (LinterInternal, LinterIndie, LINTER, register)
import IdePurescript.Atom.Hooks.StatusBar (addLeftTile)
import IdePurescript.Atom.Imports (addSuggestionImport, addExplicitImportCmd, addModuleImportCmd)
import IdePurescript.Atom.LinterBuild (getRoot, lint)
import IdePurescript.Atom.PscIdeServer (startServer)
import IdePurescript.Atom.QuickFixes (showQuickFixes)
import IdePurescript.Atom.Search (localSearch, pursuitSearchModule, pursuitSearch)
import IdePurescript.Atom.Tooltips (registerTooltips)
import IdePurescript.Modules (State, getQualModule, initialModulesState, getModulesForFile, getMainModule, getUnqualActiveModules)
import IdePurescript.PscIde (loadDeps, getLoadedModules)
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS)
import Node.FS (FS)
import Node.Process (PROCESS)
import PscIde (NET)

getSuggestions :: forall eff. Int -> State -> { editor :: TextEditor, bufferPosition :: Point, activatedManually :: Boolean }
  -> Eff (editor :: EDITOR, net :: NET, note :: NOTIFY, config :: CONFIG | eff) (Promise (Array C.AtomSuggestion))
getSuggestions port state ({editor, bufferPosition, activatedManually}) = Promise.fromAff $ flip catchError (raiseError' []) $ do
  let range = mkRange (mkPoint (getRow bufferPosition) 0) bufferPosition
  line <- liftEff'' $ getTextInRange editor range
  atom <- liftEff'' getAtom
  configRaw <- liftEff'' $ getConfig atom.config "ide-purescript.autocomplete.allModules"
  let autoCompleteAllModules = either (const false) id $ readBoolean configRaw
  modules <- if activatedManually || autoCompleteAllModules then getLoadedModules port else pure $ getUnqualActiveModules state Nothing
  let getQualifiedModule = (flip getQualModule) state
  C.getSuggestions port { line, moduleInfo: { modules, getQualifiedModule, mainModule: state.main }}
  where
  raiseError' :: (Array C.AtomSuggestion) -> Error -> Aff (editor :: EDITOR, net :: NET, note :: NOTIFY, config :: CONFIG | eff) (Array C.AtomSuggestion)
  raiseError' x e = do
    liftEff $ raiseError e
    pure x
  liftEff'' :: forall a. Eff (editor :: EDITOR, net :: NET, note :: NOTIFY, config :: CONFIG | eff) a -> Aff (editor :: EDITOR, net :: NET, note :: NOTIFY, config :: CONFIG | eff) a
  liftEff'' = liftEff

useEditor :: forall eff. Int -> (Ref State) -> TextEditor
  -> Eff (editor ::EDITOR, net :: NET, ref :: REF, console :: CONSOLE, config :: CONFIG | eff) Unit
useEditor port modulesStateRef editor = do
  path <- getPath editor
  text <- getText editor
  let mainModule = getMainModule text
  case path, mainModule of
    Just path', Just m -> void $ runAff logError ignoreError $ do
      -- We load all deps initially, but only post 0.8.4, and maybe something resets psc-ide state
      loadDeps port m
      state <- getModulesForFile port path' text
      liftEff $ writeRef modulesStateRef state
      pure unit
    _, _ -> pure unit

useEditor' :: forall eff. (Ref State) -> Maybe Int -> Maybe TextEditor
  -> Eff (editor ::EDITOR, net :: NET, ref :: REF, console :: CONSOLE, config :: CONFIG | eff) Unit
useEditor' modulesStateRef port editor = do
  case port, editor of
    Just port', Just editor' -> useEditor port' modulesStateRef editor'
    _, _ -> pure unit

type MainEff =
  ( command :: COMMAND
  , note :: NOTIFY
  , project :: PROJECT
  , fs :: FS
  , buffer :: BUFFER
  , ref :: REF
  , cp :: CHILD_PROCESS
  , process :: PROCESS
  , console :: CONSOLE
  , config :: CONFIG
  , linter :: LINTER
  , editor :: EDITOR
  , net :: NET
  , workspace :: WORKSPACE
  , pane :: PANE
  , avar :: AVAR
  , err :: EXCEPTION
  , dom :: DOM
  , grammar :: GRAMMAR
  , random :: RANDOM
  )

main :: Eff MainEff Foreign
main = do
  atom <- getAtom
  linterIndieRef <- newRef (Nothing :: Maybe LinterIndie)
  modulesState <- newRef (initialModulesState)
  messagesRef <- newRef ([] :: Array AtomLintMessage)
  linterInternalRef <- newRef (Nothing :: Maybe LinterInternal)
  buildStatusRef <- newRef (Nothing :: Maybe Element)

  startedRef <- newRef (false :: Boolean)
  serversRef <- newRef (empty :: StrMap.StrMap { port :: Int, quit :: Eff MainEff Unit })

  let
    getPort :: String -> Eff MainEff (Maybe { root :: String, port :: Int })
    getPort file = runMaybeT $ do
      servers <- liftEff $ readRef serversRef
      root <- MaybeT $ getRoot file
      { port } <- MaybeT $ pure $ lookup root servers
      pure { root, port }

    doLint :: (Maybe String) -> Eff MainEff Unit
    doLint file = do
      linterIndie <- readRef linterIndieRef
      statusElt <- readRef buildStatusRef
      portRes <- maybe (pure Nothing) getPort file
      case portRes, linterIndie, statusElt of
        -- TODO if no psc-ide port, should still be able to do FULL build
        Just { port, root }, Just linterIndie', Just statusElt' -> void $ runAff raiseError ignoreError $ do
          messages <- lint (Just port) file atom.config root linterIndie' statusElt'
          liftEff $ maybe (pure unit) (writeRef messagesRef) messages
          P.load port [] []
          editor <- liftEff $ getActiveTextEditor atom.workspace
          liftEff $ useEditor' modulesState (Just port) editor
        _, _, _ -> pure unit

    quickFix :: Eff MainEff Unit
    quickFix = do
      messages <- readRef messagesRef
      editor <- getActiveTextEditor atom.workspace
      linter <- readRef linterInternalRef
      case { editor, linter, n: length messages } of
        { editor: Just e, linter: Just l, n } | n > 0 -> withPort \port -> showQuickFixes port modulesState e l messages
        _ -> pure unit

    restartPscIdeServer :: Eff MainEff Unit
    restartPscIdeServer = do
      deactivate
      startPscIdeServer

    startPscIdeServer :: Eff MainEff Unit
    startPscIdeServer = void $ runMaybeT do
      ed <- MaybeT $ getActiveTextEditor atom.workspace
      path <- MaybeT $ getPath ed
      liftEff $ log $ "Starting psc-ide-server for path: " <> path
      liftEff $ void $ runAff
                (\_ -> log "Error starting server")
                ignoreError
                (startPscIdeServer' path)

    startPscIdeServer' :: String -> Aff MainEff Unit
    startPscIdeServer' path = do
      root' <- liftEff $ getRoot path
      case root' of
        Nothing -> pure unit
        Just root -> do
          { port, quit } <- startServer root
          maybe (pure unit) (\p -> void $ P.load p [] []) port
          liftEff $ do
            editor <- getActiveTextEditor atom.workspace
            useEditor' modulesState port editor
            registerTooltips getPortActiveEditor modulesState
            case port of
              Nothing -> pure unit
              Just port' -> modifyRef serversRef $ StrMap.insert root { port: port', quit}

    getPortActiveEditor :: Eff MainEff (Maybe Int)
    getPortActiveEditor = runMaybeT do
      editor <- MaybeT $ getActiveTextEditor atom.workspace
      file <- MaybeT $ getPath editor
      _.port <$> (MaybeT $ getPort file)

    withPortDef :: forall a. Eff MainEff a -> (Int -> Eff MainEff a) -> Eff MainEff a
    withPortDef def e = getPortActiveEditor >>= maybe def e

    withPort :: (Int -> Eff MainEff Unit) -> Eff MainEff Unit
    withPort = withPortDef (pure unit)

    activate :: Eff MainEff Unit
    activate = do
      let cmd name action = addCommand atom.commands "atom-workspace" ("purescript:"<>name) (const action)
      cmd "build" $ doLint Nothing
      cmd "show-quick-fixes" quickFix
      cmd "pursuit-search" $ withPort pursuitSearch
      cmd "pursuit-search-modules" $ withPort $ \port -> pursuitSearchModule port modulesState
      cmd "add-module-import" $ withPort $ \port -> addModuleImportCmd port modulesState
      cmd "add-explicit-import" $ withPort $ \port -> addExplicitImportCmd port modulesState
      cmd "search" $  withPort $ \port -> localSearch port modulesState
      cmd "case-split" $ withPort caseSplit
      cmd "add-clause" $ withPort addClause
      cmd "fix-typo" $ withPort $ fixTypo modulesState
      cmd "restart-psc-ide" $ restartPscIdeServer

      installDependencies

      observeTextEditors atom.workspace (\editor -> do
        path <- getPath editor
        case path of
          Just path' | contains ".purs" path' -> do
            onDidSave editor (\_ -> do
              buildOnSave <- getConfig atom.config "ide-purescript.buildOnSave"
              let buildOnSaveEnabled = either (const false) id $ readBoolean buildOnSave
              when buildOnSaveEnabled (doLint path)
            )
          _ -> pure unit
      )

      onDidChangeActivePaneItem atom.workspace (\item -> void $ runMaybeT do
        editor <- MaybeT $ pure $ toEditor item
        path <- MaybeT $ getPath editor
        port <- liftEff $ getPort path
        liftEff $ case port of
          Just { port: port' } -> do
            log $ "Switching to editor for file: " <> path
            useEditor' modulesState (Just port') (toEditor item)
          Nothing -> startPscIdeServer
      )

      startPscIdeServer
      Psci.activate
      writeRef startedRef true

    deactivate :: Eff MainEff Unit
    deactivate = do
      servers <- readRef serversRef
      sequence $ _.quit <$> StrMap.values servers
      writeRef serversRef empty

  pure $ toForeign
    { config
    , activate: mkEffFn1 \_ -> activate
    , deactivate: mkEffFn1 \_ -> deactivate
    , consumeLinterIndie: mkEffFn1 \registry -> do
        linterIndie <- register registry {name: "PureScript"}
        writeRef linterIndieRef $ Just linterIndie
    , consumeLinterInternal: mkEffFn1 \linter ->
        writeRef linterInternalRef $ Just linter
    , consumeStatusBar: mkEffFn1 \statusBar -> do
        item <- getBuildStatus
        writeRef buildStatusRef $ Just item
        addLeftTile statusBar { item, priority: -50 }
    , provideAutocomplete: \_ ->
        { selector: ".source.purescript"
        , disableForSelector: ".source.purescript .comment, .source.purescript .string"
        , inclusionPriority: 1
        , excludeLowerPriority: true
        , getSuggestions: mkEffFn1 $ \x -> do
            state <- readRef modulesState
            withPortDef (Promise.fromAff $ pure []) (\p -> getSuggestions p state x)
        , onDidInsertSuggestion: mkEffFn1 \x -> do
            shouldAddImport <- either (const false) id <$> readBoolean <$> getConfig atom.config "ide-purescript.autocomplete.addImport"
            withPort \port ->
              when shouldAddImport (void $ runAff raiseError ignoreError $ addSuggestionImport port modulesState x)
        }
    }

raiseError :: forall eff. Error -> Eff (note :: NOTIFY | eff) Unit
raiseError e = do
  atom <- getAtom
  addError atom.notifications (show e)

ignoreError :: forall a eff. a -> Eff eff Unit
ignoreError _ = pure unit

logError :: forall eff. Error -> Eff (console :: CONSOLE | eff) Unit
logError e = error $ show e

module IdePurescript.Atom.Main where

import Prelude
import Control.Promise as Promise
import Data.StrMap as StrMap
import IdePurescript.Atom.Completion as C
import IdePurescript.Atom.Psci as Psci
import PscIde as P
import Atom.Atom (getAtom)
import Atom.CommandRegistry (COMMAND, addCommand)
import Atom.Config (CONFIG, getConfig)
import Atom.Editor (EDITOR, TextEditor, toEditor, onDidSave, getPath, getText, getTextInRange)
import Atom.Grammar (GRAMMAR)
import Atom.NotificationManager (NOTIFY, addError)
import Atom.Pane (PANE)
import Atom.Point (Point, getRow, mkPoint)
import Atom.Project (PROJECT)
import Atom.Range (mkRange)
import Atom.Workspace (WORKSPACE, onDidChangeActivePaneItem, observeTextEditors, getActiveTextEditor)
import Control.Monad.Aff (runAff, Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log, error)
import Control.Monad.Eff.Exception (Error, EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Ref (modifyRef, REF, Ref, readRef, writeRef, newRef)
import Control.Monad.Error.Class (catchError)
import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
import Control.Promise (Promise)
import DOM (DOM)
import DOM.Node.Types (Element)
import Data.Array (length)
import Data.Either (either)
import Data.Foreign (Foreign, readBoolean, toForeign)
import Data.Function.Eff (mkEffFn1)
import Data.Maybe (maybe, Maybe(Just, Nothing))
import Data.StrMap (lookup, empty)
import Data.String (contains)
import Data.Traversable (sequence)
import IdePurescript.Atom.Assist (fixTypo, addClause, caseSplit)
import IdePurescript.Atom.Build (AtomLintMessage)
import IdePurescript.Atom.BuildStatus (getBuildStatus)
import IdePurescript.Atom.Config (config)
import IdePurescript.Atom.Hooks.Dependencies (installDependencies)
import IdePurescript.Atom.Hooks.Linter (LinterInternal, LinterIndie, LINTER, register)
import IdePurescript.Atom.Hooks.StatusBar (addLeftTile)
import IdePurescript.Atom.Imports (addSuggestionImport, addExplicitImportCmd, addModuleImportCmd)
import IdePurescript.Atom.LinterBuild (getRoot, lint)
import IdePurescript.Atom.PscIdeServer (startServer)
import IdePurescript.Atom.QuickFixes (showQuickFixes)
import IdePurescript.Atom.Search (localSearch, pursuitSearchModule, pursuitSearch)
import IdePurescript.Atom.Tooltips (registerTooltips)
import IdePurescript.Modules (State, getQualModule, initialModulesState, getModulesForFile, getMainModule, getUnqualActiveModules)
import IdePurescript.PscIde (loadDeps, getLoadedModules)
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS)
import Node.FS (FS)
import Node.Process (PROCESS)
import PscIde (NET)

getSuggestions :: forall eff. Int -> State -> { editor :: TextEditor, bufferPosition :: Point, activatedManually :: Boolean }
  -> Eff (editor :: EDITOR, net :: NET, note :: NOTIFY, config :: CONFIG | eff) (Promise (Array C.AtomSuggestion))
getSuggestions port state ({editor, bufferPosition, activatedManually}) = Promise.fromAff $ flip catchError (raiseError' []) $ do
  let range = mkRange (mkPoint (getRow bufferPosition) 0) bufferPosition
  line <- liftEff'' $ getTextInRange editor range
  atom <- liftEff'' getAtom
  configRaw <- liftEff'' $ getConfig atom.config "ide-purescript.autocomplete.allModules"
  let autoCompleteAllModules = either (const false) id $ readBoolean configRaw
  modules <- if activatedManually || autoCompleteAllModules then getLoadedModules port else pure $ getUnqualActiveModules state Nothing
  let getQualifiedModule = (flip getQualModule) state
  C.getSuggestions port { line, moduleInfo: { modules, getQualifiedModule, mainModule: state.main }}
  where
  raiseError' :: (Array C.AtomSuggestion) -> Error -> Aff (editor :: EDITOR, net :: NET, note :: NOTIFY, config :: CONFIG | eff) (Array C.AtomSuggestion)
  raiseError' x e = do
    liftEff $ raiseError e
    pure x
  liftEff'' :: forall a. Eff (editor :: EDITOR, net :: NET, note :: NOTIFY, config :: CONFIG | eff) a -> Aff (editor :: EDITOR, net :: NET, note :: NOTIFY, config :: CONFIG | eff) a
  liftEff'' = liftEff

useEditor :: forall eff. Int -> (Ref State) -> TextEditor
  -> Eff (editor ::EDITOR, net :: NET, ref :: REF, console :: CONSOLE, config :: CONFIG | eff) Unit
useEditor port modulesStateRef editor = do
  path <- getPath editor
  text <- getText editor
  let mainModule = getMainModule text
  case path, mainModule of
    Just path', Just m -> void $ runAff logError ignoreError $ do
      -- We load all deps initially, but only post 0.8.4, and maybe something resets psc-ide state
      loadDeps port m
      state <- getModulesForFile port path' text
      liftEff $ writeRef modulesStateRef state
      pure unit
    _, _ -> pure unit

useEditor' :: forall eff. (Ref State) -> Maybe Int -> Maybe TextEditor
  -> Eff (editor ::EDITOR, net :: NET, ref :: REF, console :: CONSOLE, config :: CONFIG | eff) Unit
useEditor' modulesStateRef port editor = do
  case port, editor of
    Just port', Just editor' -> useEditor port' modulesStateRef editor'
    _, _ -> pure unit

type MainEff =
  ( command :: COMMAND
  , note :: NOTIFY
  , project :: PROJECT
  , fs :: FS
  , buffer :: BUFFER
  , ref :: REF
  , cp :: CHILD_PROCESS
  , process :: PROCESS
  , console :: CONSOLE
  , config :: CONFIG
  , linter :: LINTER
  , editor :: EDITOR
  , net :: NET
  , workspace :: WORKSPACE
  , pane :: PANE
  , avar :: AVAR
  , err :: EXCEPTION
  , dom :: DOM
  , grammar :: GRAMMAR
  , random :: RANDOM
  )

main :: Eff MainEff Foreign
main = do
  atom <- getAtom
  linterIndieRef <- newRef (Nothing :: Maybe LinterIndie)
  modulesState <- newRef (initialModulesState)
  messagesRef <- newRef ([] :: Array AtomLintMessage)
  linterInternalRef <- newRef (Nothing :: Maybe LinterInternal)
  buildStatusRef <- newRef (Nothing :: Maybe Element)

  startedRef <- newRef (false :: Boolean)
  serversRef <- newRef (empty :: StrMap.StrMap { port :: Int, quit :: Eff MainEff Unit })

  let

    getPort :: String -> Eff MainEff (Maybe { root :: String, port :: Int })
    getPort file = do
      servers <- readRef serversRef
      root <- getRoot file
      pure $ case root of
        Just root' ->
          case lookup root' servers of
            Just { port } -> Just { port, root: root' }
            Nothing -> Nothing
        Nothing -> Nothing

    doLint :: (Maybe String) -> Eff MainEff Unit
    doLint file = do
      linterIndie <- readRef linterIndieRef
      statusElt <- readRef buildStatusRef
      portRes <- maybe (pure Nothing) getPort file
      case portRes, linterIndie, statusElt of
        -- TODO if no psc-ide port, should still be able to do FULL build
        Just { port, root }, Just linterIndie', Just statusElt' -> void $ runAff raiseError ignoreError $ do
          messages <- lint (Just port) file atom.config root linterIndie' statusElt'
          liftEff $ maybe (pure unit) (writeRef messagesRef) messages
          P.load port [] []
          editor <- liftEff $ getActiveTextEditor atom.workspace
          liftEff $ useEditor' modulesState (Just port) editor
        _, _, _ -> pure unit

    quickFix :: Eff MainEff Unit
    quickFix = do
      messages <- readRef messagesRef
      editor <- getActiveTextEditor atom.workspace
      linter <- readRef linterInternalRef
      case { editor, linter, n: length messages } of
        { editor: Just e, linter: Just l, n } | n > 0 -> withPort \port -> showQuickFixes port modulesState e l messages
        _ -> pure unit

    restartPscIdeServer :: Eff MainEff Unit
    restartPscIdeServer = do
      deactivate
      startPscIdeServer

    startPscIdeServer :: Eff MainEff Unit
    startPscIdeServer = void $ runMaybeT do
      ed <- MaybeT $ getActiveTextEditor atom.workspace
      path <- MaybeT $ getPath ed
      liftEff $ log $ "Starting psc-ide-server for path: " <> path
      liftEff $ void $ runAff
                (\_ -> log "Error starting server")
                ignoreError
                (startPscIdeServer' path)

    startPscIdeServer' :: String -> Aff MainEff Unit
    startPscIdeServer' path = do
      root' <- liftEff $ getRoot path
      case root' of
        Nothing -> pure unit
        Just root -> do
          { port, quit } <- startServer root
          maybe (pure unit) (\p -> void $ P.load p [] []) port
          liftEff $ do
            editor <- getActiveTextEditor atom.workspace
            useEditor' modulesState port editor
            registerTooltips getPortActiveEditor modulesState
            case port of
              Nothing -> pure unit
              Just port' -> modifyRef serversRef $ StrMap.insert root { port: port', quit}

    getPortActiveEditor :: Eff MainEff (Maybe Int)
    getPortActiveEditor = do
      editor <- getActiveTextEditor atom.workspace
      case editor of
        Just ed -> do
          file <- getPath ed
          res <- maybe (pure Nothing) getPort file
          pure (_.port <$> res)
        Nothing -> pure Nothing

    withPortDef :: forall a. Eff MainEff a -> (Int -> Eff MainEff a) -> Eff MainEff a
    withPortDef def e = getPortActiveEditor >>= maybe def e

    withPort :: (Int -> Eff MainEff Unit) -> Eff MainEff Unit
    withPort = withPortDef (pure unit)

    activate :: Eff MainEff Unit
    activate = do
      let cmd name action = addCommand atom.commands "atom-workspace" ("purescript:"<>name) (const action)
      cmd "build" $ doLint Nothing
      cmd "show-quick-fixes" quickFix
      cmd "pursuit-search" $ withPort pursuitSearch
      cmd "pursuit-search-modules" $ withPort $ \port -> pursuitSearchModule port modulesState
      cmd "add-module-import" $ withPort $ \port -> addModuleImportCmd port modulesState
      cmd "add-explicit-import" $ withPort $ \port -> addExplicitImportCmd port modulesState
      cmd "search" $  withPort $ \port -> localSearch port modulesState
      cmd "case-split" $ withPort caseSplit
      cmd "add-clause" $ withPort addClause
      cmd "fix-typo" $ withPort $ fixTypo modulesState
      cmd "restart-psc-ide" $ restartPscIdeServer

      installDependencies

      observeTextEditors atom.workspace (\editor -> do
        path <- getPath editor
        case path of
          Just path' | contains ".purs" path' -> do
            onDidSave editor (\_ -> do
              buildOnSave <- getConfig atom.config "ide-purescript.buildOnSave"
              let buildOnSaveEnabled = either (const false) id $ readBoolean buildOnSave
              when buildOnSaveEnabled (doLint path)
            )
          _ -> pure unit
      )

      onDidChangeActivePaneItem atom.workspace (\item -> void $ runMaybeT do
        editor <- MaybeT $ pure $ toEditor item
        path <- MaybeT $ getPath editor
        port <- liftEff $ getPort path
        liftEff $ case port of
          Just { port: port' } -> do
            log $ "Switching to editor for file: " <> path
            useEditor' modulesState (Just port') (toEditor item)
          Nothing -> startPscIdeServer
      )

      startPscIdeServer
      Psci.activate
      writeRef startedRef true

    deactivate :: Eff MainEff Unit
    deactivate = do
      servers <- readRef serversRef
      sequence $ _.quit <$> StrMap.values servers
      writeRef serversRef empty

  pure $ toForeign
    { config
    , activate: mkEffFn1 \_ -> activate
    , deactivate: mkEffFn1 \_ -> deactivate
    , consumeLinterIndie: mkEffFn1 \registry -> do
        linterIndie <- register registry {name: "PureScript"}
        writeRef linterIndieRef $ Just linterIndie
    , consumeLinterInternal: mkEffFn1 \linter ->
        writeRef linterInternalRef $ Just linter
    , consumeStatusBar: mkEffFn1 \statusBar -> do
        item <- getBuildStatus
        writeRef buildStatusRef $ Just item
        addLeftTile statusBar { item, priority: -50 }
    , provideAutocomplete: \_ ->
        { selector: ".source.purescript"
        , disableForSelector: ".source.purescript .comment, .source.purescript .string"
        , inclusionPriority: 1
        , excludeLowerPriority: true
        , getSuggestions: mkEffFn1 $ \x -> do
            state <- readRef modulesState
            withPortDef (Promise.fromAff $ pure []) (\p -> getSuggestions p state x)
        , onDidInsertSuggestion: mkEffFn1 \x -> do
            shouldAddImport <- either (const false) id <$> readBoolean <$> getConfig atom.config "ide-purescript.autocomplete.addImport"
            withPort \port ->
              when shouldAddImport (void $ runAff raiseError ignoreError $ addSuggestionImport port modulesState x)
        }
    }

raiseError :: forall eff. Error -> Eff (note :: NOTIFY | eff) Unit
raiseError e = do
  atom <- getAtom
  addError atom.notifications (show e)

ignoreError :: forall a eff. a -> Eff eff Unit
ignoreError _ = pure unit

logError :: forall eff. Error -> Eff (console :: CONSOLE | eff) Unit
logError e = error $ show e


Load on DOMContentLoaded instead of full window load

module Halogen.Aff.Util
  ( awaitLoad
  , awaitBody
  , selectElement
  , runHalogenAff
  ) where

import Prelude

import Control.Monad.Aff (Aff, Canceler(..), makeAff, nonCanceler, runAff_)
import Control.Monad.Eff (kind Effect, Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (throwException, error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener, removeEventListener)
import DOM.Event.Types (EventType(..))
import DOM.HTML (window)
import DOM.HTML.Document (ReadyState(..), readyState)
import DOM.HTML.Event.EventTypes (load)
import DOM.HTML.Types (HTMLElement, windowToEventTarget, htmlDocumentToParentNode, readHTMLElement)
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (QuerySelector(..), querySelector)
import Data.Either (Either(..), either)
import Data.Foreign (toForeign)
import Data.Maybe (Maybe(..), maybe)
import Halogen.Aff.Effects (HalogenEffects)

-- | Waits for the document to load.
awaitLoad :: forall eff. Aff (dom :: DOM | eff) Unit
awaitLoad = makeAff \callback -> liftEff do
  rs <- readyState =<< document =<< window
  case rs of
    Loading -> do
      et <- windowToEventTarget <$> window
      let listener = eventListener (\_ -> callback (Right unit))
      addEventListener (EventType "DOMContentLoaded") listener false et
      pure $ Canceler \_ -> liftEff (removeEventListener load listener false et)
    _ -> do
      callback (Right unit)
      pure nonCanceler

-- | Waits for the document to load and then finds the `body` element.
awaitBody :: forall eff. Aff (dom :: DOM | eff) HTMLElement
awaitBody = do
  awaitLoad
  body <- selectElement (QuerySelector "body")
  maybe (throwError (error "Could not find body")) pure body

-- | Tries to find an element in the document.
selectElement
  :: forall eff
   . QuerySelector
  -> Aff (dom :: DOM | eff) (Maybe HTMLElement)
selectElement query = do
  mel <- liftEff $
    ((querySelector query <<< htmlDocumentToParentNode <=< document) =<< window)
  pure case mel of
    Nothing -> Nothing
    Just el -> either (const Nothing) Just $ runExcept $ readHTMLElement (toForeign el)

-- | Runs an `Aff` value of the type commonly used by Halogen components. Any
-- | unhandled errors will be re-thrown as exceptions.
runHalogenAff
  :: forall eff x
   . Aff (HalogenEffects eff) x
  -> Eff (HalogenEffects eff) Unit
runHalogenAff = runAff_ (either throwException (const (pure unit)))

module Halogen.Aff.Util
  ( awaitLoad
  , awaitBody
  , selectElement
  , runHalogenAff
  ) where

import Prelude

import Control.Monad.Aff (Aff, Canceler(..), makeAff, nonCanceler, runAff_)
import Control.Monad.Eff (kind Effect, Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (throwException, error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener, removeEventListener)
import DOM.HTML (window)
import DOM.HTML.Document (ReadyState(..), readyState)
import DOM.HTML.Event.EventTypes (load)
import DOM.HTML.Types (HTMLElement, windowToEventTarget, htmlDocumentToParentNode, readHTMLElement)
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (QuerySelector(..), querySelector)
import Data.Either (Either(..), either)
import Data.Foreign (toForeign)
import Data.Maybe (Maybe(..), maybe)
import Halogen.Aff.Effects (HalogenEffects)

-- | Waits for the document to load.
awaitLoad :: forall eff. Aff (dom :: DOM | eff) Unit
awaitLoad = makeAff \callback -> liftEff do
  rs <- readyState =<< document =<< window
  case rs of
    Complete -> do
      callback (Right unit)
      pure nonCanceler
    _ -> do
      et <- windowToEventTarget <$> window
      let listener = eventListener (\_ -> callback (Right unit))
      addEventListener load listener false et
      pure $ Canceler \_ -> liftEff (removeEventListener load listener false et)

-- | Waits for the document to load and then finds the `body` element.
awaitBody :: forall eff. Aff (dom :: DOM | eff) HTMLElement
awaitBody = do
  awaitLoad
  body <- selectElement (QuerySelector "body")
  maybe (throwError (error "Could not find body")) pure body

-- | Tries to find an element in the document.
selectElement
  :: forall eff
   . QuerySelector
  -> Aff (dom :: DOM | eff) (Maybe HTMLElement)
selectElement query = do
  mel <- liftEff $
    ((querySelector query <<< htmlDocumentToParentNode <=< document) =<< window)
  pure case mel of
    Nothing -> Nothing
    Just el -> either (const Nothing) Just $ runExcept $ readHTMLElement (toForeign el)

-- | Runs an `Aff` value of the type commonly used by Halogen components. Any
-- | unhandled errors will be re-thrown as exceptions.
runHalogenAff
  :: forall eff x
   . Aff (HalogenEffects eff) x
  -> Eff (HalogenEffects eff) Unit
runHalogenAff = runAff_ (either throwException (const (pure unit)))


dropHandlers

dropHandlers

module Halogen.FileDrop
  ( ui
  , initialState
  , defaultOptions
  , Query()
  , setDragOver
  , setFiles
  , openFilePicker
  , State()
  , Options()
  ) where

import Prelude

import Control.Apply
import Control.Monad.Aff (Aff(), runAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console.Unsafe (logAny)
import Control.Monad.Eff.Exception (throwException, EXCEPTION)
import Data.Functor
import Data.Maybe
import Data.Foldable

import Halogen
import Halogen.Util (appendToBody, onLoad)
import Halogen.HTML.Core (prop, propName, attrName)
import Halogen.HTML.Indexed as H
import Halogen.HTML.Events.Indexed.Extra as E
import Halogen.HTML.Events.Handler (preventDefault, stopPropagation, EventHandler) as E
import Halogen.HTML.Properties.Indexed.Extra as P
import Halogen.HTML.CSS.Indexed (style) as P
import Halogen.HTML.Events.Forms.Extra (onFilesChange, onFilesDrop) as E

import DOM (DOM)
import DOM.HTML.Types (htmlElementToEventTarget)
import DOM.Event.EventTarget (dispatchEvent)
import DOM.Event.Types (EventType, MouseEvent, mouseEventToEvent)
import DOM.Event.EventTypes (click) as EventTypes
import DOM.HTML.Types (HTMLElement)
import DOM.File.Types (FileList())

import CSS as CSS

import Unsafe.Coerce (unsafeCoerce)

foreign import newMouseEvent :: EventType -> MouseEvent

data Query a
  = OpenFilePicker a
  | SetFiles FileList a
  | SetUploadElement HTMLElement a
  | SetDragOver Boolean a

setDragOver :: ∀ a. Boolean -> a -> Query a
setDragOver = SetDragOver

setFiles :: ∀ a. FileList -> a -> Query a
setFiles = SetFiles

openFilePicker :: ∀ a. a -> Query a
openFilePicker = OpenFilePicker

type State =
  { uploadElement :: Maybe HTMLElement
  , dragover :: Boolean
  , options :: Options
  }

initialState :: Options -> State
initialState options =
  { uploadElement: Nothing
  , dragover: false
  , options
  }

type Options
  = { view :: { dragover :: Boolean, multiple :: Boolean } -> ComponentHTML Query
    , multiple :: Boolean
    }

defaultOptions :: Options
defaultOptions
  = { view: defaultView
    , multiple: true
    }

defaultView
  :: { dragover :: Boolean, multiple :: Boolean }
  -> ComponentHTML Query
defaultView { multiple, dragover } =
  H.div_
    [ H.button
      [ E.onClick (E.input_ openFilePicker) ]
      [ H.text if multiple
               then "Select a file"
               else "Select some files"
      ]
    , H.div
        dropHandlers
        [ H.text if dragover
                 then "DROP IT!"
                 else "Or just drop it here"
        ]
    ]

dropHandlers :: ∀ r. Array (P.IProp r (Query Unit))
dropHandlers =
  [ E.onDragEnter
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver true)
  , E.onDragOver
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver true)
  , E.onDragExit
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver false)
  , E.onFilesDrop
      \files -> E.preventDefault
             *> E.stopPropagation
             $> action (setFiles files)
  ]

ui :: ∀ m eff. (MonadEff (dom :: DOM, err :: EXCEPTION, console :: CONSOLE | eff) m)
   => Component State Query m
ui = component render eval

render :: ∀ m. State -> ComponentHTML Query
render state =
  H.div_
    [ H.input
      [ P.inputType P.InputFile
      , P.multiple state.options.multiple
      , E.onFilesChange (E.input setFiles)
      , P.initializer (action <<< SetUploadElement)
      , P.style do
          CSS.display CSS.displayNone
      ]
    , state.options.view
        { dragover: state.dragover
        , multiple: state.options.multiple
        }
    ]

eval :: ∀ m eff. (MonadEff (dom :: DOM, err :: EXCEPTION, console :: CONSOLE | eff) m)
     => Natural Query (ComponentDSL State Query m)
eval (OpenFilePicker next) = next <$ do
  gets _.uploadElement
    >>= traverse_
          (htmlElementToEventTarget
             >>> dispatchEvent
                  (mouseEventToEvent (newMouseEvent EventTypes.click))
             >>> liftEff')

eval (SetUploadElement element next) = next <$ do
  modify (_ { uploadElement = Just element })

eval (SetFiles files next) = next <$ do
  liftEff' $ logAny files

eval (SetDragOver dragover next) = next <$ do
  modify (_ { dragover = dragover })

module Halogen.FileDrop
  ( ui
  , initialState
  , defaultOptions
  , Query()
  , setDragOver
  , setFiles
  , openFilePicker
  , State()
  , Options()
  ) where

import Prelude

import Control.Apply
import Control.Monad.Aff (Aff(), runAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console.Unsafe (logAny)
import Control.Monad.Eff.Exception (throwException, EXCEPTION)
import Data.Functor
import Data.Maybe
import Data.Foldable

import Halogen
import Halogen.Util (appendToBody, onLoad)
import Halogen.HTML.Core (prop, propName, attrName)
import Halogen.HTML.Indexed as H
import Halogen.HTML.Events.Indexed.Extra as E
import Halogen.HTML.Events.Handler (preventDefault, stopPropagation, EventHandler) as E
import Halogen.HTML.Properties.Indexed.Extra as P
import Halogen.HTML.CSS.Indexed (style) as P
import Halogen.HTML.Events.Forms.Extra (onFilesChange, onFilesDrop) as E

import DOM (DOM)
import DOM.HTML.Types (htmlElementToEventTarget)
import DOM.Event.EventTarget (dispatchEvent)
import DOM.Event.Types (EventType, MouseEvent, mouseEventToEvent)
import DOM.Event.EventTypes (click) as EventTypes
import DOM.HTML.Types (HTMLElement)
import DOM.File.Types (FileList())

import CSS as CSS

import Unsafe.Coerce (unsafeCoerce)

foreign import newMouseEvent :: EventType -> MouseEvent

data Query a
  = OpenFilePicker a
  | SetFiles FileList a
  | SetUploadElement HTMLElement a
  | SetDragOver Boolean a

setDragOver :: ∀ a. Boolean -> a -> Query a
setDragOver = SetDragOver

setFiles :: ∀ a. FileList -> a -> Query a
setFiles = SetFiles

openFilePicker :: ∀ a. a -> Query a
openFilePicker = OpenFilePicker

type State =
  { uploadElement :: Maybe HTMLElement
  , dragover :: Boolean
  , options :: Options
  }

initialState :: Options -> State
initialState options =
  { uploadElement: Nothing
  , dragover: false
  , options
  }

type Options
  = { view :: { dragover :: Boolean, multiple :: Boolean } -> ComponentHTML Query
    , multiple :: Boolean
    }

defaultOptions :: Options
defaultOptions
  = { view: defaultView
    , multiple: true
    }

defaultView
  :: { dragover :: Boolean, multiple :: Boolean }
  -> ComponentHTML Query
defaultView { multiple, dragover } =
  H.div_
    [ H.button
      [ E.onClick (E.input_ openFilePicker) ]
      [ H.text if multiple
               then "Select a file"
               else "Select some files"
      ]
    , H.div
        [ E.onDragEnter (\_ -> E.preventDefault
                            *> E.stopPropagation
                            $> action (setDragOver true))
        , E.onDragOver (\_ -> E.preventDefault
                           *> E.stopPropagation
                           $> action (setDragOver true))
        , E.onDragExit (\_ -> E.preventDefault
                           *> E.stopPropagation
                           $> action (setDragOver false))
        , E.onFilesDrop (\files -> E.preventDefault
                                *> E.stopPropagation
                                $> action (setFiles files))
        ]
        [ H.text (if dragover
                  then "DROP IT!"
                  else "Or just drop it here") ]
    ]

ui :: ∀ m eff. (MonadEff (dom :: DOM, err :: EXCEPTION, console :: CONSOLE | eff) m)
   => Component State Query m
ui = component render eval

render :: ∀ m. State -> ComponentHTML Query
render state =
  H.div_
    [ H.input
      [ P.inputType P.InputFile
      , P.multiple state.options.multiple
      , E.onFilesChange (E.input setFiles)
      , P.initializer (action <<< SetUploadElement)
      , P.style do
          CSS.display CSS.displayNone
      ]
    , state.options.view
        { dragover: state.dragover
        , multiple: state.options.multiple
        }
    ]

eval :: ∀ m eff. (MonadEff (dom :: DOM, err :: EXCEPTION, console :: CONSOLE | eff) m)
     => Natural Query (ComponentDSL State Query m)
eval (OpenFilePicker next) = next <$ do
  gets _.uploadElement
    >>= traverse_
          (htmlElementToEventTarget
             >>> dispatchEvent
                  (mouseEventToEvent (newMouseEvent EventTypes.click))
             >>> liftEff')

eval (SetUploadElement element next) = next <$ do
  modify (_ { uploadElement = Just element })

eval (SetFiles files next) = next <$ do
  liftEff' $ logAny files

eval (SetDragOver dragover next) = next <$ do
  modify (_ { dragover = dragover })