Fix Feature.Foreign import

Fix Feature.Foreign import

module Genetics.Browser.Feature.Foreign where

import Prelude
import Data.Argonaut as A
import Data.Argonaut (Json, (.?))
import Data.Argonaut.Core (JObject)
import Data.Either (Either(..))
import Data.Foreign (Foreign, F)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap, wrap)
import Genetics.Browser.Units (class HCoordinate, Bp(..), MBp(..), mbp)

-- this assumes a location has the "chr" and "pos" keys...
-- feels like this is actually a job for lenses
parseFeatureLocation :: String -> JObject -> Either String { chr :: String, pos :: Bp }
parseFeatureLocation locKey f = do
  loc <- f .? locKey
  chr <- loc .? "chr"
  pos <- Bp <$> loc .? "pos"
  pure $ { chr, pos }

parseFeatureRange :: { chrKey :: String, xlKey :: String, xrKey :: String}
                  -> JObject
                  -> Either String { chr :: String, xl :: Bp, xr :: Bp }
parseFeatureRange {chrKey, xlKey, xrKey} f = do
  chr <- f .? chrKey
  xl <- Bp <$> f .? xlKey
  xr <- Bp <$> f .? xrKey
  pure { chr, xl, xr }

module Genetics.Browser.Feature.Foreign where

import Prelude
import Data.Argonaut as A
import Data.Argonaut (Json, (.?))
import Data.Argonaut.Core (JObject)
import Data.Either (Either(..))
import Data.Foreign (Foreign, F)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap, wrap)
import Genetics.Browser.Units (class HCoordinate, Bp(..), CoordRange(..), MBp(..), mbp)

-- this assumes a location has the "chr" and "pos" keys...
-- feels like this is actually a job for lenses
parseFeatureLocation :: String -> JObject -> Either String { chr :: String, pos :: Bp }
parseFeatureLocation locKey f = do
  loc <- f .? locKey
  chr <- loc .? "chr"
  pos <- Bp <$> loc .? "pos"
  pure $ { chr, pos }

parseFeatureRange :: { chrKey :: String, xlKey :: String, xrKey :: String}
                  -> JObject
                  -> Either String { chr :: String, xl :: Bp, xr :: Bp }
parseFeatureRange {chrKey, xlKey, xrKey} f = do
  chr <- f .? chrKey
  xl <- Bp <$> f .? xlKey
  xr <- Bp <$> f .? xrKey
  pure { chr, xl, xr }


BD component raises message with Biodalliance instance

module Genetics.Browser.UI.Biodalliance
       where

import Prelude
import Genetics.Browser.Biodalliance as Biodalliance
import Genetics.Browser.UI.Events.Biodalliance as BDEvents
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Control.Monad.Aff (Aff, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import Control.Monad.Rec.Class (forever)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (_Number, _String)
import Data.Argonaut.Core (JObject)
import Data.Either (Either(..))
import Data.Foreign (F)
import Data.Foreign.Class (decode, encode)
import Data.Lens (re, (^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))
import Data.Variant (Variant, default, inj, on)
import Genetics.Browser.Events (Event(..), EventLocation, EventRange, Location, Range, _eventLocation, _eventRange, handleLocation, handleRange)
import Genetics.Browser.Types (BD, Biodalliance)
import Genetics.Browser.Units (Bp, Chr, MBp(MBp), _Bp, _Chr, bp, mbp)
import Global.Unsafe (unsafeStringify)
import Unsafe.Coerce (unsafeCoerce)

type State = { bd :: Maybe Biodalliance
             }

data Query a
  = Scroll Bp a
  | Jump Chr Bp Bp a
  | Initialize (forall eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance) a
  | InitializeCallback (H.SubscribeStatus -> a)
  | EventFromBD JObject (H.SubscribeStatus -> a)

data Message
  = Initialized
  | SendBD Biodalliance

type Effects eff = (avar :: AVAR, bd :: BD, console :: CONSOLE | eff)

data Slot = Slot
derive instance eqBDSlot :: Eq Slot
derive instance ordBDSlot :: Ord Slot

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

  initialState :: State
  initialState = { bd: Nothing }

  render :: State -> H.ComponentHTML Query
  render = const $ HH.div [ HP.ref (H.RefLabel "bd")
                          , HP.id_ "bdDiv"
                          ] []

  eval :: Query ~> H.ComponentDSL State Query Message (Aff (Effects eff))
  eval = case _ of
    Initialize mkBd next -> do
      H.getHTMLElementRef (H.RefLabel "bd") >>= case _ of
        Nothing -> pure unit
        Just el -> do
          bd <- liftEff $ mkBd el

          H.subscribe $ H.eventSource_ (Biodalliance.onInit bd) (H.request InitializeCallback)

          H.subscribe $ H.eventSource (Biodalliance.addFeatureListener bd)
            $ Just <<< H.request <<< EventFromBD
          H.raise $ SendBD bd

          H.modify (_ { bd = Just bd })

      pure next

    Scroll n next -> do
      mbd <- H.gets _.bd
      case mbd of
        Nothing -> pure next
        Just bd -> do
          liftEff $ Biodalliance.scrollView bd n
          pure next

    Jump chr xl xr next -> do
      mbd <- H.gets _.bd
      case mbd of
        Nothing -> pure next
        Just bd -> do
          liftEff $ Biodalliance.setLocation bd chr xl xr
          pure next

    InitializeCallback reply -> do
      H.raise $ Initialized
      pure $ reply H.Listening

    EventFromBD ft reply -> do

      pure $ reply H.Listening

module Genetics.Browser.UI.Biodalliance
       where

import Prelude
import Genetics.Browser.Biodalliance as Biodalliance
import Genetics.Browser.UI.Events.Biodalliance as BDEvents
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Control.Monad.Aff (Aff, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import Control.Monad.Rec.Class (forever)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (_Number, _String)
import Data.Argonaut.Core (JObject)
import Data.Either (Either(..))
import Data.Foreign (F)
import Data.Foreign.Class (decode, encode)
import Data.Lens (re, (^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))
import Data.Variant (Variant, default, inj, on)
import Genetics.Browser.Events (Event(..), EventLocation, EventRange, Location, Range, _eventLocation, _eventRange, handleLocation, handleRange)
import Genetics.Browser.Types (BD, Biodalliance)
import Genetics.Browser.Units (Bp, Chr, MBp(MBp), _Bp, _Chr, bp, mbp)
import Global.Unsafe (unsafeStringify)
import Unsafe.Coerce (unsafeCoerce)

type State = { bd :: Maybe Biodalliance
             }

data Query a
  = Scroll Bp a
  | Jump Chr Bp Bp a
  | Initialize (forall eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance) a
  | AttachHandler (Biodalliance -> Aff (bd :: BD, console :: CONSOLE, avar :: AVAR ) Unit) a
  -- | AttachHandler (forall eff. Biodalliance -> Aff (bd :: BD, console :: CONSOLE, avar :: AVAR | eff) Unit) a
  | InitializeCallback (H.SubscribeStatus -> a)
  | EventFromBD JObject (H.SubscribeStatus -> a)
  -- | RecvEvent (Event r) a

data Message
  = Initialized

type Effects eff = (avar :: AVAR, bd :: BD, console :: CONSOLE | eff)

data Slot = Slot
derive instance eqBDSlot :: Eq Slot
derive instance ordBDSlot :: Ord Slot

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

  initialState :: State
  initialState = { bd: Nothing }

  render :: State -> H.ComponentHTML Query
  render = const $ HH.div [ HP.ref (H.RefLabel "bd")
                          , HP.id_ "bdDiv"
                          ] []

  eval :: Query ~> H.ComponentDSL State Query Message (Aff (Effects eff))
  eval = case _ of
    Initialize mkBd next -> do
      H.getHTMLElementRef (H.RefLabel "bd") >>= case _ of
        Nothing -> pure unit
        Just el -> do
          bd <- liftEff $ mkBd el

          H.subscribe $ H.eventSource_ (Biodalliance.onInit bd) (H.request InitializeCallback)

          H.subscribe $ H.eventSource (Biodalliance.addFeatureListener bd)
            $ Just <<< H.request <<< EventFromBD

          H.modify (_ { bd = Just bd })
      pure next

    AttachHandler h next -> do
      mbd <- H.gets _.bd
      case mbd of
        Nothing -> pure unit
        Just bd -> do
          _ <- liftAff $ forkAff $ unsafeCoerce $ h bd
          pure unit
          -- _ <- forkAff h bd
      pure next

    Scroll n next -> do
      mbd <- H.gets _.bd
      case mbd of
        Nothing -> pure next
        Just bd -> do
          liftEff $ Biodalliance.scrollView bd n
          pure next

    Jump chr xl xr next -> do
      mbd <- H.gets _.bd
      case mbd of
        Nothing -> pure next
        Just bd -> do
          liftEff $ Biodalliance.setLocation bd chr xl xr
          pure next

    InitializeCallback reply -> do
      H.raise $ Initialized
      pure $ reply H.Listening

    EventFromBD ft reply -> do

      -- _ <- createEvent SendEvent ft
      -- let obj = do
      --       chr <- ft ^? ix "chr" <<< _String <<< re _Chr
      --       minPos <- ft ^? ix "min" <<< _Number <<< re _Bp
      --       maxPos <- ft ^? ix "max" <<< _Number <<< re _Bp
      --       pure $ { chr, minPos, maxPos }

      -- case obj of
      --   Nothing -> liftEff $ log "Error when parsing chr, min, max of BD event"
      --   Just o  -> do
      --     liftEff $ log "sending event from BD:"
      --     liftEff $ log $ unsafeStringify o
      --     H.raise $ SendEvent $ Event $ inj _eventRange o

      pure $ reply H.Listening

    -- RecvEvent (Event v) next -> do
    --   mbd <- H.gets _.bd

    --   case mbd of
    --     Nothing -> pure next
    --     Just bd -> do

    --       _ <- handleEvent bd v
          -- (default (pure unit)
          --   # handleLocation (\loc -> do
          --     let minPos = loc.pos - bp (MBp 1.5)
          --         maxPos = loc.pos + bp (MBp 1.5)
          --     liftEff $ Biodalliance.setLocation bd loc.chr (mbp minPos) (mbp maxPos))
          --   # handleRange (\ran -> do
          --     liftEff $ Biodalliance.setLocation bd ran.chr ran.minPos ran.maxPos)
          --   ) v

          -- pure next


Some refactoring

Some refactoring

module Main where

import Prelude
import Data.Either
import Data.Maybe
import App.Layout (Action(..))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error)
import Data.URI.Types (HierarchicalPart(..))

import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Location (pathname)
import DOM.HTML.Window(location)
import Data.URI as U
import Data.Path.Pathy((</>),dir,file,rootDir)
--import Debug.Trace (traceAnyM)

import Pux (App, Config, CoreEffects, fromSimple, renderToDOM, start)
import Pux.Devtool (Action, start) as Pux.Devtool
import Pux.Router (sampleUrl)

import Signal ((~>),Signal)
import Signal.Channel (channel, subscribe, CHANNEL)

import WebSocket(WEBSOCKET)

import App.Layout (Action(..), State, view, update, init)
import App.Routes (match,Route)
import App.StatsSocket as Socket

type AppEffects = (dom :: DOM, ws :: WEBSOCKET)

-- | App configuration
config :: forall eff. State -> Eff (dom :: DOM, channel :: CHANNEL, err :: EXCEPTION, ws :: WEBSOCKET | eff) (Config State Action AppEffects)
config state = do
  -- | Create a signal of URL changes.
  routeSignal <- getRouteSignal
  -- | Create a signal for WebSocket stats data
  socketSignal <- getSocketSignal
  pure
    { initialState: state
    , update: fromSimple update
    , view: view
    , inputs:
        [ routeSignal ~> PageView
        , socketSignal ~> Received ] }

getSocketSignal :: forall eff. Eff (dom :: DOM, err :: EXCEPTION, channel :: CHANNEL, ws :: WEBSOCKET | eff) (Signal Socket.Action)
getSocketSignal = do
  wsUrl <- getWsUrl
  wsInput <- channel Socket.Starting
  statsSig <- Socket.setupWs wsInput wsUrl
  pure $ subscribe wsInput

getRouteSignal :: forall eff. Eff (dom :: DOM | eff) (Signal Route)
getRouteSignal = do
  urlSignal <- sampleUrl
  pure $ urlSignal ~> match

getWsUrl :: forall eff. Eff (dom :: DOM, err :: EXCEPTION | eff) String
getWsUrl = window >>= location >>= pathname >>= convertToWsUrl

convertToWsUrl :: forall eff. String -> Eff (err :: EXCEPTION | eff) String
convertToWsUrl url =
  case U.runParseURI url of
    Right
      (U.URI _
        h@(U.HierarchicalPart auth@(Just _) _ )
       _  _
      ) ->
      let wsScheme = Just (U.URIScheme "ws")
          wsPath = (Just (Right (rootDir </> dir "ws" </> file "stats")))
          wsH = U.HierarchicalPart auth wsPath
      in
      pure $ U.printURI $ U.URI wsScheme wsH Nothing Nothing
    _ -> throwException $ error "Could not get the URL for the stats websocket"

-- | Entry point for the browser.
main :: Eff (CoreEffects AppEffects) (App State Action)
main = do
    app <- start =<< config init
    renderToDOM "#app" app.html
    pure app

-- | Entry point for the browser with pux-devtool injected.
debug :: State -> Eff (CoreEffects AppEffects) (App State (Pux.Devtool.Action Action))
debug state = do
  app <- Pux.Devtool.start =<< config state
  renderToDOM "#app" app.html
  -- | Used by hot-reloading code in support/index.js
  pure app

module Main where

import Prelude
import Data.Either
import Data.Maybe
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION,throwException,error)
import Data.URI.Types (HierarchicalPart(..))

import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Location (pathname)
import DOM.HTML.Window(location)
import Data.URI as U
import Data.Path.Pathy((</>),dir,file,rootDir)
--import Debug.Trace (traceAnyM)

import Pux (App, Config, CoreEffects, fromSimple, renderToDOM, start)
import Pux.Devtool (Action, start) as Pux.Devtool
import Pux.Router (sampleUrl)

import Signal ((~>),Signal)
import Signal.Channel (channel, subscribe, CHANNEL)

import WebSocket(WEBSOCKET)

import App.Layout (Action(..), State, view, update, init)
import App.Routes (match)
import App.StatsSocket as Socket

type AppEffects = (dom :: DOM, ws :: WEBSOCKET)

-- | App configuration
config :: forall eff. State -> Eff (dom :: DOM, channel :: CHANNEL, err :: EXCEPTION, ws :: WEBSOCKET | eff) (Config State Action AppEffects)
config state = do
  -- | Create a signal of URL changes.
  routeSignal <- configRoute
  -- | Create a signal for WebSocket stats data
  socketSignal <- configSocket
  pure
    { initialState: state
    , update: fromSimple update
    , view: view
    , inputs: [routeSignal, socketSignal] }

configSocket :: forall eff. Eff (dom :: DOM, err :: EXCEPTION, channel :: CHANNEL, ws :: WEBSOCKET | eff) (Signal Action)
configSocket = do
  wsUrl <- getWsUrl
  wsInput <- channel Socket.Starting
  statsSig <- Socket.setupWs wsInput wsUrl
  let wsSignal = subscribe wsInput
  let socketSignal = wsSignal ~> Received
  pure socketSignal

configRoute :: forall eff. Eff (dom :: DOM | eff) (Signal Action)
configRoute = do
  urlSignal <- sampleUrl
  -- | Map a signal of URL changes to PageView actions.
  pure $ urlSignal ~> match >>> PageView

getWsUrl :: forall eff. Eff (dom :: DOM, err :: EXCEPTION | eff) String
getWsUrl = getInitialPath >>= convertToWsUrl

convertToWsUrl :: forall eff. String -> Eff (err :: EXCEPTION | eff) String
convertToWsUrl url =
  case U.runParseURI url of
    Right
      (U.URI _
        h@(U.HierarchicalPart auth@(Just _) _ )
       _  _
      ) ->
      let wsScheme = Just (U.URIScheme "ws")
          wsPath = (Just (Right (rootDir </> dir "ws" </> file "stats")))
          wsH = U.HierarchicalPart auth wsPath
      in
      pure $ U.printURI $ U.URI wsScheme wsH Nothing Nothing
    _ -> throwException $ error "Could not get the URL for the stats websocket"

getInitialPath :: forall eff. Eff (dom :: DOM | eff) String
getInitialPath =  window >>= location >>= pathname

-- | Entry point for the browser.
main :: Eff (CoreEffects AppEffects) (App State Action)
main = do
    app <- start =<< config init
    renderToDOM "#app" app.html
    -- | Used by hot-reloading code in support/index.js
    pure app

-- | Entry point for the browser with pux-devtool injected.
debug :: State -> Eff (CoreEffects AppEffects) (App State (Pux.Devtool.Action Action))
debug state = do
  app <- Pux.Devtool.start =<< config state
  renderToDOM "#app" app.html
  -- | Used by hot-reloading code in support/index.js
  pure app


[CSE-172] Fix build

[CSE-172] Fix build

-- | Detail page of a `genesis block` https://cardanodocs.com/technical/blocks/#genesis-block

module Explorer.View.GenesisBlock
    ( genesisBlockView
    , maxAddressInfoRows
    )
    where

import Prelude

import Data.Array (null)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cGenesis, cAddress, cAddresses, cAll, cOf, common, cLoading, cNo, cSummary, cYes, gblAddressesError, gblAddressesNotFound, gblAddressRedeemAmount, gblAddressIsRedeemed, gblAddressIsNotRedeemed, gblNotFound, gblNumberRedeemedAddresses, gblNumberAddressesToRedeem, gblNumberRedeemedAmount, gblNumberAmountToRedeem, genesisBlock, cAddressIsRedeemed) as I18nL
import Explorer.Lenses.State (currentCGenesisAddressInfos, currentCGenesisSummary, gblAddressInfosPageNumber, gblAddressInfosPagination, gblAddressInfosPaginationEditable, gblLoadingAddressInfosPagination, gblAddressInfosMaxPageNumber, genesisBlockViewState, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CGenesisAddressInfos, GenesisBlockPagination(..), PageNumber(..), State)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, paginationView)
import Network.RemoteData (RemoteData(..))
import Pos.Explorer.Web.ClientTypes (CGenesisAddressInfo(..), CGenesisSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, cgaiCardanoAddress, cgaiGenesisAmount, cgaiIsRedeemed, cgsAmountRedeemed, cgsAmountRemaining, cgsNumRedeemed, cgsNumRemaining)
import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Text.Smolder.HTML (a, div, h3, li, p, span, ul) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup ((!), (#!))
import Text.Smolder.Markup (text) as S

genesisBlockView :: State -> P.HTML Action
genesisBlockView state =
    let lang' = state ^. lang
    in
    S.div ! S.className "explorer-genesis"$ do
        S.div ! S.className "explorer-genesis__wrapper"
              $ S.div ! S.className "explorer-genesis__container" $ do
                    S.h3  ! S.className "headline"
                        $ S.text (translate (I18nL.common <<< I18nL.cGenesis) lang')
                    case state ^. currentCGenesisSummary of
                        NotAsked  -> emptyView ""
                        Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                        Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblNotFound) lang'
                        Success summary -> summaryView summary state

        S.div ! S.className "explorer-genesis__wrapper" $ do
            S.div ! S.className "explorer-genesis__container" $ do
                S.h3  ! S.className "headline"
                      $ S.text (translate (I18nL.common <<< I18nL.cAddresses) lang')
                case state ^. currentCGenesisAddressInfos of
                    NotAsked  -> emptyView ""
                    Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                    Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesError) lang'
                    Success infos -> addressInfosView infos state

emptyView :: String -> P.HTML Action
emptyView message =
    S.div ! S.className "summary-empty__container"
          $ S.text message

type SummaryRowItem =
    { key :: String
    , label :: String
    , amount :: String
    , mCurrency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

mkSummaryItems :: State -> CGenesisSummary -> SummaryItems
mkSummaryItems state (CGenesisSummary summary) =
    let lang' = state ^. lang in
    [ { id: "0"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberRedeemedAddresses) lang'
      , amount: show $ summary ^. cgsNumRedeemed
      , mCurrency: Nothing
      }
    , { id: "2"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberAddressesToRedeem) lang'
      , amount: show $ summary ^. cgsNumRemaining
      , mCurrency: Nothing
      }
    , { id: "3"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberRedeemedAmount) lang'
      , amount: formatADA (summary ^. cgsAmountRedeemed) lang'
      , mCurrency: Just ADA
      }
    , { id: "4"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberAmountToRedeem) lang'
      , amount: formatADA (summary ^. cgsAmountRemaining) lang'
      , mCurrency: Just ADA
      }

    ]

summaryRow :: SummaryRowItem -> P.HTML Action
summaryRow item =
    S.div
        ! S.className "row row__summary"
        ! P.key item.key
        $ do
            S.div ! S.className "column column__label"
                  $ S.text item.label
            S.div ! S.className "column column__amount"
                  $ S.span  ! S.className (currencyCSSClass item.mCurrency)
                            $ S.text item.amount

summaryView :: CGenesisSummary -> State -> P.HTML Action
summaryView summary state =
    S.div ! S.className "summary-wrapper" $ do
        S.div ! S.className "summary-container" $ do
            S.h3  ! S.className "subheadline"
                  $ S.text (translate (I18nL.common <<< I18nL.cSummary) $ state ^. lang)
            S.div $ for_ (mkSummaryItems state summary) summaryRow

type AddressInfosHeaderProps =
    { label :: String
    , clazz :: String
    }

mkAddressInfosHeaderProps :: Language -> Array AddressInfosHeaderProps
mkAddressInfosHeaderProps lang =
    [ { label: translate (I18nL.common <<< I18nL.cAddress) lang
      , clazz: "hash"
      }
    , { label: translate (I18nL.genesisBlock <<< I18nL.gblAddressRedeemAmount) lang
      , clazz: "amount"
      }
    , { label: translate (I18nL.common <<< I18nL.cAddressIsRedeemed) lang
      , clazz: "redeemed"
      }
    ]

addressInfosFilterView :: State -> P.HTML Action
addressInfosFilterView state =
    let pagination = state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
        lang' = state ^. lang
    in
    S.ul ! S.className "address-infos__filter-nav"
          $ do
          addressInfosFilterItemView
              (translate (I18nL.common <<< I18nL.cAll) lang')
              GBPaginateAllAddresses
              pagination
          addressInfosFilterItemView
              (translate (I18nL.genesisBlock <<< I18nL.gblAddressIsRedeemed) lang')
              GBPaginateRedeemedAddresses
              pagination
          addressInfosFilterItemView
              (translate (I18nL.genesisBlock <<< I18nL.gblAddressIsNotRedeemed) lang')
              GBPaginateNonRedeemedAddresses
              pagination

addressInfosFilterItemView :: String -> GenesisBlockPagination -> GenesisBlockPagination -> P.HTML Action
addressInfosFilterItemView label pagination currentPagination =
    S.li  ! S.className ("address-infos__filter-nav--item"
                            <> if (currentPagination == pagination)
                                  then " selected"
                                  else ""
                        )
          #! P.onClick (const $ GenesisBlockFilterAddressInfos pagination)
          $ S.text label

addressInfosHeaderView :: Language -> P.HTML Action
addressInfosHeaderView lang =
    S.div ! S.className "address-infos__header"
          $ for_ (mkAddressInfosHeaderProps lang) addressInfosHeaderItemView

addressInfosHeaderItemView :: AddressInfosHeaderProps -> P.HTML Action
addressInfosHeaderItemView props =
    S.div ! S.className props.clazz
          $ S.text props.label

addressInfosBodyView :: Language -> CGenesisAddressInfo -> P.HTML Action
addressInfosBodyView lang (CGenesisAddressInfo info) =
    let addrLink = toUrl $ Address (info ^. cgaiCardanoAddress) in
    S.div ! S.className "address-infos__body--row"
          $ do
          -- hash
          S.a ! S.className "address-infos__body--column hash"
              ! S.href addrLink
              #! P.onClick (Navigate addrLink)
              $ S.text (info ^. (cgaiCardanoAddress <<< _CAddress))
          -- amount
          S.div ! S.className "address-infos__body--column amount"
                $ S.span ! S.className (currencyCSSClass $ Just ADA)
                          $ S.text (formatADA (info ^. cgaiGenesisAmount) lang)
          -- is redeemed
          S.div ! S.className "address-infos__body--column redeemed"
                $ S.text (if (info ^. cgaiIsRedeemed)
                              then translate (I18nL.common <<< I18nL.cYes) lang
                              else translate (I18nL.common <<< I18nL.cNo) lang)

maxAddressInfoRows :: Int
maxAddressInfoRows = 5

addressInfosView :: CGenesisAddressInfos -> State -> P.HTML Action
addressInfosView infos state = do
    S.div
        ! S.className "address-infos__wrapper"
        $ do
            addressInfosFilterView state
            addressInfosHeaderView lang'
            S.div ! S.className "address-infos__body--wrapper"
                  $ do
                  if null infos
                      then emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesNotFound) lang'
                      else for_ infos (addressInfosBodyView lang')
                  S.div ! S.className ("address-infos__body--cover" <>  if isLoading then " show" else "")
                        $ S.p ! S.className "address-infos__body--cover-label"
                              $ S.text (translate (I18nL.common <<< I18nL.cLoading) lang')
    S.div
        ! S.className "address-infos__footer"
        $  paginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                            , currentPage: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPageNumber)
                            , minPage: PageNumber minPagination
                            , maxPage: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosMaxPageNumber)
                            , changePageAction: GenesisBlockPaginateAddresses
                            , editable: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPaginationEditable)
                            , editableAction: GenesisBlockEditAddressesPageNumber
                            , invalidPageAction: GenesisBlockInvalidAddressesPageNumber
                            , disabled: isLoading
                            }
    where
        lang' = state ^. lang
        isLoading = state ^. (viewStates <<< genesisBlockViewState <<< gblLoadingAddressInfosPagination)

-- | Detail page of a `genesis block` https://cardanodocs.com/technical/blocks/#genesis-block

module Explorer.View.GenesisBlock
    ( genesisBlockView
    , maxAddressInfoRows
    )
    where

import Prelude

import Data.Array (null)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cGenesis, cAddress, cAddresses, cAll, cOf, common, cLoading, cNo, cSummary, cYes, gblAddressesError, gblAddressesNotFound, gblAddressRedeemAmount, gblAddressIsRedeemed, gblAddressIsNotRedeemed, gblNotFound, gblNumberRedeemedAddresses, gblNumberAddressesToRedeem, gblNumberRedeemedAmount, gblNumberAmountToRedeem, genesisBlock) as I18nL
import Explorer.Lenses.State (currentCGenesisAddressInfos, currentCGenesisSummary, gblAddressInfosPageNumber, gblAddressInfosPagination, gblAddressInfosPaginationEditable, gblLoadingAddressInfosPagination, gblAddressInfosMaxPageNumber, genesisBlockViewState, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CGenesisAddressInfos, GenesisBlockPagination(..), PageNumber(..), State)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, paginationView)
import Network.RemoteData (RemoteData(..))
import Pos.Explorer.Web.ClientTypes (CGenesisAddressInfo(..), CGenesisSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, cgaiCardanoAddress, cgaiGenesisAmount, cgaiIsRedeemed, cgsAmountRedeemed, cgsAmountRemaining, cgsNumRedeemed, cgsNumRemaining)
import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Text.Smolder.HTML (a, div, h3, li, p, span, ul) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup ((!), (#!))
import Text.Smolder.Markup (text) as S

genesisBlockView :: State -> P.HTML Action
genesisBlockView state =
    let lang' = state ^. lang
    in
    S.div ! S.className "explorer-genesis"$ do
        S.div ! S.className "explorer-genesis__wrapper"
              $ S.div ! S.className "explorer-genesis__container" $ do
                    S.h3  ! S.className "headline"
                        $ S.text (translate (I18nL.common <<< I18nL.cGenesis) lang')
                    case state ^. currentCGenesisSummary of
                        NotAsked  -> emptyView ""
                        Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                        Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblNotFound) lang'
                        Success summary -> summaryView summary state

        S.div ! S.className "explorer-genesis__wrapper" $ do
            S.div ! S.className "explorer-genesis__container" $ do
                S.h3  ! S.className "headline"
                      $ S.text (translate (I18nL.common <<< I18nL.cAddresses) lang')
                case state ^. currentCGenesisAddressInfos of
                    NotAsked  -> emptyView ""
                    Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                    Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesError) lang'
                    Success infos -> addressInfosView infos state

emptyView :: String -> P.HTML Action
emptyView message =
    S.div ! S.className "summary-empty__container"
          $ S.text message

type SummaryRowItem =
    { key :: String
    , label :: String
    , amount :: String
    , mCurrency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

mkSummaryItems :: State -> CGenesisSummary -> SummaryItems
mkSummaryItems state (CGenesisSummary summary) =
    let lang' = state ^. lang in
    [ { id: "0"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberRedeemedAddresses) lang'
      , amount: show $ summary ^. cgsNumRedeemed
      , mCurrency: Nothing
      }
    , { id: "2"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberAddressesToRedeem) lang'
      , amount: show $ summary ^. cgsNumRemaining
      , mCurrency: Nothing
      }
    , { id: "3"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberRedeemedAmount) lang'
      , amount: formatADA (summary ^. cgsAmountRedeemed) lang'
      , mCurrency: Just ADA
      }
    , { id: "4"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberAmountToRedeem) lang'
      , amount: formatADA (summary ^. cgsAmountRemaining) lang'
      , mCurrency: Just ADA
      }

    ]

summaryRow :: SummaryRowItem -> P.HTML Action
summaryRow item =
    S.div
        ! S.className "row row__summary"
        ! P.key item.key
        $ do
            S.div ! S.className "column column__label"
                  $ S.text item.label
            S.div ! S.className "column column__amount"
                  $ S.span  ! S.className (currencyCSSClass item.mCurrency)
                            $ S.text item.amount

summaryView :: CGenesisSummary -> State -> P.HTML Action
summaryView summary state =
    S.div ! S.className "summary-wrapper" $ do
        S.div ! S.className "summary-container" $ do
            S.h3  ! S.className "subheadline"
                  $ S.text (translate (I18nL.common <<< I18nL.cSummary) $ state ^. lang)
            S.div $ for_ (mkSummaryItems state summary) summaryRow

type AddressInfosHeaderProps =
    { label :: String
    , clazz :: String
    }

mkAddressInfosHeaderProps :: Language -> Array AddressInfosHeaderProps
mkAddressInfosHeaderProps lang =
    [ { label: translate (I18nL.common <<< I18nL.cAddress) lang
      , clazz: "hash"
      }
    , { label: translate (I18nL.genesisBlock <<< I18nL.gblAddressRedeemAmount) lang
      , clazz: "amount"
      }
    , { label: translate (I18nL.common <<< I18nL.cAddressIsRedeemed) lang
      , clazz: "redeemed"
      }
    ]

addressInfosFilterView :: State -> P.HTML Action
addressInfosFilterView state =
    let pagination = state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
        lang' = state ^. lang
    in
    S.ul ! S.className "address-infos__filter-nav"
          $ do
          addressInfosFilterItemView
              (translate (I18nL.common <<< I18nL.cAll) lang')
              GBPaginateAllAddresses
              pagination
          addressInfosFilterItemView
              (translate (I18nL.genesisBlock <<< I18nL.gblAddressIsRedeemed) lang')
              GBPaginateRedeemedAddresses
              pagination
          addressInfosFilterItemView
              (translate (I18nL.genesisBlock <<< I18nL.gblAddressIsNotRedeemed) lang')
              GBPaginateNonRedeemedAddresses
              pagination

addressInfosFilterItemView :: String -> GenesisBlockPagination -> GenesisBlockPagination -> P.HTML Action
addressInfosFilterItemView label pagination currentPagination =
    S.li  ! S.className ("address-infos__filter-nav--item"
                            <> if (currentPagination == pagination)
                                  then " selected"
                                  else ""
                        )
          #! P.onClick (const $ GenesisBlockFilterAddressInfos pagination)
          $ S.text label

addressInfosHeaderView :: Language -> P.HTML Action
addressInfosHeaderView lang =
    S.div ! S.className "address-infos__header"
          $ for_ (mkAddressInfosHeaderProps lang) addressInfosHeaderItemView

addressInfosHeaderItemView :: AddressInfosHeaderProps -> P.HTML Action
addressInfosHeaderItemView props =
    S.div ! S.className props.clazz
          $ S.text props.label

addressInfosBodyView :: Language -> CGenesisAddressInfo -> P.HTML Action
addressInfosBodyView lang (CGenesisAddressInfo info) =
    let addrLink = toUrl $ Address (info ^. cgaiCardanoAddress) in
    S.div ! S.className "address-infos__body--row"
          $ do
          -- hash
          S.a ! S.className "address-infos__body--column hash"
              ! S.href addrLink
              #! P.onClick (Navigate addrLink)
              $ S.text (info ^. (cgaiCardanoAddress <<< _CAddress))
          -- amount
          S.div ! S.className "address-infos__body--column amount"
                $ S.span ! S.className (currencyCSSClass $ Just ADA)
                          $ S.text (formatADA (info ^. cgaiGenesisAmount) lang)
          -- is redeemed
          S.div ! S.className "address-infos__body--column redeemed"
                $ S.text (if (info ^. cgaiIsRedeemed)
                              then translate (I18nL.common <<< I18nL.cYes) lang
                              else translate (I18nL.common <<< I18nL.cNo) lang)

maxAddressInfoRows :: Int
maxAddressInfoRows = 5

addressInfosView :: CGenesisAddressInfos -> State -> P.HTML Action
addressInfosView infos state = do
    S.div
        ! S.className "address-infos__wrapper"
        $ do
            addressInfosFilterView state
            addressInfosHeaderView lang'
            S.div ! S.className "address-infos__body--wrapper"
                  $ do
                  if null infos
                      then emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesNotFound) lang'
                      else for_ infos (addressInfosBodyView lang')
                  S.div ! S.className ("address-infos__body--cover" <>  if isLoading then " show" else "")
                        $ S.p ! S.className "address-infos__body--cover-label"
                              $ S.text (translate (I18nL.common <<< I18nL.cLoading) lang')
    S.div
        ! S.className "address-infos__footer"
        $  paginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                            , currentPage: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPageNumber)
                            , minPage: PageNumber minPagination
                            , maxPage: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosMaxPageNumber)
                            , changePageAction: GenesisBlockPaginateAddresses
                            , editable: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPaginationEditable)
                            , editableAction: GenesisBlockEditAddressesPageNumber
                            , invalidPageAction: GenesisBlockInvalidAddressesPageNumber
                            , disabled: isLoading
                            }
    where
        lang' = state ^. lang
        isLoading = state ^. (viewStates <<< genesisBlockViewState <<< gblLoadingAddressInfosPagination)


tweaks but no fix yet for zoom weirdness

module Main where

import D3.Selection (call, style, attr, append, enter, dataBind, selectAll, d3Select, selectElem)
import D3.Base (D3, Eff, D3Element, Index, Point, AttrSetter(..), DataBind(..), ListenerType(..), PolyValue(..), Typenames(..), (...), (..))
import D3.Drag (addDragListener, d3Drag, dragUpdate)
import D3.Zoom (addZoomListener, scaleExtent, d3Zoom, getZoomTransform)
import Prelude (Unit, unit, pure, bind)
import Control.Monad.Eff.Console (CONSOLE)
import Data.Maybe (Maybe(..))
import Unsafe.Coerce (unsafeCoerce)

circleData :: Array Point
circleData = [ {x: 100.0, y: 100.0}
             , {x: 200.0, y: 200.0}
             , {x: 100.0, y: 200.0}
             , {x: 200.0, y: 100.0}
             , {x: 150.0, y: 150.0}
             ]

-- an example of a drag listener written in Purescript
-- element will track pointer / finger, but other possibilities exist such as
-- faster or slower than dragging or adding acceleration or further side-effects
dragged :: ∀ eff. Point -> Index -> Array D3Element -> D3Element ->  Eff (d3::D3|eff) Unit
dragged d i els element = do
  selectElem element
    .. attr "cx" (SetAttr d.x) -- not changing the underlying datum here
    .. attr "cy" (SetAttr d.y) -- so nothing happens. Add further Attr options? TODO
  dragUpdate d element -- state mutating function from drag.purs that makes the change
  pure unit

-- an example of a zoom listener written in Purescript
-- this just gives the most naive implementation but here's where you'd begin to implement
-- semantic zooms and the like
-- in the example he's using a global var for the <g> which actually gets transformed
-- but we're (for now) just going to look it up each time
zoomed :: ∀ d eff. d -> Index -> Array D3Element -> D3Element ->  Eff (d3::D3|eff) Unit
zoomed d i els element = do
  g  <- d3Select "g"
     .. attr "transform" (SetAttr getZoomTransform)
  pure unit

main :: ∀ e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  svg <- d3Select ".svg"
  g <-  svg ... append "g"

  circles <- g ... selectAll "circle"
      .. dataBind (Data circleData)
    .. enter .. append "circle"
      .. attr "cx" (AttrFn (\d i nodes el -> pure d.x)) -- thing to bear in mind here:
      .. attr "cy" (AttrFn (\d i nodes el -> pure d.y)) -- if you mod here doesn't change underlying value when you drag
      .. attr "r"  (SetAttr 20.0)
      .. style "stroke" (Value "red")
      .. style "fill"   (Value "black")

  -- phantom type for d3Drag to ensure correct type for dragBehavior (but type only gets in the way here, potentially)
  dragBehavior <- d3Drag { x: 0.0, y: 0.0 }
               .. addDragListener (TypeNames [ { name: Just "foo", type: Drag } ]) dragged

  let foo = circles ... call (unsafeCoerce dragBehavior) -- adds the drag callbacks for drag (dragBehavior) on selection (g)
  -- unsafeCoerce here is obviously undesirable, need to play with types and see if we can reformulate to lose it TODO

  zoomBehavior <- d3Zoom
             .. scaleExtent [ 0.5, 8.0]
             .. addZoomListener (TypeNames [ { name: Just "bar", type: Zoom } ]) zoomed

  let bar = svg ... call (unsafeCoerce zoomBehavior)

  pure unit

module Main where

import D3.Selection (call, style, attr, append, enter, dataBind, selectAll, d3Select, selectElem)
import D3.Base (D3, Eff, D3Element, Index, Point, AttrSetter(..), DataBind(..), ListenerType(..), PolyValue(..), Typenames(..), (...), (..))
import D3.Drag (addDragListener, d3Drag, dragUpdate)
import D3.Zoom (addZoomListener, scaleExtent, d3Zoom, getZoomTransform)
import Prelude (Unit, unit, pure, bind)
import Control.Monad.Eff.Console (CONSOLE)
import Data.Maybe (Maybe(..))
import Unsafe.Coerce (unsafeCoerce)

circleData :: Array Point
circleData = [ {x: 100.0, y: 100.0}
             , {x: 200.0, y: 200.0}
             , {x: 100.0, y: 200.0}
             , {x: 200.0, y: 100.0}
             , {x: 150.0, y: 150.0}
             ]

-- an example of a drag listener written in Purescript
-- element will track pointer / finger, but other possibilities exist such as
-- faster or slower than dragging or adding acceleration or further side-effects
dragged :: ∀ eff. Point -> Index -> Array D3Element -> D3Element ->  Eff (d3::D3|eff) Unit
dragged d i els element = do
  selectElem element
    .. attr "cx" (SetAttr d.x) -- not changing the underlying datum here
    .. attr "cy" (SetAttr d.y) -- so nothing happens. Add further Attr options? TODO
  dragUpdate d element -- state mutating function from drag.purs that makes the change
  pure unit

-- an example of a zoom listener written in Purescript
-- this just gives the most naive implementation but here's where you'd begin to implement
-- semantic zooms and the like
-- in the example he's using a global var for the <g> which actually gets transformed
-- but we're (for now) just going to look it up each time
zoomed :: ∀ d eff. d -> Index -> Array D3Element -> D3Element ->  Eff (d3::D3|eff) Unit
zoomed d i els element = do
  g  <- d3Select "g"
     .. attr "transform" (SetAttr getZoomTransform)
  pure unit

main :: ∀ e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  svg <- d3Select ".svg"
  g <-  svg ... append "g"

  circles <- g ... selectAll "circle"
      .. dataBind (Data circleData)
    .. enter .. append "circle"
      .. attr "cx" (AttrFn (\d i nodes el -> pure d.x)) -- thing to bear in mind here:
      .. attr "cy" (AttrFn (\d i nodes el -> pure d.y)) -- if you mod here doesn't change underlying value when you drag
      .. attr "r"  (SetAttr 20.0)
      .. style "stroke" (Value "red")
      .. style "fill"   (Value "black")

  let phantom = { x: 0.0, y: 0.0 }
  let tn = TypeNames [ { name: Just "foo", type: Drag } ]
  yag <- d3Drag phantom -- phantom type to ensure correct type for yag (but type only gets in the way here, potentially)
        .. addDragListener tn dragged

  let foo = circles ... call (unsafeCoerce yag) -- adds the drag callbacks for drag (yag) on selection (g)
  -- unsafeCoerce here is obviously undesirable, need to play with types and see if we can reformulate to lose it TODO

  let tn2 = TypeNames [ { name: Just "foo", type: Zoom } ]
  yag2 <- d3Zoom
       .. scaleExtent [ 0.5, 8.0]
       .. addZoomListener tn2 zoomed

  let bar = g ... call (unsafeCoerce yag2)

  pure unit


select card before next action card on deletion

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Deck.Component.State
  ( StateP
  , State
  , StateMode(..)
  , CardDef
  , CardConstructor
  , initialDeck
  , _id
  , _fresh
  , _accessType
  , _cards
  , _dependencies
  , _activeCardIndex
  , _name
  , _browserFeatures
  , _viewingCard
  , _path
  , _saveTrigger
  , _runTrigger
  , _globalVarMap
  , _pendingCards
  , _failingCards
  , _stateMode
  , _backsided
  , _initialSliderX
  , _initialSliderCardWidth
  , _sliderTransition
  , _sliderTranslateX
  , _nextActionCardElement
  , addCard
  , addCard'
  , removeCards
  , findRoot
  , findParent
  , findChildren
  , findDescendants
  , findLast
  , findLastCardType
  , addPendingCard
  , getCardType
  , cardsOfType
  , fromModel
  , deckPath
  , cardIndexFromId
  , cardIdFromIndex
  , activeCardId

  , VirtualState()
  , runVirtualState
  , virtualState
  ) where

import SlamData.Prelude

import Data.BrowserFeatures (BrowserFeatures)
import Data.Foldable (maximum, any)
import Data.Lens (LensP, lens)
import Data.Array as A
import Data.List as L
import Data.Map as M
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.Set as S
import Data.StrMap as SM

import DOM.HTML.Types (HTMLElement)

import Halogen as H
import Halogen.Component.Utils.Debounced (DebounceTrigger)

import SlamData.Effects (Slam)
import SlamData.Workspace.AccessType (AccessType(..))
import SlamData.Workspace.Card.Ace.Component (AceEvaluator, AceSetup, aceComponent)
import SlamData.Workspace.Card.API.Component (apiComponent)
import SlamData.Workspace.Card.APIResults.Component (apiResultsComponent)
import SlamData.Workspace.Card.CardId (CardId(..), runCardId)
import SlamData.Workspace.Card.CardType (CardType(..), AceMode(..))
import SlamData.Workspace.Card.Chart.Component (chartComponent)
import SlamData.Workspace.Card.Component (CardComponent, CardStateP, CardQueryP, initialCardState)
import SlamData.Workspace.Card.Download.Component (downloadComponent)
import SlamData.Workspace.Card.JTable.Component (jtableComponent)
import SlamData.Workspace.Card.Markdown.Component (markdownComponent)
import SlamData.Workspace.Card.Next.Component (nextCardComponent)
import SlamData.Workspace.Card.Save.Component (saveCardComponent)
import SlamData.Workspace.Card.DownloadOptions.Component as DOpts
import SlamData.Workspace.Card.Error.Component as Error
import SlamData.Workspace.Card.Markdown.Eval (markdownEval, markdownSetup)
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.Card.Query.Eval (queryEval, querySetup)
import SlamData.Workspace.Card.Search.Component (searchComponent)
import SlamData.Workspace.Card.Viz.Component (vizComponent)
import SlamData.Workspace.Card.OpenResource.Component (openResourceComponent)
import SlamData.Workspace.Deck.Component.ChildSlot (CardSlot(..), ChildSlot, ChildState, ChildQuery)
import SlamData.Workspace.Deck.Component.Query (Query)
import SlamData.Workspace.Deck.DeckId (DeckId, deckIdToString)
import SlamData.Workspace.Deck.Model as Model

import Utils.Path (DirPath)

type StateP = H.ParentState State ChildState Query ChildQuery Slam ChildSlot

data StateMode
  = Loading
  | Ready
  | Error String

-- | The deck state. See the corresponding lenses for descriptions of
-- | the fields.
type State =
  { id ∷ Maybe DeckId
  , fresh ∷ Int
  , accessType ∷ AccessType
  , cards ∷ Array CardDef
  , dependencies ∷ M.Map CardId CardId
  , cardTypes ∷ M.Map CardId CardType
  , activeCardIndex ∷ Int
  , name ∷ Maybe String
  , path ∷ Maybe DirPath
  , browserFeatures ∷ BrowserFeatures
  , viewingCard ∷ Maybe CardId
  , saveTrigger ∷ Maybe (DebounceTrigger Query Slam)
  , runTrigger ∷ Maybe (DebounceTrigger Query Slam)
  , pendingCards ∷ S.Set CardId
  , failingCards ∷ S.Set CardId
  , globalVarMap ∷ Port.VarMap
  , stateMode ∷ StateMode
  , backsided ∷ Boolean
  , initialSliderX :: Maybe Number
  , initialSliderCardWidth :: Maybe Number
  , sliderTransition :: Boolean
  , sliderTranslateX :: Number
  , nextActionCardElement :: Maybe HTMLElement
  }

-- | A record used to represent card definitions in the deck.
type CardDef = { id ∷ CardId, ty ∷ CardType, ctor ∷ CardConstructor }

-- | The specific `SlotConstructor` type for cards in the deck.
type CardConstructor = H.SlotConstructor CardStateP CardQueryP Slam CardSlot

-- | Constructs a default `State` value.
initialDeck ∷ BrowserFeatures → State
initialDeck browserFeatures =
  { id: Nothing
  , fresh: 0
  , accessType: Editable
  , cards: mempty
  , cardTypes: M.empty
  , dependencies: M.empty
  , activeCardIndex: 0
  , name: Nothing
  , browserFeatures
  , viewingCard: Nothing
  , path: Nothing
  , saveTrigger: Nothing
  , globalVarMap: SM.empty
  , runTrigger: Nothing
  , pendingCards: S.empty
  , failingCards: S.empty
  , stateMode: Ready
  , backsided: false
  , initialSliderX: Nothing
  , initialSliderCardWidth: Nothing
  , sliderTransition: false
  , sliderTranslateX: 0.0
  , nextActionCardElement: Nothing
  }

-- | The unique identifier of the deck. If it's a fresh, unsaved deck, the id
-- | will be Nothing.
_id ∷ LensP State (Maybe DeckId)
_id = lens _.id _{id = _}

-- | A counter used to generate `CardId` values.
_fresh ∷ LensP State Int
_fresh = lens _.fresh _{fresh = _}

-- | Determines whether the deck is editable.
_accessType ∷ LensP State AccessType
_accessType = lens _.accessType _{accessType = _}

-- | The list of cards currently in the deck.
_cards ∷ LensP State (Array CardDef)
_cards = lens _.cards _{cards = _}

-- | A map of the edges in the dependency tree, where each key/value pair
-- | represents a child/parent relation.
_dependencies ∷ LensP State (M.Map CardId CardId)
_dependencies = lens _.dependencies _{dependencies = _}

-- | The `CardId` for the currently focused card. `Nothing` indicates the next
-- | action card.
_activeCardIndex ∷ LensP State Int
_activeCardIndex = lens _.activeCardIndex _{activeCardIndex = _}

-- | The display name of the deck.
_name ∷ LensP State (Maybe String)
_name = lens _.name _{name = _}

-- | The path to the deck in the filesystem
_path ∷ LensP State (Maybe DirPath)
_path = lens _.path _{path = _}

-- | The available browser features - passed through to markdown results cards
-- | as they need this information to render the output HTML.
_browserFeatures ∷ LensP State BrowserFeatures
_browserFeatures = lens _.browserFeatures _{browserFeatures = _}

-- | The currently focused card when viewing an individual card within a
-- | deck.
_viewingCard ∷ LensP State (Maybe CardId)
_viewingCard = lens _.viewingCard _{viewingCard = _}

-- | The debounced trigger for deck save actions.
_saveTrigger ∷ LensP State (Maybe (DebounceTrigger Query Slam))
_saveTrigger = lens _.saveTrigger _{saveTrigger = _}

-- | The debounced trigger for running all cards that are pending.
_runTrigger ∷ LensP State (Maybe (DebounceTrigger Query Slam))
_runTrigger = lens _.runTrigger _{runTrigger = _}

-- | The global `VarMap`, passed through to the deck via the URL.
_globalVarMap ∷ LensP State Port.VarMap
_globalVarMap = lens _.globalVarMap _{globalVarMap = _}

-- | The cards that have been enqueued to run.
_pendingCards ∷ LensP State (S.Set CardId)
_pendingCards = lens _.pendingCards _{pendingCards = _}

-- | The cards which currently have errors.
_failingCards ∷ LensP State (S.Set CardId)
_failingCards = lens _.failingCards _{failingCards = _}

-- | The "state mode" used to track whether the deck is ready, loading, or
-- | if an error has occurred while loading.
_stateMode ∷ LensP State StateMode
_stateMode = lens _.stateMode _{stateMode = _}

-- | Is `true` if backside of deck is displayed
_backsided ∷ ∀ a r. LensP {backsided ∷ a |r} a
_backsided = lens _.backsided _{backsided = _}

-- | The x position of the card slider at the start of the slide interaction in
-- | pixels. If `Nothing` slide interaction is not in progress.
_initialSliderX :: LensP State (Maybe Number)
_initialSliderX = lens _.initialSliderX _{initialSliderX = _}

-- | The width of the next action card at the start of the slide interaction in
-- | pixels. If `Nothing` either the slide interaction is not in progress or the
-- | next action card element reference is broken.
_initialSliderCardWidth :: LensP State (Maybe Number)
_initialSliderCardWidth = lens _.initialSliderCardWidth _{initialSliderCardWidth = _}

-- | Whether the translation of the card slider should be animated or not.
-- | Should be true between the end of the slide interaction and the end of the
-- | transition.
_sliderTransition :: LensP State Boolean
_sliderTransition = lens _.sliderTransition _{sliderTransition = _}

-- | The current x translation of the card slider during the slide interaction.
_sliderTranslateX :: LensP State Number
_sliderTranslateX = lens _.sliderTranslateX _{sliderTranslateX = _}

-- | The next action card HTML element
_nextActionCardElement :: LensP State (Maybe HTMLElement)
_nextActionCardElement = lens _.nextActionCardElement _{nextActionCardElement = _}

-- | Adds a new card to the deck.
-- |
-- | Takes the current deck state, the type of card to add, and an optional
-- | parent card ID.
addCard ∷ CardType → Maybe CardId → State → State
addCard cardType parent st = fst $ addCard' cardType parent st

-- | Adds a new card to the deck.
-- |
-- | Takes the current deck state, the type of card to add, and an optional
-- | parent card ID and returns the modified deck state and the new card ID.
addCard' ∷ CardType → Maybe CardId → State → Tuple State CardId
addCard' cardType parent st =
  let
    cardId = CardId st.fresh
    newState = st
      { fresh = st.fresh + 1
      , cards = st.cards `A.snoc` mkCardDef cardType cardId st
      , cardTypes = M.insert cardId cardType st.cardTypes
      , dependencies =
          maybe st.dependencies (flip (M.insert cardId) st.dependencies) parent
      }
  in
    Tuple newState cardId

-- | Insert an error card as a child to a specified card, and reassociate all
-- | its children as children of the error card.
insertErrorCard ∷ CardId → State → State
insertErrorCard parentId st =
  st
    { cards =
        fromMaybe st.cards do
          parentAddr ← A.findIndex (\c → c.id ≡ parentId) st.cards
          let errorCard = mkCardDef ErrorCard cardId st
          A.insertAt (parentAddr + 1) errorCard st.cards
    , cardTypes = M.insert cardId ErrorCard st.cardTypes
    , dependencies =
        let
          children :: Array CardId
          children = foldMap pure $ findChildren parentId st
          updates = children <#> \childId → M.insert childId cardId
        in foldr (∘) id updates $ M.insert cardId parentId st.dependencies
    }
  where
    -- The -1 index is reserved for the error card.
    cardId = CardId (-1)

mkCardDef ∷ CardType → CardId → State → CardDef
mkCardDef cardType cardId st =
  { id: cardId
  , ty: cardType
  , ctor: H.SlotConstructor (CardSlot cardId) \_ → { component, initialState }
  }
  where
  component = cardTypeComponent cardType cardId st.browserFeatures
  initialState =
    H.parentState initialCardState
      { accessType = st.accessType }

cardTypeComponent ∷ CardType → CardId → BrowserFeatures → CardComponent
cardTypeComponent (Ace mode) _ _ = aceComponent { mode, evaluator, setup }
  where
  evaluator = aceEvalMode mode
  setup = aceSetupMode mode
cardTypeComponent Search _ _ = searchComponent
cardTypeComponent Viz _ _ = vizComponent
cardTypeComponent Chart _ _ = chartComponent
cardTypeComponent Markdown cardId bf = markdownComponent cardId bf
cardTypeComponent JTable _ _ = jtableComponent
cardTypeComponent Download _ _ = downloadComponent
cardTypeComponent API _ _ = apiComponent
cardTypeComponent APIResults _ _ = apiResultsComponent
cardTypeComponent NextAction _ _ = nextCardComponent
cardTypeComponent Save _ _ = saveCardComponent
cardTypeComponent OpenResource _ _ = openResourceComponent
cardTypeComponent DownloadOptions _ _ = DOpts.comp
cardTypeComponent ErrorCard _ _ = Error.comp

aceEvalMode ∷ AceMode → AceEvaluator
aceEvalMode MarkdownMode = markdownEval
aceEvalMode SQLMode = queryEval

aceSetupMode ∷ AceMode → AceSetup
aceSetupMode MarkdownMode = markdownSetup
aceSetupMode SQLMode = querySetup

-- | Removes a set of cards from the deck. Any cards that depend on a card
-- | in the set of provided cards will also be removed.
-- |
-- | Takes the set of IDs for the cards to remove and the current deck
-- | state.
removeCards ∷ S.Set CardId → State → State
removeCards cardIds st = st
    { cards = cards
    , activeCardIndex = A.length cards - 1
    , cardTypes = foldl (flip M.delete) st.cardTypes cardIds'
    , dependencies = M.fromList $ L.filter g $ M.toList st.dependencies
    , pendingCards = S.difference st.pendingCards cardIds
    }
  where
  cards = A.filter f st.cards

  cardIds' ∷ S.Set CardId
  cardIds' = cardIds ⊕ foldMap (flip findDescendants st) cardIds

  f ∷ CardDef → Boolean
  f = not ∘ flip S.member cardIds' ∘ _.id

  g ∷ Tuple CardId CardId → Boolean
  g (Tuple kId vId) = not $ S.member kId cardIds' ∨ S.member vId cardIds'

-- | Finds the last card/card
findLast ∷ State → Maybe CardId
findLast state =
  maximum $ M.keys state.cardTypes

findLastCardType ∷ State → Maybe CardType
findLastCardType state =
  join $ flip M.lookup state.cardTypes <$> findLast state

-- | Finds the root in a chain of dependencies starting at the specified card.
-- | A card can be its own root if it depends on no other cards.
-- |
-- | Takes the ID of the card to start searching from and the current deck
-- | state.
findRoot ∷ CardId → State → CardId
findRoot cardId st = case findParent cardId st of
  Nothing → cardId
  Just parentId → findRoot parentId st

-- | Finds the parent of a card. If the card is a root it has no parent, and
-- | the result will be `Nothing`.
-- |
-- | Takes the ID of the card to find the parent of and the current deck
-- | state.
findParent ∷ CardId → State → Maybe CardId
findParent cardId st = M.lookup cardId st.dependencies

-- | Finds the immediate dependencies of a card.
-- |
-- | Takes the ID of the card to find the children of and the current deck
-- | state.
findChildren ∷ CardId → State → S.Set CardId
findChildren parentId st =
  S.fromList $ map fst $ L.filter f $ M.toList st.dependencies
  where
  f ∷ Tuple CardId CardId → Boolean
  f (Tuple _ cardId) = cardId ≡ parentId

-- | Finds all the dependencies of a card: the children, children's children,
-- | and so on until the leaves of the tree are reached.
-- |
-- | Takes the ID of the card to find the descendants of and the current
-- | deck state.
findDescendants ∷ CardId → State → S.Set CardId
findDescendants cardId st =
  let children = findChildren cardId st
  in children ⊕ foldMap (flip findDescendants st) children

-- | Determine's the `CardType` of a card; returns `Just` if the card is
-- | in the deck, and `Nothing` if it is not.
getCardType ∷ CardId → State → Maybe CardType
getCardType cardId st = M.lookup cardId st.cardTypes

cardsOfType ∷ CardType → State → Array CardId
cardsOfType cardType =
  _.cardTypes ⋙ M.toList ⋙ L.mapMaybe cardTypeMatches ⋙ foldMap pure
  where
  cardTypeMatches (Tuple cid ty) =
    if ty ≡ cardType
       then Just cid
       else Nothing

newtype VirtualState = VirtualState State

runVirtualState ∷ VirtualState → State
runVirtualState (VirtualState st) = st

-- | Equip the state for presentation by inserting Error cards
-- | in the appropriate places.
virtualState ∷ State → VirtualState
virtualState st =
  VirtualState
    case findFirst hasError st.cards of
      Just c → insertErrorCard c.id st
      Nothing → st
  where

  -- in case you're wondering, Data.Foldable.find does not find the *first*
  -- satisfying element in the list! This took me a long time to figure out.
  findFirst ∷ ∀ a. (a → Boolean) → Array a → Maybe a
  findFirst p xs =
    A.findIndex p xs
      >>= A.index xs

  hasError ∷ CardDef → Boolean
  hasError c = S.member c.id st.failingCards

-- | Adds a card to the set of cards that are enqueued to run.
-- |
-- | If the card is a descendant of an card that has already been enqueued this
-- | will have no effect, as in this case the card is already pending by
-- | implication: all cards under the queued ancestor will be evaluated as
-- | changes propagate through the subgraph.
-- |
-- | If the card is an ancestor of cards that have already been enqueued they
-- | will be removed when this card is added, for the same reasoning as above.
addPendingCard ∷ CardId → State → State
addPendingCard cardId st@{ pendingCards } =
  if cardId `S.member` pendingCards ∨ any isAncestor pendingCards
  then st
  else st { pendingCards = S.insert cardId (removeDescendants pendingCards) }
  where
  isAncestor ∷ CardId → Boolean
  isAncestor otherId = cardId `S.member` findDescendants otherId st
  removeDescendants ∷ S.Set CardId → S.Set CardId
  removeDescendants = flip S.difference (findDescendants cardId st)

-- | Finds the current deck path
deckPath ∷ State → Maybe DirPath
deckPath state = do
  path ← state.path
  deckId ← deckIdToString <$> state.id
  pure $ path </> P.dir deckId

-- | Reconstructs a deck state from a deck model.
fromModel
  ∷ BrowserFeatures
  → Maybe DirPath
  → Maybe DeckId
  → Model.Deck
  → State
  → Tuple (Array Card.Model) State
fromModel browserFeatures path deckId { cards, dependencies, name } state =
  Tuple
    cards
    ((state
        { accessType = ReadOnly
        , activeCardIndex = A.length cardDefs - 1
        , backsided = false
        , browserFeatures = browserFeatures
        , cardTypes = foldl addCardIdTypePair M.empty cards
        , cards = cardDefs
        , dependencies = dependencies
        , failingCards = S.empty
        , fresh = maybe 0 (_ + 1) $ maximum $ map (runCardId ∘ _.cardId) cards
        , globalVarMap = SM.empty
        , id = deckId
        , initialSliderX = Nothing
        , name = name
        , path = path
        , runTrigger = Nothing
        , pendingCards = S.empty
        }) :: State)
  where
  cardDefs = foldMap cardDefFromModel cards

  activeCardIndex = _.id <$> A.last cardDefs

  addCardIdTypePair mp {cardId, cardType} = M.insert cardId cardType mp

  cardDefFromModel ∷ Card.Model → Array CardDef
  cardDefFromModel { cardId, cardType} =
    let component = cardTypeComponent cardType cardId browserFeatures
        initialState = H.parentState initialCardState
    in
      pure
        { id: cardId
        , ty: cardType
        , ctor: H.SlotConstructor (CardSlot cardId) \_ → { component, initialState }
        }

cardIndexFromId :: VirtualState -> CardId -> Int
cardIndexFromId vstate =
  fromMaybe (A.length state.cards) <<< flip A.elemIndex (_.id <$> state.cards)
  where
  state = runVirtualState vstate

cardIdFromIndex :: State -> Int -> Maybe CardId
cardIdFromIndex state =
  map _.id <<< A.index (_.cards state)

activeCardId :: State -> Maybe CardId
activeCardId state =
  cardIdFromIndex state state.activeCardIndex

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Deck.Component.State
  ( StateP
  , State
  , StateMode(..)
  , CardDef
  , CardConstructor
  , initialDeck
  , _id
  , _fresh
  , _accessType
  , _cards
  , _dependencies
  , _activeCardIndex
  , _name
  , _browserFeatures
  , _viewingCard
  , _path
  , _saveTrigger
  , _runTrigger
  , _globalVarMap
  , _pendingCards
  , _failingCards
  , _stateMode
  , _backsided
  , _initialSliderX
  , _initialSliderCardWidth
  , _sliderTransition
  , _sliderTranslateX
  , _nextActionCardElement
  , addCard
  , addCard'
  , removeCards
  , findRoot
  , findParent
  , findChildren
  , findDescendants
  , findLast
  , findLastCardType
  , addPendingCard
  , getCardType
  , cardsOfType
  , fromModel
  , deckPath
  , cardIndexFromId
  , cardIdFromIndex
  , activeCardId

  , VirtualState()
  , runVirtualState
  , virtualState
  ) where

import SlamData.Prelude

import Data.BrowserFeatures (BrowserFeatures)
import Data.Foldable (maximum, any)
import Data.Lens (LensP, lens)
import Data.Array as A
import Data.List as L
import Data.Map as M
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.Set as S
import Data.StrMap as SM

import DOM.HTML.Types (HTMLElement)

import Halogen as H
import Halogen.Component.Utils.Debounced (DebounceTrigger)

import SlamData.Effects (Slam)
import SlamData.Workspace.AccessType (AccessType(..))
import SlamData.Workspace.Card.Ace.Component (AceEvaluator, AceSetup, aceComponent)
import SlamData.Workspace.Card.API.Component (apiComponent)
import SlamData.Workspace.Card.APIResults.Component (apiResultsComponent)
import SlamData.Workspace.Card.CardId (CardId(..), runCardId)
import SlamData.Workspace.Card.CardType (CardType(..), AceMode(..))
import SlamData.Workspace.Card.Chart.Component (chartComponent)
import SlamData.Workspace.Card.Component (CardComponent, CardStateP, CardQueryP, initialCardState)
import SlamData.Workspace.Card.Download.Component (downloadComponent)
import SlamData.Workspace.Card.JTable.Component (jtableComponent)
import SlamData.Workspace.Card.Markdown.Component (markdownComponent)
import SlamData.Workspace.Card.Next.Component (nextCardComponent)
import SlamData.Workspace.Card.Save.Component (saveCardComponent)
import SlamData.Workspace.Card.DownloadOptions.Component as DOpts
import SlamData.Workspace.Card.Error.Component as Error
import SlamData.Workspace.Card.Markdown.Eval (markdownEval, markdownSetup)
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.Card.Query.Eval (queryEval, querySetup)
import SlamData.Workspace.Card.Search.Component (searchComponent)
import SlamData.Workspace.Card.Viz.Component (vizComponent)
import SlamData.Workspace.Card.OpenResource.Component (openResourceComponent)
import SlamData.Workspace.Deck.Component.ChildSlot (CardSlot(..), ChildSlot, ChildState, ChildQuery)
import SlamData.Workspace.Deck.Component.Query (Query)
import SlamData.Workspace.Deck.DeckId (DeckId, deckIdToString)
import SlamData.Workspace.Deck.Model as Model

import Utils.Path (DirPath)

type StateP = H.ParentState State ChildState Query ChildQuery Slam ChildSlot

data StateMode
  = Loading
  | Ready
  | Error String

-- | The deck state. See the corresponding lenses for descriptions of
-- | the fields.
type State =
  { id ∷ Maybe DeckId
  , fresh ∷ Int
  , accessType ∷ AccessType
  , cards ∷ Array CardDef
  , dependencies ∷ M.Map CardId CardId
  , cardTypes ∷ M.Map CardId CardType
  , activeCardIndex ∷ Int
  , name ∷ Maybe String
  , path ∷ Maybe DirPath
  , browserFeatures ∷ BrowserFeatures
  , viewingCard ∷ Maybe CardId
  , saveTrigger ∷ Maybe (DebounceTrigger Query Slam)
  , runTrigger ∷ Maybe (DebounceTrigger Query Slam)
  , pendingCards ∷ S.Set CardId
  , failingCards ∷ S.Set CardId
  , globalVarMap ∷ Port.VarMap
  , stateMode ∷ StateMode
  , backsided ∷ Boolean
  , initialSliderX :: Maybe Number
  , initialSliderCardWidth :: Maybe Number
  , sliderTransition :: Boolean
  , sliderTranslateX :: Number
  , nextActionCardElement :: Maybe HTMLElement
  }

-- | A record used to represent card definitions in the deck.
type CardDef = { id ∷ CardId, ty ∷ CardType, ctor ∷ CardConstructor }

-- | The specific `SlotConstructor` type for cards in the deck.
type CardConstructor = H.SlotConstructor CardStateP CardQueryP Slam CardSlot

-- | Constructs a default `State` value.
initialDeck ∷ BrowserFeatures → State
initialDeck browserFeatures =
  { id: Nothing
  , fresh: 0
  , accessType: Editable
  , cards: mempty
  , cardTypes: M.empty
  , dependencies: M.empty
  , activeCardIndex: 0
  , name: Nothing
  , browserFeatures
  , viewingCard: Nothing
  , path: Nothing
  , saveTrigger: Nothing
  , globalVarMap: SM.empty
  , runTrigger: Nothing
  , pendingCards: S.empty
  , failingCards: S.empty
  , stateMode: Ready
  , backsided: false
  , initialSliderX: Nothing
  , initialSliderCardWidth: Nothing
  , sliderTransition: false
  , sliderTranslateX: 0.0
  , nextActionCardElement: Nothing
  }

-- | The unique identifier of the deck. If it's a fresh, unsaved deck, the id
-- | will be Nothing.
_id ∷ LensP State (Maybe DeckId)
_id = lens _.id _{id = _}

-- | A counter used to generate `CardId` values.
_fresh ∷ LensP State Int
_fresh = lens _.fresh _{fresh = _}

-- | Determines whether the deck is editable.
_accessType ∷ LensP State AccessType
_accessType = lens _.accessType _{accessType = _}

-- | The list of cards currently in the deck.
_cards ∷ LensP State (Array CardDef)
_cards = lens _.cards _{cards = _}

-- | A map of the edges in the dependency tree, where each key/value pair
-- | represents a child/parent relation.
_dependencies ∷ LensP State (M.Map CardId CardId)
_dependencies = lens _.dependencies _{dependencies = _}

-- | The `CardId` for the currently focused card. `Nothing` indicates the next
-- | action card.
_activeCardIndex ∷ LensP State Int
_activeCardIndex = lens _.activeCardIndex _{activeCardIndex = _}

-- | The display name of the deck.
_name ∷ LensP State (Maybe String)
_name = lens _.name _{name = _}

-- | The path to the deck in the filesystem
_path ∷ LensP State (Maybe DirPath)
_path = lens _.path _{path = _}

-- | The available browser features - passed through to markdown results cards
-- | as they need this information to render the output HTML.
_browserFeatures ∷ LensP State BrowserFeatures
_browserFeatures = lens _.browserFeatures _{browserFeatures = _}

-- | The currently focused card when viewing an individual card within a
-- | deck.
_viewingCard ∷ LensP State (Maybe CardId)
_viewingCard = lens _.viewingCard _{viewingCard = _}

-- | The debounced trigger for deck save actions.
_saveTrigger ∷ LensP State (Maybe (DebounceTrigger Query Slam))
_saveTrigger = lens _.saveTrigger _{saveTrigger = _}

-- | The debounced trigger for running all cards that are pending.
_runTrigger ∷ LensP State (Maybe (DebounceTrigger Query Slam))
_runTrigger = lens _.runTrigger _{runTrigger = _}

-- | The global `VarMap`, passed through to the deck via the URL.
_globalVarMap ∷ LensP State Port.VarMap
_globalVarMap = lens _.globalVarMap _{globalVarMap = _}

-- | The cards that have been enqueued to run.
_pendingCards ∷ LensP State (S.Set CardId)
_pendingCards = lens _.pendingCards _{pendingCards = _}

-- | The cards which currently have errors.
_failingCards ∷ LensP State (S.Set CardId)
_failingCards = lens _.failingCards _{failingCards = _}

-- | The "state mode" used to track whether the deck is ready, loading, or
-- | if an error has occurred while loading.
_stateMode ∷ LensP State StateMode
_stateMode = lens _.stateMode _{stateMode = _}

-- | Is `true` if backside of deck is displayed
_backsided ∷ ∀ a r. LensP {backsided ∷ a |r} a
_backsided = lens _.backsided _{backsided = _}

-- | The x position of the card slider at the start of the slide interaction in
-- | pixels. If `Nothing` slide interaction is not in progress.
_initialSliderX :: LensP State (Maybe Number)
_initialSliderX = lens _.initialSliderX _{initialSliderX = _}

-- | The width of the next action card at the start of the slide interaction in
-- | pixels. If `Nothing` either the slide interaction is not in progress or the
-- | next action card element reference is broken.
_initialSliderCardWidth :: LensP State (Maybe Number)
_initialSliderCardWidth = lens _.initialSliderCardWidth _{initialSliderCardWidth = _}

-- | Whether the translation of the card slider should be animated or not.
-- | Should be true between the end of the slide interaction and the end of the
-- | transition.
_sliderTransition :: LensP State Boolean
_sliderTransition = lens _.sliderTransition _{sliderTransition = _}

-- | The current x translation of the card slider during the slide interaction.
_sliderTranslateX :: LensP State Number
_sliderTranslateX = lens _.sliderTranslateX _{sliderTranslateX = _}

-- | The next action card HTML element
_nextActionCardElement :: LensP State (Maybe HTMLElement)
_nextActionCardElement = lens _.nextActionCardElement _{nextActionCardElement = _}

-- | Adds a new card to the deck.
-- |
-- | Takes the current deck state, the type of card to add, and an optional
-- | parent card ID.
addCard ∷ CardType → Maybe CardId → State → State
addCard cardType parent st = fst $ addCard' cardType parent st

-- | Adds a new card to the deck.
-- |
-- | Takes the current deck state, the type of card to add, and an optional
-- | parent card ID and returns the modified deck state and the new card ID.
addCard' ∷ CardType → Maybe CardId → State → Tuple State CardId
addCard' cardType parent st =
  let
    cardId = CardId st.fresh
    newState = st
      { fresh = st.fresh + 1
      , cards = st.cards `A.snoc` mkCardDef cardType cardId st
      , cardTypes = M.insert cardId cardType st.cardTypes
      , dependencies =
          maybe st.dependencies (flip (M.insert cardId) st.dependencies) parent
      }
  in
    Tuple newState cardId

-- | Insert an error card as a child to a specified card, and reassociate all
-- | its children as children of the error card.
insertErrorCard ∷ CardId → State → State
insertErrorCard parentId st =
  st
    { cards =
        fromMaybe st.cards do
          parentAddr ← A.findIndex (\c → c.id ≡ parentId) st.cards
          let errorCard = mkCardDef ErrorCard cardId st
          A.insertAt (parentAddr + 1) errorCard st.cards
    , cardTypes = M.insert cardId ErrorCard st.cardTypes
    , dependencies =
        let
          children :: Array CardId
          children = foldMap pure $ findChildren parentId st
          updates = children <#> \childId → M.insert childId cardId
        in foldr (∘) id updates $ M.insert cardId parentId st.dependencies
    }
  where
    -- The -1 index is reserved for the error card.
    cardId = CardId (-1)

mkCardDef ∷ CardType → CardId → State → CardDef
mkCardDef cardType cardId st =
  { id: cardId
  , ty: cardType
  , ctor: H.SlotConstructor (CardSlot cardId) \_ → { component, initialState }
  }
  where
  component = cardTypeComponent cardType cardId st.browserFeatures
  initialState =
    H.parentState initialCardState
      { accessType = st.accessType }

cardTypeComponent ∷ CardType → CardId → BrowserFeatures → CardComponent
cardTypeComponent (Ace mode) _ _ = aceComponent { mode, evaluator, setup }
  where
  evaluator = aceEvalMode mode
  setup = aceSetupMode mode
cardTypeComponent Search _ _ = searchComponent
cardTypeComponent Viz _ _ = vizComponent
cardTypeComponent Chart _ _ = chartComponent
cardTypeComponent Markdown cardId bf = markdownComponent cardId bf
cardTypeComponent JTable _ _ = jtableComponent
cardTypeComponent Download _ _ = downloadComponent
cardTypeComponent API _ _ = apiComponent
cardTypeComponent APIResults _ _ = apiResultsComponent
cardTypeComponent NextAction _ _ = nextCardComponent
cardTypeComponent Save _ _ = saveCardComponent
cardTypeComponent OpenResource _ _ = openResourceComponent
cardTypeComponent DownloadOptions _ _ = DOpts.comp
cardTypeComponent ErrorCard _ _ = Error.comp

aceEvalMode ∷ AceMode → AceEvaluator
aceEvalMode MarkdownMode = markdownEval
aceEvalMode SQLMode = queryEval

aceSetupMode ∷ AceMode → AceSetup
aceSetupMode MarkdownMode = markdownSetup
aceSetupMode SQLMode = querySetup

-- | Removes a set of cards from the deck. Any cards that depend on a card
-- | in the set of provided cards will also be removed.
-- |
-- | Takes the set of IDs for the cards to remove and the current deck
-- | state.
removeCards ∷ S.Set CardId → State → State
removeCards cardIds st = st
    { cards = A.filter f st.cards
    , cardTypes = foldl (flip M.delete) st.cardTypes cardIds'
    , dependencies = M.fromList $ L.filter g $ M.toList st.dependencies
    , pendingCards = S.difference st.pendingCards cardIds
    }
  where
  cardIds' ∷ S.Set CardId
  cardIds' = cardIds ⊕ foldMap (flip findDescendants st) cardIds

  f ∷ CardDef → Boolean
  f = not ∘ flip S.member cardIds' ∘ _.id

  g ∷ Tuple CardId CardId → Boolean
  g (Tuple kId vId) = not $ S.member kId cardIds' ∨ S.member vId cardIds'

-- | Finds the last card/card
findLast ∷ State → Maybe CardId
findLast state =
  maximum $ M.keys state.cardTypes

findLastCardType ∷ State → Maybe CardType
findLastCardType state =
  join $ flip M.lookup state.cardTypes <$> findLast state

-- | Finds the root in a chain of dependencies starting at the specified card.
-- | A card can be its own root if it depends on no other cards.
-- |
-- | Takes the ID of the card to start searching from and the current deck
-- | state.
findRoot ∷ CardId → State → CardId
findRoot cardId st = case findParent cardId st of
  Nothing → cardId
  Just parentId → findRoot parentId st

-- | Finds the parent of a card. If the card is a root it has no parent, and
-- | the result will be `Nothing`.
-- |
-- | Takes the ID of the card to find the parent of and the current deck
-- | state.
findParent ∷ CardId → State → Maybe CardId
findParent cardId st = M.lookup cardId st.dependencies

-- | Finds the immediate dependencies of a card.
-- |
-- | Takes the ID of the card to find the children of and the current deck
-- | state.
findChildren ∷ CardId → State → S.Set CardId
findChildren parentId st =
  S.fromList $ map fst $ L.filter f $ M.toList st.dependencies
  where
  f ∷ Tuple CardId CardId → Boolean
  f (Tuple _ cardId) = cardId ≡ parentId

-- | Finds all the dependencies of a card: the children, children's children,
-- | and so on until the leaves of the tree are reached.
-- |
-- | Takes the ID of the card to find the descendants of and the current
-- | deck state.
findDescendants ∷ CardId → State → S.Set CardId
findDescendants cardId st =
  let children = findChildren cardId st
  in children ⊕ foldMap (flip findDescendants st) children

-- | Determine's the `CardType` of a card; returns `Just` if the card is
-- | in the deck, and `Nothing` if it is not.
getCardType ∷ CardId → State → Maybe CardType
getCardType cardId st = M.lookup cardId st.cardTypes

cardsOfType ∷ CardType → State → Array CardId
cardsOfType cardType =
  _.cardTypes ⋙ M.toList ⋙ L.mapMaybe cardTypeMatches ⋙ foldMap pure
  where
  cardTypeMatches (Tuple cid ty) =
    if ty ≡ cardType
       then Just cid
       else Nothing

newtype VirtualState = VirtualState State

runVirtualState ∷ VirtualState → State
runVirtualState (VirtualState st) = st

-- | Equip the state for presentation by inserting Error cards
-- | in the appropriate places.
virtualState ∷ State → VirtualState
virtualState st =
  VirtualState
    case findFirst hasError st.cards of
      Just c → insertErrorCard c.id st
      Nothing → st
  where

  -- in case you're wondering, Data.Foldable.find does not find the *first*
  -- satisfying element in the list! This took me a long time to figure out.
  findFirst ∷ ∀ a. (a → Boolean) → Array a → Maybe a
  findFirst p xs =
    A.findIndex p xs
      >>= A.index xs

  hasError ∷ CardDef → Boolean
  hasError c = S.member c.id st.failingCards

-- | Adds a card to the set of cards that are enqueued to run.
-- |
-- | If the card is a descendant of an card that has already been enqueued this
-- | will have no effect, as in this case the card is already pending by
-- | implication: all cards under the queued ancestor will be evaluated as
-- | changes propagate through the subgraph.
-- |
-- | If the card is an ancestor of cards that have already been enqueued they
-- | will be removed when this card is added, for the same reasoning as above.
addPendingCard ∷ CardId → State → State
addPendingCard cardId st@{ pendingCards } =
  if cardId `S.member` pendingCards ∨ any isAncestor pendingCards
  then st
  else st { pendingCards = S.insert cardId (removeDescendants pendingCards) }
  where
  isAncestor ∷ CardId → Boolean
  isAncestor otherId = cardId `S.member` findDescendants otherId st
  removeDescendants ∷ S.Set CardId → S.Set CardId
  removeDescendants = flip S.difference (findDescendants cardId st)

-- | Finds the current deck path
deckPath ∷ State → Maybe DirPath
deckPath state = do
  path ← state.path
  deckId ← deckIdToString <$> state.id
  pure $ path </> P.dir deckId

-- | Reconstructs a deck state from a deck model.
fromModel
  ∷ BrowserFeatures
  → Maybe DirPath
  → Maybe DeckId
  → Model.Deck
  → State
  → Tuple (Array Card.Model) State
fromModel browserFeatures path deckId { cards, dependencies, name } state =
  Tuple
    cards
    ((state
        { accessType = ReadOnly
        , activeCardIndex = A.length cardDefs - 1
        , backsided = false
        , browserFeatures = browserFeatures
        , cardTypes = foldl addCardIdTypePair M.empty cards
        , cards = cardDefs
        , dependencies = dependencies
        , failingCards = S.empty
        , fresh = maybe 0 (_ + 1) $ maximum $ map (runCardId ∘ _.cardId) cards
        , globalVarMap = SM.empty
        , id = deckId
        , initialSliderX = Nothing
        , name = name
        , path = path
        , runTrigger = Nothing
        , pendingCards = S.empty
        }) :: State)
  where
  cardDefs = foldMap cardDefFromModel cards

  activeCardIndex = _.id <$> A.last cardDefs

  addCardIdTypePair mp {cardId, cardType} = M.insert cardId cardType mp

  cardDefFromModel ∷ Card.Model → Array CardDef
  cardDefFromModel { cardId, cardType} =
    let component = cardTypeComponent cardType cardId browserFeatures
        initialState = H.parentState initialCardState
    in
      pure
        { id: cardId
        , ty: cardType
        , ctor: H.SlotConstructor (CardSlot cardId) \_ → { component, initialState }
        }

cardIndexFromId :: VirtualState -> CardId -> Int
cardIndexFromId vstate =
  fromMaybe (A.length state.cards) <<< flip A.elemIndex (_.id <$> state.cards)
  where
  state = runVirtualState vstate

cardIdFromIndex :: State -> Int -> Maybe CardId
cardIdFromIndex state =
  map _.id <<< A.index (_.cards state)

activeCardId :: State -> Maybe CardId
activeCardId state =
  cardIdFromIndex state state.activeCardIndex


Implement applyOutputHandler; maps all output parsers over input

module Genetics.Browser.Events.Handler where

import Data.Record
import Prelude
import Type.Row
import Control.Monad.Aff.Bus as Bus
import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff, Canceler, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Rec.Class (forever)
import Data.List (List, (:), mapMaybe)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Record.Unsafe (unsafeGet)
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..))
import Data.Variant (Variant, case_, expand, match, on, prj, inj)
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

-- 'rin' is the row of types that this can handle,
-- 'rfun' is the row of types that corresponds to the record with functions
-- 'b' is the output type; all functions in 'rfun' must have 'b' as domain
data InputHandler (rin :: # Type) (rfun :: # Type) b = InputHandler (Record rfun)

appendHandler :: ∀ l a rin1 rin2 b rfun1 rfun2.
                 RowLacks l rin1
              => RowLacks l rfun1
              => RowCons l (a -> b) rfun1 rfun2
              => RowCons l a rin1 rin2
              => IsSymbol l
              => SProxy l
              -> (a -> b)
              -> InputHandler rin1 rfun1 b
              -> InputHandler rin2 rfun2 b
appendHandler l f (InputHandler r) = InputHandler $ insert l f r

class ConsHandler (rin :: # Type) (rfun :: # Type) (l :: Symbol) a b (rin2 :: # Type) (rfun2 :: # Type)
      | rin l a -> rin2, rfun l a b -> rfun2

instance consHandler
         :: ( RowLacks l rin2
            , RowLacks l rfun2
            , RowCons l a rin1 rin2
            , RowCons l (a -> b) rfun1 rfun2
            )
         => ConsHandler rin rfun l a b rin2 rfun2

class AppendHandlerImpl (rin :: # Type) (rfun :: # Type) (l :: RowList) a b (rin2 :: # Type) (rfun2 :: # Type)

instance appendHandlerNil
         :: AppendHandlerImpl rin rfun Nil a b rin2 rfun2

instance appendHandlerCons
         :: ConsHandler rin rfun k a b rin2 rfun2
         => AppendHandlerImpl rin rfun (Cons k ty rest) a b rin2 rfun2

class AppendHandler (rin :: # Type) (rfun :: # Type) (l :: # Type) a b (rin2 :: # Type) (rfun2 :: # Type)

instance appendHandlerInstance
         :: ( RowToList l llist
            , AppendHandlerImpl rin rfun llist a b rin2 rfun2
            )
         => AppendHandler rin rfun ls a b rin2 rfun2

class ConcatHandler (rin1 :: # Type) (rfun1 :: # Type)
                    (rin2 :: # Type) (rfun2 :: # Type)
                    (rin3 :: # Type) (rfun3 :: # Type)
      | rin1 rin2 -> rin3, rfun1 rfun2 -> rfun3
      , rin1 rin3 -> rin2, rfun1 rfun3 -> rfun2
      , rin2 rin3 -> rin1, rfun2 rfun3 -> rfun1

class ConcatHandlerImpl (lin1 :: RowList) (lfun1 :: RowList)
                        (lin2 :: RowList) (lfun2 :: RowList)
                        (lin3 :: RowList) (lfun3 :: RowList)

instance concatHandlerNil :: ConcatHandlerImpl Nil Nil Nil Nil Nil Nil

emptyHandler :: ∀ b.
                InputHandler () () b
emptyHandler = InputHandler {}

applyHandler :: ∀ lt a rin rfun b.
                Union lt a rin
             => InputHandler rin rfun b
             -> Variant lt
             -> b
applyHandler (InputHandler h) v =
  case coerceV v of
    Tuple tag a -> a # unsafeGet tag h
  where coerceV :: ∀ c. Variant lt -> Tuple String c
        coerceV = unsafeCoerce

forkHandler :: ∀ lt a rin rfun eff.
               Union lt a rin
            => InputHandler rin rfun (Eff (avar :: AVAR | eff) Unit)
            -> BusRW (Variant lt)
            -> Aff ( avar :: AVAR | eff ) (Canceler ( avar :: AVAR | eff ))
forkHandler h bus = forkAff $ forever do
  val <- Bus.read bus
  liftEff $ applyHandler h val

-- 'a' is the input type; the type of data that this handler can parse
-- 'rout' is the row of types that this can produce
data OutputHandler a (rout :: # Type) = OutputHandler (List (a -> Maybe (Variant rout)))

maybeToVariant :: ∀ l a r.
                  RowCons l a () r
               => IsSymbol l
               => SProxy l
               -> Maybe a
               -> Maybe (Variant r)
maybeToVariant l m = do
  x <- m
  pure $ (inj l x)

maybeFunToVariant :: ∀ l a b r.
                     RowCons l b () r
                  => IsSymbol l
                  => SProxy l
                  -> (a -> Maybe b)
                  -> (a -> Maybe (Variant r))
maybeFunToVariant l f = \a -> do
  x <- f a
  pure $ (inj l x)

maybeFun2 :: ∀ l a b r1 r r2.
             Union r1 r r2
          => RowLacks l r1
          => RowCons l b r1 r2
          => IsSymbol l
          => SProxy l
          -> (a -> Maybe b)
          -> List (a -> Maybe (Variant r1))
          -> List (a -> Maybe (Variant r2))
maybeFun2 l f list = fun2:((map <<< map <<< map) expand list)
  where fun2 :: a -> Maybe (Variant r2)
        fun2 = \a -> do
                x <- f a
                pure $ (inj l x)

appendOutputHandler :: ∀ l a b r1 r r2.
                      Union r1 r r2
                    => RowLacks l r1
                    => RowCons l b r1 r2
                    => IsSymbol l
                    => SProxy l
                    -> (a -> Maybe b)
                    -> OutputHandler a r1
                    -> OutputHandler a r2
appendOutputHandler l f (OutputHandler h) = OutputHandler (maybeFun2 l f h)

emptyOutputHandler :: ∀ a.
                      OutputHandler a ()
emptyOutputHandler = OutputHandler mempty

applyOutputHandler :: ∀ a rout.
                      OutputHandler a rout
                   -> a
                   -> List (Variant rout)
applyOutputHandler (OutputHandler h) a = mapMaybe (\f -> f a) h

module Genetics.Browser.Events.Handler where

import Data.Record
import Prelude
import Type.Row
import Control.Monad.Aff.Bus as Bus
import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff, Canceler, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Rec.Class (forever)
import Data.List (List, (:))
import Data.Maybe (Maybe(..), Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Record.Unsafe (unsafeGet)
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..))
import Data.Variant (Variant, case_, expand, match, on, prj, inj)
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

-- 'rin' is the row of types that this can handle,
-- 'rfun' is the row of types that corresponds to the record with functions
-- 'b' is the output type; all functions in 'rfun' must have 'b' as domain
data InputHandler (rin :: # Type) (rfun :: # Type) b = InputHandler (Record rfun)

appendHandler :: ∀ l a rin1 rin2 b rfun1 rfun2.
                 RowLacks l rin1
              => RowLacks l rfun1
              => RowCons l (a -> b) rfun1 rfun2
              => RowCons l a rin1 rin2
              => IsSymbol l
              => SProxy l
              -> (a -> b)
              -> InputHandler rin1 rfun1 b
              -> InputHandler rin2 rfun2 b
appendHandler l f (InputHandler r) = InputHandler $ insert l f r

class ConsHandler (rin :: # Type) (rfun :: # Type) (l :: Symbol) a b (rin2 :: # Type) (rfun2 :: # Type)
      | rin l a -> rin2, rfun l a b -> rfun2

instance consHandler
         :: ( RowLacks l rin2
            , RowLacks l rfun2
            , RowCons l a rin1 rin2
            , RowCons l (a -> b) rfun1 rfun2
            )
         => ConsHandler rin rfun l a b rin2 rfun2

class AppendHandlerImpl (rin :: # Type) (rfun :: # Type) (l :: RowList) a b (rin2 :: # Type) (rfun2 :: # Type)

instance appendHandlerNil
         :: AppendHandlerImpl rin rfun Nil a b rin2 rfun2

instance appendHandlerCons
         :: ConsHandler rin rfun k a b rin2 rfun2
         => AppendHandlerImpl rin rfun (Cons k ty rest) a b rin2 rfun2

class AppendHandler (rin :: # Type) (rfun :: # Type) (l :: # Type) a b (rin2 :: # Type) (rfun2 :: # Type)

instance appendHandlerInstance
         :: ( RowToList l llist
            , AppendHandlerImpl rin rfun llist a b rin2 rfun2
            )
         => AppendHandler rin rfun ls a b rin2 rfun2

class ConcatHandler (rin1 :: # Type) (rfun1 :: # Type)
                    (rin2 :: # Type) (rfun2 :: # Type)
                    (rin3 :: # Type) (rfun3 :: # Type)
      | rin1 rin2 -> rin3, rfun1 rfun2 -> rfun3
      , rin1 rin3 -> rin2, rfun1 rfun3 -> rfun2
      , rin2 rin3 -> rin1, rfun2 rfun3 -> rfun1

class ConcatHandlerImpl (lin1 :: RowList) (lfun1 :: RowList)
                        (lin2 :: RowList) (lfun2 :: RowList)
                        (lin3 :: RowList) (lfun3 :: RowList)

instance concatHandlerNil :: ConcatHandlerImpl Nil Nil Nil Nil Nil Nil

emptyHandler :: ∀ b.
                InputHandler () () b
emptyHandler = InputHandler {}

applyHandler :: ∀ lt a rin rfun b.
                Union lt a rin
             => InputHandler rin rfun b
             -> Variant lt
             -> b
applyHandler (InputHandler h) v =
  case coerceV v of
    Tuple tag a -> a # unsafeGet tag h
  where coerceV :: ∀ c. Variant lt -> Tuple String c
        coerceV = unsafeCoerce

forkHandler :: ∀ lt a rin rfun eff.
               Union lt a rin
            => InputHandler rin rfun (Eff (avar :: AVAR | eff) Unit)
            -> BusRW (Variant lt)
            -> Aff ( avar :: AVAR | eff ) (Canceler ( avar :: AVAR | eff ))
forkHandler h bus = forkAff $ forever do
  val <- Bus.read bus
  liftEff $ applyHandler h val

-- 'a' is the input type; the type of data that this handler can parse
-- 'rout' is the row of types that this can produce
data OutputHandler a (rout :: # Type) = OutputHandler (List (a -> Maybe (Variant rout)))

maybeToVariant :: ∀ l a r.
                  RowCons l a () r
               => IsSymbol l
               => SProxy l
               -> Maybe a
               -> Maybe (Variant r)
maybeToVariant l m = do
  x <- m
  pure $ (inj l x)

maybeFunToVariant :: ∀ l a b r.
                     RowCons l b () r
                  => IsSymbol l
                  => SProxy l
                  -> (a -> Maybe b)
                  -> (a -> Maybe (Variant r))
maybeFunToVariant l f = \a -> do
  x <- f a
  pure $ (inj l x)

maybeFun2 :: ∀ l a b r1 r r2.
             Union r1 r r2
          => RowLacks l r1
          => RowCons l b r1 r2
          => IsSymbol l
          => SProxy l
          -> (a -> Maybe b)
          -> List (a -> Maybe (Variant r1))
          -> List (a -> Maybe (Variant r2))
maybeFun2 l f list = fun2:((map <<< map <<< map) expand list)
  where fun2 :: a -> Maybe (Variant r2)
        fun2 = \a -> do
                x <- f a
                pure $ (inj l x)

appendOutputHandler :: ∀ l a b r1 r r2.
                      Union r1 r r2
                    => RowLacks l r1
                    => RowCons l b r1 r2
                    => IsSymbol l
                    => SProxy l
                    -> (a -> Maybe b)
                    -> OutputHandler a r1
                    -> OutputHandler a r2
appendOutputHandler l f (OutputHandler h) = OutputHandler (maybeFun2 l f h)

emptyOutputHandler :: ∀ a.
                      OutputHandler a ()
emptyOutputHandler = OutputHandler mempty

-- given an input, try _all_ handlers (parsers), and output a list of variants,
-- containing all valid parses.
-- so, actually
-- applyOutputHandler

-- runOutputHandler :: ∀ lt a rout rfun b.
--                     OutputHandler a rout rfun
--                  -> a
--                  -> List (Variant rout)
-- runOutputHandler (OutputHandler h) v = ?help
  -- case coerceV v of
  --   Tuple tag a -> a # unsafeGet tag h
  -- where coerceV :: ∀ c. Variant lt -> Tuple String c
  --       coerceV = unsafeCoerce


Remove unnecessary newlines #62

Remove unnecessary newlines #62

module Language.Docopt.Scanner (
    scan
  , Docopt(..)
  ) where

import Prelude
import Text.Parsing.Parser (ParseError(ParseError)) as P
import Text.Parsing.Parser.Pos (initialPos) as P
import Data.List (List(Nil, Cons), fromFoldable, catMaybes)
import Data.String.Regex as Regex
import Data.String.Regex (regex, Regex())
import Data.String (length, trim) as String
import Data.String.Yarn (replicate) as String
import Data.Maybe (maybe)
import Data.Either (Either(Left), fromRight)
import Partial.Unsafe (unsafePartial)

type Docopt = {
  usage         :: String
, options       :: List String
, originalUsage :: String
}

section :: String -> Regex
section name = unsafePartial $ fromRight $
  regex ("^([^\n]*" <> name <> "[^\n]*:(?:.*$)\n?(?:(?:[ \t].*)?(?:\n|$))*)")
        (Regex.parseFlags "gmi")

fixSection :: String -> String
fixSection s
  = Regex.replace'
      (unsafePartial $ fromRight $ regex ("(^[^:]+:)") (Regex.noFlags))
      (\m _ -> String.replicate (String.length m) ' ')
      s

scan :: String -> Either P.ParseError Docopt
scan text = do
  u <- case sections "usage" of
              Nil        -> fail "No usage section found!"
              Cons x Nil -> pure x
              _          -> fail "Multiple usage sections found!"

  pure {
    usage:         fixSection u
  , options:       fixSection <$> sections "options"
  , originalUsage: String.trim u
  }

  where
    fail msg = Left $ P.ParseError msg P.initialPos true
    sections n = maybe Nil
                       (catMaybes <<< fromFoldable)
                       (Regex.match (section n) text)

module Language.Docopt.Scanner (
    scan
  , Docopt(..)
  ) where

import Prelude
import Text.Parsing.Parser (ParseError(ParseError)) as P
import Text.Parsing.Parser.Pos (initialPos) as P
import Data.List (List(Nil, Cons), fromFoldable, catMaybes)
import Data.String.Regex as Regex
import Data.String.Regex (regex, Regex())
import Data.String (length) as String
import Data.String.Yarn (replicate) as String
import Data.Maybe (maybe)
import Data.Either (Either(Left), fromRight)
import Partial.Unsafe (unsafePartial)

type Docopt = {
  usage         :: String
, options       :: List String
, originalUsage :: String
}

section :: String -> Regex
section name = unsafePartial $ fromRight $
  regex ("^([^\n]*" <> name <> "[^\n]*:(?:.*$)\n?(?:(?:[ \t].*)?(?:\n|$))*)")
        (Regex.parseFlags "gmi")

fixSection :: String -> String
fixSection s
  = Regex.replace'
      (unsafePartial $ fromRight $ regex ("(^[^:]+:)") (Regex.noFlags))
      (\m _ -> String.replicate (String.length m) ' ')
      s

scan :: String -> Either P.ParseError Docopt
scan text = do
  u <- case sections "usage" of
              Nil        -> fail "No usage section found!"
              Cons x Nil -> pure x
              _          -> fail "Multiple usage sections found!"

  pure {
    usage:         fixSection u
  , options:       fixSection <$> sections "options"
  , originalUsage: u
  }

  where
    fail msg = Left $ P.ParseError msg P.initialPos true
    sections n = maybe Nil
                       (catMaybes <<< fromFoldable)
                       (Regex.match (section n) text)