[CSE-157] Fix psc warnings

[CSE-157] Fix psc warnings

module Explorer.View.Search
    ( searchInputView
    , searchItemViews
    ) where

import Prelude
import DOM.Node.Types (ElementId(..))
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Data.String (length)
import Data.Tuple (Tuple(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cAddress, cEpoch, cSlot, cTransaction, common, hero, hrSearch, hrTime) as I18nL
import Explorer.Lenses.State (gViewMobileMenuOpenend, gViewSearchInputFocused, gViewSearchQuery, gViewSearchTimeQuery, gViewSelectedSearch, globalViewState, lang, viewStates)
import Explorer.State (maxSlotInEpoch)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (Search(..), State)
import Explorer.View.Common (emptyView)
import Pux.Html (Html, div, input, label, li, text, ul) as P
import Pux.Html.Attributes (className, htmlFor, id_, maxLength, name, placeholder, type_, value) as P
import Pux.Html.Events (onChange, onClick, onFocus, onBlur, onKey) as P

inputEpochName :: String
inputEpochName = "inp_epoch"

inputSlotName :: String
inputSlotName = "inp_slot"

searchInputView :: ElementId -> State -> P.Html Action
searchInputView (ElementId viewId) state =
    let lang' = state ^. lang
        dbViewSearchInputFocused = state ^. (viewStates <<< globalViewState <<< gViewSearchInputFocused)
        mobileMenuOpened = state ^. (viewStates <<< globalViewState <<< gViewMobileMenuOpenend)
        selectedSearch = state ^. (viewStates <<< globalViewState <<< gViewSelectedSearch)
        addrHiddenClazz = if selectedSearch == SearchTime  then " hide " else ""
        epochHiddenClazz = if selectedSearch /= SearchTime  then " hide " else ""
        focusedClazz = if dbViewSearchInputFocused then " focused " else ""
        searchTimeQuery = state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
    in
    P.div
        [ P.className $ "explorer-search__container" <> focusedClazz
        , P.id_ viewId
        ]
        [ P.input
            [ P.className $ "explorer-search__input explorer-search__input--address-tx"
                          <> addrHiddenClazz <> focusedClazz
            , P.type_ "text"
            , P.placeholder $ if dbViewSearchInputFocused
                              then ""
                              else translate (I18nL.hero <<< I18nL.hrSearch) lang'
            , P.onFocus <<< const $
                  if mobileMenuOpened
                  then GlobalFocusSearchInput true
                  else NoOp
            , P.onBlur <<< const $
                  if mobileMenuOpened
                  then GlobalFocusSearchInput false
                  else NoOp
            , P.onChange $ GlobalUpdateSearchValue <<< _.value <<< _.target
            , P.onKey "enter" $ const GlobalSearch
            , P.value $ state ^. (viewStates <<< globalViewState <<< gViewSearchQuery)
            ]
            []
        , P.div
            [ P.className $ "explorer-search__wrapper" <> epochHiddenClazz
            ]
            [ P.label
                [ P.className $ "explorer-search__label"
                , P.htmlFor inputEpochName
                ]
                [ P.text $ translate (I18nL.common <<< I18nL.cEpoch) lang' ]
            , P.input
                [ P.className $ "explorer-search__input explorer-search__input--epoch"
                              <> focusedClazz
                , P.type_ "text"
                , P.name inputEpochName
                , P.onFocus <<< const $
                      if mobileMenuOpened
                      then GlobalFocusSearchInput true
                      else NoOp
                , P.onBlur <<< const $
                      if mobileMenuOpened
                      then GlobalFocusSearchInput false
                      else NoOp
                , P.onChange $ GlobalUpdateSearchEpochValue <<< _.value <<< _.target
                , P.onKey "enter" $ const GlobalSearchTime
                , P.value $ case searchTimeQuery of
                            Tuple (Just epoch) _ -> show epoch
                            _ -> ""
                ]
                []
            , P.label
                [ P.className $ "explorer-search__label"
                , P.htmlFor inputSlotName
                ]
                [ P.text $ translate (I18nL.common <<< I18nL.cSlot) lang' ]
            , P.input
                [ P.className $ "explorer-search__input explorer-search__input--slot"
                              <> focusedClazz
                , P.type_ "text"
                , P.name inputSlotName
                , P.maxLength <<< show <<< length $ show maxSlotInEpoch
                , P.onFocus <<< const $
                      if mobileMenuOpened
                      then GlobalFocusSearchInput true
                      else NoOp
                , P.onBlur <<< const $
                      if mobileMenuOpened
                      then GlobalFocusSearchInput false
                      else NoOp
                , P.onChange $ GlobalUpdateSearchSlotValue <<< _.value <<< _.target
                , P.onKey "enter" $ const GlobalSearchTime
                , P.value $ case searchTimeQuery of
                            Tuple _ (Just slot) -> show slot
                            _ -> ""
                ]
                []
            ]
        , if dbViewSearchInputFocused
          then searchItemViews lang' selectedSearch
          else emptyView
        , P.div
            [ P.className $ "explorer-search__btn bg-icon-search" <> focusedClazz
            , P.onClick <<< const $ if selectedSearch == SearchTime
                                    then GlobalSearchTime
                                    else GlobalSearch
            ]
            []
        ]

type SearchItem =
  { value :: Search
  , label :: String
  }

type SearchItems = Array SearchItem

mkSearchItems :: Language -> SearchItems
mkSearchItems lang =
    [ { value: SearchAddress
      , label: translate (I18nL.common <<< I18nL.cAddress) lang
      }
    , { value: SearchTx
      , label: translate (I18nL.common <<< I18nL.cTransaction) lang
      }
    , { value: SearchTime
      , label: translate (I18nL.hero <<< I18nL.hrTime) lang
      }
    ]

searchItemViews :: Language -> Search -> P.Html Action
searchItemViews lang selectedSearch =
    P.ul
        [ P.className $ "explorer-search-nav__container" ]
        <<< map (\item -> searchItemView item selectedSearch)
            $ mkSearchItems lang

searchItemView :: SearchItem -> Search -> P.Html Action
searchItemView item selectedSearch =
    let selected = item.value == selectedSearch
        selectedClass = if selected then " selected" else ""
    in
    P.li
        [ P.className $ "explorer-search-nav__item"  <> selectedClass
        , P.onClick <<< const $ GlobalUpdateSelectedSearch item.value ]
        [ P.text item.label ]

module Explorer.View.Search
    ( searchInputView
    , searchItemViews
    ) where

import Prelude
import DOM.Node.Types (ElementId(..))
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Data.String (length)
import Data.Tuple (Tuple(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cAddress, cEpoch, cSlot, cTransaction, common, hero, hrSearch, hrTime) as I18nL
import Explorer.Lenses.State (gViewMobileMenuOpenend, gViewSearchInputFocused, gViewSearchQuery, gViewSearchTimeQuery, gViewSelectedSearch, globalViewState, lang, viewStates)
import Explorer.State (maxSlotInEpoch)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (Search(..), State)
import Explorer.View.Common (emptyView)
import Pux.Html (Html, div, span, text, ul, li, label, input) as P
import Pux.Html.Attributes (checked, className, htmlFor, id_, maxLength, name, type_, placeholder, value) as P
import Pux.Html.Events (onChange, onClick, onFocus, onBlur, onKey) as P

inputEpochName :: String
inputEpochName = "inp_epoch"

inputSlotName :: String
inputSlotName = "inp_slot"

searchInputView :: ElementId -> State -> P.Html Action
searchInputView (ElementId viewId) state =
    let lang' = state ^. lang
        dbViewSearchInputFocused = state ^. (viewStates <<< globalViewState <<< gViewSearchInputFocused)
        mobileMenuOpened = state ^. (viewStates <<< globalViewState <<< gViewMobileMenuOpenend)
        selectedSearch = state ^. (viewStates <<< globalViewState <<< gViewSelectedSearch)
        addrHiddenClazz = if selectedSearch == SearchTime  then " hide " else ""
        epochHiddenClazz = if selectedSearch /= SearchTime  then " hide " else ""
        focusedClazz = if dbViewSearchInputFocused then " focused " else ""
        searchTimeQuery = state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
    in
    P.div
        [ P.className $ "explorer-search__container" <> focusedClazz
        , P.id_ viewId
        ]
        [ P.input
            [ P.className $ "explorer-search__input explorer-search__input--address-tx"
                          <> addrHiddenClazz <> focusedClazz
            , P.type_ "text"
            , P.placeholder $ if dbViewSearchInputFocused
                              then ""
                              else translate (I18nL.hero <<< I18nL.hrSearch) lang'
            , P.onFocus <<< const $
                  if mobileMenuOpened
                  then GlobalFocusSearchInput true
                  else NoOp
            , P.onBlur <<< const $
                  if mobileMenuOpened
                  then GlobalFocusSearchInput false
                  else NoOp
            , P.onChange $ GlobalUpdateSearchValue <<< _.value <<< _.target
            , P.onKey "enter" $ const GlobalSearch
            , P.value $ state ^. (viewStates <<< globalViewState <<< gViewSearchQuery)
            ]
            []
        , P.div
            [ P.className $ "explorer-search__wrapper" <> epochHiddenClazz
            ]
            [ P.label
                [ P.className $ "explorer-search__label"
                , P.htmlFor inputEpochName
                ]
                [ P.text $ translate (I18nL.common <<< I18nL.cEpoch) lang' ]
            , P.input
                [ P.className $ "explorer-search__input explorer-search__input--epoch"
                              <> focusedClazz
                , P.type_ "text"
                , P.name inputEpochName
                , P.onFocus <<< const $
                      if mobileMenuOpened
                      then GlobalFocusSearchInput true
                      else NoOp
                , P.onBlur <<< const $
                      if mobileMenuOpened
                      then GlobalFocusSearchInput false
                      else NoOp
                , P.onChange $ GlobalUpdateSearchEpochValue <<< _.value <<< _.target
                , P.onKey "enter" $ const GlobalSearchTime
                , P.value $ case searchTimeQuery of
                            Tuple (Just epoch) _ -> show epoch
                            _ -> ""
                ]
                []
            , P.label
                [ P.className $ "explorer-search__label"
                , P.htmlFor inputSlotName
                ]
                [ P.text $ translate (I18nL.common <<< I18nL.cSlot) lang' ]
            , P.input
                [ P.className $ "explorer-search__input explorer-search__input--slot"
                              <> focusedClazz
                , P.type_ "text"
                , P.name inputSlotName
                , P.maxLength <<< show <<< length $ show maxSlotInEpoch
                , P.onFocus <<< const $
                      if mobileMenuOpened
                      then GlobalFocusSearchInput true
                      else NoOp
                , P.onBlur <<< const $
                      if mobileMenuOpened
                      then GlobalFocusSearchInput false
                      else NoOp
                , P.onChange $ GlobalUpdateSearchSlotValue <<< _.value <<< _.target
                , P.onKey "enter" $ const GlobalSearchTime
                , P.value $ case searchTimeQuery of
                            Tuple _ (Just slot) -> show slot
                            _ -> ""
                ]
                []
            ]
        , if dbViewSearchInputFocused
          then searchItemViews lang' selectedSearch
          else emptyView
        , P.div
            [ P.className $ "explorer-search__btn bg-icon-search" <> focusedClazz
            , P.onClick <<< const $ if selectedSearch == SearchTime
                                    then GlobalSearchTime
                                    else GlobalSearch
            ]
            []
        ]

type SearchItem =
  { value :: Search
  , label :: String
  }

type SearchItems = Array SearchItem

mkSearchItems :: Language -> SearchItems
mkSearchItems lang =
    [ { value: SearchAddress
      , label: translate (I18nL.common <<< I18nL.cAddress) lang
      }
    , { value: SearchTx
      , label: translate (I18nL.common <<< I18nL.cTransaction) lang
      }
    , { value: SearchTime
      , label: translate (I18nL.hero <<< I18nL.hrTime) lang
      }
    ]

searchItemViews :: Language -> Search -> P.Html Action
searchItemViews lang selectedSearch =
    P.ul
        [ P.className $ "explorer-search-nav__container" ]
        <<< map (\item -> searchItemView item selectedSearch)
            $ mkSearchItems lang

searchItemView :: SearchItem -> Search -> P.Html Action
searchItemView item selectedSearch =
    let selected = item.value == selectedSearch
        selectedClass = if selected then " selected" else ""
    in
    P.li
        [ P.className $ "explorer-search-nav__item"  <> selectedClass
        , P.onClick <<< const $ GlobalUpdateSelectedSearch item.value ]
        [ P.text item.label ]


fixes test compile warnings

fixes test compile warnings

module Test.Main where

import Prelude (Unit, bind)
import Control.Monad.Eff.Console.Foreign (logF)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Data.Foreign (toForeign)
import Data.Foreign.Class (class AsForeign)

type MyRecord = { sval :: String, ival :: Int }

newtype MyNewtypeRecord = MyNewtypeRecord MyRecord

instance myNewtypeRecordAsForeign :: AsForeign MyNewtypeRecord where
  write = toForeign

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  -- example type with `AsForeign` instance
  let ex1 = MyNewtypeRecord { sval: "test newtype wrapped record", ival: 1 }
  logF ex1
  -- example vanilla `Record` using `toForeign`
  let ex2 = toForeign { sval: "test record", ival: 2 }
  logF ex2
  -- example `Array` of `AsForeign`
  logF [ "Array of words:", "a", "b", "c", "d"]

module Test.Main where

import Prelude
import Control.Monad.Eff.Console.Foreign
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console.Foreign (logF, infoF, warnF, errorF)
import Data.Foreign (toForeign, Foreign)
import Data.Foreign.Class (class AsForeign, write)

type MyRecord = { sval :: String, ival :: Int }

newtype MyNewtypeRecord = MyNewtypeRecord MyRecord

instance myNewtypeRecordAsForeign :: AsForeign MyNewtypeRecord where
  write = toForeign

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  -- example type with `AsForeign` instance
  let ex1 = MyNewtypeRecord { sval: "test newtype wrapped record", ival: 1 }
  logF ex1
  -- example vanilla `Record` using `toForeign`
  let ex2 = toForeign { sval: "test record", ival: 2 }
  logF ex2
  -- example `Array` of `AsForeign`
  logF [ "Array of words:", "a", "b", "c", "d"]


Make the button component take its child component as an argument

module Test.Main where

import Data.Maybe
import Data.Tuple

import Control.Monad.Eff

import DOM

import qualified Halogen as H
import qualified Halogen.HTML as H

foreign import appendToBody
  "function appendToBody(node) {\
  \  return function() {\
  \    document.body.appendChild(node);\
  \  };\
  \}" :: forall eff. Node -> Eff (dom :: DOM | eff) Node

data ButtonEvent = Click

-- | This `Spec` defines a reusable button component, which has a single child
-- | placeholder, and supports click events.
-- |
-- | Its state is a `Number` which represents the number of clicks
button :: forall c. H.Spec Number c -> H.Spec Number c
button = H.append (H.mkSpec render foldState)
  where
  render :: H.Render Number (Maybe c) ButtonEvent
  render _ = H.button [H.OnClick (const Click)] [H.child Nothing]

  foldState :: H.FoldState Number ButtonEvent
  foldState count Click = count + 1

-- | This `Spec` defines a reusable label component, which supports neither child
-- | nodes nor events.
-- |
-- | Its state is anything which can be rendered as a string.
label :: forall a. (Show a) => H.Spec a H.Void
label = H.mkSpec render foldState
  where
  render :: H.Render a H.Void H.Void
  render a = H.text (show a)

  foldState :: H.FoldState a H.Void
  foldState st _ = st

-- | The UI is composed by inserting a label as the button's first (only) child, and then
-- | placing the button next to _another_ label in a `div` element.
-- |
-- | We use the `label` component polymorphically. In the first case, it is used to render
-- | the click count of type number. In the second case, it is used to render a string.
-- |
-- | The state type becomes a `Tuple` due to the use of the `beside` combinator.
ui :: H.Component (Tuple Number String)
ui = button label `H.beside` label

main = do
  node <- H.runComponent ui (Tuple 0 "Click the button")
  appendToBody node

module Test.Main where

import Data.Maybe
import Data.Tuple

import Control.Monad.Eff

import DOM

import qualified Halogen as H
import qualified Halogen.HTML as H

foreign import appendToBody
  "function appendToBody(node) {\
  \  return function() {\
  \    document.body.appendChild(node);\
  \  };\
  \}" :: forall eff. Node -> Eff (dom :: DOM | eff) Node

data ButtonEvent = Click

-- | This `Spec` defines a reusable button component, which has a single child
-- | placeholder, and supports click events.
-- |
-- | Its state is a `Number` which represents the number of clicks
button :: H.Spec Number (Maybe H.Void)
button = H.mkSpec render foldState
  where
  render :: H.Render Number (Maybe H.Void) ButtonEvent
  render _ = H.button [H.OnClick (const Click)] [H.child Nothing]

  foldState :: H.FoldState Number ButtonEvent
  foldState count Click = count + 1

-- | This `Spec` defines a reusable label component, which supports neither child
-- | nodes nor events.
-- |
-- | Its state is anything which can be rendered as a string.
label :: forall a. (Show a) => H.Spec a H.Void
label = H.mkSpec render foldState
  where
  render :: H.Render a H.Void H.Void
  render a = H.text (show a)

  foldState :: H.FoldState a H.Void
  foldState st _ = st

-- | The UI is composed by inserting a label as the button's first (only) child, and then
-- | placing the button next to _another_ label in a `div` element.
-- |
-- | We use the `label` component polymorphically. In the first case, it is used to render
-- | the click count of type number. In the second case, it is used to render a string.
-- |
-- | The state type becomes a `Tuple` due to the use of the `beside` combinator.
ui :: H.Component (Tuple Number String)
ui = (button `H.append` label) `H.beside` label

main = do
  node <- H.runComponent ui (Tuple 0 "Click the button")
  appendToBody node


Fix the label name for the EXCEPTION effect

-- | A module providing a type and operations for the native JavaScript `Date`
-- | object.
-- |
-- | The `JSDate` type and associated functions are provided for interop
-- | purposes with JavaScript, but for working with dates in PureScript it is
-- | recommended that `DateTime` representation is used instead - `DateTime`
-- | offers greater type safety, a more PureScript-friendly interface, and has
-- | a `Generic` instance.
module Data.JSDate where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)

import Data.Date as Date
import Data.DateTime (DateTime(..), Date)
import Data.DateTime as DateTime
import Data.DateTime.Instant (Instant)
import Data.DateTime.Instant as Instant
import Data.Enum (fromEnum)
import Data.Foreign (unsafeReadTagged)
import Data.Foreign.Class (class IsForeign)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..))
import Data.Time as Time
import Data.Time.Duration (Milliseconds(..))

-- | The type of JavaScript `Date` objects.
foreign import data JSDate :: *

instance isForeignJSDate :: IsForeign JSDate where
  read = unsafeReadTagged "Date"

-- | Checks whether a date value is valid. When a date is invalid, the majority
-- | of the functions return `NaN`, `"Invalid Date"`, or throw an exception.
foreign import isValid :: JSDate -> Boolean

-- | Converts a `DateTime` value into a native JavaScript date object. The
-- | resulting date value is guaranteed to be valid.
fromDateTime :: DateTime -> JSDate
fromDateTime (DateTime d t) = jsdate
  { year: toNumber (fromEnum (Date.year d))
  , month: toNumber (fromEnum (Date.month d) - 1)
  , day: toNumber (fromEnum (Date.day d))
  , hour: toNumber (fromEnum (Time.hour t))
  , minute: toNumber (fromEnum (Time.minute t))
  , second: toNumber (fromEnum (Time.second t))
  , millisecond: toNumber (fromEnum (Time.millisecond t))
  }

-- | Attempts to construct a `DateTime` value for a `JSDate`. `Nothing` is
-- | returned only when the date value is an invalid date.
toDateTime :: JSDate -> Maybe DateTime
toDateTime = map Instant.toDateTime <$> toInstant

-- | Attempts to construct a `Date` value for a `JSDate`, ignoring any time
-- | component of the `JSDate`. `Nothing` is returned only when the date value
-- | is an invalid date.
toDate :: JSDate -> Maybe Date
toDate = map DateTime.date <$> toDateTime

-- | Attempts to construct an `Instant` for a `JSDate`. `Nothing` is returned
-- | only when the date value is an invalid date.
toInstant :: JSDate -> Maybe Instant
toInstant = Instant.instant <<< Milliseconds <=< toInstantImpl Just Nothing

foreign import toInstantImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> JSDate
  -> Maybe Number

-- | Constructs a new `JSDate` from UTC component values. If any of the values
-- | are `NaN` the resulting date will be invalid.
foreign import jsdate
  :: { year :: Number
     , month :: Number
     , day :: Number
     , hour :: Number
     , minute :: Number
     , second :: Number
     , millisecond :: Number
     }
  -> JSDate

-- | Constructs a new `JSDate` from component values using the current machine's
-- | locale. If any of the values are `NaN` the resulting date will be invalid.
foreign import jsdateLocal
  :: forall eff
   . { year :: Number
     , month :: Number
     , day :: Number
     , hour :: Number
     , minute :: Number
     , second :: Number
     , millisecond :: Number
     }
  -> Eff (locale :: LOCALE | eff) JSDate

foreign import dateMethodEff :: forall eff a. Fn2 String JSDate (Eff eff a)
foreign import dateMethod :: forall a. Fn2 String JSDate a

-- | Attempts to parse a date from a string. The behaviour of this function is
-- | implementation specific until ES5, so may not always have the same
-- | behaviour for a given string. The RFC2822 and ISO8601 date string formats
-- | should parse consistently.
-- |
-- | The `LOCALE` effect is present here as if no time zone is specified in the
-- | string the current locale's time zone will be used instead.
foreign import parse
  :: forall eff. String -> Eff (locale :: LOCALE | eff) JSDate

-- | The effect type used when indicating the current machine's date/time locale
-- | is used in computing a value.
foreign import data LOCALE :: !

-- | Returns the date as a number of milliseconds since 1970-01-01 00:00:00 UTC.
getTime :: JSDate -> Number
getTime dt = runFn2 dateMethod "getTime" dt

-- | Returns the day of the month for a date, according to UTC.
getUTCDate :: JSDate -> Number
getUTCDate dt = runFn2 dateMethod "getUTCDate" dt

-- | Returns the day of the week for a date, according to UTC.
getUTCDay :: JSDate -> Number
getUTCDay dt = runFn2 dateMethod "getUTCDay" dt

-- | Returns the year for a date, according to UTC.
getUTCFullYear :: JSDate -> Number
getUTCFullYear dt = runFn2 dateMethod "getUTCFullYear" dt

-- | Returns the hours for a date, according to UTC.
getUTCHours :: JSDate -> Number
getUTCHours dt = runFn2 dateMethod "getUTCHours" dt

-- | Returns the milliseconds for a date, according to UTC.
getUTCMilliseconds :: JSDate -> Number
getUTCMilliseconds dt = runFn2 dateMethod "getUTCMilliseconds" dt

-- | Returns the minutes for a date, according to UTC.
getUTCMinutes :: JSDate -> Number
getUTCMinutes dt = runFn2 dateMethod "getUTCMinutes" dt

-- | Returns the month for a date, according to UTC.
getUTCMonth :: JSDate -> Number
getUTCMonth dt = runFn2 dateMethod "getUTCMonth" dt

-- | Returns the seconds for a date, according to UTC.
getUTCSeconds :: JSDate -> Number
getUTCSeconds dt = runFn2 dateMethod "getUTCSeconds" dt

-- | Returns the day of the month for a date, according to the current
-- | machine's date/time locale.
getDate :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getDate dt = runFn2 dateMethodEff "getDate" dt

-- | Returns the day of the week for a date, according to the current
-- | machine's date/time locale.
getDay :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getDay dt = runFn2 dateMethodEff "getDay" dt

-- | Returns the year for a date, according to the current machine's date/time
-- | locale.
getFullYear :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getFullYear dt = runFn2 dateMethodEff "getFullYear" dt

-- | Returns the hour for a date, according to the current machine's date/time
-- | locale.
getHours :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getHours dt = runFn2 dateMethodEff "getHours" dt

-- | Returns the milliseconds for a date, according to the current machine's
-- | date/time locale.
getMilliseconds :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getMilliseconds dt = runFn2 dateMethodEff "getMilliseconds" dt

-- | Returns the minutes for a date, according to the current machine's
-- | date/time locale.
getMinutes :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getMinutes dt = runFn2 dateMethodEff "getMinutes" dt

-- | Returns the month for a date, according to the current machine's
-- | date/time locale.
getMonth :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getMonth dt = runFn2 dateMethodEff "getMonth" dt

-- | Returns the seconds for a date, according to the current machine's
-- | date/time locale.
getSeconds :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getSeconds dt = runFn2 dateMethodEff "getSeconds" dt

-- | Returns the time-zone offset for a date, according to the current machine's
-- | date/time locale.
getTimezoneOffset :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getTimezoneOffset dt = runFn2 dateMethodEff "getTimezoneOffset" dt

-- | Returns the date portion of a date value as a human-readable string.
toDateString :: JSDate -> String
toDateString dt = runFn2 dateMethod "toDateString" dt

-- | Converts a date value to an ISO 8601 Extended format date string.
toISOString :: forall eff. JSDate -> Eff (err :: EXCEPTION | eff) String
toISOString dt = runFn2 dateMethodEff "toISOString" dt

-- | Returns a string representing for a date value.
toString :: JSDate -> String
toString dt = runFn2 dateMethod "toString" dt

-- | Returns the time portion of a date value as a human-readable string.
toTimeString :: JSDate -> String
toTimeString dt = runFn2 dateMethod "toTimeString" dt

-- | Returns the date as a string using the UTC timezone.
toUTCString :: JSDate -> String
toUTCString dt = runFn2 dateMethod "toUTCString" dt

-- | A module providing a type and operations for the native JavaScript `Date`
-- | object.
-- |
-- | The `JSDate` type and associated functions are provided for interop
-- | purposes with JavaScript, but for working with dates in PureScript it is
-- | recommended that `DateTime` representation is used instead - `DateTime`
-- | offers greater type safety, a more PureScript-friendly interface, and has
-- | a `Generic` instance.
module Data.JSDate where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)

import Data.Date as Date
import Data.DateTime (DateTime(..), Date)
import Data.DateTime as DateTime
import Data.DateTime.Instant (Instant)
import Data.DateTime.Instant as Instant
import Data.Enum (fromEnum)
import Data.Foreign (unsafeReadTagged)
import Data.Foreign.Class (class IsForeign)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..))
import Data.Time as Time
import Data.Time.Duration (Milliseconds(..))

-- | The type of JavaScript `Date` objects.
foreign import data JSDate :: *

instance isForeignJSDate :: IsForeign JSDate where
  read = unsafeReadTagged "Date"

-- | Checks whether a date value is valid. When a date is invalid, the majority
-- | of the functions return `NaN`, `"Invalid Date"`, or throw an exception.
foreign import isValid :: JSDate -> Boolean

-- | Converts a `DateTime` value into a native JavaScript date object. The
-- | resulting date value is guaranteed to be valid.
fromDateTime :: DateTime -> JSDate
fromDateTime (DateTime d t) = jsdate
  { year: toNumber (fromEnum (Date.year d))
  , month: toNumber (fromEnum (Date.month d) - 1)
  , day: toNumber (fromEnum (Date.day d))
  , hour: toNumber (fromEnum (Time.hour t))
  , minute: toNumber (fromEnum (Time.minute t))
  , second: toNumber (fromEnum (Time.second t))
  , millisecond: toNumber (fromEnum (Time.millisecond t))
  }

-- | Attempts to construct a `DateTime` value for a `JSDate`. `Nothing` is
-- | returned only when the date value is an invalid date.
toDateTime :: JSDate -> Maybe DateTime
toDateTime = map Instant.toDateTime <$> toInstant

-- | Attempts to construct a `Date` value for a `JSDate`, ignoring any time
-- | component of the `JSDate`. `Nothing` is returned only when the date value
-- | is an invalid date.
toDate :: JSDate -> Maybe Date
toDate = map DateTime.date <$> toDateTime

-- | Attempts to construct an `Instant` for a `JSDate`. `Nothing` is returned
-- | only when the date value is an invalid date.
toInstant :: JSDate -> Maybe Instant
toInstant = Instant.instant <<< Milliseconds <=< toInstantImpl Just Nothing

foreign import toInstantImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> JSDate
  -> Maybe Number

-- | Constructs a new `JSDate` from UTC component values. If any of the values
-- | are `NaN` the resulting date will be invalid.
foreign import jsdate
  :: { year :: Number
     , month :: Number
     , day :: Number
     , hour :: Number
     , minute :: Number
     , second :: Number
     , millisecond :: Number
     }
  -> JSDate

-- | Constructs a new `JSDate` from component values using the current machine's
-- | locale. If any of the values are `NaN` the resulting date will be invalid.
foreign import jsdateLocal
  :: forall eff
   . { year :: Number
     , month :: Number
     , day :: Number
     , hour :: Number
     , minute :: Number
     , second :: Number
     , millisecond :: Number
     }
  -> Eff (locale :: LOCALE | eff) JSDate

foreign import dateMethodEff :: forall eff a. Fn2 String JSDate (Eff eff a)
foreign import dateMethod :: forall a. Fn2 String JSDate a

-- | Attempts to parse a date from a string. The behaviour of this function is
-- | implementation specific until ES5, so may not always have the same
-- | behaviour for a given string. The RFC2822 and ISO8601 date string formats
-- | should parse consistently.
-- |
-- | The `LOCALE` effect is present here as if no time zone is specified in the
-- | string the current locale's time zone will be used instead.
foreign import parse
  :: forall eff. String -> Eff (locale :: LOCALE | eff) JSDate

-- | The effect type used when indicating the current machine's date/time locale
-- | is used in computing a value.
foreign import data LOCALE :: !

-- | Returns the date as a number of milliseconds since 1970-01-01 00:00:00 UTC.
getTime :: JSDate -> Number
getTime dt = runFn2 dateMethod "getTime" dt

-- | Returns the day of the month for a date, according to UTC.
getUTCDate :: JSDate -> Number
getUTCDate dt = runFn2 dateMethod "getUTCDate" dt

-- | Returns the day of the week for a date, according to UTC.
getUTCDay :: JSDate -> Number
getUTCDay dt = runFn2 dateMethod "getUTCDay" dt

-- | Returns the year for a date, according to UTC.
getUTCFullYear :: JSDate -> Number
getUTCFullYear dt = runFn2 dateMethod "getUTCFullYear" dt

-- | Returns the hours for a date, according to UTC.
getUTCHours :: JSDate -> Number
getUTCHours dt = runFn2 dateMethod "getUTCHours" dt

-- | Returns the milliseconds for a date, according to UTC.
getUTCMilliseconds :: JSDate -> Number
getUTCMilliseconds dt = runFn2 dateMethod "getUTCMilliseconds" dt

-- | Returns the minutes for a date, according to UTC.
getUTCMinutes :: JSDate -> Number
getUTCMinutes dt = runFn2 dateMethod "getUTCMinutes" dt

-- | Returns the month for a date, according to UTC.
getUTCMonth :: JSDate -> Number
getUTCMonth dt = runFn2 dateMethod "getUTCMonth" dt

-- | Returns the seconds for a date, according to UTC.
getUTCSeconds :: JSDate -> Number
getUTCSeconds dt = runFn2 dateMethod "getUTCSeconds" dt

-- | Returns the day of the month for a date, according to the current
-- | machine's date/time locale.
getDate :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getDate dt = runFn2 dateMethodEff "getDate" dt

-- | Returns the day of the week for a date, according to the current
-- | machine's date/time locale.
getDay :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getDay dt = runFn2 dateMethodEff "getDay" dt

-- | Returns the year for a date, according to the current machine's date/time
-- | locale.
getFullYear :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getFullYear dt = runFn2 dateMethodEff "getFullYear" dt

-- | Returns the hour for a date, according to the current machine's date/time
-- | locale.
getHours :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getHours dt = runFn2 dateMethodEff "getHours" dt

-- | Returns the milliseconds for a date, according to the current machine's
-- | date/time locale.
getMilliseconds :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getMilliseconds dt = runFn2 dateMethodEff "getMilliseconds" dt

-- | Returns the minutes for a date, according to the current machine's
-- | date/time locale.
getMinutes :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getMinutes dt = runFn2 dateMethodEff "getMinutes" dt

-- | Returns the month for a date, according to the current machine's
-- | date/time locale.
getMonth :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getMonth dt = runFn2 dateMethodEff "getMonth" dt

-- | Returns the seconds for a date, according to the current machine's
-- | date/time locale.
getSeconds :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getSeconds dt = runFn2 dateMethodEff "getSeconds" dt

-- | Returns the time-zone offset for a date, according to the current machine's
-- | date/time locale.
getTimezoneOffset :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getTimezoneOffset dt = runFn2 dateMethodEff "getTimezoneOffset" dt

-- | Returns the date portion of a date value as a human-readable string.
toDateString :: JSDate -> String
toDateString dt = runFn2 dateMethod "toDateString" dt

-- | Converts a date value to an ISO 8601 Extended format date string.
toISOString :: forall eff. JSDate -> Eff (exception :: EXCEPTION | eff) String
toISOString dt = runFn2 dateMethodEff "toISOString" dt

-- | Returns a string representing for a date value.
toString :: JSDate -> String
toString dt = runFn2 dateMethod "toString" dt

-- | Returns the time portion of a date value as a human-readable string.
toTimeString :: JSDate -> String
toTimeString dt = runFn2 dateMethod "toTimeString" dt

-- | Returns the date as a string using the UTC timezone.
toUTCString :: JSDate -> String
toUTCString dt = runFn2 dateMethod "toUTCString" dt


add doc string about subscription in componentDidMount

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Canceler (redox :: RedoxStore reff | eff))

-- | Shallowly compare to objects.  If the third argument is true it skips
-- | comapring the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl reff eff =
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      void $ writeState this (st { state = view _lns state })

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.  Note that if a child triggers an action in its
    -- | `componentWillMount` it's change might be
    -- | missed.
    componentDidMount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      st <- readState this
      void $ writeState this (st { sid = Just sid })

    componentWillUnmount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn3 unsafeShallowEqual false pr nPr)

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      ctx <- unsafeCoerceEff $ ctxEff this
      { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })) this

connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = accessContext $ R.createClass $ connect' p _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl = do
  { dispatch: disp } <- _.redox <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) }) ) this
  disp dsl

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Canceler (redox :: RedoxStore reff | eff))

-- | Shallowly compare to objects.  If the third argument is true it skips
-- | comapring the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl reff eff =
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      void $ writeState this (st { state = view _lns state })

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentDidMount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      st <- readState this
      void $ writeState this (st { sid = Just sid })

    componentWillUnmount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn3 unsafeShallowEqual false pr nPr)

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      ctx <- unsafeCoerceEff $ ctxEff this
      { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })) this

connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = accessContext $ R.createClass $ connect' p _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl = do
  { dispatch: disp } <- _.redox <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) }) ) this
  disp dsl


Shows Queue as two levels

Shows Queue as two levels

module Views.Queue where

import Data.Map as M
import Pux.Html as H
import Pux.Html.Attributes as HA
import Pux.Html.Events as HE
import Structures.Purs.Queue as Q
import CodeSnippet as CS
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (Error)
import Debug.Trace (spy)
import Data.Array ((:), concatMap, fromFoldable)
import Data.Either (Either(..))
import Data.Eq (class Eq, eq)
import Data.Filterable (filterMap)
import Data.Foldable (class Foldable, foldr)
import Data.Function.Uncurried (runFn3)
import Data.Functor (map, class Functor)
import Data.Int (fromString, toNumber, round)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Ord (class Ord, compare)
import Data.Show (show)
import Data.Tuple (Tuple(..), fst, snd)
import Math (atan, sin, cos, pi)
import Prelude (($), (+), (/), (-), (*), (<), (<>), (<<<), const, min, max, (<$>), bind, pure, negate)
import Pux (EffModel, noEffects)
import Signal ((~>))
import Signal.Time (now, Time, millisecond)

type Classes = String
type NodeID = Int
type NodeValue = Int
data Node = Node { value :: NodeValue
                 , classes :: Classes
                 , id :: NodeID
                 , connections :: Array NodeID
                 }

type NodePos = { x :: Number
               , y :: Number
               , r :: Number
               , connections :: Array NodeID
               , value :: NodeValue
               , classes :: Classes
               }
type NodeMap = M.Map NodeID NodePos

instance eqNode :: Eq Node where
  eq (Node a) (Node b) = eq a.value b.value

instance ordNode :: Ord Node where
  compare (Node a) (Node b) = compare a.value b.value

type Model = { queue :: Q.Queue Node
             , currId :: NodeID
             , currInput :: Maybe NodeValue
             , currNodes :: NodeMap
             , prevNodes :: NodeMap
             , startAnimation :: Maybe Time
             , animationPhase :: Number
             , delay :: Number
             , sourceCode :: M.Map String String
             , currFnName :: Maybe String
             , currFn :: Maybe String
             }

initModel :: Model
initModel = { queue : Q.empty
            , currId : 0
            , currInput : Nothing
            , currNodes : M.empty
            , prevNodes : M.empty
            , startAnimation : Nothing
            , animationPhase : 1.0
            , delay : 750.0 * millisecond
            , sourceCode : M.empty
            , currFnName : Nothing
            , currFn : Nothing
            }

data Direction = Front | Back

mkNode :: Direction -> Model -> Maybe (Tuple Node Model)
mkNode dir model =
  case model.currInput of
    Nothing -> Nothing
    Just val ->
      let
        mlastNode =
          case dir of
            Front -> Q.topHead model.queue
            Back -> Q.backHead model.queue
        connections =
          case mlastNode of
            Nothing -> []
            Just (Node n) -> [n.id]
        newNode = Node { value : val
                       , classes : "cons"
                       , id : model.currId
                       , connections : connections
                       }
        newModel = model { currId = model.currId + 1 }
      in
       Just $ Tuple newNode newModel

maxWidth :: Number
maxWidth = 800.0

maxHeight :: Number
maxHeight = 200.0

maxRadius :: Number
maxRadius = 40.0

buffer :: Number
buffer = 10.0

mkNodePos :: Int -> Number -> Node -> Tuple Int NodeMap -> Tuple Int NodeMap
mkNodePos total ypos (Node node) (Tuple pos acc) =
  let
    ftotal = toNumber total
    fpos = toNumber pos
    r = min maxRadius (maxWidth / 3.0 / ftotal)
    offset x = x + buffer + r
    calcPos x = offset $ x * maxWidth
    circPos = { x : calcPos $ fpos / ftotal
              , y : ypos
              , r : r
              , value : node.value
              , connections : node.connections
              , classes : node.classes
              }
  in
   Tuple (pos + 1) (M.insert node.id circPos acc)

getNodeMap :: Int -> Q.Queue Node -> NodeMap
getNodeMap total (Q.Queue queue) =
  let
    front = snd $ foldr (mkNodePos total (maxHeight / 4.0)) (Tuple 0 M.empty) queue.front
    back = snd $ foldr (mkNodePos total (3.0 * maxHeight / 4.0)) (Tuple 0 M.empty) queue.back
  in
   M.union front back

changeClass :: Classes -> Node -> Node
changeClass classes (Node node) = Node (node { classes = classes })

changeAllClasses :: forall f. Functor f => Classes -> f Node -> f Node
changeAllClasses classes = map (changeClass classes)

wipeClasses :: forall f. Functor f => f Node -> f Node
wipeClasses = changeAllClasses ""

data Action = Empty
            | Top
            | Bottom
            | Pop
            | Eject
            | Push
            | Inject
            | CurrentInput String
            | ShowStructure
            | StartTimer Time
            | LoadCode (Either String CS.SourceCode)
            | Failure Error
            | Tick Time

changeFn :: Model -> String -> Model
changeFn model fn = model { currFn = M.lookup fn model.sourceCode
                          , currFnName = Just fn}

updateQueue :: Model -> Q.Queue Node -> String -> EffModel Model Action _
updateQueue model queue fn =
  let
    bict = Q.biCount queue
    ct = max (fst bict) (snd bict)
    -- ct = (fst bict) + (snd bict)
    newMap = getNodeMap ct queue
  in
   { state: model { prevNodes = model.currNodes
                  , currNodes = newMap
                  , queue = queue
                  , animationPhase = 0.0
                  , currFnName = Just fn
                  , currFn = M.lookup fn model.sourceCode
                  }
   , effects: [ do
      time <- liftEff now
      pure $ StartTimer time
              ]
   }

update :: Action -> Model -> EffModel Model Action _
update (Failure err) model = noEffects model
update (LoadCode (Left err)) model = noEffects model
update (LoadCode (Right code)) model =
  let
    sourceCodeModel = model { sourceCode = CS.parseFunctions code }
    newModel =
      case model.currFnName of
        Nothing -> sourceCodeModel
        Just fn -> changeFn sourceCodeModel fn
  in
   noEffects newModel
update (Tick time) model =
  case model.startAnimation of
    Nothing -> noEffects model
    Just start ->
      let
        timeDiff = time - start
      in
       if model.delay < timeDiff
       then noEffects $ model { animationPhase = 1.0 }
       else noEffects $ model { animationPhase = sin (timeDiff / model.delay * pi / 2.0) }
update (StartTimer time) model = noEffects $ model { startAnimation = Just time
                                                   , animationPhase = 0.0
                                                   }
update Empty model =
  updateQueue model Q.empty "empty"
update Top model =
  let
    mhead = Q.top model.queue
    mtail = Q.pop model.queue
  in
   case Tuple mhead mtail of
     Tuple Nothing _ -> noEffects $ changeFn model "top"
     Tuple _ Nothing -> noEffects $ changeFn model "top"
     Tuple (Just h) (Just t) ->
       let
         newHead = changeClass "head" h
         newTail = wipeClasses t
         newQ = Q.push newHead newTail
       in
        updateQueue model newQ "top"
update Pop model =
  let
    mtail = Q.pop model.queue
  in
   case mtail of
     Nothing -> noEffects $ changeFn model "pop"
     Just t ->
       let
         newTail = changeAllClasses "tail" t
         newQ = newTail
       in
        updateQueue model newQ "pop"
update Bottom model =
  let
    mhead = Q.back model.queue
    mtail = Q.eject model.queue
  in
   case Tuple mhead mtail of
     Tuple Nothing _ -> noEffects $ changeFn model "back"
     Tuple _ Nothing -> noEffects $ changeFn model "back"
     Tuple (Just h) (Just t) ->
       let
         newHead = changeClass "head" h
         newTail = wipeClasses t
         newQ = Q.inject newHead newTail
       in
        updateQueue model newQ "back"
update Eject model =
  let
    mtail = Q.eject model.queue
  in
   case mtail of
     Nothing -> noEffects $ changeFn model "eject"
     Just t ->
       let
         newTail = changeAllClasses "tail" t
         newQ = newTail
       in
        updateQueue model newQ "eject"
update Inject model =
  let
    mnode = mkNode Back model
    cleanQueue = wipeClasses model.queue
  in
   case mnode of
     Nothing -> noEffects $ changeFn model "inject"
     Just (Tuple node newModel) ->
       updateQueue newModel (Q.inject node cleanQueue) "inject"
update Push model =
  let
    mnode = mkNode Front model
    cleanQueue = wipeClasses model.queue
  in
   case mnode of
     Nothing -> noEffects $ changeFn model "push"
     Just (Tuple node newModel) ->
       updateQueue newModel (Q.push node cleanQueue) "push"
update (CurrentInput s) model =
  noEffects $ model { currInput = fromString s }
update ShowStructure model =
  noEffects $ changeFn model "Queue"

svgText :: forall a. Array (H.Attribute a) -> Array (H.Html a) -> H.Html a
svgText = runFn3 H.element "text"

initialNode :: NodeID -> NodePos
initialNode nid = { x : maxWidth + 10.0
                  , y : -10.0
                  , r : 0.0
                  , connections : [nid]
                  , value : 0
                  , classes : ""
                  }

finalNode :: NodeID -> NodePos
finalNode _ = { x : -10.0
              , y : maxHeight + 10.0
              , r : 0.0
              , connections : []
              , value : 0
              , classes : ""
              }

interpolate :: Number -> Number -> Number -> Number
interpolate phase old new =
  let
    diff = new - old
  in
   old + phase*diff

interpolateNodes :: Number -> NodePos -> NodePos -> NodePos
interpolateNodes phase old new =
  let
    intphase = interpolate phase
  in
   new { x = intphase old.x new.x
       , y = intphase old.y new.y
       , r = intphase old.r new.r
       }

viewNodePos :: Number -> NodeMap -> NodeMap -> NodeID -> Array (H.Html Action)
viewNodePos phase prevmap currmap nid =
  let
    interphase = interpolateNodes phase
    prev = fromMaybe (initialNode nid) (M.lookup nid prevmap)
    curr = fromMaybe (finalNode nid) (M.lookup nid currmap)
    node = interphase prev curr
    circ = H.circle [ HA.cx (show $ node.x)
                    , HA.cy (show $ node.y)
                    , HA.r (show $ node.r)
                    , HA.className (node.classes <> " node")
                    ] [ ]
    val = svgText [ HA.x (show $ node.x)
                  , HA.y (show $ node.y + 6.0)
                  , HA.textAnchor "middle" ] [ H.text (show node.value)]
    edges = filterMap (\n ->
                        let
                          mnode = M.lookup n currmap
                        in
                         case mnode of
                           Nothing -> Nothing
                           Just currEdge ->
                             let
                               prevEdge = fromMaybe (initialNode n) (M.lookup n prevmap)
                               edgeNode = interphase prevEdge currEdge
                               signX = if node.x < edgeNode.x then 1.0 else -1.0
                               signY = if node.y < edgeNode.y then 1.0 else -1.0
                               invtan = atan ((node.y - edgeNode.y) / (node.x - edgeNode.x))
                             in
                              Just $ H.line [ HA.x1 (show $ node.x + signX*cos invtan * node.r)
                                            , HA.y1 (show $ node.y - signY*sin invtan * node.r)
                                            , HA.x2 (show $ edgeNode.x - signX*cos invtan * edgeNode.r)
                                            , HA.y2 (show $ edgeNode.y + signY*sin invtan * edgeNode.r)
                                            , HA.className "edge"] [ ]) node.connections
  in
   circ : val : edges

view :: Model -> H.Html Action
view model =
  let
    keys = M.keys $ M.union model.prevNodes model.currNodes
    showNodes = viewNodePos model.animationPhase model.prevNodes model.currNodes
    nodes = concatMap showNodes (fromFoldable keys)
    stackDiv = H.div [ HA.className "render" ] [ H.svg [HA.height (show maxHeight)
                                                       , HA.width (show maxWidth)  ] nodes ]
    dataBtn = H.div [ ] [ H.button [ HA.className "pure-button pure-button-warning"
                                   , HE.onClick $ const ShowStructure
                                   ] [ H.text "Queue Structure" ]
                        ]
    emptyBtn = H.div [ ] [ H.button [ HA.className "pure-button"
                                    , HE.onClick $ const Empty
                                    ] [ H.text "Empty" ]
                         ]
    topBtn = H.button [ HA.className "pure-button"
                      , HE.onClick $ const Top
                      ] [ H.text "Top" ]
    popBtn = H.button [ HA.className "pure-button"
                      , HE.onClick $ const Pop
                      ] [ H.text "Pop / Unshift" ]
    frontDiv = H.div [ ] [ topBtn, popBtn ]
    backBtn = H.button [ HA.className "pure-button"
                       , HE.onClick $ const Bottom
                       ] [ H.text "Back" ]
    ejectBtn = H.button [ HA.className "pure-button"
                        , HE.onClick $ const Eject
                        ] [ H.text "Eject" ]
    backDiv = H.div [ ] [ backBtn, ejectBtn ]
    consSpan = H.div [ ] [ H.span [ ] [ H.button [ HA.className "pure-button"
                                                 , HE.onClick $ const Inject
                                                 ] [ H.text "Inject / Shift"]
                                      , H.button [ HA.className "pure-button"
                                                 , HE.onClick $ const Push
                                                 ] [ H.text "Push" ]
                                      , H.input [ HA.type_ "number"
                                                , HE.onChange $ \t -> CurrentInput t.target.value
                                                ] [ ]]
                         ]
    controlDiv = H.div [ HA.className "pure-u-1-2" ] [ dataBtn
                                                     , emptyBtn
                                                     , frontDiv
                                                     , backDiv
                                                     , consSpan
                                                     ]
    codeDiv = H.div [ HA.className "pure-u-1-2" ]
                    [ H.code [ ]
                      [ H.pre [ ]
                        [ case model.currFn of
                             Nothing ->
                               H.i []
                                   [ H.text "No implementation given or no function selected"]
                             Just fn -> H.text fn ]
                      ]
                    ]
  in
   H.div [ HA.className "pure-g" ] [ stackDiv
                                   , controlDiv
                                   , codeDiv
                                   ]

module Views.Queue where

import Data.Map as M
import Pux.Html as H
import Pux.Html.Attributes as HA
import Pux.Html.Events as HE
import Structures.Purs.Queue as Q
import CodeSnippet as CS
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (Error)
import Debug.Trace (spy)
import Data.Array ((:), concatMap, fromFoldable)
import Data.Either (Either(..))
import Data.Eq (class Eq, eq)
import Data.Filterable (filterMap)
import Data.Foldable (class Foldable, foldr)
import Data.Function.Uncurried (runFn3)
import Data.Functor (map, class Functor)
import Data.Int (fromString, toNumber, round)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Ord (class Ord, compare)
import Data.Show (show)
import Data.Tuple (Tuple(..), fst, snd)
import Math (atan, sin, cos, pi)
import Prelude (($), (+), (/), (-), (*), (<), (<>), (<<<), const, min, max, (<$>), bind, pure, negate)
import Pux (EffModel, noEffects)
import Signal ((~>))
import Signal.Time (now, Time, millisecond)

type Classes = String
type NodeID = Int
type NodeValue = Int
data Node = Node { value :: NodeValue
                 , classes :: Classes
                 , id :: NodeID
                 , connections :: Array NodeID
                 }

type NodePos = { x :: Number
               , y :: Number
               , r :: Number
               , connections :: Array NodeID
               , value :: NodeValue
               , classes :: Classes
               }
type NodeMap = M.Map NodeID NodePos

instance eqNode :: Eq Node where
  eq (Node a) (Node b) = eq a.value b.value

instance ordNode :: Ord Node where
  compare (Node a) (Node b) = compare a.value b.value

type Model = { queue :: Q.Queue Node
             , currId :: NodeID
             , currInput :: Maybe NodeValue
             , currNodes :: NodeMap
             , prevNodes :: NodeMap
             , startAnimation :: Maybe Time
             , animationPhase :: Number
             , delay :: Number
             , sourceCode :: M.Map String String
             , currFnName :: Maybe String
             , currFn :: Maybe String
             }

initModel :: Model
initModel = { queue : Q.empty
            , currId : 0
            , currInput : Nothing
            , currNodes : M.empty
            , prevNodes : M.empty
            , startAnimation : Nothing
            , animationPhase : 1.0
            , delay : 750.0 * millisecond
            , sourceCode : M.empty
            , currFnName : Nothing
            , currFn : Nothing
            }

data Direction = Front | Back

mkNode :: Direction -> Model -> Maybe (Tuple Node Model)
mkNode dir model =
  case model.currInput of
    Nothing -> Nothing
    Just val ->
      let
        mlastNode =
          case dir of
            Front -> Q.topHead model.queue
            Back -> Q.backHead model.queue
        connections =
          case mlastNode of
            Nothing -> []
            Just (Node n) -> [n.id]
        newNode = Node { value : val
                       , classes : "cons"
                       , id : model.currId
                       , connections : connections
                       }
        newModel = model { currId = model.currId + 1 }
      in
       Just $ Tuple newNode newModel

maxWidth :: Number
maxWidth = 800.0

maxHeight :: Number
maxHeight = 200.0

maxRadius :: Number
maxRadius = 40.0

buffer :: Number
buffer = 10.0

mkNodePos :: Int -> Node -> Tuple Int NodeMap -> Tuple Int NodeMap
mkNodePos total (Node node) (Tuple pos acc) =
  let
    ftotal = toNumber total
    fpos = toNumber pos
    r = min maxRadius (maxWidth / 3.0 / ftotal)
    offset x = x + buffer + r
    calcPos x = offset $ x * maxWidth
    circPos = { x : calcPos $ fpos / ftotal
              , y : maxHeight / 2.0
              , r : r
              , value : node.value
              , connections : node.connections
              , classes : node.classes
              }
  in
   Tuple (pos + 1) (M.insert node.id circPos acc)

getNodeMap :: forall f. Foldable f => Int -> f Node -> NodeMap
getNodeMap total stack = snd $ foldr (mkNodePos total) (Tuple 0 M.empty) stack

changeClass :: Classes -> Node -> Node
changeClass classes (Node node) = Node (node { classes = classes })

changeAllClasses :: forall f. Functor f => Classes -> f Node -> f Node
changeAllClasses classes = map (changeClass classes)

wipeClasses :: forall f. Functor f => f Node -> f Node
wipeClasses = changeAllClasses ""

data Action = Empty
            | Top
            | Bottom
            | Pop
            | Eject
            | Push
            | Inject
            | CurrentInput String
            | ShowStructure
            | StartTimer Time
            | LoadCode (Either String CS.SourceCode)
            | Failure Error
            | Tick Time

changeFn :: Model -> String -> Model
changeFn model fn = model { currFn = M.lookup fn model.sourceCode
                          , currFnName = Just fn}

updateQueue :: Model -> Q.Queue Node -> String -> EffModel Model Action _
updateQueue model queue fn =
  let
    bict = Q.biCount queue
    -- ct = max (fst bict) (snd bict)
    ct = (fst bict) + (snd bict)
    newMap = getNodeMap ct queue
  in
   { state: model { prevNodes = model.currNodes
                  , currNodes = newMap
                  , queue = queue
                  , animationPhase = 0.0
                  , currFnName = Just fn
                  , currFn = M.lookup fn model.sourceCode
                  }
   , effects: [ do
      time <- liftEff now
      pure $ StartTimer time
              ]
   }

update :: Action -> Model -> EffModel Model Action _
update (Failure err) model = noEffects model
update (LoadCode (Left err)) model = noEffects model
update (LoadCode (Right code)) model =
  let
    sourceCodeModel = model { sourceCode = CS.parseFunctions code }
    newModel =
      case model.currFnName of
        Nothing -> sourceCodeModel
        Just fn -> changeFn sourceCodeModel fn
  in
   noEffects newModel
update (Tick time) model =
  case model.startAnimation of
    Nothing -> noEffects model
    Just start ->
      let
        timeDiff = time - start
      in
       if model.delay < timeDiff
       then noEffects $ model { animationPhase = 1.0 }
       else noEffects $ model { animationPhase = sin (timeDiff / model.delay * pi / 2.0) }
update (StartTimer time) model = noEffects $ model { startAnimation = Just time
                                                   , animationPhase = 0.0
                                                   }
update Empty model =
  updateQueue model Q.empty "empty"
update Top model =
  let
    mhead = Q.top model.queue
    mtail = Q.pop model.queue
  in
   case Tuple mhead mtail of
     Tuple Nothing _ -> noEffects $ changeFn model "top"
     Tuple _ Nothing -> noEffects $ changeFn model "top"
     Tuple (Just h) (Just t) ->
       let
         newHead = changeClass "head" h
         newTail = wipeClasses t
         newQ = Q.push newHead newTail
       in
        updateQueue model newQ "top"
update Pop model =
  let
    mtail = Q.pop model.queue
  in
   case mtail of
     Nothing -> noEffects $ changeFn model "pop"
     Just t ->
       let
         newTail = changeAllClasses "tail" t
         newQ = newTail
       in
        updateQueue model newQ "pop"
update Bottom model =
  let
    mhead = Q.back model.queue
    mtail = Q.eject model.queue
  in
   case Tuple mhead mtail of
     Tuple Nothing _ -> noEffects $ changeFn model "back"
     Tuple _ Nothing -> noEffects $ changeFn model "back"
     Tuple (Just h) (Just t) ->
       let
         newHead = changeClass "head" h
         newTail = wipeClasses t
         newQ = Q.inject newHead newTail
       in
        updateQueue model newQ "back"
update Eject model =
  let
    mtail = Q.eject model.queue
  in
   case mtail of
     Nothing -> noEffects $ changeFn model "eject"
     Just t ->
       let
         newTail = changeAllClasses "tail" t
         newQ = newTail
       in
        updateQueue model newQ "eject"
update Inject model =
  let
    mnode = mkNode Back model
    cleanQueue = wipeClasses model.queue
  in
   case mnode of
     Nothing -> noEffects $ changeFn model "inject"
     Just (Tuple node newModel) ->
       updateQueue newModel (Q.inject node cleanQueue) "inject"
update Push model =
  let
    mnode = mkNode Front model
    cleanQueue = wipeClasses model.queue
  in
   case mnode of
     Nothing -> noEffects $ changeFn model "push"
     Just (Tuple node newModel) ->
       updateQueue newModel (Q.push node cleanQueue) "push"
update (CurrentInput s) model =
  noEffects $ model { currInput = fromString s }
update ShowStructure model =
  noEffects $ changeFn model "Queue"

svgText :: forall a. Array (H.Attribute a) -> Array (H.Html a) -> H.Html a
svgText = runFn3 H.element "text"

initialNode :: NodeID -> NodePos
initialNode nid = { x : maxWidth + 10.0
                  , y : -10.0
                  , r : 0.0
                  , connections : [nid]
                  , value : 0
                  , classes : ""
                  }

finalNode :: NodeID -> NodePos
finalNode _ = { x : -10.0
              , y : maxHeight + 10.0
              , r : 0.0
              , connections : []
              , value : 0
              , classes : ""
              }

interpolate :: Number -> Number -> Number -> Number
interpolate phase old new =
  let
    diff = new - old
  in
   old + phase*diff

interpolateNodes :: Number -> NodePos -> NodePos -> NodePos
interpolateNodes phase old new =
  let
    intphase = interpolate phase
  in
   new { x = intphase old.x new.x
       , y = intphase old.y new.y
       , r = intphase old.r new.r
       }

viewNodePos :: Number -> NodeMap -> NodeMap -> NodeID -> Array (H.Html Action)
viewNodePos phase prevmap currmap nid =
  let
    interphase = interpolateNodes phase
    prev = fromMaybe (initialNode nid) (M.lookup nid prevmap)
    curr = fromMaybe (finalNode nid) (M.lookup nid currmap)
    node = interphase prev curr
    circ = H.circle [ HA.cx (show $ node.x)
                    , HA.cy (show $ node.y)
                    , HA.r (show $ node.r)
                    , HA.className (node.classes <> " node")
                    ] [ ]
    val = svgText [ HA.x (show $ node.x)
                  , HA.y (show $ node.y + 6.0)
                  , HA.textAnchor "middle" ] [ H.text (show node.value)]
    edges = filterMap (\n ->
                        let
                          mnode = M.lookup n currmap
                        in
                         case mnode of
                           Nothing -> Nothing
                           Just currEdge ->
                             let
                               prevEdge = fromMaybe (initialNode n) (M.lookup n prevmap)
                               edgeNode = interphase prevEdge currEdge
                               signX = if node.x < edgeNode.x then 1.0 else -1.0
                               signY = if node.y < edgeNode.y then 1.0 else -1.0
                               invtan = atan ((node.y - edgeNode.y) / (node.x - edgeNode.x))
                             in
                              Just $ H.line [ HA.x1 (show $ node.x + signX*cos invtan * node.r)
                                            , HA.y1 (show $ node.y - signY*sin invtan * node.r)
                                            , HA.x2 (show $ edgeNode.x - signX*cos invtan * edgeNode.r)
                                            , HA.y2 (show $ edgeNode.y + signY*sin invtan * edgeNode.r)
                                            , HA.className "edge"] [ ]) node.connections
  in
   circ : val : edges

view :: Model -> H.Html Action
view model =
  let
    keys = M.keys $ M.union model.prevNodes model.currNodes
    showNodes = viewNodePos model.animationPhase model.prevNodes model.currNodes
    nodes = concatMap showNodes (fromFoldable keys)
    stackDiv = H.div [ HA.className "render" ] [ H.svg [HA.height (show maxHeight)
                                                       , HA.width (show maxWidth)  ] nodes ]
    dataBtn = H.div [ ] [ H.button [ HA.className "pure-button pure-button-warning"
                                   , HE.onClick $ const ShowStructure
                                   ] [ H.text "Queue Structure" ]
                        ]
    emptyBtn = H.div [ ] [ H.button [ HA.className "pure-button"
                                    , HE.onClick $ const Empty
                                    ] [ H.text "Empty" ]
                         ]
    topBtn = H.button [ HA.className "pure-button"
                      , HE.onClick $ const Top
                      ] [ H.text "Top" ]
    popBtn = H.button [ HA.className "pure-button"
                      , HE.onClick $ const Pop
                      ] [ H.text "Pop / Unshift" ]
    frontDiv = H.div [ ] [ topBtn, popBtn ]
    backBtn = H.button [ HA.className "pure-button"
                       , HE.onClick $ const Bottom
                       ] [ H.text "Back" ]
    ejectBtn = H.button [ HA.className "pure-button"
                        , HE.onClick $ const Eject
                        ] [ H.text "Eject" ]
    backDiv = H.div [ ] [ backBtn, ejectBtn ]
    consSpan = H.div [ ] [ H.span [ ] [ H.button [ HA.className "pure-button"
                                                 , HE.onClick $ const Inject
                                                 ] [ H.text "Inject / Shift"]
                                      , H.button [ HA.className "pure-button"
                                                 , HE.onClick $ const Push
                                                 ] [ H.text "Push" ]
                                      , H.input [ HA.type_ "number"
                                                , HE.onChange $ \t -> CurrentInput t.target.value
                                                ] [ ]]
                         ]
    controlDiv = H.div [ HA.className "pure-u-1-2" ] [ dataBtn
                                                     , emptyBtn
                                                     , frontDiv
                                                     , backDiv
                                                     , consSpan
                                                     ]
    codeDiv = H.div [ HA.className "pure-u-1-2" ]
                    [ H.code [ ]
                      [ H.pre [ ]
                        [ case model.currFn of
                             Nothing ->
                               H.i []
                                   [ H.text "No implementation given or no function selected"]
                             Just fn -> H.text fn ]
                      ]
                    ]
  in
   H.div [ HA.className "pure-g" ] [ stackDiv
                                   , controlDiv
                                   , codeDiv
                                   ]


Use a less confusing representation for input values

{-
Copyright 2015 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 Notebook.Cell.JTable.Component.Render (render) where

import Prelude

import Control.Bind (join)

import Data.Array as A
import Data.Char (fromCharCode)
import Data.Either (Either(), either)
import Data.Functor (($>))
import Data.Functor.Coproduct (left, right)
import Data.Int as Int
import Data.Json.JTable as JT
import Data.Maybe (Maybe(..), isNothing, fromMaybe)
import Data.String (fromChar)

import Halogen
import Halogen.HTML.Indexed as H
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Events.Handler as E
import Halogen.HTML.Properties.Indexed as P
import Halogen.Themes.Bootstrap3 as B

import Render.Common (glyph)
import Render.CssClasses as CSS

import Notebook.Cell.Common.EvalQuery (CellEvalQuery(..))
import Notebook.Cell.JTable.Component.Query
import Notebook.Cell.JTable.Component.State

-- | A value that holds all possible states for an inputtable value: the current
-- | actual value, and a possible pending user-entered or selected value.
type InputValue a =
  { current :: a
  , pending :: Maybe (Either String a)
  }

-- | Converts an `InputValue` into a string for use as a HTML form field value.
fromInputValue :: forall a. (Show a) => InputValue a -> String
fromInputValue { current, pending } =
  case pending of
    Nothing -> show current
    Just pending' -> either id show pending'

render :: State -> ComponentHTML QueryP
render { result: Nothing } = H.div_ []
render st@{ result: Just result } =
  let p = currentPageInfo st
  in H.div_
    [ right <$> JT.renderJTable jTableOpts result.json
    , H.div
        [ P.class_ CSS.pagination ]
        [ prevButtons (p.page <= 1)
        , pageField { current: p.page, pending: st.page } p.totalPages
        , nextButtons (p.page >= p.totalPages)
        , pageSizeControls st.isEnteringPageSize { current: p.pageSize, pending: st.pageSize }
        ]
    ]

jTableOpts :: JT.JTableOpts
jTableOpts = JT.jTableOptsDefault
  { style = JT.bootstrapStyle
  , columnOrdering = JT.alphaOrdering
  }

prevButtons :: Boolean -> ComponentHTML QueryP
prevButtons enabled =
  H.div
    [ P.classes [B.btnGroup] ]
    [ H.button
        [ P.classes [B.btn, B.btnSm, B.btnDefault]
        , P.disabled enabled
        , E.onClick $ E.input_ (right <<< StepPage First)
        ]
        [ glyph B.glyphiconFastBackward ]
    , H.button
        [ P.classes [B.btn, B.btnSm, B.btnDefault]
        , P.disabled enabled
        , E.onClick $ E.input_ (right <<< StepPage Prev)
        ]
        [ glyph B.glyphiconStepBackward ]
    ]

pageField :: InputValue Int -> Int -> ComponentHTML QueryP
pageField pageValue totalPages =
  H.div
    [ P.classes [CSS.pageInput] ]
    [ submittable
        [ H.text "Page"
        , H.input
            [ P.classes [B.formControl, B.inputSm]
            , P.value (fromInputValue pageValue)
            , E.onValueInput (E.input (\x -> right <<< SetCustomPage x))
            ]
        , H.text $ "of " ++ (show totalPages)
        ]
    ]

submittable :: Array (ComponentHTML QueryP) -> ComponentHTML QueryP
submittable =
  H.form
    [ E.onSubmit (\_ -> E.preventDefault $> action (left <<< NotifyRunCell)) ]

nextButtons :: Boolean -> ComponentHTML QueryP
nextButtons enabled =
  H.div
    [ P.classes [B.btnGroup] ]
    [ H.button
        [ P.classes [B.btn, B.btnSm, B.btnDefault]
        , P.disabled enabled
        , E.onClick $ E.input_ (right <<< StepPage Next)
        ]
        [ glyph B.glyphiconStepForward ]
    , H.button
        [ P.classes [B.btn, B.btnSm, B.btnDefault]
        , P.disabled enabled
        , E.onClick $ E.input_ (right <<< StepPage Last)
        ]
        [ glyph B.glyphiconFastForward ]
    ]

pageSizeControls :: Boolean -> InputValue Int -> ComponentHTML QueryP
pageSizeControls showCustom pageSize =
  H.div
    [ P.classes [CSS.pageSize] ]
    [ submittable
         $ [ H.text "Per page:" ]
        ++ [ if showCustom
             then H.input
                [ P.classes [B.formControl, B.inputSm]
                , P.value (fromInputValue pageSize)
                , E.onValueInput (E.input (\v -> right <<< SetCustomPageSize v))
                ]
             else H.select
                [ P.classes [B.formControl, B.inputSm]
                , E.onValueChange
                    (E.input (\v ->
                      right <<<
                        if v == "Custom"
                        then StartEnterCustomPageSize
                        else ChangePageSize v))
                ]
                pageOptions
           ]
    ]
  where

  sizeNum = fromMaybe 10 $ Int.fromString (fromInputValue pageSize)

  sizeValues = [10, 25, 50, 100]

  pageOptions = join
    [ option <$> sizeValues
    , dividerOption
    , customOption
    , [ H.option_ [ H.text "Custom" ] ]
    ]

  option value =
    H.option
      [ P.selected (value == sizeNum) ]
      [ H.text (show value) ]

  -- An unselectable option dividing the custom values from the presets
  dividerOption =
    [ H.option [ P.disabled true ] [ H.text $ fromChar $ fromCharCode 8212 ] ]

  -- If a custom value has been entered, create an entry for it in the dropdown
  customOption =
    if isNothing (A.elemIndex sizeNum sizeValues)
    then [ H.option [P.selected true] [H.text (show sizeNum)] ]
    else []

{-
Copyright 2015 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 Notebook.Cell.JTable.Component.Render (render) where

import Prelude

import Control.Bind (join)

import Data.Array as A
import Data.Char (fromCharCode)
import Data.Either (Either(), either)
import Data.Functor (($>))
import Data.Functor.Coproduct (left, right)
import Data.Int as Int
import Data.Json.JTable as JT
import Data.Maybe (Maybe(..), isNothing, fromMaybe)
import Data.String (fromChar)
import Data.Tuple (Tuple(..))

import Halogen
import Halogen.HTML.Indexed as H
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Events.Handler as E
import Halogen.HTML.Properties.Indexed as P
import Halogen.Themes.Bootstrap3 as B

import Render.Common (glyph)
import Render.CssClasses as CSS

import Notebook.Cell.Common.EvalQuery (CellEvalQuery(..))
import Notebook.Cell.JTable.Component.Query
import Notebook.Cell.JTable.Component.State

render :: State -> ComponentHTML QueryP
render { result: Nothing } = H.div_ []
render st@{ result: Just result } =
  let p = currentPageInfo st
  in H.div_
    [ right <$> JT.renderJTable jTableOpts result.json
    , H.div
        [ P.class_ CSS.pagination ]
        [ prevButtons (p.page <= 1)
        , pageField (Tuple st.page p.page) p.totalPages
        , nextButtons (p.page >= p.totalPages)
        , pageSizeControls st.isEnteringPageSize (Tuple st.pageSize p.pageSize)
        ]
    ]

jTableOpts :: JT.JTableOpts
jTableOpts = JT.jTableOptsDefault
  { style = JT.bootstrapStyle
  , columnOrdering = JT.alphaOrdering
  }

prevButtons :: Boolean -> ComponentHTML QueryP
prevButtons enabled =
  H.div
    [ P.classes [B.btnGroup] ]
    [ H.button
        [ P.classes [B.btn, B.btnSm, B.btnDefault]
        , P.disabled enabled
        , E.onClick $ E.input_ (right <<< StepPage First)
        ]
        [ glyph B.glyphiconFastBackward ]
    , H.button
        [ P.classes [B.btn, B.btnSm, B.btnDefault]
        , P.disabled enabled
        , E.onClick $ E.input_ (right <<< StepPage Prev)
        ]
        [ glyph B.glyphiconStepBackward ]
    ]

pageField :: Tuple (Maybe (Either String Int)) Int -> Int -> ComponentHTML QueryP
pageField pageValue totalPages =
  H.div
    [ P.classes [CSS.pageInput] ]
    [ submittable
        [ H.text "Page"
        , H.input
            [ P.classes [B.formControl, B.inputSm]
            , P.value (toValue pageValue)
            , E.onValueInput (E.input (\x -> right <<< SetCustomPage x))
            ]
        , H.text $ "of " ++ (show totalPages)
        ]
    ]

submittable :: Array (ComponentHTML QueryP) -> ComponentHTML QueryP
submittable =
  H.form
    [ E.onSubmit (\_ -> E.preventDefault $> action (left <<< NotifyRunCell)) ]

nextButtons :: Boolean -> ComponentHTML QueryP
nextButtons enabled =
  H.div
    [ P.classes [B.btnGroup] ]
    [ H.button
        [ P.classes [B.btn, B.btnSm, B.btnDefault]
        , P.disabled enabled
        , E.onClick $ E.input_ (right <<< StepPage Next)
        ]
        [ glyph B.glyphiconStepForward ]
    , H.button
        [ P.classes [B.btn, B.btnSm, B.btnDefault]
        , P.disabled enabled
        , E.onClick $ E.input_ (right <<< StepPage Last)
        ]
        [ glyph B.glyphiconFastForward ]
    ]

pageSizeControls :: Boolean -> Tuple (Maybe (Either String Int)) Int -> ComponentHTML QueryP
pageSizeControls showCustom pageSize =
  H.div
    [ P.classes [CSS.pageSize] ]
    [ submittable
         $ [ H.text "Per page:" ]
        ++ [ if showCustom
             then H.input
                [ P.classes [B.formControl, B.inputSm]
                , P.value (toValue pageSize)
                , E.onValueInput (E.input (\v -> right <<< SetCustomPageSize v))
                ]
             else H.select
                [ P.classes [B.formControl, B.inputSm]
                , E.onValueChange
                    (E.input (\v ->
                      right <<<
                        if v == "Custom"
                        then StartEnterCustomPageSize
                        else ChangePageSize v))
                ]
                pageOptions
           ]
    ]
  where

  sizeNum = fromMaybe 10 $ Int.fromString (toValue pageSize)

  sizeValues = [10, 25, 50, 100]

  pageOptions = join
    [ option <$> sizeValues
    , dividerOption
    , customOption
    , [ H.option_ [ H.text "Custom" ] ]
    ]

  option value =
    H.option
      [ P.selected (value == sizeNum) ]
      [ H.text (show value) ]

  -- An unselectable option dividing the custom values from the presets
  dividerOption =
    [ H.option [ P.disabled true ] [ H.text $ fromChar $ fromCharCode 8212 ] ]

  -- If a custom value has been entered, create an entry for it in the dropdown
  customOption =
    if isNothing (A.elemIndex sizeNum sizeValues)
    then [ H.option [P.selected true] [H.text (show sizeNum)] ]
    else []

toValue :: Tuple (Maybe (Either String Int)) Int -> String
toValue (Tuple custom actual) =
  case custom of
    Nothing -> show actual
    Just custom' -> either id show custom'