[CSE-68] Fix selected language

[CSE-68] Fix selected language

module Explorer.View.Common (
    placeholderView
    , txHeaderView
    , txBodyView
    , emptyTxBodyView
    , emptyTxHeaderView
    , emptyView
    , getMaxPaginationNumber
    , mkTxHeaderViewProps
    , class TxHeaderViewPropsFactory
    , mkTxBodyViewProps
    , class TxBodyViewPropsFactory
    , currencyCSSClass
    , paginationView
    , txPaginationView
    , EmptyViewProps
    , mkEmptyViewProps
    , txEmptyContentView
    , noData
    , logoView
    , clickableLogoView
    , langView
    ) where

import Prelude

import Data.Foldable (for_)
import Data.Int (ceil, fromString, toNumber)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..))

import Explorer.I18n.Lang (Language(..), readLanguage, translate)
import Explorer.I18n.Lenses (common, cDateFormat) as I18nL
import Explorer.Lenses.State (lang)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (initialState)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), PageNumber(..), State)
import Explorer.Util.DOM (enterKeyPressed)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkCoin)
import Explorer.Util.String (formatADA)
import Explorer.Util.Time (prettyDate)
import Explorer.View.Lenses (txbAmount, txbInputs, txbOutputs, txhAmount, txhHash, txhTimeIssued)
import Exporer.View.Types (TxBodyViewProps(..), TxHeaderViewProps(..))

import Pos.Explorer.Web.ClientTypes (CCoin, CAddress(..), CTxBrief(..), CTxEntry(..), CTxSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId, ctbId, ctbInputs, ctbOutputs, ctbOutputSum, ctbTimeIssued, cteId, cteTimeIssued, ctsBlockTimeIssued, ctsId, ctsInputs, ctsOutputs, ctsTotalOutput)

import Pux.DOM.Events (DOMEvent, onBlur, onChange, onFocus, onKeyDown, onClick, targetValue) as P
import Pux.DOM.HTML (HTML) as P

import Text.Smolder.HTML (a, div, p, span, input, option, select) as S
import Text.Smolder.HTML.Attributes (className, href, value, disabled, selected, type', min, max) as S
import Text.Smolder.Markup (text) as S
import Text.Smolder.Markup ((#!), (!), (!?))

-- -----------------
-- tx header
-- -----------------

-- | Factory to create TxHeaderViewProps by a given type
class TxHeaderViewPropsFactory a where
    mkTxHeaderViewProps :: a -> TxHeaderViewProps

-- | Creates a TxHeaderViewProps by a given CTxEntry
instance cTxEntryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxEntry where
    mkTxHeaderViewProps (CTxEntry entry) = TxHeaderViewProps
        { txhHash: entry ^. cteId
        , txhTimeIssued: Just $ entry ^. cteTimeIssued
        , txhAmount: entry . cteAmount
        }

-- | Creates a TxHeaderViewProps by a given CTxBrief
instance cTxBriefTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxBrief where
    mkTxHeaderViewProps (CTxBrief txBrief) = TxHeaderViewProps
        { txhHash: txBrief ^. ctbId
        , txhTimeIssued: Just $ txBrief ^. ctbTimeIssued
        , txhAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxHeaderViewProps by a given CTxSummary
instance cTxSummaryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxSummary where
    mkTxHeaderViewProps (CTxSummary txSummary) = TxHeaderViewProps
        { txhHash: txSummary ^. ctsId
        , txhTimeIssued: txSummary ^. ctsBlockTimeIssued
        , txhAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxHeaderViewProps by a given EmptyViewProps
instance emtpyTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory EmptyViewProps where
    mkTxHeaderViewProps _ = TxHeaderViewProps
        { txhHash: mkCTxId noData
        , txhTimeIssued: Nothing
        , txhAmount: mkCoin "0"
        }

txHeaderView :: Language -> TxHeaderViewProps -> P.HTML Action
txHeaderView lang (TxHeaderViewProps props) =
    S.div ! S.className "transaction-header" $ do
        S.div ! S.className "hash-container"
              $ S.a ! S.href (toUrl txRoute)
              #! P.onClick (Navigate $ toUrl txRoute)
              ! S.className "hash"
              $ S.text (props ^. (txhHash <<< _CTxId <<< _CHash))
        S.div ! S.className "date"
              $ S.text $ case props ^. txhTimeIssued of
                              Just time ->
                                  let format = translate (I18nL.common <<< I18nL.cDateFormat) lang
                                  in fromMaybe noData $ prettyDate format time
                              Nothing -> noData
        txAmountView (props ^. txhAmount) lang
    where
        txRoute = Tx $ props ^. txhHash

emptyTxHeaderView :: P.HTML Action
emptyTxHeaderView =
    S.div ! S.className "transaction-header"
          $ mempty

txAmountView :: CCoin -> Language -> P.HTML Action
txAmountView coin lang =
    S.div ! S.className "amount-container"
          $ S.div ! S.className "amount bg-ada"
                  $ S.text (formatADA coin lang)

-- -----------------
-- tx body
-- -----------------

-- | Factory to create TxBodyViewProps by a given type
class TxBodyViewPropsFactory a where
    mkTxBodyViewProps :: a -> TxBodyViewProps

-- | Creates a TxBodyViewProps by a given CTxSummary
instance cTxSummaryTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxSummary where
    mkTxBodyViewProps (CTxSummary txSummary) = TxBodyViewProps
        { txbInputs: txSummary ^. ctsInputs
        , txbOutputs: txSummary ^. ctsOutputs
        , txbAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxBodyViewProps by a given CTxBrief
instance cTxBriefTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxBrief where
    mkTxBodyViewProps (CTxBrief txBrief) = TxBodyViewProps
        { txbInputs: txBrief ^. ctbInputs
        , txbOutputs: txBrief ^. ctbOutputs
        , txbAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxBodyViewProps by a given EmptyViewProps
instance emptyTxBodyViewPropsFactory :: TxBodyViewPropsFactory EmptyViewProps where
    mkTxBodyViewProps _ = TxBodyViewProps
        { txbInputs: []
        , txbOutputs: []
        , txbAmount: mkCoin "0"
        }

txBodyView :: Language -> TxBodyViewProps -> P.HTML Action
txBodyView lang (TxBodyViewProps props) =
    S.div ! S.className "transaction-body" $ do
        S.div ! S.className "from-hash-container"
              $ for_ (props ^. txbInputs) txFromView
        S.div ! S.className "to-hash-container bg-transaction-arrow"
              $ S.div ! S.className "to-hash-wrapper"
                      $ for_ (props ^. txbOutputs) txToView
        S.div ! S.className "amounts-container"
              $ for_ (props ^. txbOutputs) (txBodyAmountView lang)
        txAmountView (props ^. txbAmount) lang

emptyTxBodyView :: P.HTML Action
emptyTxBodyView =
    S.div ! S.className "transaction-body"
          $ mempty

txFromView :: Tuple CAddress CCoin -> P.HTML Action
txFromView (Tuple (CAddress cAddress) _) =
    let addressRoute = Address $ mkCAddress cAddress in
    S.a ! S.href (toUrl addressRoute)
        #! P.onClick (Navigate $ toUrl addressRoute)
        ! S.className "from-hash"
        $ S.text cAddress

txToView :: Tuple CAddress CCoin -> P.HTML Action
txToView (Tuple (CAddress cAddress) _) =
    let addressRoute = Address $ mkCAddress cAddress in
    S.a ! S.href (toUrl addressRoute)
        #! P.onClick (Navigate $ toUrl addressRoute)
        ! S.className "to-hash"
        $ S.text cAddress

txBodyAmountView :: Language -> Tuple CAddress CCoin -> P.HTML Action
txBodyAmountView lang (Tuple _ coin) =
    S.div ! S.className "amount-wrapper"
          $ S.span  ! S.className "plain-amount bg-ada-dark"
                    $ S.text (formatADA coin lang)

-- -----------------
-- pagination
-- -----------------

type PaginationViewProps =
    { label :: String
    , currentPage :: PageNumber
    , minPage :: PageNumber
    , maxPage :: PageNumber
    , editable :: Boolean
    , changePageAction :: (PageNumber -> Action)
    , editableAction :: (P.DOMEvent -> Boolean -> Action)
    , invalidPageAction :: (P.DOMEvent -> Action)
    , disabled :: Boolean
    }

txPaginationView :: PaginationViewProps -> P.HTML Action
txPaginationView props =
    S.div ! S.className "transaction-pagination"
          $ paginationView props

paginationView :: PaginationViewProps -> P.HTML Action
paginationView props =
    S.div ! S.className "pagination-wrapper" $ do
          S.div ! S.className "pagination" $ do
                S.div ! S.className "pagination__container" $ do
                      S.div ! S.className ("btn-page" <> disablePrevBtnClazz)
                              #! P.onClick prevClickHandler
                              $ S.div ! S.className "icon bg-triangle-left"
                                      $ mempty
                      (S.input !? props.editable) (S.value <<< show $ unwrap props.currentPage)
                            ! S.className "page-number"
                            ! S.disabled (show $ props.maxPage == props.minPage)
                            ! S.min (show $ unwrap props.minPage)
                            ! S.max (show $ unwrap props.maxPage)
                            #! P.onFocus (\ev -> props.editableAction ev true)
                            #! P.onBlur (\ev -> props.editableAction ev false)
                            #! P.onKeyDown onKeyDownHandler
                      S.p ! S.className "label"
                          $ S.text props.label
                      S.input ! S.className "page-number"
                              ! S.disabled (show true)
                              ! S.type' "search"
                              ! S.value (show $ unwrap props.maxPage)
                      S.div ! S.className ("btn-page" <> disableNextBtnClazz)
                            #! P.onClick nextClickHandler
                            $ S.div ! S.className "icon bg-triangle-right"
                                    $ mempty
          S.div ! S.className ("pagination-cover" <> if props.disabled then " show" else "")
                #! P.onClick (const NoOp) -- add click handler to hide clickes from children
                $ mempty
          where
              disablePrevBtnClazz = if props.currentPage == props.minPage then " disabled" else ""
              disableNextBtnClazz = if props.currentPage == props.maxPage then " disabled" else ""
              nextClickHandler :: P.DOMEvent -> Action
              nextClickHandler event =
                  if props.currentPage < props.maxPage then
                  props.changePageAction <<< PageNumber $ (unwrap props.currentPage) + 1
                  else
                  NoOp

              prevClickHandler :: P.DOMEvent -> Action
              prevClickHandler _ =
                  if props.currentPage > props.minPage && not props.disabled then
                  props.changePageAction <<< PageNumber $ (unwrap props.currentPage) - 1
                  else
                  NoOp

              onKeyDownHandler :: P.DOMEvent -> Action
              onKeyDownHandler event =
                  if props.disabled
                      then NoOp
                      else
                          if enterKeyPressed event
                          then
                              let page = PageNumber <<< fromMaybe (unwrap props.currentPage) <<< fromString $ P.targetValue event in
                              if page >= props.minPage && page <= props.maxPage
                                  then props.changePageAction page
                                  else props.invalidPageAction event
                          else NoOp

getMaxPaginationNumber :: Int -> Int -> Int
getMaxPaginationNumber quantity max =
    ceil (toNumber quantity / toNumber max)

-- -----------------
-- txs empty view
-- -----------------

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

-- -----------------
-- logo
-- -----------------

logoView' :: Maybe Route -> P.HTML Action
logoView' mRoute =
    let logoContentTag = case mRoute of
                              Just route ->
                                  S.a ! S.href (toUrl route)
                                      #! P.onClick (Navigate $ toUrl route)
                                      $ mempty
                              Nothing ->
                                  S.div $ mempty
    in
    S.div ! S.className "logo__container"
          $ S.div ! S.className "logo__wrapper"
                  $ logoContentTag  ! S.className "logo__img bg-logo"
                                    ! S.href (toUrl Dashboard)

logoView :: P.HTML Action
logoView = logoView' Nothing

clickableLogoView :: Route -> P.HTML Action
clickableLogoView = logoView' <<< Just

-- -----------------
-- lang
-- -----------------

-- currency

langItems :: Array Language
langItems =
    [ English
    , Japanese
    , German
    ]

langView :: State -> P.HTML Action
langView state =
    S.select  ! S.className "lang__select bg-arrow-up"
              #! P.onChange (SetLanguage <<< fromMaybe (_.lang initialState) <<< readLanguage <<< P.targetValue)
              $ for_ langItems (langItemView state)

langItemView :: State -> Language -> P.HTML Action
langItemView state lang' =
  let selected = (show lang') == (show $ state ^. lang) in
  (S.option !? selected) (S.className "selected")
      ! S.value (show lang')
      ! S.selected (show selected)
      $ S.text (show lang')

-- -----------------
-- helper
-- -----------------

newtype EmptyViewProps = EmptyViewProps {}

mkEmptyViewProps :: EmptyViewProps
mkEmptyViewProps = EmptyViewProps {}

noData :: String
noData = "--"

-- | Helper to add currency classes
currencyCSSClass :: Maybe CCurrency -> String
currencyCSSClass mCurrency =
  case mCurrency of
      Just ADA -> "ada bg-ada-dark"
      Just USD -> "usd bg-usd-dark"
      _ -> ""

-- TODO (jk) Remove placeholderView if all views are implemented
placeholderView :: String -> P.HTML Action
placeholderView label =
    S.div ! S.className "explorer-dashboard__content"
          $ S.text label

emptyView :: P.HTML Action
emptyView = S.div $ mempty

module Explorer.View.Common (
    placeholderView
    , txHeaderView
    , txBodyView
    , emptyTxBodyView
    , emptyTxHeaderView
    , emptyView
    , getMaxPaginationNumber
    , mkTxHeaderViewProps
    , class TxHeaderViewPropsFactory
    , mkTxBodyViewProps
    , class TxBodyViewPropsFactory
    , currencyCSSClass
    , paginationView
    , txPaginationView
    , EmptyViewProps
    , mkEmptyViewProps
    , txEmptyContentView
    , noData
    , logoView
    , clickableLogoView
    , langView
    ) where

import Prelude

import Data.Foldable (for_)
import Data.Int (ceil, fromString, toNumber)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..))

import Explorer.I18n.Lang (Language(..), readLanguage, translate)
import Explorer.I18n.Lenses (common, cDateFormat) as I18nL
import Explorer.Lenses.State (lang)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (initialState)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), PageNumber(..), State)
import Explorer.Util.DOM (enterKeyPressed)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkCoin)
import Explorer.Util.String (formatADA)
import Explorer.Util.Time (prettyDate)
import Explorer.View.Lenses (txbAmount, txbInputs, txbOutputs, txhAmount, txhHash, txhTimeIssued)
import Exporer.View.Types (TxBodyViewProps(..), TxHeaderViewProps(..))

import Pos.Explorer.Web.ClientTypes (CCoin, CAddress(..), CTxBrief(..), CTxEntry(..), CTxSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId, ctbId, ctbInputs, ctbOutputs, ctbOutputSum, ctbTimeIssued, cteId, cteTimeIssued, ctsBlockTimeIssued, ctsId, ctsInputs, ctsOutputs, ctsTotalOutput)

import Pux.DOM.Events (DOMEvent, onBlur, onChange, onFocus, onKeyDown, onClick, targetValue) as P
import Pux.DOM.HTML (HTML) as P

import Text.Smolder.HTML (a, div, p, span, input, option, select) as S
import Text.Smolder.HTML.Attributes (className, href, value, disabled, type', min, max) as S
import Text.Smolder.Markup (text) as S
import Text.Smolder.Markup ((#!), (!), (!?))

-- -----------------
-- tx header
-- -----------------

-- | Factory to create TxHeaderViewProps by a given type
class TxHeaderViewPropsFactory a where
    mkTxHeaderViewProps :: a -> TxHeaderViewProps

-- | Creates a TxHeaderViewProps by a given CTxEntry
instance cTxEntryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxEntry where
    mkTxHeaderViewProps (CTxEntry entry) = TxHeaderViewProps
        { txhHash: entry ^. cteId
        , txhTimeIssued: Just $ entry ^. cteTimeIssued
        , txhAmount: entry . cteAmount
        }

-- | Creates a TxHeaderViewProps by a given CTxBrief
instance cTxBriefTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxBrief where
    mkTxHeaderViewProps (CTxBrief txBrief) = TxHeaderViewProps
        { txhHash: txBrief ^. ctbId
        , txhTimeIssued: Just $ txBrief ^. ctbTimeIssued
        , txhAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxHeaderViewProps by a given CTxSummary
instance cTxSummaryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxSummary where
    mkTxHeaderViewProps (CTxSummary txSummary) = TxHeaderViewProps
        { txhHash: txSummary ^. ctsId
        , txhTimeIssued: txSummary ^. ctsBlockTimeIssued
        , txhAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxHeaderViewProps by a given EmptyViewProps
instance emtpyTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory EmptyViewProps where
    mkTxHeaderViewProps _ = TxHeaderViewProps
        { txhHash: mkCTxId noData
        , txhTimeIssued: Nothing
        , txhAmount: mkCoin "0"
        }

txHeaderView :: Language -> TxHeaderViewProps -> P.HTML Action
txHeaderView lang (TxHeaderViewProps props) =
    S.div ! S.className "transaction-header" $ do
        S.div ! S.className "hash-container"
              $ S.a ! S.href (toUrl txRoute)
              #! P.onClick (Navigate $ toUrl txRoute)
              ! S.className "hash"
              $ S.text (props ^. (txhHash <<< _CTxId <<< _CHash))
        S.div ! S.className "date"
              $ S.text $ case props ^. txhTimeIssued of
                              Just time ->
                                  let format = translate (I18nL.common <<< I18nL.cDateFormat) lang
                                  in fromMaybe noData $ prettyDate format time
                              Nothing -> noData
        txAmountView (props ^. txhAmount) lang
    where
        txRoute = Tx $ props ^. txhHash

emptyTxHeaderView :: P.HTML Action
emptyTxHeaderView =
    S.div ! S.className "transaction-header"
          $ mempty

txAmountView :: CCoin -> Language -> P.HTML Action
txAmountView coin lang =
    S.div ! S.className "amount-container"
          $ S.div ! S.className "amount bg-ada"
                  $ S.text (formatADA coin lang)

-- -----------------
-- tx body
-- -----------------

-- | Factory to create TxBodyViewProps by a given type
class TxBodyViewPropsFactory a where
    mkTxBodyViewProps :: a -> TxBodyViewProps

-- | Creates a TxBodyViewProps by a given CTxSummary
instance cTxSummaryTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxSummary where
    mkTxBodyViewProps (CTxSummary txSummary) = TxBodyViewProps
        { txbInputs: txSummary ^. ctsInputs
        , txbOutputs: txSummary ^. ctsOutputs
        , txbAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxBodyViewProps by a given CTxBrief
instance cTxBriefTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxBrief where
    mkTxBodyViewProps (CTxBrief txBrief) = TxBodyViewProps
        { txbInputs: txBrief ^. ctbInputs
        , txbOutputs: txBrief ^. ctbOutputs
        , txbAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxBodyViewProps by a given EmptyViewProps
instance emptyTxBodyViewPropsFactory :: TxBodyViewPropsFactory EmptyViewProps where
    mkTxBodyViewProps _ = TxBodyViewProps
        { txbInputs: []
        , txbOutputs: []
        , txbAmount: mkCoin "0"
        }

txBodyView :: Language -> TxBodyViewProps -> P.HTML Action
txBodyView lang (TxBodyViewProps props) =
    S.div ! S.className "transaction-body" $ do
        S.div ! S.className "from-hash-container"
              $ for_ (props ^. txbInputs) txFromView
        S.div ! S.className "to-hash-container bg-transaction-arrow"
              $ S.div ! S.className "to-hash-wrapper"
                      $ for_ (props ^. txbOutputs) txToView
        S.div ! S.className "amounts-container"
              $ for_ (props ^. txbOutputs) (txBodyAmountView lang)
        txAmountView (props ^. txbAmount) lang

emptyTxBodyView :: P.HTML Action
emptyTxBodyView =
    S.div ! S.className "transaction-body"
          $ mempty

txFromView :: Tuple CAddress CCoin -> P.HTML Action
txFromView (Tuple (CAddress cAddress) _) =
    let addressRoute = Address $ mkCAddress cAddress in
    S.a ! S.href (toUrl addressRoute)
        #! P.onClick (Navigate $ toUrl addressRoute)
        ! S.className "from-hash"
        $ S.text cAddress

txToView :: Tuple CAddress CCoin -> P.HTML Action
txToView (Tuple (CAddress cAddress) _) =
    let addressRoute = Address $ mkCAddress cAddress in
    S.a ! S.href (toUrl addressRoute)
        #! P.onClick (Navigate $ toUrl addressRoute)
        ! S.className "to-hash"
        $ S.text cAddress

txBodyAmountView :: Language -> Tuple CAddress CCoin -> P.HTML Action
txBodyAmountView lang (Tuple _ coin) =
    S.div ! S.className "amount-wrapper"
          $ S.span  ! S.className "plain-amount bg-ada-dark"
                    $ S.text (formatADA coin lang)

-- -----------------
-- pagination
-- -----------------

type PaginationViewProps =
    { label :: String
    , currentPage :: PageNumber
    , minPage :: PageNumber
    , maxPage :: PageNumber
    , editable :: Boolean
    , changePageAction :: (PageNumber -> Action)
    , editableAction :: (P.DOMEvent -> Boolean -> Action)
    , invalidPageAction :: (P.DOMEvent -> Action)
    , disabled :: Boolean
    }

txPaginationView :: PaginationViewProps -> P.HTML Action
txPaginationView props =
    S.div ! S.className "transaction-pagination"
          $ paginationView props

paginationView :: PaginationViewProps -> P.HTML Action
paginationView props =
    S.div ! S.className "pagination-wrapper" $ do
          S.div ! S.className "pagination" $ do
                S.div ! S.className "pagination__container" $ do
                      S.div ! S.className ("btn-page" <> disablePrevBtnClazz)
                              #! P.onClick prevClickHandler
                              $ S.div ! S.className "icon bg-triangle-left"
                                      $ mempty
                      (S.input !? props.editable) (S.value <<< show $ unwrap props.currentPage)
                            ! S.className "page-number"
                            ! S.disabled (show $ props.maxPage == props.minPage)
                            ! S.min (show $ unwrap props.minPage)
                            ! S.max (show $ unwrap props.maxPage)
                            #! P.onFocus (\ev -> props.editableAction ev true)
                            #! P.onBlur (\ev -> props.editableAction ev false)
                            #! P.onKeyDown onKeyDownHandler
                      S.p ! S.className "label"
                          $ S.text props.label
                      S.input ! S.className "page-number"
                              ! S.disabled (show true)
                              ! S.type' "search"
                              ! S.value (show $ unwrap props.maxPage)
                      S.div ! S.className ("btn-page" <> disableNextBtnClazz)
                            #! P.onClick nextClickHandler
                            $ S.div ! S.className "icon bg-triangle-right"
                                    $ mempty
          S.div ! S.className ("pagination-cover" <> if props.disabled then " show" else "")
                #! P.onClick (const NoOp) -- add click handler to hide clickes from children
                $ mempty
          where
              disablePrevBtnClazz = if props.currentPage == props.minPage then " disabled" else ""
              disableNextBtnClazz = if props.currentPage == props.maxPage then " disabled" else ""
              nextClickHandler :: P.DOMEvent -> Action
              nextClickHandler event =
                  if props.currentPage < props.maxPage then
                  props.changePageAction <<< PageNumber $ (unwrap props.currentPage) + 1
                  else
                  NoOp

              prevClickHandler :: P.DOMEvent -> Action
              prevClickHandler _ =
                  if props.currentPage > props.minPage && not props.disabled then
                  props.changePageAction <<< PageNumber $ (unwrap props.currentPage) - 1
                  else
                  NoOp

              onKeyDownHandler :: P.DOMEvent -> Action
              onKeyDownHandler event =
                  if props.disabled
                      then NoOp
                      else
                          if enterKeyPressed event
                          then
                              let page = PageNumber <<< fromMaybe (unwrap props.currentPage) <<< fromString $ P.targetValue event in
                              if page >= props.minPage && page <= props.maxPage
                                  then props.changePageAction page
                                  else props.invalidPageAction event
                          else NoOp

getMaxPaginationNumber :: Int -> Int -> Int
getMaxPaginationNumber quantity max =
    ceil (toNumber quantity / toNumber max)

-- -----------------
-- txs empty view
-- -----------------

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

-- -----------------
-- logo
-- -----------------

logoView' :: Maybe Route -> P.HTML Action
logoView' mRoute =
    let logoContentTag = case mRoute of
                              Just route ->
                                  S.a ! S.href (toUrl route)
                                      #! P.onClick (Navigate $ toUrl route)
                                      $ mempty
                              Nothing ->
                                  S.div $ mempty
    in
    S.div ! S.className "logo__container"
          $ S.div ! S.className "logo__wrapper"
                  $ logoContentTag  ! S.className "logo__img bg-logo"
                                    ! S.href (toUrl Dashboard)

logoView :: P.HTML Action
logoView = logoView' Nothing

clickableLogoView :: Route -> P.HTML Action
clickableLogoView = logoView' <<< Just

-- -----------------
-- lang
-- -----------------

-- currency

langItems :: Array Language
langItems =
    [ English
    , Japanese
    , German
    ]

langView :: State -> P.HTML Action
langView state =
    S.select  ! S.className "lang__select bg-arrow-up"
              #! P.onChange (SetLanguage <<< fromMaybe (_.lang initialState) <<< readLanguage <<< P.targetValue)
              $ for_ langItems (langItemView state)

langItemView :: State -> Language -> P.HTML Action
langItemView state lang' =
  let selected = (show lang') == (show $ state ^. lang) in
  (S.option !? selected) (S.className "selected")
      ! S.value (show lang')
      $ S.text (show lang')

-- -----------------
-- helper
-- -----------------

newtype EmptyViewProps = EmptyViewProps {}

mkEmptyViewProps :: EmptyViewProps
mkEmptyViewProps = EmptyViewProps {}

noData :: String
noData = "--"

-- | Helper to add currency classes
currencyCSSClass :: Maybe CCurrency -> String
currencyCSSClass mCurrency =
  case mCurrency of
      Just ADA -> "ada bg-ada-dark"
      Just USD -> "usd bg-usd-dark"
      _ -> ""

-- TODO (jk) Remove placeholderView if all views are implemented
placeholderView :: String -> P.HTML Action
placeholderView label =
    S.div ! S.className "explorer-dashboard__content"
          $ S.text label

emptyView :: P.HTML Action
emptyView = S.div $ mempty


No longer prevent action on search highlight

{-
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.Card.Next.Component
 ( nextCardComponent
 , module SlamData.Workspace.Card.Next.Component.State
 , module SlamData.Workspace.Card.Next.Component.Query
 ) where

import SlamData.Prelude

import Data.Foldable as F
import Data.Lens ((.~))
import Data.String as Str

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B
import Halogen.Component.Utils as HU

import SlamData.Monad (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Guide as Guide
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.NextAction as NA
import SlamData.Workspace.Card.Next.Component.Query (QueryP, Query(..), _AddCardType, _PresentReason)
import SlamData.Workspace.Card.Next.Component.State (State)
import SlamData.Workspace.Card.Next.Component.State as State
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.InsertableCardType as ICT

import Utils.LocalStorage as LocalStorage

type NextHTML = H.ComponentHTML QueryP
type NextDSL = H.ComponentDSL State QueryP Slam

nextCardComponent ∷ CC.CardComponent
nextCardComponent = CC.makeCardComponent
  { cardType: CT.NextAction
  , component:
      H.component
        { render
        , eval
        }
  , initialState: State.initialState
  , _State: CC._NextState
  , _Query: CC.makeQueryPrism CC._NextQuery
  }

render ∷ State → NextHTML
render state =
  HH.div_
    $ (guard (not state.presentAddCardGuide) $>
      HH.form_
        [ HH.div_
            [ HH.input
                [ HP.value state.filterString
                , HE.onValueInput (HE.input (\s → right ∘ UpdateFilter s))
                , ARIA.label "Filter next actions"
                , HP.placeholder "Filter actions"
                ]
            , HH.button
                [ HP.buttonType HP.ButtonButton
                , HE.onClick (HE.input_ (right ∘ UpdateFilter ""))
                ]
                [ glyph B.glyphiconRemove ]
            ]
        ])
    ⊕ (guard state.presentAddCardGuide $>
        Guide.render
          Guide.DownArrow
          (HH.className "sd-add-card-guide")
          (right ∘ DismissAddCardGuide)
          (addCardGuideText state.input))
    ⊕ [ HH.ul_ $ map nextButton state.actions ]
  where

  filterString ∷ String
  filterString = Str.toLower state.filterString

  cardTitle ∷ NA.NextAction → String
  cardTitle (NA.Insert cty) = "Insert a " ⊕ CT.cardName cty ⊕ " card"
  cardTitle (NA.FindOutHowToInsert cty) = "Find out how to insert a " ⊕ CT.cardName cty ⊕ " card"
  cardTitle (NA.Drill name _ _) = "Select " ⊕ name ⊕ " card category"
  cardTitle (NA.GoBack) = "Go back"

  nextButton ∷ NA.NextAction → NextHTML
  nextButton action =
    HH.li_
      [ HH.button attrs
          [ NA.actionGlyph action
          , HH.p_ [ HH.text $ NA.actionLabel action ]
          ]
      ]
    where
    enabled ∷ Boolean
    enabled = case action of
      NA.GoBack → true
      _ → F.any (Str.contains filterString ∘ Str.toLower) $ NA.searchFilters action

    attrs =
      [ HP.title $ cardTitle action
      , HP.disabled $ not enabled
      , ARIA.label $ cardTitle action
      , HP.classes classes
      , HE.onClick (HE.input_ $ right ∘ Selected action)
      ]

    classes ∷ Array HH.ClassName
    classes = case action of
      NA.FindOutHowToInsert _ →
        nonInsertableClassNames
      NA.Drill _ _ actions | not (F.any NA.isInsert actions) →
        nonInsertableClassNames
      _ →
        insertableClassNames

    insertableClassNames =
      [ HH.className "sd-button" ]

    nonInsertableClassNames =
        [ HH.className "sd-button", HH.className "sd-button-warning" ]

  addCardGuideTextEmptyDeck = "To get this deck started press one of these buttons to add a card."
  addCardGuideTextNonEmptyDeck = "To do more with this deck press one of these buttons to add a card."
  addCardGuideText = maybe addCardGuideTextEmptyDeck (const addCardGuideTextNonEmptyDeck)

eval ∷ QueryP ~> NextDSL
eval = coproduct cardEval nextEval

cardEval ∷ CC.CardEvalQuery ~> NextDSL
cardEval = case _ of
  CC.EvalCard value output next →
    (H.modify
       $ (State._input .~ value.input)
       ∘ (State._actions .~ NA.fromMaybePort value.input))
       $> next
  CC.Activate next →
    H.modify (\st → st { actions = NA.fromMaybePort st.input }) $> next
  CC.Deactivate next →
    pure next
  CC.Save k →
    pure $ k Card.NextAction
  CC.Load _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

takesInput ∷ Maybe Port.Port → CT.CardType → Boolean
takesInput input =
  maybe false (ICT.takesInput $ ICT.fromMaybePort input) ∘ ICT.fromCardType

possibleToGetTo ∷ Maybe Port.Port → CT.CardType → Boolean
possibleToGetTo input =
  maybe false (ICT.possibleToGetTo $ ICT.fromMaybePort input) ∘ ICT.fromCardType

dismissedAddCardGuideKey ∷ String
dismissedAddCardGuideKey = "dismissedAddCardGuide"

getDismissedAddCardGuideBefore ∷ NextDSL Boolean
getDismissedAddCardGuideBefore =
  H.liftH
    $ either (const $ false) id
    <$> LocalStorage.getLocalStorage dismissedAddCardGuideKey

storeDismissedAddCardGuide ∷ NextDSL Unit
storeDismissedAddCardGuide =
  H.liftH $ LocalStorage.setLocalStorage dismissedAddCardGuideKey true

dismissAddCardGuide ∷ NextDSL Unit
dismissAddCardGuide =
  H.modify (State._presentAddCardGuide .~ false)
    *> storeDismissedAddCardGuide

nextEval ∷ Query ~> NextDSL
nextEval (AddCard _ next) = dismissAddCardGuide $> next
nextEval (PresentReason io card next) = pure next
nextEval (UpdateFilter str next) =
  H.modify (State._filterString .~ str) $> next
nextEval (DismissAddCardGuide next) = dismissAddCardGuide $> next
nextEval (PresentAddCardGuide next) =
  (H.modify
     ∘ (State._presentAddCardGuide .~ _)
     ∘ not =<< getDismissedAddCardGuideBefore)
     $> next
nextEval (Selected action next) = do
  st ← H.get
  case action of
    NA.Insert cardType →
      HU.raise $ right $ H.action $ AddCard cardType
    NA.FindOutHowToInsert cardType →
      HU.raise $ right $ H.action $ PresentReason st.input cardType
    NA.Drill _ _ actions →
      H.modify $ (State._actions .~ actions) ∘ (State._previousActions .~ st.actions)
    NA.GoBack →
      H.modify
        $ (State._actions .~ st.previousActions)
        ∘ (State._previousActions .~ [ ])
  pure next

{-
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.Card.Next.Component
 ( nextCardComponent
 , module SlamData.Workspace.Card.Next.Component.State
 , module SlamData.Workspace.Card.Next.Component.Query
 ) where

import SlamData.Prelude

import Data.Foldable as F
import Data.Lens ((.~))
import Data.String as Str

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B
import Halogen.Component.Utils as HU

import SlamData.Monad (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Guide as Guide
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.NextAction as NA
import SlamData.Workspace.Card.Next.Component.Query (QueryP, Query(..), _AddCardType, _PresentReason)
import SlamData.Workspace.Card.Next.Component.State (State)
import SlamData.Workspace.Card.Next.Component.State as State
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.InsertableCardType as ICT

import Utils.LocalStorage as LocalStorage

type NextHTML = H.ComponentHTML QueryP
type NextDSL = H.ComponentDSL State QueryP Slam

nextCardComponent ∷ CC.CardComponent
nextCardComponent = CC.makeCardComponent
  { cardType: CT.NextAction
  , component:
      H.component
        { render
        , eval
        }
  , initialState: State.initialState
  , _State: CC._NextState
  , _Query: CC.makeQueryPrism CC._NextQuery
  }

render ∷ State → NextHTML
render state =
  HH.div_
    $ (guard (not state.presentAddCardGuide) $>
      HH.form_
        [ HH.div_
            [ HH.input
                [ HP.value state.filterString
                , HE.onValueInput (HE.input (\s → right ∘ UpdateFilter s))
                , ARIA.label "Filter next actions"
                , HP.placeholder "Filter actions"
                ]
            , HH.button
                [ HP.buttonType HP.ButtonButton
                , HE.onClick (HE.input_ (right ∘ UpdateFilter ""))
                ]
                [ glyph B.glyphiconRemove ]
            ]
        ])
    ⊕ (guard state.presentAddCardGuide $>
        Guide.render
          Guide.DownArrow
          (HH.className "sd-add-card-guide")
          (right ∘ DismissAddCardGuide)
          (addCardGuideText state.input))
    ⊕ [ HH.ul_ $ map nextButton state.actions ]
  where

  filterString ∷ String
  filterString = Str.toLower state.filterString

  cardTitle ∷ NA.NextAction → String
  cardTitle (NA.Insert cty) = "Insert a " ⊕ CT.cardName cty ⊕ " card"
  cardTitle (NA.FindOutHowToInsert cty) = "Find out how to insert a " ⊕ CT.cardName cty ⊕ " card"
  cardTitle (NA.Drill name _ _) = "Select " ⊕ name ⊕ " card category"
  cardTitle (NA.GoBack) = "Go back"

  nextButton ∷ NA.NextAction → NextHTML
  nextButton action =
    HH.li_
      [ HH.button attrs
          [ NA.actionGlyph action
          , HH.p_ [ HH.text $ NA.actionLabel action ]
          ]
      ]
    where
    enabled ∷ Boolean
    enabled = case action of
      NA.GoBack → true
      _ → F.any (Str.contains filterString ∘ Str.toLower) $ NA.searchFilters action

    attrs =
      [ HP.title $ cardTitle action
      , HP.disabled $ not enabled
      , ARIA.label $ cardTitle action
      , HP.classes classes
      ] ⊕ (guard
            (NA.isInsert action ∨ NA.isDrill action)
            $> HE.onClick (HE.input_ (right ∘ Selected action)))

    classes ∷ Array HH.ClassName
    classes = case action of
      NA.FindOutHowToInsert _ →
        nonInsertableClassNames
      NA.Drill _ _ actions | not (F.any NA.isInsert actions) →
        nonInsertableClassNames
      _ →
        insertableClassNames

    insertableClassNames =
      [ HH.className "sd-button" ]

    nonInsertableClassNames =
        [ HH.className "sd-button", HH.className "sd-button-warning" ]

  addCardGuideTextEmptyDeck = "To get this deck started press one of these buttons to add a card."
  addCardGuideTextNonEmptyDeck = "To do more with this deck press one of these buttons to add a card."
  addCardGuideText = maybe addCardGuideTextEmptyDeck (const addCardGuideTextNonEmptyDeck)

eval ∷ QueryP ~> NextDSL
eval = coproduct cardEval nextEval

cardEval ∷ CC.CardEvalQuery ~> NextDSL
cardEval = case _ of
  CC.EvalCard value output next →
    (H.modify
       $ (State._input .~ value.input)
       ∘ (State._actions .~ NA.fromMaybePort value.input))
       $> next
  CC.Activate next →
    H.modify (\st → st { actions = NA.fromMaybePort st.input }) $> next
  CC.Deactivate next →
    pure next
  CC.Save k →
    pure $ k Card.NextAction
  CC.Load _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

takesInput ∷ Maybe Port.Port → CT.CardType → Boolean
takesInput input =
  maybe false (ICT.takesInput $ ICT.fromMaybePort input) ∘ ICT.fromCardType

possibleToGetTo ∷ Maybe Port.Port → CT.CardType → Boolean
possibleToGetTo input =
  maybe false (ICT.possibleToGetTo $ ICT.fromMaybePort input) ∘ ICT.fromCardType

dismissedAddCardGuideKey ∷ String
dismissedAddCardGuideKey = "dismissedAddCardGuide"

getDismissedAddCardGuideBefore ∷ NextDSL Boolean
getDismissedAddCardGuideBefore =
  H.liftH
    $ either (const $ false) id
    <$> LocalStorage.getLocalStorage dismissedAddCardGuideKey

storeDismissedAddCardGuide ∷ NextDSL Unit
storeDismissedAddCardGuide =
  H.liftH $ LocalStorage.setLocalStorage dismissedAddCardGuideKey true

dismissAddCardGuide ∷ NextDSL Unit
dismissAddCardGuide =
  H.modify (State._presentAddCardGuide .~ false)
    *> storeDismissedAddCardGuide

nextEval ∷ Query ~> NextDSL
nextEval (AddCard _ next) = dismissAddCardGuide $> next
nextEval (PresentReason io card next) = pure next
nextEval (UpdateFilter str next) =
  H.modify (State._filterString .~ str) $> next
nextEval (DismissAddCardGuide next) = dismissAddCardGuide $> next
nextEval (PresentAddCardGuide next) =
  (H.modify
     ∘ (State._presentAddCardGuide .~ _)
     ∘ not =<< getDismissedAddCardGuideBefore)
     $> next
nextEval (Selected action next) = do
  st ← H.get
  case action of
    NA.Insert cardType →
      HU.raise $ right $ H.action $ AddCard cardType
    NA.FindOutHowToInsert cardType →
      HU.raise $ right $ H.action $ PresentReason st.input cardType
    NA.Drill _ _ actions →
      H.modify $ (State._actions .~ actions) ∘ (State._previousActions .~ st.actions)
    NA.GoBack →
      H.modify
        $ (State._actions .~ st.previousActions)
        ∘ (State._previousActions .~ [ ])
  pure next


add fiberCanceler (#165)

add fiberCanceler (#165)

module Effect.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , supervise
  , attempt
  , apathize
  , delay
  , never
  , finally
  , invincible
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , effectCanceler
  , fiberCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Lazy (class Lazy)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try, throwError, catchError) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Parallel.Class (sequential, parallel) as Exports
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Data.Time.Duration (Milliseconds(..)) as Exports
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error, error)
import Effect.Exception (Error, error, message) as Exports
import Effect.Unsafe (unsafePerformEffect)
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff a` is an asynchronous computation with effects. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Effect` effects using
-- | `makeAff` or `liftEffect`.
foreign import data Aff ∷ Type → Type

instance functorAff ∷ Functor Aff where
  map = _map

instance applyAff ∷ Apply Aff where
  apply = ap

instance applicativeAff ∷ Applicative Aff where
  pure = _pure

instance bindAff ∷ Bind Aff where
  bind = _bind

instance monadAff ∷ Monad Aff

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff a) where
  mempty = pure mempty

instance altAff ∷ Alt Aff where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus Aff where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec Aff where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error Aff where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error Aff where
  catchError = _catchError

instance monadEffectAff ∷ MonadEffect Aff where
  liftEffect = _liftEffect

instance lazyAff ∷ Lazy (Aff a) where
  defer f = pure unit >>= f

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ Type → Type

instance functorParAff ∷ Functor ParAff where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply ParAff where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative ParAff where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt ParAff where
  alt = _parAffAlt

instance plusParAff ∷ Plus ParAff where
  empty = parallel empty

instance alternativeParAff ∷ Alternative ParAff

instance parallelAff ∷ Parallel ParAff Aff where
  parallel = (unsafeCoerce ∷ ∀ a. Aff a → ParAff a)
  sequential = _sequential

type OnComplete a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Effect Unit) → Effect Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber a = Fiber
  { run ∷ Effect Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Effect Unit) (Effect (Effect Unit))
  , join ∷ (Either Error a → Effect Unit) → Effect (Effect Unit)
  , onComplete ∷ OnComplete a → Effect (Effect Unit)
  , isSuspended ∷ Effect Boolean
  }

instance functorFiber ∷ Functor Fiber where
  map f t = unsafePerformEffect (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply Fiber where
  apply t1 t2 = unsafePerformEffect (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative Fiber where
  pure a = unsafePerformEffect (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ a. Error → Fiber a → Aff Unit
killFiber e (Fiber t) = liftEffect t.isSuspended >>= if _
  then liftEffect $ void $ Fn.runFn2 t.kill e (const (pure unit))
  else makeAff \k → effectCanceler <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ Fiber ~> Aff
joinFiber (Fiber t) = makeAff \k → effectCanceler <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler = Canceler (Error → Aff Unit)

derive instance newtypeCanceler ∷ Newtype Canceler _

instance semigroupCanceler ∷ Semigroup Canceler where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid Canceler where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ Canceler
nonCanceler = Canceler (const (pure unit))

-- | A canceler from an Effect action.
effectCanceler ∷ Effect Unit → Canceler
effectCanceler = Canceler <<< const <<< liftEffect

-- | A canceler from a Fiber.
fiberCanceler ∷ ∀ a. Fiber a → Canceler
fiberCanceler = Canceler <<< flip killFiber

-- | Forks an `Aff` from an `Effect` context, returning the `Fiber`.
launchAff ∷ ∀ a. Aff a → Effect (Fiber a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Effect` context, discarding the `Fiber`.
launchAff_ ∷ ∀ a. Aff a → Effect Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Effect` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ a. Aff a → Effect (Fiber a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit)
runAff k aff = launchAff $ liftEffect <<< k =<< try aff

-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Effect` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEffect <<< k =<< try aff

-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ a. Aff a → Aff (Fiber a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ a. Aff a → Aff (Fiber a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ Milliseconds → Aff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ a. Aff a
never = makeAff \_ → pure mempty

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ a. Aff a → Aff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ a. Aff a → Aff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ a. Aff Unit → Aff a → Aff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
invincible ∷ ∀ a. Aff a → Aff a
invincible a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ a. Aff a → Canceler → Aff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ a b. Aff a → (a → Aff Unit) → (a → Aff b) → Aff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised a =
  { fiber ∷ Fiber a
  , supervisor ∷ Supervisor
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ a. Aff a → Aff a
supervise aff =
  generalBracket (liftEffect acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised a → Aff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Effect (Supervised a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ Type
foreign import _pure ∷ ∀ a. a → Aff a
foreign import _throwError ∷ ∀ a. Error → Aff a
foreign import _catchError ∷ ∀ a. Aff a → (Error → Aff a) → Aff a
foreign import _fork ∷ ∀ a. Boolean → Aff a → Aff (Fiber a)
foreign import _map ∷ ∀ a b. (a → b) → Aff a → Aff b
foreign import _bind ∷ ∀ a b. Aff a → (a → Aff b) → Aff b
foreign import _delay ∷ ∀ a. Fn.Fn2 (Unit → Either a Unit) Number (Aff Unit)
foreign import _liftEffect ∷ ∀ a. Effect a → Aff a
foreign import _parAffMap ∷ ∀ a b. (a → b) → ParAff a → ParAff b
foreign import _parAffApply ∷ ∀ a b. ParAff (a → b) → ParAff a → ParAff b
foreign import _parAffAlt ∷ ∀ a. ParAff a → ParAff a → ParAff a
foreign import _makeFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Fiber a))
foreign import _makeSupervisedFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Supervised a))
foreign import _killAll ∷ Fn.Fn3 Error Supervisor (Effect Unit) (Effect Canceler)
foreign import _sequential ∷ ParAff ~> Aff

type BracketConditions a b =
  { killed ∷ Error → a → Aff Unit
  , failed ∷ Error → a → Aff Unit
  , completed ∷ b → a → Aff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ a b. Aff a → BracketConditions a b → (a → Aff b) → Aff b

-- | Constructs an `Aff` from low-level `Effect` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ a. ((Either Error a → Effect Unit) → Effect Canceler) → Aff a

makeFiber ∷ ∀ a. Aff a → Effect (Fiber a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"

module Effect.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , supervise
  , attempt
  , apathize
  , delay
  , never
  , finally
  , invincible
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , effectCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Lazy (class Lazy)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try, throwError, catchError) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Parallel.Class (sequential, parallel) as Exports
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Data.Time.Duration (Milliseconds(..)) as Exports
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error, error)
import Effect.Exception (Error, error, message) as Exports
import Effect.Unsafe (unsafePerformEffect)
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff a` is an asynchronous computation with effects. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Effect` effects using
-- | `makeAff` or `liftEffect`.
foreign import data Aff ∷ Type → Type

instance functorAff ∷ Functor Aff where
  map = _map

instance applyAff ∷ Apply Aff where
  apply = ap

instance applicativeAff ∷ Applicative Aff where
  pure = _pure

instance bindAff ∷ Bind Aff where
  bind = _bind

instance monadAff ∷ Monad Aff

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff a) where
  mempty = pure mempty

instance altAff ∷ Alt Aff where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus Aff where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec Aff where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error Aff where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error Aff where
  catchError = _catchError

instance monadEffectAff ∷ MonadEffect Aff where
  liftEffect = _liftEffect

instance lazyAff ∷ Lazy (Aff a) where
  defer f = pure unit >>= f

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ Type → Type

instance functorParAff ∷ Functor ParAff where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply ParAff where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative ParAff where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt ParAff where
  alt = _parAffAlt

instance plusParAff ∷ Plus ParAff where
  empty = parallel empty

instance alternativeParAff ∷ Alternative ParAff

instance parallelAff ∷ Parallel ParAff Aff where
  parallel = (unsafeCoerce ∷ ∀ a. Aff a → ParAff a)
  sequential = _sequential

type OnComplete a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Effect Unit) → Effect Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber a = Fiber
  { run ∷ Effect Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Effect Unit) (Effect (Effect Unit))
  , join ∷ (Either Error a → Effect Unit) → Effect (Effect Unit)
  , onComplete ∷ OnComplete a → Effect (Effect Unit)
  , isSuspended ∷ Effect Boolean
  }

instance functorFiber ∷ Functor Fiber where
  map f t = unsafePerformEffect (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply Fiber where
  apply t1 t2 = unsafePerformEffect (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative Fiber where
  pure a = unsafePerformEffect (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ a. Error → Fiber a → Aff Unit
killFiber e (Fiber t) = liftEffect t.isSuspended >>= if _
  then liftEffect $ void $ Fn.runFn2 t.kill e (const (pure unit))
  else makeAff \k → effectCanceler <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ Fiber ~> Aff
joinFiber (Fiber t) = makeAff \k → effectCanceler <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler = Canceler (Error → Aff Unit)

derive instance newtypeCanceler ∷ Newtype Canceler _

instance semigroupCanceler ∷ Semigroup Canceler where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid Canceler where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ Canceler
nonCanceler = Canceler (const (pure unit))

-- | A canceler from an Effect action.
effectCanceler ∷ Effect Unit → Canceler
effectCanceler = Canceler <<< const <<< liftEffect

-- | Forks an `Aff` from an `Effect` context, returning the `Fiber`.
launchAff ∷ ∀ a. Aff a → Effect (Fiber a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Effect` context, discarding the `Fiber`.
launchAff_ ∷ ∀ a. Aff a → Effect Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Effect` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ a. Aff a → Effect (Fiber a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit)
runAff k aff = launchAff $ liftEffect <<< k =<< try aff

-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Effect` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEffect <<< k =<< try aff

-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ a. Aff a → Aff (Fiber a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ a. Aff a → Aff (Fiber a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ Milliseconds → Aff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ a. Aff a
never = makeAff \_ → pure mempty

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ a. Aff a → Aff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ a. Aff a → Aff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ a. Aff Unit → Aff a → Aff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
invincible ∷ ∀ a. Aff a → Aff a
invincible a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ a. Aff a → Canceler → Aff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ a b. Aff a → (a → Aff Unit) → (a → Aff b) → Aff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised a =
  { fiber ∷ Fiber a
  , supervisor ∷ Supervisor
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ a. Aff a → Aff a
supervise aff =
  generalBracket (liftEffect acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised a → Aff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Effect (Supervised a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ Type
foreign import _pure ∷ ∀ a. a → Aff a
foreign import _throwError ∷ ∀ a. Error → Aff a
foreign import _catchError ∷ ∀ a. Aff a → (Error → Aff a) → Aff a
foreign import _fork ∷ ∀ a. Boolean → Aff a → Aff (Fiber a)
foreign import _map ∷ ∀ a b. (a → b) → Aff a → Aff b
foreign import _bind ∷ ∀ a b. Aff a → (a → Aff b) → Aff b
foreign import _delay ∷ ∀ a. Fn.Fn2 (Unit → Either a Unit) Number (Aff Unit)
foreign import _liftEffect ∷ ∀ a. Effect a → Aff a
foreign import _parAffMap ∷ ∀ a b. (a → b) → ParAff a → ParAff b
foreign import _parAffApply ∷ ∀ a b. ParAff (a → b) → ParAff a → ParAff b
foreign import _parAffAlt ∷ ∀ a. ParAff a → ParAff a → ParAff a
foreign import _makeFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Fiber a))
foreign import _makeSupervisedFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Supervised a))
foreign import _killAll ∷ Fn.Fn3 Error Supervisor (Effect Unit) (Effect Canceler)
foreign import _sequential ∷ ParAff ~> Aff

type BracketConditions a b =
  { killed ∷ Error → a → Aff Unit
  , failed ∷ Error → a → Aff Unit
  , completed ∷ b → a → Aff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ a b. Aff a → BracketConditions a b → (a → Aff b) → Aff b

-- | Constructs an `Aff` from low-level `Effect` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ a. ((Either Error a → Effect Unit) → Effect Canceler) → Aff a

makeFiber ∷ ∀ a. Aff a → Effect (Fiber a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"