Fix: Actually go to baby station view

Fix: Actually go to baby station view

-- | Loaded application ui logic
module Gonimo.UI.Loaded where

import Gonimo.UI.Html
import Data.Array as Arr
import Data.List as List
import Data.Map as Map
import Data.Tuple as Tuple
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Router as Router
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Error as Error
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Overview as OverviewC
import Gonimo.UI.Socket as SocketC
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Lenses as SocketC
import Gonimo.UI.Socket.Types as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Gonimo.WebAPI.Subscriber as Sub
import Pux.Html as H
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Bootstrap as A
import Pux.Html.Events as E
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Class (class MonadReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, modify, put)
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Array (fromFoldable, concat, catMaybes, head)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Right, Left))
import Data.Foldable (foldl)
import Data.Generic (class Generic)
import Data.Generic (gShow)
import Data.Lens (_Just, (.=), to, (^.), (^?))
import Data.Map (Map)
import Data.Maybe (fromMaybe, isNothing, maybe, Maybe(..))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Semigroup (append)
import Data.String (takeWhile)
import Data.Traversable (traverse)
import Data.Tuple (uncurry, fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Types (toIO, Settings, GonimoError, class ReportErrorAction, Gonimo)
import Gonimo.Pux (noEffects, Component, toParent, runGonimo, liftChild, ComponentType, makeChildData, ToChild, onlyModify, Update, wrapAction)
import Gonimo.Server.DbEntities (Device(Device), Family(Family))
import Gonimo.Server.DbEntities.Helpers (runFamily)
import Gonimo.Server.Error (ServerError(InvalidAuthToken))
import Gonimo.Server.Types (DeviceType(Baby, NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (dateToString, Key(Key), Secret(Secret))
import Gonimo.UI.Error (viewError, class ErrorAction, UserError(NoError, DeviceInvalid), handleSubscriber, handleError)
import Gonimo.UI.Loaded.Central (getCentrals)
import Gonimo.UI.Loaded.Types (mkInviteProps', CentralReq(..), mkInviteProps, mkSettings, mkProps, central, familyIds, authData, currentFamily, socketS, overviewS, Props, acceptS, inviteS, State, Action(..), Central(..), InviteProps)
import Gonimo.UI.Socket (viewParentChannels, getParentChannels)
import Gonimo.Util (userShow, toString, fromString)
import Gonimo.WebAPI (postInvitationsByFamilyId, postFamilies, getFamiliesByFamilyId, postFunnyName, deleteOnlineStatusByFamilyIdByDeviceId, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (DeviceInfo(DeviceInfo), AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (text, small, script, li, i, a, nav, h3, h2, td, tbody, th, tr, thead, table, ul, p, button, input, h1, span, Html, img, div)
import Pux.Html.Attributes (letterSpacing, offset)
import Pux.Html.Events (FormEvent, FocusEvent)
import Pux.Router (navigateTo)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber)
import Servant.Subscriber.Connection (Notification(HttpRequestFailed, ParseError, WebSocketClosed, WebSocketError))
import Servant.Subscriber.Internal (doDecode, coerceEffects)
import Servant.Subscriber.Request (HttpRequest(HttpRequest))
import Servant.Subscriber.Response (HttpResponse(HttpResponse))
import Servant.Subscriber.Subscriptions (Subscriptions)
import Servant.Subscriber.Util (toUserType)
import Signal (constant, Signal)
import Prelude hiding (div)

update :: Update Unit State Action
update (SetState state)                        = put state *> pure []
update (ReportError err)                       = handleError err
update (InviteA _ InviteC.GoToOverview)        = handleRequestCentral ReqCentralOverview
update (InviteA _ InviteC.GoToBabyStation)     = handleRequestCentral ReqCentralBaby
update (InviteA _ (InviteC.ReportError err))   = handleError err
update (InviteA mProps action)                 = updateInvite mProps action
update (AcceptA (AcceptC.ReportError err))     = handleError err
update (AcceptA action)                        = updateAccept action
update (SocketA (SocketC.ReportError err))     = handleError err
update (SocketA action)                        = updateSocket action
update (OverviewA (OverviewC.SocketA socketA)) = updateSocket socketA
update (OverviewA OverviewC.GoToInviteView)    = handleRequestCentral ReqCentralInvite
update (OverviewA action)                      = updateOverview action
update (SetFamilyIds ids)                      = handleSetFamilyIds ids
update (UpdateFamily familyId' family')        = onlyModify $ \state ->  state { families = Map.insert familyId' family' state.families }
update (RequestCentral c)                      = handleRequestCentral c
update (SetCentral c)                          = handleSetCentral c
update (SetOnlineDevices devices)              = onlyModify $ _ { onlineDevices = devices }
update (SetDeviceInfos devices)                = onlyModify $ _ { deviceInfos = devices }
update (SetURL url)                            = handleSetURL url
update (HandleSubscriber msg)                  = handleSubscriber msg
update ResetDevice                             = handleResetDevice
update ClearError                              = handleClearError
update Nop                                     = noEffects

toInvite :: InviteProps -> ToChild Unit State InviteProps InviteC.State
toInvite props = pure $ makeChildData inviteS props

toAccept :: ToChild Unit State Props AcceptC.State
toAccept = do
  props <- mkProps <$> get
  pure $ makeChildData acceptS props

toOverview :: ToChild Unit State Props OverviewC.State
toOverview = do
  props <- mkProps <$> get
  pure $ makeChildData overviewS props

toSocket :: ToChild Unit State Props SocketC.State
toSocket = do
  props <- mkProps <$> get
  pure $ makeChildData socketS props

updateInvite :: Maybe InviteProps -> InviteC.Action -> ComponentType Unit State Action
updateInvite mProps iAction = do
  state <- get :: Component Unit State State
  let props = mkInviteProps state <|> mProps -- State props have higher priority!
  case props of
    Nothing -> pure $
              [ toIO (mkSettings $ state^.authData) $ do
                    name <- postFunnyName
                    fid' <- postFamilies name
                    family' <- getFamiliesByFamilyId fid'
                    let newProps = mkInviteProps' fid' family' state
                    pure $ InviteA (Just newProps) iAction
              ]
    Just rProps ->
      toParent [] (InviteA Nothing) <<< liftChild (toInvite rProps) <<< InviteC.update $ iAction

updateAccept :: AcceptC.Action -> ComponentType Unit State Action
updateAccept = toParent [] AcceptA <<< liftChild toAccept <<< AcceptC.update

updateOverview :: OverviewC.Action -> ComponentType Unit State Action
updateOverview = toParent [] OverviewA <<< liftChild toOverview <<< OverviewC.update

updateSocket :: SocketC.Action -> ComponentType Unit State Action
updateSocket action = do
  case action of
    SocketC.SetAuthData _ -> handleSetAuthData
    _ -> pure unit
  toParent [] SocketA <<< liftChild toSocket $ SocketC.update action

inviteEffect :: forall m. Monad m => Secret -> m Action
inviteEffect = pure <<< AcceptA <<< AcceptC.LoadInvitation

handleResetDevice :: ComponentType Unit State Action
handleResetDevice = do
  props <- mkProps <$> get :: Component Unit State State
  pure $ [ toIO props.settings $ do
              liftEff $ localStorage.removeItem Key.authData
              SocketA <<< SocketC.SetAuthData <$> getAuthData
         ]

handleRequestCentral :: CentralReq -> ComponentType Unit State Action
handleRequestCentral c = do
  state <- get
  case c of
    ReqCentralInvite -> do
      let invProps = mkInviteProps state
      case invProps of
        Nothing -> pure
                   [ toIO (mkSettings $ state^.authData) $ do
                        name <- postFunnyName
                        fid' <- postFamilies name
                        family' <- getFamiliesByFamilyId fid'
                        let newProps = mkInviteProps' fid' family' state
                        invData <- postInvitationsByFamilyId fid'
                        pure <<< SetCentral <<< CentralInvite $ (InviteC.init invData newProps)
                   ]
        Just props -> pure
                      [ toIO (mkSettings $ state^.authData) $ do
                           invData <- postInvitationsByFamilyId props.rFamilyId
                           pure <<< SetCentral $ CentralInvite (InviteC.init invData props)
                      ]
    ReqCentralOverview -> handleSetCentral CentralOverview
    ReqCentralBaby     -> handleSetCentral CentralBaby

handleSetCentral :: Central -> ComponentType Unit State Action
handleSetCentral central' = central .= central' *> noEffects

handleSetAuthData :: Component Unit State Unit
handleSetAuthData = modify $ \state -> state
                                  {
                                   userError = case state.userError of
                                      DeviceInvalid -> NoError
                                      _ -> state.userError
                                  }
handleSetFamilyIds :: Array (Key Family) -> ComponentType Unit State Action
handleSetFamilyIds ids = do
  familyIds .= ids
  state <- get :: Component Unit State State
  if isNothing state.socketS.currentFamily
    then pure $ fromFoldable $ pure <<< SocketA <<< SocketC.SwitchFamily <$> Arr.head ids
    else noEffects

handleSetURL :: String -> ComponentType Unit State Action
handleSetURL url = do
  let
    route = Router.match url
    withoutQuery = takeWhile (_ /= '?') url
  case route of
    Router.Home -> onlyModify $ _ { url = url }
    Router.AcceptInvitation s -> do
      modify $ _ { url = withoutQuery
                 }
      actions <- handleSetCentral $ CentralAccept (AcceptC.init)
      pure $ [ do
               liftEff $ navigateTo withoutQuery
               inviteEffect s
             ] <> actions

handleClearError :: ComponentType Unit State Action
handleClearError = do
  state <- (get :: Component Unit State State)
  let
    newCentral = case state.central of
      CentralAccept (Just _) -> state.central
      _                     -> CentralOverview

  onlyModify $ _ { userError = NoError
                 , central = newCentral
                 }

--------------------------------------------------------------------------------

view :: State -> Html Action
view state =
  let
    numDevices = Arr.length state.onlineDevices
  in
    case state.userError of
      NoError ->
        div []
        [ viewHeader state
        , viewCentral state
        , div []
          [ h3 [] [ text "Videos - yeah:" ]
          , div [] $ map SocketA <$> viewParentChannels state.socketS
          ]
        , div []
          [ h3 [] [ text $ show numDevices <> " Device(s) currently online:" ]
          , div [] [ viewOnlineDevices state ]
          ]
        ]
      err -> viewError state

viewHeader :: State -> Html Action
viewHeader state =
      nav [ A.className "navbar navbar-default" ]
      [ div [ A.className "container"]
        [ div [ A.className "navbar-header"]
          [ a [ A.className "navbar-brand navbar-left"]
            [ img [ A.alt "gonimo"
                  , A.src "./pix/gonimo-logo-05.svg"
                  , A.width "35px"
                  , A.height "35px"] []
            ]
          ]

        , div [ A.className "collapse navbar-collapse"]
          [ ul [ A.className "nav navbar-nav"] $
            (viewCentralItem <$> getCentrals state) <>
            [ li []
              [ ul [ A.className "nav navbar-nav "]
                [ li [A.className "dropdown"]
                  [ a [ A.className "dropdown-toggle" , A.href "#"
                      , A.dataToggle "dropdown"       , A.role "button"]
                    [ i [A.className "fa fa-users"] []
                    , text " "
                    , text "funky hedgehogs"
                    , text " "
                    , span [A.className "caret"] [] ]
                  , ul [A.className "dropdown-menu"]
                    [ li [] [div [A.className "navbar-text"] [text "Change family to"]]
                    , li [] [a [] [text "wild frogs"]]
                    , li [] [a [] [text "funny cats"]]
                    , li [] [a [] [text "running dogs"]]
                    , li [] [a [] [ text "funky hedgehogs"
                                  , text " ✔"
                                  ]
                            ]
                    ]
                  ]
                ]
              ]
            , li [A.className "dropdown"]
              [ a [ A.className "dropdown-toggle" , A.href "#"
                  , A.dataToggle "dropdown"       , A.role "button"
                  , A.style [Tuple "minWidth" "180px"]]
                [ i [A.className "fa fa-user"] []
                , text " "
                , text "epsilonhalbe"
                , text " "
                , span [A.className "caret"] []
                ]
              , ul [A.className "dropdown-menu", A.style [Tuple "minWidth" "180px"]]
                [ li [] [a [] [text " User settings "
                              ,i [A.className "fa fa-cog pull-right"] []]]
                , li [] [ a [] [ text "Change password "
                               , i [A.className "fa fa-lock pull-right" ][]
                               ]]
                , li [A.className "divider", A.role "separator"] []
                , li [] [a [] [ text "Log-Out "
                              , i [A.className "fa fa-sign-out pull-right"] []
                              ]]
                ]
              ]
            ]
          ]
         ]
       ]

  where
    viewCentralItem :: Tuple Boolean CentralReq -> Html Action
    viewCentralItem (Tuple active item) =
      li [ A.className $ "nav navbar-nav" <> if active then " active" else "" ]
      [ a [ E.onClick $ const $ RequestCentral item ]
        [ text (userShow item) ]
      ]

-- viewNavbar :: State -> Html Action
-- viewNavbar state =
--        nav [ A.className "navbar navbar-default" ]
--         [ div [ A.className "container-fluid" ]
--           [ -- Brand and toggle get grouped for better mobile display
--             div [ A.className "navbar-header" ]
--             [ button [ A.type_ "button"
--                      , A.className "navbar-toggle collapsed"
--                      , A.dataToggle "collapse"
--                      , A.dataTarget "navbar-collapse-1"
--                      ]
--               [ span [ A.className "sr-only" ] [ text "Toggle navigation" ]
--               , span [ A.className "icon-bar" ] []
--               , span [ A.className "icon-bar" ] []
--               , span [ A.className "icon-bar" ] []
--               ]
--             , a [ A.className "navbar-brand"
--                 , A.role "button"
--                 , E.onClick $ const $ SetCentral centralOverview
--                 ]
--                 [ text "Overview" ]
--             , a [ A.className "navbar-brand"
--                 , A.role "button"
--                 , E.onClick $ const $ SetCentral CentralInvite
--                 ]
--               [ text "Invite" ]
--             ]
--           , -- Collect the nav links, forms, and other content for toggling
--             div [ A.className "collapse navbar-collapse", A.id_ "navbar-collapse-1" ]
--             [
--               ul [ A.className "nav navbar-nav" ]
--               [ li []
--                 [ viewFamilyChooser state
--                 ]
--               ]
--             , ul [ A.className "nav navbar-nav navbar-right" ]
--               [ li [ A.className "dropdown" ]
--                 [ a [ A.className "dropdown-toggle"
--                          , A.dataToggle "dropdown"
--                          , A.role "button"
--                          ]
--                   [ text "Account" , span [ A.className "caret" ] [] ]
--                   , ul [ A.className "dropdown-menu" ]
--                     [ li [] [ a [ A.href "#" ] [ text "Configure User Details" ] ]
--                     , li [] [ a [ A.href "#" ] [ text "change password" ] ]
--                     , li [ A.role "separator",  A.className "divider" ] []
--                     , li [] [ a [ A.href "#" ] [ text "Log out" ] ]
--                     ]
--                   ]
--                 ]
--               ]
--             ]
--           ]

viewCentral :: State -> Html Action
viewCentral state =
  let
    props = mkProps state
    invProps = mkInviteProps state
  in
   case state.central of
    CentralInvite s -> case invProps of
      Nothing -> viewLoading "Loading, please wait ..."
      Just invProps' -> map (InviteA Nothing) $ InviteC.view invProps' s
    CentralAccept s -> map AcceptA $ AcceptC.view s
    CentralOverview     -> map OverviewA   $ OverviewC.view props state.overviewS
    CentralBaby     -> map SocketA   $ SocketC.view props state.socketS

viewOnlineDevices :: State -> Html Action
viewOnlineDevices state = table [ A.className "table table-striped"]
                          [ head
                          , body
                          ]
  where
    head = thead []
           [ tr []
             [ th [ A.className "centered"] [ text "Online" ]
             , th [ A.className "centered"] [ text "Type" ]
             , th [] [ text "Name" ]
             , th [] [ text "Last Seen"]
             , th [] []
             , th [] []
             , th [] []
             ]
           ]
    body = tbody []
           <<< Arr.mapMaybe viewOnlineDevice
           $ map fst state.onlineDevices
    viewOnlineDevice deviceId = do
        (DeviceInfo info) <- Tuple.lookup deviceId state.deviceInfos
        let name = info.deviceInfoName
        let lastAccessed = dateToString info.deviceInfoLastAccessed
        pure $ tr []
               [ td [A.className "centered"] [ i [ A.className ("fa fa-" <> "circle-o") -- "check-circle"
                       , A.dataToggle "tooltip"
                       , A.dataPlacement "right"
                       , A.title "offline" ] []]
                       --, A.title "online" ] []]
               , td [A.className "centered"]
                   [ i [ A.className ("fa fa-" <> "mobile")
                       , A.dataToggle "tooltip"
                       , A.dataPlacement "right"
                       , A.title "edit device name" ] []
                       ]
               , td [] [ text name ]
               , td [] [ text lastAccessed ]
               , td [] [ i [ A.className "fa fa-pencil"
                       , A.dataToggle "tooltip"
                       , A.dataPlacement "right"
                       , A.title "edit device name" ] []
                       ]
               , td [] [ i [ A.className "fa fa-trash"
                       , A.dataToggle "tooltip"
                       , A.dataPlacement "right"
                       , A.title "delete device from family" ] []]
               ]

viewFamilyChooser :: State -> Html Action
viewFamilyChooser state = H.div []
                          [ H.label [ A.htmlFor "familySelect" ] [ text "Family: " ]
                          , H.select [ A.id_ "familySelect"
                                     , A.className "form-control"
                                     , E.onInput doSwitchFamily
                                     ]
                            $ fromFoldable
                            <<< map (uncurry makeOption)
                            <<< Map.toList $ state.families
                          ]
  where
    doSwitchFamily :: FormEvent -> Action
    doSwitchFamily ev = maybe Nop (SocketA <<< SocketC.SwitchFamily) $ fromString ev.target.value

    makeOption :: Key Family -> Family -> Html Action
    makeOption familyId (Family family) = H.option [ A.value (toString familyId) ]
                                          [ text family.familyName ]

--------------------------------------------------------------------------------
getSubscriptions :: State -> Subscriptions Action
getSubscriptions state =
  let
    familyId = state^?currentFamily

    --subscribeGetFamily :: forall m. MonadReader Settings m => Key Family -> m (Subscriptions Action)
    subscribeGetFamily familyId' =
      Sub.getFamiliesByFamilyId (maybe Nop (UpdateFamily familyId')) familyId'

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader (mkSettings $ state^.authData)) <<< concat $
      [ [ Sub.getAccountsByAccountIdFamilies (maybe Nop SetFamilyIds)
                                          (runAuthData $ state^.authData).accountId
        ]
      , fromFoldable $
        Sub.getOnlineStatusByFamilyId (maybe Nop SetOnlineDevices) <$> familyId
      , fromFoldable $
        Sub.getFamiliesByFamilyIdDeviceInfos (maybe Nop SetDeviceInfos) <$> familyId
      , map subscribeGetFamily state.familyIds
      ]
  in
   case state.userError of
     NoError -> foldl append mempty subArray <> map SocketA (SocketC.getSubscriptions (mkProps state) state.socketS)
     _       -> mempty

getPongRequest :: State -> Maybe HttpRequest
getPongRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    onlineStatus' = state ^. socketS <<< to SocketC.toDeviceType
    deviceData = Tuple deviceId onlineStatus'
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <<< Reqs.postOnlineStatusByFamilyId deviceData <$> familyId
     _ -> Nothing

getCloseRequest :: State -> Maybe HttpRequest
getCloseRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <<< flip Reqs.deleteOnlineStatusByFamilyIdByDeviceId deviceId <$> familyId
     _ -> Nothing

-- | Retrieve AuthData from local storage or if not present get new one from server
getAuthData :: Gonimo AuthData
getAuthData = do
  md <- liftEff $ localStorage.getItem Key.authData
  Gonimo.log $ "Got authdata from local storage: " <> gShow md
  case md of
    Nothing -> do
      auth <- postAccounts
      Gonimo.log $ "Got Nothing - called postAccounts and got: " <> gShow auth
      Gonimo.log $ "Calling setItem with : " <> gShow Key.authData
      liftEff $ localStorage.setItem Key.authData auth
      pure auth
    Just d  -> pure d

-- | Loaded application ui logic
module Gonimo.UI.Loaded where

import Gonimo.UI.Html
import Data.Array as Arr
import Data.List as List
import Data.Map as Map
import Data.Tuple as Tuple
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Router as Router
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Error as Error
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Overview as OverviewC
import Gonimo.UI.Socket as SocketC
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Lenses as SocketC
import Gonimo.UI.Socket.Types as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Gonimo.WebAPI.Subscriber as Sub
import Pux.Html as H
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Bootstrap as A
import Pux.Html.Events as E
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Class (class MonadReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, modify, put)
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Array (fromFoldable, concat, catMaybes, head)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Right, Left))
import Data.Foldable (foldl)
import Data.Generic (class Generic)
import Data.Generic (gShow)
import Data.Lens (_Just, (.=), to, (^.), (^?))
import Data.Map (Map)
import Data.Maybe (fromMaybe, isNothing, maybe, Maybe(..))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Semigroup (append)
import Data.String (takeWhile)
import Data.Traversable (traverse)
import Data.Tuple (uncurry, fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Types (toIO, Settings, GonimoError, class ReportErrorAction, Gonimo)
import Gonimo.Pux (noEffects, Component, toParent, runGonimo, liftChild, ComponentType, makeChildData, ToChild, onlyModify, Update, wrapAction)
import Gonimo.Server.DbEntities (Device(Device), Family(Family))
import Gonimo.Server.DbEntities.Helpers (runFamily)
import Gonimo.Server.Error (ServerError(InvalidAuthToken))
import Gonimo.Server.Types (DeviceType(Baby, NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (dateToString, Key(Key), Secret(Secret))
import Gonimo.UI.Error (viewError, class ErrorAction, UserError(NoError, DeviceInvalid), handleSubscriber, handleError)
import Gonimo.UI.Loaded.Central (getCentrals)
import Gonimo.UI.Loaded.Types (mkInviteProps', CentralReq(..), mkInviteProps, mkSettings, mkProps, central, familyIds, authData, currentFamily, socketS, overviewS, Props, acceptS, inviteS, State, Action(..), Central(..), InviteProps)
import Gonimo.UI.Socket (viewParentChannels, getParentChannels)
import Gonimo.Util (userShow, toString, fromString)
import Gonimo.WebAPI (postInvitationsByFamilyId, postFamilies, getFamiliesByFamilyId, postFunnyName, deleteOnlineStatusByFamilyIdByDeviceId, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (DeviceInfo(DeviceInfo), AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (text, small, script, li, i, a, nav, h3, h2, td, tbody, th, tr, thead, table, ul, p, button, input, h1, span, Html, img, div)
import Pux.Html.Attributes (letterSpacing, offset)
import Pux.Html.Events (FormEvent, FocusEvent)
import Pux.Router (navigateTo)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber)
import Servant.Subscriber.Connection (Notification(HttpRequestFailed, ParseError, WebSocketClosed, WebSocketError))
import Servant.Subscriber.Internal (doDecode, coerceEffects)
import Servant.Subscriber.Request (HttpRequest(HttpRequest))
import Servant.Subscriber.Response (HttpResponse(HttpResponse))
import Servant.Subscriber.Subscriptions (Subscriptions)
import Servant.Subscriber.Util (toUserType)
import Signal (constant, Signal)
import Prelude hiding (div)

update :: Update Unit State Action
update (SetState state)                        = put state *> pure []
update (ReportError err)                       = handleError err
update (InviteA _ InviteC.GoToOverview)        = handleRequestCentral ReqCentralOverview
update (InviteA _ InviteC.GoToBabyStation)     = handleRequestCentral ReqCentralOverview -- TODO: Fix me!
update (InviteA _ (InviteC.ReportError err))   = handleError err
update (InviteA mProps action)                 = updateInvite mProps action
update (AcceptA (AcceptC.ReportError err))     = handleError err
update (AcceptA action)                        = updateAccept action
update (SocketA (SocketC.ReportError err))     = handleError err
update (SocketA action)                        = updateSocket action
update (OverviewA (OverviewC.SocketA socketA)) = updateSocket socketA
update (OverviewA OverviewC.GoToInviteView)    = handleRequestCentral ReqCentralInvite
update (OverviewA action)                      = updateOverview action
update (SetFamilyIds ids)                      = handleSetFamilyIds ids
update (UpdateFamily familyId' family')        = onlyModify $ \state ->  state { families = Map.insert familyId' family' state.families }
update (RequestCentral c)                      = handleRequestCentral c
update (SetCentral c)                          = handleSetCentral c
update (SetOnlineDevices devices)              = onlyModify $ _ { onlineDevices = devices }
update (SetDeviceInfos devices)                = onlyModify $ _ { deviceInfos = devices }
update (SetURL url)                            = handleSetURL url
update (HandleSubscriber msg)                  = handleSubscriber msg
update ResetDevice                             = handleResetDevice
update ClearError                              = handleClearError
update Nop                                     = noEffects

toInvite :: InviteProps -> ToChild Unit State InviteProps InviteC.State
toInvite props = pure $ makeChildData inviteS props

toAccept :: ToChild Unit State Props AcceptC.State
toAccept = do
  props <- mkProps <$> get
  pure $ makeChildData acceptS props

toOverview :: ToChild Unit State Props OverviewC.State
toOverview = do
  props <- mkProps <$> get
  pure $ makeChildData overviewS props

toSocket :: ToChild Unit State Props SocketC.State
toSocket = do
  props <- mkProps <$> get
  pure $ makeChildData socketS props

updateInvite :: Maybe InviteProps -> InviteC.Action -> ComponentType Unit State Action
updateInvite mProps iAction = do
  state <- get :: Component Unit State State
  let props = mkInviteProps state <|> mProps -- State props have higher priority!
  case props of
    Nothing -> pure $
              [ toIO (mkSettings $ state^.authData) $ do
                    name <- postFunnyName
                    fid' <- postFamilies name
                    family' <- getFamiliesByFamilyId fid'
                    let newProps = mkInviteProps' fid' family' state
                    pure $ InviteA (Just newProps) iAction
              ]
    Just rProps ->
      toParent [] (InviteA Nothing) <<< liftChild (toInvite rProps) <<< InviteC.update $ iAction

updateAccept :: AcceptC.Action -> ComponentType Unit State Action
updateAccept = toParent [] AcceptA <<< liftChild toAccept <<< AcceptC.update

updateOverview :: OverviewC.Action -> ComponentType Unit State Action
updateOverview = toParent [] OverviewA <<< liftChild toOverview <<< OverviewC.update

updateSocket :: SocketC.Action -> ComponentType Unit State Action
updateSocket action = do
  case action of
    SocketC.SetAuthData _ -> handleSetAuthData
    _ -> pure unit
  toParent [] SocketA <<< liftChild toSocket $ SocketC.update action

inviteEffect :: forall m. Monad m => Secret -> m Action
inviteEffect = pure <<< AcceptA <<< AcceptC.LoadInvitation

handleResetDevice :: ComponentType Unit State Action
handleResetDevice = do
  props <- mkProps <$> get :: Component Unit State State
  pure $ [ toIO props.settings $ do
              liftEff $ localStorage.removeItem Key.authData
              SocketA <<< SocketC.SetAuthData <$> getAuthData
         ]

handleRequestCentral :: CentralReq -> ComponentType Unit State Action
handleRequestCentral c = do
  state <- get
  case c of
    ReqCentralInvite -> do
      let invProps = mkInviteProps state
      case invProps of
        Nothing -> pure
                   [ toIO (mkSettings $ state^.authData) $ do
                        name <- postFunnyName
                        fid' <- postFamilies name
                        family' <- getFamiliesByFamilyId fid'
                        let newProps = mkInviteProps' fid' family' state
                        invData <- postInvitationsByFamilyId fid'
                        pure <<< SetCentral <<< CentralInvite $ (InviteC.init invData newProps)
                   ]
        Just props -> pure
                      [ toIO (mkSettings $ state^.authData) $ do
                           invData <- postInvitationsByFamilyId props.rFamilyId
                           pure <<< SetCentral $ CentralInvite (InviteC.init invData props)
                      ]
    ReqCentralOverview -> handleSetCentral CentralOverview
    ReqCentralBaby     -> handleSetCentral CentralBaby

handleSetCentral :: Central -> ComponentType Unit State Action
handleSetCentral central' = central .= central' *> noEffects

handleSetAuthData :: Component Unit State Unit
handleSetAuthData = modify $ \state -> state
                                  {
                                   userError = case state.userError of
                                      DeviceInvalid -> NoError
                                      _ -> state.userError
                                  }
handleSetFamilyIds :: Array (Key Family) -> ComponentType Unit State Action
handleSetFamilyIds ids = do
  familyIds .= ids
  state <- get :: Component Unit State State
  if isNothing state.socketS.currentFamily
    then pure $ fromFoldable $ pure <<< SocketA <<< SocketC.SwitchFamily <$> Arr.head ids
    else noEffects

handleSetURL :: String -> ComponentType Unit State Action
handleSetURL url = do
  let
    route = Router.match url
    withoutQuery = takeWhile (_ /= '?') url
  case route of
    Router.Home -> onlyModify $ _ { url = url }
    Router.AcceptInvitation s -> do
      modify $ _ { url = withoutQuery
                 }
      actions <- handleSetCentral $ CentralAccept (AcceptC.init)
      pure $ [ do
               liftEff $ navigateTo withoutQuery
               inviteEffect s
             ] <> actions

handleClearError :: ComponentType Unit State Action
handleClearError = do
  state <- (get :: Component Unit State State)
  let
    newCentral = case state.central of
      CentralAccept (Just _) -> state.central
      _                     -> CentralOverview

  onlyModify $ _ { userError = NoError
                 , central = newCentral
                 }

--------------------------------------------------------------------------------

view :: State -> Html Action
view state =
  let
    numDevices = Arr.length state.onlineDevices
  in
    case state.userError of
      NoError ->
        div []
        [ viewHeader state
        , viewCentral state
        , div []
          [ h3 [] [ text "Videos - yeah:" ]
          , div [] $ map SocketA <$> viewParentChannels state.socketS
          ]
        , div []
          [ h3 [] [ text $ show numDevices <> " Device(s) currently online:" ]
          , div [] [ viewOnlineDevices state ]
          ]
        ]
      err -> viewError state

viewHeader :: State -> Html Action
viewHeader state =
      nav [ A.className "navbar navbar-default" ]
      [ div [ A.className "container"]
        [ div [ A.className "navbar-header"]
          [ a [ A.className "navbar-brand navbar-left"]
            [ img [ A.alt "gonimo"
                  , A.src "./pix/gonimo-logo-05.svg"
                  , A.width "35px"
                  , A.height "35px"] []
            ]
          ]

        , div [ A.className "collapse navbar-collapse"]
          [ ul [ A.className "nav navbar-nav"] $
            (viewCentralItem <$> getCentrals state) <>
            [ li []
              [ ul [ A.className "nav navbar-nav "]
                [ li [A.className "dropdown"]
                  [ a [ A.className "dropdown-toggle" , A.href "#"
                      , A.dataToggle "dropdown"       , A.role "button"]
                    [ i [A.className "fa fa-users"] []
                    , text " "
                    , text "funky hedgehogs"
                    , text " "
                    , span [A.className "caret"] [] ]
                  , ul [A.className "dropdown-menu"]
                    [ li [] [div [A.className "navbar-text"] [text "Change family to"]]
                    , li [] [a [] [text "wild frogs"]]
                    , li [] [a [] [text "funny cats"]]
                    , li [] [a [] [text "running dogs"]]
                    , li [] [a [] [ text "funky hedgehogs"
                                  , text " ✔"
                                  ]
                            ]
                    ]
                  ]
                ]
              ]
            , li [A.className "dropdown"]
              [ a [ A.className "dropdown-toggle" , A.href "#"
                  , A.dataToggle "dropdown"       , A.role "button"
                  , A.style [Tuple "minWidth" "180px"]]
                [ i [A.className "fa fa-user"] []
                , text " "
                , text "epsilonhalbe"
                , text " "
                , span [A.className "caret"] []
                ]
              , ul [A.className "dropdown-menu", A.style [Tuple "minWidth" "180px"]]
                [ li [] [a [] [text " User settings "
                              ,i [A.className "fa fa-cog pull-right"] []]]
                , li [] [ a [] [ text "Change password "
                               , i [A.className "fa fa-lock pull-right" ][]
                               ]]
                , li [A.className "divider", A.role "separator"] []
                , li [] [a [] [ text "Log-Out "
                              , i [A.className "fa fa-sign-out pull-right"] []
                              ]]
                ]
              ]
            ]
          ]
         ]
       ]

  where
    viewCentralItem :: Tuple Boolean CentralReq -> Html Action
    viewCentralItem (Tuple active item) =
      li [ A.className $ "nav navbar-nav" <> if active then " active" else "" ]
      [ a [ E.onClick $ const $ RequestCentral item ]
        [ text (userShow item) ]
      ]

-- viewNavbar :: State -> Html Action
-- viewNavbar state =
--        nav [ A.className "navbar navbar-default" ]
--         [ div [ A.className "container-fluid" ]
--           [ -- Brand and toggle get grouped for better mobile display
--             div [ A.className "navbar-header" ]
--             [ button [ A.type_ "button"
--                      , A.className "navbar-toggle collapsed"
--                      , A.dataToggle "collapse"
--                      , A.dataTarget "navbar-collapse-1"
--                      ]
--               [ span [ A.className "sr-only" ] [ text "Toggle navigation" ]
--               , span [ A.className "icon-bar" ] []
--               , span [ A.className "icon-bar" ] []
--               , span [ A.className "icon-bar" ] []
--               ]
--             , a [ A.className "navbar-brand"
--                 , A.role "button"
--                 , E.onClick $ const $ SetCentral centralOverview
--                 ]
--                 [ text "Overview" ]
--             , a [ A.className "navbar-brand"
--                 , A.role "button"
--                 , E.onClick $ const $ SetCentral CentralInvite
--                 ]
--               [ text "Invite" ]
--             ]
--           , -- Collect the nav links, forms, and other content for toggling
--             div [ A.className "collapse navbar-collapse", A.id_ "navbar-collapse-1" ]
--             [
--               ul [ A.className "nav navbar-nav" ]
--               [ li []
--                 [ viewFamilyChooser state
--                 ]
--               ]
--             , ul [ A.className "nav navbar-nav navbar-right" ]
--               [ li [ A.className "dropdown" ]
--                 [ a [ A.className "dropdown-toggle"
--                          , A.dataToggle "dropdown"
--                          , A.role "button"
--                          ]
--                   [ text "Account" , span [ A.className "caret" ] [] ]
--                   , ul [ A.className "dropdown-menu" ]
--                     [ li [] [ a [ A.href "#" ] [ text "Configure User Details" ] ]
--                     , li [] [ a [ A.href "#" ] [ text "change password" ] ]
--                     , li [ A.role "separator",  A.className "divider" ] []
--                     , li [] [ a [ A.href "#" ] [ text "Log out" ] ]
--                     ]
--                   ]
--                 ]
--               ]
--             ]
--           ]

viewCentral :: State -> Html Action
viewCentral state =
  let
    props = mkProps state
    invProps = mkInviteProps state
  in
   case state.central of
    CentralInvite s -> case invProps of
      Nothing -> viewLoading "Loading, please wait ..."
      Just invProps' -> map (InviteA Nothing) $ InviteC.view invProps' s
    CentralAccept s -> map AcceptA $ AcceptC.view s
    CentralOverview     -> map OverviewA   $ OverviewC.view props state.overviewS
    CentralBaby     -> map SocketA   $ SocketC.view props state.socketS

viewOnlineDevices :: State -> Html Action
viewOnlineDevices state = table [ A.className "table table-striped"]
                          [ head
                          , body
                          ]
  where
    head = thead []
           [ tr []
             [ th [ A.className "centered"] [ text "Online" ]
             , th [ A.className "centered"] [ text "Type" ]
             , th [] [ text "Name" ]
             , th [] [ text "Last Seen"]
             , th [] []
             , th [] []
             , th [] []
             ]
           ]
    body = tbody []
           <<< Arr.mapMaybe viewOnlineDevice
           $ map fst state.onlineDevices
    viewOnlineDevice deviceId = do
        (DeviceInfo info) <- Tuple.lookup deviceId state.deviceInfos
        let name = info.deviceInfoName
        let lastAccessed = dateToString info.deviceInfoLastAccessed
        pure $ tr []
               [ td [A.className "centered"] [ i [ A.className ("fa fa-" <> "circle-o") -- "check-circle"
                       , A.dataToggle "tooltip"
                       , A.dataPlacement "right"
                       , A.title "offline" ] []]
                       --, A.title "online" ] []]
               , td [A.className "centered"]
                   [ i [ A.className ("fa fa-" <> "mobile")
                       , A.dataToggle "tooltip"
                       , A.dataPlacement "right"
                       , A.title "edit device name" ] []
                       ]
               , td [] [ text name ]
               , td [] [ text lastAccessed ]
               , td [] [ i [ A.className "fa fa-pencil"
                       , A.dataToggle "tooltip"
                       , A.dataPlacement "right"
                       , A.title "edit device name" ] []
                       ]
               , td [] [ i [ A.className "fa fa-trash"
                       , A.dataToggle "tooltip"
                       , A.dataPlacement "right"
                       , A.title "delete device from family" ] []]
               ]

viewFamilyChooser :: State -> Html Action
viewFamilyChooser state = H.div []
                          [ H.label [ A.htmlFor "familySelect" ] [ text "Family: " ]
                          , H.select [ A.id_ "familySelect"
                                     , A.className "form-control"
                                     , E.onInput doSwitchFamily
                                     ]
                            $ fromFoldable
                            <<< map (uncurry makeOption)
                            <<< Map.toList $ state.families
                          ]
  where
    doSwitchFamily :: FormEvent -> Action
    doSwitchFamily ev = maybe Nop (SocketA <<< SocketC.SwitchFamily) $ fromString ev.target.value

    makeOption :: Key Family -> Family -> Html Action
    makeOption familyId (Family family) = H.option [ A.value (toString familyId) ]
                                          [ text family.familyName ]

--------------------------------------------------------------------------------
getSubscriptions :: State -> Subscriptions Action
getSubscriptions state =
  let
    familyId = state^?currentFamily

    --subscribeGetFamily :: forall m. MonadReader Settings m => Key Family -> m (Subscriptions Action)
    subscribeGetFamily familyId' =
      Sub.getFamiliesByFamilyId (maybe Nop (UpdateFamily familyId')) familyId'

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader (mkSettings $ state^.authData)) <<< concat $
      [ [ Sub.getAccountsByAccountIdFamilies (maybe Nop SetFamilyIds)
                                          (runAuthData $ state^.authData).accountId
        ]
      , fromFoldable $
        Sub.getOnlineStatusByFamilyId (maybe Nop SetOnlineDevices) <$> familyId
      , fromFoldable $
        Sub.getFamiliesByFamilyIdDeviceInfos (maybe Nop SetDeviceInfos) <$> familyId
      , map subscribeGetFamily state.familyIds
      ]
  in
   case state.userError of
     NoError -> foldl append mempty subArray <> map SocketA (SocketC.getSubscriptions (mkProps state) state.socketS)
     _       -> mempty

getPongRequest :: State -> Maybe HttpRequest
getPongRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    onlineStatus' = state ^. socketS <<< to SocketC.toDeviceType
    deviceData = Tuple deviceId onlineStatus'
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <<< Reqs.postOnlineStatusByFamilyId deviceData <$> familyId
     _ -> Nothing

getCloseRequest :: State -> Maybe HttpRequest
getCloseRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <<< flip Reqs.deleteOnlineStatusByFamilyIdByDeviceId deviceId <$> familyId
     _ -> Nothing

-- | Retrieve AuthData from local storage or if not present get new one from server
getAuthData :: Gonimo AuthData
getAuthData = do
  md <- liftEff $ localStorage.getItem Key.authData
  Gonimo.log $ "Got authdata from local storage: " <> gShow md
  case md of
    Nothing -> do
      auth <- postAccounts
      Gonimo.log $ "Got Nothing - called postAccounts and got: " <> gShow auth
      Gonimo.log $ "Calling setItem with : " <> gShow Key.authData
      liftEff $ localStorage.setItem Key.authData auth
      pure auth
    Just d  -> pure d


Forever example

Forever example

module Prelude where

class Monad m where
  ret :: forall a. a -> m a
  (>>=) :: forall a b. m a -> (a -> m b) -> m b

module Do where

import Prelude

data Maybe a = Nothing | Just a

instance Prelude.Monad Maybe where
  ret = Just
  (>>=) Nothing _ = Nothing
  (>>=) (Just a) f = f a

test1 = do Just "abc"

test3 = do
  (x : _) <- Just [1, 2, 3]
  (y : _) <- Just [4, 5, 6]
  Just (x + y)

test4 = do
  Just 1
  Nothing :: Maybe Number
  Just 2

test5 mx my = do
  x <- mx
  y <- my
  Just (x + y)

test6 mx my mz = do
  x <- mx
  y <- my
  let sum = x + y
  z <- mz
  Just (z + sum)

test7 mx = do let Just x = mx
              Just x

test8 = do Just (do Just 1)

(<$>) :: forall a b. (a -> b) -> Maybe a -> Maybe b
(<$>) f m = do
  a <- m
  ret (f a)

(<*>) :: forall a b. (Maybe (a -> b)) -> Maybe a -> Maybe b
(<*>) f m = do
  g <- f
  a <- m
  ret (g a)

foo x y z = x + y + z

forever :: forall m a b. (Monad m) => m a -> m b
forever a = do
  a
  forever a

test9 = foo <$> Just 1 <*> Just 2 <*> Just 3

module Prelude where

class Monad m where
  ret :: forall a. a -> m a
  (>>=) :: forall a b. m a -> (a -> m b) -> m b

module Do where

import Prelude

data Maybe a = Nothing | Just a

instance Prelude.Monad Maybe where
  ret = Just
  (>>=) Nothing _ = Nothing
  (>>=) (Just a) f = f a

test1 = do Just "abc"

test3 = do
  (x : _) <- Just [1, 2, 3]
  (y : _) <- Just [4, 5, 6]
  Just (x + y)

test4 = do
  Just 1
  Nothing :: Maybe Number
  Just 2

test5 mx my = do
  x <- mx
  y <- my
  Just (x + y)

test6 mx my mz = do
  x <- mx
  y <- my
  let sum = x + y
  z <- mz
  Just (z + sum)

test7 mx = do let Just x = mx
              Just x

test8 = do Just (do Just 1)

(<$>) :: forall a b. (a -> b) -> Maybe a -> Maybe b
(<$>) f m = do
  a <- m
  ret (f a)

(<*>) :: forall a b. (Maybe (a -> b)) -> Maybe a -> Maybe b
(<*>) f m = do
  g <- f
  a <- m
  ret (g a)

foo x y z = x + y + z

test9 = foo <$> Just 1 <*> Just 2 <*> Just 3


Add helpers to go from Instants to a duration (#99)

module Data.DateTime.Instant
  ( duration
  , durationMillis
  , Instant
  , instant
  , unInstant
  , fromDateTime
  , fromDate
  , toDateTime
  ) where

import Prelude

import Data.DateTime (Millisecond, Second, Minute, Hour, Day, Year, DateTime(..), Date, Time(..), canonicalDate, millisecond, second, minute, hour, day, month, year)
import Data.Enum (fromEnum, toEnum)
import Data.Function.Uncurried (Fn7, runFn7)
import Data.Maybe (Maybe(..), fromJust)
import Data.Time.Duration (class Duration, Milliseconds(..), negateDuration, toDuration)
import Partial.Unsafe (unsafePartial)

-- | An instant is a duration in milliseconds relative to the Unix epoch
-- | (1970-01-01 00:00:00 UTC).
-- |
-- | The constructor is private as the `Instant` range matches that of the
-- | `DateTime` type.
newtype Instant = Instant Milliseconds

derive newtype instance eqDateTime :: Eq Instant
derive newtype instance ordDateTime :: Ord Instant

instance boundedInstant :: Bounded Instant where
  bottom = Instant (Milliseconds (-8639977881600000.0))
  top = Instant (Milliseconds 8639977881599999.0)

instance showInstant :: Show Instant where
  show (Instant ms) = "(Instant " <> show ms <> ")"

-- Unfortunately Instant cannot be made a `BoundedEnum` as it "should" be,
-- unless enum cardinality and from/to range is extended to use a numeric type
-- bigger than Int32

-- | Attempts to create an `Instant` from a `Milliseconds` duration. The
-- | minimum acceptable value equates to the `bottom` `DateTime` and the maximum
-- | acceptable value equates to the `top` `DateTime`.
instant :: Milliseconds -> Maybe Instant
instant ms@(Milliseconds n)
  | n >= -8639977881600000.0 && n <= 8639977881599999.0 = Just (Instant ms)
  | otherwise = Nothing

-- | Lowers an `Instant` to a `Milliseconds` duration.
unInstant :: Instant -> Milliseconds
unInstant (Instant ms) = ms

-- | Creates an `Instant` from a `DateTime` value.
fromDateTime :: DateTime -> Instant
fromDateTime (DateTime d t) =
  runFn7 fromDateTimeImpl
    (year d) (fromEnum (month d)) (day d)
    (hour t) (minute t) (second t) (millisecond t)

-- | Creates an `Instant` from a `Date` value, using the assumed time 00:00:00.
fromDate :: Date -> Instant
fromDate d =
  runFn7 fromDateTimeImpl
    (year d) (fromEnum (month d)) (day d)
    bottom bottom bottom bottom

-- | Creates a `DateTime` value from an `Instant`.
toDateTime :: Instant -> DateTime
toDateTime = toDateTimeImpl mkDateTime
  where
  mkDateTime = unsafePartial \y mo d h mi s ms ->
    DateTime (canonicalDate y (fromJust (toEnum mo)) d) (Time h mi s ms)

-- TODO: these could (and probably should) be implemented in PS
foreign import fromDateTimeImpl :: Fn7 Year Int Day Hour Minute Second Millisecond Instant
foreign import toDateTimeImpl :: (Year -> Int -> Day -> Hour -> Minute -> Second -> Millisecond -> DateTime) -> Instant -> DateTime

-- | Get the amount of milliseconds between start and end
-- | for example:
-- | ```
-- | do
-- |   start <- Instant.now
-- |   aLongRunningEffect
-- |   end <- Instant.now
-- |   let millis = duration end start
-- |   log ("A long running effect took " <> show millis)
-- | ```
durationMillis :: { start :: Instant, end :: Instant } → Milliseconds
durationMillis { start, end } =
  unInstant end <> negateDuration (unInstant start)

-- | Get the duration between start and end
-- | for example:
-- | ```
-- | do
-- |   start <- Instant.now # liftEffect
-- |   aLongRunningAff
-- |   end <- Instant.now # liftEffect
-- |   let
-- |     hours :: Hours
-- |     hours = duration end start
-- |   log ("A long running Aff took " <> show hours)
-- | ```
duration :: forall d. Duration d => { start :: Instant, end :: Instant } → d
duration = durationMillis >>> toDuration

module Data.DateTime.Instant
  ( Instant
  , instant
  , unInstant
  , fromDateTime
  , fromDate
  , toDateTime
  ) where

import Prelude

import Data.DateTime (Millisecond, Second, Minute, Hour, Day, Year, DateTime(..), Date, Time(..), canonicalDate, millisecond, second, minute, hour, day, month, year)
import Data.Enum (fromEnum, toEnum)
import Data.Function.Uncurried (Fn7, runFn7)
import Data.Maybe (Maybe(..), fromJust)
import Data.Time.Duration (Milliseconds(..))

import Partial.Unsafe (unsafePartial)

-- | An instant is a duration in milliseconds relative to the Unix epoch
-- | (1970-01-01 00:00:00 UTC).
-- |
-- | The constructor is private as the `Instant` range matches that of the
-- | `DateTime` type.
newtype Instant = Instant Milliseconds

derive newtype instance eqDateTime :: Eq Instant
derive newtype instance ordDateTime :: Ord Instant

instance boundedInstant :: Bounded Instant where
  bottom = Instant (Milliseconds (-8639977881600000.0))
  top = Instant (Milliseconds 8639977881599999.0)

instance showInstant :: Show Instant where
  show (Instant ms) = "(Instant " <> show ms <> ")"

-- Unfortunately Instant cannot be made a `BoundedEnum` as it "should" be,
-- unless enum cardinality and from/to range is extended to use a numeric type
-- bigger than Int32

-- | Attempts to create an `Instant` from a `Milliseconds` duration. The
-- | minimum acceptable value equates to the `bottom` `DateTime` and the maximum
-- | acceptable value equates to the `top` `DateTime`.
instant :: Milliseconds -> Maybe Instant
instant ms@(Milliseconds n)
  | n >= -8639977881600000.0 && n <= 8639977881599999.0 = Just (Instant ms)
  | otherwise = Nothing

-- | Lowers an `Instant` to a `Milliseconds` duration.
unInstant :: Instant -> Milliseconds
unInstant (Instant ms) = ms

-- | Creates an `Instant` from a `DateTime` value.
fromDateTime :: DateTime -> Instant
fromDateTime (DateTime d t) =
  runFn7 fromDateTimeImpl
    (year d) (fromEnum (month d)) (day d)
    (hour t) (minute t) (second t) (millisecond t)

-- | Creates an `Instant` from a `Date` value, using the assumed time 00:00:00.
fromDate :: Date -> Instant
fromDate d =
  runFn7 fromDateTimeImpl
    (year d) (fromEnum (month d)) (day d)
    bottom bottom bottom bottom

-- | Creates a `DateTime` value from an `Instant`.
toDateTime :: Instant -> DateTime
toDateTime = toDateTimeImpl mkDateTime
  where
  mkDateTime = unsafePartial \y mo d h mi s ms ->
    DateTime (canonicalDate y (fromJust (toEnum mo)) d) (Time h mi s ms)

-- TODO: these could (and probably should) be implemented in PS
foreign import fromDateTimeImpl :: Fn7 Year Int Day Hour Minute Second Millisecond Instant
foreign import toDateTimeImpl :: (Year -> Int -> Day -> Hour -> Minute -> Second -> Millisecond -> DateTime) -> Instant -> DateTime


scheduler: Support FAILURE events

scheduler: Support FAILURE events

module Mesos.Scheduler where

import Prelude
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, Error, throw, throwException)
import Control.Monad.Except (runExcept)
import Control.Monad.Error.Class (class MonadError, throwError, catchError)
import Control.Monad.State (execState, modify)
import Data.Either (either)
import Data.Foreign (Foreign, writeObject, toForeign, ForeignError(..))
import Data.Foreign.Class (class AsForeign, class IsForeign, readProp, write, (.=))
import Data.Foreign.Index (prop)
import Data.Foreign.Undefined (Undefined(..))
import Data.List.NonEmpty as NEL
import Data.Maybe (Maybe, maybe')
import Data.Options (Options, (:=))
import Data.StrMap (lookup)
import Data.StrMap as SM
import Node.Encoding as Encoding
import Node.HTTP as HTTP
import Node.HTTP.Client (RequestHeaders(..), RequestOptions, Response, request, method, path, requestAsStream, responseHeaders, responseAsStream, statusCode, headers)
import Node.Process (stdout)
import Mesos.Raw (FrameworkID, FrameworkInfo, Offer, OfferID, TaskStatus, AgentID, ExecutorID, readPropNU)
import Mesos.RecordIO (onRecordIO)
import Mesos.Util (jsonStringify, fromJSON, throwErrorS)
import Node.Stream (end, writeString, pipe)

newtype Subscribed = Subscribed { frameworkId :: FrameworkID
                                , heartbeatIntervalSeconds :: Int
                                }

instance subscribedAsForeign :: AsForeign Subscribed where
    write (Subscribed obj) = writeObject props where
        props = [ "framework_id" .= write obj.frameworkId
                , "heartbeat_interval_seconds" .= write obj.heartbeatIntervalSeconds
                ]

instance subscribedIsForeign :: IsForeign Subscribed where
    read value = do
        frameworkId <- readProp "framework_id" value
        heartbeatIntervalSeconds <- readProp "heartbeat_interval_seconds" value
        pure $ Subscribed { frameworkId: frameworkId
                          , heartbeatIntervalSeconds: heartbeatIntervalSeconds
                          }

newtype Subscribe = Subscribe { frameworkInfo :: FrameworkInfo
                              }

instance subscribeAsForeign :: AsForeign Subscribe where
    write (Subscribe obj) = writeObject props where
        props = [ "framework_info" .= write obj.frameworkInfo
                ]

newtype ExecutorMessage = ExecutorMessage
    { agentId :: AgentID
    , executorId :: ExecutorID
    , data :: String
    }

instance executorMessageAsForeign :: AsForeign ExecutorMessage where
    write (ExecutorMessage obj) = writeObject props where
        props = [ "agent_id" .= write obj.agentId
                , "executor_id" .= write obj.executorId
                , "data" .= write obj.data
                ]

instance executorMessageIsForeign :: IsForeign ExecutorMessage where
    read obj = do
        agentId <- readProp "agent_id" obj
        executorId <- readProp "executor_id" obj
        d <- readProp "data" obj
        pure <<< ExecutorMessage $
            { agentId: agentId
            , executorId: executorId
            , data: d
            }

newtype Failure = Failure
    { slaveId :: Maybe AgentID
    , executorId :: Maybe ExecutorID
    , status :: Maybe Int
    }

instance failureAsForeign :: AsForeign Failure where
    write (Failure obj) = writeObject props where
        props = [ "agent_id" .= (write $ Undefined obj.slaveId)
                , "executor_id" .= (write $ Undefined obj.executorId)
                , "status" .= (write $ Undefined obj.status)
                ]

instance failureIsForeign :: IsForeign Failure where
    read obj = do
        slaveId <- catchError (readPropNU "agent_id" obj) \_ -> readPropNU "slave_id" obj
        executorId <- readPropNU "executor_id" obj
        status <- readPropNU "status" obj
        pure <<< Failure $
            { slaveId: slaveId
            , executorId: executorId
            , status: status
            }

-- | Represents a single RecordIO message
data Message = SubscribeMessage Subscribe
             | SubscribedMessage Subscribed
             | OffersMessage (Array Offer)
             | RescindMessage OfferID
             | UpdateMessage TaskStatus
             | MessageMessage ExecutorMessage
             | FailureMessage Failure
             | HeartbeatMessage

-- | Utility for Writing a mesos subscribe-style recordio message
writeMessage :: forall a. (AsForeign a) => String -> String -> a -> Foreign
writeMessage t k d = writeObject props where
    props = [ "type" .= toForeign t
            , k .= write d
            ]

instance messageAsForeign :: AsForeign Message where
    write (SubscribeMessage subscribeInfo) = writeMessage "SUBSCRIBE" "subscribe" subscribeInfo
    write (SubscribedMessage subscribedInfo) = writeMessage "SUBSCRIBED" "subscribed" subscribedInfo
    write (OffersMessage offers) = writeMessage "OFFERS" "offers" offers
    write (RescindMessage offerId) = toForeign $
        { type: "RESCIND"
        , rescind: { offer_id: write offerId }
        }
    write (UpdateMessage taskStatus) = toForeign $
        { type: "UPDATE"
        , update: { status: write taskStatus }
        }
    write (MessageMessage msg) = writeMessage "MESSAGE" "message" msg
    write (FailureMessage failure) = writeMessage "FAILURE" "failure" failure
    write HeartbeatMessage = toForeign $ { type: "HEARTBEAT" }

instance messageIsForeign :: IsForeign Message where
    read value = readProp "type" value >>= readMessageType where
        readMessageType "SUBSCRIBE" = throwError $ NEL.singleton $ ForeignError "Unimplemented!" -- TODO: implement
        readMessageType "SUBSCRIBED" = SubscribedMessage <$> readProp "subscribed" value
        readMessageType "OFFERS" = OffersMessage <$> readProp "offers" value
        readMessageType "RESCIND" = RescindMessage <$> (prop "rescind" value >>= readProp "offer_id")
        readMessageType "UPDATE" = UpdateMessage <$> (prop "update" value >>= readProp "status")
        readMessageType "MESSAGE" = MessageMessage <$> readProp "message" value
        readMessageType "FAILURE" = FailureMessage <$> readProp "failure" value
        readMessageType "HEARTBEAT" = pure HeartbeatMessage
        readMessageType _ = throwError $ NEL.singleton $ ErrorAtProperty "type" (ForeignError "Unknown message type")

-- | List of common headers to include in a call to the mesos scheduler subscribe api
subscribeHeaders :: RequestHeaders
subscribeHeaders =
    SM.insert "Content-Type" "application/json" >>>
    SM.insert "Accept" "application/json" >>>
    SM.insert "Connection" "close" >>>
    RequestHeaders $
    SM.empty

-- | Make a call to `/api/v1/subscribe`, taking an action for each message
subscribe :: forall eff. Options RequestOptions
          -> Subscribe
          -> (Message -> Eff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit)
          -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit
subscribe userReqOpts subscribeInfo callback = do
    res <- makeAff \_ onS -> do
        req <- request reqOpts onS
        let reqStream = requestAsStream req
            reqData = jsonStringify <<< write $ SubscribeMessage subscribeInfo
        writeString reqStream Encoding.UTF8 reqData $ end reqStream (pure unit)
        pure unit
    handleRes res
    where
        handleRes :: Response -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit
        handleRes res
          | statusCode res == 200 = do
              mesosStreamId <- requiredHeader "mesos-stream-id"
              liftEff <<< log $ "mesos-stream-id: " <> mesosStreamId
              liftEff $ onRecordIO resStream throwException handleRecord
              where
                  handleRecord =
                      either (throw <<< show) callback <<<
                      runExcept <<<
                      fromJSON
                  headers = responseHeaders res
                  resStream = responseAsStream res
                  requiredHeader :: forall m. (MonadError Error m) => String -> m String
                  requiredHeader key =
                      maybe' (throwErrorS <<< e) pure $ lookup key headers where
                          e _ = "Header \"" <> key <> "\" not found"
          | otherwise = do
              liftEff do
                  log $ "Reponse status error (" <> (show <<< statusCode) res <> "):"
                  pipe (responseAsStream res) stdout
                  log ""
              pure unit
        reqOpts :: Options RequestOptions
        reqOpts = flip execState userReqOpts do
            overrideOption $ method := "POST"
            overrideOption $ path := "/api/v1/scheduler"
            overrideOption $ headers := subscribeHeaders
            where
                overrideOption o = modify $ flip (<>) o

module Mesos.Scheduler where

import Prelude
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, Error, throw, throwException)
import Control.Monad.Except (runExcept)
import Control.Monad.Error.Class (class MonadError, throwError)
import Control.Monad.State (execState, modify)
import Data.Either (either)
import Data.Foreign (Foreign, writeObject, toForeign, ForeignError(..))
import Data.Foreign.Class (class AsForeign, class IsForeign, readProp, write, (.=))
import Data.Foreign.Index (prop)
import Data.List.NonEmpty as NEL
import Data.Maybe (maybe')
import Data.Options (Options, (:=))
import Data.StrMap (lookup)
import Data.StrMap as SM
import Node.Encoding as Encoding
import Node.HTTP as HTTP
import Node.HTTP.Client (RequestHeaders(..), RequestOptions, Response, request, method, path, requestAsStream, responseHeaders, responseAsStream, statusCode, headers)
import Node.Process (stdout)
import Mesos.Raw (FrameworkID, FrameworkInfo, Offer, OfferID, TaskStatus, AgentID, ExecutorID)
import Mesos.RecordIO (onRecordIO)
import Mesos.Util (jsonStringify, fromJSON, throwErrorS)
import Node.Stream (end, writeString, pipe)

newtype Subscribed = Subscribed { frameworkId :: FrameworkID
                                , heartbeatIntervalSeconds :: Int
                                }

instance subscribedAsForeign :: AsForeign Subscribed where
    write (Subscribed obj) = writeObject props where
        props = [ "framework_id" .= write obj.frameworkId
                , "heartbeat_interval_seconds" .= write obj.heartbeatIntervalSeconds
                ]

instance subscribedIsForeign :: IsForeign Subscribed where
    read value = do
        frameworkId <- readProp "framework_id" value
        heartbeatIntervalSeconds <- readProp "heartbeat_interval_seconds" value
        pure $ Subscribed { frameworkId: frameworkId
                          , heartbeatIntervalSeconds: heartbeatIntervalSeconds
                          }

newtype Subscribe = Subscribe { frameworkInfo :: FrameworkInfo
                              }

instance subscribeAsForeign :: AsForeign Subscribe where
    write (Subscribe obj) = writeObject props where
        props = [ "framework_info" .= write obj.frameworkInfo
                ]

newtype ExecutorMessage = ExecutorMessage
    { agentId :: AgentID
    , executorId :: ExecutorID
    , data :: String
    }

instance executorMessageAsForeign :: AsForeign ExecutorMessage where
    write (ExecutorMessage obj) = writeObject props where
        props = [ "agent_id" .= write obj.agentId
                , "executor_id" .= write obj.executorId
                , "data" .= write obj.data
                ]

instance executorMessageIsForeign :: IsForeign ExecutorMessage where
    read obj = do
        agentId <- readProp "agent_id" obj
        executorId <- readProp "executor_id" obj
        d <- readProp "data" obj
        pure <<< ExecutorMessage $
            { agentId: agentId
            , executorId: executorId
            , data: d
            }

-- | Represents a single RecordIO message
data Message = SubscribeMessage Subscribe
             | SubscribedMessage Subscribed
             | OffersMessage (Array Offer)
             | RescindMessage OfferID
             | UpdateMessage TaskStatus
             | MessageMessage ExecutorMessage
             | HeartbeatMessage

-- | Utility for Writing a mesos subscribe-style recordio message
writeMessage :: forall a. (AsForeign a) => String -> String -> a -> Foreign
writeMessage t k d = writeObject props where
    props = [ "type" .= toForeign t
            , k .= write d
            ]

instance messageAsForeign :: AsForeign Message where
    write (SubscribeMessage subscribeInfo) = writeMessage "SUBSCRIBE" "subscribe" subscribeInfo
    write (SubscribedMessage subscribedInfo) = writeMessage "SUBSCRIBED" "subscribed" subscribedInfo
    write (OffersMessage offers) = writeMessage "OFFERS" "offers" offers
    write (RescindMessage offerId) = toForeign $
        { type: "RESCIND"
        , rescind: { offer_id: write offerId }
        }
    write (UpdateMessage taskStatus) = toForeign $
        { type: "UPDATE"
        , update: { status: write taskStatus }
        }
    write (MessageMessage msg) = writeMessage "MESSAGE" "message" msg
    write HeartbeatMessage = toForeign $ { type: "HEARTBEAT" }

instance messageIsForeign :: IsForeign Message where
    read value = readProp "type" value >>= readMessageType where
        readMessageType "SUBSCRIBE" = throwError $ NEL.singleton $ ForeignError "Unimplemented!" -- TODO: implement
        readMessageType "SUBSCRIBED" = SubscribedMessage <$> readProp "subscribed" value
        readMessageType "OFFERS" = OffersMessage <$> readProp "offers" value
        readMessageType "RESCIND" = RescindMessage <$> (prop "rescind" value >>= readProp "offer_id")
        readMessageType "UPDATE" = UpdateMessage <$> (prop "update" value >>= readProp "status")
        readMessageType "MESSAGE" = MessageMessage <$> readProp "message" value
        readMessageType "HEARTBEAT" = pure HeartbeatMessage
        readMessageType _ = throwError $ NEL.singleton $ ErrorAtProperty "type" (ForeignError "Unknown message type")

-- | List of common headers to include in a call to the mesos scheduler subscribe api
subscribeHeaders :: RequestHeaders
subscribeHeaders =
    SM.insert "Content-Type" "application/json" >>>
    SM.insert "Accept" "application/json" >>>
    SM.insert "Connection" "close" >>>
    RequestHeaders $
    SM.empty

-- | Make a call to `/api/v1/subscribe`, taking an action for each message
subscribe :: forall eff. Options RequestOptions
          -> Subscribe
          -> (Message -> Eff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit)
          -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit
subscribe userReqOpts subscribeInfo callback = do
    res <- makeAff \_ onS -> do
        req <- request reqOpts onS
        let reqStream = requestAsStream req
            reqData = jsonStringify <<< write $ SubscribeMessage subscribeInfo
        writeString reqStream Encoding.UTF8 reqData $ end reqStream (pure unit)
        pure unit
    handleRes res
    where
        handleRes :: Response -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit
        handleRes res
          | statusCode res == 200 = do
              mesosStreamId <- requiredHeader "mesos-stream-id"
              liftEff <<< log $ "mesos-stream-id: " <> mesosStreamId
              liftEff $ onRecordIO resStream throwException handleRecord
              where
                  handleRecord =
                      either (throw <<< show) callback <<<
                      runExcept <<<
                      fromJSON
                  headers = responseHeaders res
                  resStream = responseAsStream res
                  requiredHeader :: forall m. (MonadError Error m) => String -> m String
                  requiredHeader key =
                      maybe' (throwErrorS <<< e) pure $ lookup key headers where
                          e _ = "Header \"" <> key <> "\" not found"
          | otherwise = do
              liftEff do
                  log $ "Reponse status error (" <> (show <<< statusCode) res <> "):"
                  pipe (responseAsStream res) stdout
                  log ""
              pure unit
        reqOpts :: Options RequestOptions
        reqOpts = flip execState userReqOpts do
            overrideOption $ method := "POST"
            overrideOption $ path := "/api/v1/scheduler"
            overrideOption $ headers := subscribeHeaders
            where
                overrideOption o = modify $ flip (<>) o


createImageData

createImageData

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect
  , clearRect

  , scale
  , rotate
  , translate
  , transform

  , setTextAlign
  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData
  , putImageDataFull
  , createImageData

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth      Number      more
  | SetFillStyle      String      more
  | SetStrokeStyle    String      more
  | SetShadowColor    String      more
  | SetShadowBlur     Number      more
  | SetShadowOffsetX  Number      more
  | SetShadowOffsetY  Number      more
  | SetLineCap        C.LineCap   more
  | SetComposite      C.Composite more
  | SetAlpha          Number      more
  | BeginPath         more
  | Stroke            more
  | Fill              more
  | Clip              more
  | LineTo            Number      Number      more
  | MoveTo            Number      Number      more
  | ClosePath         more
  | Arc               C.Arc       more
  | Rect              C.Rectangle more
  | ClearRect         C.Rectangle more
  | Scale             Number      Number      more
  | Rotate            Number      more
  | Translate         Number      Number      more
  | Transform         C.Transform more
  | SetTextAlign      C.TextAlign more
  | SetFont           String      more
  | FillText          String      Number      Number    more
  | StrokeText        String      Number      Number    more
  | MeasureText       String      (C.TextMetrics -> more)
  | Save              more
  | Restore           more
  | GetImageData      Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData      C.ImageData Number      Number    more
  | PutImageDataFull  C.ImageData Number      Number    Number   Number  Number  Number  more
  | CreateImageData   Number      Number      more

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

clearRect :: C.Rectangle -> Graphics Unit
clearRect r = liftFC $ ClearRect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

setTextAlign :: C.TextAlign -> Graphics Unit
setTextAlign ta = liftFC $ SetTextAlign ta unit

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

putImageDataFull :: C.ImageData -> Number -> Number -> Number -> Number -> Number -> Number -> Graphics Unit
putImageDataFull d x y dx dy dw dh = liftFC $ PutImageDataFull d x y dx dy dw dh unit

createImageData :: Number -> Number -> Graphics Unit
createImageData w h = liftFC $ CreateImageData w h unit

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = runFreeCM interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a)                     = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a)                     = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a)                   = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a)                   = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a)                    = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a)                 = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a)                 = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a)                      = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a)                     = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a)                         = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a)                          = const a <$> C.beginPath ctx
  interp (Stroke a)                             = const a <$> C.stroke ctx
  interp (Fill a)                               = const a <$> C.fill ctx
  interp (Clip a)                               = const a <$> C.clip ctx
  interp (LineTo x y a)                         = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a)                         = const a <$> C.moveTo ctx x y
  interp (ClosePath a)                          = const a <$> C.closePath ctx
  interp (Arc arc a)                            = const a <$> C.arc ctx arc
  interp (Rect r a)                             = const a <$> C.rect ctx r
  interp (ClearRect r a)                        = const a <$> C.clearRect ctx r
  interp (Scale sx sy a)                        = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a)                          = const a <$> C.rotate th ctx
  interp (Translate tx ty a)                    = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a)                       = const a <$> C.transform tx ctx
  interp (SetTextAlign ta a)                    = const a <$> C.setTextAlign ctx ta
  interp (SetFont f a)                          = const a <$> C.setFont f ctx
  interp (FillText s x y a)                     = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a)                   = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k)                      = k <$> C.measureText ctx s
  interp (Save a)                               = const a <$> C.save ctx
  interp (Restore a)                            = const a <$> C.restore ctx
  interp (GetImageData x y w h k)               = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a)                 = const a <$> C.putImageData ctx d x y
  interp (PutImageDataFull d x y dx dy dw dh a) = const a <$> C.putImageDataFull ctx d x y dx dy dw dh
  interp (CreateImageData w h a)                = const a <$> C.createImageData ctx w h

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect
  , clearRect

  , scale
  , rotate
  , translate
  , transform

  , setTextAlign
  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData
  , putImageDataFull

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth      Number      more
  | SetFillStyle      String      more
  | SetStrokeStyle    String      more
  | SetShadowColor    String      more
  | SetShadowBlur     Number      more
  | SetShadowOffsetX  Number      more
  | SetShadowOffsetY  Number      more
  | SetLineCap        C.LineCap   more
  | SetComposite      C.Composite more
  | SetAlpha          Number      more
  | BeginPath         more
  | Stroke            more
  | Fill              more
  | Clip              more
  | LineTo            Number      Number      more
  | MoveTo            Number      Number      more
  | ClosePath         more
  | Arc               C.Arc       more
  | Rect              C.Rectangle more
  | ClearRect         C.Rectangle more
  | Scale             Number      Number      more
  | Rotate            Number      more
  | Translate         Number      Number      more
  | Transform         C.Transform more
  | SetTextAlign      C.TextAlign more
  | SetFont           String      more
  | FillText          String      Number      Number    more
  | StrokeText        String      Number      Number    more
  | MeasureText       String      (C.TextMetrics -> more)
  | Save              more
  | Restore           more
  | GetImageData      Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData      C.ImageData Number      Number    more
  | PutImageDataFull  C.ImageData Number      Number    Number   Number  Number  Number  more

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

clearRect :: C.Rectangle -> Graphics Unit
clearRect r = liftFC $ ClearRect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

setTextAlign :: C.TextAlign -> Graphics Unit
setTextAlign ta = liftFC $ SetTextAlign ta unit

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

putImageDataFull :: C.ImageData -> Number -> Number -> Number -> Number -> Number -> Number -> Graphics Unit
putImageDataFull d x y dx dy dw dh = liftFC $ PutImageDataFull d x y dx dy dw dh unit

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = runFreeCM interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a)                     = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a)                     = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a)                   = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a)                   = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a)                    = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a)                 = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a)                 = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a)                      = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a)                     = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a)                         = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a)                          = const a <$> C.beginPath ctx
  interp (Stroke a)                             = const a <$> C.stroke ctx
  interp (Fill a)                               = const a <$> C.fill ctx
  interp (Clip a)                               = const a <$> C.clip ctx
  interp (LineTo x y a)                         = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a)                         = const a <$> C.moveTo ctx x y
  interp (ClosePath a)                          = const a <$> C.closePath ctx
  interp (Arc arc a)                            = const a <$> C.arc ctx arc
  interp (Rect r a)                             = const a <$> C.rect ctx r
  interp (ClearRect r a)                        = const a <$> C.clearRect ctx r
  interp (Scale sx sy a)                        = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a)                          = const a <$> C.rotate th ctx
  interp (Translate tx ty a)                    = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a)                       = const a <$> C.transform tx ctx
  interp (SetTextAlign ta a)                    = const a <$> C.setTextAlign ctx ta
  interp (SetFont f a)                          = const a <$> C.setFont f ctx
  interp (FillText s x y a)                     = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a)                   = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k)                      = k <$> C.measureText ctx s
  interp (Save a)                               = const a <$> C.save ctx
  interp (Restore a)                            = const a <$> C.restore ctx
  interp (GetImageData x y w h k)               = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a)                 = const a <$> C.putImageData ctx d x y
  interp (PutImageDataFull d x y dx dy dw dh a) = const a <$> C.putImageDataFull ctx d x y dx dy dw dh


Integer is highlighted

Integer is highlighted

Original commit 05ee0bcba8ccf1eae17a8afa59e8c75e88f851df

module Language.SimpleTypes
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Bifunctor (bimap)
import Data.Char.Unicode (GeneralCategory(..), generalCategory)
import Data.Foldable (for_, intercalate, maximum)
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.String as Str
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)
import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "Simple Types"
    , aceMode: "groovy"
    , extension: "types"
    , doc: pseudocodeDoc
    , transforms:
        { nameForClass: noForbidNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: simpleNamer id
        , unions: Nothing
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

isComplex :: IRType -> Boolean
isComplex = case _ of
    IRArray a -> isComplex a
    IRMap _ -> true
    IRUnion _ -> true
    _ -> false

isStartCharacter :: Char -> Boolean
isStartCharacter c = Str.isLetterOrLetterNumber c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isStartCharacter c

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any" -- we can have arrays of nothing
    IRNull -> pure "Null"
    IRInteger -> pure "Integer"
    IRDouble -> pure "Double"
    IRBool -> pure "Boolean"
    IRString -> pure "String"
    IRClass i -> lookupClassName i

    IRArray a | isComplex a -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"

    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"

    IRMap t -> do
        rendered <- renderType t
        pure $ "Map<String, " <> rendered <> ">"

    IRUnion types -> do
        let typeSet = unionToSet types
        case nullableFromSet typeSet of
            Nothing -> renderUnion typeSet
            Just t -> do
                rendered <- renderType t
                pure $ "Maybe<" <> rendered <> ">"

classNameStyle :: Boolean -> String -> String
classNameStyle upper = Str.legalizeCharacters isPartCharacter >>> Str.camelCase >>> (Str.startWithLetter isStartCharacter upper)

upperNameStyle :: String -> String
upperNameStyle = classNameStyle true

propertyNameify :: String -> String
propertyNameify = case _ of
    "" -> "\"\""
    s | Str.contains (Str.Pattern " ") s -> "\"" <> s <> "\""
    s -> s

pseudocodeDoc :: Doc Unit
pseudocodeDoc = forEachClass_ \className properties -> do
    line $ "class " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let propsClean = bimap propertyNameify id <$> props
        let maxWidth = propsClean <#> fst <#> Str.length # maximum
        for_ propsClean \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered
    line "}"
    blank

module Language.SimpleTypes
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Bifunctor (bimap)
import Data.Char.Unicode (GeneralCategory(..), generalCategory)
import Data.Foldable (for_, intercalate, maximum)
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.String as Str
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)
import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "Simple Types"
    , aceMode: "groovy"
    , extension: "types"
    , doc: pseudocodeDoc
    , transforms:
        { nameForClass: noForbidNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: simpleNamer id
        , unions: Nothing
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

isComplex :: IRType -> Boolean
isComplex = case _ of
    IRArray a -> isComplex a
    IRMap _ -> true
    IRUnion _ -> true
    _ -> false

isStartCharacter :: Char -> Boolean
isStartCharacter c = Str.isLetterOrLetterNumber c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isStartCharacter c

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any" -- we can have arrays of nothing
    IRNull -> pure "Null"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Boolean"
    IRString -> pure "String"
    IRClass i -> lookupClassName i

    IRArray a | isComplex a -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"

    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"

    IRMap t -> do
        rendered <- renderType t
        pure $ "Map<String, " <> rendered <> ">"

    IRUnion types -> do
        let typeSet = unionToSet types
        case nullableFromSet typeSet of
            Nothing -> renderUnion typeSet
            Just t -> do
                rendered <- renderType t
                pure $ "Maybe<" <> rendered <> ">"

classNameStyle :: Boolean -> String -> String
classNameStyle upper = Str.legalizeCharacters isPartCharacter >>> Str.camelCase >>> (Str.startWithLetter isStartCharacter upper)

upperNameStyle :: String -> String
upperNameStyle = classNameStyle true

propertyNameify :: String -> String
propertyNameify = case _ of
    "" -> "\"\""
    s | Str.contains (Str.Pattern " ") s -> "\"" <> s <> "\""
    s -> s

pseudocodeDoc :: Doc Unit
pseudocodeDoc = forEachClass_ \className properties -> do
    line $ "class " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let propsClean = bimap propertyNameify id <$> props
        let maxWidth = propsClean <#> fst <#> Str.length # maximum
        for_ propsClean \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered
    line "}"
    blank


Fix warning

Fix warning

module Graphics.D3.SVG.Axis
  ( Axis()
  , axis
  , scale
  , orient
  , ticks
  , tickFormat
  , renderAxis
  ) where

import Graphics.D3.Base (D3Eff)
import Graphics.D3.Selection (class Existing, Selection)
import Graphics.D3.Scale (class Scale)

import Data.Foreign.EasyFFI (unsafeForeignFunction)

ffi :: forall a. Array String -> String -> a
ffi = unsafeForeignFunction

foreign import data Axis :: *

foreign import axis :: D3Eff Axis

scale :: forall s d. (Scale s) => s d Number -> Axis -> D3Eff Axis
scale = ffi ["scale", "axis", ""] "axis.scale(scale)"

orient :: String -> Axis -> D3Eff Axis
orient = ffi ["orientation", "axis", ""] "axis.orient(orientation)"

ticks :: Number -> Axis -> D3Eff Axis
ticks = ffi ["count", "axis", ""] "axis.ticks(count)"

tickFormat :: String -> Axis -> D3Eff Axis
tickFormat = ffi ["format", "axis", ""] "axis.tickFormat(d3.format(format))"

renderAxis :: forall s d. (Existing s) => Axis -> s d -> D3Eff (Selection d)
renderAxis = ffi ["axis", "selection", ""] "selection.call(axis)"

module Graphics.D3.SVG.Axis
  ( Axis()
  , axis
  , scale
  , orient
  , ticks
  , tickFormat
  , renderAxis
  ) where

import Graphics.D3.Base (D3Eff)
import Graphics.D3.Selection (class Existing, Selection)
import Graphics.D3.Scale (class Scale)

import Data.Foreign.EasyFFI (unsafeForeignFunction)

ffi = unsafeForeignFunction

foreign import data Axis :: *

foreign import axis :: D3Eff Axis

scale :: forall s d. (Scale s) => s d Number -> Axis -> D3Eff Axis
scale = ffi ["scale", "axis", ""] "axis.scale(scale)"

orient :: String -> Axis -> D3Eff Axis
orient = ffi ["orientation", "axis", ""] "axis.orient(orientation)"

ticks :: Number -> Axis -> D3Eff Axis
ticks = ffi ["count", "axis", ""] "axis.ticks(count)"

tickFormat :: String -> Axis -> D3Eff Axis
tickFormat = ffi ["format", "axis", ""] "axis.tickFormat(d3.format(format))"

renderAxis :: forall s d. (Existing s) => Axis -> s d -> D3Eff (Selection d)
renderAxis = ffi ["axis", "selection", ""] "selection.call(axis)"