Family switching works (again) in style

Family switching works (again) in style

-- | 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.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 (offset, letterSpacing)
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
  r <- 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     -> do
                          handleSetCentral CentralBaby
                          pure [ pure $ SocketA SocketC.GetUserMedia ]
  case Tuple state.central c of
    Tuple CentralBaby ReqCentralBaby -> pure r
    Tuple CentralBaby _              -> pure $ [ pure $ SocketA SocketC.StopUserMedia ] <> r
    Tuple _ _                        -> pure r

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 $ 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"]
            [ button [ A.className "navbar-toggle collapsed"
                     , A.dataToggle "collapse"
                     , A.dataTarget "#navbarmenu"
                     , A.type_ "button"
                     ]
              [ span [A.className "icon-bar"] []
              , span [A.className "icon-bar"] []
              , span [A.className "icon-bar"] []
              ]
            , 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 "navbar-collapse collapse"
                , A.id_ "navbarmenu"
                , A.dataToggle "collapse"
                , A.dataTarget "#navbarmenu"]
            [ ul [ A.className "nav navbar-nav"] $
              (viewCentralItem <$> getCentrals state) <>
              [ li [A.className "dropdown"
                   ,A.dataToggle "collapse"]
                  [ a [ A.className "dropdown-toggle" , A.href "#"
                      , A.dataToggle "dropdown"       , A.role "button"
                      , A.type_ "button"
                      ]
                    [ i [A.className "fa fa-fw fa-users"] []
                    , text " "
                    , text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)
                    , text " "
                    , span [A.className "caret"] [] ]
                    , viewFamilyChooser state
                  ]
              , li [A.className "dropdown"]
                [ a [ A.className "dropdown-toggle" , A.href "#"
                    , A.dataToggle "dropdown"       , A.role "button"
                    , A.type_ "button"
                    , A.style [Tuple "minWidth" "180px"]]
                  [ i [A.className "fa fa-fw 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-fw fa-cog pull-right"] []]]
                  , li [] [ a [] [ text "Change password "
                                 , i [A.className "fa fa-fw fa-lock pull-right" ][]
                                 ]]
                  , li [A.className "divider", A.role "separator"] []
                  , li [] [a [] [ text "Log-Out "
                                , i [A.className "fa fa-fw 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.type_ "button"
         , A.role "button"
         ]
      [ 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 []
--                 [
--                 ]
--               ]
--             , 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-fw 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-fw fa-pencil"
                       , A.dataToggle "tooltip"
                       , A.dataPlacement "right"
                       , A.title "edit device name" ] []
                       ]
               , td [] [ i [ A.className "fa fa-fw fa-trash"
                       , A.dataToggle "tooltip"
                       , A.dataPlacement "right"
                       , A.title "delete device from family" ] []]
               ]

viewFamilyChooser :: State -> Html Action
viewFamilyChooser state =
    H.ul [A.className "dropdown-menu"] $
         [li [A.dataToggle "collapse"] [div [A.className "navbar-text"] [text "Change family to"]]]
         <> (fromFoldable <<< map (uncurry (viewFamily state.socketS.currentFamily))
                          <<< Map.toList $ state.families)
  where
    doSwitchFamily :: Key Family -> Action
    doSwitchFamily = SocketA <<< SocketC.SwitchFamily

    viewFamily :: Maybe (Key Family) -> Key Family -> Family -> Html Action
    viewFamily currentFamilyId familyId (Family family) =
        li [] [a [E.onClick $ const $ doSwitchFamily familyId ] $
                 [text family.familyName] <> if Just familyId == currentFamilyId
                                                then [text " ✔"]
                                                else []
              ]

--------------------------------------------------------------------------------
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.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 (offset, letterSpacing)
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
  r <- 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     -> do
                          handleSetCentral CentralBaby
                          pure [ pure $ SocketA SocketC.GetUserMedia ]
  case Tuple state.central c of
    Tuple CentralBaby ReqCentralBaby -> pure r
    Tuple CentralBaby _              -> pure $ [ pure $ SocketA SocketC.StopUserMedia ] <> r
    Tuple _ _                        -> pure r

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 $ 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"]
            [ button [ A.className "navbar-toggle collapsed"
                     , A.dataToggle "collapse"
                     , A.dataTarget "#navbarmenu"
                     , A.type_ "button"
                     ]
              [ span [A.className "icon-bar"] []
              , span [A.className "icon-bar"] []
              , span [A.className "icon-bar"] []
              ]
            , 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 "navbar-collapse collapse"
                , A.id_ "navbarmenu"
                , A.dataToggle "collapse"
                , A.dataTarget "#navbarmenu"]
            [ ul [ A.className "nav navbar-nav"] $
              (viewCentralItem <$> getCentrals state) <>
              [ li [A.className "dropdown"
                   ,A.dataToggle "collapse"]
                  [ a [ A.className "dropdown-toggle" , A.href "#"
                      , A.dataToggle "dropdown"       , A.role "button"
                      , A.type_ "button"
                      ]
                    [ i [A.className "fa fa-fw fa-users"] []
                    , text " "
                    , text "funky hedgehogs"
                    , text " "
                    , span [A.className "caret"] [] ]
                  , ul [A.className "dropdown-menu"]
                    [ li [A.dataToggle "collapse"] [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 " ✔" ]
                            ]

                    ]
                  , viewFamilyChooser state
                  ]
              , li [A.className "dropdown"]
                [ a [ A.className "dropdown-toggle" , A.href "#"
                    , A.dataToggle "dropdown"       , A.role "button"
                    , A.type_ "button"
                    , A.style [Tuple "minWidth" "180px"]]
                  [ i [A.className "fa fa-fw 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-fw fa-cog pull-right"] []]]
                  , li [] [ a [] [ text "Change password "
                                 , i [A.className "fa fa-fw fa-lock pull-right" ][]
                                 ]]
                  , li [A.className "divider", A.role "separator"] []
                  , li [] [a [] [ text "Log-Out "
                                , i [A.className "fa fa-fw 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.type_ "button"
         , A.role "button"
         ]
      [ 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 []
--                 [
--                 ]
--               ]
--             , 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-fw 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-fw fa-pencil"
                       , A.dataToggle "tooltip"
                       , A.dataPlacement "right"
                       , A.title "edit device name" ] []
                       ]
               , td [] [ i [ A.className "fa fa-fw fa-trash"
                       , A.dataToggle "tooltip"
                       , A.dataPlacement "right"
                       , A.title "delete device from family" ] []]
               ]

viewFamilyChooser :: State -> Html Action
viewFamilyChooser state = H.ul [A.className "dropdown-menu"]
                          [ H.label [ A.htmlFor "familySelect" ] [i [A.className "fa fa-fw fa-users"] []]
                          , 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


Fixes for 0.6.1

Fixes for 0.6.1

--
-- Maps as balanced 2-3 trees
--
-- Based on http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf
--

module Data.Map
  ( Map(),
    showTree,
    empty,
    isEmpty,
    singleton,
    checkValid,
    insert,
    lookup,
    toList,
    fromList,
    delete,
    member,
    alter,
    update,
    keys,
    values,
    union,
    unions,
    map
  ) where

import qualified Prelude as P

import qualified Data.Array as A
import Data.Maybe
import Data.Tuple
import Data.Foldable (foldl, foldMap, foldr, Foldable)
import Data.Traversable (traverse, Traversable)

data Map k v
  = Leaf
  | Two (Map k v) k v (Map k v)
  | Three (Map k v) k v (Map k v) k v (Map k v)

instance eqMap :: (P.Eq k, P.Eq v) => P.Eq (Map k v) where
  (==) m1 m2 = toList m1 P.== toList m2
  (/=) m1 m2 = P.not (m1 P.== m2)

instance showMap :: (P.Show k, P.Show v) => P.Show (Map k v) where
  show m = "fromList " P.++ P.show (toList m)

instance functorMap :: P.Functor (Map k) where
  (<$>) _ Leaf = Leaf
  (<$>) f (Two left k v right) = Two (f P.<$> left) k (f v) (f P.<$> right)
  (<$>) f (Three left k1 v1 mid k2 v2 right) = Three (f P.<$> left) k1 (f v1) (f P.<$> mid) k2 (f v2) (f P.<$> right)

instance foldableMap :: Foldable (Map k) where
  foldl   f z m = foldl   f z (values m)
  foldr   f z m = foldr   f z (values m)
  foldMap f   m = foldMap f   (values m)

instance traversableMap :: (P.Ord k) => Traversable (Map k) where
  traverse f ms = foldr (\x acc -> union P.<$> x P.<*> acc) (P.pure empty) ((P.(<$>) (uncurry singleton)) P.<$> (traverse f P.<$> toList ms))
  sequence = traverse P.id

showTree :: forall k v. (P.Show k, P.Show v) => Map k v -> String
showTree Leaf = "Leaf"
showTree (Two left k v right) =
  "Two (" P.++ showTree left P.++
  ") (" P.++ P.show k P.++
  ") (" P.++ P.show v P.++
  ") (" P.++ showTree right P.++ ")"
showTree (Three left k1 v1 mid k2 v2 right) =
  "Three (" P.++ showTree left P.++
  ") (" P.++ P.show k1 P.++
  ") (" P.++ P.show v1 P.++
  ") (" P.++ showTree mid P.++
  ") (" P.++ P.show k2 P.++
  ") (" P.++ P.show v2 P.++
  ") (" P.++ showTree right P.++ ")"

empty :: forall k v. Map k v
empty = Leaf

isEmpty :: forall k v. Map k v -> Boolean
isEmpty Leaf = true
isEmpty _ = false

singleton :: forall k v. k -> v -> Map k v
singleton k v = Two Leaf k v Leaf

checkValid :: forall k v. Map k v -> Boolean
checkValid tree = A.length (A.nub (allHeights tree)) P.== 1
  where
  allHeights :: forall k v. Map k v -> [Number]
  allHeights Leaf = [0]
  allHeights (Two left _ _ right) = A.map (\n -> n P.+ 1) (allHeights left P.++ allHeights right)
  allHeights (Three left _ _ mid _ _ right) = A.map (\n -> n P.+ 1) (allHeights left P.++ allHeights mid P.++ allHeights right)

lookup :: forall k v. (P.Ord k) => k -> Map k v -> Maybe v
lookup _ Leaf = Nothing
lookup k (Two _ k1 v _) | k P.== k1 = Just v
lookup k (Two left k1 _ _) | k P.< k1 = lookup k left
lookup k (Two _ _ _ right) = lookup k right
lookup k (Three _ k1 v1 _ _ _ _) | k P.== k1 = Just v1
lookup k (Three _ _ _ _ k2 v2 _) | k P.== k2 = Just v2
lookup k (Three left k1 _ _ _ _ _) | k P.< k1 = lookup k left
lookup k (Three _ k1 _ mid k2 _ _) | k1 P.< k P.&& k P.<= k2 = lookup k mid
lookup k (Three _ _ _ _ _ _ right) = lookup k right

member :: forall k v. (P.Ord k) => k -> Map k v -> Boolean
member k m = isJust (k `lookup` m)

data TreeContext k v
  = TwoLeft k v (Map k v)
  | TwoRight (Map k v) k v
  | ThreeLeft k v (Map k v) k v (Map k v)
  | ThreeMiddle (Map k v) k v k v (Map k v)
  | ThreeRight (Map k v) k v (Map k v) k v

fromZipper :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
fromZipper [] tree = tree
fromZipper (TwoLeft k1 v1 right : ctx) left = fromZipper ctx (Two left k1 v1 right)
fromZipper (TwoRight left k1 v1 : ctx) right = fromZipper ctx (Two left k1 v1 right)
fromZipper (ThreeLeft k1 v1 mid k2 v2 right : ctx) left = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (ThreeMiddle left k1 v1 k2 v2 right : ctx) mid = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (ThreeRight left k1 v1 mid k2 v2 : ctx) right = fromZipper ctx (Three left k1 v1 mid k2 v2 right)

data KickUp k v = KickUp (Map k v) k v (Map k v)

insert :: forall k v. (P.Ord k) => k -> v -> Map k v -> Map k v
insert = down []
  where
  down :: forall k v. (P.Ord k) => [TreeContext k v] -> k -> v -> Map k v -> Map k v
  down ctx k v Leaf = up ctx (KickUp Leaf k v Leaf)
  down ctx k v (Two left k1 _ right) | k P.== k1 = fromZipper ctx (Two left k v right)
  down ctx k v (Two left k1 v1 right) | k P.< k1 = down (TwoLeft k1 v1 right P.: ctx) k v left
  down ctx k v (Two left k1 v1 right) = down (TwoRight left k1 v1 P.: ctx) k v right
  down ctx k v (Three left k1 _ mid k2 v2 right) | k P.== k1 = fromZipper ctx (Three left k v mid k2 v2 right)
  down ctx k v (Three left k1 v1 mid k2 _ right) | k P.== k2 = fromZipper ctx (Three left k1 v1 mid k v right)
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k P.< k1 = down (ThreeLeft k1 v1 mid k2 v2 right P.: ctx) k v left
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k1 P.< k P.&& k P.<= k2 = down (ThreeMiddle left k1 v1 k2 v2 right P.: ctx) k v mid
  down ctx k v (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k v right

  up :: forall k v. (P.Ord k) => [TreeContext k v] -> KickUp k v -> Map k v
  up [] (KickUp left k v right) = Two left k v right
  up (TwoLeft k1 v1 right : ctx) (KickUp left k v mid) = fromZipper ctx (Three left k v mid k1 v1 right)
  up (TwoRight left k1 v1 : ctx) (KickUp mid k v right) = fromZipper ctx (Three left k1 v1 mid k v right)
  up (ThreeLeft k1 v1 c k2 v2 d : ctx) (KickUp a k v b) = up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
  up (ThreeMiddle a k1 v1 k2 v2 d : ctx) (KickUp b k v c) = up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
  up (ThreeRight a k1 v1 b k2 v2 : ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))

delete :: forall k v. (P.Ord k) => k -> Map k v -> Map k v
delete = down []
  where
  down :: forall k v. (P.Ord k) => [TreeContext k v] -> k -> Map k v -> Map k v
  down ctx _ Leaf = fromZipper ctx Leaf
  down ctx k (Two Leaf k1 _ Leaf)
    | k P.== k1 = up ctx Leaf
  down ctx k (Two left k1 v1 right)
    | k P.== k1   = let max = maxNode left
                    in removeMaxNode (TwoLeft max.key max.value right P.: ctx) left
    | k P.< k1    = down (TwoLeft k1 v1 right P.: ctx) k left
    | P.otherwise = down (TwoRight left k1 v1 P.: ctx) k right
  down ctx k (Three Leaf k1 _ Leaf k2 v2 Leaf)
    | k P.== k1 = fromZipper ctx (Two Leaf k2 v2 Leaf)
  down ctx k (Three Leaf k1 v1 Leaf k2 _ Leaf)
    | k P.== k2 = fromZipper ctx (Two Leaf k1 v1 Leaf)
  down ctx k (Three left k1 v1 mid k2 v2 right)
    | k P.== k1 = let max = maxNode left
                  in removeMaxNode (ThreeLeft max.key max.value mid k2 v2 right P.: ctx) left
    | k P.== k2 = let max = maxNode mid
                  in removeMaxNode (ThreeMiddle left k1 v1 max.key max.value right P.: ctx) mid
    | k P.< k1               = down (ThreeLeft k1 v1 mid k2 v2 right P.: ctx) k left
    | k1 P.< k P.&& k P.< k2 = down (ThreeMiddle left k1 v1 k2 v2 right P.: ctx) k mid
    | P.otherwise            = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k right

  up :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
  up [] tree = tree
  up (TwoLeft k1 v1 Leaf : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (TwoRight Leaf k1 v1 : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (TwoLeft k1 v1 (Two m k2 v2 r) : ctx) l = up ctx (Three l k1 v1 m k2 v2 r)
  up (TwoRight (Two l k1 v1 m) k2 v2 : ctx) r = up ctx (Three l k1 v1 m k2 v2 r)
  up (TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d) : ctx) a = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (TwoRight (Three a k1 v1 b k2 v2 c) k3 v3 : ctx) d = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (ThreeLeft k1 v1 Leaf k2 v2 Leaf : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeMiddle Leaf k1 v1 k2 v2 Leaf : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeRight Leaf k1 v1 Leaf k2 v2 : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d : ctx) a = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d : ctx) c = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d) : ctx) b = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3 : ctx) d = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e : ctx) a = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e : ctx) d = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e) : ctx) b = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
  up (ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 : ctx) e = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))

  maxNode :: forall k v. (P.Ord k) => Map k v -> { key :: k, value :: v }
  maxNode (Two _ k v Leaf) = { key: k, value: v }
  maxNode (Two _ _ _ right) = maxNode right
  maxNode (Three _ _ _ _ k v Leaf) = { key: k, value: v }
  maxNode (Three _ _ _ _ _ _ right) = maxNode right

  removeMaxNode :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
  removeMaxNode ctx (Two Leaf _ _ Leaf) = up ctx Leaf
  removeMaxNode ctx (Two left k v right) = removeMaxNode (TwoRight left k v P.: ctx) right
  removeMaxNode ctx (Three Leaf k1 v1 Leaf _ _ Leaf) = up (TwoRight Leaf k1 v1 P.: ctx) Leaf
  removeMaxNode ctx (Three left k1 v1 mid k2 v2 right) = removeMaxNode (ThreeRight left k1 v1 mid k2 v2 P.: ctx) right

alter :: forall k v. (P.Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

update :: forall k v. (P.Ord k) => (v -> Maybe v) -> k -> Map k v -> Map k v
update f k m = alter (maybe Nothing f) k m

toList :: forall k v. Map k v -> [Tuple k v]
toList Leaf = []
toList (Two left k v right) = toList left P.++ [Tuple k v] P.++ toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left P.++ [Tuple k1 v1] P.++ toList mid P.++ [Tuple k2 v2] P.++ toList right

fromList :: forall k v. (P.Ord k) => [Tuple k v] -> Map k v
fromList = foldl (\m (Tuple k v) -> insert k v m) empty

keys :: forall k v. Map k v -> [k]
keys Leaf = []
keys (Two left k _ right) = keys left P.++ [k] P.++ keys right
keys (Three left k1 _ mid k2 _ right) = keys left P.++ [k1] P.++ keys mid P.++ [k2] P.++ keys right

values :: forall k v. Map k v -> [v]
values Leaf = []
values (Two left _ v right) = values left P.++ [v] P.++ values right
values (Three left _ v1 mid _ v2 right) = values left P.++ [v1] P.++ values mid P.++ [v2] P.++ values right

union :: forall k v. (P.Ord k) => Map k v -> Map k v -> Map k v
union m1 m2 = foldl (\m (Tuple k v) -> insert k v m) m2 (toList m1)

unions :: forall k v. (P.Ord k) => [Map k v] -> Map k v
unions = foldl union empty

map :: forall k a b. (a -> b) -> Map k a -> Map k b
map = P.(<$>)

--
-- Maps as balanced 2-3 trees
--
-- Based on http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf
--

module Data.Map
  ( Map(),
    showTree,
    empty,
    isEmpty,
    singleton,
    checkValid,
    insert,
    lookup,
    toList,
    fromList,
    delete,
    member,
    alter,
    update,
    keys,
    values,
    union,
    unions,
    map
  ) where

import qualified Prelude as P

import qualified Data.Array as A
import Data.Maybe
import Data.Tuple
import Data.Foldable (foldl, foldMap, foldr, Foldable)
import Data.Traversable (traverse, Traversable)

data Map k v
  = Leaf
  | Two (Map k v) k v (Map k v)
  | Three (Map k v) k v (Map k v) k v (Map k v)

instance eqMap :: (P.Eq k, P.Eq v) => P.Eq (Map k v) where
  (==) m1 m2 = toList m1 P.== toList m2
  (/=) m1 m2 = P.not (m1 P.== m2)

instance showMap :: (P.Show k, P.Show v) => P.Show (Map k v) where
  show m = "fromList " P.++ P.show (toList m)

instance functorMap :: P.Functor (Map k) where
  (<$>) _ Leaf = Leaf
  (<$>) f (Two left k v right) = Two (f P.<$> left) k (f v) (f P.<$> right)
  (<$>) f (Three left k1 v1 mid k2 v2 right) = Three (f P.<$> left) k1 (f v1) (f P.<$> mid) k2 (f v2) (f P.<$> right)

instance foldableMap :: Foldable (Map k) where
  foldl   f z m = foldl   f z (values m)
  foldr   f z m = foldr   f z (values m)
  foldMap f   m = foldMap f   (values m)

instance traversableMap :: (P.Ord k) => Traversable (Map k) where
  traverse f ms = foldr (\x acc -> union P.<$> x P.<*> acc) (P.pure empty) ((P.(<$>) (uncurry singleton)) P.<$> (traverse f P.<$> toList ms))
  sequence = traverse P.id

showTree :: forall k v. (P.Show k, P.Show v) => Map k v -> String
showTree Leaf = "Leaf"
showTree (Two left k v right) =
  "Two (" P.++ showTree left P.++
  ") (" P.++ P.show k P.++
  ") (" P.++ P.show v P.++
  ") (" P.++ showTree right P.++ ")"
showTree (Three left k1 v1 mid k2 v2 right) =
  "Three (" P.++ showTree left P.++
  ") (" P.++ P.show k1 P.++
  ") (" P.++ P.show v1 P.++
  ") (" P.++ showTree mid P.++
  ") (" P.++ P.show k2 P.++
  ") (" P.++ P.show v2 P.++
  ") (" P.++ showTree right P.++ ")"

empty :: forall k v. Map k v
empty = Leaf

isEmpty :: forall k v. Map k v -> Boolean
isEmpty Leaf = true
isEmpty _ = false

singleton :: forall k v. k -> v -> Map k v
singleton k v = Two Leaf k v Leaf

checkValid :: forall k v. Map k v -> Boolean
checkValid tree = A.length (A.nub (allHeights tree)) P.== 1
  where
  allHeights :: forall k v. Map k v -> [Number]
  allHeights Leaf = [0]
  allHeights (Two left _ _ right) = A.map (\n -> n P.+ 1) (allHeights left P.++ allHeights right)
  allHeights (Three left _ _ mid _ _ right) = A.map (\n -> n P.+ 1) (allHeights left P.++ allHeights mid P.++ allHeights right)

lookup :: forall k v. (P.Ord k) => k -> Map k v -> Maybe v
lookup _ Leaf = Nothing
lookup k (Two _ k1 v _) | k P.== k1 = Just v
lookup k (Two left k1 _ _) | k P.< k1 = lookup k left
lookup k (Two _ _ _ right) = lookup k right
lookup k (Three _ k1 v1 _ _ _ _) | k P.== k1 = Just v1
lookup k (Three _ _ _ _ k2 v2 _) | k P.== k2 = Just v2
lookup k (Three left k1 _ _ _ _ _) | k P.< k1 = lookup k left
lookup k (Three _ k1 _ mid k2 _ _) | k1 P.< k P.&& k P.<= k2 = lookup k mid
lookup k (Three _ _ _ _ _ _ right) = lookup k right

member :: forall k v. (P.Ord k) => k -> Map k v -> Boolean
member k m = isJust (k `lookup` m)

data TreeContext k v
  = TwoLeft k v (Map k v)
  | TwoRight (Map k v) k v
  | ThreeLeft k v (Map k v) k v (Map k v)
  | ThreeMiddle (Map k v) k v k v (Map k v)
  | ThreeRight (Map k v) k v (Map k v) k v

fromZipper :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
fromZipper [] tree = tree
fromZipper (TwoLeft k1 v1 right : ctx) left = fromZipper ctx (Two left k1 v1 right)
fromZipper (TwoRight left k1 v1 : ctx) right = fromZipper ctx (Two left k1 v1 right)
fromZipper (ThreeLeft k1 v1 mid k2 v2 right : ctx) left = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (ThreeMiddle left k1 v1 k2 v2 right : ctx) mid = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (ThreeRight left k1 v1 mid k2 v2 : ctx) right = fromZipper ctx (Three left k1 v1 mid k2 v2 right)

data KickUp k v = KickUp (Map k v) k v (Map k v)

insert :: forall k v. (P.Ord k) => k -> v -> Map k v -> Map k v
insert = down []
  where
  down :: forall k v. (P.Ord k) => [TreeContext k v] -> k -> v -> Map k v -> Map k v
  down ctx k v Leaf = up ctx (KickUp Leaf k v Leaf)
  down ctx k v (Two left k1 _ right) | k P.== k1 = fromZipper ctx (Two left k v right)
  down ctx k v (Two left k1 v1 right) | k P.< k1 = down (TwoLeft k1 v1 right P.: ctx) k v left
  down ctx k v (Two left k1 v1 right) = down (TwoRight left k1 v1 P.: ctx) k v right
  down ctx k v (Three left k1 _ mid k2 v2 right) | k P.== k1 = fromZipper ctx (Three left k v mid k2 v2 right)
  down ctx k v (Three left k1 v1 mid k2 _ right) | k P.== k2 = fromZipper ctx (Three left k1 v1 mid k v right)
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k P.< k1 = down (ThreeLeft k1 v1 mid k2 v2 right P.: ctx) k v left
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k1 P.< k P.&& k P.<= k2 = down (ThreeMiddle left k1 v1 k2 v2 right P.: ctx) k v mid
  down ctx k v (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k v right

  up :: forall k v. (P.Ord k) => [TreeContext k v] -> KickUp k v -> Map k v
  up [] (KickUp left k v right) = Two left k v right
  up (TwoLeft k1 v1 right : ctx) (KickUp left k v mid) = fromZipper ctx (Three left k v mid k1 v1 right)
  up (TwoRight left k1 v1 : ctx) (KickUp mid k v right) = fromZipper ctx (Three left k1 v1 mid k v right)
  up (ThreeLeft k1 v1 c k2 v2 d : ctx) (KickUp a k v b) = up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
  up (ThreeMiddle a k1 v1 k2 v2 d : ctx) (KickUp b k v c) = up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
  up (ThreeRight a k1 v1 b k2 v2 : ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))

delete :: forall k v. (P.Ord k) => k -> Map k v -> Map k v
delete = down []
  where
  down :: forall k v. (P.Ord k) => [TreeContext k v] -> k -> Map k v -> Map k v
  down ctx _ Leaf = fromZipper ctx Leaf
  down ctx k (Two Leaf k1 _ Leaf) | k P.== k1 = up ctx Leaf
  down ctx k (Two left k1 _ right) | k P.== k1 =
    let max = maxNode left
    in removeMaxNode (TwoLeft max.key max.value right P.: ctx) left
  down ctx k (Two left k1 v1 right) | k P.< k1 = down (TwoLeft k1 v1 right P.: ctx) k left
  down ctx k (Two left k1 v1 right) = down (TwoRight left k1 v1 P.: ctx) k right
  down ctx k (Three Leaf k1 _ Leaf k2 v2 Leaf) | k P.== k1 = fromZipper ctx (Two Leaf k2 v2 Leaf)
  down ctx k (Three Leaf k1 v1 Leaf k2 _ Leaf) | k P.== k2 = fromZipper ctx (Two Leaf k1 v1 Leaf)
  down ctx k (Three left k1 _ mid k2 v2 right) | k P.== k1 =
    let max = maxNode left
    in removeMaxNode (ThreeLeft max.key max.value mid k2 v2 right P.: ctx) left
  down ctx k (Three left k1 v1 mid k2 _ right) | k P.== k2 =
    let max = maxNode mid
    in removeMaxNode (ThreeMiddle left k1 v1 max.key max.value right P.: ctx) mid
  down ctx k (Three left k1 v1 mid k2 v2 right) | k P.< k1 = down (ThreeLeft k1 v1 mid k2 v2 right P.: ctx) k left
  down ctx k (Three left k1 v1 mid k2 v2 right) | k1 P.< k P.&& k P.< k2  = down (ThreeMiddle left k1 v1 k2 v2 right P.: ctx) k mid
  down ctx k (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k right

  up :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
  up [] tree = tree
  up (TwoLeft k1 v1 Leaf : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (TwoRight Leaf k1 v1 : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (TwoLeft k1 v1 (Two m k2 v2 r) : ctx) l = up ctx (Three l k1 v1 m k2 v2 r)
  up (TwoRight (Two l k1 v1 m) k2 v2 : ctx) r = up ctx (Three l k1 v1 m k2 v2 r)
  up (TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d) : ctx) a = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (TwoRight (Three a k1 v1 b k2 v2 c) k3 v3 : ctx) d = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (ThreeLeft k1 v1 Leaf k2 v2 Leaf : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeMiddle Leaf k1 v1 k2 v2 Leaf : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeRight Leaf k1 v1 Leaf k2 v2 : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d : ctx) a = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d : ctx) c = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d) : ctx) b = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3 : ctx) d = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e : ctx) a = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e : ctx) d = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e) : ctx) b = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
  up (ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 : ctx) e = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))

  maxNode :: forall k v. (P.Ord k) => Map k v -> { key :: k, value :: v }
  maxNode (Two _ k v Leaf) = { key: k, value: v }
  maxNode (Two _ _ _ right) = maxNode right
  maxNode (Three _ _ _ _ k v Leaf) = { key: k, value: v }
  maxNode (Three _ _ _ _ _ _ right) = maxNode right

  removeMaxNode :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
  removeMaxNode ctx (Two Leaf _ _ Leaf) = up ctx Leaf
  removeMaxNode ctx (Two left k v right) = removeMaxNode (TwoRight left k v P.: ctx) right
  removeMaxNode ctx (Three Leaf k1 v1 Leaf _ _ Leaf) = up (TwoRight Leaf k1 v1 P.: ctx) Leaf
  removeMaxNode ctx (Three left k1 v1 mid k2 v2 right) = removeMaxNode (ThreeRight left k1 v1 mid k2 v2 P.: ctx) right

alter :: forall k v. (P.Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

update :: forall k v. (P.Ord k) => (v -> Maybe v) -> k -> Map k v -> Map k v
update f k m = alter (maybe Nothing f) k m

toList :: forall k v. Map k v -> [Tuple k v]
toList Leaf = []
toList (Two left k v right) = toList left P.++ [Tuple k v] P.++ toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left P.++ [Tuple k1 v1] P.++ toList mid P.++ [Tuple k2 v2] P.++ toList right

fromList :: forall k v. (P.Ord k) => [Tuple k v] -> Map k v
fromList = foldl (\m (Tuple k v) -> insert k v m) empty

keys :: forall k v. Map k v -> [k]
keys Leaf = []
keys (Two left k _ right) = keys left P.++ [k] P.++ keys right
keys (Three left k1 _ mid k2 _ right) = keys left P.++ [k1] P.++ keys mid P.++ [k2] P.++ keys right

values :: forall k v. Map k v -> [v]
values Leaf = []
values (Two left _ v right) = values left P.++ [v] P.++ values right
values (Three left _ v1 mid _ v2 right) = values left P.++ [v1] P.++ values mid P.++ [v2] P.++ values right

union :: forall k v. (P.Ord k) => Map k v -> Map k v -> Map k v
union m1 m2 = foldl (\m (Tuple k v) -> insert k v m) m2 (toList m1)

unions :: forall k v. (P.Ord k) => [Map k v] -> Map k v
unions = foldl union empty

map :: forall k a b. (a -> b) -> Map k a -> Map k b
map = P.(<$>)


added purescript implementation

added purescript implementation

module LinearSearch where

-- Written in Purescript 0.12
import Prelude ((+), (==))
import Data.Array
import Data.Maybe (Maybe(..))

exampleSearch :: Maybe Int
exampleSearch = linear_Search [29,24,5,7,69,1,56] 5

linear_Search :: Array Int -> Int -> Maybe Int
linear_Search arr value = search arr value 0

search :: Array Int -> Int -> Int -> Maybe Int
search arr value pos = case uncons arr of 	 			 -- uncons splits array into head and tail
		Just { head: x, tail: xs } ->
			if x == value then Just pos 				 -- if found return the position
						  else search xs value (pos+1)   -- If its not found, recursively search
  		Nothing -> Nothing

error: pathspec 'search/linear_search/purescript/LinearSearch.purs' did not match any file(s) known to git


Fleshed out minimal version of helper function xHoursToJob().

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/0dB/cats-utils.git/'


sharkdp added support for `textarea` for me!


Removed a debugging output statement.

Removed a debugging output statement.

module Main where

import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Overview as OverviewC
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Loaded as LoadedC
import Gonimo.UI.Loaded.Types as LoadedC
import Gonimo.UI.Socket as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Pux.Html.Attributes as A
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Servant.Subscriber.Subscriptions as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (launchAff, Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Ref (newRef, writeRef, readRef, REF, Ref)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (runIO, IO)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (modify, put, get)
import Data.Array (head)
import Data.Either (Either(Right, Left))
import Data.Foldable (traverse_)
import Data.Generic (gShow)
import Data.Lens (prism', PrismP, (^?))
import Data.List (toUnfoldable, reverse, List(Nil, Cons))
import Data.Maybe (fromMaybe, Maybe(..))
import Data.Profunctor (lmap)
import Data.Traversable (traverse)
import Data.Tuple (fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Router (match, Route(AcceptInvitation, Home))
import Gonimo.Client.Types (toIO, GonimoError, Gonimo, class ReportErrorAction)
import Gonimo.Client.Types (Settings)
import Gonimo.Pux (toPux, noEffects, wrapAction, onlyModify, Update, ComponentType, makeChildData, ToChild, liftChild, Component)
import Gonimo.Server.Types (DeviceType(NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Secret(Secret))
import Gonimo.UI.Error (viewError, handleError, class ErrorAction, UserError(NoError))
import Gonimo.UI.Html as Html
import Gonimo.Util (fromMaybeM, coerceEffects)
import Gonimo.WebAPI (postFunnyName, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (App, renderToDOM, fromSimple, start)
import Pux.Html (text, span, Html, img, div)
import Gonimo.Util (sampleUrl)
import Pux.Devtool (Action, start) as Pux.Devtool
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber, SubscriberEff)
import Servant.Subscriber.Connection (setPongRequest)
import Signal (foldp, map2, runSignal, constant, Signal)
import Signal.Channel (Channel, CHANNEL, send, subscribe, channel)
import Unsafe.Coerce (unsafeCoerce)
import Prelude hiding (div)

data State = LoadingS LoadingS'
           | LoadedS LoadedC.State

_LoadingS :: PrismP State LoadingS'
_LoadingS = prism' LoadingS (\s -> case s of
                                LoadingS x -> Just x
                                _ -> Nothing)

_LoadedS :: PrismP State LoadedC.State
_LoadedS = prism' LoadedS (\s -> case s of
                                LoadedS x -> Just x
                                _ -> Nothing)

type LoadingS' = { actionQueue :: List LoadedC.Action -- | We queue actions until we are loaded.
                 , userError :: UserError
                 , sendAction :: Action -> Eff () Unit
                 }

type LoadedState = {
               authData :: AuthData
             , settings :: Settings
             }

init :: (Action -> Eff () Unit) -> State
init sendAction' = LoadingS { actionQueue : Nil
                            , userError : NoError
                            , sendAction : sendAction'
                            }

data Action = Start
            | Init LoadedC.State
            | ReportError GonimoError
            | LoadedA LoadedC.Action
            | ResetDevice
            | ClearError
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

instance errorActionAction :: ErrorAction Action where
  resetDevice = ResetDevice
  nop = Nop
  clearError = ClearError

type MySubscriber = Subscriber () LoadedC.Action
--------------------------------------------------------------------------------

update :: Update Unit State Action
update action = do
  state <- ( get :: Component Unit State State)
  case action of
    Nop -> noEffects
    Init ls -> fromMaybe [] <$> handleInit ls
    _ -> fromMaybeM (fromMaybe [] <$> updateLoaded action) (updateLoading action)

toLoading :: ToChild Unit State Unit LoadingS'
toLoading = pure $ makeChildData _LoadingS unit

toLoaded :: ToChild Unit State Unit LoadedC.State
toLoaded = pure $ makeChildData _LoadedS unit

updateLoading' ::  Update Unit LoadingS' Action
updateLoading' action = do
  state <- get
  case action of
    Start           -> pure [ load state.sendAction ]
    LoadedA action  -> onlyModify $ \state' -> state' {
                          actionQueue = Cons action state.actionQueue
                        }
    Init ls         -> pure [ do
                                  Gonimo.log "Init command should be handled in toplevel update!"
                                  pure Nop
                              ]
    ReportError err -> handleError err
    ResetDevice     -> handleResetDevice
    ClearError      -> do
      modify $ _ { userError = NoError }
      pure $ wrapAction Start
    Nop             -> noEffects

handleResetDevice :: ComponentType Unit LoadingS' Action
handleResetDevice = pure $ [ do
  liftEff $ localStorage.removeItem Key.authData
  pure Start
 ]
updateLoading :: Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoading = liftChild toLoading <<< updateLoading'

updateLoaded :: Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoaded action = case action of
  LoadedA act -> updateLoaded' act
  (ReportError err) -> updateLoaded' (LoadedC.ReportError err)
  _ -> do
       state <- get
       case state of
        LoadedS _ -> pure <<< Just $
                     [ do Gonimo.log "Only LoadedA actions are supported when loaded"
                          pure Nop
                     ]
        _ -> pure Nothing

updateLoaded' :: LoadedC.Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoaded' = map (map (map (map LoadedA))) <<< liftChild toLoaded <<< LoadedC.update

handleInit :: LoadedC.State -> Component Unit State (Maybe (Array (IO Action)))
handleInit ls = do
    state <- get
    case state ^? _LoadingS of
      Nothing -> pure Nothing
      Just loadingS -> do
        let queueEffects = map (pure <<< LoadedA) <<< reverse $ loadingS.actionQueue
        put $ LoadedS ls
        pure <<< Just $ toUnfoldable queueEffects

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

view :: State -> Html Action
view (LoadingS state) = viewLoading state
view (LoadedS state)  = map LoadedA $ LoadedC.view state

viewLoading :: LoadingS' -> Html Action
viewLoading state = case state.userError of
      NoError -> Html.viewLoading "Loading your gonimo, stay tight ..."
      _ -> viewError state

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

load :: (Action -> Eff () Unit) -> IO Action
load sendAction' = Gonimo.toIO initSettings $ authToAction =<< LoadedC.getAuthData
  where
    initSettings = mkSettings $ GonimoSecret (Secret "blabala")

    mkSettings :: AuthToken -> Settings
    mkSettings secret = defaultSettings $ SPParams_ {
          authorization : secret
        , baseURL       : "http://localhost:8081/"
        }

    authToAction :: AuthData -> Gonimo Action
    authToAction (authData@(AuthData auth)) = do
      pure $ Init
            { subscriberUrl : "ws://localhost:8081/subscriber"
            , overviewS         : OverviewC.init
            , socketS       : SocketC.init authData
            , central       : LoadedC.CentralOverview
            , familyIds     : []
            , families      : Map.empty
            , url           : ""
            , onlineDevices : []
            , deviceInfos   : []
            , userError     : NoError
            , sendAction    : lmap LoadedA sendAction'
            }

makeCallback :: forall eff. Channel Action ->  (LoadedC.Action -> SubscriberEff (channel :: CHANNEL | eff) Unit)
makeCallback c = send c <<< LoadedA

makeNotify :: forall eff. Channel Action ->  (Sub.Notification -> SubscriberEff (channel :: CHANNEL | eff) Unit)
makeNotify c = send c <<< LoadedA <<< LoadedC.HandleSubscriber

deploySubscriptions :: IO (Maybe MySubscriber) -> State -> IO Unit
deploySubscriptions _ (LoadingS _) = pure unit
deploySubscriptions getSubscriber (LoadedS s) = do
  let subscriptions = LoadedC.getSubscriptions s
  subscriber <- getSubscriber
  case subscriber of
    Nothing -> Console.log "Not deploying - no subscriber yet!"
    Just subscriber' -> do
      Console.log "Setting pong and close requests ..."
      liftEff $ traverse_ (flip Sub.setPongRequest  (Sub.getConnection subscriber')) $ LoadedC.getPongRequest s
      liftEff $ traverse_ (flip Sub.setCloseRequest (Sub.getConnection subscriber')) $ LoadedC.getCloseRequest s
      liftEff $ Sub.deploy subscriptions subscriber'
      Console.log $ "Deployed " <> show (Sub.size subscriptions) <> " subscriptions!"

-- | Don't use a foldp instead of Ref - you will build up an endless thunk of actions in memory.
renewSubscriber :: Channel Action -> Ref (Maybe MySubscriber)
                   -> State -> IO (Maybe MySubscriber)
renewSubscriber controlChan subscriberRef state = do
    oldSub <- liftEff $ readRef subscriberRef
    let oldUrl = Sub.getUrl <<< Sub.getConnection <$> oldSub
    let newUrl = case state of
          LoadedS lState -> Just lState.subscriberUrl
          _ -> Nothing
    Console.log $ "Old url: " <> show oldUrl
    Console.log $ "New url: " <> show newUrl
    Console.log $ "Is different: " <> show (newUrl /= oldUrl)
    if (newUrl /= oldUrl)
      then do
        Console.log $ "Closing old subscriber ..."
        liftEff $ traverse_ (Sub.close <<< Sub.getConnection) oldSub
        newSub <- traverse makeMySubscriber newUrl
        liftEff $ writeRef subscriberRef newSub
        pure newSub
       else
        pure oldSub
  where
    makeMySubscriber :: String -> IO MySubscriber
    makeMySubscriber url' = do
        map coerceSubscriberEffects <<< liftEff $ Sub.makeSubscriber
                  { url : url'
                  , callback : makeCallback controlChan
                  , notify : makeNotify controlChan
                  }

main = do
  urlSignal <- sampleUrl
  controlChan <- channel Nop
  subscriberRef <- newRef Nothing
  let controlSig = subscribe controlChan
  let routeSignal = map (LoadedA <<< LoadedC.SetURL) urlSignal
  app <- start $
    { initialState: init (coerceEffects <<< send controlChan)
    , update: toPux update
    , view: view
    , inputs: [controlSig, routeSignal]
    }
  -- We have to send Start after the fact, because on merging const signals one gets lost!
  send controlChan Start
  let subscriberSignal = map (renewSubscriber controlChan subscriberRef) app.state
  let subscribeSignal = deploySubscriptions <$> subscriberSignal <*> app.state
  runSignal $ coerceEffects <<< map (const unit) <<< launchAff <<< runIO <$> subscribeSignal
  runSignal $ map (\_ -> Console.log "State changed!") app.state
  runSignal $ Console.log <$> urlSignal
  renderToDOM "#app" app.html
  pure app

debug = do
  urlSignal <- sampleUrl
  controlChan <- channel Nop
  subscriberRef <- newRef Nothing
  let controlSig = subscribe controlChan
  let routeSignal = map (LoadedA <<< LoadedC.SetURL) urlSignal
  app <- Pux.Devtool.start $
    { initialState: init (coerceEffects <<< send controlChan)
    , update: toPux update
    , view: view
    , inputs: [controlSig, routeSignal]
    }
  -- We have to send Start after the fact, because on merging const signals one gets lost!
  send controlChan Start
  let subscriberSignal = map (renewSubscriber controlChan subscriberRef) app.state
  let subscribeSignal = deploySubscriptions <$> subscriberSignal <*> app.state
  runSignal $ coerceEffects <<< map (const unit) <<< launchAff <<< runIO <$> subscribeSignal
  runSignal $ map (\_ -> Console.log "State changed!") app.state
  runSignal $ Console.log <$> urlSignal
  renderToDOM "#app" app.html
  pure app

coerceSubscriberEffects :: forall eff1 eff2 a. Subscriber eff1 a -> Subscriber eff2 a
coerceSubscriberEffects = unsafeCoerce

module Main where

import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Overview as OverviewC
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Loaded as LoadedC
import Gonimo.UI.Loaded.Types as LoadedC
import Gonimo.UI.Socket as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Pux.Html.Attributes as A
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Servant.Subscriber.Subscriptions as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (launchAff, Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Ref (newRef, writeRef, readRef, REF, Ref)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (runIO, IO)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (modify, put, get)
import Data.Array (head)
import Data.Either (Either(Right, Left))
import Data.Foldable (traverse_)
import Data.Generic (gShow)
import Data.Lens (prism', PrismP, (^?))
import Data.List (toUnfoldable, reverse, List(Nil, Cons))
import Data.Maybe (fromMaybe, Maybe(..))
import Data.Profunctor (lmap)
import Data.Traversable (traverse)
import Data.Tuple (fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Router (match, Route(AcceptInvitation, Home))
import Gonimo.Client.Types (toIO, GonimoError, Gonimo, class ReportErrorAction)
import Gonimo.Client.Types (Settings)
import Gonimo.Pux (toPux, noEffects, wrapAction, onlyModify, Update, ComponentType, makeChildData, ToChild, liftChild, Component)
import Gonimo.Server.Types (DeviceType(NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Secret(Secret))
import Gonimo.UI.Error (viewError, handleError, class ErrorAction, UserError(NoError))
import Gonimo.UI.Html as Html
import Gonimo.Util (fromMaybeM, coerceEffects)
import Gonimo.WebAPI (postFunnyName, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (App, renderToDOM, fromSimple, start)
import Pux.Html (text, span, Html, img, div)
import Gonimo.Util (sampleUrl)
import Pux.Devtool (Action, start) as Pux.Devtool
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber, SubscriberEff)
import Servant.Subscriber.Connection (setPongRequest)
import Signal (foldp, map2, runSignal, constant, Signal)
import Signal.Channel (Channel, CHANNEL, send, subscribe, channel)
import Unsafe.Coerce (unsafeCoerce)
import Prelude hiding (div)

data State = LoadingS LoadingS'
           | LoadedS LoadedC.State

_LoadingS :: PrismP State LoadingS'
_LoadingS = prism' LoadingS (\s -> case s of
                                LoadingS x -> Just x
                                _ -> Nothing)

_LoadedS :: PrismP State LoadedC.State
_LoadedS = prism' LoadedS (\s -> case s of
                                LoadedS x -> Just x
                                _ -> Nothing)

type LoadingS' = { actionQueue :: List LoadedC.Action -- | We queue actions until we are loaded.
                 , userError :: UserError
                 , sendAction :: Action -> Eff () Unit
                 }

type LoadedState = {
               authData :: AuthData
             , settings :: Settings
             }

init :: (Action -> Eff () Unit) -> State
init sendAction' = LoadingS { actionQueue : Nil
                            , userError : NoError
                            , sendAction : sendAction'
                            }

data Action = Start
            | Init LoadedC.State
            | ReportError GonimoError
            | LoadedA LoadedC.Action
            | ResetDevice
            | ClearError
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

instance errorActionAction :: ErrorAction Action where
  resetDevice = ResetDevice
  nop = Nop
  clearError = ClearError

type MySubscriber = Subscriber () LoadedC.Action
--------------------------------------------------------------------------------

update :: Update Unit State Action
update action = do
  state <- ( get :: Component Unit State State)
  case action of
    Nop -> noEffects
    Init ls -> fromMaybe [] <$> handleInit ls
    _ -> fromMaybeM (fromMaybe [] <$> updateLoaded action) (updateLoading action)

toLoading :: ToChild Unit State Unit LoadingS'
toLoading = pure $ makeChildData _LoadingS unit

toLoaded :: ToChild Unit State Unit LoadedC.State
toLoaded = pure $ makeChildData _LoadedS unit

updateLoading' ::  Update Unit LoadingS' Action
updateLoading' action = do
  state <- get
  case action of
    Start           -> pure [ load state.sendAction ]
    LoadedA action  -> onlyModify $ \state' -> state' {
                          actionQueue = Cons action state.actionQueue
                        }
    Init ls         -> pure [ do
                                  Gonimo.log "Init command should be handled in toplevel update!"
                                  pure Nop
                              ]
    ReportError err -> handleError err
    ResetDevice     -> handleResetDevice
    ClearError      -> do
      modify $ _ { userError = NoError }
      pure $ wrapAction Start
    Nop             -> noEffects

handleResetDevice :: ComponentType Unit LoadingS' Action
handleResetDevice = pure $ [ do
  liftEff $ localStorage.removeItem Key.authData
  pure Start
 ]
updateLoading :: Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoading = liftChild toLoading <<< updateLoading'

updateLoaded :: Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoaded action = case action of
  LoadedA act -> updateLoaded' act
  (ReportError err) -> updateLoaded' (LoadedC.ReportError err)
  _ -> do
       state <- get
       case state of
        LoadedS _ -> pure <<< Just $
                     [ do Gonimo.log "Only LoadedA actions are supported when loaded"
                          pure Nop
                     ]
        _ -> pure Nothing

updateLoaded' :: LoadedC.Action -> Component Unit State (Maybe (Array (IO Action)))
updateLoaded' = map (map (map (map LoadedA))) <<< liftChild toLoaded <<< LoadedC.update

handleInit :: LoadedC.State -> Component Unit State (Maybe (Array (IO Action)))
handleInit ls = do
    state <- get
    case state ^? _LoadingS of
      Nothing -> pure Nothing
      Just loadingS -> do
        let queueEffects = map (pure <<< LoadedA) <<< reverse $ loadingS.actionQueue
        put $ LoadedS ls
        pure <<< Just $ toUnfoldable queueEffects

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

view :: State -> Html Action
view (LoadingS state) = viewLoading state
view (LoadedS state)  = map LoadedA $ LoadedC.view state

viewLoading :: LoadingS' -> Html Action
viewLoading state = case state.userError of
      NoError -> Html.viewLoading "Loading your gonimo, stay tight ..."
      _ -> viewError state

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

load :: (Action -> Eff () Unit) -> IO Action
load sendAction' = Gonimo.toIO initSettings $ authToAction =<< LoadedC.getAuthData
  where
    initSettings = mkSettings $ GonimoSecret (Secret "blabala")

    mkSettings :: AuthToken -> Settings
    mkSettings secret = defaultSettings $ SPParams_ {
          authorization : secret
        , baseURL       : "http://localhost:8081/"
        }

    authToAction :: AuthData -> Gonimo Action
    authToAction (authData@(AuthData auth)) = do
      pure $ Init
            { subscriberUrl : "ws://localhost:8081/subscriber"
            , overviewS         : OverviewC.init
            , socketS       : SocketC.init authData
            , central       : LoadedC.CentralOverview
            , familyIds     : []
            , families      : Map.empty
            , url           : ""
            , onlineDevices : []
            , deviceInfos   : []
            , userError     : NoError
            , sendAction    : lmap LoadedA sendAction'
            }

makeCallback :: forall eff. Channel Action ->  (LoadedC.Action -> SubscriberEff (channel :: CHANNEL | eff) Unit)
makeCallback c = send c <<< LoadedA

makeNotify :: forall eff. Channel Action ->  (Sub.Notification -> SubscriberEff (channel :: CHANNEL | eff) Unit)
makeNotify c = send c <<< LoadedA <<< LoadedC.HandleSubscriber

deploySubscriptions :: IO (Maybe MySubscriber) -> State -> IO Unit
deploySubscriptions _ (LoadingS _) = pure unit
deploySubscriptions getSubscriber (LoadedS s) = do
  let subscriptions = LoadedC.getSubscriptions s
  subscriber <- getSubscriber
  case subscriber of
    Nothing -> Console.log "Not deploying - no subscriber yet!"
    Just subscriber' -> do
      Console.log "Setting pong and close requests ..."
      liftEff $ traverse_ (flip Sub.setPongRequest  (Sub.getConnection subscriber')) $ LoadedC.getPongRequest s
      liftEff $ traverse_ (flip Sub.setCloseRequest (Sub.getConnection subscriber')) $ LoadedC.getCloseRequest s
      Console.log $ "Deploying " <> show (Sub.size subscriptions) <> " subscriptions!"
      liftEff $ Sub.deploy subscriptions subscriber'
      Console.log $ "Deployed " <> show (Sub.size subscriptions) <> " subscriptions!"

-- | Don't use a foldp instead of Ref - you will build up an endless thunk of actions in memory.
renewSubscriber :: Channel Action -> Ref (Maybe MySubscriber)
                   -> State -> IO (Maybe MySubscriber)
renewSubscriber controlChan subscriberRef state = do
    oldSub <- liftEff $ readRef subscriberRef
    let oldUrl = Sub.getUrl <<< Sub.getConnection <$> oldSub
    let newUrl = case state of
          LoadedS lState -> Just lState.subscriberUrl
          _ -> Nothing
    Console.log $ "Old url: " <> show oldUrl
    Console.log $ "New url: " <> show newUrl
    Console.log $ "Is different: " <> show (newUrl /= oldUrl)
    if (newUrl /= oldUrl)
      then do
        Console.log $ "Closing old subscriber ..."
        liftEff $ traverse_ (Sub.close <<< Sub.getConnection) oldSub
        newSub <- traverse makeMySubscriber newUrl
        liftEff $ writeRef subscriberRef newSub
        pure newSub
       else
        pure oldSub
  where
    makeMySubscriber :: String -> IO MySubscriber
    makeMySubscriber url' = do
        map coerceSubscriberEffects <<< liftEff $ Sub.makeSubscriber
                  { url : url'
                  , callback : makeCallback controlChan
                  , notify : makeNotify controlChan
                  }

main = do
  urlSignal <- sampleUrl
  controlChan <- channel Nop
  subscriberRef <- newRef Nothing
  let controlSig = subscribe controlChan
  let routeSignal = map (LoadedA <<< LoadedC.SetURL) urlSignal
  app <- start $
    { initialState: init (coerceEffects <<< send controlChan)
    , update: toPux update
    , view: view
    , inputs: [controlSig, routeSignal]
    }
  -- We have to send Start after the fact, because on merging const signals one gets lost!
  send controlChan Start
  let subscriberSignal = map (renewSubscriber controlChan subscriberRef) app.state
  let subscribeSignal = deploySubscriptions <$> subscriberSignal <*> app.state
  runSignal $ coerceEffects <<< map (const unit) <<< launchAff <<< runIO <$> subscribeSignal
  runSignal $ map (\_ -> Console.log "State changed!") app.state
  runSignal $ Console.log <$> urlSignal
  renderToDOM "#app" app.html
  pure app

debug = do
  urlSignal <- sampleUrl
  controlChan <- channel Nop
  subscriberRef <- newRef Nothing
  let controlSig = subscribe controlChan
  let routeSignal = map (LoadedA <<< LoadedC.SetURL) urlSignal
  app <- Pux.Devtool.start $
    { initialState: init (coerceEffects <<< send controlChan)
    , update: toPux update
    , view: view
    , inputs: [controlSig, routeSignal]
    }
  -- We have to send Start after the fact, because on merging const signals one gets lost!
  send controlChan Start
  let subscriberSignal = map (renewSubscriber controlChan subscriberRef) app.state
  let subscribeSignal = deploySubscriptions <$> subscriberSignal <*> app.state
  runSignal $ coerceEffects <<< map (const unit) <<< launchAff <<< runIO <$> subscribeSignal
  runSignal $ map (\_ -> Console.log "State changed!") app.state
  runSignal $ Console.log <$> urlSignal
  renderToDOM "#app" app.html
  pure app

coerceSubscriberEffects :: forall eff1 eff2 a. Subscriber eff1 a -> Subscriber eff2 a
coerceSubscriberEffects = unsafeCoerce


We dropped some errors at gonimo-back

We dropped some errors at gonimo-back

-- File auto generated by purescript-bridge! --
module Gonimo.Server.Error where

import Gonimo.Server.DbEntities (Family)
import Gonimo.Types (Key)

import Data.Generic (class Generic)

data ServerError =
    InvalidAuthToken
  | InvitationAlreadyClaimed
  | AlreadyFamilyMember
  | NoSuchFamily (Key Family)
  | NoSuchInvitation
  | NoSuchSocket
  | Forbidden
  | NotFound
  | TransactionTimeout

derive instance genericServerError :: Generic ServerError

-- File auto generated by purescript-bridge! --
module Gonimo.Server.Error where

import Gonimo.Server.DbEntities (Family)
import Gonimo.Types (Key)

import Data.Generic (class Generic)

data ServerError =
    InvalidAuthToken
  | InvitationAlreadyClaimed
  | AlreadyFamilyMember
  | NoSuchFamily (Key Family)
  | NoSuchInvitation
  | NoSuchSocket
  | Forbidden
  | NotFound
  | NoDataAvailable
  | NoNewChannel
  | TransactionTimeout
  | NotPossible

derive instance genericServerError :: Generic ServerError


Wrote Show and EnocodeJson instances for Credits and Habit.

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/gcross/habit-of-fate.git/'